path: root/test/indent/pascal.pas

{ GPC demo program for the CRT unit.

Copyright (C) 1999-2006, 2013 Free Software Foundation, Inc.

Author: Frank Heckenbach <frank@pascal.gnu.de>

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License as
published by the Free Software Foundation, version 2.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.

As a special exception, if you incorporate even large parts of the
code of this demo program into another program with substantially
different functionality, this does not cause the other program to
be covered by the GNU General Public License. This exception does
not however invalidate any other reasons why it might be covered
by the GNU General Public License. }

{$gnu-pascal,I+}

program CRTDemo;

uses GPC, CRT;

type
   TFrameChars = array [1 .. 8] of Char;
   TSimulateBlockCursorKind = (bc_None, bc_Blink, bc_Static);

const
   SingleFrame: TFrameChars = (chCornerTLS, chLineHS, chCornerTRS, chLineVS, chLineVS, chCornerBLS, chLineHS, chCornerBRS);
   DoubleFrame: TFrameChars = (chCornerTLD, chLineHD, chCornerTRD, chLineVD, chLineVD, chCornerBLD, chLineHD, chCornerBRD);

var
   ScrollState: Boolean = True;
   SimulateBlockCursorKind: TSimulateBlockCursorKind = bc_None;
   CursorShape: TCursorShape = CursorNormal;
   MainPanel: TPanel;
   OrigScreenSize: TPoint;

procedure FrameWin (const Title: String; const Frame: TFrameChars; TitleInverse: Boolean);
var
   w, h, y, Color: Integer;
   Attr: TTextAttr;
begin
   HideCursor;
   SetPCCharSet (True);
   ClrScr;
   w := GetXMax;
   h := GetYMax;
   WriteCharAt (1, 1, 1,     Frame[1], TextAttr);
   WriteCharAt (2, 1, w - 2, Frame[2], TextAttr);
   WriteCharAt (w, 1, 1,     Frame[3], TextAttr);
   for y := 2 to h - 1 do
   begin
      WriteCharAt (1, y, 1, Frame[4], TextAttr);
      WriteCharAt (w, y, 1, Frame[5], TextAttr)
   end;
   WriteCharAt (1, h, 1,     Frame[6], TextAttr);
   WriteCharAt (2, h, w - 2, Frame[7], TextAttr);
   WriteCharAt (w, h, 1,     Frame[8], TextAttr);
   SetPCCharSet (False);
   Attr := TextAttr;
   if TitleInverse then
   begin
      Color := GetTextColor;
      TextColor (GetTextBackground);
      TextBackground (Color)
   end;
   WriteStrAt ((w - Length (Title)) div 2 + 1, 1, Title, TextAttr);
   TextAttr := Attr
end;

function GetKey (TimeOut: Integer) = Key: TKey; forward;

procedure ClosePopUpWindow;
begin
   PanelDelete (GetActivePanel);
   PanelDelete (GetActivePanel)
end;

function PopUpConfirm (XSize, YSize: Integer; const Msg: String): Boolean;
var
   ax, ay: Integer;
   Key: TKey;
   SSize: TPoint;
begin
   repeat
      SSize := ScreenSize;
      ax := (SSize.x - XSize - 4) div 2 + 1;
      ay := (SSize.y - YSize - 4) div 2 + 1;
      PanelNew (ax, ay, ax + XSize + 3, ay + YSize + 1, False);
      TextBackground (Black);
      TextColor (Yellow);
      SetControlChars (True);
      FrameWin ('', DoubleFrame, False);
      NormalCursor;
      PanelNew (ax + 2, ay + 1, ax + XSize + 2, ay + YSize, False);
      ClrScr;
      Write (Msg);
      Key := GetKey (-1);
      if Key = kbScreenSizeChanged then ClosePopUpWindow
      until Key <> kbScreenSizeChanged;
   PopUpConfirm := not (Key in [kbEsc, kbAltEsc])
end;

procedure MainDraw;
begin
   WriteLn ('3, F3 : Open a window');
   WriteLn ('4, F4 : Close window');
   WriteLn ('5, F5 : Previous window');
   WriteLn ('6, F6 : Next window');
   WriteLn ('7, F7 : Move window');
   WriteLn ('8, F8 : Resize window');
   Write   ('q, Esc: Quit')
end;

procedure StatusDraw;
const
   YesNo: array [Boolean] of String [3] = ('No', 'Yes');
   SimulateBlockCursorIDs: array [TSimulateBlockCursorKind] of String [8] = ('Off', 'Blinking', 'Static');
   CursorShapeIDs: array [TCursorShape] of String [7] = ('Ignored', 'Hidden', 'Normal', 'Fat', 'Block');
var
   SSize: TPoint;
