mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-21 06:55:39 +00:00
Code Issues Releases Activity
master
emacs/test/manual/indent/pascal.pas
Po Lu 8e1c56ae46 ; Add 2024 to copyright years
2024-01-02 09:47:10 +08:00

1093 lines
31 KiB
ObjectPascal
Raw Permalink Blame History

{ 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.
Reference in New Issue View Git Blame Copy Permalink