home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1990 / 06 / tricks / g_tast.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-05-29  |  7.2 KB  |  279 lines
  1. (* ------------------------------------------------------ *)
  2. (*                     G-TAST.PAS                         *)
  3. (*            gra-tas: Grafikzeichen einfach              *)
  4. (*             (c) 1990 H.Zenz & TOOLBOX                  *)
  5. (* ------------------------------------------------------ *)
  6. {$R-,S-,I-,D-,F+,V-,B-,N-,L+}
  7. {$M 1024,0,0}
  8. PROGRAM gra_tas;
  9.  
  10. USES Crt, Dos;
  11.  
  12. CONST
  13.   version = '1.1';
  14.   farbvor = WHITE;
  15.   farbhin = RED;
  16.  
  17. VAR
  18.   Screen        : ARRAY [1..80, 1..25] OF WORD;
  19.   OldInt16      : POINTER;
  20.   OldSS, OldSP,
  21.   NewSS, NewSP  : WORD;
  22.   work          : BOOLEAN;
  23.   elo, obe, ero,
  24.   lnk, rct, elu,
  25.   unt, eru, krz,
  26.   hrz, vrk      : WORD;
  27.   x, y, xc, yc  : WORD;
  28.   HotKey        : WORD;
  29.   get           : WORD;
  30.  
  31.   PROCEDURE Store_Scr;
  32.   BEGIN
  33.     Move(Mem[$B800:0000], Screen, 4000);
  34.   END;
  35.  
  36.   PROCEDURE Load_Scr;
  37.   BEGIN
  38.     Move(Screen, Mem[$b800:0000], 4000);
  39.   END;
  40.  
  41.   FUNCTION GetHotkey : WORD;
  42.   VAR
  43.     Regs : Registers;
  44.   BEGIN
  45.     WITH Regs DO BEGIN
  46.       REPEAT UNTIL KeyPressed;
  47.       ah := 0;
  48.       Intr($16, Regs);
  49.       GetHotkey := ax;
  50.     END;
  51.   END;
  52.  
  53.   PROCEDURE ShowHelp(vor, hinten : WORD);
  54.   BEGIN
  55.     Window(x, y, x+13, y+10);
  56.     TextBackGround(hinten);
  57.     TextColor(vor);
  58.     ClrScr;
  59.     Window(x, y, x+13, y+11);
  60.     GotoXY(1,1); Write('┌────────────┐');
  61.     GotoXY(1,2); Write('│    8      ', Chr(hrz),'│');
  62.     GotoXY(1,3); Write('│7', Chr(elo), '  ', Chr(obe), '  ',
  63.                        Chr(ero), '9  -│');
  64.     GotoXY(1,4); Write('│           ', chr(vrk),'│');
  65.     GotoXY(1,5); Write('│           +│');
  66.     GotoXY(1,6); Write('│4', Chr(lnk), '  ', Chr(krz), '  ',
  67.                        Chr(rct), '6   │');
  68.     GotoXY(1,7); Write('│    5       │');
  69.     GotoXY(1,8); Write('│            │');
  70.     GotoXY(1,9); Write('│1', Chr(elu), '  ', Chr(unt), '  ',
  71.                        Chr(eru), '3   │');
  72.     GotoXY(1,10);Write('│    2       │');
  73.     GotoXY(1,11);Write('└────────────┘');
  74.     Window(1, 1, 80, 25);
  75.     GotoXY(xc,yc);
  76.   END;
  77.  
  78.   PROCEDURE Set1;
  79.   BEGIN
  80.     elo := 218; obe := 194; ero := 191; lnk := 195;
  81.     krz := 197; rct := 180; elu := 192; unt := 193;
  82.     eru := 217; hrz := 196; vrk := 179;
  83.   END;
  84.  
  85.   PROCEDURE Set2;
  86.   BEGIN
  87.     elo := 201; obe := 203; ero := 187; lnk := 204;
  88.     krz := 206; rct := 185; elu := 200; unt := 202;
  89.     eru := 188; hrz := 205; vrk := 186;
  90.   END;
  91.  
  92.   PROCEDURE Set3;
  93.   BEGIN
  94.     elo := 214; obe := 210; ero := 183; lnk := 199;
  95.     krz := 215; rct := 182; elu := 211; unt := 208;
  96.     eru := 189; hrz := 196; vrk := 186;
  97.   END;
  98.  
  99.   PROCEDURE Set4;
  100.   BEGIN
  101.     elo := 213; obe := 209; ero := 184; lnk := 198;
  102.     krz := 216; rct := 181; elu := 212; unt := 207;
  103.     eru := 190; hrz := 205; vrk := 179;
  104.   END;
  105.  
  106.   PROCEDURE Set5;
  107.   BEGIN
  108.     elo := 176; obe := 223; ero := 177; lnk := 221;
  109.     krz := 248; rct := 222; elu := 178; unt := 220;
  110.     eru := 219; hrz := 249; vrk := 250;
  111.   END;
  112.  
  113.   PROCEDURE Move_Window;
  114.   VAR
  115.     c : CHAR;
  116.   BEGIN
  117.     ShowHelp(farbhin, farbvor);
  118.     REPEAT
  119.       c := ReadKey;
  120.       Load_Scr;
  121.       CASE c OF
  122.         '4' : x := x - 1;
  123.         '6' : x := x + 1;
  124.         '2' : y := y + 1;
  125.         '8' : y := y - 1;
  126.       END;
  127.       IF x < 1  THEN x := 1;
  128.       IF y < 1  THEN y := 1;
  129.       IF x > 67 THEN x := 67;
  130.       IF y > 14 THEN y := 14;
  131.       ShowHelp(farbhin, farbvor);
  132.     UNTIL ((c = #27) OR (c = '.'));
  133.     ShowHelp(farbvor, farbhin);
  134.   END;
  135.  
  136.   PROCEDURE StoreKey(taste : WORD);
  137.   VAR
  138.     KeyBuff : ARRAY [$1e..$3c] OF BYTE ABSOLUTE $0040:$001e;
  139.     KeyEnd  : WORD ABSOLUTE $0040:$001c;
  140.   BEGIN
  141.     Move(taste, KeyBuff[KeyEnd], 2);
  142.     Inc(KeyEnd, 2);
  143.     IF KeyEnd > $003c Then KeyEnd := $001e;
  144.   END;
  145.  
  146.   PROCEDURE GrafTaste;
  147.   VAR
  148.     ready : BOOLEAN;
  149.     c     : WORD;
  150.   BEGIN
  151.     Store_Scr;
  152.     xc := WhereX; yc := WhereY;
  153.     ready := FALSE;
  154.     Mem[0:$417] := Mem[0:$417] OR 32;      (* numlock ein *)
  155.     REPEAT
  156.       ShowHelp(farbvor, farbhin);
  157.       c := GetHotKey;
  158.       CASE c OF
  159.         $4f31 : BEGIN
  160.                   StoreKey(elu);
  161.                   StoreKey(HotKey);
  162.                   ready := TRUE;
  163.                 END;
  164.         $5032 : BEGIN
  165.                   StoreKey(unt);
  166.                   StoreKey(hotkey);
  167.                   ready := TRUE;
  168.                 END;
  169.         $5133 : BEGIN
  170.                   StoreKey(eru);
  171.                   StoreKey(HotKey);
  172.                   ready := TRUE;
  173.                 END;
  174.         $4b34 : BEGIN
  175.                   StoreKey(lnk);
  176.                   StoreKey(HotKey);
  177.                   ready := TRUE;
  178.                 END;
  179.         $4c35 : BEGIN
  180.                   StoreKey(krz);
  181.                   StoreKey(HotKey);
  182.                   ready := TRUE;
  183.                 END;
  184.         $4d36 : BEGIN
  185.                   StoreKey(rct);
  186.                   StoreKey(HotKey);
  187.                   ready := true end;
  188.         $4737 : BEGIN
  189.                   StoreKey(elo);
  190.                   StoreKey(HotKey);
  191.                   ready := TRUE;
  192.                 END;
  193.         $4838 : BEGIN
  194.                   StoreKey(obe);
  195.                   StoreKey(HotKey);
  196.                   ready := TRUE;
  197.                 END;
  198.         $4939 : BEGIN
  199.                   StoreKey(ero);
  200.                   StoreKey(HotKey);
  201.                   ready := TRUE;
  202.                 END;
  203.         $4e2b : BEGIN
  204.                   StoreKey(vrk);
  205.                   StoreKey(HotKey);
  206.                   ready := TRUE;
  207.                 END;
  208.         $4a2d : BEGIN
  209.                   StoreKey(hrz);
  210.                   StoreKey(HotKey);
  211.                   ready := TRUE;
  212.                 END;
  213.         $3b00 : Set1;
  214.         $3c00 : Set2;
  215.         $3d00 : Set3;
  216.         $3e00 : Set4;
  217.         $3f00 : Set5;
  218.         $011b : ready := TRUE;
  219.         $532e : Move_Window;
  220.       ELSE
  221.         BEGIN
  222.           StoreKey(c);
  223.           StoreKey(HotKey);
  224.           ready := TRUE;
  225.         END;
  226.       END;
  227.     UNTIL (ready = TRUE);
  228.     Mem[0:$417] := Mem[0:$417] AND 223;   (* numlock aus *)
  229.     Load_Scr;
  230.   END;
  231.  
  232.   PROCEDURE NewInt16(flags, cs, ip, ax, bx, cx, dx,
  233.                      si, di, ds, es, bp : WORD); INTERRUPT;
  234.  
  235.     PROCEDURE NewStack;
  236.     INLINE ($8c/$16/OldSS/$89/$26/OldSP/$fa/
  237.             $8e/$16/NewSS/$8b/$26/NewSP/$fb);
  238.  
  239.     PROCEDURE OldStack;
  240.     INLINE ($fa/$8e/$16/OldSS/$8b/$26/OldSP/$fb);
  241.  
  242.     PROCEDURE ExecInt(adress : POINTER);
  243.     INLINE ($5b/$58/$87/$5e/$0e/$87/$46/$10/$89/
  244.             $ec/$5d/$07/$1f/$5f/$5e/$5a/$59/$cb);
  245.  
  246.     FUNCTION GetKey : WORD;
  247.     INLINE ($31/$c0/$9c/$ff/$1e/oldint16);
  248.  
  249.   BEGIN
  250.     IF (Hi(ax) = 0) THEN BEGIN
  251.       ax := GetKey;
  252.       IF ((ax = HotKey) AND (work = FALSE)) THEN BEGIN
  253.         NewStack;
  254.         work := TRUE;
  255.         GrafTaste;
  256.         work := FALSE;
  257.         OldStack;
  258.       END;
  259.     END ELSE
  260.       ExecInt(oldint16);
  261.   END;
  262.  
  263. BEGIN
  264.   NewSS := SSeg;
  265.   NewSP := SPtr;
  266.   WriteLn(version);
  267.   WriteLn('Bitte drücken Sie den Hotkey zum Aktivieren');
  268.   HotKey := GetHotKey;
  269.   x := 1;  y := 1;
  270.   Set1;
  271.   work := FALSE;
  272.   GetIntVec($16, OldInt16);
  273.   SetIntVec($16, @NewInt16);
  274.   SetIntVec($1b, SaveInt1b);
  275.   Keep(0);
  276. END.
  277. (* ------------------------------------------------------ *)
  278. (*               Ende von G-TAST.PAS                      *)
  279.