HCoop / bpt / emacs.git / blob
? search:


9ba61c5abb984786261c78274d4165afed3b0dac
[bpt/emacs.git] / test / indent / pascal.pas
1 { GPC demo program for the CRT unit.
2
3 Copyright (C) 1999-2006 Free Software Foundation, Inc.
4
5 Author: Frank Heckenbach <frank@pascal.gnu.de>
6
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.
10
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.
15
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/>.
18
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. }
25
26 {$gnu-pascal,I+}
27
28 program CRTDemo;
29
30 uses GPC, CRT;
31
32 type
33 TFrameChars = array [1 .. 8] of Char;
34 TSimulateBlockCursorKind = (bc_None, bc_Blink, bc_Static);
35
36 const
37 SingleFrame: TFrameChars = (chCornerTLS, chLineHS, chCornerTRS, chLineVS, chLineVS, chCornerBLS, chLineHS, chCornerBRS);
38 DoubleFrame: TFrameChars = (chCornerTLD, chLineHD, chCornerTRD, chLineVD, chLineVD, chCornerBLD, chLineHD, chCornerBRD);
39
40 var
41 ScrollState: Boolean = True;
42 SimulateBlockCursorKind: TSimulateBlockCursorKind = bc_None;
43 CursorShape: TCursorShape = CursorNormal;
44 MainPanel: TPanel;
45 OrigScreenSize: TPoint;
46
47 procedure FrameWin (const Title: String; const Frame: TFrameChars; TitleInverse: Boolean);
48 var
49 w, h, y, Color: Integer;
50 Attr: TTextAttr;
51 begin
52 HideCursor;
53 SetPCCharSet (True);
54 ClrScr;
55 w := GetXMax;
56 h := GetYMax;
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
61 begin
62 WriteCharAt (1, y, 1, Frame[4], TextAttr);
63 WriteCharAt (w, y, 1, Frame[5], TextAttr)
64 end;
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);
68 SetPCCharSet (False);
69 Attr := TextAttr;
70 if TitleInverse then
71 begin
72 Color := GetTextColor;
73 TextColor (GetTextBackground);
74 TextBackground (Color)
75 end;
76 WriteStrAt ((w - Length (Title)) div 2 + 1, 1, Title, TextAttr);
77 TextAttr := Attr
78 end;
79
80 function GetKey (TimeOut: Integer) = Key: TKey; forward;
81
82 procedure ClosePopUpWindow;
83 begin
84 PanelDelete (GetActivePanel);
85 PanelDelete (GetActivePanel)
86 end;
87
88 function PopUpConfirm (XSize, YSize: Integer; const Msg: String): Boolean;
89 var
90 ax, ay: Integer;
91 Key: TKey;
92 SSize: TPoint;
93 begin
94 repeat
95 SSize := ScreenSize;
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);
100 TextColor (Yellow);
101 SetControlChars (True);
102 FrameWin ('', DoubleFrame, False);
103 NormalCursor;
104 PanelNew (ax + 2, ay + 1, ax + XSize + 2, ay + YSize, False);
105 ClrScr;
106 Write (Msg);
107 Key := GetKey (-1);
108 if Key = kbScreenSizeChanged then ClosePopUpWindow
109 until Key <> kbScreenSizeChanged;
110 PopUpConfirm := not (Key in [kbEsc, kbAltEsc])
111 end;
112
113 procedure MainDraw;
114 begin
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')
122 end;
123
124 procedure StatusDraw;
125 const
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');
129 var
130 SSize: TPoint;
131 begin
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.');
137 WriteLn;
138 WriteLn ('XCurses version: ', YesNo[XCRT]);
139 WriteLn ('CRTSavePreviousScreen: ', YesNo[CRTSavePreviousScreenWorks]);
140 WriteLn ('(M)onochrome: ', YesNo[IsMonochrome]);
141 SSize := ScreenSize;
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]);
149 GotoXY (36, WhereY)
150 end;
151
152 procedure RedrawAll; forward;
153 procedure CheckScreenSize; forward;
154
155 procedure StatusKey (Key: TKey);
156 var SSize, NewSize: TPoint;
157 begin
158 case LoCase (Key2Char (Key)) of
159 'm': begin
160 SetMonochrome (not IsMonochrome);
161 RedrawAll
162 end;
163 'c': begin
164 SSize := ScreenSize;
165 if SSize.x > 40 then
166 NewSize.x := 40
167 else
168 NewSize.x := 80;
169 if SSize.y > 25 then
170 NewSize.y := 50
171 else
172 NewSize.y := 25;
173 SetScreenSize (NewSize.x, NewSize.y);
174 CheckScreenSize
175 end;
176 'l': begin
177 SSize := ScreenSize;
178 if SSize.x > 40 then
179 NewSize.x := 80
180 else
181 NewSize.x := 40;
182 if SSize.y > 25 then
183 NewSize.y := 25
184 else
185 NewSize.y := 50;
186 SetScreenSize (NewSize.x, NewSize.y);
187 CheckScreenSize
188 end;
189 'r': begin
190 SetScreenSize (OrigScreenSize.x, OrigScreenSize.y);
191 CheckScreenSize
192 end;
193 'b': CheckBreak := not CheckBreak;
194 's': ScrollState := not ScrollState;
195 'i': if SimulateBlockCursorKind = High (SimulateBlockCursorKind) then
196 SimulateBlockCursorKind := Low (SimulateBlockCursorKind)
197 else
198 Inc (SimulateBlockCursorKind);
199 'u': case CursorShape of
200 CursorNormal: CursorShape := CursorBlock;
201 CursorFat,
202 CursorBlock : CursorShape := CursorHidden;
203 else CursorShape := CursorNormal
204 end;
205 end;
206 ClrScr;
207 StatusDraw
208 end;
209
210 procedure TextAttrDemo;
211 var f, b, y, x1, y1, x2, y2, Fill, n1, n2, n3: Integer;
212 begin
213 GetWindow (x1, y1, x2, y2);
214 Window (x1 - 1, y1, x2, y2);
215 TextColor (White);
216 TextBackground (Blue);
217 ClrScr;
218 SetScroll (False);
219 Fill := GetXMax - 32;
220 for y := 1 to GetYMax do
221 begin
222 GotoXY (1, y);
223 b := (y - 1) mod 16;
224 n1 := 0;
225 for f := 0 to 15 do
226 begin
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);
231 n1 := n3
232 end
233 end
234 end;
235
236 procedure CharSetDemo (UsePCCharSet: Boolean);
237 var h, l, y, x1, y1, x2, y2, Fill, n1, n2: Integer;
238 begin
239 GetWindow (x1, y1, x2, y2);
240 Window (x1 - 1, y1, x2, y2);
241 ClrScr;
242 SetScroll (False);
243 SetPCCharSet (UsePCCharSet);
244 SetControlChars (False);
245 Fill := GetXMax - 35;
246 for y := 1 to GetYMax do
247 begin
248 GotoXY (1, y);
249 h := (y - 2) mod 16;
250 n1 := (Fill + 9) div 18;
251 if y = 1 then
252 Write ('' : 3 + n1)
253 else
254 Write (16 * h : 3 + n1);
255 for l := 0 to 15 do
256 begin
257 n2 := (Fill * (2 + l) + 9) div 18;
258 if y = 1 then
259 Write ('' : n2 - n1, l : 2)
260 else
261 Write ('' : n2 - n1 + 1, Chr (16 * h + l));
262 n1 := n2
263 end
264 end
265 end;
266
267 procedure NormalCharSetDemo;
268 begin
269 CharSetDemo (False)
270 end;
271
272 procedure PCCharSetDemo;
273 begin
274 CharSetDemo (True)
275 end;
276
277 procedure FKeyDemoDraw;
278 var x1, y1, x2, y2: Integer;
279 begin
280 GetWindow (x1, y1, x2, y2);
281 Window (x1, y1, x2 - 1, y2);
282 ClrScr;
283 SetScroll (False);
284 WriteLn ('You can type the following keys');
285 WriteLn ('(function keys if present on the');
286 WriteLn ('terminal, letters as alternatives):');
287 GotoXY (1, 4);
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');
297 GotoXY (1, 13);
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')
307 end;
308
309 procedure FKeyDemoKey (Key: TKey);
310 const TabSize = 8;
311 var
312 ch: Char;
313 NewX: Integer;
314 begin
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;
330 Ord ('#') : Beep;
331 Ord ('*') : Flash;
332 kbTab : begin
333 NewX := ((WhereX - 1) div TabSize + 1) * TabSize + 1;
334 if NewX <= GetXMax then GotoXY (NewX, WhereY) else WriteLn
335 end;
336 kbCR : WriteLn;
337 kbBkSp : Write (chBkSp, ' ', chBkSp);
338 else ch := Key2Char (Key);
339 if ch <> #0 then Write (ch)
340 end
341 end;
342
343 procedure KeyDemoDraw;
344 begin
345 WriteLn ('Press some keys ...')
346 end;
347
348 procedure KeyDemoKey (Key: TKey);
349 var ch: Char;
350 begin
351 ch := Key2Char (Key);
352 if ch <> #0 then
353 begin
354 Write ('Normal key');
355 if IsPrintable (ch) then Write (' `', ch, '''');
356 WriteLn (', ASCII #', Ord (ch))
357 end
358 else
359 WriteLn ('Special key ', Ord (Key2Scan (Key)))
360 end;
361
362 procedure IOSelectPeriodical;
363 var
364 CurrentTime: TimeStamp;
365 s: String (8);
366 i: Integer;
367 begin
368 GetTimeStamp (CurrentTime);
369 with CurrentTime do
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';
373 GotoXY (1, 12);
374 Write ('The time is: ', s)
375 end;
376
377 procedure IOSelectDraw;
378 begin
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.');
384 WriteLn;
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.');
389 IOSelectPeriodical
390 end;
391
392 procedure ModifierPeriodical;
393 const
394 Pressed: array [Boolean] of String [8] = ('Released', 'Pressed');
395 ModifierNames: array [1 .. 7] of record
396 Modifier: Integer;
397 Name: String (17)
398 end =
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)'),
405 (shExtra, 'Extra'));
406 var
407 ShiftState, i: Integer;
408 begin
409 ShiftState := GetShiftState;
410 for i := 1 to 7 do
411 with ModifierNames[i] do
412 begin
413 GotoXY (1, 4 + i);
414 ClrEOL;
415 Write (Name, ':');
416 GotoXY (20, WhereY);
417 Write (Pressed[(ShiftState and Modifier) <> 0])
418 end
419 end;
420
421 procedure ModifierDraw;
422 begin
423 WriteLn ('Modifier keys (NOTE: only');
424 WriteLn ('available on some systems;');
425 WriteLn ('X11: only after key press):');
426 ModifierPeriodical
427 end;
428
429 procedure ChecksDraw;
430 begin
431 WriteLn ('(O)S shell');
432 WriteLn ('OS shell with (C)learing');
433 WriteLn ('(R)efresh check');
434 Write ('(S)ound check')
435 end;
436
437 procedure ChecksKey (Key: TKey);
438 var
439 i, j: Integer;
440 WasteTime: Real; attribute (volatile);
441
442 procedure DoOSShell;
443 var
444 Result: Integer;
445 Shell: TString;
446 begin
447 Shell := GetShellPath (Null);
448 {$I-}
449 Result := Execute (Shell);
450 {$I+}
451 if (InOutRes <> 0) or (Result <> 0) then
452 begin
453 ClrScr;
454 if InOutRes <> 0 then
455 WriteLn (GetIOErrorMessage, ' while trying to execute `', Shell, '''.')
456 else
457 WriteLn ('`', Shell, ''' returned status ', Result, '.');
458 Write ('Any key to continue.');
459 BlockCursor;
460 Discard (GetKey (-1))
461 end
462 end;
463
464 begin
465 case LoCase (Key2Char (Key)) of
466 'o': begin
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
479 begin
480 RestoreTerminal (True);
481 DoOSShell
482 end;
483 ClosePopUpWindow
484 end;
485 'c': begin
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
495 begin
496 RestoreTerminalClearCRT;
497 DoOSShell
498 end;
499 ClosePopUpWindow
500 end;
501 'r': begin
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
510 begin
511 SetCRTUpdate (UpdateRegularly);
512 BlockCursor;
513 WriteLn;
514 WriteLn;
515 for i := 1 to GetXMax - 2 do
516 begin
517 Write ('.');
518 for j := 1 to 400000 do WasteTime := Random
519 end;
520 SetCRTUpdate (UpdateInput);
521 WriteLn;
522 Write ('Press any key.');
523 Discard (GetKey (-1))
524 end;
525 ClosePopUpWindow
526 end;
527 's': begin
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
532 begin
533 BlockCursor;
534 for i := 0 to 7 do
535 begin
536 Sound (Round (440 * 2 ** (Round (i * 12 / 7 + 0.3) / 12)));
537 if GetKey (400000) in [kbEsc, kbAltEsc] then Break
538 end;
539 NoSound
540 end;
541 ClosePopUpWindow
542 end;
543 end
544 end;
545
546 type
547 PWindowList = ^TWindowList;
548 TWindowList = record
549 Next, Prev: PWindowList;
550 Panel, FramePanel: TPanel;
551 WindowType: Integer;
552 x1, y1, xs, ys: Integer;
553 State: (ws_None, ws_Moving, ws_Resizing);
554 end;
555
556 TKeyProc = procedure (Key: TKey);
557 TProcedure = procedure;
558
559 const
560 MenuNameLength = 16;
561 WindowTypes: array [0 .. 9] of record
562 DrawProc,
563 PeriodicalProc: procedure;
564 KeyProc : TKeyProc;
565 Name : String (MenuNameLength);
566 Color,
567 Background,
568 MinSizeX,
569 MinSizeY,
570 PrefSizeX,
571 PrefSizeY : Integer;
572 RedrawAlways,
573 WantCursor : Boolean
574 end =
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));
585
586 MenuMax = High (WindowTypes);
587 MenuXSize = MenuNameLength + 4;
588 MenuYSize = MenuMax + 2;
589
590 var
591 WindowList: PWindowList = nil;
592
593 procedure RedrawFrame (p: PWindowList);
594 begin
595 with p^, WindowTypes[WindowType] do
596 begin
597 PanelActivate (FramePanel);
598 Window (x1, y1, x1 + xs - 1, y1 + ys - 1);
599 ClrScr;
600 case State of
601 ws_None : if p = WindowList then
602 FrameWin (' ' + Name + ' ', DoubleFrame, True)
603 else
604 FrameWin (' ' + Name + ' ', SingleFrame, False);
605 ws_Moving : FrameWin (' Move Window ', SingleFrame, True);
606 ws_Resizing: FrameWin (' Resize Window ', SingleFrame, True);
607 end
608 end
609 end;
610
611 procedure DrawWindow (p: PWindowList);
612 begin
613 with p^, WindowTypes[WindowType] do
614 begin
615 RedrawFrame (p);
616 PanelActivate (Panel);
617 Window (x1 + 2, y1 + 1, x1 + xs - 2, y1 + ys - 2);
618 ClrScr;
619 DrawProc
620 end
621 end;
622
623 procedure RedrawAll;
624 var
625 LastPanel: TPanel;
626 p: PWindowList;
627 x2, y2: Integer;
628 begin
629 LastPanel := GetActivePanel;
630 PanelActivate (MainPanel);
631 TextBackground (Blue);
632 ClrScr;
633 p := WindowList;
634 if p <> nil then
635 repeat
636 with p^ do
637 begin
638 PanelActivate (FramePanel);
639 GetWindow (x1, y1, x2, y2); { updated automatically by CRT }
640 xs := x2 - x1 + 1;
641 ys := y2 - y1 + 1
642 end;
643 DrawWindow (p);
644 p := p^.Next
645 until p = WindowList;
646 PanelActivate (LastPanel)
647 end;
648
649 procedure CheckScreenSize;
650 var
651 LastPanel: TPanel;
652 MinScreenSizeX, MinScreenSizeY, i: Integer;
653 SSize: TPoint;
654 begin
655 LastPanel := GetActivePanel;
656 PanelActivate (MainPanel);
657 HideCursor;
658 MinScreenSizeX := MenuXSize;
659 MinScreenSizeY := MenuYSize;
660 for i := Low (WindowTypes) to High (WindowTypes) do
661 with WindowTypes[i] do
662 begin
663 MinScreenSizeX := Max (MinScreenSizeX, MinSizeX + 2);
664 MinScreenSizeY := Max (MinScreenSizeY, MinSizeY + 2)
665 end;
666 SSize := ScreenSize;
667 Window (1, 1, SSize.x, SSize.y);
668 if (SSize.x < MinScreenSizeX) or (SSize.y < MinScreenSizeY) then
669 begin
670 NormVideo;
671 ClrScr;
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.');
675 Halt (2)
676 end;
677 PanelActivate (LastPanel);
678 RedrawAll
679 end;
680
681 procedure Die; attribute (noreturn);
682 begin
683 NoSound;
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.');
687 Halt (3)
688 end;
689
690 function GetKey (TimeOut: Integer) = Key: TKey;
691 var
692 NeedSelect, SelectValue: Integer;
693 SimulateBlockCursorCurrent: TSimulateBlockCursorKind;
694 SelectInput: array [1 .. 1] of PAnyFile = (@Input);
695 NextSelectTime: MicroSecondTimeType = 0; attribute (static);
696 TimeOutTime: MicroSecondTimeType;
697 LastPanel: TPanel;
698 p: PWindowList;
699 begin
700 LastPanel := GetActivePanel;
701 if TimeOut < 0 then
702 TimeOutTime := High (TimeOutTime)
703 else
704 TimeOutTime := GetMicroSecondTime + TimeOut;
705 NeedSelect := 0;
706 if TimeOut >= 0 then
707 Inc (NeedSelect);
708 SimulateBlockCursorCurrent := SimulateBlockCursorKind;
709 if SimulateBlockCursorCurrent <> bc_None then
710 Inc (NeedSelect);
711 p := WindowList;
712 repeat
713 if @WindowTypes[p^.WindowType].PeriodicalProc <> nil then
714 Inc (NeedSelect);
715 p := p^.Next
716 until p = WindowList;
717 p := WindowList;
718 repeat
719 with p^, WindowTypes[WindowType] do
720 if RedrawAlways then
721 begin
722 PanelActivate (Panel);
723 ClrScr;
724 DrawProc
725 end;
726 p := p^.Next
727 until p = WindowList;
728 if NeedSelect <> 0 then
729 repeat
730 CRTUpdate;
731 SelectValue := IOSelectRead (SelectInput, Max (0, Min (NextSelectTime, TimeOutTime) - GetMicroSecondTime));
732 if SelectValue = 0 then
733 begin
734 case SimulateBlockCursorCurrent of
735 bc_None : ;
736 bc_Blink : SimulateBlockCursor;
737 bc_Static: begin
738 SimulateBlockCursor;
739 SimulateBlockCursorCurrent := bc_None;
740 Dec (NeedSelect)
741 end
742 end;
743 NextSelectTime := GetMicroSecondTime + 120000;
744 p := WindowList;
745 repeat
746 with p^, WindowTypes[WindowType] do
747 if @PeriodicalProc <> nil then
748 begin
749 PanelActivate (Panel);
750 PeriodicalProc
751 end;
752 p := p^.Next
753 until p = WindowList
754 end;
755 until (NeedSelect = 0) or (SelectValue <> 0) or ((TimeOut >= 0) and (GetMicroSecondTime >= TimeOutTime));
756 if NeedSelect = 0 then
757 SelectValue := 1;
758 if SelectValue = 0 then
759 Key := 0
760 else
761 Key := ReadKeyWord;
762 if SimulateBlockCursorKind <> bc_None then
763 SimulateBlockCursorOff;
764 if IsDeadlySignal (Key) then Die;
765 if Key = kbScreenSizeChanged then CheckScreenSize;
766 PanelActivate (LastPanel)
767 end;
768
769 function Menu = n: Integer;
770 var
771 i, ax, ay: Integer;
772 Key: TKey;
773 Done: Boolean;
774 SSize: TPoint;
775 begin
776 n := 1;
777 repeat
778 SSize := ScreenSize;
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);
783 TextColor (Blue);
784 TextBackground (LightGray);
785 FrameWin (' Select Window ', DoubleFrame, True);
786 IgnoreCursor;
787 PanelNew (ax + 1, ay + 1, ax + MenuXSize - 2, ay + MenuYSize - 2, False);
788 ClrScr;
789 TextColor (Black);
790 SetScroll (False);
791 Done := False;
792 repeat
793 for i := 1 to MenuMax do
794 begin
795 GotoXY (1, i);
796 if i = n then
797 TextBackground (Green)
798 else
799 TextBackground (LightGray);
800 ClrEOL;
801 Write (' ', WindowTypes[i].Name);
802 ChangeTextAttr (2, i, 1, Red + $10 * GetTextBackground)
803 end;
804 Key := GetKey (-1);
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);
808 kbHome,
809 kbPgUp,
810 kbCtrlPgUp,
811 kbCtrlHome : n := 1;
812 kbEnd,
813 kbPgDn,
814 kbCtrlPgDn,
815 kbCtrlEnd : n := MenuMax;
816 kbCR : Done := True;
817 kbEsc, kbAltEsc : begin
818 n := -1;
819 Done := True
820 end;
821 Ord ('a') .. Ord ('z'): begin
822 i := MenuMax;
823 while (i > 0) and (LoCase (Key2Char (Key)) <> LoCase (WindowTypes[i].Name[1])) do Dec (i);
824 if i > 0 then
825 begin
826 n := i;
827 Done := True
828 end
829 end;
830 end
831 until Done or (Key = kbScreenSizeChanged);
832 ClosePopUpWindow
833 until Key <> kbScreenSizeChanged
834 end;
835
836 procedure NewWindow (WindowType, ax, ay: Integer);
837 var
838 p, LastWindow: PWindowList;
839 MaxX1, MaxY1: Integer;
840 SSize: TPoint;
841 begin
842 New (p);
843 if WindowList = nil then
844 begin
845 p^.Prev := p;
846 p^.Next := p
847 end
848 else
849 begin
850 p^.Prev := WindowList;
851 p^.Next := WindowList^.Next;
852 p^.Prev^.Next := p;
853 p^.Next^.Prev := p;
854 end;
855 p^.WindowType := WindowType;
856 with p^, WindowTypes[WindowType] do
857 begin
858 SSize := ScreenSize;
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));
869 State := ws_None;
870 PanelNew (1, 1, 1, 1, False);
871 FramePanel := GetActivePanel;
872 SetControlChars (True);
873 TextColor (Color);
874 TextBackground (Background);
875 PanelNew (1, 1, 1, 1, False);
876 SetPCCharSet (False);
877 Panel := GetActivePanel;
878 end;
879 LastWindow := WindowList;
880 WindowList := p;
881 if LastWindow <> nil then RedrawFrame (LastWindow);
882 DrawWindow (p)
883 end;
884
885 procedure OpenWindow;
886 var WindowType: Integer;
887 begin
888 WindowType := Menu;
889 if WindowType >= 0 then NewWindow (WindowType, 0, 0)
890 end;
891
892 procedure NextWindow;
893 var LastWindow: PWindowList;
894 begin
895 LastWindow := WindowList;
896 WindowList := WindowList^.Next;
897 PanelTop (WindowList^.FramePanel);
898 PanelTop (WindowList^.Panel);
899 RedrawFrame (LastWindow);
900 RedrawFrame (WindowList)
901 end;
902
903 procedure PreviousWindow;
904 var LastWindow: PWindowList;
905 begin
906 PanelMoveAbove (WindowList^.Panel, MainPanel);
907 PanelMoveAbove (WindowList^.FramePanel, MainPanel);
908 LastWindow := WindowList;
909 WindowList := WindowList^.Prev;
910 RedrawFrame (LastWindow);
911 RedrawFrame (WindowList)
912 end;
913
914 procedure CloseWindow;
915 var p: PWindowList;
916 begin
917 if WindowList^.WindowType <> 0 then
918 begin
919 p := WindowList;
920 NextWindow;
921 PanelDelete (p^.FramePanel);
922 PanelDelete (p^.Panel);
923 p^.Next^.Prev := p^.Prev;
924 p^.Prev^.Next := p^.Next;
925 Dispose (p)
926 end
927 end;
928
929 procedure MoveWindow;
930 var
931 Done, Changed: Boolean;
932 SSize: TPoint;
933 begin
934 with WindowList^ do
935 begin
936 Done := False;
937 Changed := True;
938 State := ws_Moving;
939 repeat
940 if Changed then DrawWindow (WindowList);
941 Changed := True;
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
952 x1 := 1;
953 y1 := 1
954 end;
955 Ord ('b'), kbCtrlPgDn: begin
956 SSize := ScreenSize;
957 x1 := SSize.x - xs + 1;
958 y1 := SSize.y - ys + 1
959 end;
960 kbCR,
961 kbEsc, kbAltEsc : Done := True;
962 else Changed := False
963 end
964 until Done;
965 State := ws_None;
966 DrawWindow (WindowList)
967 end
968 end;
969
970 procedure ResizeWindow;
971 var
972 Done, Changed: Boolean;
973 SSize: TPoint;
974 begin
975 with WindowList^, WindowTypes[WindowType] do
976 begin
977 Done := False;
978 Changed := True;
979 State := ws_Resizing;
980 repeat
981 if Changed then DrawWindow (WindowList);
982 Changed := True;
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
993 xs := MinSizeX + 2;
994 ys := MinSizeY + 2
995 end;
996 Ord ('b'), kbCtrlPgDn: begin
997 SSize := ScreenSize;
998 xs := SSize.x - x1 + 1;
999 ys := SSize.y - y1 + 1
1000 end;
1001 kbCR,
1002 kbEsc, kbAltEsc : Done := True;
1003 else Changed := False
1004 end
1005 until Done;
1006 State := ws_None;
1007 DrawWindow (WindowList)
1008 end
1009 end;
1010
1011 procedure ActivateCursor;
1012 begin
1013 with WindowList^, WindowTypes[WindowType] do
1014 begin
1015 PanelActivate (Panel);
1016 if WantCursor then
1017 SetCursorShape (CursorShape)
1018 else
1019 HideCursor
1020 end;
1021 SetScroll (ScrollState)
1022 end;
1023
1024 var
1025 Key: TKey;
1026 ScreenShot, Done: Boolean;
1027
1028 begin
1029 ScreenShot := ParamStr (1) = '--screenshot';
1030 if ParamCount <> Ord (ScreenShot) then
1031 begin
1032 RestoreTerminal (True);
1033 WriteLn (StdErr, ParamStr (0), ': invalid argument `', ParamStr (Ord (ScreenShot) + 1), '''');
1034 Halt (1)
1035 end;
1036 CRTSavePreviousScreen (True);
1037 SetCRTUpdate (UpdateInput);
1038 MainPanel := GetActivePanel;
1039 CheckScreenSize;
1040 OrigScreenSize := ScreenSize;
1041 if ScreenShot then
1042 begin
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'));
1049 KeyDemoKey (246);
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);
1057 ActivateCursor;
1058 OpenWindow
1059 end
1060 else
1061 NewWindow (0, 3, 2);
1062 Done := False;
1063 repeat
1064 ActivateCursor;
1065 Key := GetKey (-1);
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;
1073 Ord ('q'), kbEsc,
1074 kbAltEsc: Done := True;
1075 else
1076 if WindowList <> nil then
1077 with WindowList^, WindowTypes[WindowType] do
1078 if @KeyProc <> nil then
1079 begin
1080 TextColor (Color);
1081 TextBackground (Background);
1082 KeyProc (Key)
1083 end
1084 end
1085 until Done
1086 end.
Unnamed repository; edit this file 'description' to name the repository.