1 { GPC demo program for the CRT unit.
3 Copyright (C) 1999-2006, 2013 Free Software Foundation, Inc.
5 Author: Frank Heckenbach <frank@pascal.gnu.de>
7 This program is free software; you can redistribute it and/or
8 modify it under the terms of the GNU General Public License as
9 published by the Free Software Foundation, version 2.
11 This program is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with this program. If not, see <http://www.gnu.org/licenses/>.
19 As a special exception, if you incorporate even large parts of the
20 code of this demo program into another program with substantially
21 different functionality, this does not cause the other program to
22 be covered by the GNU General Public License. This exception does
23 not however invalidate any other reasons why it might be covered
24 by the GNU General Public License. }
33 TFrameChars
= array [1 .. 8] of Char;
34 TSimulateBlockCursorKind
= (bc_None
, bc_Blink
, bc_Static
);
37 SingleFrame
: TFrameChars
= (chCornerTLS
, chLineHS
, chCornerTRS
, chLineVS
, chLineVS
, chCornerBLS
, chLineHS
, chCornerBRS
);
38 DoubleFrame
: TFrameChars
= (chCornerTLD
, chLineHD
, chCornerTRD
, chLineVD
, chLineVD
, chCornerBLD
, chLineHD
, chCornerBRD
);
41 ScrollState
: Boolean = True;
42 SimulateBlockCursorKind
: TSimulateBlockCursorKind
= bc_None
;
43 CursorShape
: TCursorShape
= CursorNormal
;
45 OrigScreenSize
: TPoint
;
47 procedure FrameWin (const Title
: String; const Frame
: TFrameChars
; TitleInverse
: Boolean);
49 w
, h
, y
, Color
: Integer;
57 WriteCharAt (1, 1, 1, Frame
[1], TextAttr
);
58 WriteCharAt (2, 1, w
- 2, Frame
[2], TextAttr
);
59 WriteCharAt (w
, 1, 1, Frame
[3], TextAttr
);
60 for y
:= 2 to h
- 1 do
62 WriteCharAt (1, y
, 1, Frame
[4], TextAttr
);
63 WriteCharAt (w
, y
, 1, Frame
[5], TextAttr
)
65 WriteCharAt (1, h
, 1, Frame
[6], TextAttr
);
66 WriteCharAt (2, h
, w
- 2, Frame
[7], TextAttr
);
67 WriteCharAt (w
, h
, 1, Frame
[8], TextAttr
);
72 Color
:= GetTextColor
;
73 TextColor (GetTextBackground
);
74 TextBackground (Color
)
76 WriteStrAt ((w
- Length (Title
)) div 2 + 1, 1, Title
, TextAttr
);
80 function GetKey (TimeOut
: Integer) = Key
: TKey
; forward;
82 procedure ClosePopUpWindow
;
84 PanelDelete (GetActivePanel
);
85 PanelDelete (GetActivePanel
)
88 function PopUpConfirm (XSize
, YSize
: Integer; const Msg
: String): Boolean;
96 ax
:= (SSize
.x
- XSize
- 4) div 2 + 1;
97 ay
:= (SSize
.y
- YSize
- 4) div 2 + 1;
98 PanelNew (ax
, ay
, ax
+ XSize
+ 3, ay
+ YSize
+ 1, False);
99 TextBackground (Black
);
101 SetControlChars (True);
102 FrameWin ('', DoubleFrame
, False);
104 PanelNew (ax
+ 2, ay
+ 1, ax
+ XSize
+ 2, ay
+ YSize
, False);
108 if Key
= kbScreenSizeChanged
then ClosePopUpWindow
109 until Key
<> kbScreenSizeChanged
;
110 PopUpConfirm
:= not (Key
in [kbEsc
, kbAltEsc
])
115 WriteLn ('3, F3 : Open a window');
116 WriteLn ('4, F4 : Close window');
117 WriteLn ('5, F5 : Previous window');
118 WriteLn ('6, F6 : Next window');
119 WriteLn ('7, F7 : Move window');
120 WriteLn ('8, F8 : Resize window');
121 Write ('q, Esc: Quit')
124 procedure StatusDraw
;
126 YesNo
: array [Boolean] of String [3] = ('No', 'Yes');
127 SimulateBlockCursorIDs
: array [TSimulateBlockCursorKind
] of String [8] = ('Off', 'Blinking', 'Static');
128 CursorShapeIDs
: array [TCursorShape
] of String [7] = ('Ignored', 'Hidden', 'Normal', 'Fat', 'Block');
132 WriteLn ('You can change some of the following');
133 WriteLn ('settings by pressing the key shown');
134 WriteLn ('in parentheses. Naturally, color and');
135 WriteLn ('changing the cursor shape or screen');
136 WriteLn ('size does not work on all terminals.');
138 WriteLn ('XCurses version: ', YesNo
[XCRT
]);
139 WriteLn ('CRTSavePreviousScreen: ', YesNo
[CRTSavePreviousScreenWorks
]);
140 WriteLn ('(M)onochrome: ', YesNo
[IsMonochrome
]);
142 WriteLn ('Screen (C)olumns: ', SSize
.x
);
143 WriteLn ('Screen (L)ines: ', SSize
.y
);
144 WriteLn ('(R)estore screen size');
145 WriteLn ('(B)reak checking: ', YesNo
[CheckBreak
]);
146 WriteLn ('(S)crolling: ', YesNo
[ScrollState
]);
147 WriteLn ('S(i)mulated block cursor: ', SimulateBlockCursorIDs
[SimulateBlockCursorKind
]);
148 Write ('C(u)rsor shape: ', CursorShapeIDs
[CursorShape
]);
152 procedure RedrawAll
; forward;
153 procedure CheckScreenSize
; forward;
155 procedure StatusKey (Key
: TKey
);
156 var SSize
, NewSize
: TPoint
;
158 case LoCase (Key2Char (Key
)) of
160 SetMonochrome (not IsMonochrome
);
173 SetScreenSize (NewSize
.x
, NewSize
.y
);
186 SetScreenSize (NewSize
.x
, NewSize
.y
);
190 SetScreenSize (OrigScreenSize
.x
, OrigScreenSize
.y
);
193 'b': CheckBreak
:= not CheckBreak
;
194 's': ScrollState
:= not ScrollState
;
195 'i': if SimulateBlockCursorKind
= High (SimulateBlockCursorKind
) then
196 SimulateBlockCursorKind
:= Low (SimulateBlockCursorKind
)
198 Inc (SimulateBlockCursorKind
);
199 'u': case CursorShape
of
200 CursorNormal
: CursorShape
:= CursorBlock
;
202 CursorBlock
: CursorShape
:= CursorHidden
;
203 else CursorShape
:= CursorNormal
210 procedure TextAttrDemo
;
211 var f
, b
, y
, x1
, y1
, x2
, y2
, Fill
, n1
, n2
, n3
: Integer;
213 GetWindow (x1
, y1
, x2
, y2
);
214 Window (x1
- 1, y1
, x2
, y2
);
216 TextBackground (Blue
);
219 Fill
:= GetXMax
- 32;
220 for y
:= 1 to GetYMax
do
227 TextAttr
:= f
+ 16 * b
;
228 n2
:= (Fill
* (1 + 2 * f
) + 16) div 32;
229 n3
:= (Fill
* (2 + 2 * f
) + 16) div 32;
230 Write ('' : n2
- n1
, NumericBaseDigitsUpper
[b
], NumericBaseDigitsUpper
[f
], '' : n3
- n2
);
236 procedure CharSetDemo (UsePCCharSet
: Boolean);
237 var h
, l
, y
, x1
, y1
, x2
, y2
, Fill
, n1
, n2
: Integer;
239 GetWindow (x1
, y1
, x2
, y2
);
240 Window (x1
- 1, y1
, x2
, y2
);
243 SetPCCharSet (UsePCCharSet
);
244 SetControlChars (False);
245 Fill
:= GetXMax
- 35;
246 for y
:= 1 to GetYMax
do
250 n1
:= (Fill
+ 9) div 18;
254 Write (16 * h
: 3 + n1
);
257 n2
:= (Fill
* (2 + l
) + 9) div 18;
259 Write ('' : n2
- n1
, l
: 2)
261 Write ('' : n2
- n1
+ 1, Chr (16 * h
+ l
));
267 procedure NormalCharSetDemo
;
272 procedure PCCharSetDemo
;
277 procedure FKeyDemoDraw
;
278 var x1
, y1
, x2
, y2
: Integer;
280 GetWindow (x1
, y1
, x2
, y2
);
281 Window (x1
, y1
, x2
- 1, y2
);
284 WriteLn ('You can type the following keys');
285 WriteLn ('(function keys if present on the');
286 WriteLn ('terminal, letters as alternatives):');
288 WriteLn ('S, Left : left (wrap-around)');
289 WriteLn ('D, Right : right (wrap-around)');
290 WriteLn ('E, Up : up (wrap-around)');
291 WriteLn ('X, Down : down (wrap-around)');
292 WriteLn ('A, Home : go to first column');
293 WriteLn ('F, End : go to last column');
294 WriteLn ('R, Page Up : go to first line');
295 WriteLn ('C, Page Down: go to last line');
296 WriteLn ('Y, Ctrl-PgUp: first column and line');
298 WriteLn ('B, Ctrl-PgDn: last column and line');
299 WriteLn ('Z, Ctrl-Home: clear screen');
300 WriteLn ('N, Ctrl-End : clear to end of line');
301 WriteLn ('V, Insert : insert a line');
302 WriteLn ('T, Delete : delete a line');
303 WriteLn ('# : beep');
304 WriteLn ('* : flash');
305 WriteLn ('Tab, Enter, Backspace, other');
306 WriteLn (' normal characters: write text')
309 procedure FKeyDemoKey (Key
: TKey
);
315 case LoCaseKey (Key
) of
316 Ord ('s'), kbLeft
: if WhereX
= 1 then GotoXY (GetXMax
, WhereY
) else GotoXY (WhereX
- 1, WhereY
);
317 Ord ('d'), kbRight
: if WhereX
= GetXMax
then GotoXY (1, WhereY
) else GotoXY (WhereX
+ 1, WhereY
);
318 Ord ('e'), kbUp
: if WhereY
= 1 then GotoXY (WhereX
, GetYMax
) else GotoXY (WhereX
, WhereY
- 1);
319 Ord ('x'), kbDown
: if WhereY
= GetYMax
then GotoXY (WhereX
, 1) else GotoXY (WhereX
, WhereY
+ 1);
320 Ord ('a'), kbHome
: Write (chCR
);
321 Ord ('f'), kbEnd
: GotoXY (GetXMax
, WhereY
);
322 Ord ('r'), kbPgUp
: GotoXY (WhereX
, 1);
323 Ord ('c'), kbPgDn
: GotoXY (WhereX
, GetYMax
);
324 Ord ('y'), kbCtrlPgUp
: GotoXY (1, 1);
325 Ord ('b'), kbCtrlPgDn
: GotoXY (GetXMax
, GetYMax
);
326 Ord ('z'), kbCtrlHome
: ClrScr
;
327 Ord ('n'), kbCtrlEnd
: ClrEOL
;
328 Ord ('v'), kbIns
: InsLine
;
329 Ord ('t'), kbDel
: DelLine
;
333 NewX
:= ((WhereX
- 1) div TabSize
+ 1) * TabSize
+ 1;
334 if NewX
<= GetXMax
then GotoXY (NewX
, WhereY
) else WriteLn
337 kbBkSp
: Write (chBkSp
, ' ', chBkSp
);
338 else ch
:= Key2Char (Key
);
339 if ch
<> #0 then Write (ch
)
343 procedure KeyDemoDraw
;
345 WriteLn ('Press some keys ...')
348 procedure KeyDemoKey (Key
: TKey
);
351 ch
:= Key2Char (Key
);
354 Write ('Normal key');
355 if IsPrintable (ch
) then Write (' `', ch
, '''');
356 WriteLn (', ASCII #', Ord (ch
))
359 WriteLn ('Special key ', Ord (Key2Scan (Key
)))
362 procedure IOSelectPeriodical
;
364 CurrentTime
: TimeStamp
;
368 GetTimeStamp (CurrentTime
);
370 WriteStr (s
, Hour
: 2, ':', Minute
: 2, ':', Second
: 2);
371 for i
:= 1 to Length (s
) do
372 if s
[i
] = ' ' then s
[i
] := '0';
374 Write ('The time is: ', s
)
377 procedure IOSelectDraw
;
379 WriteLn ('IOSelect is a way to handle I/O from');
380 WriteLn ('or to several places simultaneously,');
381 WriteLn ('without having to use threads or');
382 WriteLn ('signal/interrupt handlers or waste');
383 WriteLn ('CPU time with busy waiting.');
385 WriteLn ('This demo shows how IOSelect works');
386 WriteLn ('in connection with CRT. It displays');
387 WriteLn ('a clock, but still reacts to user');
388 WriteLn ('input immediately.');
392 procedure ModifierPeriodical
;
394 Pressed
: array [Boolean] of String [8] = ('Released', 'Pressed');
395 ModifierNames
: array [1 .. 7] of record
399 ((shLeftShift
, 'Left Shift'),
400 (shRightShift
, 'Right Shift'),
401 (shLeftCtrl
, 'Left Control'),
402 (shRightCtrl
, 'Right Control'),
403 (shAlt
, 'Alt (left)'),
404 (shAltGr
, 'AltGr (right Alt)'),
407 ShiftState
, i
: Integer;
409 ShiftState
:= GetShiftState
;
411 with ModifierNames
[i
] do
417 Write (Pressed
[(ShiftState
and Modifier
) <> 0])
421 procedure ModifierDraw
;
423 WriteLn ('Modifier keys (NOTE: only');
424 WriteLn ('available on some systems;');
425 WriteLn ('X11: only after key press):');
429 procedure ChecksDraw
;
431 WriteLn ('(O)S shell');
432 WriteLn ('OS shell with (C)learing');
433 WriteLn ('(R)efresh check');
434 Write ('(S)ound check')
437 procedure ChecksKey (Key
: TKey
);
440 WasteTime
: Real; attribute (volatile
);
447 Shell
:= GetShellPath (Null
);
449 Result
:= Execute (Shell
);
451 if (InOutRes
<> 0) or (Result
<> 0) then
454 if InOutRes
<> 0 then
455 WriteLn (GetIOErrorMessage
, ' while trying to execute `', Shell
, '''.')
457 WriteLn ('`', Shell
, ''' returned status ', Result
, '.');
458 Write ('Any key to continue.');
460 Discard (GetKey (-1))
465 case LoCase (Key2Char (Key
)) of
467 if PopUpConfirm (36, 12, 'You will now get an OS shell. Unless' + NewLine
+
468 'CRTDemo is running in its own (GUI)' + NewLine
+
469 'window, the shell will run on the' + NewLine
+
470 'same screen as CRTDemo which is not' + NewLine
+
471 'cleared before the shell is started.' + NewLine
+
472 'If possible, the screen contents are' + NewLine
+
473 'restored to the state before CRTDemo' + NewLine
+
474 'was started. After leaving the shell' + NewLine
+
475 'in the usual way (usually by enter-' + NewLine
+
476 'ing `exit''), you will get back to' + NewLine
+
477 'the demo. <ESC> to abort, any other' + NewLine
+
478 'key to start.') then
480 RestoreTerminal (True);
486 if PopUpConfirm (36, 9, 'You will now get an OS shell. Unless' + NewLine
+
487 'CRTDemo is running in its own (GUI)' + NewLine
+
488 'window, the screen will be cleared,' + NewLine
+
489 'and the cursor will be moved to the' + NewLine
+
490 'top before the shell is started.' + NewLine
+
491 'After leaving the shell in the usual' + NewLine
+
492 'way (usually by entering `exit''),' + NewLine
+
493 'you will get back to the demo. <ESC>' + NewLine
+
494 'to abort, any other key to start.') then
496 RestoreTerminalClearCRT
;
502 if PopUpConfirm (36, 11, 'The program will now get busy with' + NewLine
+
503 'some dummy computations. However,' + NewLine
+
504 'CRT output in the form of dots will' + NewLine
+
505 'still appear continuously one by one' + NewLine
+
506 '(rather than the whole line at once' + NewLine
+
507 'in the end). While running, the test' + NewLine
+
508 'cannot be interrupted. <ESC> to' + NewLine
+
509 'abort, any other key to start.') then
511 SetCRTUpdate (UpdateRegularly
);
515 for i
:= 1 to GetXMax
- 2 do
518 for j
:= 1 to 400000 do WasteTime
:= Random
520 SetCRTUpdate (UpdateInput
);
522 Write ('Press any key.');
523 Discard (GetKey (-1))
528 if PopUpConfirm (32, 4, 'You will now hear some sounds if' + NewLine
+
529 'supported (otherwise there will' + NewLine
+
530 'just be a short pause). <ESC> to' + NewLine
+
531 'abort, any other key to start.') then
536 Sound (Round (440 * 2 ** (Round (i
* 12 / 7 + 0.3) / 12)));
537 if GetKey (400000) in [kbEsc
, kbAltEsc
] then Break
547 PWindowList
= ^TWindowList
;
549 Next
, Prev
: PWindowList
;
550 Panel
, FramePanel
: TPanel
;
552 x1
, y1
, xs
, ys
: Integer;
553 State
: (ws_None
, ws_Moving
, ws_Resizing
);
556 TKeyProc
= procedure (Key
: TKey
);
557 TProcedure
= procedure;
561 WindowTypes
: array [0 .. 9] of record
563 PeriodicalProc
: procedure;
565 Name
: String (MenuNameLength
);
575 ((MainDraw
, nil , nil , 'CRT Demo' , LightGreen
, Blue
, 26, 7, 0, 0, False, False),
576 (StatusDraw
, nil , StatusKey
, 'Status' , White
, Red
, 38, 16, 0, 0, True, True),
577 (TextAttrDemo
, nil , nil , 'Text Attributes' , White
, Blue
, 32, 16, 64, 16, False, False),
578 (NormalCharSetDemo
, nil , nil , 'Character Set' , Black
, Green
, 35, 17, 53, 17, False, False),
579 (PCCharSetDemo
, nil , nil , 'PC Character Set', Black
, Brown
, 35, 17, 53, 17, False, False),
580 (KeyDemoDraw
, nil , KeyDemoKey
, 'Keys' , Blue
, LightGray
, 29, 5, -1, -1, False, True),
581 (FKeyDemoDraw
, nil , FKeyDemoKey
, 'Function Keys' , Blue
, LightGray
, 37, 22, -1, -1, False, True),
582 (ModifierDraw
, ModifierPeriodical
, nil , 'Modifier Keys' , Black
, Cyan
, 29, 11, 0, 0, True, False),
583 (IOSelectDraw
, IOSelectPeriodical
, nil , 'IOSelect Demo' , White
, Magenta
, 38, 12, 0, 0, False, False),
584 (ChecksDraw
, nil , ChecksKey
, 'Various Checks' , Black
, Red
, 26, 4, 0, 0, False, False));
586 MenuMax
= High (WindowTypes
);
587 MenuXSize
= MenuNameLength
+ 4;
588 MenuYSize
= MenuMax
+ 2;
591 WindowList
: PWindowList
= nil;
593 procedure RedrawFrame (p
: PWindowList
);
595 with p
^, WindowTypes
[WindowType
] do
597 PanelActivate (FramePanel
);
598 Window (x1
, y1
, x1
+ xs
- 1, y1
+ ys
- 1);
601 ws_None
: if p
= WindowList
then
602 FrameWin (' ' + Name
+ ' ', DoubleFrame
, True)
604 FrameWin (' ' + Name
+ ' ', SingleFrame
, False);
605 ws_Moving
: FrameWin (' Move Window ', SingleFrame
, True);
606 ws_Resizing
: FrameWin (' Resize Window ', SingleFrame
, True);
611 procedure DrawWindow (p
: PWindowList
);
613 with p
^, WindowTypes
[WindowType
] do
616 PanelActivate (Panel
);
617 Window (x1
+ 2, y1
+ 1, x1
+ xs
- 2, y1
+ ys
- 2);
629 LastPanel
:= GetActivePanel
;
630 PanelActivate (MainPanel
);
631 TextBackground (Blue
);
638 PanelActivate (FramePanel
);
639 GetWindow (x1
, y1
, x2
, y2
); { updated automatically by CRT }
645 until p
= WindowList
;
646 PanelActivate (LastPanel
)
649 procedure CheckScreenSize
;
652 MinScreenSizeX
, MinScreenSizeY
, i
: Integer;
655 LastPanel
:= GetActivePanel
;
656 PanelActivate (MainPanel
);
658 MinScreenSizeX
:= MenuXSize
;
659 MinScreenSizeY
:= MenuYSize
;
660 for i
:= Low (WindowTypes
) to High (WindowTypes
) do
661 with WindowTypes
[i
] do
663 MinScreenSizeX
:= Max (MinScreenSizeX
, MinSizeX
+ 2);
664 MinScreenSizeY
:= Max (MinScreenSizeY
, MinSizeY
+ 2)
667 Window (1, 1, SSize
.x
, SSize
.y
);
668 if (SSize
.x
< MinScreenSizeX
) or (SSize
.y
< MinScreenSizeY
) then
672 RestoreTerminal (True);
673 WriteLn (StdErr
, 'Sorry, your screen is too small for this demo (', SSize
.x
, 'x', SSize
.y
, ').');
674 WriteLn (StdErr
, 'You need at least ', MinScreenSizeX
, 'x', MinScreenSizeY
, ' characters.');
677 PanelActivate (LastPanel
);
681 procedure Die
; attribute (noreturn
);
684 RestoreTerminalClearCRT
;
685 WriteLn (StdErr
, 'You''re trying to kill me. Since I have break checking turned off,');
686 WriteLn (StdErr
, 'I''m not dying, but I''ll do you a favour and terminate now.');
690 function GetKey (TimeOut
: Integer) = Key
: TKey
;
692 NeedSelect
, SelectValue
: Integer;
693 SimulateBlockCursorCurrent
: TSimulateBlockCursorKind
;
694 SelectInput
: array [1 .. 1] of PAnyFile
= (@Input
);
695 NextSelectTime
: MicroSecondTimeType
= 0; attribute (static
);
696 TimeOutTime
: MicroSecondTimeType
;
700 LastPanel
:= GetActivePanel
;
702 TimeOutTime
:= High (TimeOutTime
)
704 TimeOutTime
:= GetMicroSecondTime
+ TimeOut
;
708 SimulateBlockCursorCurrent
:= SimulateBlockCursorKind
;
709 if SimulateBlockCursorCurrent
<> bc_None
then
713 if @WindowTypes
[p
^.WindowType
].PeriodicalProc
<> nil then
716 until p
= WindowList
;
719 with p
^, WindowTypes
[WindowType
] do
722 PanelActivate (Panel
);
727 until p
= WindowList
;
728 if NeedSelect
<> 0 then
731 SelectValue
:= IOSelectRead (SelectInput
, Max (0, Min (NextSelectTime
, TimeOutTime
) - GetMicroSecondTime
));
732 if SelectValue
= 0 then
734 case SimulateBlockCursorCurrent
of
736 bc_Blink
: SimulateBlockCursor
;
739 SimulateBlockCursorCurrent
:= bc_None
;
743 NextSelectTime
:= GetMicroSecondTime
+ 120000;
746 with p
^, WindowTypes
[WindowType
] do
747 if @PeriodicalProc
<> nil then
749 PanelActivate (Panel
);
755 until (NeedSelect
= 0) or (SelectValue
<> 0) or ((TimeOut
>= 0) and (GetMicroSecondTime
>= TimeOutTime
));
756 if NeedSelect
= 0 then
758 if SelectValue
= 0 then
762 if SimulateBlockCursorKind
<> bc_None
then
763 SimulateBlockCursorOff
;
764 if IsDeadlySignal (Key
) then Die
;
765 if Key
= kbScreenSizeChanged
then CheckScreenSize
;
766 PanelActivate (LastPanel
)
769 function Menu
= n
: Integer;
779 ax
:= (SSize
.x
- MenuXSize
) div 2 + 1;
780 ay
:= (SSize
.y
- MenuYSize
) div 2 + 1;
781 PanelNew (ax
, ay
, ax
+ MenuXSize
- 1, ay
+ MenuYSize
- 1, False);
782 SetControlChars (True);
784 TextBackground (LightGray
);
785 FrameWin (' Select Window ', DoubleFrame
, True);
787 PanelNew (ax
+ 1, ay
+ 1, ax
+ MenuXSize
- 2, ay
+ MenuYSize
- 2, False);
793 for i
:= 1 to MenuMax
do
797 TextBackground (Green
)
799 TextBackground (LightGray
);
801 Write (' ', WindowTypes
[i
].Name
);
802 ChangeTextAttr (2, i
, 1, Red
+ $10 * GetTextBackground
)
805 case LoCaseKey (Key
) of
806 kbUp
: if n
= 1 then n
:= MenuMax
else Dec (n
);
807 kbDown
: if n
= MenuMax
then n
:= 1 else Inc (n
);
815 kbCtrlEnd
: n
:= MenuMax
;
817 kbEsc
, kbAltEsc
: begin
821 Ord ('a') .. Ord ('z'): begin
823 while (i
> 0) and (LoCase (Key2Char (Key
)) <> LoCase (WindowTypes
[i
].Name
[1])) do Dec (i
);
831 until Done
or (Key
= kbScreenSizeChanged
);
833 until Key
<> kbScreenSizeChanged
836 procedure NewWindow (WindowType
, ax
, ay
: Integer);
838 p
, LastWindow
: PWindowList
;
839 MaxX1
, MaxY1
: Integer;
843 if WindowList
= nil then
850 p
^.Prev
:= WindowList
;
851 p
^.Next
:= WindowList
^.Next
;
855 p
^.WindowType
:= WindowType
;
856 with p
^, WindowTypes
[WindowType
] do
859 if PrefSizeX
> 0 then xs
:= PrefSizeX
else xs
:= MinSizeX
;
860 if PrefSizeY
> 0 then ys
:= PrefSizeY
else ys
:= MinSizeY
;
861 xs
:= Min (xs
+ 2, SSize
.x
);
862 ys
:= Min (ys
+ 2, SSize
.y
);
863 MaxX1
:= SSize
.x
- xs
+ 1;
864 MaxY1
:= SSize
.y
- ys
+ 1;
865 if ax
= 0 then x1
:= Random (MaxX1
) + 1 else x1
:= Min (ax
, MaxX1
);
866 if ay
= 0 then y1
:= Random (MaxY1
) + 1 else y1
:= Min (ay
, MaxY1
);
867 if (ax
= 0) and (PrefSizeX
< 0) then Inc (xs
, Random (SSize
.x
- x1
- xs
+ 2));
868 if (ax
= 0) and (PrefSizeY
< 0) then Inc (ys
, Random (SSize
.y
- y1
- ys
+ 2));
870 PanelNew (1, 1, 1, 1, False);
871 FramePanel
:= GetActivePanel
;
872 SetControlChars (True);
874 TextBackground (Background
);
875 PanelNew (1, 1, 1, 1, False);
876 SetPCCharSet (False);
877 Panel
:= GetActivePanel
;
879 LastWindow
:= WindowList
;
881 if LastWindow
<> nil then RedrawFrame (LastWindow
);
885 procedure OpenWindow
;
886 var WindowType
: Integer;
889 if WindowType
>= 0 then NewWindow (WindowType
, 0, 0)
892 procedure NextWindow
;
893 var LastWindow
: PWindowList
;
895 LastWindow
:= WindowList
;
896 WindowList
:= WindowList
^.Next
;
897 PanelTop (WindowList
^.FramePanel
);
898 PanelTop (WindowList
^.Panel
);
899 RedrawFrame (LastWindow
);
900 RedrawFrame (WindowList
)
903 procedure PreviousWindow
;
904 var LastWindow
: PWindowList
;
906 PanelMoveAbove (WindowList
^.Panel
, MainPanel
);
907 PanelMoveAbove (WindowList
^.FramePanel
, MainPanel
);
908 LastWindow
:= WindowList
;
909 WindowList
:= WindowList
^.Prev
;
910 RedrawFrame (LastWindow
);
911 RedrawFrame (WindowList
)
914 procedure CloseWindow
;
917 if WindowList
^.WindowType
<> 0 then
921 PanelDelete (p
^.FramePanel
);
922 PanelDelete (p
^.Panel
);
923 p
^.Next
^.Prev
:= p
^.Prev
;
924 p
^.Prev
^.Next
:= p
^.Next
;
929 procedure MoveWindow
;
931 Done
, Changed
: Boolean;
940 if Changed
then DrawWindow (WindowList
);
942 case LoCaseKey (GetKey (-1)) of
943 Ord ('s'), kbLeft
: if x1
> 1 then Dec (x1
);
944 Ord ('d'), kbRight
: if x1
+ xs
- 1 < ScreenSize
.x
then Inc (x1
);
945 Ord ('e'), kbUp
: if y1
> 1 then Dec (y1
);
946 Ord ('x'), kbDown
: if y1
+ ys
- 1 < ScreenSize
.y
then Inc (y1
);
947 Ord ('a'), kbHome
: x1
:= 1;
948 Ord ('f'), kbEnd
: x1
:= ScreenSize
.x
- xs
+ 1;
949 Ord ('r'), kbPgUp
: y1
:= 1;
950 Ord ('c'), kbPgDn
: y1
:= ScreenSize
.y
- ys
+ 1;
951 Ord ('y'), kbCtrlPgUp
: begin
955 Ord ('b'), kbCtrlPgDn
: begin
957 x1
:= SSize
.x
- xs
+ 1;
958 y1
:= SSize
.y
- ys
+ 1
961 kbEsc
, kbAltEsc
: Done
:= True;
962 else Changed
:= False
966 DrawWindow (WindowList
)
970 procedure ResizeWindow
;
972 Done
, Changed
: Boolean;
975 with WindowList
^, WindowTypes
[WindowType
] do
979 State
:= ws_Resizing
;
981 if Changed
then DrawWindow (WindowList
);
983 case LoCaseKey (GetKey (-1)) of
984 Ord ('s'), kbLeft
: if xs
> MinSizeX
+ 2 then Dec (xs
);
985 Ord ('d'), kbRight
: if x1
+ xs
- 1 < ScreenSize
.x
then Inc (xs
);
986 Ord ('e'), kbUp
: if ys
> MinSizeY
+ 2 then Dec (ys
);
987 Ord ('x'), kbDown
: if y1
+ ys
- 1 < ScreenSize
.y
then Inc (ys
);
988 Ord ('a'), kbHome
: xs
:= MinSizeX
+ 2;
989 Ord ('f'), kbEnd
: xs
:= ScreenSize
.x
- x1
+ 1;
990 Ord ('r'), kbPgUp
: ys
:= MinSizeY
+ 2;
991 Ord ('c'), kbPgDn
: ys
:= ScreenSize
.y
- y1
+ 1;
992 Ord ('y'), kbCtrlPgUp
: begin
996 Ord ('b'), kbCtrlPgDn
: begin
998 xs
:= SSize
.x
- x1
+ 1;
999 ys
:= SSize
.y
- y1
+ 1
1002 kbEsc
, kbAltEsc
: Done
:= True;
1003 else Changed
:= False
1007 DrawWindow (WindowList
)
1011 procedure ActivateCursor
;
1013 with WindowList
^, WindowTypes
[WindowType
] do
1015 PanelActivate (Panel
);
1017 SetCursorShape (CursorShape
)
1021 SetScroll (ScrollState
)
1026 ScreenShot
, Done
: Boolean;
1029 ScreenShot
:= ParamStr (1) = '--screenshot';
1030 if ParamCount
<> Ord (ScreenShot
) then
1032 RestoreTerminal (True);
1033 WriteLn (StdErr
, ParamStr (0), ': invalid argument `', ParamStr (Ord (ScreenShot
) + 1), '''');
1036 CRTSavePreviousScreen (True);
1037 SetCRTUpdate (UpdateInput
);
1038 MainPanel
:= GetActivePanel
;
1040 OrigScreenSize
:= ScreenSize
;
1043 CursorShape
:= CursorBlock
;
1044 NewWindow (6, 1, 1);
1045 NewWindow (2, 1, MaxInt
);
1046 NewWindow (8, MaxInt
, 1);
1047 NewWindow (5, 1, 27);
1048 KeyDemoKey (Ord ('f'));
1050 KeyDemoKey (kbDown
);
1051 NewWindow (3, MaxInt
, 13);
1052 NewWindow (4, MaxInt
, 31);
1053 NewWindow (7, MaxInt
, MaxInt
);
1054 NewWindow (9, MaxInt
, 33);
1055 NewWindow (0, 1, 2);
1056 NewWindow (1, 1, 14);
1061 NewWindow (0, 3, 2);
1066 case LoCaseKey (Key
) of
1067 Ord ('3'), kbF3
: OpenWindow
;
1068 Ord ('4'), kbF4
: CloseWindow
;
1069 Ord ('5'), kbF5
: PreviousWindow
;
1070 Ord ('6'), kbF6
: NextWindow
;
1071 Ord ('7'), kbF7
: MoveWindow
;
1072 Ord ('8'), kbF8
: ResizeWindow
;
1074 kbAltEsc
: Done
:= True;
1076 if WindowList
<> nil then
1077 with WindowList
^, WindowTypes
[WindowType
] do
1078 if @KeyProc
<> nil then
1081 TextBackground (Background
);