begin
   WriteLn ('You can change some of the following');
   WriteLn ('settings  by pressing the key  shown');
   WriteLn ('in parentheses. Naturally, color and');
   WriteLn ('changing the cursor  shape or screen');
   WriteLn ('size does not work on all terminals.');
   WriteLn;
   WriteLn ('XCurses version:          ', YesNo[XCRT]);
   WriteLn ('CRTSavePreviousScreen:    ', YesNo[CRTSavePreviousScreenWorks]);
   WriteLn ('(M)onochrome:             ', YesNo[IsMonochrome]);
   SSize := ScreenSize;
   WriteLn ('Screen (C)olumns:         ', SSize.x);
   WriteLn ('Screen (L)ines:           ', SSize.y);
   WriteLn ('(R)estore screen size');
   WriteLn ('(B)reak checking:         ', YesNo[CheckBreak]);
   WriteLn ('(S)crolling:              ', YesNo[ScrollState]);
   WriteLn ('S(i)mulated block cursor: ', SimulateBlockCursorIDs[SimulateBlockCursorKind]);
   Write   ('C(u)rsor shape:           ', CursorShapeIDs[CursorShape]);
   GotoXY (36, WhereY)
end;

procedure RedrawAll; forward;
procedure CheckScreenSize; forward;

procedure StatusKey (Key: TKey);
var SSize, NewSize: TPoint;
begin
   case LoCase (Key2Char (Key)) of
     'm': begin
	SetMonochrome (not IsMonochrome);
	RedrawAll
     end;
     'c': begin
	SSize := ScreenSize;
	if SSize.x > 40 then
	   NewSize.x := 40
	else
	   NewSize.x := 80;
	if SSize.y > 25 then
	   NewSize.y := 50
	else
	   NewSize.y := 25;
	SetScreenSize (NewSize.x, NewSize.y);
	CheckScreenSize
     end;
     'l': begin
	SSize := ScreenSize;
	if SSize.x > 40 then
	   NewSize.x := 80
	else
	   NewSize.x := 40;
	if SSize.y > 25 then
	   NewSize.y := 25
	else
	   NewSize.y := 50;
	SetScreenSize (NewSize.x, NewSize.y);
	CheckScreenSize
     end;
     'r': begin
	SetScreenSize (OrigScreenSize.x, OrigScreenSize.y);
	CheckScreenSize
     end;
     'b': CheckBreak := not CheckBreak;
     's': ScrollState := not ScrollState;
     'i': if SimulateBlockCursorKind = High (SimulateBlockCursorKind) then
	SimulateBlockCursorKind := Low (SimulateBlockCursorKind)
     else
	Inc (SimulateBlockCursorKind);
     'u': case CursorShape of
       CursorNormal: CursorShape := CursorBlock;
       CursorFat,
       CursorBlock : CursorShape := CursorHidden;
     else          CursorShape := CursorNormal
     end;
   end;
   ClrScr;
   StatusDraw
end;

procedure TextAttrDemo;
var f, b, y, x1, y1, x2, y2, Fill, n1, n2, n3: Integer;
begin
   GetWindow (x1, y1, x2, y2);
   Window (x1 - 1, y1, x2, y2);
   TextColor (White);
   TextBackground (Blue);
   ClrScr;
   SetScroll (False);
   Fill := GetXMax - 32;
   for y := 1 to GetYMax do
   begin
      GotoXY (1, y);
      b := (y - 1) mod 16;
      n1 := 0;
      for f := 0 to 15 do
      begin
	 TextAttr := f + 16 * b;
	 n2 := (Fill * (1 + 2 * f) + 16) div 32;
	 n3 := (Fill * (2 + 2 * f) + 16) div 32;
	 Write ('' : n2 - n1, NumericBaseDigitsUpper[b], NumericBaseDigitsUpper[f], '' : n3 - n2);
	 n1 := n3
      end
   end
end;

procedure CharSetDemo (UsePCCharSet: Boolean);
var h, l, y, x1, y1, x2, y2, Fill, n1, n2: Integer;
begin
   GetWindow (x1, y1, x2, y2);
   Window (x1 - 1, y1, x2, y2);
   ClrScr;
   SetScroll (False);
   SetPCCharSet (UsePCCharSet);
   SetControlChars (False);
   Fill := GetXMax - 35;
   for y := 1 to GetYMax do
   begin
      GotoXY (1, y);
      h := (y - 2) mod 16;
      n1 := (Fill + 9) div 18;
      if y = 1 then
	 Write ('' : 3 + n1)
      else
	 Write (16 * h : 3 + n1);
      for l := 0 to 15 do
      begin
	 n2 := (Fill * (2 + l) + 9) div 18;
	 if y = 1 then
	    Write ('' : n2 - n1, l : 2)
	 else
	    Write ('' : n2 - n1 + 1, Chr (16 * h + l));
	 n1 := n2
      end
   end
end;

procedure NormalCharSetDemo;
begin
   CharSetDemo (False)
end;

procedure PCCharSetDemo;
begin
   CharSetDemo (True)
end;

