{ $Id$ This file is part of the Free Pascal run time library. Copyright (c) 1998 by Nils Sjoholm 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 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} TextAttr : Byte = $07; LastMode : Word = 3; WindMin : Word = $0; WindMax : Word = $184f; var { CheckBreak have to make this one to a function for Amiga } CheckEOF, CheckSnow, DirectVideo: Boolean; Procedure AssignCrt(Var F: Text); Function KeyPressed: Boolean; Function ReadKey: Char; Procedure TextMode(Mode: Integer); Procedure Window(X1, Y1, X2, Y2: Integer); Procedure GoToXy(X: Integer; Y: Integer); Function WhereX: Integer; Function WhereY: Integer; 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} 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; Class_ : 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; pConUnit = ^tConUnit; tConUnit = packed record cu_MP : tMsgPort; 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; cu_KeyMapStruct : Pointer; cu_TabStops : Array [0..80-1] of Word; 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; cu_Modes : Array [0..(22+7) div 8 - 1] of Byte; cu_RawEvents : Array [0..($15+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 : integer; begin WhereX := ConData(CD_CURRX); end; function WhereY : integer; begin WhereY := ConData(CD_CURRY); end; function maxx : integer; begin maxx := ConData(CD_MAXX); end; function maxy : integer; begin maxy := ConData(CD_MAXY); end; procedure GotoXY(x, y : integer); var mx, my : integer; begin mx := maxx; my := maxy; if x < 1 then x := wherex else if x > mx then x := mx; if y < 1 then y := wherey else if y > my then y := my; Write(CSI, y, ';', x, '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; 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^.Class_ = IDCMP_VANILLAKEY) or (imsg^.Class_ = 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 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^.Class_ = IDCMP_VANILLAKEY) or (imsg^.Class_ = IDCMP_RAWKEY) then ispressed := true; 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 Write(CSI, '3', color, 'm'); end; procedure TextBackground(color : byte); begin Write(CSI, '4', color, 'm'); end; procedure window(X1,Y1,X2,Y2 : Integer); begin end; procedure assigncrt(var f : text); begin 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 end; procedure normvideo; begin end; end.