summaryrefslogtreecommitdiff
path: root/test/manual/indent/pascal.pas
diff options
context:
space:
mode:
authorPhillip Lord <phillip.lord@russet.org.uk>2015-11-23 22:02:42 +0000
committerPhillip Lord <phillip.lord@russet.org.uk>2015-11-24 17:04:22 +0000
commit22bbf7ca22f11cc33d887d0162cf2ec6661c3a3e (patch)
tree779ff7e07667194416e01c6a6e8bd7b970244c70 /test/manual/indent/pascal.pas
parentc378d6c33f751d1a0b97958f3cacfe0b07c72f58 (diff)
downloademacs-22bbf7ca22f11cc33d887d0162cf2ec6661c3a3e.tar.gz
Rename all test files to reflect source layout.
* CONTRIBUTE,Makefile.in,configure.ac: Update to reflect test directory moves. * test/file-organisation.org: New file. * test/automated/Makefile.in test/automated/data/decompress/foo.gz test/automated/data/epg/pubkey.asc test/automated/data/epg/seckey.asc test/automated/data/files-bug18141.el.gz test/automated/data/flymake/test.c test/automated/data/flymake/test.pl test/automated/data/package/archive-contents test/automated/data/package/key.pub test/automated/data/package/key.sec test/automated/data/package/multi-file-0.2.3.tar test/automated/data/package/multi-file-readme.txt test/automated/data/package/newer-versions/archive-contents test/automated/data/package/newer-versions/new-pkg-1.0.el test/automated/data/package/newer-versions/simple-single-1.4.el test/automated/data/package/package-test-server.py test/automated/data/package/signed/archive-contents test/automated/data/package/signed/archive-contents.sig test/automated/data/package/signed/signed-bad-1.0.el test/automated/data/package/signed/signed-bad-1.0.el.sig test/automated/data/package/signed/signed-good-1.0.el test/automated/data/package/signed/signed-good-1.0.el.sig test/automated/data/package/simple-depend-1.0.el test/automated/data/package/simple-single-1.3.el test/automated/data/package/simple-single-readme.txt test/automated/data/package/simple-two-depend-1.1.el test/automated/abbrev-tests.el test/automated/auto-revert-tests.el test/automated/calc-tests.el test/automated/icalendar-tests.el test/automated/character-fold-tests.el test/automated/comint-testsuite.el test/automated/descr-text-test.el test/automated/electric-tests.el test/automated/cl-generic-tests.el test/automated/cl-lib-tests.el test/automated/eieio-test-methodinvoke.el test/automated/eieio-test-persist.el test/automated/eieio-tests.el test/automated/ert-tests.el test/automated/ert-x-tests.el test/automated/generator-tests.el test/automated/let-alist.el test/automated/map-tests.el test/automated/advice-tests.el test/automated/package-test.el test/automated/pcase-tests.el test/automated/regexp-tests.el test/automated/seq-tests.el test/automated/subr-x-tests.el test/automated/tabulated-list-test.el test/automated/thunk-tests.el test/automated/timer-tests.el test/automated/epg-tests.el test/automated/eshell.el test/automated/faces-tests.el test/automated/file-notify-tests.el test/automated/auth-source-tests.el test/automated/gnus-tests.el test/automated/message-mode-tests.el test/automated/help-fns.el test/automated/imenu-test.el test/automated/info-xref.el test/automated/mule-util.el test/automated/isearch-tests.el test/automated/json-tests.el test/automated/bytecomp-tests.el test/automated/coding-tests.el test/automated/core-elisp-tests.el test/automated/decoder-tests.el test/automated/files.el test/automated/font-parse-tests.el test/automated/lexbind-tests.el test/automated/occur-tests.el test/automated/process-tests.el test/automated/syntax-tests.el test/automated/textprop-tests.el test/automated/undo-tests.el test/automated/man-tests.el test/automated/completion-tests.el test/automated/dbus-tests.el test/automated/newsticker-tests.el test/automated/sasl-scram-rfc-tests.el test/automated/tramp-tests.el test/automated/obarray-tests.el test/automated/compile-tests.el test/automated/elisp-mode-tests.el test/automated/f90.el test/automated/flymake-tests.el test/automated/python-tests.el test/automated/ruby-mode-tests.el test/automated/subword-tests.el test/automated/replace-tests.el test/automated/simple-test.el test/automated/sort-tests.el test/automated/subr-tests.el test/automated/reftex-tests.el test/automated/sgml-mode-tests.el test/automated/tildify-tests.el test/automated/thingatpt.el test/automated/url-future-tests.el test/automated/url-util-tests.el test/automated/add-log-tests.el test/automated/vc-bzr.el test/automated/vc-tests.el test/automated/xml-parse-tests.el test/BidiCharacterTest.txt test/biditest.el test/cedet/cedet-utests.el test/cedet/ede-tests.el test/cedet/semantic-ia-utest.el test/cedet/semantic-tests.el test/cedet/semantic-utest-c.el test/cedet/semantic-utest.el test/cedet/srecode-tests.el test/cedet/tests/test.c test/cedet/tests/test.el test/cedet/tests/test.make test/cedet/tests/testdoublens.cpp test/cedet/tests/testdoublens.hpp test/cedet/tests/testfriends.cpp test/cedet/tests/testjavacomp.java test/cedet/tests/testnsp.cpp test/cedet/tests/testpolymorph.cpp test/cedet/tests/testspp.c test/cedet/tests/testsppcomplete.c test/cedet/tests/testsppreplace.c test/cedet/tests/testsppreplaced.c test/cedet/tests/testsubclass.cpp test/cedet/tests/testsubclass.hh test/cedet/tests/testtypedefs.cpp test/cedet/tests/testvarnames.c test/etags/CTAGS.good test/etags/ETAGS.good_1 test/etags/ETAGS.good_2 test/etags/ETAGS.good_3 test/etags/ETAGS.good_4 test/etags/ETAGS.good_5 test/etags/ETAGS.good_6 test/etags/a-src/empty.zz test/etags/a-src/empty.zz.gz test/etags/ada-src/2ataspri.adb test/etags/ada-src/2ataspri.ads test/etags/ada-src/etags-test-for.ada test/etags/ada-src/waroquiers.ada test/etags/c-src/a/b/b.c test/etags/c-src/abbrev.c test/etags/c-src/c.c test/etags/c-src/dostorture.c test/etags/c-src/emacs/src/gmalloc.c test/etags/c-src/emacs/src/keyboard.c test/etags/c-src/emacs/src/lisp.h test/etags/c-src/emacs/src/regex.h test/etags/c-src/etags.c test/etags/c-src/exit.c test/etags/c-src/exit.strange_suffix test/etags/c-src/fail.c test/etags/c-src/getopt.h test/etags/c-src/h.h test/etags/c-src/machsyscalls.c test/etags/c-src/machsyscalls.h test/etags/c-src/sysdep.h test/etags/c-src/tab.c test/etags/c-src/torture.c test/etags/cp-src/MDiagArray2.h test/etags/cp-src/Range.h test/etags/cp-src/burton.cpp test/etags/cp-src/c.C test/etags/cp-src/clheir.cpp.gz test/etags/cp-src/clheir.hpp test/etags/cp-src/conway.cpp test/etags/cp-src/conway.hpp test/etags/cp-src/fail.C test/etags/cp-src/functions.cpp test/etags/cp-src/screen.cpp test/etags/cp-src/screen.hpp test/etags/cp-src/x.cc test/etags/el-src/TAGTEST.EL test/etags/el-src/emacs/lisp/progmodes/etags.el test/etags/erl-src/gs_dialog.erl test/etags/f-src/entry.for test/etags/f-src/entry.strange.gz test/etags/f-src/entry.strange_suffix test/etags/forth-src/test-forth.fth test/etags/html-src/algrthms.html test/etags/html-src/index.shtml test/etags/html-src/software.html test/etags/html-src/softwarelibero.html test/etags/lua-src/allegro.lua test/etags/objc-src/PackInsp.h test/etags/objc-src/PackInsp.m test/etags/objc-src/Subprocess.h test/etags/objc-src/Subprocess.m test/etags/objcpp-src/SimpleCalc.H test/etags/objcpp-src/SimpleCalc.M test/etags/pas-src/common.pas test/etags/perl-src/htlmify-cystic test/etags/perl-src/kai-test.pl test/etags/perl-src/yagrip.pl test/etags/php-src/lce_functions.php test/etags/php-src/ptest.php test/etags/php-src/sendmail.php test/etags/prol-src/natded.prolog test/etags/prol-src/ordsets.prolog test/etags/ps-src/rfc1245.ps test/etags/pyt-src/server.py test/etags/tex-src/gzip.texi test/etags/tex-src/nonewline.tex test/etags/tex-src/testenv.tex test/etags/tex-src/texinfo.tex test/etags/y-src/atest.y test/etags/y-src/cccp.c test/etags/y-src/cccp.y test/etags/y-src/parse.c test/etags/y-src/parse.y test/indent/css-mode.css test/indent/js-indent-init-dynamic.js test/indent/js-indent-init-t.js test/indent/js-jsx.js test/indent/js.js test/indent/latex-mode.tex test/indent/modula2.mod test/indent/nxml.xml test/indent/octave.m test/indent/pascal.pas test/indent/perl.perl test/indent/prolog.prolog test/indent/ps-mode.ps test/indent/ruby.rb test/indent/scheme.scm test/indent/scss-mode.scss test/indent/sgml-mode-attribute.html test/indent/shell.rc test/indent/shell.sh test/redisplay-testsuite.el test/rmailmm.el test/automated/buffer-tests.el test/automated/cmds-tests.el test/automated/data-tests.el test/automated/finalizer-tests.el test/automated/fns-tests.el test/automated/inotify-test.el test/automated/keymap-tests.el test/automated/print-tests.el test/automated/libxml-tests.el test/automated/zlib-tests.el: Files Moved.
Diffstat (limited to 'test/manual/indent/pascal.pas')
-rw-r--r--test/manual/indent/pascal.pas1092
1 files changed, 1092 insertions, 0 deletions
diff --git a/test/manual/indent/pascal.pas b/test/manual/indent/pascal.pas
new file mode 100644
index 00000000000..bb2e7002b6b
--- /dev/null
+++ b/test/manual/indent/pascal.pas
@@ -0,0 +1,1092 @@
+{ GPC demo program for the CRT unit.
+
+Copyright (C) 1999-2006, 2013-2015 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 3.
+
+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+}
+
+(* second style of comment *)
+// Free-pascal style comment.
+var x:Char = 12 /* 45; // This /* does not start a comment.
+var x:Char = (/ 4); // This (/ does not start a comment.
+var a_to_b : integer; // 'to' should not be highlighted
+
+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 favor 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.