procedure FKeyDemoDraw;
var x1, y1, x2, y2: Integer;
begin
   GetWindow (x1, y1, x2, y2);
   Window (x1, y1, x2 - 1, y2);
   ClrScr;
   SetScroll (False);
   WriteLn ('You can type the following keys');
   WriteLn ('(function keys if present on the');
   WriteLn ('terminal, letters as alternatives):');
   GotoXY (1, 4);
   WriteLn ('S, Left     : left (wrap-around)');
   WriteLn ('D, Right    : right (wrap-around)');
   WriteLn ('E, Up       : up (wrap-around)');
   WriteLn ('X, Down     : down (wrap-around)');
   WriteLn ('A, Home     : go to first column');
   WriteLn ('F, End      : go to last column');
   WriteLn ('R, Page Up  : go to first line');
   WriteLn ('C, Page Down: go to last line');
   WriteLn ('Y, Ctrl-PgUp: first column and line');
   GotoXY (1, 13);
   WriteLn ('B, Ctrl-PgDn: last column and line');
   WriteLn ('Z, Ctrl-Home: clear screen');
   WriteLn ('N, Ctrl-End : clear to end of line');
   WriteLn ('V, Insert   : insert a line');
   WriteLn ('T, Delete   : delete a line');
   WriteLn ('#           : beep');
   WriteLn ('*           : flash');
   WriteLn ('Tab, Enter, Backspace, other');
   WriteLn ('  normal characters: write text')
end;

procedure FKeyDemoKey (Key: TKey);
const TabSize = 8;
var
   ch: Char;
   NewX: Integer;
begin
   case LoCaseKey (Key) of
     Ord ('s'), kbLeft    : if WhereX = 1 then GotoXY (GetXMax, WhereY) else GotoXY (WhereX - 1, WhereY);
     Ord ('d'), kbRight   : if WhereX = GetXMax then GotoXY (1, WhereY) else GotoXY (WhereX + 1, WhereY);
     Ord ('e'), kbUp      : if WhereY = 1 then GotoXY (WhereX, GetYMax) else GotoXY (WhereX, WhereY - 1);
     Ord ('x'), kbDown    : if WhereY = GetYMax then GotoXY (WhereX, 1) else GotoXY (WhereX, WhereY + 1);
     Ord ('a'), kbHome    : Write (chCR);
     Ord ('f'), kbEnd     : GotoXY (GetXMax, WhereY);
     Ord ('r'), kbPgUp    : GotoXY (WhereX, 1);
     Ord ('c'), kbPgDn    : GotoXY (WhereX, GetYMax);
     Ord ('y'), kbCtrlPgUp: GotoXY (1, 1);
     Ord ('b'), kbCtrlPgDn: GotoXY (GetXMax, GetYMax);
     Ord ('z'), kbCtrlHome: ClrScr;
     Ord ('n'), kbCtrlEnd : ClrEOL;
     Ord ('v'), kbIns     : InsLine;
     Ord ('t'), kbDel     : DelLine;
     Ord ('#')            : Beep;
     Ord ('*')            : Flash;
     kbTab                : begin
			       NewX := ((WhereX - 1) div TabSize + 1) * TabSize + 1;
			       if NewX <= GetXMax then GotoXY (NewX, WhereY) else WriteLn
			    end;
     kbCR                 : WriteLn;
     kbBkSp               : Write (chBkSp, ' ', chBkSp);
   else                   ch := Key2Char (Key);
     if ch <> #0 then Write (ch)
   end
end;

procedure KeyDemoDraw;
begin
   WriteLn ('Press some keys ...')
end;

