code.delx.au - gnu-emacs/blob - test/manual/indent/pascal.pas

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