home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / l / l044 / 4.ddi / DEMOS.ZIP / WINDEMO.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1990-10-23  |  4.2 KB  |  207 lines
  1.  
  2. { Turbo Windows }
  3. { Copyright (c) 1989,90 by Borland International, Inc. }
  4.  
  5. program WinDemo;
  6. { Turbo Pascal 6.0 example.
  7.   This program demonstrates use of the WIN unit.
  8. }
  9.  
  10. {$S-}
  11.  
  12. uses Crt, Win;
  13.  
  14. const
  15.  
  16.   CClose  = ^C;
  17.   CRight  = ^D;
  18.   CUp     = ^E;
  19.   CEnter  = ^M;
  20.   CInsLin = ^N;
  21.   COpen   = ^O;
  22.   CRandom = ^R;
  23.   CLeft   = ^S;
  24.   CDown   = ^X;
  25.   CDelLin = ^Y;
  26.   CExit   = ^[;
  27.  
  28. type
  29.  
  30.   TitleStrPtr = ^TitleStr;
  31.  
  32.   WinRecPtr = ^WinRec;
  33.   WinRec = record
  34.     Next: WinRecPtr;
  35.     State: WinState;
  36.     Title: TitleStrPtr;
  37.     TitleAttr, FrameAttr: Byte;
  38.     Buffer: Pointer;
  39.   end;
  40.  
  41. var
  42.   TopWindow: WinRecPtr;
  43.   WindowCount: Integer;
  44.   Done: Boolean;
  45.   Ch: Char;
  46.  
  47. procedure ActiveWindow(Active: Boolean);
  48. begin
  49.   if TopWindow <> nil then
  50.   begin
  51.     UnFrameWin;
  52.     with TopWindow^ do
  53.       if Active then
  54.         FrameWin(Title^, DoubleFrame, TitleAttr, FrameAttr)
  55.       else
  56.         FrameWin(Title^, SingleFrame, FrameAttr, FrameAttr);
  57.   end;
  58. end;
  59.  
  60. procedure OpenWindow(X1, Y1, X2, Y2: Byte; T: TitleStr;
  61.   TAttr, FAttr: Byte);
  62. var
  63.   W: WinRecPtr;
  64. begin
  65.   ActiveWindow(False);
  66.   New(W);
  67.   with W^ do
  68.   begin
  69.     Next := TopWindow;
  70.     SaveWin(State);
  71.     GetMem(Title, Length(T) + 1);
  72.     Title^ := T;
  73.     TitleAttr := TAttr;
  74.     FrameAttr := FAttr;
  75.     Window(X1, Y1, X2, Y2);
  76.     GetMem(Buffer, WinSize);
  77.     ReadWin(Buffer^);
  78.     FrameWin(T, DoubleFrame, TAttr, FAttr);
  79.   end;
  80.   TopWindow := W;
  81.   Inc(WindowCount);
  82. end;
  83.  
  84. procedure CloseWindow;
  85. var
  86.   W: WinRecPtr;
  87. begin
  88.   if TopWindow <> nil then
  89.   begin
  90.     W := TopWindow;
  91.     with W^ do
  92.     begin
  93.       UnFrameWin;
  94.       WriteWin(Buffer^);
  95.       FreeMem(Buffer, WinSize);
  96.       FreeMem(Title, Length(Title^) + 1);
  97.       RestoreWin(State);
  98.       TopWindow := Next;
  99.     end;
  100.     Dispose(W);
  101.     ActiveWindow(True);
  102.     Dec(WindowCount);
  103.   end;
  104. end;
  105.  
  106. procedure Initialize;
  107. begin
  108.   CheckBreak := False;
  109.   if (LastMode <> CO80) and (LastMode <> BW80) and
  110.     (LastMode <> Mono) then TextMode(CO80);
  111.   TextAttr := Black + LightGray * 16;
  112.   Window(1, 2, 80, 24);
  113.   FillWin(#178, LightGray + Black * 16);
  114.   Window(1, 1, 80, 25);
  115.   GotoXY(1, 1);
  116.   Write(' Turbo Pascal 6.0 Window Demo');
  117.   ClrEol;
  118.   GotoXY(1, 25);
  119.   Write(' Ins-InsLine  Del-DelLine  Alt-O-Open ' +
  120.     ' Alt-C-Close  Alt-R-Random  Esc-Exit ');
  121.   ClrEol;
  122.   Randomize;
  123.   TopWindow := nil;
  124.   WindowCount := 0;
  125. end;
  126.  
  127. procedure CreateWindow;
  128. var
  129.   X, Y, W, H: Integer;
  130.   S: string[15];
  131.   Color: Byte;
  132. begin
  133.   W := Random(50) + 10;
  134.   H := Random(15) + 5;
  135.   X := Random(80 - W) + 1;
  136.   Y := Random(23 - H) + 2;
  137.   Str(WindowCount + 1, S);
  138.   if LastMode <> CO80 then
  139.     Color := Black else Color := WindowCount mod 6 + 1;
  140.   OpenWindow(X, Y, X + W - 1, Y + H - 1, ' Window ' + S + ' ',
  141.     Color + LightGray * 16, LightGray + Color * 16);
  142.   TextAttr := LightGray;
  143.   ClrScr;
  144. end;
  145.  
  146. procedure RandomText;
  147. begin
  148.   repeat
  149.     Write(Chr(Random(95) + 32));
  150.   until KeyPressed;
  151. end;
  152.  
  153. function ReadChar: Char;
  154. var
  155.   Ch: Char;
  156. begin
  157.   Ch := ReadKey;
  158.   if Ch = #0 then
  159.     case ReadKey of
  160.       #19: Ch := CRandom;   { Alt-R }
  161.       #24: Ch := COpen;     { Alt-O }
  162.       #45: Ch := CExit;     { Alt-X }
  163.       #46: Ch := CClose;    { Alt-C }
  164.       #72: Ch := CUp;       { Up }
  165.       #75: Ch := CLeft;     { Left }
  166.       #77: Ch := CRight;    { Right }
  167.       #80: Ch := CDown;     { Down }
  168.       #82: Ch := CInsLin;   { Ins }
  169.       #83: Ch := CDelLin;   { Del }
  170.     end;
  171.   ReadChar := Ch;
  172. end;
  173.  
  174. procedure Beep;
  175. begin
  176.   Sound(500); Delay(25); NoSound;
  177. end;
  178.  
  179. begin
  180.   Initialize;
  181.   Done := False;
  182.   repeat
  183.     Ch := ReadChar;
  184.     if WindowCount = 0 then
  185.       if (Ch <> COpen) and (Ch <> CExit) then Ch := #0;
  186.     case Ch of
  187.       #32..#255: Write(Ch);
  188.       COpen: CreateWindow;
  189.       CClose: CloseWindow;
  190.       CUp: GotoXY(WhereX, WhereY - 1);
  191.       CLeft: GotoXY(WhereX - 1, WhereY);
  192.       CRight: GotoXY(WhereX + 1, WhereY);
  193.       CDown: GotoXY(WhereX, WhereY + 1);
  194.       CRandom: RandomText;
  195.       CInsLin: InsLine;
  196.       CDelLin: DelLine;
  197.       CEnter: WriteLn;
  198.       CExit: Done := True;
  199.     else
  200.       Beep;
  201.     end;
  202.   until Done;
  203.   Window(1, 1, 80, 25);
  204.   NormVideo;
  205.   ClrScr;
  206. end.
  207.