test/indent/pascal.pas

   1 { GPC demo program for the CRT unit.
   2
   3 Copyright (C) 1999-2006, 2013-2014 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 3.
  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 (* second style of comment *)
  29 // Free-pascal style comment.
  30 var x:Char = 12 /* 45;   // This /* does not start a comment.
  31 var x:Char = (/ 4);      // This (/ does not start a comment.
  32
  33 program CRTDemo;
  34
  35 uses GPC, CRT;
  36
  37 type
  38    TFrameChars = array [1 .. 8] of Char;
  39    TSimulateBlockCursorKind = (bc_None, bc_Blink, bc_Static);
  40
  41 const
  42    SingleFrame: TFrameChars = (chCornerTLS, chLineHS, chCornerTRS, chLineVS, chLineVS, chCornerBLS, chLineHS, chCornerBRS);
  43    DoubleFrame: TFrameChars = (chCornerTLD, chLineHD, chCornerTRD, chLineVD, chLineVD, chCornerBLD, chLineHD, chCornerBRD);
  44
  45 var
  46    ScrollState: Boolean = True;
  47    SimulateBlockCursorKind: TSimulateBlockCursorKind = bc_None;
  48    CursorShape: TCursorShape = CursorNormal;
  49    MainPanel: TPanel;
  50    OrigScreenSize: TPoint;
  51
  52 procedure FrameWin (const Title: String; const Frame: TFrameChars; TitleInverse: Boolean);
  53 var
  54    w, h, y, Color: Integer;
  55    Attr: TTextAttr;
  56 begin
  57    HideCursor;
  58    SetPCCharSet (True);
  59    ClrScr;
  60    w := GetXMax;
  61    h := GetYMax;
  62    WriteCharAt (1, 1, 1,     Frame[1], TextAttr);
  63    WriteCharAt (2, 1, w - 2, Frame[2], TextAttr);
  64    WriteCharAt (w, 1, 1,     Frame[3], TextAttr);
  65    for y := 2 to h - 1 do
  66    begin
  67       WriteCharAt (1, y, 1, Frame[4], TextAttr);
  68       WriteCharAt (w, y, 1, Frame[5], TextAttr)
  69    end;
  70    WriteCharAt (1, h, 1,     Frame[6], TextAttr);
  71    WriteCharAt (2, h, w - 2, Frame[7], TextAttr);
  72    WriteCharAt (w, h, 1,     Frame[8], TextAttr);
  73    SetPCCharSet (False);
  74    Attr := TextAttr;
  75    if TitleInverse then
  76    begin
  77       Color := GetTextColor;
  78       TextColor (GetTextBackground);
  79       TextBackground (Color)
  80    end;
  81    WriteStrAt ((w - Length (Title)) div 2 + 1, 1, Title, TextAttr);
  82    TextAttr := Attr
  83 end;
  84
  85 function GetKey (TimeOut: Integer) = Key: TKey; forward;
  86
  87 procedure ClosePopUpWindow;
  88 begin
  89    PanelDelete (GetActivePanel);
  90    PanelDelete (GetActivePanel)
  91 end;
  92
  93 function PopUpConfirm (XSize, YSize: Integer; const Msg: String): Boolean;
  94 var
  95    ax, ay: Integer;
  96    Key: TKey;
  97    SSize: TPoint;
  98 begin
  99    repeat
 100       SSize := ScreenSize;
 101       ax := (SSize.x - XSize - 4) div 2 + 1;
 102       ay := (SSize.y - YSize - 4) div 2 + 1;
 103       PanelNew (ax, ay, ax + XSize + 3, ay + YSize + 1, False);
 104       TextBackground (Black);
 105       TextColor (Yellow);
 106       SetControlChars (True);
 107       FrameWin ('', DoubleFrame, False);
 108       NormalCursor;
 109       PanelNew (ax + 2, ay + 1, ax + XSize + 2, ay + YSize, False);
 110       ClrScr;
 111       Write (Msg);
 112       Key := GetKey (-1);
 113       if Key = kbScreenSizeChanged then ClosePopUpWindow
 114       until Key <> kbScreenSizeChanged;
 115    PopUpConfirm := not (Key in [kbEsc, kbAltEsc])
 116 end;
 117
 118 procedure MainDraw;
 119 begin
 120    WriteLn ('3, F3 : Open a window');
 121    WriteLn ('4, F4 : Close window');
 122    WriteLn ('5, F5 : Previous window');
 123    WriteLn ('6, F6 : Next window');
 124    WriteLn ('7, F7 : Move window');
 125    WriteLn ('8, F8 : Resize window');
 126    Write   ('q, Esc: Quit')
 127 end;
 128
 129 procedure StatusDraw;
 130 const
 131    YesNo: array [Boolean] of String [3] = ('No', 'Yes');
 132    SimulateBlockCursorIDs: array [TSimulateBlockCursorKind] of String [8] = ('Off', 'Blinking', 'Static');
 133    CursorShapeIDs: array [TCursorShape] of String [7] = ('Ignored', 'Hidden', 'Normal', 'Fat', 'Block');
 134 var
 135    SSize: TPoint;
 136 begin
 137    WriteLn ('You can change some of the following');
 138    WriteLn ('settings  by pressing the key  shown');
 139    WriteLn ('in parentheses. Naturally, color and');
 140    WriteLn ('changing the cursor  shape or screen');
 141    WriteLn ('size does not work on all terminals.');
 142    WriteLn;
 143    WriteLn ('XCurses version:          ', YesNo[XCRT]);
 144    WriteLn ('CRTSavePreviousScreen:    ', YesNo[CRTSavePreviousScreenWorks]);
 145    WriteLn ('(M)onochrome:             ', YesNo[IsMonochrome]);
 146    SSize := ScreenSize;
 147    WriteLn ('Screen (C)olumns:         ', SSize.x);
 148    WriteLn ('Screen (L)ines:           ', SSize.y);
 149    WriteLn ('(R)estore screen size');
 150    WriteLn ('(B)reak checking:         ', YesNo[CheckBreak]);
 151    WriteLn ('(S)crolling:              ', YesNo[ScrollState]);
 152    WriteLn ('S(i)mulated block cursor: ', SimulateBlockCursorIDs[SimulateBlockCursorKind]);
 153    Write   ('C(u)rsor shape:           ', CursorShapeIDs[CursorShape]);
 154    GotoXY (36, WhereY)
 155 end;
 156
 157 procedure RedrawAll; forward;
 158 procedure CheckScreenSize; forward;
 159
 160 procedure StatusKey (Key: TKey);
 161 var SSize, NewSize: TPoint;
 162 begin
 163    case LoCase (Key2Char (Key)) of
 164      'm': begin
 165         SetMonochrome (not IsMonochrome);
 166         RedrawAll
 167      end;
 168      'c': begin
 169         SSize := ScreenSize;
 170         if SSize.x > 40 then
 171            NewSize.x := 40
 172         else
 173            NewSize.x := 80;
 174         if SSize.y > 25 then
 175            NewSize.y := 50
 176         else
 177            NewSize.y := 25;
 178         SetScreenSize (NewSize.x, NewSize.y);
 179         CheckScreenSize
 180      end;
 181      'l': begin
 182         SSize := ScreenSize;
 183         if SSize.x > 40 then
 184            NewSize.x := 80
 185         else
 186            NewSize.x := 40;
 187         if SSize.y > 25 then
 188            NewSize.y := 25
 189         else
 190            NewSize.y := 50;
 191         SetScreenSize (NewSize.x, NewSize.y);
 192         CheckScreenSize
 193      end;
 194      'r': begin
 195         SetScreenSize (OrigScreenSize.x, OrigScreenSize.y);
 196         CheckScreenSize
 197      end;
 198      'b': CheckBreak := not CheckBreak;
 199      's': ScrollState := not ScrollState;
 200      'i': if SimulateBlockCursorKind = High (SimulateBlockCursorKind) then
 201         SimulateBlockCursorKind := Low (SimulateBlockCursorKind)
 202      else
 203         Inc (SimulateBlockCursorKind);
 204      'u': case CursorShape of
 205        CursorNormal: CursorShape := CursorBlock;
 206        CursorFat,
 207        CursorBlock : CursorShape := CursorHidden;
 208      else          CursorShape := CursorNormal
 209      end;
 210    end;
 211    ClrScr;
 212    StatusDraw
 213 end;
 214
 215 procedure TextAttrDemo;
 216 var f, b, y, x1, y1, x2, y2, Fill, n1, n2, n3: Integer;
 217 begin
 218    GetWindow (x1, y1, x2, y2);
 219    Window (x1 - 1, y1, x2, y2);
 220    TextColor (White);
 221    TextBackground (Blue);
 222    ClrScr;
 223    SetScroll (False);
 224    Fill := GetXMax - 32;
 225    for y := 1 to GetYMax do
 226    begin
 227       GotoXY (1, y);
 228       b := (y - 1) mod 16;
 229       n1 := 0;
 230       for f := 0 to 15 do
 231       begin
 232          TextAttr := f + 16 * b;
 233          n2 := (Fill * (1 + 2 * f) + 16) div 32;
 234          n3 := (Fill * (2 + 2 * f) + 16) div 32;
 235          Write ('' : n2 - n1, NumericBaseDigitsUpper[b], NumericBaseDigitsUpper[f], '' : n3 - n2);
 236          n1 := n3
 237       end
 238    end
 239 end;
 240
 241 procedure CharSetDemo (UsePCCharSet: Boolean);
 242 var h, l, y, x1, y1, x2, y2, Fill, n1, n2: Integer;
 243 begin
 244    GetWindow (x1, y1, x2, y2);
 245    Window (x1 - 1, y1, x2, y2);
 246    ClrScr;
 247    SetScroll (False);
 248    SetPCCharSet (UsePCCharSet);
 249    SetControlChars (False);
 250    Fill := GetXMax - 35;
 251    for y := 1 to GetYMax do
 252    begin
 253       GotoXY (1, y);
 254       h := (y - 2) mod 16;
 255       n1 := (Fill + 9) div 18;
 256       if y = 1 then
 257          Write ('' : 3 + n1)
 258       else
 259          Write (16 * h : 3 + n1);
 260       for l := 0 to 15 do
 261       begin
 262          n2 := (Fill * (2 + l) + 9) div 18;
 263          if y = 1 then
 264             Write ('' : n2 - n1, l : 2)
 265          else
 266             Write ('' : n2 - n1 + 1, Chr (16 * h + l));
 267          n1 := n2
 268       end
 269    end
 270 end;
 271
 272 procedure NormalCharSetDemo;
 273 begin
 274    CharSetDemo (False)
 275 end;
 276
 277 procedure PCCharSetDemo;
 278 begin
 279    CharSetDemo (True)
 280 end;
 281
 282 procedure FKeyDemoDraw;
 283 var x1, y1, x2, y2: Integer;
 284 begin
 285    GetWindow (x1, y1, x2, y2);
 286    Window (x1, y1, x2 - 1, y2);
 287    ClrScr;
 288    SetScroll (False);
 289    WriteLn ('You can type the following keys');
 290    WriteLn ('(function keys if present on the');
 291    WriteLn ('terminal, letters as alternatives):');
 292    GotoXY (1, 4);
 293    WriteLn ('S, Left     : left (wrap-around)');
 294    WriteLn ('D, Right    : right (wrap-around)');
 295    WriteLn ('E, Up       : up (wrap-around)');
 296    WriteLn ('X, Down     : down (wrap-around)');
 297    WriteLn ('A, Home     : go to first column');
 298    WriteLn ('F, End      : go to last column');
 299    WriteLn ('R, Page Up  : go to first line');
 300    WriteLn ('C, Page Down: go to last line');
 301    WriteLn ('Y, Ctrl-PgUp: first column and line');
 302    GotoXY (1, 13);
 303    WriteLn ('B, Ctrl-PgDn: last column and line');
 304    WriteLn ('Z, Ctrl-Home: clear screen');
 305    WriteLn ('N, Ctrl-End : clear to end of line');
 306    WriteLn ('V, Insert   : insert a line');
 307    WriteLn ('T, Delete   : delete a line');
 308    WriteLn ('#           : beep');
 309    WriteLn ('*           : flash');
 310    WriteLn ('Tab, Enter, Backspace, other');
 311    WriteLn ('  normal characters: write text')
 312 end;
 313
 314 procedure FKeyDemoKey (Key: TKey);
 315 const TabSize = 8;
 316 var
 317    ch: Char;
 318    NewX: Integer;
 319 begin
 320    case LoCaseKey (Key) of
 321      Ord ('s'), kbLeft    : if WhereX = 1 then GotoXY (GetXMax, WhereY) else GotoXY (WhereX - 1, WhereY);
 322      Ord ('d'), kbRight   : if WhereX = GetXMax then GotoXY (1, WhereY) else GotoXY (WhereX + 1, WhereY);
 323      Ord ('e'), kbUp      : if WhereY = 1 then GotoXY (WhereX, GetYMax) else GotoXY (WhereX, WhereY - 1);
 324      Ord ('x'), kbDown    : if WhereY = GetYMax then GotoXY (WhereX, 1) else GotoXY (WhereX, WhereY + 1);
 325      Ord ('a'), kbHome    : Write (chCR);
 326      Ord ('f'), kbEnd     : GotoXY (GetXMax, WhereY);
 327      Ord ('r'), kbPgUp    : GotoXY (WhereX, 1);
 328      Ord ('c'), kbPgDn    : GotoXY (WhereX, GetYMax);
 329      Ord ('y'), kbCtrlPgUp: GotoXY (1, 1);
 330      Ord ('b'), kbCtrlPgDn: GotoXY (GetXMax, GetYMax);
 331      Ord ('z'), kbCtrlHome: ClrScr;
 332      Ord ('n'), kbCtrlEnd : ClrEOL;
 333      Ord ('v'), kbIns     : InsLine;
 334      Ord ('t'), kbDel     : DelLine;
 335      Ord ('#')            : Beep;
 336      Ord ('*')            : Flash;
 337      kbTab                : begin
 338                                NewX := ((WhereX - 1) div TabSize + 1) * TabSize + 1;
 339                                if NewX <= GetXMax then GotoXY (NewX, WhereY) else WriteLn
 340                             end;
 341      kbCR                 : WriteLn;
 342      kbBkSp               : Write (chBkSp, ' ', chBkSp);
 343    else                   ch := Key2Char (Key);
 344      if ch <> #0 then Write (ch)
 345    end
 346 end;
 347
 348 procedure KeyDemoDraw;
 349 begin
 350    WriteLn ('Press some keys ...')
 351 end;
 352
 353 procedure KeyDemoKey (Key: TKey);
 354 var ch: Char;
 355 begin
 356    ch := Key2Char (Key);
 357    if ch <> #0 then
 358    begin
 359       Write ('Normal key');
 360       if IsPrintable (ch) then Write (' `', ch, '''');
 361       WriteLn (', ASCII #', Ord (ch))
 362    end
 363    else
 364       WriteLn ('Special key ', Ord (Key2Scan (Key)))
 365 end;
 366
 367 procedure IOSelectPeriodical;
 368 var
 369    CurrentTime: TimeStamp;
 370    s: String (8);
 371    i: Integer;
 372 begin
 373    GetTimeStamp (CurrentTime);
 374    with CurrentTime do
 375       WriteStr (s, Hour : 2, ':', Minute : 2, ':', Second : 2);
 376    for i := 1 to Length (s) do
 377       if s[i] = ' ' then s[i] := '0';
 378    GotoXY (1, 12);
 379    Write ('The time is: ', s)
 380 end;
 381
 382 procedure IOSelectDraw;
 383 begin
 384    WriteLn ('IOSelect is a way to handle I/O from');
 385    WriteLn ('or to several places simultaneously,');
 386    WriteLn ('without  having  to use  threads  or');
 387    WriteLn ('signal/interrupt  handlers  or waste');
 388    WriteLn ('CPU time with busy waiting.');
 389    WriteLn;
 390    WriteLn ('This demo  shows how  IOSelect works');
 391    WriteLn ('in connection with CRT.  It displays');
 392    WriteLn ('a clock,  but still  reacts  to user');
 393    WriteLn ('input immediately.');
 394    IOSelectPeriodical
 395 end;
 396
 397 procedure ModifierPeriodical;
 398 const
 399    Pressed: array [Boolean] of String [8] = ('Released', 'Pressed');
 400    ModifierNames: array [1 .. 7] of record
 401                      Modifier: Integer;
 402                      Name: String (17)
 403                   end =
 404    ((shLeftShift,  'Left Shift'),
 405     (shRightShift, 'Right Shift'),
 406     (shLeftCtrl,   'Left Control'),
 407     (shRightCtrl,  'Right Control'),
 408     (shAlt,        'Alt (left)'),
 409     (shAltGr,      'AltGr (right Alt)'),
 410     (shExtra,      'Extra'));
 411 var
 412    ShiftState, i: Integer;
 413 begin
 414    ShiftState := GetShiftState;
 415    for i := 1 to 7 do
 416       with ModifierNames[i] do
 417       begin
 418          GotoXY (1, 4 + i);
 419          ClrEOL;
 420          Write (Name, ':');
 421          GotoXY (20, WhereY);
 422          Write (Pressed[(ShiftState and Modifier) <> 0])
 423       end
 424 end;
 425
 426 procedure ModifierDraw;
 427 begin
 428    WriteLn ('Modifier keys (NOTE: only');
 429    WriteLn ('available on some systems;');
 430    WriteLn ('X11: only after key press):');
 431    ModifierPeriodical
 432 end;
 433
 434 procedure ChecksDraw;
 435 begin
 436    WriteLn ('(O)S shell');
 437    WriteLn ('OS shell with (C)learing');
 438    WriteLn ('(R)efresh check');
 439    Write   ('(S)ound check')
 440 end;
 441
 442 procedure ChecksKey (Key: TKey);
 443 var
 444    i, j: Integer;
 445    WasteTime: Real; attribute (volatile);
 446
 447    procedure DoOSShell;
 448    var
 449       Result: Integer;
 450       Shell: TString;
 451    begin
 452       Shell := GetShellPath (Null);
 453       {$I-}
 454       Result := Execute (Shell);
 455       {$I+}
 456       if (InOutRes <> 0) or (Result <> 0) then
 457       begin
 458          ClrScr;
 459          if InOutRes <> 0 then
 460             WriteLn (GetIOErrorMessage, ' while trying to execute `', Shell, '''.')
 461          else
 462             WriteLn ('`', Shell, ''' returned status ', Result, '.');
 463          Write ('Any key to continue.');
 464          BlockCursor;
 465          Discard (GetKey (-1))
 466       end
 467    end;
 468
 469 begin
 470    case LoCase (Key2Char (Key)) of
 471      'o': begin
 472         if PopUpConfirm (36, 12, 'You will now get an OS shell. Unless' + NewLine +
 473                          'CRTDemo is running  in its own (GUI)' + NewLine +
 474                          'window,  the shell  will run  on the' + NewLine +
 475                          'same screen as CRTDemo  which is not' + NewLine +
 476                          'cleared before the shell is started.' + NewLine +
 477                          'If possible, the screen contents are' + NewLine +
 478                          'restored to the state before CRTDemo' + NewLine +
 479                          'was started. After leaving the shell' + NewLine +
 480                          'in the usual way (usually  by enter-' + NewLine +
 481                          'ing  `exit''), you will  get back to' + NewLine +
 482                          'the demo.  <ESC> to abort, any other' + NewLine +
 483                          'key to start.') then
 484         begin
 485            RestoreTerminal (True);
 486            DoOSShell
 487         end;
 488         ClosePopUpWindow
 489      end;
 490      'c': begin
 491         if PopUpConfirm (36, 9, 'You will now get an OS shell. Unless' + NewLine +
 492                          'CRTDemo is running in  its own (GUI)' + NewLine +
 493                          'window, the screen  will be cleared,' + NewLine +
 494                          'and the cursor will be  moved to the' + NewLine +
 495                          'top  before  the  shell  is started.' + NewLine +
 496                          'After leaving the shell in the usual' + NewLine +
 497                          'way  (usually  by entering  `exit''),' + NewLine +
 498                          'you will get back to the demo. <ESC>' + NewLine +
 499                          'to abort, any other key to start.') then
 500         begin
 501            RestoreTerminalClearCRT;
 502            DoOSShell
 503         end;
 504         ClosePopUpWindow
 505      end;
 506      'r': begin
 507         if PopUpConfirm (36, 11, 'The program will  now get  busy with' + NewLine +
 508                          'some  dummy  computations.  However,' + NewLine +
 509                          'CRT output in  the form of dots will' + NewLine +
 510                          'still appear continuously one by one' + NewLine +
 511                          '(rather than the  whole line at once' + NewLine +
 512                          'in the end). While running, the test' + NewLine +
 513                          'cannot  be  interrupted.   <ESC>  to' + NewLine +
 514                          'abort, any other key to start.') then
 515         begin
 516            SetCRTUpdate (UpdateRegularly);
 517            BlockCursor;
 518            WriteLn;
 519            WriteLn;
 520            for i := 1 to GetXMax - 2 do
 521            begin
 522               Write ('.');
 523               for j := 1 to 400000 do WasteTime := Random
 524            end;
 525            SetCRTUpdate (UpdateInput);
 526            WriteLn;
 527            Write ('Press any key.');
 528            Discard (GetKey (-1))
 529         end;
 530         ClosePopUpWindow
 531      end;
 532      's': begin
 533         if PopUpConfirm (32, 4, 'You will now hear some sounds if' + NewLine +
 534                          'supported  (otherwise there will' + NewLine +
 535                          'just be a short pause). <ESC> to' + NewLine +
 536                          'abort, any other key to start.') then
 537         begin
 538            BlockCursor;
 539            for i := 0 to 7 do
 540            begin
 541               Sound (Round (440 * 2 ** (Round (i * 12 / 7 + 0.3) / 12)));
 542               if GetKey (400000) in [kbEsc, kbAltEsc] then Break
 543            end;
 544            NoSound
 545         end;
 546         ClosePopUpWindow
 547      end;
 548    end
 549 end;
 550
 551 type
 552    PWindowList = ^TWindowList;
 553    TWindowList = record
 554                     Next, Prev: PWindowList;
 555                     Panel, FramePanel: TPanel;
 556                     WindowType: Integer;
 557                     x1, y1, xs, ys: Integer;
 558                     State: (ws_None, ws_Moving, ws_Resizing);
 559                  end;
 560
 561 TKeyProc = procedure (Key: TKey);
 562 TProcedure = procedure;
 563
 564 const
 565    MenuNameLength = 16;
 566    WindowTypes: array [0 .. 9] of record
 567                    DrawProc,
 568                    PeriodicalProc: procedure;
 569                    KeyProc       : TKeyProc;
 570                    Name          : String (MenuNameLength);
 571                    Color,
 572                    Background,
 573                    MinSizeX,
 574                    MinSizeY,
 575                    PrefSizeX,
 576                    PrefSizeY     : Integer;
 577                    RedrawAlways,
 578                    WantCursor    : Boolean
 579                                    end =
 580 ((MainDraw         , nil               , nil        , 'CRT Demo'        , LightGreen, Blue     , 26,  7,  0,  0, False, False),
 581  (StatusDraw       , nil               , StatusKey  , 'Status'          , White     , Red      , 38, 16,  0,  0, True,  True),
 582  (TextAttrDemo     , nil               , nil        , 'Text Attributes' , White     , Blue     , 32, 16, 64, 16, False, False),
 583  (NormalCharSetDemo, nil               , nil        , 'Character Set'   , Black     , Green    , 35, 17, 53, 17, False, False),
 584  (PCCharSetDemo    , nil               , nil        , 'PC Character Set', Black     , Brown    , 35, 17, 53, 17, False, False),
 585  (KeyDemoDraw      , nil               , KeyDemoKey , 'Keys'            , Blue      , LightGray, 29,  5, -1, -1, False, True),
 586  (FKeyDemoDraw     , nil               , FKeyDemoKey, 'Function Keys'   , Blue      , LightGray, 37, 22, -1, -1, False, True),
 587  (ModifierDraw     , ModifierPeriodical, nil        , 'Modifier Keys'   , Black     , Cyan     , 29, 11,  0,  0, True,  False),
 588  (IOSelectDraw     , IOSelectPeriodical, nil        , 'IOSelect Demo'   , White     , Magenta  , 38, 12,  0,  0, False, False),
 589  (ChecksDraw       , nil               , ChecksKey  , 'Various Checks'  , Black     , Red      , 26,  4,  0,  0, False, False));
 590
 591 MenuMax = High (WindowTypes);
 592 MenuXSize = MenuNameLength + 4;
 593 MenuYSize = MenuMax + 2;
 594
 595 var
 596    WindowList: PWindowList = nil;
 597
 598    procedure RedrawFrame (p: PWindowList);
 599    begin
 600       with p^, WindowTypes[WindowType] do
 601       begin
 602          PanelActivate (FramePanel);
 603          Window (x1, y1, x1 + xs - 1, y1 + ys - 1);
 604          ClrScr;
 605          case State of
 606            ws_None    : if p = WindowList then
 607               FrameWin (' ' + Name + ' ', DoubleFrame, True)
 608            else
 609               FrameWin (' ' + Name + ' ', SingleFrame, False);
 610            ws_Moving  : FrameWin (' Move Window ', SingleFrame, True);
 611            ws_Resizing: FrameWin (' Resize Window ', SingleFrame, True);
 612          end
 613       end
 614    end;
 615
 616    procedure DrawWindow (p: PWindowList);
 617    begin
 618       with p^, WindowTypes[WindowType] do
 619       begin
 620          RedrawFrame (p);
 621          PanelActivate (Panel);
 622          Window (x1 + 2, y1 + 1, x1 + xs - 2, y1 + ys - 2);
 623          ClrScr;
 624          DrawProc
 625       end
 626    end;
 627
 628    procedure RedrawAll;
 629    var
 630       LastPanel: TPanel;
 631       p: PWindowList;
 632       x2, y2: Integer;
 633    begin
 634       LastPanel := GetActivePanel;
 635       PanelActivate (MainPanel);
 636       TextBackground (Blue);
 637       ClrScr;
 638       p := WindowList;
 639       if p <> nil then
 640          repeat
 641             with p^ do
 642             begin
 643                PanelActivate (FramePanel);
 644                GetWindow (x1, y1, x2, y2);  { updated automatically by CRT }
 645                xs := x2 - x1 + 1;
 646                ys := y2 - y1 + 1
 647             end;
 648             DrawWindow (p);
 649             p := p^.Next
 650          until p = WindowList;
 651       PanelActivate (LastPanel)
 652    end;
 653
 654    procedure CheckScreenSize;
 655    var
 656       LastPanel: TPanel;
 657       MinScreenSizeX, MinScreenSizeY, i: Integer;
 658       SSize: TPoint;
 659    begin
 660       LastPanel := GetActivePanel;
 661       PanelActivate (MainPanel);
 662       HideCursor;
 663       MinScreenSizeX := MenuXSize;
 664       MinScreenSizeY := MenuYSize;
 665       for i := Low (WindowTypes) to High (WindowTypes) do
 666          with WindowTypes[i] do
 667          begin
 668             MinScreenSizeX := Max (MinScreenSizeX, MinSizeX + 2);
 669             MinScreenSizeY := Max (MinScreenSizeY, MinSizeY + 2)
 670          end;
 671       SSize := ScreenSize;
 672       Window (1, 1, SSize.x, SSize.y);
 673       if (SSize.x < MinScreenSizeX) or (SSize.y < MinScreenSizeY) then
 674       begin
 675          NormVideo;
 676          ClrScr;
 677          RestoreTerminal (True);
 678          WriteLn (StdErr, 'Sorry, your screen is too small for this demo (', SSize.x, 'x', SSize.y, ').');
 679          WriteLn (StdErr, 'You need at least ', MinScreenSizeX, 'x', MinScreenSizeY, ' characters.');
 680          Halt (2)
 681       end;
 682       PanelActivate (LastPanel);
 683       RedrawAll
 684    end;
 685
 686    procedure Die; attribute (noreturn);
 687    begin
 688       NoSound;
 689       RestoreTerminalClearCRT;
 690       WriteLn (StdErr, 'You''re trying to kill me. Since I have break checking turned off,');
 691       WriteLn (StdErr, 'I''m not dying, but I''ll do you a favour and terminate now.');
 692       Halt (3)
 693    end;
 694
 695    function GetKey (TimeOut: Integer) = Key: TKey;
 696    var
 697       NeedSelect, SelectValue: Integer;
 698       SimulateBlockCursorCurrent: TSimulateBlockCursorKind;
 699       SelectInput: array [1 .. 1] of PAnyFile = (@Input);
 700       NextSelectTime: MicroSecondTimeType = 0; attribute (static);
 701       TimeOutTime: MicroSecondTimeType;
 702       LastPanel: TPanel;
 703       p: PWindowList;
 704    begin
 705       LastPanel := GetActivePanel;
 706       if TimeOut < 0 then
 707          TimeOutTime := High (TimeOutTime)
 708       else
 709          TimeOutTime := GetMicroSecondTime + TimeOut;
 710       NeedSelect := 0;
 711       if TimeOut >= 0 then
 712          Inc (NeedSelect);
 713       SimulateBlockCursorCurrent := SimulateBlockCursorKind;
 714       if SimulateBlockCursorCurrent <> bc_None then
 715          Inc (NeedSelect);
 716       p := WindowList;
 717       repeat
 718          if @WindowTypes[p^.WindowType].PeriodicalProc <> nil then
 719             Inc (NeedSelect);
 720          p := p^.Next
 721       until p = WindowList;
 722       p := WindowList;
 723       repeat
 724          with p^, WindowTypes[WindowType] do
 725             if RedrawAlways then
 726             begin
 727                PanelActivate (Panel);
 728                ClrScr;
 729                DrawProc
 730             end;
 731          p := p^.Next
 732       until p = WindowList;
 733       if NeedSelect <> 0 then
 734          repeat
 735             CRTUpdate;
 736             SelectValue := IOSelectRead (SelectInput, Max (0, Min (NextSelectTime, TimeOutTime) - GetMicroSecondTime));
 737             if SelectValue = 0 then
 738             begin
 739                case SimulateBlockCursorCurrent of
 740                  bc_None  : ;
 741                  bc_Blink : SimulateBlockCursor;
 742                  bc_Static: begin
 743                     SimulateBlockCursor;
 744                     SimulateBlockCursorCurrent := bc_None;
 745                     Dec (NeedSelect)
 746                  end
 747                end;
 748                NextSelectTime := GetMicroSecondTime + 120000;
 749                p := WindowList;
 750                repeat
 751                   with p^, WindowTypes[WindowType] do
 752                      if @PeriodicalProc <> nil then
 753                      begin
 754                         PanelActivate (Panel);
 755                         PeriodicalProc
 756                      end;
 757                   p := p^.Next
 758                until p = WindowList
 759             end;
 760          until (NeedSelect = 0) or (SelectValue <> 0) or ((TimeOut >= 0) and (GetMicroSecondTime >= TimeOutTime));
 761       if NeedSelect = 0 then
 762          SelectValue := 1;
 763       if SelectValue = 0 then
 764          Key := 0
 765       else
 766          Key := ReadKeyWord;
 767       if SimulateBlockCursorKind <> bc_None then
 768          SimulateBlockCursorOff;
 769       if IsDeadlySignal (Key) then Die;
 770       if Key = kbScreenSizeChanged then CheckScreenSize;
 771       PanelActivate (LastPanel)
 772    end;
 773
 774    function Menu = n: Integer;
 775    var
 776       i, ax, ay: Integer;
 777       Key: TKey;
 778       Done: Boolean;
 779       SSize: TPoint;
 780    begin
 781       n := 1;
 782       repeat
 783          SSize := ScreenSize;
 784          ax := (SSize.x - MenuXSize) div 2 + 1;
 785          ay := (SSize.y - MenuYSize) div 2 + 1;
 786          PanelNew (ax, ay, ax + MenuXSize - 1, ay + MenuYSize - 1, False);
 787          SetControlChars (True);
 788          TextColor (Blue);
 789          TextBackground (LightGray);
 790          FrameWin (' Select Window ', DoubleFrame, True);
 791          IgnoreCursor;
 792          PanelNew (ax + 1, ay + 1, ax + MenuXSize - 2, ay + MenuYSize - 2, False);
 793          ClrScr;
 794          TextColor (Black);
 795          SetScroll (False);
 796          Done := False;
 797          repeat
 798             for i := 1 to MenuMax do
 799             begin
 800                GotoXY (1, i);
 801                if i = n then
 802                   TextBackground (Green)
 803                else
 804                   TextBackground (LightGray);
 805                ClrEOL;
 806                Write (' ', WindowTypes[i].Name);
 807                ChangeTextAttr (2, i, 1, Red + $10 * GetTextBackground)
 808             end;
 809             Key := GetKey (-1);
 810             case LoCaseKey (Key) of
 811               kbUp                  : if n = 1 then n := MenuMax else Dec (n);
 812               kbDown                : if n = MenuMax then n := 1 else Inc (n);
 813               kbHome,
 814               kbPgUp,
 815               kbCtrlPgUp,
 816               kbCtrlHome            : n := 1;
 817               kbEnd,
 818               kbPgDn,
 819               kbCtrlPgDn,
 820               kbCtrlEnd             : n := MenuMax;
 821               kbCR                  : Done := True;
 822               kbEsc, kbAltEsc       : begin
 823                  n := -1;
 824                  Done := True
 825               end;
 826               Ord ('a') .. Ord ('z'): begin
 827                  i := MenuMax;
 828                  while (i > 0) and (LoCase (Key2Char (Key)) <> LoCase (WindowTypes[i].Name[1])) do Dec (i);
 829                  if i > 0 then
 830                  begin
 831                     n := i;
 832                     Done := True
 833                  end
 834               end;
 835             end
 836          until Done or (Key = kbScreenSizeChanged);
 837          ClosePopUpWindow
 838       until Key <> kbScreenSizeChanged
 839    end;
 840
 841    procedure NewWindow (WindowType, ax, ay: Integer);
 842    var
 843       p, LastWindow: PWindowList;
 844       MaxX1, MaxY1: Integer;
 845       SSize: TPoint;
 846    begin
 847       New (p);
 848       if WindowList = nil then
 849       begin
 850          p^.Prev := p;
 851          p^.Next := p
 852       end
 853       else
 854       begin
 855          p^.Prev := WindowList;
 856          p^.Next := WindowList^.Next;
 857          p^.Prev^.Next := p;
 858          p^.Next^.Prev := p;
 859       end;
 860       p^.WindowType := WindowType;
 861       with p^, WindowTypes[WindowType] do
 862       begin
 863          SSize := ScreenSize;
 864          if PrefSizeX > 0 then xs := PrefSizeX else xs := MinSizeX;
 865          if PrefSizeY > 0 then ys := PrefSizeY else ys := MinSizeY;
 866          xs := Min (xs + 2, SSize.x);
 867          ys := Min (ys + 2, SSize.y);
 868          MaxX1 := SSize.x - xs + 1;
 869          MaxY1 := SSize.y - ys + 1;
 870          if ax = 0 then x1 := Random (MaxX1) + 1 else x1 := Min (ax, MaxX1);
 871          if ay = 0 then y1 := Random (MaxY1) + 1 else y1 := Min (ay, MaxY1);
 872          if (ax = 0) and (PrefSizeX < 0) then Inc (xs, Random (SSize.x - x1 - xs + 2));
 873          if (ax = 0) and (PrefSizeY < 0) then Inc (ys, Random (SSize.y - y1 - ys + 2));
 874          State := ws_None;
 875          PanelNew (1, 1, 1, 1, False);
 876          FramePanel := GetActivePanel;
 877          SetControlChars (True);
 878          TextColor (Color);
 879          TextBackground (Background);
 880          PanelNew (1, 1, 1, 1, False);
 881          SetPCCharSet (False);
 882          Panel := GetActivePanel;
 883       end;
 884       LastWindow := WindowList;
 885       WindowList := p;
 886       if LastWindow <> nil then RedrawFrame (LastWindow);
 887       DrawWindow (p)
 888    end;
 889
 890    procedure OpenWindow;
 891    var WindowType: Integer;
 892    begin
 893       WindowType := Menu;
 894       if WindowType >= 0 then NewWindow (WindowType, 0, 0)
 895    end;
 896
 897    procedure NextWindow;
 898    var LastWindow: PWindowList;
 899    begin
 900       LastWindow := WindowList;
 901       WindowList := WindowList^.Next;
 902       PanelTop (WindowList^.FramePanel);
 903       PanelTop (WindowList^.Panel);
 904       RedrawFrame (LastWindow);
 905       RedrawFrame (WindowList)
 906    end;
 907
 908    procedure PreviousWindow;
 909    var LastWindow: PWindowList;
 910    begin
 911       PanelMoveAbove (WindowList^.Panel, MainPanel);
 912       PanelMoveAbove (WindowList^.FramePanel, MainPanel);
 913       LastWindow := WindowList;
 914       WindowList := WindowList^.Prev;
 915       RedrawFrame (LastWindow);
 916       RedrawFrame (WindowList)
 917    end;
 918
 919    procedure CloseWindow;
 920    var p: PWindowList;
 921    begin
 922       if WindowList^.WindowType <> 0 then
 923       begin
 924          p := WindowList;
 925          NextWindow;
 926          PanelDelete (p^.FramePanel);
 927          PanelDelete (p^.Panel);
 928          p^.Next^.Prev := p^.Prev;
 929          p^.Prev^.Next := p^.Next;
 930          Dispose (p)
 931       end
 932    end;
 933
 934    procedure MoveWindow;
 935    var
 936       Done, Changed: Boolean;
 937       SSize: TPoint;
 938    begin
 939       with WindowList^ do
 940       begin
 941          Done := False;
 942          Changed := True;
 943          State := ws_Moving;
 944          repeat
 945             if Changed then DrawWindow (WindowList);
 946             Changed := True;
 947             case LoCaseKey (GetKey (-1)) of
 948               Ord ('s'), kbLeft    : if x1 > 1 then Dec (x1);
 949               Ord ('d'), kbRight   : if x1 + xs - 1 < ScreenSize.x then Inc (x1);
 950               Ord ('e'), kbUp      : if y1 > 1 then Dec (y1);
 951               Ord ('x'), kbDown    : if y1 + ys - 1 < ScreenSize.y then Inc (y1);
 952               Ord ('a'), kbHome    : x1 := 1;
 953               Ord ('f'), kbEnd     : x1 := ScreenSize.x - xs + 1;
 954               Ord ('r'), kbPgUp    : y1 := 1;
 955               Ord ('c'), kbPgDn    : y1 := ScreenSize.y - ys + 1;
 956               Ord ('y'), kbCtrlPgUp: begin
 957                  x1 := 1;
 958                  y1 := 1
 959               end;
 960               Ord ('b'), kbCtrlPgDn: begin
 961                  SSize := ScreenSize;
 962                  x1 := SSize.x - xs + 1;
 963                  y1 := SSize.y - ys + 1
 964               end;
 965               kbCR,
 966               kbEsc, kbAltEsc      : Done := True;
 967             else                   Changed := False
 968             end
 969          until Done;
 970          State := ws_None;
 971          DrawWindow (WindowList)
 972       end
 973    end;
 974
 975    procedure ResizeWindow;
 976    var
 977       Done, Changed: Boolean;
 978       SSize: TPoint;
 979    begin
 980       with WindowList^, WindowTypes[WindowType] do
 981       begin
 982          Done := False;
 983          Changed := True;
 984          State := ws_Resizing;
 985          repeat
 986             if Changed then DrawWindow (WindowList);
 987             Changed := True;
 988             case LoCaseKey (GetKey (-1)) of
 989               Ord ('s'), kbLeft    : if xs > MinSizeX + 2 then Dec (xs);
 990               Ord ('d'), kbRight   : if x1 + xs - 1 < ScreenSize.x then Inc (xs);
 991               Ord ('e'), kbUp      : if ys > MinSizeY + 2 then Dec (ys);
 992               Ord ('x'), kbDown    : if y1 + ys - 1 < ScreenSize.y then Inc (ys);
 993               Ord ('a'), kbHome    : xs := MinSizeX + 2;
 994               Ord ('f'), kbEnd     : xs := ScreenSize.x - x1 + 1;
 995               Ord ('r'), kbPgUp    : ys := MinSizeY + 2;
 996               Ord ('c'), kbPgDn    : ys := ScreenSize.y - y1 + 1;
 997               Ord ('y'), kbCtrlPgUp: begin
 998                  xs := MinSizeX + 2;
 999                  ys := MinSizeY + 2
1000               end;
1001               Ord ('b'), kbCtrlPgDn: begin
1002                  SSize := ScreenSize;
1003                  xs := SSize.x - x1 + 1;
1004                  ys := SSize.y - y1 + 1
1005               end;
1006               kbCR,
1007               kbEsc, kbAltEsc      : Done := True;
1008             else                   Changed := False
1009             end
1010          until Done;
1011          State := ws_None;
1012          DrawWindow (WindowList)
1013       end
1014    end;
1015
1016    procedure ActivateCursor;
1017    begin
1018       with WindowList^, WindowTypes[WindowType] do
1019       begin
1020          PanelActivate (Panel);
1021          if WantCursor then
1022             SetCursorShape (CursorShape)
1023          else
1024             HideCursor
1025       end;
1026       SetScroll (ScrollState)
1027    end;
1028
1029 var
1030    Key: TKey;
1031    ScreenShot, Done: Boolean;
1032
1033 begin
1034    ScreenShot := ParamStr (1) = '--screenshot';
1035    if ParamCount <> Ord (ScreenShot) then
1036    begin
1037       RestoreTerminal (True);
1038       WriteLn (StdErr, ParamStr (0), ': invalid argument `', ParamStr (Ord (ScreenShot) + 1), '''');
1039       Halt (1)
1040    end;
1041    CRTSavePreviousScreen (True);
1042    SetCRTUpdate (UpdateInput);
1043    MainPanel := GetActivePanel;
1044    CheckScreenSize;
1045    OrigScreenSize := ScreenSize;
1046    if ScreenShot then
1047    begin
1048       CursorShape := CursorBlock;
1049       NewWindow (6,      1,      1);
1050       NewWindow (2,      1, MaxInt);
1051       NewWindow (8, MaxInt,      1);
1052       NewWindow (5,      1,     27);
1053       KeyDemoKey (Ord ('f'));
1054       KeyDemoKey (246);
1055       KeyDemoKey (kbDown);
1056       NewWindow (3, MaxInt,     13);
1057       NewWindow (4, MaxInt,     31);
1058       NewWindow (7, MaxInt, MaxInt);
1059       NewWindow (9, MaxInt,     33);
1060       NewWindow (0,      1,      2);
1061       NewWindow (1,      1,     14);
1062       ActivateCursor;
1063       OpenWindow
1064    end
1065    else
1066       NewWindow (0, 3, 2);
1067    Done := False;
1068    repeat
1069       ActivateCursor;
1070       Key := GetKey (-1);
1071       case LoCaseKey (Key) of
1072         Ord ('3'), kbF3 : OpenWindow;
1073         Ord ('4'), kbF4 : CloseWindow;
1074         Ord ('5'), kbF5 : PreviousWindow;
1075         Ord ('6'), kbF6 : NextWindow;
1076         Ord ('7'), kbF7 : MoveWindow;
1077         Ord ('8'), kbF8 : ResizeWindow;
1078         Ord ('q'), kbEsc,
1079         kbAltEsc:         Done := True;
1080       else
1081          if WindowList <> nil then
1082             with WindowList^, WindowTypes[WindowType] do
1083                if @KeyProc <> nil then
1084                begin
1085                   TextColor (Color);
1086                   TextBackground (Background);
1087                   KeyProc (Key)
1088                end
1089       end
1090    until Done
1091 end.