home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / tvision / gtmous / tvbdemo.pas < prev   
Pascal/Delphi Source File  |  1993-09-30  |  9KB  |  344 lines
  1. {************************************************}
  2. {                                                }
  3. {   Demo program from the Turbo Vision Guide     }
  4. {   Copyright (c) 1990 by Borland International  }
  5. {                                                }
  6. {   TVBeauty 1.0                                 }
  7. {   Changes Copyright (c) 1993 by Igor I. Evsikov}
  8. {   Sergey Yu. Shmakov &  Pete P. Sychov         }
  9. {************************************************}
  10. program TVBDEMO;
  11.  
  12. uses GTMOUSE,Objects, Drivers, Views, Menus, Dialogs, App, Memory, Dos,dark;
  13.  
  14. const
  15.   FileToRead        = 'TVBDEMO.PAS';
  16.   MaxLines          = 100;
  17.   WinCount: Integer =   0;
  18.   cmFileOpen        = 100;
  19.   cmNewWin          = 101;
  20.   cmNewDialog       = 102;
  21.   cmChIm            = 103;
  22.   cmdosshell        = 104;
  23. var
  24.   LineCount: Integer;
  25.   Lines: array[0..MaxLines - 1] of PString;
  26.  
  27. type
  28.   TMyApp = object(TApplication)
  29.     procedure HandleEvent(var Event: TEvent); virtual;
  30.     procedure InitMenuBar; virtual;
  31.     procedure InitStatusLine; virtual;
  32.     procedure NewDialog;
  33.     procedure NewWindow;
  34.     procedure dosshell;
  35.     procedure idle;virtual;
  36.   end;
  37.  
  38.  
  39.   PInterior = ^TInterior;
  40.   TInterior = object(TScroller)
  41.     constructor Init(var Bounds: TRect; AHScrollBar,
  42.       AVScrollBar: PScrollBar);
  43.     procedure Draw; virtual;
  44.   end;
  45.  
  46.   PDemoWindow = ^TDemoWindow;
  47.   TDemoWindow = object(TWindow)
  48.     RInterior, LInterior: PInterior;
  49.     constructor Init(Bounds: TRect; WinTitle: String; WindowNo: Word);
  50.     function MakeInterior(Bounds: TRect; Left: Boolean): PInterior;
  51.     procedure SizeLimits(var Min, Max: TPoint); virtual;
  52.   end;
  53.  
  54.   PDemoDialog = ^TDemoDialog;
  55.   TDemoDialog = object(TDialog)
  56.   end;
  57.  
  58.  
  59. procedure TMyApp.idle;
  60. begin
  61.   TApplication.idle;
  62.   Sleeper;
  63. {  DrawArrow;}
  64. end;
  65.  
  66. procedure Tmyapp.DosShell;
  67. var R: TRect;
  68. begin
  69.   GetExtent(R);
  70.   R.B.Y := R.A.Y + 1;
  71.   MenuBar := New(PMenuBar, Init(R, NewMenu(
  72.     NewSubMenu('~F~ile', hcNoContext, NewMenu(
  73.       NewItem('~O~pen', 'F3', kbF3, cmFileOpen, hcNoContext,
  74.       NewItem('~D~os shell', 'alt F4', kbaltF4, cmdosshell, hcNoContext,
  75.       NewItem('~N~ew', 'F4', kbF4, cmNewWin, hcNoContext,
  76.       NewLine(
  77.       NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, hcNoContext,
  78.       nil)))))),
  79.     NewSubMenu('~W~indow', hcNoContext, NewMenu(
  80.       NewItem('~N~ext', 'F6', kbF6, cmNext, hcNoContext,
  81.       NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcNoContext,
  82.       NewItem('~D~ialog', 'F2', kbF2, cmNewDialog, hcNoContext,
  83.       nil)))),
  84.     nil))
  85.   )));
  86. end;
  87. {begin
  88.   DoneSysError;
  89.   DoneEvents;
  90.   DoneVideo;
  91.   DoneMemory;
  92.   SetMemTop(HeapPtr);
  93.   PrintStr('Type EXIT to return...');
  94.  
  95.   DoneGTMouse;
  96.   RestoreFont;
  97.  
  98.   SwapVectors;
  99.   Exec(GetEnv('COMSPEC'), '');
  100.   SwapVectors;
  101.  
  102.   SetFont;
  103.   InitGtMouse;
  104.  
  105.   SetMemTop(HeapEnd);
  106.   InitGtMouse;
  107.   InitMemory;
  108.   InitVideo;
  109.   InitEvents;
  110.   InitSysError;
  111.   Redraw;
  112. end;     }
  113.  
  114. procedure ReadFile;
  115. var
  116.   F: Text;
  117.   S: String;
  118. begin
  119.   LineCount := 0;
  120.   Assign(F, FileToRead);
  121.   {$I-}
  122.   Reset(F);
  123.   {$I+}
  124.   if IOResult <> 0 then
  125.   begin
  126.     Writeln('Cannot open ', FileToRead);
  127.     Halt(1);
  128.   end;
  129.   while not Eof(F) and (LineCount < MaxLines) do
  130.   begin
  131.     Readln(F, S);
  132.     Lines[LineCount] := NewStr(S);
  133.     Inc(LineCount);
  134.   end;
  135.   Close(F);
  136. end;
  137. procedure NewImage;
  138. begin
  139.  inc(ImageNoPressed);
  140.  if ImageNoPressed=DragArrow then inc(ImageNoPressed);
  141.  if ImageNoPressed=UserArrow then ImageNoPressed:=NormalArrow;
  142. end;
  143.  
  144. procedure DoneFile;
  145. var
  146.   I: Integer;
  147. begin
  148.   for I := 0 to LineCount - 1 do
  149.     if Lines[I] <> nil then DisposeStr(Lines[i]);
  150. end;
  151.  
  152. { TInterior }
  153. constructor TInterior.Init(var Bounds: TRect; AHScrollBar,
  154.   AVScrollBar: PScrollBar);
  155. begin
  156.   TScroller.Init(Bounds, AHScrollBar, AVScrollBar);
  157.   Options := Options or ofFramed;
  158.   SetLimit(128, LineCount);
  159. end;
  160.  
  161. procedure TInterior.Draw;
  162. var
  163.   Color: Byte;
  164.   I, Y: Integer;
  165.   B: TDrawBuffer;
  166. begin
  167.   Color := GetColor(1);
  168.   for Y := 0 to Size.Y - 1 do
  169.   begin
  170.     MoveChar(B, ' ', Color, Size.X);
  171.     i := Delta.Y + Y;
  172.     if (I < LineCount) and (Lines[I] <> nil) then
  173.       MoveStr(B, Copy(Lines[I]^, Delta.X + 1, Size.X), Color);
  174.     WriteLine(0, Y, Size.X, 1, B);
  175.   end;
  176. end;
  177.  
  178. { TDemoWindow }
  179. constructor TDemoWindow.Init(Bounds: TRect; WinTitle: String; WindowNo: Word);
  180. var
  181.   S: string[3];
  182.   R: TRect;
  183. begin
  184.   Str(WindowNo, S);
  185.   TWindow.Init(Bounds, WinTitle + ' ' + S, wnNoNumber);
  186.   GetExtent(Bounds);
  187.   R.Assign(Bounds.A.X, Bounds.A.Y, Bounds.B.X div 2 + 1, Bounds.B.Y);
  188.   LInterior := MakeInterior(R, True);
  189.   LInterior^.GrowMode := gfGrowHiY;
  190.   Insert(Linterior);
  191.   R.Assign(Bounds.B.X div 2, Bounds.A.Y, Bounds.B.X, Bounds.B.Y);
  192.   RInterior := MakeInterior(R,False);
  193.   RInterior^.GrowMode := gfGrowHiX + gfGrowHiY;
  194.   Insert(RInterior);
  195. end;
  196.  
  197. function TDemoWindow.MakeInterior(Bounds: TRect; Left: Boolean): PInterior;
  198. var
  199.   HScrollBar, VScrollBar: PScrollBar;
  200.   R: TRect;
  201. begin
  202.   R.Assign(Bounds.B.X-1, Bounds.A.Y+1, Bounds.B.X, Bounds.B.Y-1);
  203.   VScrollBar := New(PScrollBar, Init(R));
  204.   VScrollBar^.Options := VScrollBar^.Options or ofPostProcess;
  205.   if Left then VScrollBar^.GrowMode := gfGrowHiY;
  206.   Insert(VScrollBar);
  207.   R.Assign(Bounds.A.X+2, Bounds.B.Y-1, Bounds.B.X-2, Bounds.B.Y);
  208.   HScrollBar := New(PScrollBar, Init(R));
  209.   HScrollBar^.Options := HScrollBar^.Options or ofPostProcess;
  210.   if Left then HScrollBar^.GrowMode := gfGrowHiY + gfGrowLoY;
  211.   Insert(HScrollBar);
  212.   Bounds.Grow(-1,-1);
  213.   MakeInterior := New(PInterior, Init(Bounds, HScrollBar, VScrollBar));
  214. end;
  215.  
  216. procedure TDemoWindow.SizeLimits(var Min, Max: TPoint);
  217. var R: TRect;
  218. begin
  219.   TWindow.SizeLimits(Min, Max);
  220.   Min.X := LInterior^.Size.X + 9;
  221. end;
  222.  
  223. { TMyApp }
  224. procedure TMyApp.HandleEvent(var Event: TEvent);
  225. begin
  226.   Sleeper;
  227.   TApplication.HandleEvent(Event);
  228.   if Event.What = evCommand then
  229.   begin
  230.     case Event.Command of
  231.       cmNewWin: NewWindow;
  232.       cmNewDialog: NewDialog;
  233.       cmChIm: NewImage;
  234.       cmDosshell:dosshell;
  235.     else
  236.       Exit;
  237.     end;
  238.     ClearEvent(Event);
  239.   end;
  240. end;
  241.  
  242. procedure TMyApp.InitMenuBar;
  243. var R: TRect;
  244. begin
  245.   GetExtent(R);
  246.   R.B.Y := R.A.Y + 1;
  247.   MenuBar := New(PMenuBar, Init(R, NewMenu(
  248.     NewSubMenu('~F~ile', hcNoContext, NewMenu(
  249.       NewItem('~O~pen', 'F3', kbF3, cmFileOpen, hcNoContext,
  250.       NewItem('~D~os shell', 'alt F4', kbaltF4, cmdosshell, hcNoContext,
  251.       NewItem('~N~ew', 'F4', kbF4, cmNewWin, hcNoContext,
  252.       NewLine(
  253.       NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, hcNoContext,
  254.       nil)))))),
  255.     NewSubMenu('~W~indow', hcNoContext, NewMenu(
  256.       NewItem('~N~ext', 'F6', kbF6, cmNext, hcNoContext,
  257.       NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcNoContext,
  258.       NewItem('~D~ialog', 'F2', kbF2, cmNewDialog, hcNoContext,
  259.       nil)))),
  260.     nil))
  261.   )));
  262. end;
  263.  
  264. procedure TMyApp.InitStatusLine;
  265. var R: TRect;
  266. begin
  267.   GetExtent(R);
  268.   R.A.Y := R.B.Y - 1;
  269.   StatusLine := New(PStatusLine, Init(R,
  270.     NewStatusDef(0, $FFFF,
  271.       NewStatusKey('', kbF10, cmMenu,
  272.       NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit,
  273.       NewStatusKey('~F4~ New', kbF4, cmNewWin,
  274.       NewStatusKey('~Alt-F3~ Close', kbAltF3, cmClose,
  275.       NewStatusKey('~Alt-H~ cHange image', kbAltH, cmChIm,
  276.       nil))))),
  277.     nil)
  278.   ));
  279. end;
  280.  
  281. procedure TMyApp.NewDialog;
  282. var
  283.   Bruce: PView;
  284.   Dialog: PDemoDialog;
  285.   R: TRect;
  286.   C: Word;
  287. begin
  288.   R.Assign(20, 6, 60, 19);
  289.   Dialog := New(PDemoDialog, Init(R, 'Demo Dialog'));
  290.   with Dialog^ do
  291.   begin
  292.     R.Assign(3, 3, 18, 6);
  293.     Bruce := New(PCheckBoxes, Init(R,
  294.       NewSItem('~H~varti',
  295.       NewSItem('~T~ilset',
  296.       NewSItem('~J~arlsberg',
  297.       nil)))
  298.     ));
  299.     Insert(Bruce);
  300.     R.Assign(2, 2, 10, 3);
  301.     Insert(New(PLabel, Init(R, 'Cheeses', Bruce)));
  302.     R.Assign(22, 3, 34, 6);
  303.     Bruce := New(PRadioButtons, Init(R,
  304.       NewSItem('~S~olid',
  305.       NewSItem('~R~unny',
  306.       NewSItem('~M~elted',
  307.       nil)))
  308.     ));
  309.     Insert(Bruce);
  310.     R.Assign(21, 2, 33, 3);
  311.     Insert(New(PLabel, Init(R, 'Consistency', Bruce)));
  312.     R.Assign(15, 10, 25, 12);
  313.     Insert(New(PButton, Init(R, '~O~k', cmOK, bfDefault)));
  314.     R.Assign(28, 10, 38, 12);
  315.     Insert(New(PButton, Init(R, 'Cancel', cmCancel, bfNormal)));
  316.   end;
  317.   C := DeskTop^.ExecView(Dialog);
  318.   Dispose(Dialog, Done);
  319. end;
  320.  
  321. procedure TMyApp.NewWindow;
  322. var
  323.   Window: PDemoWindow;
  324.   R: TRect;
  325. begin
  326.   Inc(WinCount);
  327.   R.Assign(0, 0, 45, 13);
  328.   R.Move(Random(34), Random(11));
  329.   Window := New(PDemoWindow, Init(R, 'Demo Window', WinCount));
  330.   DeskTop^.Insert(Window);
  331. end;
  332.  
  333. var
  334.   MyApp: TMyApp;
  335.   i : integer;
  336. begin
  337.   InitSleeper(4,10,80,1,80,1); { ReInit Slepper to left down/10 sec }
  338.   ReadFile;
  339.   MyApp.Init;
  340.   MyApp.Run;
  341.   MyApp.Done;
  342.   DoneFile;
  343. end.
  344.