home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1991 / 01 / zoomer / zoomer.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-10-10  |  14.2 KB  |  415 lines
  1. (* ------------------------------------------------------ *)
  2. (*                       ZOOMER.PAS                       *)
  3. (*   Speicherresidente Zeichenlupe für Turbo Pascal 5.5   *)
  4. (*             (c) 1990 Gerd Arnold & TOOLBOX             *)
  5. (* ------------------------------------------------------ *)
  6.  
  7. {$B-,D-,F-,I-,O-,R-,S-,V-}            { alle Prüfungen aus }
  8. {$M 1024,0,655360}  { wenig Stack, Heap durch TSR begrenzt }
  9.  
  10. PROGRAM Zoomer;
  11.  
  12. USES TSR, Crt, DOS;
  13.  
  14. CONST
  15.   WinMaxHoehe = 10;                    { Höhe des Fensters }
  16. TYPE
  17.   ZeichenTyp  = ARRAY[0..7] OF BYTE;         { 8x8-Zeichen }
  18.   FensterType = ARRAY[1..WinMaxHoehe, 1..80] OF WORD;
  19.   ScreenType  = ARRAY[1..25, 1..80] OF WORD;
  20.   CHARSET     = SET OF CHAR;
  21. CONST
  22.   ZoomID                   = 11;              { Kennziffer }
  23.   Programm                 = 'ZOOMER 1.1';  { Programmname }
  24.   Hotkey                   = $6800;  { Aktivierung: Alt-F1 }
  25.   HotkeyName               = 'Alt-F1';
  26.   MaxPosition              = 6;  { Anzahl Windowpositionen }
  27.   LetterBreite             = 9; { bestimmt Größe der Lücke }
  28.   Rechts      : BYTE       = 80;            { rechter Rand }
  29.   Unten       : BYTE       = 25;            { unterer Rand }
  30.   AnzLetter   : BYTE       = 5;    { Buchstaben im Fenster }
  31.   Position    : BYTE       = 1;          { Fensterposition }
  32.   Lesbar      : CHARSET    =             { Lesbare Zeichen }
  33.     [#48..#57, #65..#90, #97..#122, #128..#165, #128..#165];
  34. VAR
  35.   WinX1, WinX2, WinY1, WinY2, CurX, CurY, CurXAlt, CurYAlt,
  36.   WinBreite          : BYTE;         { Breite des Fensters }
  37.   Fenster            : FensterType;
  38.   Screen             : ^ScreenType; { Pointer auf Grafiksp.}
  39.   Passage, Begriff   : STRING[10];           { Suchbegriff }
  40.   DrawNeu, Abbruch   : BOOLEAN;      { Flag: neu zeichnen? }
  41.   NormAttr, FindAttr : BYTE;        { Attribute für Window }
  42. CONST
  43.   Zeichen: ARRAY[0..255] OF ZeichenTyp =
  44. { Hier wird der mit Hilfe von "MAKECHAR.PAS" erzeugte 8x8-
  45.   Zeichensatz aus der Datei "ZSATZ.INC" eingebunden!       }
  46. {$I ZSATZ.INC}
  47.  
  48. PROCEDURE Pieps;                                  { Pieps! }
  49. BEGIN
  50.   Sound(800); Delay(100); NoSound;
  51. END;
  52.  
  53. PROCEDURE GetMode;  { Adresse Bildschirmspeicher ermitteln }
  54. VAR R : Registers;
  55. BEGIN
  56.   R.AH := $0F; Intr($10, R);
  57.   IF NOT (R.AL IN [2, 3, 7]) THEN BEGIN { 80x25-Textmodus? }
  58.     Pieps; Abbruch := TRUE;                        { Nein! }
  59.     Exit;                                     { Abbruch... }
  60.   END;
  61.   IF (MEM[0000:1040] AND 48) <> 48 THEN BEGIN
  62.     Screen := Ptr ($B800, $0000);             { Farbgrafik }
  63.     NormAttr := White OR BLACK SHL 4;
  64.     FindAttr := LightGreen OR BLACK SHL 4;
  65.   END ELSE BEGIN
  66.     Screen := Ptr ($B000, $0000);               { Hercules }
  67.     NormAttr := 7;
  68.     FindAttr := 15;
  69.   END;
  70. END;
  71.  
  72. PROCEDURE WriteAt(x, y : BYTE; ch : CHAR; Attr : BYTE);
  73.    { schreibt ein Zeichen direkt in den Bildschirmspeicher }
  74. BEGIN
  75.   Screen^[y, x] := WORD(Ord(ch) OR (Attr SHL 8));
  76. END;
  77.  
  78. FUNCTION UpChar(ch : CHAR) : CHAR; { verbessertes "UpCase" }
  79. BEGIN
  80.   CASE ch OF
  81.     'ä'      : UpChar := 'Ä';           { deutsche Umlaute }
  82.     'ö'      : UpChar := 'Ö';           { berücksichtigen  }
  83.     'ü'      : UpChar := 'Ü';
  84.   ELSE         UpChar := UpCase(ch); END;
  85. END;
  86.  
  87. PROCEDURE GetPosition(VAR x, y : BYTE);
  88. BEGIN                      { Position für Window ermitteln }
  89.   CASE Position OF
  90.     1: BEGIN
  91.          x := 1; y := 1;
  92.        END;
  93.     2: BEGIN
  94.          x := 1; y := (Unten - WinMaxHoehe) DIV 2 + 1;
  95.        END;
  96.     3: BEGIN
  97.          x := 1; y := Unten - WinMaxHoehe + 1;
  98.        END;
  99.     4: BEGIN
  100.          x := Rechts - AnzLetter * LetterBreite - 2; y := 1;
  101.        END;
  102.     5: BEGIN
  103.          x := Rechts - AnzLetter * LetterBreite - 2;
  104.          y := (Unten - WinMaxHoehe) DIV 2 + 1;
  105.        END;
  106.     6: BEGIN
  107.          x := Rechts - AnzLetter * LetterBreite - 2;
  108.          y := Unten - WinMaxHoehe + 1;
  109.        END;
  110.   END;
  111. END;
  112.  
  113. PROCEDURE MakeWindow(Attr : BYTE);      { Fenster erzeugen }
  114. VAR x, y : BYTE;
  115. CONST
  116.   EckLO = #201;   EckRO = #187;       { Blockgrafikzeichen }
  117.   EckLU = #200;   EckRU = #188;       { für doppelten      }
  118.   Horiz = #205;   Vert  = #186;       { Rahmen um Window   }
  119. BEGIN
  120.   Dec(Position);
  121.   REPEAT           { gültige Position für Window ermitteln }
  122.     Inc(Position);
  123.     IF Position > MaxPosition THEN Position := 1;
  124.     GetPosition(WinX1, WinY1);
  125.     WinX2 := WinX1 + 2 + LetterBreite * AnzLetter;
  126.     WinY2 := WinY1 + WinMaxHoehe - 1;
  127.     WinBreite := (WinX2 - WinX1 + 1) * 2;
  128.   UNTIL NOT (CurY IN [WinY1..WinY2]);
  129.   FOR y := WinY1 TO WinY2 DO BEGIN   { Hintergrund sichern }
  130.     Move(Screen^ [y, WinX1],
  131.       Fenster[y - WinY1+1] , WinBreite);
  132.     FillChar(SCREEN^ [y, WinX1], WinBreite, 0);  { löschen }
  133.   END;
  134.   FOR x:=Succ(WinX1) TO Pred(WinX2) DO BEGIN
  135.     WriteAt(x, WinY1, Horiz, Attr);      { Rahmen zeichnen }
  136.     WriteAt(x, WinY2, Horiz, Attr);
  137.   END;
  138.   FOR x:=Succ(WinY1) TO Pred(WinY2) DO BEGIN
  139.     WriteAt(WinX1, x, Vert, Attr);
  140.     WriteAt(WinX2, x, Vert, Attr);
  141.   END;
  142.   WriteAt(WinX1, WinY1, EckLO, Attr);
  143.   WriteAt(WinX2, WinY1, EckRO, Attr);
  144.   WriteAt(WinX1, WinY2, EckLU, Attr);
  145.   WriteAt(WinX2, WinY2, EckRU, Attr);
  146. END;
  147.  
  148. PROCEDURE RestoreWindow;        { Hintergrund restaurieren }
  149. VAR y : BYTE;
  150. BEGIN
  151.   FOR y := WinY1 TO WinY2 DO
  152.     Move(Fenster[y - WinY1 + 1],
  153.          Screen^ [y, WinX1], WinBreite);
  154. END;
  155.  
  156. FUNCTION GetChar(x, y : BYTE) : CHAR;
  157. BEGIN                    { Zeichen vom Bildschirm einlesen }
  158.   IF x <= Rechts THEN GetChar := CHAR(Screen^[y, x])
  159.   ELSE GetChar := #32;
  160. END;
  161.  
  162. PROCEDURE WriteLetter(Letter: CHAR; Posi, Attr: BYTE);
  163. VAR                        { Vergrößertes Zeichen anzeigen }
  164.   ASCII, xPos, x, y : BYTE;
  165. CONST
  166.   Bits: ARRAY[0..7] OF BYTE = (128, 64, 32, 16, 8, 4, 2, 1);
  167.   Voll = #219; Leer = #32;
  168. BEGIN
  169.   ASCII := Ord(Letter);
  170.   xPos := WinX1 + 2 + (Posi - 1) * LetterBreite;
  171.   FOR y := 0 TO 7 DO BEGIN
  172.     FOR x := 0 TO 7 DO
  173.       IF Zeichen[ASCII, y] AND Bits[x] > 0 THEN
  174.         WriteAt(xPos + x, Succ(WinY1 + y), Voll, Attr)
  175.       ELSE
  176.         WriteAt(xPos + x, Succ(WinY1 + y), Leer, Attr);
  177.   END;
  178. END;
  179.  
  180. PROCEDURE ShowBlock;
  181. VAR n : BYTE;       { vergrößerten Block invers darstellen }
  182. BEGIN
  183.   FOR n := 0 TO AnzLetter - 1 DO
  184.     IF CurX + n <= Rechts THEN
  185.       Screen^[CurY, CurX + n] :=
  186.         Screen^[CurY, CurX + n] XOR $7F00;
  187. END;
  188.  
  189. PROCEDURE FindWord;   { sucht Zeichenfolge auf dem Monitor }
  190. VAR x, y, n, Match, MatchStart, Durchlauf : BYTE;
  191. BEGIN
  192.   IF Length(Begriff) = 0 THEN BEGIN Pieps; Exit; END;
  193.   x := CurX; y := CurY; n := 1; Durchlauf := 0;
  194.   Match := 0; RestoreWindow; DrawNeu := TRUE;
  195.   REPEAT
  196.     Inc(x);
  197.     IF x > Succ(Rechts - Length(Begriff) + Match) THEN BEGIN
  198.       x := 1; Inc(y);
  199.       IF y > Unten THEN BEGIN
  200.         y := 1; Inc(Durchlauf);       { Endlosschleife bei }
  201.         IF Durchlauf > 1 THEN BEGIN   { erfolgloser Suche  }
  202.           MakeWindow(NormAttr);       { verhindern!        }
  203.           Pieps; Exit;
  204.         END;
  205.       END;
  206.     END;
  207.     IF UpChar(GetChar(x, y)) =
  208.        UpChar(Begriff[Match+1]) THEN BEGIN
  209.       IF Match = 0 THEN MatchStart := x;
  210.       Inc(Match);
  211.     END ELSE Match := 0;
  212.   UNTIL Match = Length(Begriff);
  213.   CurX := MatchStart;          { Suche erfolgreich beenden }
  214.   CurY := y;
  215.   MakeWindow(NormAttr);
  216. END;
  217.  
  218. PROCEDURE Find;                        { Suchwort eingeben }
  219. VAR
  220.   n       : BYTE;
  221.   ch, ch2 : CHAR;
  222. BEGIN
  223.   RestoreWindow; MakeWindow(FindAttr);
  224.   DrawNeu := TRUE; n := 1; Begriff := '';
  225.   REPEAT
  226.     ch := ReadKey;
  227.     IF ch = #0 THEN ch2 := ReadKey;
  228.     IF ch = #8 THEN BEGIN                    { <BackSpace> }
  229.       ch := #0;
  230.       IF n > 1 THEN BEGIN
  231.         Dec(n); Begriff[n] := #32;
  232.         WriteLetter(#32, n, FindAttr);
  233.       END;
  234.     END;
  235.     IF (n <= AnzLetter) AND
  236.     NOT (ch IN [#0, #10, #13, #27]) THEN BEGIN
  237.       Begriff[n] := ch;
  238.       WriteLetter(ch, n, FindAttr); Inc(n);
  239.     END;
  240.   UNTIL ch IN [#13, #27];
  241.   Dec(n); Begriff[0] := Chr(n);
  242.   IF (n = 0) OR (ch = #27) THEN BEGIN           { <Escape> }
  243.     RestoreWindow; MakeWindow(NormAttr); Exit;
  244.   END;
  245.   FindWord;
  246. END;
  247.  
  248. PROCEDURE FindNextChar(Step : SHORTINT);
  249.     { sucht das nächste lesbare Zeichen auf dem Bildschirm }
  250. VAR x, y : BYTE;
  251. BEGIN
  252.   x := CurX; y := CurY;
  253.   REPEAT
  254.     Inc(x, Step);
  255.     CASE Step OF
  256.       -1: IF x < 1 THEN BEGIN
  257.             x := Rechts; Dec(y);
  258.           END;
  259.        1: IF x > Rechts THEN BEGIN
  260.             x := 1; Inc(y);
  261.           END;
  262.     END;
  263.     IF (y < 1) OR (y > Unten) THEN Exit;
  264.   UNTIL GetChar(x, y) IN Lesbar;
  265.   CurX := x; CurY := y;
  266. END;
  267.  
  268. {$F+}
  269. PROCEDURE Zoom;                            { Hauptprozedur }
  270. VAR
  271.   Letter, ch, ch2 : CHAR;
  272.   n, x, y         : BYTE;
  273. CONST
  274.   BigStep = 4;        { Zeilensprung für <PgUp> und <PgDn> }
  275. BEGIN
  276.   Passage[0] := Chr(AnzLetter); Abbruch := FALSE;
  277.   GetMode;                   { Programm darf nur im 80x25- }
  278.   IF NOT Abbruch THEN BEGIN  { Modus akitviert werden !    }
  279.     CurX := WhereX; CurY := WhereY;
  280.     CurXAlt := WhereX; CurYAlt := WhereY;
  281.     Begriff := '';
  282.     MakeWindow(NormAttr);
  283.     FOR n := 1 TO AnzLetter DO Passage[n] := ' ';
  284.     DrawNeu := FALSE;
  285.     REPEAT
  286.       GotoXY(CurX, CurY); ShowBlock;
  287.       REPEAT
  288.         FOR n := 0 TO AnzLetter - 1 DO BEGIN
  289.           Letter := GetChar(CurX + n, CurY);
  290.           IF (Letter <> Passage[n+1]) OR DrawNeu THEN BEGIN
  291.             Passage[n + 1] := Letter;
  292.             WriteLetter(Letter, n + 1, NormAttr);
  293.           END;
  294.         END;
  295.         DrawNeu := FALSE;
  296.       UNTIL KeyPressed;
  297.       ch := ReadKey;
  298.       ShowBlock;
  299.       CASE UpCase(ch) OF
  300.         #0:  BEGIN
  301.                ch2:=ReadKey;
  302.                CASE ch2 OF
  303.                  #72: IF CurY > 1 THEN            { <hoch> }
  304.                         Dec(CurY);
  305.                  #80: IF CurY < Unten THEN      { <runter> }
  306.                         Inc(CurY);
  307.                  #75: IF CurX > 1 THEN           { <links> }
  308.                         Dec(CurX)
  309.                       ELSE BEGIN
  310.                         CurX := Rechts;
  311.                         IF CurY > 1 THEN
  312.                           Dec(CurY);
  313.                       END;
  314.                  #77: IF CurX < Rechts THEN     { <rechts> }
  315.                         Inc(CurX)
  316.                       ELSE BEGIN
  317.                         CurX := 1;
  318.                         IF CurY < Unten THEN
  319.                           Inc(CurY);
  320.                       END;
  321.                 #115: FindNextChar(-1);   { <Ctrl>-<links> }
  322.                 #116: FindNextChar(1);   { <Ctrl>-<rechts> }
  323.                  #71: CurX := 1;                  { <Home> }
  324.                  #79: CurX := Rechts-AnzLetter+1;  { <End> }
  325.                 #119: BEGIN                { <Ctrl>-<Home> }
  326.                         CurX := 1; CurY := 1;
  327.                       END;
  328.                 #117: BEGIN                 { <Ctrl>-<End> }
  329.                         CurX := Rechts - AnzLetter + 1;
  330.                         CurY := Unten;
  331.                       END;
  332.                  #73: IF CurY > BigStep THEN      { <PgUp> }
  333.                         Dec(CurY, BigStep)
  334.                       ELSE CurY := 1;
  335.                  #81: IF CurY < Unten-BigStep THEN
  336.                         Inc(CurY, BigStep)        { <PgDn> }
  337.                       ELSE CurY := Unten;
  338.                 #132: CurY := 1;           { <Ctrl>-<PgUp> }
  339.                 #118: CurY := Unten;       { <Crtl>-<PgDn> }
  340.                  #15: BEGIN                { <Shift>-<Tab> }
  341.                         IF CurX = 1 THEN BEGIN
  342.                           CurX := Rechts - AnzLetter + 1;
  343.                           IF CurY > 1 THEN Dec(CurY)
  344.                           ELSE CurY := Unten;
  345.                         END ELSE
  346.                           IF CurX < AnzLetter + 1 THEN
  347.                             CurX := 1
  348.                           ELSE Dec(CurX, AnzLetter);
  349.                       END;
  350.                END;
  351.              END;
  352.         #13: IF CurY < Unten THEN BEGIN          { <Enter> }
  353.                Inc(CurY); CurX := 1;
  354.              END;
  355.         #32: BEGIN                               { <Space> }
  356.                RestoreWindow; DrawNeu := TRUE;
  357.                Inc(Position); MakeWindow(NormAttr);
  358.              END;
  359.          #9: IF CurX < Rechts - AnzLetter + 1 THEN { <Tab> }
  360.                Inc(CurX, AnzLetter)
  361.              ELSE BEGIN
  362.                CurX := 1;
  363.                IF CurY < Unten THEN Inc(CurY)
  364.                ELSE CurY := 1;
  365.              END;
  366.         '+': IF (AnzLetter + 1) * LetterBreite + 4 < Rechts
  367.              THEN BEGIN               { Window verbreitern }
  368.                RestoreWindow;
  369.                Inc(AnzLetter);
  370.                IF CurX + AnzLetter > Rechts THEN
  371.                  Dec(CurX);
  372.                DrawNeu := TRUE;
  373.                MakeWindow(NormAttr);
  374.              END;
  375.         '-': IF AnzLetter > 1 THEN BEGIN
  376.                RestoreWindow;         { Window verkleinern }
  377.                Dec(AnzLetter); DrawNeu := TRUE;
  378.                MakeWindow(NormAttr);
  379.              END;
  380.         'S': Find;       { Suchbegriff eingeben und suchen }
  381.         'W': FindWord;                     { weiter suchen }
  382.       END;
  383.      { prüfen, ob Window automatisch verschoben werden muß }
  384.       IF CurY IN [WinY1..WinY2] THEN BEGIN
  385.         DrawNeu := TRUE; RestoreWindow;
  386.         MakeWindow(NormAttr);
  387.       END;
  388.     UNTIL ch = #27;                    { Ende mit <Escape> }
  389.     RestoreWindow;           { Bildschirm restaurieren,    }
  390.     GotoXY(CurXAlt, CurYAlt);{ Cursorposition restaurieren }
  391.   END;
  392. END;                         { und Zoomer verlassen ...    }
  393. {$F-}
  394.  
  395. BEGIN
  396.   IF AlreadyLoaded(ZoomID) THEN
  397.     Writeln(Programm, ' ist bereits geladen!',
  398.             ^M^J, 'Aktivieren Sie das Programm mit ',
  399.             HotkeyName, '.')
  400.   ELSE BEGIN
  401.     IF PopUpInstalled (@Zoom, Hotkey, 1) THEN BEGIN
  402.       Writeln(Programm, ' geladen',
  403.             ^M^J, 'Aktivieren Sie das Programm mit ',
  404.             HotkeyName);
  405.       MakeResident(ZoomID);
  406.     END ELSE
  407.       Writeln(Programm, ' nicht installiert,', ^M^J,
  408.               'Fehler: Vermutlich zu wenig Hauptspeicher!');
  409.   END;
  410.   Writeln;
  411.   Writeln('(c) 1990 Gerd Arnold & TOOLBOX');
  412. END.
  413. (* ------------------------------------------------------ *)
  414. (*                   Ende von ZOOMER.PAS                  *)
  415.