home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / grafik / crtgraph / crtg.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-04-03  |  29.0 KB  |  1,175 lines

  1. UNIT Crtg;
  2. {
  3. | This unit is a direct replacement for the CRT unit shipped with Turbo Pascal.
  4. | It has been tested with version 5.5 but should work with versions 4 and 5 as
  5. | well.  It will probably work with version 6 but I have not tested it.  This
  6. | unit uses only the GRAPH unit.  The major benifit to this unit is that it
  7. | allows the use of the graphics operations in GRAPH to be used while doing
  8. | normal text operations.
  9. |
  10. | Modifications have been made to the way Read(ln) works.  When erasing
  11. | character on the input line the cursor will move back along the entire
  12. | input line even if it has wrapped at the right edge of the window.  If the
  13. | window was scrolled up because the input line went past the lower edge of
  14. | the window and if the start of the input line was scrolled off the screen
  15. | it will be replaced as the cursor moves up the window.
  16. |
  17. | Assumptions: The video system supports all the VGA modes in a form
  18. |              compatable with IBM VGA.
  19. |
  20. | When this unit is used it will replace the drivers on Input and Output for
  21. | Write(ln) and Read(ln).  I/O redirection is NOT supported.  If the CRT unit
  22. | is used and comes after this unit then the functions in this unit will be
  23. | mostly useless.
  24. |
  25. | Some of the assembly code is from other sources.  These are:
  26. |
  27. |   Programmer's Guide to PC & PS/2 Video Systems.
  28. |   Richard Wilton, Microsoft Press.
  29. |
  30. |   CRT unit from Borland's Turbo Pascal Version 5.0
  31. |
  32. | The code is marked in the assembler files.
  33. |
  34. | If you use this code I would appreciate being given credit for it.  If you
  35. | find problems with it, other than it won't work with your video card,
  36. | please send mail to tsmith@plains.nodak.edu
  37. |
  38. | Hope somebody can use this,
  39. |       Tim Smith
  40. |
  41. }
  42.  
  43. INTERFACE
  44.  
  45. const
  46. {
  47. | Color constants
  48. }
  49.   Black         = 0;
  50.   Blue          = 1;
  51.   Green         = 2;
  52.   Cyan          = 3;
  53.   Red           = 4;
  54.   Magenta       = 5;
  55.   Brown         = 6;
  56.   LightGray     = 7;
  57.   DarkGray      = 8;
  58.   LightBlue     = 9;
  59.   LightGreen    = 10;
  60.   LightCyan     = 11;
  61.   LightRed      = 12;
  62.   LightMagenta  = 13;
  63.   Yellow        = 14;
  64.   White         = 15;
  65.  
  66. {
  67. | Mode constants
  68. }
  69.   BW40          = 0;     { not supported }
  70.   BW80          = 2;     { is considered to be CO80 }
  71.   Mono          = 7;     { not supported }
  72.   CO40          = 1;     { not supported }
  73.   CO80          = 3;
  74.   Font8x8       = 256;
  75.   C40           = CO40;  { not supported }
  76.   C80           = CO80;
  77.   T80x25        = 128;   { 80 cols x 25 rows : default VGA 640x350 Font: 8x14 }
  78.   T80x34        = 129;   { 80 cols x 34 rows           VGA 640x480       8x14 }
  79.   T80x60        = 130;   { 80 cols x 60 rows           VGA 640x480       8x8  }
  80.   T80x43        = 256;   { 80 cols x 43 rows           VGA 640x350       8x8  }
  81.  
  82. var
  83.   TrapBreak   : boolean; { See Readkey }
  84.   CheckBreak  : boolean;
  85.   CheckEOF    : boolean;
  86.   CheckSnow   : boolean; { not used }
  87.   DirectVideo : boolean; { not used }
  88.   LastMode    : byte;
  89.   TextAttr    : byte;
  90.   WindMin     : word;
  91.   WindMax     : word;
  92.  
  93. {
  94. |=============================================================================
  95. | These functions/procedures are replacements for the CRT unit functions
  96. |=============================================================================
  97. }
  98. procedure AssignCrt( var F : text );
  99.  
  100. procedure ClrEol;
  101.  
  102. procedure ClrScr;
  103.  
  104. procedure Delay( ms : word );
  105.  
  106. procedure DelLine;
  107.  
  108. procedure GotoXY( X,Y : word );
  109.  
  110. procedure HighVideo;
  111.  
  112. procedure InsLine;
  113.  
  114. procedure LowVideo;
  115.  
  116. procedure NormVideo;
  117.  
  118. procedure NoSound;
  119.  
  120. procedure Sound( Hz : word );
  121.  
  122. procedure TextBackground( Color : byte );
  123.  
  124. procedure TextColor( Color : byte );
  125.  
  126. procedure TextMode( Mode : word );
  127.  
  128. procedure Window( X0,Y0,X1,Y1: word );
  129.  
  130. function KeyPressed : boolean;
  131.  
  132. {
  133. | If the flag CheckBreak is false it is possible to detect the Ctrl-Break
  134. | sequence with Readkey. The Ctrl-Break sequence will be treated as an
  135. | extended key press if the flag TrapBreak is true.  If TrapBreak is false
  136. | Ctrl-Break will be ignored.  The value of Ctrl-Break is #0 followed by a
  137. | second #0.
  138. }
  139. function ReadKey : char;
  140.  
  141. function WhereX : word;
  142.  
  143. function WhereY : word;
  144.  
  145. {
  146. |=============================================================================
  147. | These functions/procedures are additions to the CRT unit functions
  148. |=============================================================================
  149. }
  150. {
  151. | Turns cursor off.  The character underneath is restored.
  152. }
  153. procedure CurOff;
  154.  
  155. {
  156. | Turns the cursor on.  The cursor does NOT flash.
  157. }
  158. procedure CurOn;
  159.  
  160. {
  161. | Returns a the word containing the character and it's color attribute from
  162. | the text position X,Y.  If X,Y is outside of the current screen range 0 is
  163. | returned.
  164. }
  165. function GetScreenCell( X,Y : word ) : word;
  166.  
  167. {
  168. | Puts the character C at text position X,Y with current attributes.  If X,Y
  169. | is outside of the current screen range nothing is done.  This procedure is
  170. | the only way to update the character storage area.
  171. }
  172. procedure SetChar( C : char; X,Y : word );
  173.  
  174. IMPLEMENTATION
  175.  
  176. uses
  177.   graph;
  178.  
  179. {
  180. | File constants. Did not want to use DOS unit.
  181. }
  182. const
  183.   fmClosed = $D7B0;
  184.   fmInput  = $D7B1;
  185.   fmOutput = $D7B2;
  186.   fmInOut  = $D7B3;
  187.   CrtMaxX : word = 80;
  188.   CrtMaxY : word = 25;
  189.  
  190. type
  191.  
  192.   BiosArrayW = array[0..32000] of word;
  193.   BiosArrayB = array[0..64000] of byte;
  194.  
  195.   BufTyp = array[0..4800] of word;
  196.   BufPtr = ^BufTyp;
  197.  
  198.   ScrCel = record
  199.     Cha : char;
  200.     Att : byte
  201.     end;
  202.  
  203.   MinMax = record
  204.     X,Y : byte
  205.     end;
  206.  
  207. {
  208. |Textfile record Again I did not want to use DOS.
  209. }
  210.   TextBuf = array[0..127] of Char;
  211.   TextRec = record
  212.              Handle: Word;
  213.              Mode: Word;
  214.              BufSize: Word;
  215.              Private: Word;
  216.              BufPos: Word;
  217.              BufEnd: Word;
  218.              BufPtr: ^TextBuf;
  219.              OpenFunc: Pointer;
  220.              InOutFunc: Pointer;
  221.              FlushFunc: Pointer;
  222.              CloseFunc: Pointer;
  223.              UserData: array[1..16] of Byte;
  224.              Name: array[0..79] of Char;
  225.              Buffer: TextBuf;
  226.              end;
  227.  
  228. var
  229.   Extended,                   { is an extended key press available    }
  230.   CurAct,                     { is the cursor on                      }
  231.   BreakPressed : boolean;     { has Ctrl-Break been pressed           }
  232.   OldCurX,                    { last position of cursor               }
  233.   OldCurY      : integer;
  234.   CurX,                       { current position of cursor            }
  235.   CurY,                       { origin at 0,0 relative to window      }
  236.   KeyBufSta,                  { start of keyboard buffer              }
  237.   KeyBufEnd    : word;        { end of keyboard buffer                }
  238.   BiosPtr      : ^BiosArrayW; { array of words at $40:00              }
  239.   KeyBuf       : ^BiosArrayB; { array of bytes at $40:00              }
  240.   CurCha,                     { current available character in buffer }
  241.   NexOpe       : ^word;       { next open spot in buffer              }
  242.   ScrSta       : BufPtr;      { screen storage area                   }
  243.   ExiSav,                     { execute closegraph when done          }
  244.   FontTable    : pointer;     { which font?                           }
  245.   ChaHgt       : byte;        { character height                      }
  246.  
  247.  
  248. {
  249. |=============================================================================
  250. | SUPPORT FUNCTIONS
  251. |=============================================================================
  252. }
  253.  
  254. {$F+}
  255. procedure EgaVgaDriverProc; external; {$L EGAVGA.OBJ }
  256.  
  257. procedure Text8x14; external; {$L text8x14.OBJ}
  258.  
  259. procedure Text8x8; external; {$L text8x8.OBJ}
  260.  
  261. procedure ScrollUp( X,Y,Len,Dep : word ); external;
  262.  
  263. procedure ScrollDown( X,Y,Len,Dep : word ); external;
  264.  
  265. procedure PutChar( C,X,Y   : word;
  266.                    Fgd,Bkg : byte ); external;
  267.  
  268. procedure Delay( ms : word ); external;
  269.  
  270. procedure NoSound; external;
  271.  
  272. procedure Sound( Hz : word ); external;
  273.  
  274. procedure InitCTimer; external;
  275. {$L crtg.obj}
  276. {$F-}
  277.  
  278. {
  279. | Puts the cursor at Graphical X,Y
  280. }
  281. procedure PutCur( X,Y : word );
  282.   begin
  283.   setcolor( TextAttr and 15);
  284.   line( X+1,Y+ChaHgt-1,X+7,Y+ChaHgt-1 );
  285.   line( X+1,Y+ChaHgt-2,X+7,Y+ChaHgt-2 );
  286.   end;{ PutCur }
  287.  
  288.  
  289. {$F+}
  290. {
  291. | OutPut functions assigned to OUTPUT
  292. }
  293. function CrtOut( var Win : TextRec ) : integer;
  294.   type
  295.     ChaBuf = array[0..64000] of char;
  296.     ChaPtr = ^ChaBuf;
  297.   var
  298.     CX,CY,I,Y,
  299.     MaxX,MaxY,
  300.     MinX,MinY  : word;
  301.     C          : ScrCel;
  302.     CPtr       : ChaPtr;
  303.     CA         : boolean;
  304.   begin
  305.   if Win.BufPos=0 then
  306.     begin
  307.     CrtOut := 0;
  308.     exit;
  309.     end;
  310.   CA := CurAct;
  311.   if CA then
  312.     CurOff;
  313.   CPtr := ChaPtr(Win.BufPtr);
  314.   MinX := MinMax(WindMin).X;
  315.   MinY := MinMax(WindMin).Y;
  316.   MaxX := MinMax(WindMax).X;
  317.   MaxY := MinMax(WindMax).Y;
  318.   CX := MinX + CurX;
  319.   CY := MinY + CurY;
  320.   for I:=0 to Win.BufPos-1 do
  321.     begin
  322.     case CPtr^[I] of
  323.       #7  :   begin
  324.               sound(220);
  325.               delay(200)
  326.               end;       { beep }
  327.       #8  : if CX>MinX then
  328.               begin
  329.               dec(CX);
  330.               dec(CurX)
  331.               end;
  332.       #10 : begin { LineFeed }
  333.             if CY<MaxY then
  334.               begin
  335.               inc(CurY);
  336.               inc(CY);
  337.               end
  338.             else
  339.               begin
  340.               Y := CurY;
  341.               CurY := 0;
  342.               DelLine;
  343.               CurY := Y
  344.               end
  345.             end;
  346.       #13 : begin
  347.             CurX := 0;
  348.             CX := MinX;
  349.             end;
  350.       else
  351.         if CPtr^[I]>=' ' then
  352.           begin
  353.           C.Cha := CPtr^[I];
  354.           C.Att := textattr;
  355.           ScrSta^[CX + CY*CrtMaxX] := word(C);
  356.           PutChar( ord(CPtr^[I]),CX,CY,(textattr and $0F),(textattr and $F0) shr 4 );
  357.           if CX<MaxX then
  358.             begin
  359.             inc( CurX );
  360.             inc( CX );
  361.             end
  362.           else
  363.             begin
  364.             CurX := 0;
  365.             CX :=  MinX;
  366.             if CY<MaxY then
  367.               begin
  368.               inc(CurY);
  369.               inc(CY);
  370.               end
  371.             else
  372.               begin
  373.               Y := CurY;
  374.               CurY := 0;
  375.               DelLine;
  376.               CurY := Y
  377.               end
  378.             end
  379.           end
  380.       end;
  381.     end;
  382.   Win.BufPos := 0;
  383.   CrtOut := 0;
  384.   if CA then
  385.     begin
  386.     OldCurX := CurX;
  387.     OldCurY := CurY;
  388.     CurOn
  389.     end;
  390.   end;{ WinIO }
  391.  
  392. var
  393.   ReadDon : boolean;
  394.   LastLine : string;
  395.  
  396. {
  397. |
  398. }
  399. function CrtIn( var Win : TextRec ) : integer;
  400.   type
  401.     ChaTyp = array[1..64000] of char;
  402.     ChaPtr = ^ChaTyp;
  403.   var
  404.     FY,FX,Y,X : word;
  405.     CX,CY,LI : word;
  406.     C        : ScrCel;
  407.     I,Imax,J : word;
  408.     CPtr     : ChaPtr;
  409.     Ch       : char;
  410.     CA,Don   : boolean;
  411.     BacOff   : array[0..255] of word;
  412.     BacOffLen : word;
  413.   begin
  414.   Imax := Win.BufSize;
  415.   CPtr := ChaPtr(Win.BufPtr);
  416.   CA := CurAct;
  417.   CX := MinMax(WindMin).X+CurX;
  418.   CY := MinMax(WindMin).Y+CurY;
  419.   FY := CurY;
  420.   FX := CurX;
  421.   I := 1;
  422.   BacOffLen := 0;
  423.   ReadDon := false;
  424.   LI := 0;
  425.   while not ReadDon do
  426.     begin
  427.     Don := false;
  428.     while not Don do
  429.       begin
  430.       Ch := readkey;
  431.       if keypressed then
  432.         begin
  433.         Ch := readkey;
  434.         Don := false
  435.         end
  436.       else
  437.         Don := true
  438.       end;
  439.     if (Ch=^D) and (I<=length(LastLine)) then
  440.         Ch := LastLine[I];
  441.     if (Ch=^F) and (I<=length(LastLine)) then
  442.       begin
  443.       if CA then
  444.         CurOff;
  445.       for J:=I to length(LastLine) do
  446.         begin
  447.         if J<Imax then
  448.           begin
  449.           CPtr^[J] := LastLine[J];
  450.           C.Cha := LastLine[J];
  451.           C.Att := textattr;
  452.           ScrSta^[CX + CY*CrtMaxX] := word(C);
  453.           PutChar( ord(LastLine[J]),CX,CY,(textattr and $0F),(textattr and $F0) shr 4 );
  454.           if CX<MinMax(WindMax).X then
  455.             begin
  456.             inc( CurX );
  457.             inc( CX )
  458.             end
  459.           else
  460.             begin
  461.             CurX := 0;
  462.             CX := MinMax(WindMin).X;
  463.             if CY<MinMax(WindMax).Y then
  464.               begin
  465.               inc(CurY);
  466.               inc(CY)
  467.               end
  468.             else
  469.               begin
  470.               inc(LI);
  471.               Y := MinMax(WindMin).Y*CrtMaxX;
  472.               for X:=MinMax(WindMin).X to MinMax(WindMax).X do
  473.                 begin
  474.                 BacOff[BacOffLen] := ScrSta^[X+Y];
  475.                 inc(BacOffLen)
  476.                 end;
  477.               Y := CurY;
  478.               CurY := 0;
  479.               DelLine;
  480.               CurY := Y
  481.               end
  482.             end;
  483.           end;
  484.         end;
  485.       I := length(LastLine)+1;
  486.       if CA then
  487.         CurOn;
  488.       end;
  489.     case Ch of
  490.        ^F : ;
  491.    ^A,#27 : begin
  492.             if CA then CurOff;
  493.             if LI>FY then
  494.               begin
  495.               clrscr;
  496.               BacOffLen := 0;
  497.               FY := 0;
  498.               CurX := FX;
  499.               CurY := FY;
  500.               CY := MinMax(WindMin).Y;
  501.               CX := MinMax(WindMin).X;
  502.               if FX>0 then
  503.                 begin
  504.                 Y := CY*CrtMaxX;
  505.                 for X:=0 to (FX-1) do
  506.                   begin
  507.                   C := ScrCel(BacOff[X]);
  508.                   ScrSta^[X+Y] := word(C);
  509.                   PutChar( byte(C.Cha),CX+X,CY,(C.Att and $0F),(C.Att and $F0) shr 4 );
  510.                   end
  511.                 end;
  512.               CX := CX + FX
  513.               end
  514.             else
  515.               begin
  516.               FY := FY - LI;
  517.               Y := CurY;
  518.               CurX := 0;
  519.               for CurY:=Y downto (FY+1) do
  520.                 clreol;
  521.               CurX := FX;
  522.               CurY := FY;
  523.               clreol;
  524.               CY := MinMax(WindMin).Y + CurY;
  525.               CX := MinMax(WindMin).X + FX;
  526.               end;
  527.             LI := 0;
  528.             I := 1;
  529.             if CA then CurOn;
  530.             end;
  531.    ^S,#8  : begin
  532.             if CA then
  533.               CurOff;
  534.             if I>1 then
  535.               begin
  536.               dec(I);
  537.               if CurX>0 then
  538.                 begin
  539.                 dec(CurX);
  540.                 dec(CX);
  541.                 C.Cha := ' ';
  542.                 C.Att := textattr;
  543.                 ScrSta^[CX + CY*CrtMaxX] := word(C);
  544.                 PutChar( 32,CX,CY,(textattr and $0F),(textattr and $F0) shr 4 );
  545.                 end
  546.               else
  547.                 if CurY>0 then
  548.                   begin
  549.                   dec(CurY);
  550.                   dec(CY);
  551.                   CX := MinMax(WindMax).X;
  552.                   CurX := CX - MinMax(WindMin).X;
  553.                   C.Cha := ' ';
  554.                   C.Att := textattr;
  555.                   ScrSta^[CX + CY*CrtMaxX] := word(C);
  556.                   PutChar( 32,CX,CY,(textattr and $0F),(textattr and $F0) shr 4 );
  557.                   end
  558.                 else
  559.                   begin
  560.                   Y := MinMax(WindMin).Y*CrtMaxX;
  561.                   for X:=MinMax(WindMax).X downto MinMax(WindMin).X do
  562.                     begin
  563.                     dec(BacOffLen);
  564.                     ScrSta^[X+Y] := BacOff[BacOffLen];
  565.                     C := ScrCel(BacOff[BacOffLen]);
  566.                     PutChar( byte(C.Cha),X,CY,(C.Att and $0F),(C.Att and $F0) shr 4 );
  567.                     end;
  568.                   CX := MinMax(WindMax).X;
  569.                   CurX := CX - MinMax(WindMin).X;
  570.                   C.Cha := ' ';
  571.                   C.Att := textattr;
  572.                   ScrSta^[CX + CY*CrtMaxX] := word(C);
  573.                   PutChar( 32,CX,CY,(textattr and $0F),(textattr and $F0) shr 4 );
  574.                   end;
  575.               end;
  576.             if CA then
  577.               CurOn;
  578.             end;
  579.       #10 : begin { LineFeed }
  580.             if CA then
  581.               CurOff;
  582.             if I<Imax then
  583.               if CY<MinMax(WindMax).Y then
  584.                 begin
  585.                 inc(CY);
  586.                 inc(CurY);
  587.                 end
  588.               else
  589.                 begin
  590.                 inc(LI);
  591.                 Y := MinMax(WindMin).Y*CrtMaxX;
  592.                 for X:=MinMax(WindMin).X to MinMax(WindMax).X do
  593.                   begin
  594.                   BacOff[BacOffLen] := ScrSta^[X+Y];
  595.                   inc(BacOffLen)
  596.                   end;
  597.                 Y := CurY;
  598.                 CurY := 0;
  599.                 DelLine;
  600.                 CurY := Y
  601.                 end;
  602.             if CA then
  603.               CurOn
  604.             end;
  605.       #13 : begin
  606.             if CA then
  607.               CurOff;
  608.             CurX := 0;
  609.             if CY<MinMax(WindMax).Y then
  610.               begin
  611.               inc(CY);
  612.               inc(CurY)
  613.               end
  614.             else
  615.               begin
  616.               Y := CurY;
  617.               CurY := 0;
  618.               DelLine;
  619.               CurY := Y
  620.               end;
  621.             CPtr^[I] := #13;
  622.             if I<Imax then
  623.               begin
  624.               inc(I);
  625.               CPtr^[I] := #10
  626.               end;
  627.             ReadDon := true;
  628.             if CA then
  629.               CurOn
  630.             end;
  631.       else
  632.         if Ch>=' ' then
  633.           begin
  634.           if CA then
  635.             CurOff;
  636.           if I<Imax then
  637.             begin
  638.             C.Cha := Ch;
  639.             C.Att := textattr;
  640.             ScrSta^[CX + CY*CrtMaxX] := word(C);
  641.             PutChar( ord(Ch),CX,CY,(textattr and $0F),(textattr and $F0) shr 4 );
  642.             if CX<MinMax(WindMax).X then
  643.               begin
  644.               inc( CurX );
  645.               inc( CX )
  646.               end
  647.             else
  648.               begin
  649.               CurX := 0;
  650.               CX := MinMax(WindMin).X;
  651.               if CY<MinMax(WindMax).Y then
  652.                 begin
  653.                 inc(CurY);
  654.                 inc(CY)
  655.                 end
  656.               else
  657.                 begin
  658.                 inc(LI);
  659.                 Y := MinMax(WindMin).Y*CrtMaxX;
  660.                 for X:=MinMax(WindMin).X to MinMax(WindMax).X do
  661.                   begin
  662.                   BacOff[BacOffLen] := ScrSta^[X+Y];
  663.                   inc(BacOffLen)
  664.                   end;
  665.                 Y := CurY;
  666.                 CurY := 0;
  667.                 DelLine;
  668.                 CurY := Y
  669.                 end
  670.               end;
  671.             end;
  672.           if CA then
  673.             CurOn;
  674.           end
  675.       end;{ case }
  676.     if pos(Ch,#8+^F+^D+^S+^A+#27+^Z+#13)=0 then
  677.       begin
  678.       CPtr^[I] := Ch;
  679.       if I<Imax then
  680.         inc(I)
  681.       end
  682.     end;{ while }
  683.   Win.BufPos := 0;
  684.   Win.BufEnd := I;
  685.   for J:=1 to I do
  686.     LastLine[J] := CPtr^[J];
  687.   if LastLine[I]=#10 then
  688.     byte(LastLine[0]) := I-2
  689.   else
  690.     byte(LastLine[0]) := I-1;
  691.   CrtIn := 0;
  692.   end;{ WinIn }
  693.  
  694. function CrtInFlu( var Win : TextRec ) : integer;
  695.   begin
  696.   Win.BufPos := 0;
  697.   Win.BufEnd := 0;
  698.   CrtInFlu := 0;
  699.   end;{ WinFlu }
  700.  
  701. procedure PilWinExi;
  702.   begin
  703.   ExitProc := ExiSav;
  704.   closegraph;
  705.   end;{ PilWinExi }
  706.  
  707. function CrtClo( var Win : TextRec ) : integer;
  708.   begin
  709.   dispose(Win.BufPtr);
  710.   CrtClo := 0
  711.   end;
  712.  
  713. function CrtOpe( var Win : TextRec ) : integer;
  714.   begin
  715.   with Win do
  716.     begin
  717.     case Mode of
  718.       fmInput  : begin
  719.                  InOutFunc := @CrtIn;
  720.                  FlushFunc := @CrtInFlu;
  721.                  end;
  722.       fmOutput : begin
  723.                  InOutFunc := @CrtOut;
  724.                  FlushFunc := @CrtOut;
  725.                  end;
  726.       end;
  727.     end;
  728.   CrtOpe := 0
  729.   end;
  730.  
  731. function AssCrtOpe( var Win : TextRec ) : integer;
  732.   begin
  733.   with Win do
  734.     begin
  735.     case Mode of
  736.       fmInput  : begin
  737.                  InOutFunc := @CrtIn;
  738.                  FlushFunc := @CrtInFlu;
  739.                  end;
  740.       fmOutput : begin
  741.                  InOutFunc := @CrtOut;
  742.                  FlushFunc := @CrtOut;
  743.                  end;
  744.       end;
  745.     CloseFunc := @CrtClo;
  746.     end;
  747.   AssCrtOpe := 0
  748.   end;
  749. {$F-}
  750.  
  751. procedure PilWinIni;
  752.   var
  753.     I : word;
  754.     C : ScrCel;
  755.     Gd,Gm : integer;
  756.   begin
  757.   InitCTimer;
  758.   BiosPtr := ptr($40,0);
  759.   KeyBuf := ptr($40,0);
  760.   KeyBufSta := BiosPtr^[$40];
  761.   KeyBufEnd := BiosPtr^[$41];
  762.   CurCha := ptr($40,$1a);
  763.   NexOpe := ptr($40,$1c);
  764.   TrapBreak := false;
  765.   CheckBreak := true;
  766.   CheckEOF := false;
  767.   CheckSnow := false;
  768.   DirectVideo := true;
  769.   LastMode := KeyBuf^[$49];
  770.   TextAttr := 7;
  771.   CrtMaxX := 79;
  772.   CrtMaxX := 80;
  773.   CurAct := true;
  774.   {
  775.   | Set up exit code
  776.   }
  777.   ExiSav := ExitProc;
  778.   ExitProc := @PilWinExi;
  779.   {
  780.   | Set mode to highest graphics mode
  781.   }
  782.   I := RegisterBGIdriver(@EGAVGADriverProc);
  783.   Gd := VGA;
  784.   Gm := VGAMed;
  785.   initgraph(Gd,Gm,'');
  786.   new(ScrSta);
  787.   TextMode(LastMode);
  788.   {
  789.   | Reroute write(ln) output
  790.   }
  791.   with textrec(output) do
  792.     begin
  793.     OpenFunc := @CrtOpe;
  794.     InOutFunc := @CrtOut;
  795.     FlushFunc := @CrtOut;
  796.     end;
  797.   {
  798.   | Reroute read(ln) output
  799.   }
  800.   with textrec(input) do
  801.     begin
  802.     OpenFunc := @CrtOpe;
  803.     InOutFunc := @CrtIn;
  804.     FlushFunc := @CrtInFlu;
  805.     end;
  806.   end;{ PilWinIni }
  807.  
  808. {
  809. |=============================================================================
  810. | INTERFACE FUNCTIONS
  811. |=============================================================================
  812. }
  813.  
  814. procedure AssignCrt( var F : text );
  815.   begin
  816.   with textrec(F) do
  817.     begin
  818.     Handle := $FFFF;
  819.     Mode := fmClosed;
  820.     BufSize := 128;
  821.     new(BufPtr);
  822.     Name[0] := #0;
  823.     OpenFunc := @AssCrtOpe;
  824.     end;
  825.   end;{ AssignCrt }
  826.  
  827. procedure ClrEol;
  828.   var
  829.     X,Y,C,
  830.     X0,Y0,X1,Y1 : word;
  831.   begin
  832.   ScrCel(C).Cha := ' ';
  833.   ScrCel(C).Att := TextAttr;
  834.   Y := (MinMax(WindMin).Y+CurY) * CrtMaxX;
  835.   for X:=MinMax(WindMin).X+CurX to MinMax(WindMax).X do
  836.     ScrSta^[X+Y] := C;
  837.   X0 := (MinMax(WindMin).X+CurX)*8;
  838.   X1 := (MinMax(WindMax).X)*8+7;
  839.   Y0 := (MinMax(WindMin).Y+CurY)*ChaHgt;
  840.   Y1 := Y0 + ChaHgt - 1;
  841.   setfillstyle( Solidfill,(textattr shr 4) and 7);
  842.   bar( X0,Y0,X1,Y1 );
  843.   end;{ ClrEol }
  844.  
  845. procedure ClrScr;
  846.   var
  847.     X,Y,C,YO,
  848.     X0,Y0,X1,Y1 : word;
  849.   begin
  850.   x0 := MinMax(WindMin).X;
  851.   y0 := MinMax(WindMin).Y;
  852.   x1 := MinMax(WindMax).X;
  853.   y1 := MinMax(WindMax).Y;
  854.   ScrCel(C).Cha := ' ';
  855.   ScrCel(C).Att := TextAttr;
  856.   for Y:=Y0 to Y1 do
  857.     begin
  858.     Yo := Y*CrtMaxX;
  859.     for X:=X0 to X1 do
  860.       ScrSta^[X+YO] := C;
  861.     end;
  862.   X0 := X0*8;
  863.   X1 := X1*8+7;
  864.   Y0 := Y0*ChaHgt;
  865.   Y1 := Y1*ChaHgt+ChaHgt-1;
  866.   setfillstyle( Solidfill,(textattr shr 4) and 7);
  867.   bar( X0,Y0,X1,Y1 );
  868.   gotoxy(1,1);
  869.   end;{ ClrScr }
  870.  
  871. procedure CurOff;
  872.   var
  873.     Sx,Sy,Gx,Gy,C : word;
  874.   begin
  875.   CurAct := false;
  876.   Sx := MinMax(WindMin).X+CurX;
  877.   Sy := MinMax(WindMin).Y+CurY;
  878.   C := ScrSta^[Sx+Sy*CrtMaxX];
  879.   PutChar( ord(ScrCel(C).Cha),Sx,Sy,(ScrCel(C).Att and $0F),(ScrCel(C).Att and $F0) shr 4 );
  880.   end;{ CurOff }
  881.  
  882. procedure CurOn;
  883.   var
  884.     Sx,Sy,Gx,Gy : word;
  885.   begin
  886.   CurAct := true;
  887.   Sx := MinMax(WindMin).X+CurX;
  888.   Sy := MinMax(WindMin).Y+CurY;
  889.   Gy := Sy * ChaHgt;
  890.   Gx := Sx * 8;
  891.   PutCur( Gx,Gy );
  892.   end;{ CurOn }
  893.  
  894. procedure DelLine;
  895.   var
  896.     Y,T0,T1 : word;
  897.     Sx0,Sy0,Sx1,Sy1 : word;
  898.     CA : boolean;
  899.   begin
  900.   CA := CurAct;
  901.   if CA then
  902.     CurOff;
  903.   Sx0 := MinMax(WindMin).X;
  904.   Sy0 := MinMax(WindMin).Y + CurY;
  905.   Sx1 := MinMax(WindMax).X;
  906.   Sy1 := MinMax(WindMax).Y;
  907.   T0 := Sx0+Sy0*CrtMaxX;
  908.   T1 := T0 + CrtMaxX;
  909.   for Y:=Sy0 to Sy1-1 do
  910.     begin
  911.     move( ScrSta^[T1],ScrSta^[T0],(Sx1-Sx0+1)*2 );
  912.     inc(T0,CrtMaxX);
  913.     inc(T1,CrtMaxX)
  914.     end;
  915.  
  916.   ScrollUp( MinMax(WindMin).X,Sy0,
  917.             (MinMax(WindMax).X-MinMax(WindMin).X)+1,
  918.             (MinMax(WindMax).Y-Sy0+1) );
  919.   Y := CurY;
  920.   gotoxy( 1,Sy1-Sy0+1 );
  921.   clreol;
  922.   gotoxy( 1,Y+1 );
  923.   if CA then CurOn;
  924.   end;{ DelLine }
  925.  
  926. function GetScreenCell( X,Y : word ) : word;
  927.   begin
  928.   if (X>0) and (Y>0) and (X<=CrtMaxX) and (Y<=CrtMaxY) then
  929.     GetScreenCell := ScrSta^[X+Y*CrtMaxX]
  930.   else
  931.     GetScreenCell := 0
  932.   end;
  933.  
  934. procedure GotoXY( X,Y : word );
  935.   var
  936.     Sx,Sy,Gx,Gy,C : word;
  937.   begin
  938.   if (X<1) or (Y<1) or (X>80) or (Y>CrtMaxY) then exit;
  939.   CurX := X-1;
  940.   CurY := Y-1;
  941.   if CurAct then
  942.     begin
  943.     if OldCurX<>-1 then
  944.       begin
  945.       Sx := OldCurX;
  946.       Sy := OldCurY;
  947.       C := ScrSta^[Sx+Sy*CrtMaxX];
  948.       PutChar( ord(ScrCel(C).Cha),Sx,Sy,(ScrCel(C).Att and $0F),(ScrCel(C).Att and $F0) shr 4 );
  949.       end;
  950.     Sx := MinMax(WindMin).X+CurX;
  951.     Sy := MinMax(WindMin).Y+CurY;
  952.     OldCurX := Sx;
  953.     OldCurY := Sy;
  954.     Gx := Sx * 8;
  955.     Gy := Sy * ChaHgt;
  956.     PutCur( Gx,Gy )
  957.     end;
  958.   end;{ GotoXY }
  959.  
  960. procedure HighVideo;
  961.   begin
  962.   TextAttr := TextAttr or 8
  963.   end;
  964.  
  965. procedure InsLine;
  966.   var
  967.     Y,T0,T1 : word;
  968.     Sx0,Sy0,Sx1,Sy1 : word;
  969.     CA : boolean;
  970.   begin
  971.   CA := CurAct;
  972.   if CA then
  973.     CurOff;
  974.   Sx0 := MinMax(WindMin).X;
  975.   Sy0 := MinMax(WindMin).Y + CurY;
  976.   Sx1 := MinMax(WindMax).X;
  977.   Sy1 := MinMax(WindMax).Y;
  978.   T0 := Sx0+Sy1*CrtMaxX;
  979.   T1 := T0 - CrtMaxX;
  980.   for Y:=Sy0 to Sy1-1 do
  981.     begin
  982.     move( ScrSta^[T1],ScrSta^[T0],(Sx1-Sx0+1)*2 );
  983.     dec(T0,CrtMaxX);
  984.     dec(T1,CrtMaxX)
  985.     end;
  986.  
  987.   ScrollDown( MinMax(WindMin).X,Sy0,
  988.               (MinMax(WindMax).X-MinMax(WindMin).X)+1,
  989.               (MinMax(WindMax).Y-Sy0+1) );
  990.   CurX := 0;
  991.   clreol;
  992.   if CA then
  993.     CurOn;
  994.   end;{ InsLine }
  995.  
  996. procedure LowVideo;
  997.   begin
  998.   TextAttr := TextAttr and 247
  999.   end;
  1000.  
  1001. procedure NormVideo;
  1002.   begin
  1003.   TextAttr := (TextAttr and $F0) or Lightgray
  1004.   end;
  1005.  
  1006. procedure SetChar( C : char ;X,Y : word );
  1007.   var
  1008.     SC : ScrCel;
  1009.   begin
  1010.   if (X>0) and (Y>0) and (X<=CrtMaxX) and (Y<=CrtMaxY) then
  1011.     begin
  1012.     SC.Cha := C;
  1013.     SC.Att := TextAttr;
  1014.     ScrSta^[X+Y*CrtMaxX] := word(SC);
  1015.     PutChar( ord(C),X,Y,(TextAttr and $0F),(TextAttr and $F0) shr 4 );
  1016.     end
  1017.   end;
  1018.  
  1019. procedure TextBackground( Color : byte );
  1020.   begin
  1021.   TextAttr := (TextAttr and 143) or ((Color and 7) shl 4)
  1022.   end;
  1023.  
  1024. procedure TextColor( Color : byte );
  1025.   begin
  1026.   if (Color and 240)<>0 then
  1027.     Color := (Color and 15) or 128;
  1028.   TextAttr := (TextAttr and 112) or Color
  1029.   end;
  1030.  
  1031. procedure Window( X0,Y0,X1,Y1 : word );
  1032.   var
  1033.     CA : boolean;
  1034.   begin
  1035.   if (X0<X1) and (Y0<Y1) and
  1036.      ((X0-1)>=0) and
  1037.      ((Y0-1)>=0) and
  1038.      (X1<=CrtMaxX) and
  1039.      (Y1<=CrtMaxY) then
  1040.        begin
  1041.        CA := CurAct;
  1042.        if CA then CurOff;
  1043.        MinMax(WindMin).X := X0-1;
  1044.        MinMax(WindMin).Y := Y0-1;
  1045.        MinMax(WindMax).X := X1-1;
  1046.        MinMax(WindMax).Y := Y1-1;
  1047.        CurAct := CA;
  1048.        gotoxy(1,1)
  1049.        end
  1050.   end;{ Window }
  1051.  
  1052. procedure TextMode( Mode : word );
  1053.   type
  1054.     bp = ^byte;
  1055.     Grec = record
  1056.         O: word;
  1057.         S: word;
  1058.         end;
  1059.   var
  1060.     C : ScrCel;
  1061.     I : word;
  1062.     Gd,Gm : integer;
  1063.   begin
  1064.   case Mode of
  1065.     CO80,
  1066.     T80x25 : begin { 640x350 with 8x14  or 640x200 with 8x8}
  1067.              setgraphmode(VGAMed);
  1068.              FontTable := @Text8x14;
  1069.              ChaHgt := bp(FontTable)^;
  1070.              CrtMaxY := 25;
  1071.              inc(Grec(FontTable).O);
  1072.              end;
  1073.     T80x34 : begin { 640x480 with 8x14 }
  1074.              setgraphmode(VGAHi);
  1075.              FontTable := @Text8x14;
  1076.              ChaHgt := bp(FontTable)^;
  1077.              CrtMaxY := 34;
  1078.              inc(Grec(FontTable).O);
  1079.              end;
  1080.     T80x60 : begin { 640x480 with 8x8  }
  1081.              setgraphmode(VGAHi);
  1082.              FontTable := @Text8x8;
  1083.              ChaHgt := bp(FontTable)^;
  1084.              CrtMaxY := 60;
  1085.              inc(Grec(FontTable).O);
  1086.              end;
  1087.     T80x43 : begin { 640x350 with 8x8  }
  1088.              setgraphmode(VGAMed);
  1089.              FontTable := @Text8x8;
  1090.              ChaHgt := bp(FontTable)^;
  1091.              CrtMaxY := 43;
  1092.              inc(Grec(FontTable).O);
  1093.              end;
  1094.     else
  1095.       begin
  1096.       setgraphmode(VGAMed);
  1097.       FontTable := @Text8x14;
  1098.       ChaHgt := bp(FontTable)^;
  1099.       CrtMaxY := 25;
  1100.       inc(Grec(FontTable).O);
  1101.       end
  1102.     end;
  1103.   C.Cha := ' ';
  1104.   C.Att := textattr;
  1105.   for I:=0 to CrtMaxX*CrtMaxY do
  1106.     ScrSta^[I] := word(C);
  1107.   windmin := 0;
  1108.   MinMax(windmax).Y := CrtMaxY-1;
  1109.   MinMax(windmax).X := 79;
  1110.   CurX := 0;
  1111.   CurY := 0;
  1112.   OldCurY := -1;
  1113.   OldCurX := -1;
  1114.   gotoxy(1,1)
  1115.   end;
  1116.  
  1117. function Keypressed : boolean;
  1118.   begin
  1119.   KeyPressed := CurCha^ <> NexOpe^
  1120.   end;
  1121.  
  1122. procedure CheckCrtlBreak;
  1123.   begin
  1124.   if CurCha^=NexOpe^ then exit;
  1125.   if (BiosPtr^[CurCha^ div 2]=0) or BreakPressed then halt
  1126.   end;
  1127.  
  1128. function ReadKey : char;
  1129.   begin
  1130.   if Extended then
  1131.     begin
  1132.     ReadKey := chr(KeyBuf^[CurCha^+1]);
  1133.     Extended := false;
  1134.     inc(CurCha^,2);
  1135.     if CurCha^=KeyBufEnd then
  1136.       CurCha^ := KeyBufSta
  1137.     end
  1138.   else
  1139.     begin
  1140.     while CurCha^=NexOpe^ do;
  1141.     ReadKey := chr(KeyBuf^[CurCha^]);
  1142.     if KeyBuf^[CurCha^]=0 then
  1143.       if (KeyBuf^[CurCha^+1]=0) and not CheckBreak then
  1144.         if TrapBreak then
  1145.           Extended := true
  1146.         else
  1147.           CurCha^ := NexOpe^
  1148.       else
  1149.         begin
  1150.         BreakPressed := true;
  1151.         CurCha^ := NexOpe^
  1152.         end
  1153.     else
  1154.       begin
  1155.       Extended := false;
  1156.       inc(CurCha^,2);
  1157.       if CurCha^=KeyBufEnd then
  1158.         CurCha^ := KeyBufSta
  1159.       end;
  1160.     end;
  1161.   end;
  1162.  
  1163. function WhereX : word;
  1164.   begin
  1165.   WhereX := CurX + 1
  1166.   end;{ WhereX }
  1167.  
  1168. function WhereY : word;
  1169.   begin
  1170.   WhereY := CurY + 1
  1171.   end;{ WhereY }
  1172.  
  1173. BEGIN
  1174. PilWinIni
  1175. END.