home *** CD-ROM | disk | FTP | other *** search
- UNIT Crtg;
- {
- | This unit is a direct replacement for the CRT unit shipped with Turbo Pascal.
- | It has been tested with version 5.5 but should work with versions 4 and 5 as
- | well. It will probably work with version 6 but I have not tested it. This
- | unit uses only the GRAPH unit. The major benifit to this unit is that it
- | allows the use of the graphics operations in GRAPH to be used while doing
- | normal text operations.
- |
- | Modifications have been made to the way Read(ln) works. When erasing
- | character on the input line the cursor will move back along the entire
- | input line even if it has wrapped at the right edge of the window. If the
- | window was scrolled up because the input line went past the lower edge of
- | the window and if the start of the input line was scrolled off the screen
- | it will be replaced as the cursor moves up the window.
- |
- | Assumptions: The video system supports all the VGA modes in a form
- | compatable with IBM VGA.
- |
- | When this unit is used it will replace the drivers on Input and Output for
- | Write(ln) and Read(ln). I/O redirection is NOT supported. If the CRT unit
- | is used and comes after this unit then the functions in this unit will be
- | mostly useless.
- |
- | Some of the assembly code is from other sources. These are:
- |
- | Programmer's Guide to PC & PS/2 Video Systems.
- | Richard Wilton, Microsoft Press.
- |
- | CRT unit from Borland's Turbo Pascal Version 5.0
- |
- | The code is marked in the assembler files.
- |
- | If you use this code I would appreciate being given credit for it. If you
- | find problems with it, other than it won't work with your video card,
- | please send mail to tsmith@plains.nodak.edu
- |
- | Hope somebody can use this,
- | Tim Smith
- |
- }
-
- INTERFACE
-
- const
- {
- | Color constants
- }
- Black = 0;
- Blue = 1;
- Green = 2;
- Cyan = 3;
- Red = 4;
- Magenta = 5;
- Brown = 6;
- LightGray = 7;
- DarkGray = 8;
- LightBlue = 9;
- LightGreen = 10;
- LightCyan = 11;
- LightRed = 12;
- LightMagenta = 13;
- Yellow = 14;
- White = 15;
-
- {
- | Mode constants
- }
- BW40 = 0; { not supported }
- BW80 = 2; { is considered to be CO80 }
- Mono = 7; { not supported }
- CO40 = 1; { not supported }
- CO80 = 3;
- Font8x8 = 256;
- C40 = CO40; { not supported }
- C80 = CO80;
- T80x25 = 128; { 80 cols x 25 rows : default VGA 640x350 Font: 8x14 }
- T80x34 = 129; { 80 cols x 34 rows VGA 640x480 8x14 }
- T80x60 = 130; { 80 cols x 60 rows VGA 640x480 8x8 }
- T80x43 = 256; { 80 cols x 43 rows VGA 640x350 8x8 }
-
- var
- TrapBreak : boolean; { See Readkey }
- CheckBreak : boolean;
- CheckEOF : boolean;
- CheckSnow : boolean; { not used }
- DirectVideo : boolean; { not used }
- LastMode : byte;
- TextAttr : byte;
- WindMin : word;
- WindMax : word;
-
- {
- |=============================================================================
- | These functions/procedures are replacements for the CRT unit functions
- |=============================================================================
- }
- procedure AssignCrt( var F : text );
-
- procedure ClrEol;
-
- procedure ClrScr;
-
- procedure Delay( ms : word );
-
- procedure DelLine;
-
- procedure GotoXY( X,Y : word );
-
- procedure HighVideo;
-
- procedure InsLine;
-
- procedure LowVideo;
-
- procedure NormVideo;
-
- procedure NoSound;
-
- procedure Sound( Hz : word );
-
- procedure TextBackground( Color : byte );
-
- procedure TextColor( Color : byte );
-
- procedure TextMode( Mode : word );
-
- procedure Window( X0,Y0,X1,Y1: word );
-
- function KeyPressed : boolean;
-
- {
- | If the flag CheckBreak is false it is possible to detect the Ctrl-Break
- | sequence with Readkey. The Ctrl-Break sequence will be treated as an
- | extended key press if the flag TrapBreak is true. If TrapBreak is false
- | Ctrl-Break will be ignored. The value of Ctrl-Break is #0 followed by a
- | second #0.
- }
- function ReadKey : char;
-
- function WhereX : word;
-
- function WhereY : word;
-
- {
- |=============================================================================
- | These functions/procedures are additions to the CRT unit functions
- |=============================================================================
- }
- {
- | Turns cursor off. The character underneath is restored.
- }
- procedure CurOff;
-
- {
- | Turns the cursor on. The cursor does NOT flash.
- }
- procedure CurOn;
-
- {
- | Returns a the word containing the character and it's color attribute from
- | the text position X,Y. If X,Y is outside of the current screen range 0 is
- | returned.
- }
- function GetScreenCell( X,Y : word ) : word;
-
- {
- | Puts the character C at text position X,Y with current attributes. If X,Y
- | is outside of the current screen range nothing is done. This procedure is
- | the only way to update the character storage area.
- }
- procedure SetChar( C : char; X,Y : word );
-
- IMPLEMENTATION
-
- uses
- graph;
-
- {
- | File constants. Did not want to use DOS unit.
- }
- const
- fmClosed = $D7B0;
- fmInput = $D7B1;
- fmOutput = $D7B2;
- fmInOut = $D7B3;
- CrtMaxX : word = 80;
- CrtMaxY : word = 25;
-
- type
-
- BiosArrayW = array[0..32000] of word;
- BiosArrayB = array[0..64000] of byte;
-
- BufTyp = array[0..4800] of word;
- BufPtr = ^BufTyp;
-
- ScrCel = record
- Cha : char;
- Att : byte
- end;
-
- MinMax = record
- X,Y : byte
- end;
-
- {
- |Textfile record Again I did not want to use DOS.
- }
- TextBuf = array[0..127] of Char;
- TextRec = record
- Handle: Word;
- Mode: Word;
- BufSize: Word;
- Private: Word;
- BufPos: Word;
- BufEnd: Word;
- BufPtr: ^TextBuf;
- OpenFunc: Pointer;
- InOutFunc: Pointer;
- FlushFunc: Pointer;
- CloseFunc: Pointer;
- UserData: array[1..16] of Byte;
- Name: array[0..79] of Char;
- Buffer: TextBuf;
- end;
-
- var
- Extended, { is an extended key press available }
- CurAct, { is the cursor on }
- BreakPressed : boolean; { has Ctrl-Break been pressed }
- OldCurX, { last position of cursor }
- OldCurY : integer;
- CurX, { current position of cursor }
- CurY, { origin at 0,0 relative to window }
- KeyBufSta, { start of keyboard buffer }
- KeyBufEnd : word; { end of keyboard buffer }
- BiosPtr : ^BiosArrayW; { array of words at $40:00 }
- KeyBuf : ^BiosArrayB; { array of bytes at $40:00 }
- CurCha, { current available character in buffer }
- NexOpe : ^word; { next open spot in buffer }
- ScrSta : BufPtr; { screen storage area }
- ExiSav, { execute closegraph when done }
- FontTable : pointer; { which font? }
- ChaHgt : byte; { character height }
-
-
- {
- |=============================================================================
- | SUPPORT FUNCTIONS
- |=============================================================================
- }
-
- {$F+}
- procedure EgaVgaDriverProc; external; {$L EGAVGA.OBJ }
-
- procedure Text8x14; external; {$L text8x14.OBJ}
-
- procedure Text8x8; external; {$L text8x8.OBJ}
-
- procedure ScrollUp( X,Y,Len,Dep : word ); external;
-
- procedure ScrollDown( X,Y,Len,Dep : word ); external;
-
- procedure PutChar( C,X,Y : word;
- Fgd,Bkg : byte ); external;
-
- procedure Delay( ms : word ); external;
-
- procedure NoSound; external;
-
- procedure Sound( Hz : word ); external;
-
- procedure InitCTimer; external;
- {$L crtg.obj}
- {$F-}
-
- {
- | Puts the cursor at Graphical X,Y
- }
- procedure PutCur( X,Y : word );
- begin
- setcolor( TextAttr and 15);
- line( X+1,Y+ChaHgt-1,X+7,Y+ChaHgt-1 );
- line( X+1,Y+ChaHgt-2,X+7,Y+ChaHgt-2 );
- end;{ PutCur }
-
-
- {$F+}
- {
- | OutPut functions assigned to OUTPUT
- }
- function CrtOut( var Win : TextRec ) : integer;
- type
- ChaBuf = array[0..64000] of char;
- ChaPtr = ^ChaBuf;
- var
- CX,CY,I,Y,
- MaxX,MaxY,
- MinX,MinY : word;
- C : ScrCel;
- CPtr : ChaPtr;
- CA : boolean;
- begin
- if Win.BufPos=0 then
- begin
- CrtOut := 0;
- exit;
- end;
- CA := CurAct;
- if CA then
- CurOff;
- CPtr := ChaPtr(Win.BufPtr);
- MinX := MinMax(WindMin).X;
- MinY := MinMax(WindMin).Y;
- MaxX := MinMax(WindMax).X;
- MaxY := MinMax(WindMax).Y;
- CX := MinX + CurX;
- CY := MinY + CurY;
- for I:=0 to Win.BufPos-1 do
- begin
- case CPtr^[I] of
- #7 : begin
- sound(220);
- delay(200)
- end; { beep }
- #8 : if CX>MinX then
- begin
- dec(CX);
- dec(CurX)
- end;
- #10 : begin { LineFeed }
- if CY<MaxY then
- begin
- inc(CurY);
- inc(CY);
- end
- else
- begin
- Y := CurY;
- CurY := 0;
- DelLine;
- CurY := Y
- end
- end;
- #13 : begin
- CurX := 0;
- CX := MinX;
- end;
- else
- if CPtr^[I]>=' ' then
- begin
- C.Cha := CPtr^[I];
- C.Att := textattr;
- ScrSta^[CX + CY*CrtMaxX] := word(C);
- PutChar( ord(CPtr^[I]),CX,CY,(textattr and $0F),(textattr and $F0) shr 4 );
- if CX<MaxX then
- begin
- inc( CurX );
- inc( CX );
- end
- else
- begin
- CurX := 0;
- CX := MinX;
- if CY<MaxY then
- begin
- inc(CurY);
- inc(CY);
- end
- else
- begin
- Y := CurY;
- CurY := 0;
- DelLine;
- CurY := Y
- end
- end
- end
- end;
- end;
- Win.BufPos := 0;
- CrtOut := 0;
- if CA then
- begin
- OldCurX := CurX;
- OldCurY := CurY;
- CurOn
- end;
- end;{ WinIO }
-
- var
- ReadDon : boolean;
- LastLine : string;
-
- {
- |
- }
- function CrtIn( var Win : TextRec ) : integer;
- type
- ChaTyp = array[1..64000] of char;
- ChaPtr = ^ChaTyp;
- var
- FY,FX,Y,X : word;
- CX,CY,LI : word;
- C : ScrCel;
- I,Imax,J : word;
- CPtr : ChaPtr;
- Ch : char;
- CA,Don : boolean;
- BacOff : array[0..255] of word;
- BacOffLen : word;
- begin
- Imax := Win.BufSize;
- CPtr := ChaPtr(Win.BufPtr);
- CA := CurAct;
- CX := MinMax(WindMin).X+CurX;
- CY := MinMax(WindMin).Y+CurY;
- FY := CurY;
- FX := CurX;
- I := 1;
- BacOffLen := 0;
- ReadDon := false;
- LI := 0;
- while not ReadDon do
- begin
- Don := false;
- while not Don do
- begin
- Ch := readkey;
- if keypressed then
- begin
- Ch := readkey;
- Don := false
- end
- else
- Don := true
- end;
- if (Ch=^D) and (I<=length(LastLine)) then
- Ch := LastLine[I];
- if (Ch=^F) and (I<=length(LastLine)) then
- begin
- if CA then
- CurOff;
- for J:=I to length(LastLine) do
- begin
- if J<Imax then
- begin
- CPtr^[J] := LastLine[J];
- C.Cha := LastLine[J];
- C.Att := textattr;
- ScrSta^[CX + CY*CrtMaxX] := word(C);
- PutChar( ord(LastLine[J]),CX,CY,(textattr and $0F),(textattr and $F0) shr 4 );
- if CX<MinMax(WindMax).X then
- begin
- inc( CurX );
- inc( CX )
- end
- else
- begin
- CurX := 0;
- CX := MinMax(WindMin).X;
- if CY<MinMax(WindMax).Y then
- begin
- inc(CurY);
- inc(CY)
- end
- else
- begin
- inc(LI);
- Y := MinMax(WindMin).Y*CrtMaxX;
- for X:=MinMax(WindMin).X to MinMax(WindMax).X do
- begin
- BacOff[BacOffLen] := ScrSta^[X+Y];
- inc(BacOffLen)
- end;
- Y := CurY;
- CurY := 0;
- DelLine;
- CurY := Y
- end
- end;
- end;
- end;
- I := length(LastLine)+1;
- if CA then
- CurOn;
- end;
- case Ch of
- ^F : ;
- ^A,#27 : begin
- if CA then CurOff;
- if LI>FY then
- begin
- clrscr;
- BacOffLen := 0;
- FY := 0;
- CurX := FX;
- CurY := FY;
- CY := MinMax(WindMin).Y;
- CX := MinMax(WindMin).X;
- if FX>0 then
- begin
- Y := CY*CrtMaxX;
- for X:=0 to (FX-1) do
- begin
- C := ScrCel(BacOff[X]);
- ScrSta^[X+Y] := word(C);
- PutChar( byte(C.Cha),CX+X,CY,(C.Att and $0F),(C.Att and $F0) shr 4 );
- end
- end;
- CX := CX + FX
- end
- else
- begin
- FY := FY - LI;
- Y := CurY;
- CurX := 0;
- for CurY:=Y downto (FY+1) do
- clreol;
- CurX := FX;
- CurY := FY;
- clreol;
- CY := MinMax(WindMin).Y + CurY;
- CX := MinMax(WindMin).X + FX;
- end;
- LI := 0;
- I := 1;
- if CA then CurOn;
- end;
- ^S,#8 : begin
- if CA then
- CurOff;
- if I>1 then
- begin
- dec(I);
- if CurX>0 then
- begin
- dec(CurX);
- dec(CX);
- C.Cha := ' ';
- C.Att := textattr;
- ScrSta^[CX + CY*CrtMaxX] := word(C);
- PutChar( 32,CX,CY,(textattr and $0F),(textattr and $F0) shr 4 );
- end
- else
- if CurY>0 then
- begin
- dec(CurY);
- dec(CY);
- CX := MinMax(WindMax).X;
- CurX := CX - MinMax(WindMin).X;
- C.Cha := ' ';
- C.Att := textattr;
- ScrSta^[CX + CY*CrtMaxX] := word(C);
- PutChar( 32,CX,CY,(textattr and $0F),(textattr and $F0) shr 4 );
- end
- else
- begin
- Y := MinMax(WindMin).Y*CrtMaxX;
- for X:=MinMax(WindMax).X downto MinMax(WindMin).X do
- begin
- dec(BacOffLen);
- ScrSta^[X+Y] := BacOff[BacOffLen];
- C := ScrCel(BacOff[BacOffLen]);
- PutChar( byte(C.Cha),X,CY,(C.Att and $0F),(C.Att and $F0) shr 4 );
- end;
- CX := MinMax(WindMax).X;
- CurX := CX - MinMax(WindMin).X;
- C.Cha := ' ';
- C.Att := textattr;
- ScrSta^[CX + CY*CrtMaxX] := word(C);
- PutChar( 32,CX,CY,(textattr and $0F),(textattr and $F0) shr 4 );
- end;
- end;
- if CA then
- CurOn;
- end;
- #10 : begin { LineFeed }
- if CA then
- CurOff;
- if I<Imax then
- if CY<MinMax(WindMax).Y then
- begin
- inc(CY);
- inc(CurY);
- end
- else
- begin
- inc(LI);
- Y := MinMax(WindMin).Y*CrtMaxX;
- for X:=MinMax(WindMin).X to MinMax(WindMax).X do
- begin
- BacOff[BacOffLen] := ScrSta^[X+Y];
- inc(BacOffLen)
- end;
- Y := CurY;
- CurY := 0;
- DelLine;
- CurY := Y
- end;
- if CA then
- CurOn
- end;
- #13 : begin
- if CA then
- CurOff;
- CurX := 0;
- if CY<MinMax(WindMax).Y then
- begin
- inc(CY);
- inc(CurY)
- end
- else
- begin
- Y := CurY;
- CurY := 0;
- DelLine;
- CurY := Y
- end;
- CPtr^[I] := #13;
- if I<Imax then
- begin
- inc(I);
- CPtr^[I] := #10
- end;
- ReadDon := true;
- if CA then
- CurOn
- end;
- else
- if Ch>=' ' then
- begin
- if CA then
- CurOff;
- if I<Imax then
- begin
- C.Cha := Ch;
- C.Att := textattr;
- ScrSta^[CX + CY*CrtMaxX] := word(C);
- PutChar( ord(Ch),CX,CY,(textattr and $0F),(textattr and $F0) shr 4 );
- if CX<MinMax(WindMax).X then
- begin
- inc( CurX );
- inc( CX )
- end
- else
- begin
- CurX := 0;
- CX := MinMax(WindMin).X;
- if CY<MinMax(WindMax).Y then
- begin
- inc(CurY);
- inc(CY)
- end
- else
- begin
- inc(LI);
- Y := MinMax(WindMin).Y*CrtMaxX;
- for X:=MinMax(WindMin).X to MinMax(WindMax).X do
- begin
- BacOff[BacOffLen] := ScrSta^[X+Y];
- inc(BacOffLen)
- end;
- Y := CurY;
- CurY := 0;
- DelLine;
- CurY := Y
- end
- end;
- end;
- if CA then
- CurOn;
- end
- end;{ case }
- if pos(Ch,#8+^F+^D+^S+^A+#27+^Z+#13)=0 then
- begin
- CPtr^[I] := Ch;
- if I<Imax then
- inc(I)
- end
- end;{ while }
- Win.BufPos := 0;
- Win.BufEnd := I;
- for J:=1 to I do
- LastLine[J] := CPtr^[J];
- if LastLine[I]=#10 then
- byte(LastLine[0]) := I-2
- else
- byte(LastLine[0]) := I-1;
- CrtIn := 0;
- end;{ WinIn }
-
- function CrtInFlu( var Win : TextRec ) : integer;
- begin
- Win.BufPos := 0;
- Win.BufEnd := 0;
- CrtInFlu := 0;
- end;{ WinFlu }
-
- procedure PilWinExi;
- begin
- ExitProc := ExiSav;
- closegraph;
- end;{ PilWinExi }
-
- function CrtClo( var Win : TextRec ) : integer;
- begin
- dispose(Win.BufPtr);
- CrtClo := 0
- end;
-
- function CrtOpe( var Win : TextRec ) : integer;
- begin
- with Win do
- begin
- case Mode of
- fmInput : begin
- InOutFunc := @CrtIn;
- FlushFunc := @CrtInFlu;
- end;
- fmOutput : begin
- InOutFunc := @CrtOut;
- FlushFunc := @CrtOut;
- end;
- end;
- end;
- CrtOpe := 0
- end;
-
- function AssCrtOpe( var Win : TextRec ) : integer;
- begin
- with Win do
- begin
- case Mode of
- fmInput : begin
- InOutFunc := @CrtIn;
- FlushFunc := @CrtInFlu;
- end;
- fmOutput : begin
- InOutFunc := @CrtOut;
- FlushFunc := @CrtOut;
- end;
- end;
- CloseFunc := @CrtClo;
- end;
- AssCrtOpe := 0
- end;
- {$F-}
-
- procedure PilWinIni;
- var
- I : word;
- C : ScrCel;
- Gd,Gm : integer;
- begin
- InitCTimer;
- BiosPtr := ptr($40,0);
- KeyBuf := ptr($40,0);
- KeyBufSta := BiosPtr^[$40];
- KeyBufEnd := BiosPtr^[$41];
- CurCha := ptr($40,$1a);
- NexOpe := ptr($40,$1c);
- TrapBreak := false;
- CheckBreak := true;
- CheckEOF := false;
- CheckSnow := false;
- DirectVideo := true;
- LastMode := KeyBuf^[$49];
- TextAttr := 7;
- CrtMaxX := 79;
- CrtMaxX := 80;
- CurAct := true;
- {
- | Set up exit code
- }
- ExiSav := ExitProc;
- ExitProc := @PilWinExi;
- {
- | Set mode to highest graphics mode
- }
- I := RegisterBGIdriver(@EGAVGADriverProc);
- Gd := VGA;
- Gm := VGAMed;
- initgraph(Gd,Gm,'');
- new(ScrSta);
- TextMode(LastMode);
- {
- | Reroute write(ln) output
- }
- with textrec(output) do
- begin
- OpenFunc := @CrtOpe;
- InOutFunc := @CrtOut;
- FlushFunc := @CrtOut;
- end;
- {
- | Reroute read(ln) output
- }
- with textrec(input) do
- begin
- OpenFunc := @CrtOpe;
- InOutFunc := @CrtIn;
- FlushFunc := @CrtInFlu;
- end;
- end;{ PilWinIni }
-
- {
- |=============================================================================
- | INTERFACE FUNCTIONS
- |=============================================================================
- }
-
- procedure AssignCrt( var F : text );
- begin
- with textrec(F) do
- begin
- Handle := $FFFF;
- Mode := fmClosed;
- BufSize := 128;
- new(BufPtr);
- Name[0] := #0;
- OpenFunc := @AssCrtOpe;
- end;
- end;{ AssignCrt }
-
- procedure ClrEol;
- var
- X,Y,C,
- X0,Y0,X1,Y1 : word;
- begin
- ScrCel(C).Cha := ' ';
- ScrCel(C).Att := TextAttr;
- Y := (MinMax(WindMin).Y+CurY) * CrtMaxX;
- for X:=MinMax(WindMin).X+CurX to MinMax(WindMax).X do
- ScrSta^[X+Y] := C;
- X0 := (MinMax(WindMin).X+CurX)*8;
- X1 := (MinMax(WindMax).X)*8+7;
- Y0 := (MinMax(WindMin).Y+CurY)*ChaHgt;
- Y1 := Y0 + ChaHgt - 1;
- setfillstyle( Solidfill,(textattr shr 4) and 7);
- bar( X0,Y0,X1,Y1 );
- end;{ ClrEol }
-
- procedure ClrScr;
- var
- X,Y,C,YO,
- X0,Y0,X1,Y1 : word;
- begin
- x0 := MinMax(WindMin).X;
- y0 := MinMax(WindMin).Y;
- x1 := MinMax(WindMax).X;
- y1 := MinMax(WindMax).Y;
- ScrCel(C).Cha := ' ';
- ScrCel(C).Att := TextAttr;
- for Y:=Y0 to Y1 do
- begin
- Yo := Y*CrtMaxX;
- for X:=X0 to X1 do
- ScrSta^[X+YO] := C;
- end;
- X0 := X0*8;
- X1 := X1*8+7;
- Y0 := Y0*ChaHgt;
- Y1 := Y1*ChaHgt+ChaHgt-1;
- setfillstyle( Solidfill,(textattr shr 4) and 7);
- bar( X0,Y0,X1,Y1 );
- gotoxy(1,1);
- end;{ ClrScr }
-
- procedure CurOff;
- var
- Sx,Sy,Gx,Gy,C : word;
- begin
- CurAct := false;
- Sx := MinMax(WindMin).X+CurX;
- Sy := MinMax(WindMin).Y+CurY;
- C := ScrSta^[Sx+Sy*CrtMaxX];
- PutChar( ord(ScrCel(C).Cha),Sx,Sy,(ScrCel(C).Att and $0F),(ScrCel(C).Att and $F0) shr 4 );
- end;{ CurOff }
-
- procedure CurOn;
- var
- Sx,Sy,Gx,Gy : word;
- begin
- CurAct := true;
- Sx := MinMax(WindMin).X+CurX;
- Sy := MinMax(WindMin).Y+CurY;
- Gy := Sy * ChaHgt;
- Gx := Sx * 8;
- PutCur( Gx,Gy );
- end;{ CurOn }
-
- procedure DelLine;
- var
- Y,T0,T1 : word;
- Sx0,Sy0,Sx1,Sy1 : word;
- CA : boolean;
- begin
- CA := CurAct;
- if CA then
- CurOff;
- Sx0 := MinMax(WindMin).X;
- Sy0 := MinMax(WindMin).Y + CurY;
- Sx1 := MinMax(WindMax).X;
- Sy1 := MinMax(WindMax).Y;
- T0 := Sx0+Sy0*CrtMaxX;
- T1 := T0 + CrtMaxX;
- for Y:=Sy0 to Sy1-1 do
- begin
- move( ScrSta^[T1],ScrSta^[T0],(Sx1-Sx0+1)*2 );
- inc(T0,CrtMaxX);
- inc(T1,CrtMaxX)
- end;
-
- ScrollUp( MinMax(WindMin).X,Sy0,
- (MinMax(WindMax).X-MinMax(WindMin).X)+1,
- (MinMax(WindMax).Y-Sy0+1) );
- Y := CurY;
- gotoxy( 1,Sy1-Sy0+1 );
- clreol;
- gotoxy( 1,Y+1 );
- if CA then CurOn;
- end;{ DelLine }
-
- function GetScreenCell( X,Y : word ) : word;
- begin
- if (X>0) and (Y>0) and (X<=CrtMaxX) and (Y<=CrtMaxY) then
- GetScreenCell := ScrSta^[X+Y*CrtMaxX]
- else
- GetScreenCell := 0
- end;
-
- procedure GotoXY( X,Y : word );
- var
- Sx,Sy,Gx,Gy,C : word;
- begin
- if (X<1) or (Y<1) or (X>80) or (Y>CrtMaxY) then exit;
- CurX := X-1;
- CurY := Y-1;
- if CurAct then
- begin
- if OldCurX<>-1 then
- begin
- Sx := OldCurX;
- Sy := OldCurY;
- C := ScrSta^[Sx+Sy*CrtMaxX];
- PutChar( ord(ScrCel(C).Cha),Sx,Sy,(ScrCel(C).Att and $0F),(ScrCel(C).Att and $F0) shr 4 );
- end;
- Sx := MinMax(WindMin).X+CurX;
- Sy := MinMax(WindMin).Y+CurY;
- OldCurX := Sx;
- OldCurY := Sy;
- Gx := Sx * 8;
- Gy := Sy * ChaHgt;
- PutCur( Gx,Gy )
- end;
- end;{ GotoXY }
-
- procedure HighVideo;
- begin
- TextAttr := TextAttr or 8
- end;
-
- procedure InsLine;
- var
- Y,T0,T1 : word;
- Sx0,Sy0,Sx1,Sy1 : word;
- CA : boolean;
- begin
- CA := CurAct;
- if CA then
- CurOff;
- Sx0 := MinMax(WindMin).X;
- Sy0 := MinMax(WindMin).Y + CurY;
- Sx1 := MinMax(WindMax).X;
- Sy1 := MinMax(WindMax).Y;
- T0 := Sx0+Sy1*CrtMaxX;
- T1 := T0 - CrtMaxX;
- for Y:=Sy0 to Sy1-1 do
- begin
- move( ScrSta^[T1],ScrSta^[T0],(Sx1-Sx0+1)*2 );
- dec(T0,CrtMaxX);
- dec(T1,CrtMaxX)
- end;
-
- ScrollDown( MinMax(WindMin).X,Sy0,
- (MinMax(WindMax).X-MinMax(WindMin).X)+1,
- (MinMax(WindMax).Y-Sy0+1) );
- CurX := 0;
- clreol;
- if CA then
- CurOn;
- end;{ InsLine }
-
- procedure LowVideo;
- begin
- TextAttr := TextAttr and 247
- end;
-
- procedure NormVideo;
- begin
- TextAttr := (TextAttr and $F0) or Lightgray
- end;
-
- procedure SetChar( C : char ;X,Y : word );
- var
- SC : ScrCel;
- begin
- if (X>0) and (Y>0) and (X<=CrtMaxX) and (Y<=CrtMaxY) then
- begin
- SC.Cha := C;
- SC.Att := TextAttr;
- ScrSta^[X+Y*CrtMaxX] := word(SC);
- PutChar( ord(C),X,Y,(TextAttr and $0F),(TextAttr and $F0) shr 4 );
- end
- end;
-
- procedure TextBackground( Color : byte );
- begin
- TextAttr := (TextAttr and 143) or ((Color and 7) shl 4)
- end;
-
- procedure TextColor( Color : byte );
- begin
- if (Color and 240)<>0 then
- Color := (Color and 15) or 128;
- TextAttr := (TextAttr and 112) or Color
- end;
-
- procedure Window( X0,Y0,X1,Y1 : word );
- var
- CA : boolean;
- begin
- if (X0<X1) and (Y0<Y1) and
- ((X0-1)>=0) and
- ((Y0-1)>=0) and
- (X1<=CrtMaxX) and
- (Y1<=CrtMaxY) then
- begin
- CA := CurAct;
- if CA then CurOff;
- MinMax(WindMin).X := X0-1;
- MinMax(WindMin).Y := Y0-1;
- MinMax(WindMax).X := X1-1;
- MinMax(WindMax).Y := Y1-1;
- CurAct := CA;
- gotoxy(1,1)
- end
- end;{ Window }
-
- procedure TextMode( Mode : word );
- type
- bp = ^byte;
- Grec = record
- O: word;
- S: word;
- end;
- var
- C : ScrCel;
- I : word;
- Gd,Gm : integer;
- begin
- case Mode of
- CO80,
- T80x25 : begin { 640x350 with 8x14 or 640x200 with 8x8}
- setgraphmode(VGAMed);
- FontTable := @Text8x14;
- ChaHgt := bp(FontTable)^;
- CrtMaxY := 25;
- inc(Grec(FontTable).O);
- end;
- T80x34 : begin { 640x480 with 8x14 }
- setgraphmode(VGAHi);
- FontTable := @Text8x14;
- ChaHgt := bp(FontTable)^;
- CrtMaxY := 34;
- inc(Grec(FontTable).O);
- end;
- T80x60 : begin { 640x480 with 8x8 }
- setgraphmode(VGAHi);
- FontTable := @Text8x8;
- ChaHgt := bp(FontTable)^;
- CrtMaxY := 60;
- inc(Grec(FontTable).O);
- end;
- T80x43 : begin { 640x350 with 8x8 }
- setgraphmode(VGAMed);
- FontTable := @Text8x8;
- ChaHgt := bp(FontTable)^;
- CrtMaxY := 43;
- inc(Grec(FontTable).O);
- end;
- else
- begin
- setgraphmode(VGAMed);
- FontTable := @Text8x14;
- ChaHgt := bp(FontTable)^;
- CrtMaxY := 25;
- inc(Grec(FontTable).O);
- end
- end;
- C.Cha := ' ';
- C.Att := textattr;
- for I:=0 to CrtMaxX*CrtMaxY do
- ScrSta^[I] := word(C);
- windmin := 0;
- MinMax(windmax).Y := CrtMaxY-1;
- MinMax(windmax).X := 79;
- CurX := 0;
- CurY := 0;
- OldCurY := -1;
- OldCurX := -1;
- gotoxy(1,1)
- end;
-
- function Keypressed : boolean;
- begin
- KeyPressed := CurCha^ <> NexOpe^
- end;
-
- procedure CheckCrtlBreak;
- begin
- if CurCha^=NexOpe^ then exit;
- if (BiosPtr^[CurCha^ div 2]=0) or BreakPressed then halt
- end;
-
- function ReadKey : char;
- begin
- if Extended then
- begin
- ReadKey := chr(KeyBuf^[CurCha^+1]);
- Extended := false;
- inc(CurCha^,2);
- if CurCha^=KeyBufEnd then
- CurCha^ := KeyBufSta
- end
- else
- begin
- while CurCha^=NexOpe^ do;
- ReadKey := chr(KeyBuf^[CurCha^]);
- if KeyBuf^[CurCha^]=0 then
- if (KeyBuf^[CurCha^+1]=0) and not CheckBreak then
- if TrapBreak then
- Extended := true
- else
- CurCha^ := NexOpe^
- else
- begin
- BreakPressed := true;
- CurCha^ := NexOpe^
- end
- else
- begin
- Extended := false;
- inc(CurCha^,2);
- if CurCha^=KeyBufEnd then
- CurCha^ := KeyBufSta
- end;
- end;
- end;
-
- function WhereX : word;
- begin
- WhereX := CurX + 1
- end;{ WhereX }
-
- function WhereY : word;
- begin
- WhereY := CurY + 1
- end;{ WhereY }
-
- BEGIN
- PilWinIni
- END.