procedure KeyDemoKey (Key: TKey);
var ch: Char;
begin
   ch := Key2Char (Key);
   if ch <> #0 then
   begin
      Write ('Normal key');
      if IsPrintable (ch) then Write (' `', ch, '''');
      WriteLn (', ASCII #', Ord (ch))
   end
   else
      WriteLn ('Special key ', Ord (Key2Scan (Key)))
end;

procedure IOSelectPeriodical;
var
   CurrentTime: TimeStamp;
   s: String (8);
   i: Integer;
begin
   GetTimeStamp (CurrentTime);
   with CurrentTime do
      WriteStr (s, Hour : 2, ':', Minute : 2, ':', Second : 2);
   for i := 1 to Length (s) do
      if s[i] = ' ' then s[i] := '0';
   GotoXY (1, 12);
   Write ('The time is: ', s)
end;

procedure IOSelectDraw;
begin
   WriteLn ('IOSelect is a way to handle I/O from');
   WriteLn ('or to several places simultaneously,');
   WriteLn ('without  having  to use  threads  or');
   WriteLn ('signal/interrupt  handlers  or waste');
   WriteLn ('CPU time with busy waiting.');
   WriteLn;
   WriteLn ('This demo  shows how  IOSelect works');
   WriteLn ('in connection with CRT.  It displays');
   WriteLn ('a clock,  but still  reacts  to user');
   WriteLn ('input immediately.');
   IOSelectPeriodical
end;

procedure ModifierPeriodical;
const
   Pressed: array [Boolean] of String [8] = ('Released', 'Pressed');
   ModifierNames: array [1 .. 7] of record
		     Modifier: Integer;
		     Name: String (17)
		  end =
   ((shLeftShift,  'Left Shift'),
    (shRightShift, 'Right Shift'),
    (shLeftCtrl,   'Left Control'),
    (shRightCtrl,  'Right Control'),
    (shAlt,        'Alt (left)'),
    (shAltGr,      'AltGr (right Alt)'),
    (shExtra,      'Extra'));
var
   ShiftState, i: Integer;
begin
   ShiftState := GetShiftState;
   for i := 1 to 7 do
      with ModifierNames[i] do
      begin
	 GotoXY (1, 4 + i);
	 ClrEOL;
	 Write (Name, ':');
	 GotoXY (20, WhereY);
	 Write (Pressed[(ShiftState and Modifier) <> 0])
      end
end;

procedure ModifierDraw;
begin
   WriteLn ('Modifier keys (NOTE: only');
   WriteLn ('available on some systems;');
   WriteLn ('X11: only after key press):');
   ModifierPeriodical
end;

procedure ChecksDraw;
begin
   WriteLn ('(O)S shell');
   WriteLn ('OS shell with (C)learing');
   WriteLn ('(R)efresh check');
   Write   ('(S)ound check')
end;

procedure ChecksKey (Key: TKey);
var
   i, j: Integer;
   WasteTime: Real; attribute (volatile);

   procedure DoOSShell;
   var
      Result: Integer;
      Shell: TString;
   begin
      Shell := GetShellPath (Null);
      {$I-}
      Result := Execute (Shell);
      {$I+}
      if (InOutRes <> 0) or (Result <> 0) then
      begin
	 ClrScr;
	 if InOutRes <> 0 then
	    WriteLn (GetIOErrorMessage, ' while trying to execute `', Shell, '''.')
	 else
	    WriteLn ('`', Shell, ''' returned status ', Result, '.');
	 Write ('Any key to continue.');
	 BlockCursor;
	 Discard (GetKey (-1))
      end
   end;

begin
   case LoCase (Key2Char (Key)) of
     'o': begin
	if PopUpConfirm (36, 12, 'You will now get an OS shell. Unless' + NewLine +
			 'CRTDemo is running  in its own (GUI)' + NewLine +
			 'window,  the shell  will run  on the' + NewLine +
			 'same screen as CRTDemo  which is not' + NewLine +
			 'cleared before the shell is started.' + NewLine +
			 'If possible, the screen contents are' + NewLine +
			 'restored to the state before CRTDemo' + NewLine +
			 'was started. After leaving the shell' + NewLine +
			 'in the usual way (usually  by enter-' + NewLine +
			 'ing  `exit''), you will  get back to' + NewLine +
			 'the demo.  <ESC> to abort, any other' + NewLine +
			 'key to start.') then
	begin
	   RestoreTerminal (True);
	   DoOSShell
	end;
	ClosePopUpWindow
     end;
     'c': begin
	if PopUpConfirm (36, 9, 'You will now get an OS shell. Unless' + NewLine +
			 'CRTDemo is running in  its own (GUI)' + NewLine +
			 'window, the screen  will be cleared,' + NewLine +
			 'and the cursor will be  moved to the' + NewLine +
			 'top  before  the  shell  is started.' + NewLine +
			 'After leaving the shell in the usual' + NewLine +
			 'way  (usually  by entering  `exit''),' + NewLine +
			 'you will get back to the demo. <ESC>' + NewLine +
			 'to abort, any other key to start.') then
	begin
	   RestoreTerminalClearCRT;
	   DoOSShell
	end;
	ClosePopUpWindow
     end;
     'r': begin
	if PopUpConfirm (36, 11, 'The program will  now get  busy with' + NewLine +
			 'some  dummy  computations.  However,' + NewLine +
			 'CRT output in  the form of dots will' + NewLine +
			 'still appear continuously one by one' + NewLine +
			 '(rather than the  whole line at once' + NewLine +
			 'in the end). While running, the test' + NewLine +
			 'cannot  be  interrupted.   <ESC>  to' + NewLine +
			 'abort, any other key to start.') then
	begin
	   SetCRTUpdate (UpdateRegularly);
	   BlockCursor;
	   WriteLn;
	   WriteLn;
	   for i := 1 to GetXMax - 2 do
	   begin
	      Write ('.');
	      for j := 1 to 400000 do WasteTime := Random
	   end;
	   SetCRTUpdate (UpdateInput);
	   WriteLn;
	   Write ('Press any key.');
	   Discard (GetKey (-1))
	end;
	ClosePopUpWindow
     end;
     's': begin
	if PopUpConfirm (32, 4, 'You will now hear some sounds if' + NewLine +
			 'supported  (otherwise there will' + NewLine +
			 'just be a short pause). <ESC> to' + NewLine +
			 'abort, any other key to start.') then
	begin
	   BlockCursor;
	   for i := 0 to 7 do
	   begin
	      Sound (Round (440 * 2 ** (Round (i * 12 / 7 + 0.3) / 12)));
	      if GetKey (400000) in [kbEsc, kbAltEsc] then Break
	   end;
	   NoSound
	end;
	ClosePopUpWindow
     end;
   end
end;

type
   PWindowList = ^TWindowList;
   TWindowList = record
		    Next, Prev: PWindowList;
		    Panel, FramePanel: TPanel;
		    WindowType: Integer;
		    x1, y1, xs, ys: Integer;
		    State: (ws_None, ws_Moving, ws_Resizing);
		 end;

TKeyProc = procedure (Key: TKey);
TProcedure = procedure;

const
   MenuNameLength = 16;
   WindowTypes: array [0 .. 9] of record
		   DrawProc,
		   PeriodicalProc: procedure;
		   KeyProc       : TKeyProc;
		   Name          : String (MenuNameLength);
		   Color,
		   Background,
		   MinSizeX,
		   MinSizeY,
		   PrefSizeX,
		   PrefSizeY     : Integer;
		   RedrawAlways,
		   WantCursor    : Boolean
				   end =
((MainDraw         , nil               , nil        , 'CRT Demo'        , LightGreen, Blue     , 26,  7,  0,  0, False, False),
 (StatusDraw       , nil               , StatusKey  , 'Status'          , White     , Red      , 38, 16,  0,  0, True,  True),
 (TextAttrDemo     , nil               , nil        , 'Text Attributes' , White     , Blue     , 32, 16, 64, 16, False, False),
 (NormalCharSetDemo, nil               , nil        , 'Character Set'   , Black     , Green    , 35, 17, 53, 17, False, False),
 (PCCharSetDemo    , nil               , nil        , 'PC Character Set', Black     , Brown    , 35, 17, 53, 17, False, False),
 (KeyDemoDraw      , nil               , KeyDemoKey , 'Keys'            , Blue      , LightGray, 29,  5, -1, -1, False, True),
 (FKeyDemoDraw     , nil               , FKeyDemoKey, 'Function Keys'   , Blue      , LightGray, 37, 22, -1, -1, False, True),
 (ModifierDraw     , ModifierPeriodical, nil        , 'Modifier Keys'   , Black     , Cyan     , 29, 11,  0,  0, True,  False),
 (IOSelectDraw     , IOSelectPeriodical, nil        , 'IOSelect Demo'   , White     , Magenta  , 38, 12,  0,  0, False, False),
 (ChecksDraw       , nil               , ChecksKey  , 'Various Checks'  , Black     , Red      , 26,  4,  0,  0, False, False));

MenuMax = High (WindowTypes);
MenuXSize = MenuNameLength + 4;
MenuYSize = MenuMax + 2;

var
   WindowList: PWindowList = nil;

   procedure RedrawFrame (p: PWindowList);
   begin
      with p^, WindowTypes[WindowType] do
      begin
	 PanelActivate (FramePanel);
	 Window (x1, y1, x1 + xs - 1, y1 + ys - 1);
	 ClrScr;
	 case State of
	   ws_None    : if p = WindowList then
	      FrameWin (' ' + Name + ' ', DoubleFrame, True)
	   else
	      FrameWin (' ' + Name + ' ', SingleFrame, False);
	   ws_Moving  : FrameWin (' Move Window ', SingleFrame, True);
	   ws_Resizing: FrameWin (' Resize Window ', SingleFrame, True);
	 end
      end
   end;

   procedure DrawWindow (p: PWindowList);
   begin
      with p^, WindowTypes[WindowType] do
      begin
	 RedrawFrame (p);
	 PanelActivate (Panel);
	 Window (x1 + 2, y1 + 1, x1 + xs - 2, y1 + ys - 2);
	 ClrScr;
	 DrawProc
      end
   end;

   procedure RedrawAll;
   var
      LastPanel: TPanel;
      p: PWindowList;
      x2, y2: Integer;
   begin
      LastPanel := GetActivePanel;
      PanelActivate (MainPanel);
      TextBackground (Blue);
      ClrScr;
      p := WindowList;
      if p <> nil then
	 repeat
	    with p^ do
	    begin
	       PanelActivate (FramePanel);
	       GetWindow (x1, y1, x2, y2);  { updated automatically by CRT }
	       xs := x2 - x1 + 1;
	       ys := y2 - y1 + 1
	    end;
	    DrawWindow (p);
	    p := p^.Next
	 until p = WindowList;
      PanelActivate (LastPanel)
   end;

   procedure CheckScreenSize;
   var
      LastPanel: TPanel;
      MinScreenSizeX, MinScreenSizeY, i: Integer;
      SSize: TPoint;
   begin
      LastPanel := GetActivePanel;
      PanelActivate (MainPanel);
      HideCursor;
      MinScreenSizeX := MenuXSize;
      MinScreenSizeY := MenuYSize;
      for i := Low (WindowTypes) to High (WindowTypes) do
	 with WindowTypes[i] do
	 begin
	    MinScreenSizeX := Max (MinScreenSizeX, MinSizeX + 2);
	    MinScreenSizeY := Max (MinScreenSizeY, MinSizeY + 2)
	 end;
      SSize := ScreenSize;
      Window (1, 1, SSize.x, SSize.y);
      if (SSize.x < MinScreenSizeX) or (SSize.y < MinScreenSizeY) then
      begin
	 NormVideo;
	 ClrScr;
	 RestoreTerminal (True);
	 WriteLn (StdErr, 'Sorry, your screen is too small for this demo (', SSize.x, 'x', SSize.y, ').');
	 WriteLn (StdErr, 'You need at least ', MinScreenSizeX, 'x', MinScreenSizeY, ' characters.');
	 Halt (2)
      end;
      PanelActivate (LastPanel);
      RedrawAll
   end;

   procedure Die; attribute (noreturn);
   begin
      NoSound;
      RestoreTerminalClearCRT;
      WriteLn (StdErr, 'You''re trying to kill me. Since I have break checking turned off,');
      WriteLn (StdErr, 'I''m not dying, but I''ll do you a favour and terminate now.');
      Halt (3)
   end;

   function GetKey (TimeOut: Integer) = Key: TKey;
   var
      NeedSelect, SelectValue: Integer;
      SimulateBlockCursorCurrent: TSimulateBlockCursorKind;
      SelectInput: array [1 .. 1] of PAnyFile = (@Input);
      NextSelectTime: MicroSecondTimeType = 0; attribute (static);
      TimeOutTime: MicroSecondTimeType;
      LastPanel: TPanel;
      p: PWindowList;
   begin
      LastPanel := GetActivePanel;
      if TimeOut < 0 then
	 TimeOutTime := High (TimeOutTime)
      else
	 TimeOutTime := GetMicroSecondTime + TimeOut;
      NeedSelect := 0;
      if TimeOut >= 0 then
	 Inc (NeedSelect);
      SimulateBlockCursorCurrent := SimulateBlockCursorKind;
      if SimulateBlockCursorCurrent <> bc_None then
	 Inc (NeedSelect);
      p := WindowList;
      repeat
	 if @WindowTypes[p^.WindowType].PeriodicalProc <> nil then
	    Inc (NeedSelect);
	 p := p^.Next
      until p = WindowList;
      p := WindowList;
      repeat
	 with p^, WindowTypes[WindowType] do
	    if RedrawAlways then
	    begin
	       PanelActivate (Panel);
	       ClrScr;
	       DrawProc
	    end;
	 p := p^.Next
      until p = WindowList;
      if NeedSelect <> 0 then
	 repeat
	    CRTUpdate;
	    SelectValue := IOSelectRead (SelectInput, Max (0, Min (NextSelectTime, TimeOutTime) - GetMicroSecondTime));
	    if SelectValue = 0 then
	    begin
	       case SimulateBlockCursorCurrent of
		 bc_None  : ;
		 bc_Blink : SimulateBlockCursor;
		 bc_Static: begin
		    SimulateBlockCursor;
		    SimulateBlockCursorCurrent := bc_None;
		    Dec (NeedSelect)
		 end
	       end;
	       NextSelectTime := GetMicroSecondTime + 120000;
	       p := WindowList;
	       repeat
		  with p^, WindowTypes[WindowType] do
		     if @PeriodicalProc <> nil then
		     begin
			PanelActivate (Panel);
			PeriodicalProc
		     end;
		  p := p^.Next
	       until p = WindowList
	    end;
	 until (NeedSelect = 0) or (SelectValue <> 0) or ((TimeOut >= 0) and (GetMicroSecondTime >= TimeOutTime));
      if NeedSelect = 0 then
	 SelectValue := 1;
      if SelectValue = 0 then
	 Key := 0
      else
	 Key := ReadKeyWord;
      if SimulateBlockCursorKind <> bc_None then
	 SimulateBlockCursorOff;
      if IsDeadlySignal (Key) then Die;
      if Key = kbScreenSizeChanged then CheckScreenSize;
      PanelActivate (LastPanel)
   end;

   function Menu = n: Integer;
   var
      i, ax, ay: Integer;
      Key: TKey;
      Done: Boolean;
      SSize: TPoint;
   begin
      n := 1;
      repeat
	 SSize := ScreenSize;
	 ax := (SSize.x - MenuXSize) div 2 + 1;
	 ay := (SSize.y - MenuYSize) div 2 + 1;
	 PanelNew (ax, ay, ax + MenuXSize - 1, ay + MenuYSize - 1, False);
	 SetControlChars (True);
	 TextColor (Blue);
	 TextBackground (LightGray);
	 FrameWin (' Select Window ', DoubleFrame, True);
	 IgnoreCursor;
	 PanelNew (ax + 1, ay + 1, ax + MenuXSize - 2, ay + MenuYSize - 2, False);
	 ClrScr;
	 TextColor (Black);
	 SetScroll (False);
	 Done := False;
	 repeat
	    for i := 1 to MenuMax do
	    begin
	       GotoXY (1, i);
	       if i = n then
		  TextBackground (Green)
	       else
		  TextBackground (LightGray);
	       ClrEOL;
	       Write (' ', WindowTypes[i].Name);
	       ChangeTextAttr (2, i, 1, Red + $10 * GetTextBackground)
	    end;
	    Key := GetKey (-1);
	    case LoCaseKey (Key) of
	      kbUp                  : if n = 1 then n := MenuMax else Dec (n);
	      kbDown                : if n = MenuMax then n := 1 else Inc (n);
	      kbHome,
	      kbPgUp,
	      kbCtrlPgUp,
	      kbCtrlHome            : n := 1;
	      kbEnd,
	      kbPgDn,
	      kbCtrlPgDn,
	      kbCtrlEnd             : n := MenuMax;
	      kbCR                  : Done := True;
	      kbEsc, kbAltEsc       : begin
		 n := -1;
		 Done := True
	      end;
	      Ord ('a') .. Ord ('z'): begin
		 i := MenuMax;
		 while (i > 0) and (LoCase (Key2Char (Key)) <> LoCase (WindowTypes[i].Name[1])) do Dec (i);
		 if i > 0 then
		 begin
		    n := i;
		    Done := True
		 end
	      end;
	    end
	 until Done or (Key = kbScreenSizeChanged);
	 ClosePopUpWindow
      until Key <> kbScreenSizeChanged
   end;

   procedure NewWindow (WindowType, ax, ay: Integer);
   var
      p, LastWindow: PWindowList;
      MaxX1, MaxY1: Integer;
      SSize: TPoint;
   begin
      New (p);
      if WindowList = nil then
      begin
	 p^.Prev := p;
	 p^.Next := p
      end
      else
      begin
	 p^.Prev := WindowList;
	 p^.Next := WindowList^.Next;
	 p^.Prev^.Next := p;
	 p^.Next^.Prev := p;
      end;
      p^.WindowType := WindowType;
      with p^, WindowTypes[WindowType] do
      begin
	 SSize := ScreenSize;
	 if PrefSizeX > 0 then xs := PrefSizeX else xs := MinSizeX;
	 if PrefSizeY > 0 then ys := PrefSizeY else ys := MinSizeY;
	 xs := Min (xs + 2, SSize.x);
	 ys := Min (ys + 2, SSize.y);
	 MaxX1 := SSize.x - xs + 1;
	 MaxY1 := SSize.y - ys + 1;
	 if ax = 0 then x1 := Random (MaxX1) + 1 else x1 := Min (ax, MaxX1);
	 if ay = 0 then y1 := Random (MaxY1) + 1 else y1 := Min (ay, MaxY1);
	 if (ax = 0) and (PrefSizeX < 0) then Inc (xs, Random (SSize.x - x1 - xs + 2));
	 if (ax = 0) and (PrefSizeY < 0) then Inc (ys, Random (SSize.y - y1 - ys + 2));
	 State := ws_None;
	 PanelNew (1, 1, 1, 1, False);
	 FramePanel := GetActivePanel;
	 SetControlChars (True);
	 TextColor (Color);
	 TextBackground (Background);
	 PanelNew (1, 1, 1, 1, False);
	 SetPCCharSet (False);
	 Panel := GetActivePanel;
      end;
      LastWindow := WindowList;
      WindowList := p;
      if LastWindow <> nil then RedrawFrame (LastWindow);
      DrawWindow (p)
   end;

   procedure OpenWindow;
   var WindowType: Integer;
   begin
      WindowType := Menu;
      if WindowType >= 0 then NewWindow (WindowType, 0, 0)
   end;

   procedure NextWindow;
   var LastWindow: PWindowList;
   begin
      LastWindow := WindowList;
      WindowList := WindowList^.Next;
      PanelTop (WindowList^.FramePanel);
      PanelTop (WindowList^.Panel);
      RedrawFrame (LastWindow);
      RedrawFrame (WindowList)
   end;

   procedure PreviousWindow;
   var LastWindow: PWindowList;
   begin
      PanelMoveAbove (WindowList^.Panel, MainPanel);
      PanelMoveAbove (WindowList^.FramePanel, MainPanel);
      LastWindow := WindowList;
      WindowList := WindowList^.Prev;
      RedrawFrame (LastWindow);
      RedrawFrame (WindowList)
   end;

   procedure CloseWindow;
   var p: PWindowList;
   begin
      if WindowList^.WindowType <> 0 then
      begin
	 p := WindowList;
	 NextWindow;
	 PanelDelete (p^.FramePanel);
	 PanelDelete (p^.Panel);
	 p^.Next^.Prev := p^.Prev;
	 p^.Prev^.Next := p^.Next;
	 Dispose (p)
      end
   end;

   procedure MoveWindow;
   var
      Done, Changed: Boolean;
      SSize: TPoint;
   begin
      with WindowList^ do
      begin
	 Done := False;
	 Changed := True;
	 State := ws_Moving;
	 repeat
	    if Changed then DrawWindow (WindowList);
	    Changed := True;
	    case LoCaseKey (GetKey (-1)) of
	      Ord ('s'), kbLeft    : if x1 > 1 then Dec (x1);
	      Ord ('d'), kbRight   : if x1 + xs - 1 < ScreenSize.x then Inc (x1);
	      Ord ('e'), kbUp      : if y1 > 1 then Dec (y1);
	      Ord ('x'), kbDown    : if y1 + ys - 1 < ScreenSize.y then Inc (y1);
	      Ord ('a'), kbHome    : x1 := 1;
	      Ord ('f'), kbEnd     : x1 := ScreenSize.x - xs + 1;
	      Ord ('r'), kbPgUp    : y1 := 1;
	      Ord ('c'), kbPgDn    : y1 := ScreenSize.y - ys + 1;
	      Ord ('y'), kbCtrlPgUp: begin
		 x1 := 1;
		 y1 := 1
	      end;
	      Ord ('b'), kbCtrlPgDn: begin
		 SSize := ScreenSize;
		 x1 := SSize.x - xs + 1;
		 y1 := SSize.y - ys + 1
	      end;
	      kbCR,
	      kbEsc, kbAltEsc      : Done := True;
	    else                   Changed := False
	    end
	 until Done;
	 State := ws_None;
	 DrawWindow (WindowList)
      end
   end;

   procedure ResizeWindow;
   var
      Done, Changed: Boolean;
      SSize: TPoint;
   begin
      with WindowList^, WindowTypes[WindowType] do
      begin
	 Done := False;
	 Changed := True;
	 State := ws_Resizing;
	 repeat
	    if Changed then DrawWindow (WindowList);
	    Changed := True;
	    case LoCaseKey (GetKey (-1)) of
	      Ord ('s'), kbLeft    : if xs > MinSizeX + 2 then Dec (xs);
	      Ord ('d'), kbRight   : if x1 + xs - 1 < ScreenSize.x then Inc (xs);
	      Ord ('e'), kbUp      : if ys > MinSizeY + 2 then Dec (ys);
	      Ord ('x'), kbDown    : if y1 + ys - 1 < ScreenSize.y then Inc (ys);
	      Ord ('a'), kbHome    : xs := MinSizeX + 2;
	      Ord ('f'), kbEnd     : xs := ScreenSize.x - x1 + 1;
	      Ord ('r'), kbPgUp    : ys := MinSizeY + 2;
	      Ord ('c'), kbPgDn    : ys := ScreenSize.y - y1 + 1;
	      Ord ('y'), kbCtrlPgUp: begin
		 xs := MinSizeX + 2;
		 ys := MinSizeY + 2
	      end;
	      Ord ('b'), kbCtrlPgDn: begin
		 SSize := ScreenSize;
		 xs := SSize.x - x1 + 1;
		 ys := SSize.y - y1 + 1
	      end;
	      kbCR,
	      kbEsc, kbAltEsc      : Done := True;
	    else                   Changed := False
	    end
	 until Done;
	 State := ws_None;
	 DrawWindow (WindowList)
      end
   end;

   procedure ActivateCursor;
   begin
      with WindowList^, WindowTypes[WindowType] do
      begin
	 PanelActivate (Panel);
	 if WantCursor then
	    SetCursorShape (CursorShape)
	 else
	    HideCursor
      end;
      SetScroll (ScrollState)
   end;

var
   Key: TKey;
   ScreenShot, Done: Boolean;

begin
   ScreenShot := ParamStr (1) = '--screenshot';
   if ParamCount <> Ord (ScreenShot) then
   begin
      RestoreTerminal (True);
      WriteLn (StdErr, ParamStr (0), ': invalid argument `', ParamStr (Ord (ScreenShot) + 1), '''');
      Halt (1)
   end;
   CRTSavePreviousScreen (True);
   SetCRTUpdate (UpdateInput);
   MainPanel := GetActivePanel;
   CheckScreenSize;
   OrigScreenSize := ScreenSize;
   if ScreenShot then
   begin
      CursorShape := CursorBlock;
      NewWindow (6,      1,      1);
      NewWindow (2,      1, MaxInt);
      NewWindow (8, MaxInt,      1);
      NewWindow (5,      1,     27);
      KeyDemoKey (Ord ('f'));
      KeyDemoKey (246);
      KeyDemoKey (kbDown);
      NewWindow (3, MaxInt,     13);
      NewWindow (4, MaxInt,     31);
      NewWindow (7, MaxInt, MaxInt);
      NewWindow (9, MaxInt,     33);
      NewWindow (0,      1,      2);
      NewWindow (1,      1,     14);
      ActivateCursor;
      OpenWindow
   end
   else
      NewWindow (0, 3, 2);
   Done := False;
   repeat
      ActivateCursor;
      Key := GetKey (-1);
      case LoCaseKey (Key) of
	Ord ('3'), kbF3 : OpenWindow;
	Ord ('4'), kbF4 : CloseWindow;
	Ord ('5'), kbF5 : PreviousWindow;
	Ord ('6'), kbF6 : NextWindow;
	Ord ('7'), kbF7 : MoveWindow;
	Ord ('8'), kbF8 : ResizeWindow;
	Ord ('q'), kbEsc,
	kbAltEsc:         Done := True;
      else
	 if WindowList <> nil then
	    with WindowList^, WindowTypes[WindowType] do
	       if @KeyProc <> nil then
	       begin
		  TextColor (Color);
		  TextBackground (Background);
		  KeyProc (Key)
	       end
      end
   until Done
end.