mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-04 02:19:22 +01:00
1027 lines
25 KiB
ObjectPascal
1027 lines
25 KiB
ObjectPascal
{
|
|
$Id$
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 1999-2000 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.
|
|
|
|
|
|
|
|
|
|
|
|
$Log$
|
|
Revision 1.3 2002-09-07 16:01:16 peter
|
|
* old logs removed and tabs fixed
|
|
|
|
}
|