home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1988 / 06_07 / ascii / ascii.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-03-24  |  6.7 KB  |  197 lines
  1. (* ----------------------------------------------------- *)
  2. (*                ASCII.PAS  (v1.0)                      *)
  3. (*                                                       *)
  4. (*    Eingabe von beliebigen ASCII-Zeichen durch         *)
  5. (*    Cursortasten-Anwahl.                               *)
  6. (*        TSR-Routine unter Turbo Pascal 4.0             *)
  7. (*                                                       *)
  8. (* (c) 1988  Karsten Gieselmann  &  PASCAL International *)
  9. (*                                                       *)
  10. (* ----------------------------------------------------- *)
  11.  
  12. {$R-,S-,I-,V-,B-}      (* größtmögliche Geschwindigkeit! *)
  13. {$M 1024,0,0}          (* wenig Stack, kein Heap!        *)
  14.  
  15. Uses  TSR, Crt;                       (* benötigte Units *)
  16.  
  17. Type  ScreenType = Array [1..25,1..80] of Word;
  18.  
  19. Const Version    = 'ASCII v1.0';
  20.       Hotkey     = $6D00;
  21.                        (* Aktivierungstaste hier: Alt-F6 *)
  22.       HotkeyName = 'Alt-F6';
  23.       MaxRow     = 22;      (* Ausmaße der ASCII-Tabelle *)
  24.       MaxCol     = 35;
  25.                             (* Farbe für....             *)
  26.       Normal = $07;         (* ....normale Zeichen       *)
  27.       Select = $DF;         (* ....das gewählte Zeichen  *)
  28.       Help   = $1F;         (* ....die beiden Infozeilen *)
  29.       Frame  = $0F;         (* ....den Fensterrahmen     *)
  30.  
  31. Var   Code       :Byte;
  32.       Table      :Array [1..MaxRow,1..MaxCol] of Word;
  33.       Screen     :^ScreenType;
  34.       SaveScreen :ScreenType;
  35.       VideoMode  :Byte absolute $0040:$0049;
  36.                                  (* aktueller Videomodus *)
  37.  
  38.  
  39. (* - baut die ASCII-Tabelle im WORD-ARRAY "Table" auf -- *)
  40.  
  41. Procedure BuildTable;
  42.  
  43. Const UpperLeft = #218;  Horizontal = #196;
  44.       UpperRight = #191; LowerLeft = #192;
  45.       Vertical   = #179;  LowerRight = #217;
  46.  
  47.       Upper   :String[33] =
  48.                        '     Anwahl mit Cursortasten     ';
  49.       Lower   :String[33] =
  50.                        '   Übernahme mit (Ctrl-)Return   ';
  51.  
  52. Var   Row,Col :Byte;               (* Schleifenvariablen *)
  53.  
  54.  
  55.   Procedure SetTable (Col,Row,Attr :Byte; Code :Char);
  56.  
  57. (* besetzt die Position <Col,Row> von des WORD-ARRAYs    *)
  58. (* "Table" mit dem Zeichen "Code" in der Hintergrund/    *)
  59. (* Vordergrundfarbe "Attr"                               *)
  60.  
  61.     Begin
  62.       Table [Row,Col] := Word(Attr)*256 + Ord(Code)
  63.     End;
  64.  
  65. Begin                                 (* Rahmen aufbauen *)
  66.   SetTable (     1,     1, Frame, UpperLeft);
  67.   SetTable (MaxCol,     1, Frame, UpperRight);
  68.   SetTable (     1,MaxRow, Frame, LowerLeft);
  69.   SetTable (MaxCol,MaxRow, Frame, LowerRight);
  70.   For Col:=2 to MaxCol-1 do Begin
  71.     SetTable (Col,     1,   Frame, Horizontal);
  72.     SetTable (Col,MaxRow,   Frame, Horizontal);
  73.     SetTable (Col,       2, Help,  Upper[Col-1]);
  74.                                            (* Hilfstexte *)
  75.     SetTable (Col,MaxRow-1, Help,  Lower[Col-1]);
  76.   End;
  77.   For Row:=2 to MaxRow-1 do Begin
  78.     SetTable (     1,Row, Frame, Vertical);
  79.     SetTable (MaxCol,Row, Frame, Vertical);
  80.   End;
  81.   For Row:=3 to MaxRow-2 do   (* Tabelleninneres löschen *)
  82.     For Col:=2 to MaxCol-1 do
  83.       SetTable (Col,Row, Normal, ' ');
  84.   For Row:=0 to 15 do         (* ASCII-Zeichen eintragen *)
  85.     For Col:=0 to 15 do
  86.       SetTable (Col*2+3, Row+4, Normal, Chr(Row*16+Col));
  87.   End;
  88.  
  89.  
  90. (* das PopUp-Programm...                                 *)
  91. (* ... muß im FAR-Modell compiliert werden! ------------ *)
  92.  
  93. {$F+}
  94.  
  95. Procedure ASCII_Table;
  96.  
  97. Const XWin   =  46;
  98.       YWin   =   1;
  99.                    (* linke obere Ecke der ASCII-Tabelle *)
  100.  
  101.       Left    = #$CB;  Right   = #$CD;  Up     = #$C8;
  102.       Down    = #$D0;  Home    = #$C7;  End_   = #$CF;
  103.       PgUp    = #$C9;  PgDn    = #$D1;  Return = #$0D;
  104.       CtrlRet = #$0A;  Esc     = #$1B;
  105.  
  106. Var   Row,Col,Save :Byte;
  107.       Command      :Char;
  108.  
  109.   Procedure WriteToKbdBuffer (ScanCode :Word);
  110.  
  111.              (* legt "ScanCode" im DOS-Tastaturpuffer ab *)
  112.  
  113.   Var   KbdHead   :Word absolute $0040:$001A;
  114.         KbdTail   :Word absolute $0040:$001C;
  115.         KbdBuffer :Array [$1E..$3C] of
  116.                    Byte absolute $0040:$001E;
  117.  
  118.   Begin
  119.     KbdBuffer[KbdTail]   := Lo(ScanCode);
  120.     KbdBuffer[KbdTail+1] := Hi(ScanCode);
  121.     Inc (KbdTail, 2);
  122.     If KbdTail > $003C then
  123.       KbdTail := $001E
  124.     End;
  125.  
  126.   Procedure GetKey (Var Key :Char);
  127.  
  128. (* holt Tastencode; bei erweiterten Tasten (z.B.        *)
  129. (* Funktions- oder Cursortasten, erster Code ist Null-  *)
  130. (* zeichen) wird das 8.Bit im Code gesetzt;             *)
  131. (* für Turbo 3.0 weicht der Programmtext etwas von dem  *)
  132. (* unteren ab:
  133.  
  134.           Read (Kbd, Key);
  135.           If (Key = Esc) and KeyPressed then
  136.              Begin
  137.              Read (Kbd, Key);
  138.              Key := Chr (Ord(Key) or $80)
  139.              End                                        *)
  140.  
  141.   Begin
  142.     Key := ReadKey;
  143.     If Key = #0 then               (* erweiterter Code? *)
  144.       Key := Chr (Ord(ReadKey) or $80)
  145.     End;
  146.  
  147. Begin                             (* Bildschirm sichern *)
  148.   Move (Screen^, SaveScreen, SizeOf(ScreenType));
  149.   For Row:=1 to MaxRow do
  150.     Move (Table[Row], Screen^[YWin+Row-1,XWin], MaxCol*2);
  151.   Save := 0;
  152.   Repeat
  153.     Col := XWin + (Code mod 16 + 1)*2;
  154.     Row := YWin + (Code shr  4 + 3);
  155.     Screen^[Row,Col] := Word(Select)*256 + Code;
  156.                                    (* Zeichen markieren *)
  157.     Save := Code;
  158.     GetKey (Command);         (* auf Kommando warten... *)
  159.     Case Command of
  160.       Left:   Dec (Code);
  161.       Right:  Inc (Code);
  162.       Up:     Dec (Code, 16);
  163.       Down:   Inc (Code, 16);
  164.       Home:   Code := (Code shr 4) shl 4;
  165.       End_:   Code := (Code shr 4) shl 4 + 15;
  166.       PgUp:   Code :=  Code mod 16;
  167.       PgDn:   Code :=  Code mod 16 + 240;
  168.     End;
  169.     Screen^[Row,Col] := Word(Normal)*256 + Save;
  170.   until Command in [Esc,Return,CtrlRet];
  171.   If Command = CtrlRet then Begin
  172.     WriteToKbdBuffer (Word (Code));
  173.     WriteToKbdBuffer (Hotkey); End
  174.   else
  175.     If Command = Return then
  176.       WriteToKbdBuffer (Word (Code));
  177.   Move (SaveScreen, Screen^, SizeOf(ScreenType));
  178.                                   (* Schirm restaurieren *)
  179. End;
  180.  
  181. {$F-}
  182.  
  183. (* --------- der Installationsteil von ASCII ----------- *)
  184.  
  185. Begin
  186.   If VideoMode = 7 then
  187.     Screen := Ptr ($B000,$0000)  (* Monochrome, Hercules *)
  188.   else
  189.     Screen := Ptr ($B800,$0000);   (* Farbgrafik-Adapter *)
  190.   BuildTable;
  191.   Code := 224;              (* erstes markiertes Zeichen *)
  192.   WriteLn (^M^J, Version, ' installiert,',
  193.            ^M^J'aktivieren mit ', HotKeyName, '.');
  194.   MakeResident (@Ascii_Table , Hotkey)
  195. End.
  196. (* ----------------------------------------------------- *)
  197. (*                 Ende von ASCII.PAS                    *)