From 643c1ea7e07bb88c8b18cbb5f686b8d8023187e7 Mon Sep 17 00:00:00 2001 From: marcus Date: Mon, 30 Dec 2019 13:14:10 +0000 Subject: [PATCH] Amiga: First Version of crt for Amiga git-svn-id: trunk@43814 - --- packages/rtl-console/fpmake.pp | 2 +- packages/rtl-console/src/amiga/crt.pp | 1204 +++++++++---------------- 2 files changed, 413 insertions(+), 793 deletions(-) diff --git a/packages/rtl-console/fpmake.pp b/packages/rtl-console/fpmake.pp index ab07391943..208708fb42 100644 --- a/packages/rtl-console/fpmake.pp +++ b/packages/rtl-console/fpmake.pp @@ -16,7 +16,7 @@ Const KVMAll = [emx,go32v2,msdos,netware,netwlibc,os2,win32,win64,win16]+UnixLikes+AllAmigaLikeOSes; // all full KVMers have crt too, except Amigalikes - CrtOSes = KVMALL+[WatCom]-[aros,morphos,amiga]; + CrtOSes = KVMALL+[WatCom]-[aros,morphos]; KbdOSes = KVMALL; VideoOSes = KVMALL; MouseOSes = KVMALL; diff --git a/packages/rtl-console/src/amiga/crt.pp b/packages/rtl-console/src/amiga/crt.pp index 8bbb448ee8..a5e0e0bc31 100644 --- a/packages/rtl-console/src/amiga/crt.pp +++ b/packages/rtl-console/src/amiga/crt.pp @@ -1,6 +1,7 @@ { This file is part of the Free Pascal run time library. Copyright (c) 1999-2000 by Nils Sjoholm and Carl Eric Codere + Copyright (c) 2019 by Free Pascal development team See the file COPYING.FPC, included in this distribution, for details about the copyright. @@ -11,915 +12,534 @@ **********************************************************************} +unit crt; -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; +interface {$i crth.inc} -Implementation +implementation uses - exec, amigados, conunit, intuition; + exec, amigados, conunit, intuition, agraphics; var - maxcols,maxrows : longint; + 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; + // Special Character for commands to console + CSI = Chr($9b); - - 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)); + // Pens for Front/Backcolors (must be 0-7) + RedPen: LongInt = -1; + FreeRed: Boolean = False; + GreenPen: LongInt = -1; + FreeGreen: Boolean = False; + // multiple keys + LastKeys: string = ''; - 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; +function SendActionPacket(Port: PMsgPort; Arg: BPTR): LongInt; var - info : pInfoData; - theunit : pConUnit; - pos : Longint; + ReplyPort: PMsgPort; + Packet: PStandardPacket; + Ret: NativeInt; begin - pos := 1; - info := OpenInfo; + SendActionPacket := 0; + ReplyPort := CreateMsgPort; + if not Assigned(ReplyPort) then + Exit; - if info <> nil then begin - theunit := pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit); + Packet := AllocMem(SizeOf(TStandardPacket)); - 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; + if not Assigned(Packet) then + begin + DeleteMsgPort(ReplyPort); + Exit; + end; - CloseInfo(info); - end; + Packet^.sp_Msg.mn_Node.ln_Name := @(Packet^.sp_Pkt); + Packet^.sp_Pkt.dp_Link := @(Packet^.sp_Msg); + Packet^.sp_Pkt.dp_Port := ReplyPort; + Packet^.sp_Pkt.dp_Type := ACTION_DISK_INFO; + Packet^.sp_Pkt.dp_Arg1 := NativeInt(Arg); - ConData := pos + 1; + PutMsg(Port, PMessage(Packet)); + WaitPort(ReplyPort); + GetMsg(ReplyPort); + + Ret := Packet^.sp_Pkt.dp_Res1; + + FreeMem(Packet); + DeleteMsgPort(ReplyPort); + + SendActionPacket := Ret; end; -function WhereX : tcrtcoord; +function OpenInfo: PInfoData; +var + Port: PMsgPort; + Info: PInfoData; + Bptr1: BPTR; begin - WhereX := Byte(ConData(CD_CURRX))-lo(windmin); + Info := PInfoData(AllocMem(SizeOf(TInfoData))); + + if Assigned(Info) then + begin + Port := PFileHandle(BADDR(DosInput()))^.fh_Type; + //GetConsoleTask; + Bptr1 := MKBADDR(Info); + + if Assigned(Port) then + begin + if SendActionPacket(Port, Bptr1) = 0 then + Port := nil; + end; + + if Port = nil then + begin + FreeMem(Info); + Info := nil; + end; + end; + OpenInfo := Info; end; -function realx: byte; +procedure CloseInfo(var Info: PInfoData); begin - RealX := Byte(ConData(CD_CURRX)); + if Assigned(Info) then + begin + FreeMem(Info); + Info := nil; + end; end; -function realy: byte; +function ConData(Modus: Byte): Integer; +var + Info: PInfoData; + TheUnit: PConUnit; + Pos: Longint; begin - RealY := Byte(ConData(CD_CURRY)); + pos := 1; + Info := OpenInfo; + + if Assigned(Info) 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 WhereY : tcrtcoord; +function WhereX: TCrtCoord; begin - WhereY := Byte(ConData(CD_CURRY))-hi(windmin); + WhereX := Byte(ConData(CD_CURRX)) - WindMinX; end; -function screencols : integer; +function RealX: Byte; begin - screencols := ConData(CD_MAXX); + RealX := Byte(ConData(CD_CURRX)); end; -function screenrows : integer; +function RealY: Byte; begin - screenrows := ConData(CD_MAXY); + RealY := Byte(ConData(CD_CURRY)); end; +function WhereY: TCrtCoord; +begin + WhereY := Byte(ConData(CD_CURRY)) - WindMinY; +end; - procedure Realgotoxy(x,y : integer); - begin - Write(CSI, y, ';', x, 'H'); - end; +function ScreenCols: Integer; +begin + Screencols := ConData(CD_MAXX); +end; +function ScreenRows: Integer; +begin + ScreenRows := ConData(CD_MAXY); +end; - procedure gotoxy(x,y : tcrtcoord); - 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 RealGotoXY(x, y: Integer); +begin + Write(CSI, y, ';', x, 'H'); +end; +procedure GotoXY(x, y: TCrtCoord); +begin + if y + WindMinY - 2 >= WindMaxY then + y := WindMaxY - WindMinY + 1; + if x + WindMinX - 2 >= WindMaxX then + x := WindMaxX - WindMinX + 1; + Write(CSI, y + WindMinY, ';', x + WindMinX, 'H'); +end; procedure CursorOff; begin - Write(CSI,'0 p'); + Write(CSI,'0 p'); end; procedure CursorOn; begin - Write(CSI,'1 p'); + Write(CSI,' p'); end; procedure ClrScr; begin - Write(Chr($0c)); + Write(Chr($0c)); end; -function ReadKey : char; -const - IDCMP_VANILLAKEY = $00200000; - IDCMP_RAWKEY = $00000400; +function WaitForKey: string; var - info : pInfoData; - win : pWindow; - imsg : pIntuiMessage; - msg : pMessage; - key : char; - idcmp, vanil : Longint; + OutP: BPTR; // Output file handle + Res: Char; // Char to get fropm console + Key: string; // result 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) + Key := ''; + OutP := DosOutput(); + SetMode(OutP, 1); // change to Raw Mode + // Special for AROS + // AROS always sends a #184, #185 or #0, ignore them + repeat + Res := #0; + DosRead(OutP, @Res, 1); + if not (Ord(Res) in [184, 185, 0]) then + Break; + Delay(1); + until False; + // get the key + Key := Res; + // Check if Special OP + if Res = CSI then + begin + repeat + Res := #0; + DosRead(OutP, @Res, 1); + if Ord(Res) in [184, 185, 0] then // just to make sure on AROS that it ends when nothing left + Break; + if Ord(Res) = 126 then // end marker + Break; + Key := Key + Res; // add to final string + // stop on cursor, they have no end marker... + case Ord(Res) of + 64..69,83,84: Break; end; + until False; + end; + // set result + WaitForKey := Key; + // set back mode to CON: + SetMode(OutP, 0); +end; - ReplyMsg(pMessage(imsg)); +type + TKeyMap = record + con: string; + c1: Char; + c2: Char; + end; +const + KeyMapping: array[0..17] of TKeyMap = + ((con: #155'0'; c1: #0; c2:#59;), // F1 + (con: #155'1'; c1: #0; c2:#60;), // F2 + (con: #155'2'; c1: #0; c2:#61;), // F3 + (con: #155'3'; c1: #0; c2:#62;), // F4 + (con: #155'4'; c1: #0; c2:#63;), // F5 + (con: #155'5'; c1: #0; c2:#64;), // F6 + (con: #155'6'; c1: #0; c2:#65;), // F7 + (con: #155'7'; c1: #0; c2:#66;), // F8 + (con: #155'8'; c1: #0; c2:#67;), // F9 + (con: #155'9'; c1: #0; c2:#68;), // F10 + (con: #155'20'; c1: #0; c2:#133;), // F11 + (con: #155'21'; c1: #0; c2:#134;), // F12 - repeat - msg := GetMsg(win^.UserPort); + (con: #155'41'; c1: #0; c2:#73;), // Page Up + (con: #155'42'; c1: #0; c2:#81;), // Page Down - if msg <> nil then ReplyMsg(msg); - until msg = nil; + (con: #155'A'; c1: #0; c2:#72;), // Cursor Up + (con: #155'B'; c1: #0; c2:#80;), // Cursor Down + (con: #155'C'; c1: #0; c2:#77;), // Cursor Right + (con: #155'D'; c1: #0; c2:#75;) // Cursor Left + ); - ModifyIDCMP(win, idcmp); +function ReadKey: Char; +var + Res: string; + i: Integer; +begin + // we got a key to sent + if Length(LastKeys) > 0 then + begin + ReadKey := LastKeys[1]; + Delete(LastKeys, 1, 1); + Exit; + end; + Res := WaitForKey; + // Search for Map Key + for i := 0 to High(KeyMapping) do + begin + if KeyMapping[i].Con = Res then + begin + ReadKey := KeyMapping[i].c1; + if KeyMapping[i].c2 <> #0 then + LastKeys := KeyMapping[i].c2; + Exit; + end; + end; + ReadKey := Res[1]; +end; - CloseInfo(info); - end; - KeyPressed := ispressed; +// Wait for Key, does not work for AROS currently +// because WaitForChar ALWAYS returns even no key is pressed, but this +// is clearly an AROS bug +function KeyPressed : Boolean; +var + OutP: BPTR; +begin + if Length(LastKeys) > 0 then + begin + KeyPressed := True; + Exit; + end; + OutP := DosOutput(); + SetMode(OutP, 1); + // Wait one millisecond for the key (-1 = timeout) + {$if defined(MorphOS) or defined(Amiga68k))} + KeyPressed := WaitForChar(OutP, 1); + {$else} + KeyPressed := WaitForChar(OutP, 1) <> 0; + {$endif} + SetMode(OutP, 0); +end; + +function ConvertColor(Color: Byte): Byte; +begin + Color := Color and $f; // make sure we are in the 0..7 range + // make some color mappings + case Color of + White: ConvertColor := 2; + Black: ConvertColor := 1; + Blue: ConvertColor := 3; + LightGray: ConvertColor := 0; + Red: ConvertColor := RedPen; + Green: ConvertColor := GreenPen; + else + ConvertColor := Color; + end; +end; + +function ConvertColorBack(Color: Byte): Byte; +begin + Color := Color and $f; + case Color of + 2 : ConvertColorBack := White; + 1: ConvertColorBack := Black; + 3: ConvertColorBack := Blue; + 0: ConvertColorBack := LightGray; + else + if Color = RedPen then ConvertColorBack := Red else + if color = GreenPen then ConvertColorBack := Green else + ConvertColorBack := Color; + end; end; procedure TextColor(color : byte); begin - TextAttr := (TextAttr and $70) or color; - Write(CSI, '3', color, 'm'); + Color := ConvertColor(Color); + 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'); + Color := ConvertColor(Color); + Textattr:=(textattr and $8f) or ((Color and $7) shl 4); + Write(CSI, '4', color, 'm'); +end; + +function GetTextBackground: Byte; +var + Info: PInfoData; + Pen: Byte; +begin + pen := 1; + Info := OpenInfo; + if Assigned(Info)then + begin + Pen := PConUnit((PIoStdReq(Info^.id_InUse))^.io_Unit)^.cu_BgPen; + Pen := ConvertColorBack(Pen); + CloseInfo(Info); + end; + GetTextBackground := Pen; +end; + +function GetTextColor: Byte; +var + Info: PInfoData; + Pen: Byte; +begin + Pen := 1; + Info := OpenInfo; + if Assigned(info) then + begin + Pen := PConUnit((PIoStdReq(Info^.id_InUse))^.io_Unit)^.cu_FgPen; + Pen := ConvertColorBack(Pen); + CloseInfo(Info); + end; + GetTextColor := Pen; 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; - - - +begin + if x1 < 1 then + x1 := 1; + if y1 < 1 then + y1 := 1; + if (x2 > ScreenCols) or (y2 > ScreenRows) or (x1 > x2) or (y1 > y2) then + Exit; + WindMinX := x1 - 1; + WindMinY := y1 - 1; + WindMaxX := x2 - 1; + WindMaxY := y2 - 1; + GotoXY(1, 1); +end; procedure DelLine; begin - Write(CSI,'X'); + Write(CSI,'X'); end; procedure ClrEol; begin - Write(CSI,'K'); + Write(CSI,'K'); end; procedure InsLine; begin - Write(CSI,'1 L'); + Write(CSI,'1 L'); end; -procedure cursorbig; +procedure CursorBig; begin end; -procedure lowvideo; +procedure LowVideo; begin end; -procedure highvideo; +procedure HighVideo; begin end; -procedure nosound; +procedure NoSound; begin end; -procedure sound(hz : word); +procedure Sound(hz: Word); begin end; -procedure delay(ms : Word); +procedure NormVideo; +begin +end; + +procedure AssignCrt(var F: Text); +begin +end; + +procedure Delay(ms: Word); var - dummy : Longint; + Dummy: Longint; begin - dummy := trunc((real(ms) / 1000.0) * 50.0); - DOSDelay(dummy); + dummy := Trunc((ms / 1000.0) * 50.0); + DOSDelay(dummy); end; -{function CheckBreak : boolean; +procedure TextMode(Mode: word); begin - if (SetSignal(0, 0) and SIGBREAKF_CTRL_C) = SIGBREAKF_CTRL_C then - CheckBreak := true - else - CheckBreak := false; -end;} - -procedure textmode(mode : word); -begin - lastmode:=mode; - mode:=mode and $ff; - windmin:=0; - windmax:=(screencols-1) or ((screenrows-1) shl 8); - maxcols:=screencols; - maxrows:=screenrows; + LastMode := Mode; + Mode := Mode and $ff; + MaxCols := ScreenCols; + MaxRows := ScreenRows; + WindMinX := 0; + WindMinY := 0; + WindMaxX := MaxCols - 1; + WindMaxY := MaxRows - 1; end; -procedure normvideo; -begin -end; - -function GetTextBackground : byte; +function GetClosestPen(r,g,b: Byte): ShortInt; var - info : pInfoData; - pen : byte; + i: Byte; + cm: PColorMap; + AR, AG, AB: Byte; + Col: LongInt; + MinDist, Dist: LongInt; 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; + GetClosestPen := -1; + cm := IntuitionBase^.ActiveScreen^.ViewPort.ColorMap; + MinDist := MaxInt; + for i := 2 to 7 do + begin + Col := GetRGB4(CM, i); + if Col = -1 then + Continue; + AR := (Col shr 8) and $F; + AR := AR or (AR shl 4); + AG := (Col shr 4) and $F; + AG := AG or (AR shl 4); + AB := (Col shr 0) and $F; + AB := AB or (AR shl 4); + Dist := Abs(AR-r) + Abs(AG-g) + Abs(AB-b); + if Dist < MinDist then + begin + GetClosestPen := i; + MinDist := Dist; + end; + end; end; -function GetTextColor : byte; -var - info : pInfoData; - pen : byte; -begin - pen := 1; - info := OpenInfo; +initialization + // Init Colors, (until now only Red and Green) + RedPen := ObtainPen(IntuitionBase^.ActiveScreen^.ViewPort.ColorMap, 7, $FFFFFFFF, 0, 0, 0); + FreeRed := RedPen >= 0; + if not FreeRed then + RedPen := GetClosestPen($ff,00,00); + // + GreenPen := ObtainPen(IntuitionBase^.ActiveScreen^.ViewPort.ColorMap, 6, 0, $FFFFFFFF, 0, 0); + FreeGreen := GreenPen >= 0; + if not FreeRed then + GreenPen := GetClosestPen(00,$ff,00); - if info <> nil then begin - pen := pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_FgPen; + // 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 + WindMaxX := MaxCols - 1; + WindMaxY := MaxRows - 1; - 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 } +finalization + if FreeRed then + ReleasePen(IntuitionBase^.ActiveScreen^.ViewPort.ColorMap, RedPen); + if FreeGreen then + ReleasePen(IntuitionBase^.ActiveScreen^.ViewPort.ColorMap, GreenPen); 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;} + CursorOn; end.