1093 lines
31 KiB
Plaintext
1093 lines
31 KiB
Plaintext
{ GPC demo program for the CRT unit.
|
|
|
|
Copyright (C) 1999-2006, 2013-2024 Free Software Foundation, Inc.
|
|
|
|
Author: Frank Heckenbach <frank@pascal.gnu.de>
|
|
|
|
This program is free software; you can redistribute it and/or
|
|
modify it under the terms of the GNU General Public License as
|
|
published by the Free Software Foundation, version 3.
|
|
|
|
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. See the GNU
|
|
General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
along with this program. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
As a special exception, if you incorporate even large parts of the
|
|
code of this demo program into another program with substantially
|
|
different functionality, this does not cause the other program to
|
|
be covered by the GNU General Public License. This exception does
|
|
not however invalidate any other reasons why it might be covered
|
|
by the GNU General Public License. }
|
|
|
|
{$gnu-pascal,I+}
|
|
|
|
(* second style of comment *)
|
|
// Free-pascal style comment.
|
|
var x:Char = 12 /* 45; // This /* does not start a comment.
|
|
var x:Char = (/ 4); // This (/ does not start a comment.
|
|
var a_to_b : integer; // 'to' should not be highlighted
|
|
|
|
program CRTDemo;
|
|
|
|
uses GPC, CRT;
|
|
|
|
type
|
|
TFrameChars = array [1 .. 8] of Char;
|
|
TSimulateBlockCursorKind = (bc_None, bc_Blink, bc_Static);
|
|
|
|
const
|
|
SingleFrame: TFrameChars = (chCornerTLS, chLineHS, chCornerTRS, chLineVS, chLineVS, chCornerBLS, chLineHS, chCornerBRS);
|
|
DoubleFrame: TFrameChars = (chCornerTLD, chLineHD, chCornerTRD, chLineVD, chLineVD, chCornerBLD, chLineHD, chCornerBRD);
|
|
|
|
var
|
|
ScrollState: Boolean = True;
|
|
SimulateBlockCursorKind: TSimulateBlockCursorKind = bc_None;
|
|
CursorShape: TCursorShape = CursorNormal;
|
|
MainPanel: TPanel;
|
|
OrigScreenSize: TPoint;
|
|
|
|
procedure FrameWin (const Title: String; const Frame: TFrameChars; TitleInverse: Boolean);
|
|
var
|
|
w, h, y, Color: Integer;
|
|
Attr: TTextAttr;
|
|
begin
|
|
HideCursor;
|
|
SetPCCharSet (True);
|
|
ClrScr;
|
|
w := GetXMax;
|
|
h := GetYMax;
|
|
WriteCharAt (1, 1, 1, Frame[1], TextAttr);
|
|
WriteCharAt (2, 1, w - 2, Frame[2], TextAttr);
|
|
WriteCharAt (w, 1, 1, Frame[3], TextAttr);
|
|
for y := 2 to h - 1 do
|
|
begin
|
|
WriteCharAt (1, y, 1, Frame[4], TextAttr);
|
|
WriteCharAt (w, y, 1, Frame[5], TextAttr)
|
|
end;
|
|
WriteCharAt (1, h, 1, Frame[6], TextAttr);
|
|
WriteCharAt (2, h, w - 2, Frame[7], TextAttr);
|
|
WriteCharAt (w, h, 1, Frame[8], TextAttr);
|
|
SetPCCharSet (False);
|
|
Attr := TextAttr;
|
|
if TitleInverse then
|
|
begin
|
|
Color := GetTextColor;
|
|
TextColor (GetTextBackground);
|
|
TextBackground (Color)
|
|
end;
|
|
WriteStrAt ((w - Length (Title)) div 2 + 1, 1, Title, TextAttr);
|
|
TextAttr := Attr
|
|
end;
|
|
|
|
function GetKey (TimeOut: Integer) = Key: TKey; forward;
|
|
|
|
procedure ClosePopUpWindow;
|
|
begin
|
|
PanelDelete (GetActivePanel);
|
|
PanelDelete (GetActivePanel)
|
|
end;
|
|
|
|
function PopUpConfirm (XSize, YSize: Integer; const Msg: String): Boolean;
|
|
var
|
|
ax, ay: Integer;
|
|
Key: TKey;
|
|
SSize: TPoint;
|
|
begin
|
|
repeat
|
|
SSize := ScreenSize;
|
|
ax := (SSize.x - XSize - 4) div 2 + 1;
|
|
ay := (SSize.y - YSize - 4) div 2 + 1;
|
|
PanelNew (ax, ay, ax + XSize + 3, ay + YSize + 1, False);
|
|
TextBackground (Black);
|
|
TextColor (Yellow);
|
|
SetControlChars (True);
|
|
FrameWin ('', DoubleFrame, False);
|
|
NormalCursor;
|
|
PanelNew (ax + 2, ay + 1, ax + XSize + 2, ay + YSize, False);
|
|
ClrScr;
|
|
Write (Msg);
|
|
Key := GetKey (-1);
|
|
if Key = kbScreenSizeChanged then ClosePopUpWindow
|
|
until Key <> kbScreenSizeChanged;
|
|
PopUpConfirm := not (Key in [kbEsc, kbAltEsc])
|
|
end;
|
|
|
|
procedure MainDraw;
|
|
begin
|
|
WriteLn ('3, F3 : Open a window');
|
|
WriteLn ('4, F4 : Close window');
|
|
WriteLn ('5, F5 : Previous window');
|
|
WriteLn ('6, F6 : Next window');
|
|
WriteLn ('7, F7 : Move window');
|
|
WriteLn ('8, F8 : Resize window');
|
|
Write ('q, Esc: Quit')
|
|
end;
|
|
|
|
procedure StatusDraw;
|
|
const
|
|
YesNo: array [Boolean] of String [3] = ('No', 'Yes');
|
|
SimulateBlockCursorIDs: array [TSimulateBlockCursorKind] of String [8] = ('Off', 'Blinking', 'Static');
|
|
CursorShapeIDs: array [TCursorShape] of String [7] = ('Ignored', 'Hidden', 'Normal', 'Fat', 'Block');
|
|
var
|
|
SSize: TPoint;
|
|
begin
|
|
WriteLn ('You can change some of the following');
|
|
WriteLn ('settings by pressing the key shown');
|
|
WriteLn ('in parentheses. Naturally, color and');
|
|
WriteLn ('changing the cursor shape or screen');
|
|
WriteLn ('size does not work on all terminals.');
|
|
WriteLn;
|
|
WriteLn ('XCurses version: ', YesNo[XCRT]);
|
|
WriteLn ('CRTSavePreviousScreen: ', YesNo[CRTSavePreviousScreenWorks]);
|
|
WriteLn ('(M)onochrome: ', YesNo[IsMonochrome]);
|
|
SSize := ScreenSize;
|
|
WriteLn ('Screen (C)olumns: ', SSize.x);
|
|
WriteLn ('Screen (L)ines: ', SSize.y);
|
|
WriteLn ('(R)estore screen size');
|
|
WriteLn ('(B)reak checking: ', YesNo[CheckBreak]);
|
|
WriteLn ('(S)crolling: ', YesNo[ScrollState]);
|
|
WriteLn ('S(i)mulated block cursor: ', SimulateBlockCursorIDs[SimulateBlockCursorKind]);
|
|
Write ('C(u)rsor shape: ', CursorShapeIDs[CursorShape]);
|
|
GotoXY (36, WhereY)
|
|
end;
|
|
|
|
procedure RedrawAll; forward;
|
|
procedure CheckScreenSize; forward;
|
|
|
|
procedure StatusKey (Key: TKey);
|
|
var SSize, NewSize: TPoint;
|
|
begin
|
|
case LoCase (Key2Char (Key)) of
|
|
'm': begin
|
|
SetMonochrome (not IsMonochrome);
|
|
RedrawAll
|
|
end;
|
|
'c': begin
|
|
SSize := ScreenSize;
|
|
if SSize.x > 40 then
|
|
NewSize.x := 40
|
|
else
|
|
NewSize.x := 80;
|
|
if SSize.y > 25 then
|
|
NewSize.y := 50
|
|
else
|
|
NewSize.y := 25;
|
|
SetScreenSize (NewSize.x, NewSize.y);
|
|
CheckScreenSize
|
|
end;
|
|
'l': begin
|
|
SSize := ScreenSize;
|
|
if SSize.x > 40 then
|
|
NewSize.x := 80
|
|
else
|
|
NewSize.x := 40;
|
|
if SSize.y > 25 then
|
|
NewSize.y := 25
|
|
else
|
|
NewSize.y := 50;
|
|
SetScreenSize (NewSize.x, NewSize.y);
|
|
CheckScreenSize
|
|
end;
|
|
'r': begin
|
|
SetScreenSize (OrigScreenSize.x, OrigScreenSize.y);
|
|
CheckScreenSize
|
|
end;
|
|
'b': CheckBreak := not CheckBreak;
|
|
's': ScrollState := not ScrollState;
|
|
'i': if SimulateBlockCursorKind = High (SimulateBlockCursorKind) then
|
|
SimulateBlockCursorKind := Low (SimulateBlockCursorKind)
|
|
else
|
|
Inc (SimulateBlockCursorKind);
|
|
'u': case CursorShape of
|
|
CursorNormal: CursorShape := CursorBlock;
|
|
CursorFat,
|
|
CursorBlock : CursorShape := CursorHidden;
|
|
else CursorShape := CursorNormal
|
|
end;
|
|
end;
|
|
ClrScr;
|
|
StatusDraw
|
|
end;
|
|
|
|
procedure TextAttrDemo;
|
|
var f, b, y, x1, y1, x2, y2, Fill, n1, n2, n3: Integer;
|
|
begin
|
|
GetWindow (x1, y1, x2, y2);
|
|
Window (x1 - 1, y1, x2, y2);
|
|
TextColor (White);
|
|
TextBackground (Blue);
|
|
ClrScr;
|
|
SetScroll (False);
|
|
Fill := GetXMax - 32;
|
|
for y := 1 to GetYMax do
|
|
begin
|
|
GotoXY (1, y);
|
|
b := (y - 1) mod 16;
|
|
n1 := 0;
|
|
for f := 0 to 15 do
|
|
begin
|
|
TextAttr := f + 16 * b;
|
|
n2 := (Fill * (1 + 2 * f) + 16) div 32;
|
|
n3 := (Fill * (2 + 2 * f) + 16) div 32;
|
|
Write ('' : n2 - n1, NumericBaseDigitsUpper[b], NumericBaseDigitsUpper[f], '' : n3 - n2);
|
|
n1 := n3
|
|
end
|
|
end
|
|
end;
|
|
|
|
procedure CharSetDemo (UsePCCharSet: Boolean);
|
|
var h, l, y, x1, y1, x2, y2, Fill, n1, n2: Integer;
|
|
begin
|
|
GetWindow (x1, y1, x2, y2);
|
|
Window (x1 - 1, y1, x2, y2);
|
|
ClrScr;
|
|
SetScroll (False);
|
|
SetPCCharSet (UsePCCharSet);
|
|
SetControlChars (False);
|
|
Fill := GetXMax - 35;
|
|
for y := 1 to GetYMax do
|
|
begin
|
|
GotoXY (1, y);
|
|
h := (y - 2) mod 16;
|
|
n1 := (Fill + 9) div 18;
|
|
if y = 1 then
|
|
Write ('' : 3 + n1)
|
|
else
|
|
Write (16 * h : 3 + n1);
|
|
for l := 0 to 15 do
|
|
begin
|
|
n2 := (Fill * (2 + l) + 9) div 18;
|
|
if y = 1 then
|
|
Write ('' : n2 - n1, l : 2)
|
|
else
|
|
Write ('' : n2 - n1 + 1, Chr (16 * h + l));
|
|
n1 := n2
|
|
end
|
|
end
|
|
end;
|
|
|
|
procedure NormalCharSetDemo;
|
|
begin
|
|
CharSetDemo (False)
|
|
end;
|
|
|
|
procedure PCCharSetDemo;
|
|
begin
|
|
CharSetDemo (True)
|
|
end;
|
|
|
|
procedure FKeyDemoDraw;
|
|
var x1, y1, x2, y2: Integer;
|
|
begin
|
|
GetWindow (x1, y1, x2, y2);
|
|
Window (x1, y1, x2 - 1, y2);
|
|
ClrScr;
|
|
SetScroll (False);
|
|
WriteLn ('You can type the following keys');
|
|
WriteLn ('(function keys if present on the');
|
|
WriteLn ('terminal, letters as alternatives):');
|
|
GotoXY (1, 4);
|
|
WriteLn ('S, Left : left (wrap-around)');
|
|
WriteLn ('D, Right : right (wrap-around)');
|
|
WriteLn ('E, Up : up (wrap-around)');
|
|
WriteLn ('X, Down : down (wrap-around)');
|
|
WriteLn ('A, Home : go to first column');
|
|
WriteLn ('F, End : go to last column');
|
|
WriteLn ('R, Page Up : go to first line');
|
|
WriteLn ('C, Page Down: go to last line');
|
|
WriteLn ('Y, Ctrl-PgUp: first column and line');
|
|
GotoXY (1, 13);
|
|
WriteLn ('B, Ctrl-PgDn: last column and line');
|
|
WriteLn ('Z, Ctrl-Home: clear screen');
|
|
WriteLn ('N, Ctrl-End : clear to end of line');
|
|
WriteLn ('V, Insert : insert a line');
|
|
WriteLn ('T, Delete : delete a line');
|
|
WriteLn ('# : beep');
|
|
WriteLn ('* : flash');
|
|
WriteLn ('Tab, Enter, Backspace, other');
|
|
WriteLn (' normal characters: write text')
|
|
end;
|
|
|
|
procedure FKeyDemoKey (Key: TKey);
|
|
const TabSize = 8;
|
|
var
|
|
ch: Char;
|
|
NewX: Integer;
|
|
begin
|
|
case LoCaseKey (Key) of
|
|
Ord ('s'), kbLeft : if WhereX = 1 then GotoXY (GetXMax, WhereY) else GotoXY (WhereX - 1, WhereY);
|
|
Ord ('d'), kbRight : if WhereX = GetXMax then GotoXY (1, WhereY) else GotoXY (WhereX + 1, WhereY);
|
|
Ord ('e'), kbUp : if WhereY = 1 then GotoXY (WhereX, GetYMax) else GotoXY (WhereX, WhereY - 1);
|
|
Ord ('x'), kbDown : if WhereY = GetYMax then GotoXY (WhereX, 1) else GotoXY (WhereX, WhereY + 1);
|
|
Ord ('a'), kbHome : Write (chCR);
|
|
Ord ('f'), kbEnd : GotoXY (GetXMax, WhereY);
|
|
Ord ('r'), kbPgUp : GotoXY (WhereX, 1);
|
|
Ord ('c'), kbPgDn : GotoXY (WhereX, GetYMax);
|
|
Ord ('y'), kbCtrlPgUp: GotoXY (1, 1);
|
|
Ord ('b'), kbCtrlPgDn: GotoXY (GetXMax, GetYMax);
|
|
Ord ('z'), kbCtrlHome: ClrScr;
|
|
Ord ('n'), kbCtrlEnd : ClrEOL;
|
|
Ord ('v'), kbIns : InsLine;
|
|
Ord ('t'), kbDel : DelLine;
|
|
Ord ('#') : Beep;
|
|
Ord ('*') : Flash;
|
|
kbTab : begin
|
|
NewX := ((WhereX - 1) div TabSize + 1) * TabSize + 1;
|
|
if NewX <= GetXMax then GotoXY (NewX, WhereY) else WriteLn
|
|
end;
|
|
kbCR : WriteLn;
|
|
kbBkSp : Write (chBkSp, ' ', chBkSp);
|
|
else ch := Key2Char (Key);
|
|
if ch <> #0 then Write (ch)
|
|
end
|
|
end;
|
|
|
|
procedure KeyDemoDraw;
|
|
begin
|
|
WriteLn ('Press some keys ...')
|
|
end;
|
|
|
|
procedure KeyDemoKey (Key: TKey);
|
|
var ch: Char;
|
|
begin
|
|
ch := Key2Char (Key);
|
|
if ch <> #0 then
|
|
begin
|
|
Write ('Normal key');
|
|
if IsPrintable (ch) then Write (' `', ch, '''');
|
|
WriteLn (', ASCII #', Ord (ch))
|
|
end
|
|
else
|
|
WriteLn ('Special key ', Ord (Key2Scan (Key)))
|
|
end;
|
|
|
|
procedure IOSelectPeriodical;
|
|
var
|
|
CurrentTime: TimeStamp;
|
|
s: String (8);
|
|
i: Integer;
|
|
begin
|
|
GetTimeStamp (CurrentTime);
|
|
with CurrentTime do
|
|
WriteStr (s, Hour : 2, ':', Minute : 2, ':', Second : 2);
|
|
for i := 1 to Length (s) do
|
|
if s[i] = ' ' then s[i] := '0';
|
|
GotoXY (1, 12);
|
|
Write ('The time is: ', s)
|
|
end;
|
|
|
|
procedure IOSelectDraw;
|
|
begin
|
|
WriteLn ('IOSelect is a way to handle I/O from');
|
|
WriteLn ('or to several places simultaneously,');
|
|
WriteLn ('without having to use threads or');
|
|
WriteLn ('signal/interrupt handlers or waste');
|
|
WriteLn ('CPU time with busy waiting.');
|
|
WriteLn;
|
|
WriteLn ('This demo shows how IOSelect works');
|
|
WriteLn ('in connection with CRT. It displays');
|
|
WriteLn ('a clock, but still reacts to user');
|
|
WriteLn ('input immediately.');
|
|
IOSelectPeriodical
|
|
end;
|
|
|
|
procedure ModifierPeriodical;
|
|
const
|
|
Pressed: array [Boolean] of String [8] = ('Released', 'Pressed');
|
|
ModifierNames: array [1 .. 7] of record
|
|
Modifier: Integer;
|
|
Name: String (17)
|
|
end =
|
|
((shLeftShift, 'Left Shift'),
|
|
(shRightShift, 'Right Shift'),
|
|
(shLeftCtrl, 'Left Control'),
|
|
(shRightCtrl, 'Right Control'),
|
|
(shAlt, 'Alt (left)'),
|
|
(shAltGr, 'AltGr (right Alt)'),
|
|
(shExtra, 'Extra'));
|
|
var
|
|
ShiftState, i: Integer;
|
|
begin
|
|
ShiftState := GetShiftState;
|
|
for i := 1 to 7 do
|
|
with ModifierNames[i] do
|
|
begin
|
|
GotoXY (1, 4 + i);
|
|
ClrEOL;
|
|
Write (Name, ':');
|
|
GotoXY (20, WhereY);
|
|
Write (Pressed[(ShiftState and Modifier) <> 0])
|
|
end
|
|
end;
|
|
|
|
procedure ModifierDraw;
|
|
begin
|
|
WriteLn ('Modifier keys (NOTE: only');
|
|
WriteLn ('available on some systems;');
|
|
WriteLn ('X11: only after key press):');
|
|
ModifierPeriodical
|
|
end;
|
|
|
|
procedure ChecksDraw;
|
|
begin
|
|
WriteLn ('(O)S shell');
|
|
WriteLn ('OS shell with (C)learing');
|
|
WriteLn ('(R)efresh check');
|
|
Write ('(S)ound check')
|
|
end;
|
|
|
|
procedure ChecksKey (Key: TKey);
|
|
var
|
|
i, j: Integer;
|
|
WasteTime: Real; attribute (volatile);
|
|
|
|
procedure DoOSShell;
|
|
var
|
|
Result: Integer;
|
|
Shell: TString;
|
|
begin
|
|
Shell := GetShellPath (Null);
|
|
{$I-}
|
|
Result := Execute (Shell);
|
|
{$I+}
|
|
if (InOutRes <> 0) or (Result <> 0) then
|
|
begin
|
|
ClrScr;
|
|
if InOutRes <> 0 then
|
|
WriteLn (GetIOErrorMessage, ' while trying to execute `', Shell, '''.')
|
|
else
|
|
WriteLn ('`', Shell, ''' returned status ', Result, '.');
|
|
Write ('Any key to continue.');
|
|
BlockCursor;
|
|
Discard (GetKey (-1))
|
|
end
|
|
end;
|
|
|
|
begin
|
|
case LoCase (Key2Char (Key)) of
|
|
'o': begin
|
|
if PopUpConfirm (36, 12, 'You will now get an OS shell. Unless' + NewLine +
|
|
'CRTDemo is running in its own (GUI)' + NewLine +
|
|
'window, the shell will run on the' + NewLine +
|
|
'same screen as CRTDemo which is not' + NewLine +
|
|
'cleared before the shell is started.' + NewLine +
|
|
'If possible, the screen contents are' + NewLine +
|
|
'restored to the state before CRTDemo' + NewLine +
|
|
'was started. After leaving the shell' + NewLine +
|
|
'in the usual way (usually by enter-' + NewLine +
|
|
'ing `exit''), you will get back to' + NewLine +
|
|
'the demo. <ESC> to abort, any other' + NewLine +
|
|
'key to start.') then
|
|
begin
|
|
RestoreTerminal (True);
|
|
DoOSShell
|
|
end;
|
|
ClosePopUpWindow
|
|
end;
|
|
'c': begin
|
|
if PopUpConfirm (36, 9, 'You will now get an OS shell. Unless' + NewLine +
|
|
'CRTDemo is running in its own (GUI)' + NewLine +
|
|
'window, the screen will be cleared,' + NewLine +
|
|
'and the cursor will be moved to the' + NewLine +
|
|
'top before the shell is started.' + NewLine +
|
|
'After leaving the shell in the usual' + NewLine +
|
|
'way (usually by entering `exit''),' + NewLine +
|
|
'you will get back to the demo. <ESC>' + NewLine +
|
|
'to abort, any other key to start.') then
|
|
begin
|
|
RestoreTerminalClearCRT;
|
|
DoOSShell
|
|
end;
|
|
ClosePopUpWindow
|
|
end;
|
|
'r': begin
|
|
if PopUpConfirm (36, 11, 'The program will now get busy with' + NewLine +
|
|
'some dummy computations. However,' + NewLine +
|
|
'CRT output in the form of dots will' + NewLine +
|
|
'still appear continuously one by one' + NewLine +
|
|
'(rather than the whole line at once' + NewLine +
|
|
'in the end). While running, the test' + NewLine +
|
|
'cannot be interrupted. <ESC> to' + NewLine +
|
|
'abort, any other key to start.') then
|
|
begin
|
|
SetCRTUpdate (UpdateRegularly);
|
|
BlockCursor;
|
|
WriteLn;
|
|
WriteLn;
|
|
for i := 1 to GetXMax - 2 do
|
|
begin
|
|
Write ('.');
|
|
for j := 1 to 400000 do WasteTime := Random
|
|
end;
|
|
SetCRTUpdate (UpdateInput);
|
|
WriteLn;
|
|
Write ('Press any key.');
|
|
Discard (GetKey (-1))
|
|
end;
|
|
ClosePopUpWindow
|
|
end;
|
|
's': begin
|
|
if PopUpConfirm (32, 4, 'You will now hear some sounds if' + NewLine +
|
|
'supported (otherwise there will' + NewLine +
|
|
'just be a short pause). <ESC> to' + NewLine +
|
|
'abort, any other key to start.') then
|
|
begin
|
|
BlockCursor;
|
|
for i := 0 to 7 do
|
|
begin
|
|
Sound (Round (440 * 2 ** (Round (i * 12 / 7 + 0.3) / 12)));
|
|
if GetKey (400000) in [kbEsc, kbAltEsc] then Break
|
|
end;
|
|
NoSound
|
|
end;
|
|
ClosePopUpWindow
|
|
end;
|
|
end
|
|
end;
|
|
|
|
type
|
|
PWindowList = ^TWindowList;
|
|
TWindowList = record
|
|
Next, Prev: PWindowList;
|
|
Panel, FramePanel: TPanel;
|
|
WindowType: Integer;
|
|
x1, y1, xs, ys: Integer;
|
|
State: (ws_None, ws_Moving, ws_Resizing);
|
|
end;
|
|
|
|
TKeyProc = procedure (Key: TKey);
|
|
TProcedure = procedure;
|
|
|
|
const
|
|
MenuNameLength = 16;
|
|
WindowTypes: array [0 .. 9] of record
|
|
DrawProc,
|
|
PeriodicalProc: procedure;
|
|
KeyProc : TKeyProc;
|
|
Name : String (MenuNameLength);
|
|
Color,
|
|
Background,
|
|
MinSizeX,
|
|
MinSizeY,
|
|
PrefSizeX,
|
|
PrefSizeY : Integer;
|
|
RedrawAlways,
|
|
WantCursor : Boolean
|
|
end =
|
|
((MainDraw , nil , nil , 'CRT Demo' , LightGreen, Blue , 26, 7, 0, 0, False, False),
|
|
(StatusDraw , nil , StatusKey , 'Status' , White , Red , 38, 16, 0, 0, True, True),
|
|
(TextAttrDemo , nil , nil , 'Text Attributes' , White , Blue , 32, 16, 64, 16, False, False),
|
|
(NormalCharSetDemo, nil , nil , 'Character Set' , Black , Green , 35, 17, 53, 17, False, False),
|
|
(PCCharSetDemo , nil , nil , 'PC Character Set', Black , Brown , 35, 17, 53, 17, False, False),
|
|
(KeyDemoDraw , nil , KeyDemoKey , 'Keys' , Blue , LightGray, 29, 5, -1, -1, False, True),
|
|
(FKeyDemoDraw , nil , FKeyDemoKey, 'Function Keys' , Blue , LightGray, 37, 22, -1, -1, False, True),
|
|
(ModifierDraw , ModifierPeriodical, nil , 'Modifier Keys' , Black , Cyan , 29, 11, 0, 0, True, False),
|
|
(IOSelectDraw , IOSelectPeriodical, nil , 'IOSelect Demo' , White , Magenta , 38, 12, 0, 0, False, False),
|
|
(ChecksDraw , nil , ChecksKey , 'Various Checks' , Black , Red , 26, 4, 0, 0, False, False));
|
|
|
|
MenuMax = High (WindowTypes);
|
|
MenuXSize = MenuNameLength + 4;
|
|
MenuYSize = MenuMax + 2;
|
|
|
|
var
|
|
WindowList: PWindowList = nil;
|
|
|
|
procedure RedrawFrame (p: PWindowList);
|
|
begin
|
|
with p^, WindowTypes[WindowType] do
|
|
begin
|
|
PanelActivate (FramePanel);
|
|
Window (x1, y1, x1 + xs - 1, y1 + ys - 1);
|
|
ClrScr;
|
|
case State of
|
|
ws_None : if p = WindowList then
|
|
FrameWin (' ' + Name + ' ', DoubleFrame, True)
|
|
else
|
|
FrameWin (' ' + Name + ' ', SingleFrame, False);
|
|
ws_Moving : FrameWin (' Move Window ', SingleFrame, True);
|
|
ws_Resizing: FrameWin (' Resize Window ', SingleFrame, True);
|
|
end
|
|
end
|
|
end;
|
|
|
|
procedure DrawWindow (p: PWindowList);
|
|
begin
|
|
with p^, WindowTypes[WindowType] do
|
|
begin
|
|
RedrawFrame (p);
|
|
PanelActivate (Panel);
|
|
Window (x1 + 2, y1 + 1, x1 + xs - 2, y1 + ys - 2);
|
|
ClrScr;
|
|
DrawProc
|
|
end
|
|
end;
|
|
|
|
procedure RedrawAll;
|
|
var
|
|
LastPanel: TPanel;
|
|
p: PWindowList;
|
|
x2, y2: Integer;
|
|
begin
|
|
LastPanel := GetActivePanel;
|
|
PanelActivate (MainPanel);
|
|
TextBackground (Blue);
|
|
ClrScr;
|
|
p := WindowList;
|
|
if p <> nil then
|
|
repeat
|
|
with p^ do
|
|
begin
|
|
PanelActivate (FramePanel);
|
|
GetWindow (x1, y1, x2, y2); { updated automatically by CRT }
|
|
xs := x2 - x1 + 1;
|
|
ys := y2 - y1 + 1
|
|
end;
|
|
DrawWindow (p);
|
|
p := p^.Next
|
|
until p = WindowList;
|
|
PanelActivate (LastPanel)
|
|
end;
|
|
|
|
procedure CheckScreenSize;
|
|
var
|
|
LastPanel: TPanel;
|
|
MinScreenSizeX, MinScreenSizeY, i: Integer;
|
|
SSize: TPoint;
|
|
begin
|
|
LastPanel := GetActivePanel;
|
|
PanelActivate (MainPanel);
|
|
HideCursor;
|
|
MinScreenSizeX := MenuXSize;
|
|
MinScreenSizeY := MenuYSize;
|
|
for i := Low (WindowTypes) to High (WindowTypes) do
|
|
with WindowTypes[i] do
|
|
begin
|
|
MinScreenSizeX := Max (MinScreenSizeX, MinSizeX + 2);
|
|
MinScreenSizeY := Max (MinScreenSizeY, MinSizeY + 2)
|
|
end;
|
|
SSize := ScreenSize;
|
|
Window (1, 1, SSize.x, SSize.y);
|
|
if (SSize.x < MinScreenSizeX) or (SSize.y < MinScreenSizeY) then
|
|
begin
|
|
NormVideo;
|
|
ClrScr;
|
|
RestoreTerminal (True);
|
|
WriteLn (StdErr, 'Sorry, your screen is too small for this demo (', SSize.x, 'x', SSize.y, ').');
|
|
WriteLn (StdErr, 'You need at least ', MinScreenSizeX, 'x', MinScreenSizeY, ' characters.');
|
|
Halt (2)
|
|
end;
|
|
PanelActivate (LastPanel);
|
|
RedrawAll
|
|
end;
|
|
|
|
procedure Die; attribute (noreturn);
|
|
begin
|
|
NoSound;
|
|
RestoreTerminalClearCRT;
|
|
WriteLn (StdErr, 'You''re trying to kill me. Since I have break checking turned off,');
|
|
WriteLn (StdErr, 'I''m not dying, but I''ll do you a favor and terminate now.');
|
|
Halt (3)
|
|
end;
|
|
|
|
function GetKey (TimeOut: Integer) = Key: TKey;
|
|
var
|
|
NeedSelect, SelectValue: Integer;
|
|
SimulateBlockCursorCurrent: TSimulateBlockCursorKind;
|
|
SelectInput: array [1 .. 1] of PAnyFile = (@Input);
|
|
NextSelectTime: MicroSecondTimeType = 0; attribute (static);
|
|
TimeOutTime: MicroSecondTimeType;
|
|
LastPanel: TPanel;
|
|
p: PWindowList;
|
|
begin
|
|
LastPanel := GetActivePanel;
|
|
if TimeOut < 0 then
|
|
TimeOutTime := High (TimeOutTime)
|
|
else
|
|
TimeOutTime := GetMicroSecondTime + TimeOut;
|
|
NeedSelect := 0;
|
|
if TimeOut >= 0 then
|
|
Inc (NeedSelect);
|
|
SimulateBlockCursorCurrent := SimulateBlockCursorKind;
|
|
if SimulateBlockCursorCurrent <> bc_None then
|
|
Inc (NeedSelect);
|
|
p := WindowList;
|
|
repeat
|
|
if @WindowTypes[p^.WindowType].PeriodicalProc <> nil then
|
|
Inc (NeedSelect);
|
|
p := p^.Next
|
|
until p = WindowList;
|
|
p := WindowList;
|
|
repeat
|
|
with p^, WindowTypes[WindowType] do
|
|
if RedrawAlways then
|
|
begin
|
|
PanelActivate (Panel);
|
|
ClrScr;
|
|
DrawProc
|
|
end;
|
|
p := p^.Next
|
|
until p = WindowList;
|
|
if NeedSelect <> 0 then
|
|
repeat
|
|
CRTUpdate;
|
|
SelectValue := IOSelectRead (SelectInput, Max (0, Min (NextSelectTime, TimeOutTime) - GetMicroSecondTime));
|
|
if SelectValue = 0 then
|
|
begin
|
|
case SimulateBlockCursorCurrent of
|
|
bc_None : ;
|
|
bc_Blink : SimulateBlockCursor;
|
|
bc_Static: begin
|
|
SimulateBlockCursor;
|
|
SimulateBlockCursorCurrent := bc_None;
|
|
Dec (NeedSelect)
|
|
end
|
|
end;
|
|
NextSelectTime := GetMicroSecondTime + 120000;
|
|
p := WindowList;
|
|
repeat
|
|
with p^, WindowTypes[WindowType] do
|
|
if @PeriodicalProc <> nil then
|
|
begin
|
|
PanelActivate (Panel);
|
|
PeriodicalProc
|
|
end;
|
|
p := p^.Next
|
|
until p = WindowList
|
|
end;
|
|
until (NeedSelect = 0) or (SelectValue <> 0) or ((TimeOut >= 0) and (GetMicroSecondTime >= TimeOutTime));
|
|
if NeedSelect = 0 then
|
|
SelectValue := 1;
|
|
if SelectValue = 0 then
|
|
Key := 0
|
|
else
|
|
Key := ReadKeyWord;
|
|
if SimulateBlockCursorKind <> bc_None then
|
|
SimulateBlockCursorOff;
|
|
if IsDeadlySignal (Key) then Die;
|
|
if Key = kbScreenSizeChanged then CheckScreenSize;
|
|
PanelActivate (LastPanel)
|
|
end;
|
|
|
|
function Menu = n: Integer;
|
|
var
|
|
i, ax, ay: Integer;
|
|
Key: TKey;
|
|
Done: Boolean;
|
|
SSize: TPoint;
|
|
begin
|
|
n := 1;
|
|
repeat
|
|
SSize := ScreenSize;
|
|
ax := (SSize.x - MenuXSize) div 2 + 1;
|
|
ay := (SSize.y - MenuYSize) div 2 + 1;
|
|
PanelNew (ax, ay, ax + MenuXSize - 1, ay + MenuYSize - 1, False);
|
|
SetControlChars (True);
|
|
TextColor (Blue);
|
|
TextBackground (LightGray);
|
|
FrameWin (' Select Window ', DoubleFrame, True);
|
|
IgnoreCursor;
|
|
PanelNew (ax + 1, ay + 1, ax + MenuXSize - 2, ay + MenuYSize - 2, False);
|
|
ClrScr;
|
|
TextColor (Black);
|
|
SetScroll (False);
|
|
Done := False;
|
|
repeat
|
|
for i := 1 to MenuMax do
|
|
begin
|
|
GotoXY (1, i);
|
|
if i = n then
|
|
TextBackground (Green)
|
|
else
|
|
TextBackground (LightGray);
|
|
ClrEOL;
|
|
Write (' ', WindowTypes[i].Name);
|
|
ChangeTextAttr (2, i, 1, Red + $10 * GetTextBackground)
|
|
end;
|
|
Key := GetKey (-1);
|
|
case LoCaseKey (Key) of
|
|
kbUp : if n = 1 then n := MenuMax else Dec (n);
|
|
kbDown : if n = MenuMax then n := 1 else Inc (n);
|
|
kbHome,
|
|
kbPgUp,
|
|
kbCtrlPgUp,
|
|
kbCtrlHome : n := 1;
|
|
kbEnd,
|
|
kbPgDn,
|
|
kbCtrlPgDn,
|
|
kbCtrlEnd : n := MenuMax;
|
|
kbCR : Done := True;
|
|
kbEsc, kbAltEsc : begin
|
|
n := -1;
|
|
Done := True
|
|
end;
|
|
Ord ('a') .. Ord ('z'): begin
|
|
i := MenuMax;
|
|
while (i > 0) and (LoCase (Key2Char (Key)) <> LoCase (WindowTypes[i].Name[1])) do Dec (i);
|
|
if i > 0 then
|
|
begin
|
|
n := i;
|
|
Done := True
|
|
end
|
|
end;
|
|
end
|
|
until Done or (Key = kbScreenSizeChanged);
|
|
ClosePopUpWindow
|
|
until Key <> kbScreenSizeChanged
|
|
end;
|
|
|
|
procedure NewWindow (WindowType, ax, ay: Integer);
|
|
var
|
|
p, LastWindow: PWindowList;
|
|
MaxX1, MaxY1: Integer;
|
|
SSize: TPoint;
|
|
begin
|
|
New (p);
|
|
if WindowList = nil then
|
|
begin
|
|
p^.Prev := p;
|
|
p^.Next := p
|
|
end
|
|
else
|
|
begin
|
|
p^.Prev := WindowList;
|
|
p^.Next := WindowList^.Next;
|
|
p^.Prev^.Next := p;
|
|
p^.Next^.Prev := p;
|
|
end;
|
|
p^.WindowType := WindowType;
|
|
with p^, WindowTypes[WindowType] do
|
|
begin
|
|
SSize := ScreenSize;
|
|
if PrefSizeX > 0 then xs := PrefSizeX else xs := MinSizeX;
|
|
if PrefSizeY > 0 then ys := PrefSizeY else ys := MinSizeY;
|
|
xs := Min (xs + 2, SSize.x);
|
|
ys := Min (ys + 2, SSize.y);
|
|
MaxX1 := SSize.x - xs + 1;
|
|
MaxY1 := SSize.y - ys + 1;
|
|
if ax = 0 then x1 := Random (MaxX1) + 1 else x1 := Min (ax, MaxX1);
|
|
if ay = 0 then y1 := Random (MaxY1) + 1 else y1 := Min (ay, MaxY1);
|
|
if (ax = 0) and (PrefSizeX < 0) then Inc (xs, Random (SSize.x - x1 - xs + 2));
|
|
if (ax = 0) and (PrefSizeY < 0) then Inc (ys, Random (SSize.y - y1 - ys + 2));
|
|
State := ws_None;
|
|
PanelNew (1, 1, 1, 1, False);
|
|
FramePanel := GetActivePanel;
|
|
SetControlChars (True);
|
|
TextColor (Color);
|
|
TextBackground (Background);
|
|
PanelNew (1, 1, 1, 1, False);
|
|
SetPCCharSet (False);
|
|
Panel := GetActivePanel;
|
|
end;
|
|
LastWindow := WindowList;
|
|
WindowList := p;
|
|
if LastWindow <> nil then RedrawFrame (LastWindow);
|
|
DrawWindow (p)
|
|
end;
|
|
|
|
procedure OpenWindow;
|
|
var WindowType: Integer;
|
|
begin
|
|
WindowType := Menu;
|
|
if WindowType >= 0 then NewWindow (WindowType, 0, 0)
|
|
end;
|
|
|
|
procedure NextWindow;
|
|
var LastWindow: PWindowList;
|
|
begin
|
|
LastWindow := WindowList;
|
|
WindowList := WindowList^.Next;
|
|
PanelTop (WindowList^.FramePanel);
|
|
PanelTop (WindowList^.Panel);
|
|
RedrawFrame (LastWindow);
|
|
RedrawFrame (WindowList)
|
|
end;
|
|
|
|
procedure PreviousWindow;
|
|
var LastWindow: PWindowList;
|
|
begin
|
|
PanelMoveAbove (WindowList^.Panel, MainPanel);
|
|
PanelMoveAbove (WindowList^.FramePanel, MainPanel);
|
|
LastWindow := WindowList;
|
|
WindowList := WindowList^.Prev;
|
|
RedrawFrame (LastWindow);
|
|
RedrawFrame (WindowList)
|
|
end;
|
|
|
|
procedure CloseWindow;
|
|
var p: PWindowList;
|
|
begin
|
|
if WindowList^.WindowType <> 0 then
|
|
begin
|
|
p := WindowList;
|
|
NextWindow;
|
|
PanelDelete (p^.FramePanel);
|
|
PanelDelete (p^.Panel);
|
|
p^.Next^.Prev := p^.Prev;
|
|
p^.Prev^.Next := p^.Next;
|
|
Dispose (p)
|
|
end
|
|
end;
|
|
|
|
procedure MoveWindow;
|
|
var
|
|
Done, Changed: Boolean;
|
|
SSize: TPoint;
|
|
begin
|
|
with WindowList^ do
|
|
begin
|
|
Done := False;
|
|
Changed := True;
|
|
State := ws_Moving;
|
|
repeat
|
|
if Changed then DrawWindow (WindowList);
|
|
Changed := True;
|
|
case LoCaseKey (GetKey (-1)) of
|
|
Ord ('s'), kbLeft : if x1 > 1 then Dec (x1);
|
|
Ord ('d'), kbRight : if x1 + xs - 1 < ScreenSize.x then Inc (x1);
|
|
Ord ('e'), kbUp : if y1 > 1 then Dec (y1);
|
|
Ord ('x'), kbDown : if y1 + ys - 1 < ScreenSize.y then Inc (y1);
|
|
Ord ('a'), kbHome : x1 := 1;
|
|
Ord ('f'), kbEnd : x1 := ScreenSize.x - xs + 1;
|
|
Ord ('r'), kbPgUp : y1 := 1;
|
|
Ord ('c'), kbPgDn : y1 := ScreenSize.y - ys + 1;
|
|
Ord ('y'), kbCtrlPgUp: begin
|
|
x1 := 1;
|
|
y1 := 1
|
|
end;
|
|
Ord ('b'), kbCtrlPgDn: begin
|
|
SSize := ScreenSize;
|
|
x1 := SSize.x - xs + 1;
|
|
y1 := SSize.y - ys + 1
|
|
end;
|
|
kbCR,
|
|
kbEsc, kbAltEsc : Done := True;
|
|
else Changed := False
|
|
end
|
|
until Done;
|
|
State := ws_None;
|
|
DrawWindow (WindowList)
|
|
end
|
|
end;
|
|
|
|
procedure ResizeWindow;
|
|
var
|
|
Done, Changed: Boolean;
|
|
SSize: TPoint;
|
|
begin
|
|
with WindowList^, WindowTypes[WindowType] do
|
|
begin
|
|
Done := False;
|
|
Changed := True;
|
|
State := ws_Resizing;
|
|
repeat
|
|
if Changed then DrawWindow (WindowList);
|
|
Changed := True;
|
|
case LoCaseKey (GetKey (-1)) of
|
|
Ord ('s'), kbLeft : if xs > MinSizeX + 2 then Dec (xs);
|
|
Ord ('d'), kbRight : if x1 + xs - 1 < ScreenSize.x then Inc (xs);
|
|
Ord ('e'), kbUp : if ys > MinSizeY + 2 then Dec (ys);
|
|
Ord ('x'), kbDown : if y1 + ys - 1 < ScreenSize.y then Inc (ys);
|
|
Ord ('a'), kbHome : xs := MinSizeX + 2;
|
|
Ord ('f'), kbEnd : xs := ScreenSize.x - x1 + 1;
|
|
Ord ('r'), kbPgUp : ys := MinSizeY + 2;
|
|
Ord ('c'), kbPgDn : ys := ScreenSize.y - y1 + 1;
|
|
Ord ('y'), kbCtrlPgUp: begin
|
|
xs := MinSizeX + 2;
|
|
ys := MinSizeY + 2
|
|
end;
|
|
Ord ('b'), kbCtrlPgDn: begin
|
|
SSize := ScreenSize;
|
|
xs := SSize.x - x1 + 1;
|
|
ys := SSize.y - y1 + 1
|
|
end;
|
|
kbCR,
|
|
kbEsc, kbAltEsc : Done := True;
|
|
else Changed := False
|
|
end
|
|
until Done;
|
|
State := ws_None;
|
|
DrawWindow (WindowList)
|
|
end
|
|
end;
|
|
|
|
procedure ActivateCursor;
|
|
begin
|
|
with WindowList^, WindowTypes[WindowType] do
|
|
begin
|
|
PanelActivate (Panel);
|
|
if WantCursor then
|
|
SetCursorShape (CursorShape)
|
|
else
|
|
HideCursor
|
|
end;
|
|
SetScroll (ScrollState)
|
|
end;
|
|
|
|
var
|
|
Key: TKey;
|
|
ScreenShot, Done: Boolean;
|
|
|
|
begin
|
|
ScreenShot := ParamStr (1) = '--screenshot';
|
|
if ParamCount <> Ord (ScreenShot) then
|
|
begin
|
|
RestoreTerminal (True);
|
|
WriteLn (StdErr, ParamStr (0), ': invalid argument `', ParamStr (Ord (ScreenShot) + 1), '''');
|
|
Halt (1)
|
|
end;
|
|
CRTSavePreviousScreen (True);
|
|
SetCRTUpdate (UpdateInput);
|
|
MainPanel := GetActivePanel;
|
|
CheckScreenSize;
|
|
OrigScreenSize := ScreenSize;
|
|
if ScreenShot then
|
|
begin
|
|
CursorShape := CursorBlock;
|
|
NewWindow (6, 1, 1);
|
|
NewWindow (2, 1, MaxInt);
|
|
NewWindow (8, MaxInt, 1);
|
|
NewWindow (5, 1, 27);
|
|
KeyDemoKey (Ord ('f'));
|
|
KeyDemoKey (246);
|
|
KeyDemoKey (kbDown);
|
|
NewWindow (3, MaxInt, 13);
|
|
NewWindow (4, MaxInt, 31);
|
|
NewWindow (7, MaxInt, MaxInt);
|
|
NewWindow (9, MaxInt, 33);
|
|
NewWindow (0, 1, 2);
|
|
NewWindow (1, 1, 14);
|
|
ActivateCursor;
|
|
OpenWindow
|
|
end
|
|
else
|
|
NewWindow (0, 3, 2);
|
|
Done := False;
|
|
repeat
|
|
ActivateCursor;
|
|
Key := GetKey (-1);
|
|
case LoCaseKey (Key) of
|
|
Ord ('3'), kbF3 : OpenWindow;
|
|
Ord ('4'), kbF4 : CloseWindow;
|
|
Ord ('5'), kbF5 : PreviousWindow;
|
|
Ord ('6'), kbF6 : NextWindow;
|
|
Ord ('7'), kbF7 : MoveWindow;
|
|
Ord ('8'), kbF8 : ResizeWindow;
|
|
Ord ('q'), kbEsc,
|
|
kbAltEsc: Done := True;
|
|
else
|
|
if WindowList <> nil then
|
|
with WindowList^, WindowTypes[WindowType] do
|
|
if @KeyProc <> nil then
|
|
begin
|
|
TextColor (Color);
|
|
TextBackground (Background);
|
|
KeyProc (Key)
|
|
end
|
|
end
|
|
until Done
|
|
end.
|