home *** CD-ROM | disk | FTP | other *** search
/ The Devil's Doorknob BBS Capture (1996-2003) / devilsdoorknobbbscapture1996-2003.iso / Dloads / OTHERUTI / TPASCAL3.ZIP / TVDEMOS.ZIP / TVDEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1991-06-11  |  16KB  |  615 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal 6.0                             }
  4. {   Turbo Vision Demo                            }
  5. {   Copyright (c) 1990 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8.  
  9. program TVDemo;
  10.  
  11. {$X+,S-}
  12. {$M 16384,8192,655360}
  13.  
  14. { Turbo Vision demo program. This program uses many of the Turbo
  15.   Vision standard and demo units, including:
  16.  
  17.     StdDlg    - Open file browser, change directory tree.
  18.     MsgBox    - Simple dialog to display messages.
  19.     ColorSel  - Color customization.
  20.     Gagdets   - Shows system time and available heap space.
  21.     AsciiTab  - ASCII table.
  22.     Calendar  - View a month at a time
  23.     Calc      - Desktop calculator.
  24.     FViewer   - Scroll through text files.
  25.     HelpFile  - Context sensitive help.
  26.     MouseDlg  - Mouse options dialog.
  27.     Puzzle    - Simple brain puzzle.
  28.  
  29.   And of course this program includes many standard Turbo Vision
  30.   objects and behaviors (menubar, desktop, status line, dialog boxes,
  31.   mouse support, window resize/move/tile/cascade).
  32. }
  33.  
  34. uses
  35.   Dos, Objects, Drivers, Memory, Views, Menus, Dialogs, StdDlg, MsgBox, App,
  36.   DemoCmds, Gadgets, Puzzle, Calendar, AsciiTab, Calc, FViewer, HelpFile,
  37.   DemoHelp, ColorSel, MouseDlg;
  38.  
  39. type
  40.  
  41.   { TTVDemo }
  42.  
  43.   PTVDemo = ^TTVDemo;
  44.   TTVDemo = object(TApplication)
  45.     Clock: PClockView;
  46.     Heap: PHeapView;
  47.     constructor Init;
  48.     procedure FileOpen(WildCard: PathStr);
  49.     procedure GetEvent(var Event: TEvent); virtual;
  50.     function GetPalette: PPalette; virtual;
  51.     procedure HandleEvent(var Event: TEvent); virtual;
  52.     procedure Idle; virtual;
  53.     procedure InitMenuBar; virtual;
  54.     procedure InitStatusLine; virtual;
  55.     procedure LoadDesktop(var S: TStream);
  56.     procedure OutOfMemory; virtual;
  57.     procedure StoreDesktop(var S: TStream);
  58.     procedure ViewFile(FileName: PathStr);
  59.   end;
  60.  
  61. { CalcHelpName }
  62.  
  63. function CalcHelpName: PathStr;
  64. var
  65.   EXEName: PathStr;
  66.   Dir: DirStr;
  67.   Name: NameStr;
  68.   Ext: ExtStr;
  69. begin
  70.   if Lo(DosVersion) >= 3 then EXEName := ParamStr(0)
  71.   else EXEName := FSearch('TVDEMO.EXE', GetEnv('PATH'));
  72.   FSplit(EXEName, Dir, Name, Ext);
  73.   if Dir[Length(Dir)] = '\' then Dec(Dir[0]);
  74.   CalcHelpName := FSearch('DEMOHELP.HLP', Dir);
  75. end;
  76.  
  77.  
  78. { TTVDemo }
  79. constructor TTVDemo.Init;
  80. var
  81.   R: TRect;
  82.   I: Integer;
  83.   FileName: PathStr;
  84. begin
  85.   TApplication.Init;
  86.   RegisterObjects;
  87.   RegisterViews;
  88.   RegisterMenus;
  89.   RegisterDialogs;
  90.   RegisterApp;
  91.   RegisterHelpFile;
  92.   RegisterPuzzle;
  93.   RegisterCalendar;
  94.   RegisterAsciiTab;
  95.   RegisterCalc;
  96.   RegisterFViewer;
  97.  
  98.   GetExtent(R);
  99.   R.A.X := R.B.X - 9; R.B.Y := R.A.Y + 1;
  100.   Clock := New(PClockView, Init(R));
  101.   Insert(Clock);
  102.  
  103.   GetExtent(R);
  104.   Dec(R.B.X);
  105.   R.A.X := R.B.X - 9; R.A.Y := R.B.Y - 1;
  106.   Heap := New(PHeapView, Init(R));
  107.   Insert(Heap);
  108.  
  109.   for I := 1 to ParamCount do
  110.   begin
  111.     FileName := ParamStr(I);
  112.     if FileName[Length(FileName)] = '\' then
  113.       FileName := FileName + '*.*';
  114.     if (Pos('?', FileName) = 0) and (Pos('*', FileName) = 0) then
  115.       ViewFile(FExpand(FileName))
  116.     else FileOpen(FileName);
  117.   end;
  118. end;
  119.  
  120. procedure TTVDemo.FileOpen(WildCard: PathStr);
  121. var
  122.   D: PFileDialog;
  123.   FileName: PathStr;
  124. begin
  125.   D := New(PFileDialog, Init(WildCard, 'Open a File',
  126.     '~N~ame', fdOpenButton + fdHelpButton, 100));
  127.   D^.HelpCtx := hcFOFileOpenDBox;
  128.   if ValidView(D) <> nil then
  129.   begin
  130.     if Desktop^.ExecView(D) <> cmCancel then
  131.     begin
  132.       D^.GetFileName(FileName);
  133.       ViewFile(FileName);
  134.     end;
  135.     Dispose(D, Done);
  136.   end;
  137. end;
  138.  
  139. procedure TTVDemo.GetEvent(var Event: TEvent);
  140. var
  141.   W: PWindow;
  142.   HFile: PHelpFile;
  143.   HelpStrm: PDosStream;
  144. const
  145.   HelpInUse: Boolean = False;
  146. begin
  147.   TApplication.GetEvent(Event);
  148.   case Event.What of
  149.     evCommand:
  150.       if (Event.Command = cmHelp) and not HelpInUse then
  151.       begin
  152.         HelpInUse := True;
  153.         HelpStrm := New(PDosStream, Init(CalcHelpName, stOpenRead));
  154.         HFile := New(PHelpFile, Init(HelpStrm));
  155.         if HelpStrm^.Status <> stOk then
  156.         begin
  157.           MessageBox('Could not open help file.', nil, mfError + mfOkButton);
  158.           Dispose(HFile, Done);
  159.         end
  160.         else
  161.         begin
  162.           W := New(PHelpWindow,Init(HFile, GetHelpCtx));
  163.           if ValidView(W) <> nil then
  164.           begin
  165.             ExecView(W);
  166.             Dispose(W, Done);
  167.           end;
  168.           ClearEvent(Event);
  169.         end;
  170.         HelpInUse := False;
  171.       end;
  172.     evMouseDown:
  173.       if Event.Buttons <> 1 then Event.What := evNothing;
  174.   end;
  175. end;
  176.  
  177. function TTVDemo.GetPalette: PPalette;
  178. const
  179.   CNewColor = CColor + CHelpColor;
  180.   CNewBlackWhite = CBlackWhite + CHelpBlackWhite;
  181.   CNewMonochrome = CMonochrome + CHelpMonochrome;
  182.   P: array[apColor..apMonochrome] of string[Length(CNewColor)] =
  183.     (CNewColor, CNewBlackWhite, CNewMonochrome);
  184. begin
  185.   GetPalette := @P[AppPalette];
  186. end;
  187.  
  188. procedure TTVDemo.HandleEvent(var Event: TEvent);
  189.  
  190. procedure ChangeDir;
  191. var
  192.   D: PChDirDialog;
  193. begin
  194.   D := New(PChDirDialog, Init(cdNormal + cdHelpButton, 101));
  195.   D^.HelpCtx := hcFCChDirDBox;
  196.   if ValidView(D) <> nil then
  197.   begin
  198.     DeskTop^.ExecView(D);
  199.     Dispose(D, Done);
  200.   end;
  201. end;
  202.  
  203. procedure Tile;
  204. var
  205.   R: TRect;
  206. begin
  207.   Desktop^.GetExtent(R);
  208.   Desktop^.Tile(R);
  209. end;
  210.  
  211. procedure Cascade;
  212. var
  213.   R: TRect;
  214. begin
  215.   Desktop^.GetExtent(R);
  216.   Desktop^.Cascade(R);
  217. end;
  218.  
  219. procedure Puzzle;
  220. var
  221.   P: PPuzzleWindow;
  222. begin
  223.   P := New(PPuzzleWindow, Init);
  224.   P^.HelpCtx := hcPuzzle;
  225.   Desktop^.Insert(ValidView(P));
  226. end;
  227.  
  228. procedure Calendar;
  229. var
  230.   P: PCalendarWindow;
  231. begin
  232.   P := New(PCalendarWindow, Init);
  233.   P^.HelpCtx := hcCalendar;
  234.   Desktop^.Insert(ValidView(P));
  235. end;
  236.  
  237. procedure About;
  238. var
  239.   D: PDialog;
  240.   Control: PView;
  241.   R: TRect;
  242. begin
  243.   R.Assign(0, 0, 40, 11);
  244.   D := New(PDialog, Init(R, 'About'));
  245.   with D^ do
  246.   begin
  247.     Options := Options or ofCentered;
  248.  
  249.     R.Grow(-1, -1);
  250.     Dec(R.B.Y, 3);
  251.     Insert(New(PStaticText, Init(R,
  252.       #13 +
  253.       ^C'Turbo Vision Demo'#13 +
  254.       #13 +
  255.       ^C'Copyright (c) 1990'#13 +
  256.       #13 +
  257.       ^C'Borland International')));
  258.  
  259.     R.Assign(15, 8, 25, 10);
  260.     Insert(New(PButton, Init(R, 'O~K', cmOk, bfDefault)));
  261.   end;
  262.   if ValidView(D) <> nil then
  263.   begin
  264.     Desktop^.ExecView(D);
  265.     Dispose(D, Done);
  266.   end;
  267. end;
  268.  
  269. procedure AsciiTab;
  270. var
  271.   P: PAsciiChart;
  272. begin
  273.   P := New(PAsciiChart, Init);
  274.   P^.HelpCtx := hcAsciiTable;
  275.   Desktop^.Insert(ValidView(P));
  276. end;
  277.  
  278. procedure Calculator;
  279. var
  280.   P: PCalculator;
  281. begin
  282.   P := New(PCalculator, Init);
  283.   P^.HelpCtx := hcCalculator;
  284.   if ValidView(P) <> nil then
  285.     Desktop^.Insert(P);
  286. end;
  287.  
  288. procedure Colors;
  289. var
  290.   D: PColorDialog;
  291. begin
  292.   D := New(PColorDialog, Init('',
  293.     ColorGroup('Desktop',
  294.       ColorItem('Color',             32, nil),
  295.     ColorGroup('Menus',
  296.       ColorItem('Normal',            2,
  297.       ColorItem('Disabled',          3,
  298.       ColorItem('Shortcut',          4,
  299.       ColorItem('Selected',          5,
  300.       ColorItem('Selected disabled', 6,
  301.       ColorItem('Shortcut selected', 7, nil)))))),
  302.     ColorGroup('Dialogs/Calc',
  303.       ColorItem('Frame/background',  33,
  304.       ColorItem('Frame icons',       34,
  305.       ColorItem('Scroll bar page',   35,
  306.       ColorItem('Scroll bar icons',  36,
  307.       ColorItem('Static text',       37,
  308.  
  309.       ColorItem('Label normal',      38,
  310.       ColorItem('Label selected',    39,
  311.       ColorItem('Label shortcut',    40,
  312.  
  313.       ColorItem('Button normal',     41,
  314.       ColorItem('Button default',    42,
  315.       ColorItem('Button selected',   43,
  316.       ColorItem('Button disabled',   44,
  317.       ColorItem('Button shortcut',   45,
  318.       ColorItem('Button shadow',     46,
  319.  
  320.       ColorItem('Cluster normal',    47,
  321.       ColorItem('Cluster selected',  48,
  322.       ColorItem('Cluster shortcut',  49,
  323.  
  324.       ColorItem('Input normal',      50,
  325.       ColorItem('Input selected',    51,
  326.       ColorItem('Input arrow',       52,
  327.  
  328.       ColorItem('History button',    53,
  329.       ColorItem('History sides',     54,
  330.       ColorItem('History bar page',  55,
  331.       ColorItem('History bar icons', 56,
  332.  
  333.       ColorItem('List normal',       57,
  334.       ColorItem('List focused',      58,
  335.       ColorItem('List selected',     59,
  336.       ColorItem('List divider',      60,
  337.  
  338.       ColorItem('Information pane',  61, nil))))))))))))))))))))))))))))),
  339.     ColorGroup('Viewer',
  340.       ColorItem('Frame passive',      8,
  341.       ColorItem('Frame active',       9,
  342.       ColorItem('Frame icons',       10,
  343.       ColorItem('Scroll bar page',   11,
  344.       ColorItem('Scroll bar icons',  12,
  345.       ColorItem('Text',              13, nil)))))),
  346.     ColorGroup('Puzzle',
  347.       ColorItem('Frame passive',      8,
  348.       ColorItem('Frame active',       9,
  349.       ColorItem('Frame icons',       10,
  350.       ColorItem('Scroll bar page',   11,
  351.       ColorItem('Scroll bar icons',  12,
  352.       ColorItem('Normal text',       13,
  353.       ColorItem('Highlighted text',  14, nil))))))),
  354.     ColorGroup('Calendar',
  355.       ColorItem('Frame passive',     16,
  356.       ColorItem('Frame active',      17,
  357.       ColorItem('Frame icons',       18,
  358.       ColorItem('Scroll bar page',   19,
  359.       ColorItem('Scroll bar icons',  20,
  360.       ColorItem('Normal text',       21,
  361.       ColorItem('Current day',       22, nil))))))),
  362.     ColorGroup('Ascii table',
  363.       ColorItem('Frame passive',     24,
  364.       ColorItem('Frame active',      25,
  365.       ColorItem('Frame icons',       26,
  366.       ColorItem('Scroll bar page',   27,
  367.       ColorItem('Scroll bar icons',  28,
  368.       ColorItem('Text',              29, nil)))))), nil)))))))));
  369.  
  370.   D^.HelpCtx := hcOCColorsDBox;
  371.   if ValidView(D) <> nil then
  372.   begin
  373.     D^.SetData(Application^.GetPalette^);
  374.     if Desktop^.ExecView(D) <> cmCancel then
  375.     begin
  376.       Application^.GetPalette^ := D^.Pal;
  377.       DoneMemory;  { Dispose all group buffers }
  378.       ReDraw;      { Redraw application with new palette }
  379.     end;
  380.     Dispose(D, Done);
  381.   end;
  382. end;
  383.  
  384. procedure Mouse;
  385. var
  386.   D: PDialog;
  387. begin
  388.   D := New(PMouseDialog, Init);
  389.   D^.HelpCtx := hcOMMouseDBox;
  390.   if ValidView(D) <> nil then
  391.   begin
  392.     D^.SetData(MouseReverse);
  393.     if Desktop^.ExecView(D) <> cmCancel then
  394.       D^.GetData(MouseReverse);
  395.   end;
  396. end;
  397.  
  398. procedure DosShell;
  399. begin
  400.   DoneSysError;
  401.   DoneEvents;
  402.   DoneVideo;
  403.   DoneMemory;
  404.   SetMemTop(HeapPtr);
  405.   PrintStr('Type EXIT to return...');
  406.   SwapVectors;
  407.   Exec(GetEnv('COMSPEC'), '');
  408.   SwapVectors;
  409.   SetMemTop(HeapEnd);
  410.   InitMemory;
  411.   InitVideo;
  412.   InitEvents;
  413.   InitSysError;
  414.   Redraw;
  415. end;
  416.  
  417. procedure RetrieveDesktop;
  418. var
  419.   S: PStream;
  420. begin
  421.   S := New(PBufStream, Init('TVDEMO.DSK', stOpenRead, 1024));
  422.   if LowMemory then OutOfMemory
  423.   else if S^.Status <> stOk then
  424.     MessageBox('Could not open desktop file', nil, mfOkButton + mfError)
  425.   else
  426.   begin
  427.     LoadDesktop(S^);
  428.     if S^.Status <> stOk then
  429.       MessageBox('Error reading desktop file', nil, mfOkButton + mfError);
  430.   end;
  431.   Dispose(S, Done);
  432. end;
  433.  
  434. procedure SaveDesktop;
  435. var
  436.   S: PStream;
  437.   F: File;
  438. begin
  439.   S := New(PBufStream, Init('TVDEMO.DSK', stCreate, 1024));
  440.   if not LowMemory and (S^.Status = stOk) then
  441.   begin
  442.     StoreDesktop(S^);
  443.     if S^.Status <> stOk then
  444.     begin
  445.       MessageBox('Could not create TVDEMO.DSK.', nil, mfOkButton + mfError);
  446.       {$I-}
  447.       Dispose(S, Done);
  448.       Assign(F, 'TVDEMO.DSK');
  449.       Erase(F);
  450.       Exit;
  451.     end;
  452.   end;
  453.   Dispose(S, Done);
  454. end;
  455.  
  456.  
  457. begin
  458.   TApplication.HandleEvent(Event);
  459.   case Event.What of
  460.     evCommand:
  461.       begin
  462.         case Event.Command of
  463.           cmFOpen: FileOpen('*.*');
  464.           cmChDir: ChangeDir;
  465.           cmCascade: Cascade;
  466.           cmTile: Tile;
  467.           cmAbout: About;
  468.           cmPuzzle: Puzzle;
  469.           cmCalendar: Calendar;
  470.           cmAsciiTab: AsciiTab;
  471.           cmCalculator: Calculator;
  472.           cmColors: Colors;
  473.           cmMouse: Mouse;
  474.           cmDosShell: DosShell;
  475.           cmSaveDesktop: SaveDesktop;
  476.           cmRetrieveDesktop: RetrieveDesktop;
  477.         else
  478.           Exit;
  479.         end;
  480.         ClearEvent(Event);
  481.       end;
  482.   end;
  483. end;
  484.  
  485. procedure TTVDemo.Idle;
  486.  
  487. function IsTileable(P: PView): Boolean; far;
  488. begin
  489.   IsTileable := P^.Options and ofTileable <> 0;
  490. end;
  491.  
  492. begin
  493.   TApplication.Idle;
  494.   Clock^.Update;
  495.   Heap^.Update;
  496.   if Desktop^.FirstThat(@IsTileable) <> nil then
  497.     EnableCommands([cmTile, cmCascade])
  498.   else
  499.     DisableCommands([cmTile, cmCascade]);
  500. end;
  501.  
  502. procedure TTVDemo.InitMenuBar;
  503. var
  504.   R: TRect;
  505. begin
  506.   GetExtent(R);
  507.   R.B.Y := R.A.Y+1;
  508.   MenuBar := New(PMenuBar, Init(R, NewMenu(
  509.     NewSubMenu('~'#240'~', hcSystem, NewMenu(
  510.       NewItem('~A~bout', '', kbNoKey, cmAbout, hcSAbout,
  511.       NewLine(
  512.       NewItem('~P~uzzle', '', kbNoKey, cmPuzzle, hcSPuzzle,
  513.       NewItem('Ca~l~endar', '', kbNoKey, cmCalendar, hcSCalendar,
  514.       NewItem('Ascii ~t~able', '', kbNoKey, cmAsciiTab, hcSAsciiTable,
  515.       NewItem('~C~alculator', '', kbNoKey, cmCalculator, hcCalculator, nil))))))),
  516.     NewSubMenu('~F~ile', hcFile, NewMenu(
  517.       NewItem('~O~pen...', 'F3', kbF3, cmFOpen, hcFOpen,
  518.       NewItem('~C~hange dir...', '', kbNoKey, cmChDir, hcFChangeDir,
  519.       NewLine(
  520.       NewItem('~D~OS shell', '', kbNoKey, cmDosShell, hcFDosShell,
  521.       NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, hcFExit, nil)))))),
  522.     NewSubMenu('~W~indows', hcWindows, NewMenu(
  523.       NewItem('~R~esize/move','Ctrl-F5', kbCtrlF5, cmResize, hcWSizeMove,
  524.       NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcWZoom,
  525.       NewItem('~N~ext', 'F6', kbF6, cmNext, hcWNext,
  526.       NewItem('~C~lose', 'Alt-F3', kbAltF3, cmClose, hcWClose,
  527.       NewItem('~T~ile', '', kbNoKey, cmTile, hcWTile,
  528.       NewItem('C~a~scade', '', kbNoKey, cmCascade, hcWCascade, nil))))))),
  529.     NewSubMenu('~O~ptions', hcOptions, NewMenu(
  530.       NewItem('~M~ouse...', '', kbNoKey, cmMouse, hcOMouse,
  531.       NewItem('~C~olors...', '', kbNoKey, cmColors, hcOColors,
  532.       NewLine(
  533.       NewItem('~S~ave desktop', '', kbNoKey, cmSaveDesktop, hcOSaveDesktop,
  534.       NewItem('~R~etrieve desktop', '', kbNoKey, cmRetrieveDesktop, hcORestoreDesktop, nil)))))), nil)))))));
  535. end;
  536.  
  537. procedure TTVDemo.InitStatusLine;
  538. var
  539.   R: TRect;
  540. begin
  541.   GetExtent(R);
  542.   R.A.Y := R.B.Y - 1;
  543.   StatusLine := New(PStatusLine, Init(R,
  544.     NewStatusDef(0, $FFFF,
  545.       NewStatusKey('~F1~ Help', kbF1, cmHelp,
  546.       NewStatusKey('~F3~ Open', kbF3, cmFOpen,
  547.       NewStatusKey('~Alt-F3~ Close', kbAltF3, cmClose,
  548.       NewStatusKey('~F5~ Zoom', kbF5, cmZoom,
  549.       NewStatusKey('', kbF10, cmMenu,
  550.       NewStatusKey('', kbCtrlF5, cmResize, nil)))))), nil)));
  551. end;
  552.  
  553. procedure TTVDemo.OutOfMemory;
  554. begin
  555.   MessageBox('Not enough memory available to complete operation.',
  556.     nil, mfError + mfOkButton);
  557. end;
  558.  
  559. { Since the safety pool is only large enough to guarantee that allocating
  560.   a window will not run out of memory, loading the entire desktop without
  561.   checking LowMemory could cause a heap error.  This means that each
  562.   window should be read individually, instead of using Desktop's Load.
  563. }
  564.  
  565. procedure TTVDemo.LoadDesktop(var S: TStream);
  566. var
  567.   P: PView;
  568.  
  569. procedure CloseView(P: PView); far;
  570. begin
  571.   Message(P, evCommand, cmClose, nil);
  572. end;
  573.  
  574. begin
  575.   if Desktop^.Valid(cmClose) then
  576.   begin
  577.     Desktop^.ForEach(@CloseView); { Clear the desktop }
  578.     repeat
  579.       P := PView(S.Get);
  580.       Desktop^.InsertBefore(ValidView(P), Desktop^.Last);
  581.     until P = nil;
  582.   end;
  583. end;
  584.  
  585. procedure TTVDemo.StoreDesktop(var S: TStream);
  586.  
  587. procedure WriteView(P: PView); far;
  588. begin
  589.   if P <> Desktop^.Last then S.Put(P);
  590. end;
  591.  
  592. begin
  593.   Desktop^.ForEach(@WriteView);
  594.   S.Put(nil);
  595. end;
  596.  
  597. procedure TTVDemo.ViewFile(FileName: PathStr);
  598. var
  599.   W: PWindow;
  600. begin
  601.   W := New(PFileWindow,Init(FileName));
  602.   W^.HelpCtx := hcViewer;
  603.   if ValidView(W) <> nil then
  604.     Desktop^.Insert(W);
  605. end;
  606.  
  607. var
  608.   Demo: TTVDemo;
  609.  
  610. begin
  611.   Demo.Init;
  612.   Demo.Run;
  613.   Demo.Done;
  614. end.
  615.