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

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