home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1991 / 05 / trickbox / screenlo.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-04-03  |  7.1 KB  |  265 lines
  1. UNIT ScreenLow;
  2. (* (c) 1991 Ralf Hensmann & toolbox *)
  3.  
  4. INTERFACE
  5.  
  6. USES Dos,Crt;
  7.  
  8. (**************************************************************************)
  9. (*                                                                        *)
  10. (*                            Export                                      *)
  11. (*                                                                        *)
  12. (* ScreenLow: TScreen            - Schirmtyp (80*25 Zeichen)              *)
  13. (*            PScreen            - Zeiger auf Schirmtyp                   *)
  14. (*            Screen             - Zeiger auf den Textbildschirm          *)
  15. (*            InsChar(ch)        - fügt Zeichen an Cursorposition ein.    *)
  16. (*            NewLine(i,i,i,i,b) - Neue Linie von nach, doppelt ?         *)
  17. (*            InsCr              - Editor-CR (Einfügemodus)               *)
  18. (*            SetHighBack(b)     - Setzt Hintergrund hell/blinkend        *)
  19. (*            SaveGroundLine     - speichert die unterste Zeile           *)
  20. (*            RestoreGroundLine  - restort die unterste Zeile             *)
  21. (*            Advance(i)         - springt auf Wortanfang                 *)
  22. (*            DelCh              - löscht Zeichen aus Zeile               *)
  23. (*                                                                        *)
  24. (**************************************************************************)
  25.  
  26. TYPE SChar   = RECORD
  27.                  ch   : CHAR;
  28.                  attr : BYTE;
  29.                END;
  30.      TScreen = ARRAY [1..25,1..80] OF SChar;
  31.      PScreen = ^TScreen;
  32.  
  33. VAR  Screen : PScreen;
  34.  
  35.  
  36. PROCEDURE InsChar(Ch : CHAR);
  37.   (* Schreibt Zeichen an Cursorposition und schiebt Rest nach rechts *)
  38.  
  39. PROCEDURE NewLine(x,y,ncx,ncy : INTEGER; Double,Rubber : BOOLEAN; TCol : BYTE);
  40.   (* Berechnet Linie an aktueller Position (x,y) - Der neue Cursor steht *)
  41.   (* an ncx,ncy *)
  42.  
  43. PROCEDURE DoubleLine;
  44.   (* Verdoppelt die Zeile, in der der Cursor steht *)
  45.  
  46. PROCEDURE InsCr;
  47.   (* Fügt CR in Text wie im Einfügemodus des Editors ein *)
  48.  
  49. PROCEDURE SetHighback(Highback : BOOLEAN);
  50.   (* Setzt / Löscht Hintergrundattribut blink/hell *)
  51.  
  52. PROCEDURE SaveGroundLine;
  53.   (* Speichert die unterste Zeile des Bildschirms *)
  54.  
  55. PROCEDURE RestoreGroundLine;
  56.   (* Restort die unterste Bildschirmzeile *)
  57.  
  58. PROCEDURE Advance(dif : INTEGER);
  59.   (* Springt an Wortanfang *)
  60.  
  61. PROCEDURE DelCh;
  62.   (* Löscht Buchstabe aus Zeile *)
  63.  
  64. PROCEDURE Cursor(Block : BOOLEAN);
  65.  
  66. IMPLEMENTATION
  67.  
  68. VAR GroundLine   : ARRAY [1..80] OF SChar;
  69.     LastX, LastY : BYTE;
  70.     TextAttrOld  : BYTE;
  71.  
  72. PROCEDURE Cursor(Block : BOOLEAN);
  73. VAR R : Registers;
  74. BEGIN
  75.   IF LastMode = Mono THEN R.CL := 13 ELSE R.CL := 7;
  76.   IF Block           THEN R.CH := 0  ELSE R.CH := R.CL-1;
  77.   R.AH := 1;
  78.   Intr($10,R);
  79. END;
  80.  
  81.  
  82. FUNCTION IsAlpha(Ch : CHAR) : BOOLEAN;
  83. BEGIN
  84.  IsAlpha := Ch IN ['a'..'z','A'..'Z','0'..'9','ä','ö','ü','Ä','Ö','Ü'];
  85. END;
  86.  
  87.  
  88. PROCEDURE Advance(dif : INTEGER);
  89. VAR x,y          : INTEGER;
  90.     NextIs,NowIs : BOOLEAN;
  91. BEGIN
  92.   x := WhereX; y := WhereY;
  93.   IF dif < 0 THEN BEGIN
  94.       IF x = 1 THEN BEGIN
  95.         x := 80; DEC(y);
  96.       END;
  97.       NextIs := FALSE;
  98.       IF y > 0 THEN
  99.         REPEAT
  100.           DEC(x);
  101.           NowIs := NextIs;
  102.           NextIs := IsAlpha(Screen^[y,x-1].ch);
  103.         UNTIL (x=1) OR (NOT NextIs AND NowIs);
  104.     IF y = 0 THEN BEGIN
  105.       y := 1; x := 1;
  106.     END;
  107.   END ELSE BEGIN
  108.       IF x = 80 THEN BEGIN
  109.         x := 1; INC(y);
  110.       END;
  111.       NextIs := TRUE;
  112.       IF y <= 25 THEN
  113.         REPEAT
  114.           INC(x);
  115.           NowIs := NextIs;
  116.           NextIs := IsAlpha(Screen^[y,x+1].ch);
  117.         UNTIL (x=79) OR (NextIs AND NOT NowIs);
  118.     IF NextIs AND NOT NowIs THEN
  119.       INC(x)
  120.     ELSE BEGIN
  121.       x := 1; INC(y);
  122.     END;
  123.     IF y = 26 THEN BEGIN
  124.       y := 1; x := 1;
  125.     END;
  126.   END;
  127.   GotoXY(x,y);
  128. END;
  129.  
  130. PROCEDURE DelCh;
  131. VAR x,y : INTEGER;
  132. BEGIN
  133.  x := WhereX; y := WhereY;
  134.  Move(Screen^[y,x+1],Screen^[y,x],2*(80-x));
  135.  Screen^[y,80].ch := ' ';
  136. END;
  137.  
  138.  
  139. PROCEDURE SetHighback(Highback : BOOLEAN);
  140. CONST Value : ARRAY [FALSE..TRUE] OF BYTE = ($29,$09);
  141. VAR R : Registers;
  142. BEGIN
  143.   IF LastMode = Mono THEN
  144.     Port[$3B8] := Value[Highback]
  145.   ELSE BEGIN
  146.     (* Port[$3D8] := Value[Highback]; *)
  147.     R.AX:=$1003; R.BL:=1-ORD(HighBack);
  148.     Intr($10,R);
  149.   END;
  150. END;
  151.  
  152.  
  153. PROCEDURE InsChar(Ch : CHAR);
  154. VAR x,y,i : INTEGER;
  155. BEGIN
  156.   x := WhereX; y := WhereY;
  157.   IF x < 80 THEN
  158.     Move(Screen^[y,x],Screen^[y,x+1],2*(80-x));
  159.   Write(Ch);
  160. END;
  161.  
  162.  
  163. PROCEDURE DoubleLine;
  164. VAR x,y,i : INTEGER;
  165. BEGIN
  166.   x := WhereX; y := WhereY;
  167.   IF y = 25 THEN BEGIN
  168.     GotoXY(1,1);
  169.     DelLine;
  170.   END ELSE BEGIN
  171.     GotoXY(1,y+1);
  172.     InsLine;
  173.     Move(Screen^[y,x],Screen^[y+1,1],2*(81-x));
  174.   END;
  175. END;
  176.  
  177.  
  178. PROCEDURE InsCr;
  179. VAR x,y,i : INTEGER;
  180. BEGIN
  181.   x := WhereX; y := WhereY;
  182.   IF y = 25 THEN BEGIN
  183.     GotoXY(1,1);
  184.     DelLine;
  185.     y := 24;
  186.   END;
  187.   GotoXY(1,y+1);
  188.   InsLine;
  189.   Move(Screen^[y,x],Screen^[y+1,1],2*(81-x));
  190.   GotoXY(x,y);
  191.   Write('':81-x);
  192.   i := 80;
  193.   WHILE (i>0) AND (Screen^[y+1,i].ch=' ') DO BEGIN
  194.     Screen^[y+1,i].attr := TextAttr;
  195.     DEC(i);
  196.   END;
  197. END;
  198.  
  199.  
  200. PROCEDURE SaveGroundLine;
  201. BEGIN
  202.   Move(Screen^[25,1],GroundLine,SizeOf(GroundLine));
  203.   LastX := WhereX; LastY := WhereY;
  204.   TextAttrOld := TextAttr; TextAttr := 7;
  205. END;
  206.  
  207.  
  208. PROCEDURE RestoreGroundLine;
  209. BEGIN
  210.   Move(GroundLine,Screen^[25,1],SizeOf(GroundLine));
  211.   GotoXY(LastX,LastY);
  212.   TextAttr := TextAttrOld;
  213. END;
  214.  
  215.  
  216. PROCEDURE NewLine(x,y,ncx,ncy : INTEGER; Double,Rubber : BOOLEAN; TCol : BYTE);
  217. TYPE  NumArray = ARRAY [#179..#218] OF INTEGER;
  218. CONST BoxFeld : ARRAY [4..12] OF STRING[12] =
  219.         ('*** ─═│┘╛║╜╝','***──═└┴┴╙╨╨','***═══╘┴╧╚╨╩',
  220.          '***│┐╕│┤╡║┤╡','***┌┬┬├┼┼├┼┼','***╒┬╤╞┼╪├┼╪',
  221.          '***║╖╗║┤╡║╢╣','***╓┼╥╟┼┼╟╫╫','***╔╥╦╠┼╪╠╫╬');
  222.       Left  : NumArray =
  223.         (1,2, 3,2,2,3,3, 1,3,3,2,3, 2,1,2,2,1, 2,2,1,1,1, 1,3,3,1,3,
  224.               3,3,2,3,2, 1,1,1,1,2, 3,2,1);
  225.       Above : NumArray =
  226.         (2,2, 2,3,1,1,3, 3,1,3,3,2, 1,2,2,1,2, 1,2,2,3,3, 1,3,1,3,1,
  227.               3,2,3,1,1, 3,2,1,1,3, 2,2,1);
  228.       Right : NumArray =
  229.         (1,1, 1,1,1,1,1, 1,1,1,1,1, 1,2,2,2,2, 2,2,3,2,3, 3,3,3,3,3,
  230.               3,3,2,3,2, 2,3,3,2,2, 3,1,2);
  231.       Below : NumArray =
  232.         (2,2, 2,3,3,2,3, 3,3,1,1,1, 2,1,1,2,2, 1,2,2,3,1, 3,1,3,3,1,
  233.               3,1,1,2,3, 1,1,2,3,3, 2,1,2);
  234.  
  235.   FUNCTION Get(VAR N : NumArray; x,y : INTEGER) : INTEGER;
  236.   VAR Ch : CHAR;
  237.   BEGIN
  238.     IF (x<=0) OR (x>80) OR (y<=0) OR (y>25) THEN
  239.       Get := 1
  240.     ELSE IF (x=ncx) AND (y=ncy) THEN
  241.       IF Rubber THEN Get := 1 ELSE Get := 2+ORD(Double)
  242.     ELSE BEGIN
  243.       Ch := Screen^[y,x].ch;
  244.       IF (Ch < #179) OR (Ch > #218) THEN
  245.         Get := 1
  246.       ELSE
  247.         Get := N[Ch];
  248.     END;
  249.   END;
  250.  
  251. VAR h : INTEGER;
  252. BEGIN
  253.   IF Rubber THEN BEGIN
  254.     Screen^[y,x].ch := ' ';
  255.   END;
  256.   Screen^[y,x].ch := BoxFeld[3*Get(Above,x,y+1)+Get(Left,x+1,y)]
  257.                             [3*Get(Below,x,y-1)+Get(Right,x-1,y)];
  258.   Screen^[y,x].Attr := Screen^[y,x].Attr AND $F0 + TCol;
  259. END;
  260.  
  261. BEGIN
  262.   IF LastMode = Mono THEN Screen := Ptr($B000,0)
  263.                      ELSE Screen := Ptr($B800,0);
  264. END.
  265.