{ $Id: crt.pp,v 1.5 1998/09/14 20:21:53 carl Exp $ This file is part of the Free Pascal run time library. Copyright (c) 1998 by Nils Sjoholm and Carl Eric Codere 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; {--------------------------------------------------------------------} { LEFT TO DO: } {--------------------------------------------------------------------} { o Write special characters are not recognized } { o Write does not take care of window coordinates yet. } { o Read does not recognize the special editing characters } { o Read does not take care of window coordinates yet. } { o Readkey extended scancode is not correct yet } { o Color mapping only works for 4 colours } { o ClrScr, DeleteLine, InsLine do not work with window coordinates } {--------------------------------------------------------------------} Interface Const { Controlling consts } Flushing=false; {if true then don't buffer output} ScreenWidth = 80; ScreenHeight = 25; { 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; { When using this color constants on the Amiga you can bet that they don't work as expected. You never know what color the user has on his Amiga. Perhaps we should do a check of the number of bitplanes (for number of colors) The normal 4 first pens for an Amiga are 0 LightGrey 1 Black 2 White 3 Blue } { Foreground and background color constants } Black = 1; { normal pen for amiga } Blue = 3; { windowborder color } Green = 15; Cyan = 7; Red = 4; Magenta = 5; Brown = 6; LightGray = 0; { canvas color } { Foreground color constants } DarkGray = 8; LightBlue = 9; LightGreen = 10; LightCyan = 11; LightRed = 12; LightMagenta = 13; Yellow = 14; White = 2; { third color on amiga } { Add-in for blinking } Blink = 128; {Other Defaults} LastMode : Word = 3; WindMin : Word = $0; WindMax : Word = $184f; { These don't change anything if they are modified } CheckSnow : Boolean = FALSE; DirectVideo: Boolean = FALSE; var TextAttr : BYTE; { CheckBreak have to make this one to a function for Amiga } CheckEOF : Boolean; 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: byte; 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(DTime: Word); Procedure Sound(Hz: Word); Procedure NoSound; { Extra functions } Procedure CursorOn; Procedure CursorOff; Function CheckBreak: Boolean; Implementation { The definitions of TextRec and FileRec are in separate files. } {$i textrec.inc} {$i filerec.inc} var maxcols,maxrows : longint; CONST { This is used to make sure that readkey returns immediately } { if keypressed was used beforehand. } KeyPress : char = #0; _LVODisplayBeep = -96; Type pInfoData = ^tInfoData; tInfoData = packed record id_NumSoftErrors : Longint; { number of soft errors on disk } id_UnitNumber : Longint; { Which unit disk is (was) mounted on } id_DiskState : Longint; { See defines below } id_NumBlocks : Longint; { Number of blocks on disk } id_NumBlocksUsed : Longint; { Number of block in use } id_BytesPerBlock : Longint; id_DiskType : Longint; { Disk Type code } id_VolumeNode : Longint; { BCPL pointer to volume node } id_InUse : Longint; { Flag, zero if not in use } end; { * List Node Structure. Each member in a list starts with a Node * } pNode = ^tNode; tNode = packed Record ln_Succ, { * Pointer to next (successor) * } ln_Pred : pNode; { * Pointer to previous (predecessor) * } ln_Type : Byte; ln_Pri : Shortint; { * Priority, for sorting * } ln_Name : PChar; { * ID string, null terminated * } End; { * Note: Integer aligned * } { normal, full featured list } pList = ^tList; tList = packed record lh_Head : pNode; lh_Tail : pNode; lh_TailPred : pNode; lh_Type : Byte; l_pad : Byte; end; pMsgPort = ^tMsgPort; tMsgPort = packed record mp_Node : tNode; mp_Flags : Byte; mp_SigBit : Byte; { signal bit number } mp_SigTask : Pointer; { task to be signalled (TaskPtr) } mp_MsgList : tList; { message linked list } end; pMessage = ^tMessage; tMessage = packed record mn_Node : tNode; mn_ReplyPort : pMsgPort; { message reply port } mn_Length : Word; { message len in bytes } end; pIOStdReq = ^tIOStdReq; tIOStdReq = packed record io_Message : tMessage; io_Device : Pointer; { device node pointer } io_Unit : Pointer; { unit (driver private)} io_Command : Word; { device command } io_Flags : Byte; io_Error : Shortint; { error or warning num } io_Actual : Longint; { actual number of bytes transferred } io_Length : Longint; { requested number bytes transferred} io_Data : Pointer; { points to data area } io_Offset : Longint; { offset for block structured devices } end; pIntuiMessage = ^tIntuiMessage; tIntuiMessage = packed record ExecMessage : tMessage; IClass : Longint; Code : Word; Qualifier : Word; IAddress : Pointer; MouseX, MouseY : Word; Seconds, Micros : Longint; IDCMPWindow : Pointer; SpecialLink : pIntuiMessage; end; pWindow = ^tWindow; tWindow = packed record NextWindow : pWindow; { for the linked list in a screen } LeftEdge, TopEdge : Integer; { screen dimensions of window } Width, Height : Integer; { screen dimensions of window } MouseY, MouseX : Integer; { relative to upper-left of window } MinWidth, MinHeight : Integer; { minimum sizes } MaxWidth, MaxHeight : Word; { maximum sizes } Flags : Longint; { see below for defines } MenuStrip : Pointer; { the strip of Menu headers } Title : PChar; { the title text for this window } FirstRequest : Pointer; { all active Requesters } DMRequest : Pointer; { double-click Requester } ReqCount : Integer; { count of reqs blocking Window } WScreen : Pointer; { this Window's Screen } RPort : Pointer; { this Window's very own RastPort } BorderLeft, BorderTop, BorderRight, BorderBottom : Shortint; BorderRPort : Pointer; FirstGadget : Pointer; Parent, Descendant : pWindow; Pointer_ : Pointer; { sprite data } PtrHeight : Shortint; { sprite height (not including sprite padding) } PtrWidth : Shortint; { sprite width (must be less than or equal to 16) } XOffset, YOffset : Shortint; { sprite offsets } IDCMPFlags : Longint; { User-selected flags } UserPort, WindowPort : pMsgPort; MessageKey : pIntuiMessage; DetailPen, BlockPen : Byte; { for bar/border/gadget rendering } CheckMark : Pointer; ScreenTitle : PChar; { if non-null, Screen title when Window is active } GZZMouseX : Integer; GZZMouseY : Integer; GZZWidth : Integer; GZZHeight : Word; ExtData : Pointer; UserData : Pointer; { general-purpose pointer to User data extension } WLayer : Pointer; IFont : Pointer; MoreFlags : Longint; end; const M_LNM = 20; { linefeed newline mode } PMB_ASM = M_LNM + 1; { internal storage bit for AS flag } PMB_AWM = PMB_ASM + 1; { internal storage bit for AW flag } MAXTABS = 80; IECLASS_MAX = $15; type pKeyMap = ^tKeyMap; tKeyMap = packed record km_LoKeyMapTypes : Pointer; km_LoKeyMap : Pointer; km_LoCapsable : Pointer; km_LoRepeatable : Pointer; km_HiKeyMapTypes : Pointer; km_HiKeyMap : Pointer; km_HiCapsable : Pointer; km_HiRepeatable : Pointer; end; pConUnit = ^tConUnit; tConUnit = packed record cu_MP : tMsgPort; { ---- read only variables } cu_Window : Pointer; { (WindowPtr) intuition window bound to this unit } cu_XCP : Integer; { character position } cu_YCP : Integer; cu_XMax : Integer; { max character position } cu_YMax : Integer; cu_XRSize : Integer; { character raster size } cu_YRSize : Integer; cu_XROrigin : Integer; { raster origin } cu_YROrigin : Integer; cu_XRExtant : Integer; { raster maxima } cu_YRExtant : Integer; cu_XMinShrink : Integer; { smallest area intact from resize process } cu_YMinShrink : Integer; cu_XCCP : Integer; { cursor position } cu_YCCP : Integer; { ---- read/write variables (writes must must be protected) } { ---- storage for AskKeyMap and SetKeyMap } cu_KeyMapStruct : tKeyMap; { ---- tab stops } cu_TabStops : Array [0..MAXTABS-1] of Word; { 0 at start, -1 at end of list } { ---- console rastport attributes } cu_Mask : Shortint; cu_FgPen : Shortint; cu_BgPen : Shortint; cu_AOLPen : Shortint; cu_DrawMode : Shortint; cu_AreaPtSz : Shortint; cu_AreaPtrn : Pointer; { cursor area pattern } cu_Minterms : Array [0..7] of Byte; { console minterms } cu_Font : Pointer; { (TextFontPtr) } cu_AlgoStyle : Byte; cu_TxFlags : Byte; cu_TxHeight : Word; cu_TxWidth : Word; cu_TxBaseline : Word; cu_TxSpacing : Word; { ---- console MODES and RAW EVENTS switches } cu_Modes : Array [0..(PMB_AWM+7) div 8 - 1] of Byte; { one bit per mode } cu_RawEvents : Array [0..(IECLASS_MAX+7) div 8 - 1] of Byte; end; const CD_CURRX = 1; CD_CURRY = 2; CD_MAXX = 3; CD_MAXY = 4; CSI = chr($9b); SIGBREAKF_CTRL_C = 4096; function AllocVec( size, reqm : Longint ): Pointer; begin asm MOVE.L A6,-(A7) MOVE.L size,d0 MOVE.L reqm,d1 MOVE.L _ExecBase, A6 JSR -684(A6) MOVE.L (A7)+,A6 MOVE.L d0,@RESULT end; end; function DoPkt(ID : pMsgPort; Action, Param1, Param2, Param3, Param4, Param5 : Longint) : Longint; begin asm MOVEM.L d2/d3/d4/d5/d6/d7/a6,-(A7) MOVE.L ID,d1 MOVE.L Action,d2 MOVE.L Param1,d3 MOVE.L Param2,d4 MOVE.L Param3,d5 MOVE.L Param4,d6 MOVE.L Param5,d7 MOVE.L _DOSBase,A6 JSR -240(A6) MOVEM.L (A7)+,d2/d3/d4/d5/d6/d7/a6 MOVE.L d0,@RESULT end; end; procedure FreeVec( memory : Pointer ); begin asm MOVE.L A6,-(A7) MOVE.L memory,a1 MOVE.L _ExecBase,A6 JSR -690(A6) MOVE.L (A7)+,A6 end; end; function GetConsoleTask : pMsgPort; begin asm MOVE.L A6,-(A7) MOVE.L _DOSBase,A6 JSR -510(A6) MOVE.L (A7)+,A6 MOVE.L d0,@RESULT end; end; function GetMsg(port : pMsgPort): pMessage; begin asm MOVE.L A6,-(A7) MOVE.L port,a0 MOVE.L _ExecBase,A6 JSR -372(A6) MOVE.L (A7)+,A6 MOVE.L d0,@RESULT end; end; function ModifyIDCMP(window : pWindow; IDCMPFlags : Longint) : Boolean; begin asm MOVE.L A6,-(A7) MOVE.L window,a0 MOVE.L IDCMPFlags,d0 MOVE.L _IntuitionBase,A6 JSR -150(A6) MOVE.L (A7)+,A6 TST.L d0 bne @success bra @end @success: move.b #1,d0 @end: move.b d0,@RESULT end; end; procedure ReplyMsg(mess : pMessage); begin asm MOVE.L A6,-(A7) MOVE.L mess,a1 MOVE.L _ExecBase,A6 JSR -378(A6) MOVE.L (A7)+,A6 end; end; function WaitPort(port : pMsgPort): pMessage; begin asm MOVE.L A6,-(A7) MOVE.L port,a0 MOVE.L _ExecBase,A6 JSR -384(A6) MOVE.L (A7)+,A6 MOVE.L d0,@RESULT end; end; procedure Delay_(ticks : Longint); begin asm MOVE.L A6,-(A7) MOVE.L ticks,d1 MOVE.L _DOSBase,A6 JSR -198(A6) MOVE.L (A7)+,A6 end; end; function SetSignal(newSignals, signalMask : Longint) : Longint; begin asm MOVE.L A6,-(A7) MOVE.L newSignals,d0 MOVE.L signalMask,d1 MOVE.L _ExecBase,A6 JSR -306(A6) MOVE.L (A7)+,A6 MOVE.L d0,@RESULT end; end; function OpenInfo : pInfoData; var port : pMsgPort; info : pInfoData; bptr, d4, d5, d6, d7 : Longint; begin info := pInfoData(AllocVec(SizeOf(tInfoData), 1)); if info <> nil then begin port := GetConsoleTask; bptr := Longint(info) shr 2; if port <> nil then begin if DoPkt(port, $19, bptr, d4, d5, d6, d7) <> 0 then info := pInfoData(bptr shl 2) else port := nil; end; if port = nil then begin FreeVec(info); info := nil; end; end; OpenInfo := info; end; procedure CloseInfo(var info : pInfoData); begin if info <> nil then begin FreeVec(info); info := nil; end; end; function ConData(modus : byte) : integer; var info : pInfoData; theunit : pConUnit; pos : Longint; begin pos := 1; info := OpenInfo; if info <> nil then begin theunit := pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit); case modus of CD_CURRX : pos := theunit^.cu_XCP; CD_CURRY : pos := theunit^.cu_YCP; CD_MAXX : pos := theunit^.cu_XMax; CD_MAXY : pos := theunit^.cu_YMax; end; CloseInfo(info); end; ConData := pos + 1; end; function WhereX : Byte; begin WhereX := Byte(ConData(CD_CURRX))-lo(windmin); end; function realx: byte; begin RealX := Byte(ConData(CD_CURRX)); end; function realy: byte; begin RealY := Byte(ConData(CD_CURRY)); end; function WhereY : Byte; begin WhereY := Byte(ConData(CD_CURRY))-hi(windmin); end; function screencols : integer; begin screencols := ConData(CD_MAXX); end; function screenrows : integer; begin screenrows := ConData(CD_MAXY); end; procedure Realgotoxy(x,y : integer); begin Write(CSI, y, ';', x, 'H'); end; procedure gotoxy(x,y : byte); begin if (x<1) then x:=1; if (y<1) then y:=1; if y+hi(windmin)-2>=hi(windmax) then y:=hi(windmax)-hi(windmin)+1; if x+lo(windmin)-2>=lo(windmax) then x:=lo(windmax)-lo(windmin)+1; Write(CSI, y+hi(windmin), ';', x+lo(windmin), 'H'); end; procedure CursorOff; begin Write(CSI,'0 p'); end; procedure CursorOn; begin Write(CSI,'1 p'); end; procedure ClrScr; begin Write(Chr($0c)); end; function ReadKey : char; const IDCMP_VANILLAKEY = $00200000; IDCMP_RAWKEY = $00000400; var info : pInfoData; win : pWindow; imsg : pIntuiMessage; msg : pMessage; key : char; idcmp, vanil : Longint; begin key := #0; if KeyPress <> #0 then Begin ReadKey:=KeyPress; KeyPress:=#0; exit; end; info := OpenInfo; if info <> nil then begin win := pWindow(pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_Window); idcmp := win^.IDCMPFlags; vanil := IDCMP_VANILLAKEY or IDCMP_RAWKEY; ModifyIDCMP(win, (idcmp or vanil)); repeat msg := WaitPort(win^.UserPort); imsg := pIntuiMessage(GetMsg(win^.UserPort)); if (imsg^.IClass = IDCMP_VANILLAKEY) then key := char(imsg^.Code) else if (imsg^.IClass = IDCMP_RAWKEY) then key := char(imsg^.Code); ReplyMsg(pMessage(imsg)); until key <> #0; repeat msg := GetMsg(win^.UserPort); if msg <> nil then ReplyMsg(msg); until msg = nil; ModifyIDCMP(win, idcmp); CloseInfo(info); end; ReadKey := key; end; function KeyPressed : Boolean; const IDCMP_VANILLAKEY = $00200000; IDCMP_RAWKEY = $00000400; var info : pInfoData; win : pWindow; imsg : pIntuiMessage; msg : pMessage; idcmp, vanil : Longint; ispressed : Boolean; begin KeyPress := #0; ispressed := False; info := OpenInfo; if info <> nil then begin win := pWindow(pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_Window); idcmp := win^.IDCMPFlags; vanil := IDCMP_VANILLAKEY or IDCMP_RAWKEY; ModifyIDCMP(win, (idcmp or vanil)); msg := WaitPort(win^.UserPort); imsg := pIntuiMessage(GetMsg(win^.UserPort)); if (imsg^.IClass = IDCMP_VANILLAKEY) or (imsg^.IClass = IDCMP_RAWKEY) then Begin ispressed := true; KeyPress := char(imsg^.Code) end; ReplyMsg(pMessage(imsg)); repeat msg := GetMsg(win^.UserPort); if msg <> nil then ReplyMsg(msg); until msg = nil; ModifyIDCMP(win, idcmp); CloseInfo(info); end; KeyPressed := ispressed; end; procedure TextColor(color : byte); begin TextAttr := (TextAttr and $70) or color; Write(CSI, '3', color, 'm'); end; procedure TextBackground(color : byte); begin Textattr:=(textattr and $8f) or ((color and $7) shl 4); Write(CSI, '4', color, 'm'); end; procedure Window(X1,Y1,X2,Y2: Byte); begin if (x1<1) or (x2>screencols) or (y2>screenrows) or (x1>x2) or (y1>y2) then exit; windmin:=(x1-1) or ((y1-1) shl 8); windmax:=(x2-1) or ((y2-1) shl 8); gotoxy(1,1); end; procedure DelLine; begin Write(CSI,'X'); end; procedure ClrEol; begin Write(CSI,'K'); end; procedure InsLine; begin Write(CSI,'1 L'); end; procedure cursorbig; begin end; procedure lowvideo; begin end; procedure highvideo; begin end; procedure nosound; begin end; procedure sound(hz : word); begin end; procedure delay(DTime : Word); var dummy : Longint; begin dummy := trunc((real(DTime) / 1000.0) * 50.0); Delay_(dummy); end; function CheckBreak : boolean; begin if (SetSignal(0, 0) and SIGBREAKF_CTRL_C) = SIGBREAKF_CTRL_C then CheckBreak := true else CheckBreak := false; end; procedure textmode(mode : integer); begin lastmode:=mode; mode:=mode and $ff; windmin:=0; windmax:=(screencols-1) or ((screenrows-1) shl 8); maxcols:=screencols; maxrows:=screenrows; end; procedure normvideo; begin end; function GetTextBackground : byte; var info : pInfoData; pen : byte; begin pen := 1; info := OpenInfo; if info <> nil then begin pen := pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_BgPen; CloseInfo(info); end; GetTextBackground := pen; end; function GetTextColor : byte; var info : pInfoData; pen : byte; begin pen := 1; info := OpenInfo; if info <> nil then begin pen := pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_FgPen; CloseInfo(info); end; GetTextColor := pen; end; {***************************************************************************** Read and Write routines *****************************************************************************} { Problem here: Currently all these routines are not implemented because of how } { the console device works. Because w low level write is required to change the } { position of the cursor, and since the CrtWrite is assigned as the standard } { write routine, a recursive call will occur } { How to fix this: } { At startup make a copy of the Output handle, and then use this copy to make } { low level positioning calls. This does not seem to work yet. } Function CrtWrite(var f : textrec):integer; var i,col,row : longint; c : char; buf: array[0..1] of char; begin col:=realx; row:=realy; inc(row); inc(col); for i:=0 to f.bufpos-1 do begin c:=f.buffer[i]; case ord(c) of 10 : begin inc(row); end; 13 : begin col:=lo(windmin)+1; end; 8 : if col>lo(windmin)+1 then begin dec(col); end; 7 : begin { beep } asm move.l a6,d6 { save base pointer } move.l _IntuitionBase,a6 { set library base } sub.l a0,a0 jsr _LVODisplayBeep(a6) move.l d6,a6 { restore base pointer } end; end; else begin buf[0]:=c; realgotoxy(row,col); do_write(f.handle,longint(@buf[0]),1); inc(col); end; end; if col>lo(windmax)+1 then begin col:=lo(windmin)+1; inc(row); end; while row>hi(windmax)+1 do begin delline; dec(row); end; end; f.bufpos:=0; realgotoxy(row-1,col-1); CrtWrite:=0; end; Function CrtClose(Var F: TextRec): Integer; Begin F.Mode:=fmClosed; CrtClose:=0; End; Function CrtOpen(Var F: TextRec): Integer; Begin If F.Mode = fmOutput Then CrtOpen:=0 Else CrtOpen:=5; End; Function CrtRead(Var F: TextRec): Integer; Begin f.bufend:=do_read(f.handle,longint(f.bufptr),f.bufsize); f.bufpos:=0; CrtRead:=0; End; Function CrtInOut(Var F: TextRec): Integer; Begin Case F.Mode of fmInput: CrtInOut:=CrtRead(F); fmOutput: CrtInOut:=CrtWrite(F); End; End; procedure assigncrt(var f : text); begin { TextRec(F).Mode:=fmClosed; TextRec(F).BufSize:=SizeOf(TextBuf); TextRec(F).BufPtr:=@TextRec(F).Buffer; TextRec(F).BufPos:=0; TextRec(F).OpenFunc:=@CrtOpen; TextRec(F).InOutFunc:=@CrtInOut; TextRec(F).FlushFunc:=@CrtInOut; TextRec(F).CloseFunc:=@CrtClose; TextRec(F).Name[0]:='.'; TextRec(F).Name[1]:=#0;} end; var old_exit : pointer; procedure crt_exit; begin { Restore default colors } write(CSI,'0m'); exitproc:=old_exit; end; Begin old_exit:=exitproc; exitproc:=@crt_exit; { load system variables to temporary variables to save time } maxcols:=screencols; maxrows:=screenrows; { Set the initial text attributes } { Text background } Textattr:=(textattr and $8f) or ((GetTextBackGround and $7) shl 4); { Text foreground } TextAttr := (TextAttr and $70) or GetTextColor; { set output window } windmax:=(maxcols-1) or (( maxrows-1) shl 8); { Get a copy of the standard } { output handle, and when using } { direct console calls, use this } { handle instead. } { assigncrt(Output); TextRec(Output).mode:=fmOutput;} end.