{ $Id$ This file is part of the Free Pascal run time library. Copyright (c) 1993-98 by the Free Pascal development team. Borland Pascal 7 Compatible CRT Unit for Go32V1 and Go32V2 See the file COPYING.FPC, included in this distribution, for details about the copyright. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} unit crt; interface {$I os.inc} const { CRT modes } BW40 = 0; { 40x25 B/W on Color Adapter } CO40 = 1; { 40x25 Color on Color Adapter } BW80 = 2; { 80x25 B/W on Color Adapter } CO80 = 3; { 80x25 Color on Color Adapter } Mono = 7; { 80x25 on Monochrome Adapter } Font8x8 = 256; { Add-in for ROM font } { Mode constants for 3.0 compatibility } C40 = CO40; C80 = CO80; { Foreground and background color constants } Black = 0; Blue = 1; Green = 2; Cyan = 3; Red = 4; Magenta = 5; Brown = 6; LightGray = 7; { Foreground color constants } DarkGray = 8; LightBlue = 9; LightGreen = 10; LightCyan = 11; LightRed = 12; LightMagenta = 13; Yellow = 14; White = 15; { Add-in for blinking } Blink = 128; var { Interface variables } CheckBreak: Boolean; { Enable Ctrl-Break } CheckEOF: Boolean; { Enable Ctrl-Z } DirectVideo: Boolean; { Enable direct video addressing } CheckSnow: Boolean; { Enable snow filtering } LastMode: Word; { Current text mode } TextAttr: Byte; { Current text attribute } WindMin: Word; { Window upper left coordinates } WindMax: Word; { Window lower right coordinates } { Interface procedures } procedure AssignCrt(var F: Text); function KeyPressed: Boolean; function ReadKey: Char; procedure TextMode(Mode: Integer); procedure Window(X1,Y1,X2,Y2: Byte); procedure GotoXY(X,Y: Byte); function WhereX: Byte; function WhereY: Byte; procedure ClrScr; procedure ClrEol; procedure InsLine; procedure DelLine; procedure TextColor(Color: Byte); procedure TextBackground(Color: Byte); procedure LowVideo; procedure HighVideo; procedure NormVideo; procedure Delay(MS: Word); procedure Sound(Hz: Word); procedure NoSound; {Extra Functions} procedure cursoron; procedure cursoroff; procedure cursorbig; implementation uses go32; {$ifdef VER0_99_5} {$I386_DIRECT} {due to a bug in the assembler reader using a } { call to a symbol will crash under FPC 0.99.5 } {$endif} {$ASMMODE ATT} var DelayCnt, { don't modify this var name, as it is hard coded } ScreenWidth, ScreenHeight : longint; { definition of textrec is in textrec.inc } {$i textrec.inc} {**************************************************************************** Low level Routines ****************************************************************************} procedure setscreenmode(mode : byte); {$ifdef GO32V2} var regs : trealregs; {$endif GO32V2} begin {$ifdef GO32V2} regs.realeax:=mode; realintr($10,regs); {$else GO32V2} asm movb 8(%ebp),%al xorb %ah,%ah pushl %ebp int $0x10 popl %ebp end; {$endif GO32V2} end; function GetScreenHeight : longint; begin {$ifdef GO32V2} getscreenheight:=mem[$40:$84]+1; {$else} dosmemget($40,$84,getscreenheight,1); inc(getscreenheight); {$endif} end; function GetScreenWidth : longint; begin {$ifdef GO32V2} getscreenwidth:=mem[$40:$4a]; {$else} dosmemget($40,$4a,getscreenwidth,1); {$endif} end; procedure SetScreenCursor(x,y : longint); {$ifdef GO32V2} var regs : trealregs; {$endif GO32V2} begin {$ifdef GO32V2} regs.realeax:=$0200; regs.realebx:=0; regs.realedx:=(y-1) shl 8+(x-1); realintr($10,regs); {$else GO32V2} asm movb $0x02,%ah movb $0,%bh movb y,%dh movb x,%dl subw $0x0101,%dx pushl %ebp int $0x10 popl %ebp end; {$endif GO32V2} end; procedure GetScreenCursor(var x,y : longint); begin {$ifdef Go32V2} x:=mem[$40:$50]+1; y:=mem[$40:$51]+1; {$else Go32V2} x:=0; y:=0; dosmemget($40,$50,x,1); dosmemget($40,$51,y,1); inc(x); inc(y); {$endif GO32V2} end; {**************************************************************************** Helper Routines ****************************************************************************} Function WinMinX: Byte; { Current Minimum X coordinate } Begin WinMinX:=(WindMin and $ff)+1; End; Function WinMinY: Byte; { Current Minimum Y Coordinate } Begin WinMinY:=(WindMin shr 8)+1; End; Function WinMaxX: Byte; { Current Maximum X coordinate } Begin WinMaxX:=(WindMax and $ff)+1; End; Function WinMaxY: Byte; { Current Maximum Y coordinate; } Begin WinMaxY:=(WindMax shr 8) + 1; End; Function FullWin:boolean; { Full Screen 80x25? Window(1,1,80,25) is used, allows faster routines } begin FullWin:=(WindMax-WindMin=$184f); end; {**************************************************************************** Public Crt Functions ****************************************************************************} procedure textmode(mode : integer); begin lastmode:=mode; mode:=mode and $ff; setscreenmode(mode); screenwidth:=getscreenwidth; screenheight:=getscreenheight; windmin:=0; windmax:=(screenwidth-1) or ((screenheight-1) shl 8); end; Procedure TextColor(Color: Byte); { Switch foregroundcolor } Begin TextAttr:=(Color and $8f) or (TextAttr and $70); End; Procedure TextBackground(Color: Byte); { Switch backgroundcolor } Begin TextAttr:=(Color shl 4) or (TextAttr and $0f); End; Procedure HighVideo; { Set highlighted output. } Begin TextColor(TextAttr Or $08); End; Procedure LowVideo; { Set normal output } Begin TextColor(TextAttr And $77); End; Procedure NormVideo; { Set normal back and foregroundcolors. } Begin TextColor(7); TextBackGround(0); End; Procedure GotoXy(X: Byte; Y: Byte); { Go to coordinates X,Y in the current window. } Begin If (X>0) and (X<=WinMaxX- WinMinX+1) and (Y>0) and (Y<=WinMaxY-WinMinY+1) Then Begin Inc(X,WinMinX-1); Inc(Y,WinMinY-1); SetScreenCursor(x,y); End; End; Procedure Window(X1, Y1, X2, Y2: Byte); { Set screen window to the specified coordinates. } Begin if (X1>X2) or (X2>ScreenWidth) or (Y1>Y2) or (Y2>ScreenHeight) then exit; WindMin:=((Y1-1) Shl 8)+(X1-1); WindMax:=((Y2-1) Shl 8)+(X2-1); GoToXY(1,1); End; Procedure ClrScr; { Clear the current window, and set the cursor on 1,1 } var fil : word; y : longint; begin fil:=32 or (textattr shl 8); if FullWin then DosmemFillWord($b800,0,ScreenHeight*ScreenWidth,fil) else begin for y:=WinMinY to WinMaxY do DosmemFillWord($b800,((y-1)*ScreenWidth+(WinMinX-1))*2,WinMaxX-WinMinX+1,fil); end; Gotoxy(1,1); end; Procedure ClrEol; { Clear from current position to end of line. } var x,y : longint; fil : word; Begin GetScreenCursor(x,y); fil:=32 or (textattr shl 8); if x=y) do begin dosmemmove($b800,(((WinMinY+my-1)-1)*ScreenWidth+(WinMinX-1))*2, $b800,(((WinMinY+my)-1)*ScreenWidth+(WinMinX-1))*2,(WinMaxX-WinMinX+1)*2); dec(my); end; dosmemfillword($b800,(((WinMinY+y-1)-1)*ScreenWidth+(WinMinX-1))*2,(WinMaxX-WinMinX+1),fil); end; {**************************************************************************** Extra Crt Functions ****************************************************************************} procedure cursoron; {$ifdef GO32V2} var regs : trealregs; {$endif GO32V2} begin {$ifndef GO32V2} asm movb $1,%ah movb $10,%cl movb $9,%ch pushl %ebp int $0x10 popl %ebp end; {$else GO32V2} regs.realeax:=$0100; regs.realecx:=$90A; realintr($10,regs); {$endif GO32V2} end; procedure cursoroff; {$ifdef GO32V2} var regs : trealregs; {$endif GO32V2} begin {$ifdef GO32V2} regs.realeax:=$0100; regs.realecx:=$ffff; realintr($10,regs); {$else GO32V2} asm movb $1,%ah movb $-1,%cl movb $-1,%ch pushl %ebp int $0x10 popl %ebp end; {$endif GO32V2} end; procedure cursorbig; {$ifdef GO32V2} var regs : trealregs; {$endif GO32V2} begin {$ifdef GO32V2} regs.realeax:=$0100; regs.realecx:=$10A; realintr($10,regs); {$else GO32V2} asm movb $1,%ah movw $110,%cx pushl %ebp int $0x10 popl %ebp end; {$endif GO32V2} end; {***************************************************************************** Read and Write routines *****************************************************************************} var CurrX,CurrY : longint; Procedure WriteChar(c:char); var {$ifdef GO32V2} regs : trealregs; {$else} chattr : word; {$endif} begin case c of #10 : inc(CurrY); #13 : CurrX:=WinMinX; #8 : begin if CurrX>WinMinX then dec(CurrX); end; #7 : begin { beep } {$ifdef GO32V2} regs.dl:=7; regs.ah:=2; realintr($21,regs); {$endif} end; else begin {$ifdef GO32V2} memw[$b800:((CurrY-1)*ScreenWidth+(CurrX-1))*2]:=(textattr shl 8) or byte(c); {$else} chattr:=(textattr shl 8) or byte(c); dosmemput($b800,((CurrY-1)*ScreenWidth+(CurrX-1))*2,chattr,2); {$endif} inc(CurrX); end; end; if CurrX>WinMaxX then begin CurrX:=WinMinX; inc(CurrY); end; while CurrY>WinMaxY do begin removeline(1); dec(CurrY); end; end; Function CrtWrite(var f : textrec):integer; var i : longint; begin GetScreenCursor(CurrX,CurrY); for i:=0 to f.bufpos-1 do WriteChar(f.buffer[i]); SetScreenCursor(CurrX,CurrY); f.bufpos:=0; CrtWrite:=0; end; Function CrtRead(Var F: TextRec): Integer; procedure BackSpace; begin if (f.bufpos>0) and (f.bufpos=f.bufend) then begin WriteChar(#8); WriteChar(' '); WriteChar(#8); dec(f.bufpos); dec(f.bufend); end; end; var ch : Char; Begin GetScreenCursor(CurrX,CurrY); f.bufpos:=0; f.bufend:=0; repeat if f.bufpos>f.bufend then f.bufend:=f.bufpos; SetScreenCursor(CurrX,CurrY); ch:=readkey; case ch of #0 : case readkey of #71 : while f.bufpos>0 do begin dec(f.bufpos); WriteChar(#8); end; #75 : if f.bufpos>0 then begin dec(f.bufpos); WriteChar(#8); end; #77 : if f.bufpos0 do BackSpace; end; #13 : begin WriteChar(#13); WriteChar(#10); f.bufptr^[f.bufend]:=#13; f.bufptr^[f.bufend+1]:=#10; inc(f.bufend,2); break; end; #26 : if CheckEOF then begin f.bufptr^[f.bufend]:=#26; inc(f.bufend); break; end; else begin if f.bufpos