{************************************************}
{                                                }
{   Turbo Pascal 6.0                             }
{   Turbo Vision Demo                            }
{   Copyright (c) 1990 by Borland International  }
{                                                }
{************************************************}

{ Turbo Vision demo program. This program uses many of the Turbo
  Vision standard and demo units, including:

    StdDlg    - Open file browser, change directory tree.
    MsgBox    - Simple dialog to display messages.
    ColorSel  - Color customization.
    Gauges    - Shows system time and available heap on status line.
    Puzzle    - Simple brain puzzle.
    Calendar  - View a month at a time
    AsciiTab  - ASCII table.
    Calc      - Desktop calculator.
    FViewer   - Scroll through text files.
    Mouse     - Mouse options dialog.
    HelpFile  - Context sensitive help.

  And of course this program includes many standard Turbo Vision
  objects and behaviors (menubar, desktop, status line, dialog boxes,
  mouse support, window resize/move/tile/cascade).
}

program TVDemo;

{$X+}

uses
  Dos, Objects, Drivers, Memory, Views, Menus, Dialogs, StdDlg, MsgBox, App,
  Gauges, Puzzle, Calendar, AsciiTab, Calc, FViewer, HelpFile, DemoHelp,
  ColorSel, Mouse;

const
  cmFileOpen        = 1000;
  cmChangeDir       = 1001;
  cmAbout           = 1002;
  cmPuzzle          = 1003;
  cmCalendar        = 1004;
  cmAsciiTab        = 1005;
  cmCalculator      = 1006;
  cmMouse           = 1007;
  cmColors          = 1008;
  cmDosShell        = 1009;
  cmSaveDesktop     = 1010;
  cmRetrieveDesktop = 1011;

type

  { TTVDemo }

  PTVDemo = ^TTVDemo;
  TTVDemo = object(TApplication)
    Clock: PClockView;
    Heap: PHeapView;
    constructor Init;
    procedure FileOpen(WildCard: PathStr);
    procedure GetEvent(var Event: TEvent); virtual;
    function GetPalette: PPalette; virtual;
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure Idle; virtual;
    procedure InitMenuBar; virtual;
    procedure InitStatusLine; virtual;
    procedure LoadDesktop(var S: TStream);
    procedure OutOfMemory; virtual;
    procedure StoreDesktop(var S: TStream);
    procedure ViewFile(FileName: PathStr);
  end;

{ TTVDemo }
constructor TTVDemo.Init;
var
  R: TRect;
  I: Integer;
  FileName: PathStr;
begin
  TApplication.Init;
  RegisterTypes;
  RegisterPuzzle;
  RegisterCalendar;
  RegisterAsciiTab;
  RegisterCalc;
  RegisterFViewer;

  GetExtent(R);
  R.A.X := R.B.X - 9; R.B.Y := R.A.Y + 1;
  Clock := New(PClockView, Init(R));
  Insert(Clock);

  GetExtent(R);
  R.A.X := R.B.X - 9; R.A.Y := R.B.Y - 1;
  Heap := New(PHeapView, Init(R));
  Insert(Heap);

  for I := 1 to ParamCount do
  begin
    FileName := ParamStr(I);
    if FileName[Length(FileName)] = '\' then
      FileName := FileName + '*.*';
    if (Pos('?', FileName) = 0) and (Pos('*', FileName) = 0) then
      ViewFile(FExpand(FileName))
    else FileOpen(FileName);
  end;
end;

procedure TTVDemo.FileOpen(WildCard: PathStr);
var
  D: PFileDialog;
  FileName: PathStr;
begin
  D := New(PFileDialog, Init(WildCard, 'Open a File',
    '~N~ame', fdOpenButton + fdHelpButton, 100));
  D^.HelpCtx := hcFOFileOpenDBox;
  if ValidView(D) <> nil then
  begin
    if Desktop^.ExecView(D) <> cmCancel then
    begin
      D^.GetFileName(FileName);
      ViewFile(FileName);
    end;
    Dispose(D, Done);
  end;
end;

procedure TTVDemo.GetEvent(var Event: TEvent);
var
  W: PWindow;
  HelpFile: PHelpFile;
  HelpStrm: PDosStream;
const
  HelpInUse: Boolean = False;
begin
  TApplication.GetEvent(Event);
  if (Event.What = evCommand) and (Event.Command = cmHelp) and
    not HelpInUse then
  begin
    HelpStrm := New(PDosStream, Init('DEMOHELP.HLP', stOpenRead));
    HelpFile := New(PHelpFile, Init(HelpStrm));
    if HelpStrm^.Status <> stOk then
    begin
      MessageBox('Could not open help file.', nil, mfError + mfOkButton);
      Dispose(HelpFile, Done);
    end
    else
    begin
      HelpInUse := True;
      W := New(PHelpWindow,Init(Helpfile, GetHelpCtx));
      if ValidView(W) <> nil then
      begin
        ExecView(W);
        Dispose(W, Done);
      end;
      HelpInUse := False;
      ClearEvent(Event);
    end;
  end;
end;

function TTVDemo.GetPalette: PPalette;
const
  CNewColor = CColor + CHelpColor;
  CNewBlackWhite = CBlackWhite + CHelpBlackWhite;
  CNewMonochrome = CMonochrome + CHelpMonochrome;
  P: array[apColor..apMonochrome] of string[Length(CNewColor)] =
    (CNewColor, CNewBlackWhite, CNewMonochrome);
begin
  GetPalette := @P[AppPalette];
end;

procedure TTVDemo.HandleEvent(var Event: TEvent);

procedure ChangeDir;
var
  D: PChDirDialog;
begin
  D := New(PChDirDialog, Init(cdNormal + cdHelpButton, 101));
  D^.HelpCtx := hcFCChDirDBox;
  if ValidView(D) <> nil then
  begin
    DeskTop^.ExecView(D);
    Dispose(D, Done);
  end;
end;

procedure Tile;
var
  R: TRect;
begin
  Desktop^.GetExtent(R);
  Desktop^.Tile(R);
end;

procedure Cascade;
var
  R: TRect;
begin
  Desktop^.GetExtent(R);
  Desktop^.Cascade(R);
end;

procedure Puzzle;
var
  P: PPuzzleWindow;
begin
  P := New(PPuzzleWindow, Init);
  P^.HelpCtx := hcPuzzle;
  Desktop^.Insert(ValidView(P));
end;

procedure Calendar;
var
  P: PCalendarWindow;
begin
  P := New(PCalendarWindow, Init);
  P^.HelpCtx := hcCalendar;
  Desktop^.Insert(ValidView(P));
end;

procedure About;
var
  D: PDialog;
  Control: PView;
  R: TRect;
begin
  R.Assign(0, 0, 40, 11);
  D := New(PDialog, Init(R, 'About'));
  with D^ do
  begin
    Options := Options or ofCentered;

    R.Grow(-1, -1);
    Dec(R.B.Y, 3);
    Insert(New(PStaticText, Init(R,
      #13 +
      ^C'Turbo Vision Demo'#13 +
      #13 +
      ^C'Copyright (c) 1990'#13 +
      #13 +
      ^C'Borland International')));

    R.Assign(15, 8, 25, 10);
    Insert(New(PButton, Init(R, 'O~K', cmOk, bfDefault)));
  end;
  if ValidView(D) <> nil then
  begin
    Desktop^.ExecView(D);
    Dispose(D, Done);
  end;
end;

procedure AsciiTab;
var
  P: PAsciiChart;
begin
  P := New(PAsciiChart, Init);
  P^.HelpCtx := hcAsciiTable;
  Desktop^.Insert(ValidView(P));
end;

procedure Calculator;
var
  P: PCalculator;
begin
  P := New(PCalculator, Init);
  P^.HelpCtx := hcCalculator;
  if ValidView(P) <> nil then
    Desktop^.Insert(P);
end;

procedure Colors;
var
  D: PColorDialog;
begin
  D := New(PColorDialog, Init('',
    ColorGroup('Desktop',
      ColorItem('Color',             32, nil),
    ColorGroup('Menus',
      ColorItem('Normal',            2,
      ColorItem('Disabled',          3,
      ColorItem('Shortcut',          4,
      ColorItem('Selected',          5,
      ColorItem('Selected disabled', 6,
      ColorItem('Shortcut selected', 7, nil)))))),
    ColorGroup('Dialogs/Calc',
      ColorItem('Frame/background',  33,
      ColorItem('Frame icons',       34,
      ColorItem('Scroll bar page',   35,
      ColorItem('Scroll bar icons',  36,
      ColorItem('Static text',       37,

      ColorItem('Label normal',      38,
      ColorItem('Label selected',    39,
      ColorItem('Label shortcut',    40,

      ColorItem('Button normal',     41,
      ColorItem('Button default',    42,
      ColorItem('Button selected',   43,
      ColorItem('Button disabled',   44,
      ColorItem('Button shortcut',   45,
      ColorItem('Button shadow',     46,

      ColorItem('Cluster normal',    47,
      ColorItem('Cluster selected',  48,
      ColorItem('Cluster shortcut',  49,

      ColorItem('Input normal',      50,
      ColorItem('Input selected',    51,
      ColorItem('Input arrow',       52,

      ColorItem('History button',    53,
      ColorItem('History sides',     54,
      ColorItem('History bar page',  55,
      ColorItem('History bar icons', 56,

      ColorItem('List normal',       57,
      ColorItem('List focused',      58,
      ColorItem('List selected',     59,
      ColorItem('List divider',      60,

      ColorItem('Information pane',  61, nil))))))))))))))))))))))))))))),
    ColorGroup('Viewer',
      ColorItem('Frame passive',      8,
      ColorItem('Frame active',       9,
      ColorItem('Frame icons',       10,
      ColorItem('Scroll bar page',   11,
      ColorItem('Scroll bar icons',  12,
      ColorItem('Text',              13, nil)))))),
    ColorGroup('Puzzle',
      ColorItem('Frame passive',      8,
      ColorItem('Frame active',       9,
      ColorItem('Frame icons',       10,
      ColorItem('Scroll bar page',   11,
      ColorItem('Scroll bar icons',  12,
      ColorItem('Normal text',       13,
      ColorItem('Highlighted text',  14, nil))))))),
    ColorGroup('Calendar',
      ColorItem('Frame passive',     16,
      ColorItem('Frame active',      17,
      ColorItem('Frame icons',       18,
      ColorItem('Scroll bar page',   19,
      ColorItem('Scroll bar icons',  20,
      ColorItem('Normal text',       21,
      ColorItem('Current day',       22, nil))))))),
    ColorGroup('Ascii table',
      ColorItem('Frame passive',     24,
      ColorItem('Frame active',      25,
      ColorItem('Frame icons',       26,
      ColorItem('Scroll bar page',   27,
      ColorItem('Scroll bar icons',  28,
      ColorItem('Text',              29, nil)))))), nil)))))))));

  D^.HelpCtx := hcOCColorsDBox;
  if ValidView(D) <> nil then
  begin
    D^.SetData(Application^.GetPalette^);
    if Desktop^.ExecView(D) <> cmCancel then
    begin
      Application^.GetPalette^ := D^.Pal;
      DoneMemory;  { Dispose all group buffers }
      ReDraw;      { Redraw application with new palette }
    end;
    Dispose(D, Done);
  end;
end;

procedure Mouse;
var
  D: PDialog;
begin
  D := New(PMouseDialog, Init);
  D^.HelpCtx := hcOMMouseDBox;
  if ValidView(D) <> nil then
  begin
    D^.SetData(MouseReverse);
    if Desktop^.ExecView(D) <> cmCancel then
      D^.GetData(MouseReverse);
  end;
end;

procedure DosShell;
begin
  DoneSysError;
  DoneEvents;
  DoneVideo;
  DoneMemory;
  SetMemTop(HeapPtr);
  PrintStr('Type EXIT to return...');
  SwapVectors;
  Exec(GetEnv('COMSPEC'), '');
  SwapVectors;
  SetMemTop(HeapEnd);
  InitMemory;
  InitVideo;
  InitEvents;
  InitSysError;
  Redraw;
end;

procedure RetrieveDesktop;
var
  S: PStream;
begin
  S := New(PBufStream, Init('TVDEMO.DSK', stOpenRead, 1024));
  if LowMemory then OutOfMemory
  else if S^.Status <> stOk then
    MessageBox('Could not open desktop file', nil, mfOkButton + mfError)
  else
  begin
    LoadDesktop(S^);
    if S^.Status <> stOk then
      MessageBox('Could not read desktop file', nil, mfOkButton + mfError);
  end;
  Dispose(S, Done);
end;

procedure SaveDesktop;
var
  S: PStream;
  F: File;
begin
  S := New(PBufStream, Init('TVDEMO.DSK', stCreate, 1024));
  if not LowMemory and (S^.Status = stOk) then
  begin
    StoreDesktop(S^);
    if S^.Status <> stOk then
    begin
      MessageBox('Could not create TVDEMO.DSK.', nil, mfOkButton + mfError);
      {$I-}
      Dispose(S, Done);
      Assign(F, 'TVDEMO.DSK');
      Erase(F);
      Exit;
    end;
  end;
  Dispose(S, Done);
end;


begin
  TApplication.HandleEvent(Event);
  case Event.What of
    evCommand:
      begin
        case Event.Command of
          cmFileOpen: FileOpen('*.*');
          cmChangeDir: ChangeDir;
          cmCascade: Cascade;
          cmTile: Tile;
          cmAbout: About;
          cmPuzzle: Puzzle;
          cmCalendar: Calendar;
          cmAsciiTab: AsciiTab;
          cmCalculator: Calculator;
          cmColors: Colors;
          cmMouse: Mouse;
          cmDosShell: DosShell;
          cmSaveDesktop: SaveDesktop;
          cmRetrieveDesktop: RetrieveDesktop;
        else
          Exit;
        end;
        ClearEvent(Event);
      end;
  end;
end;

procedure TTVDemo.Idle;

function IsTileable(P: PView): Boolean; far;
begin
  IsTileable := P^.Options and ofTileable <> 0;
end;

begin
  TApplication.Idle;
  Clock^.Update;
  Heap^.Update;
  if Desktop^.FirstThat(@IsTileable) <> nil then
    EnableCommands([cmTile, cmCascade])
  else
    DisableCommands([cmTile, cmCascade]);
end;
 
procedure TTVDemo.InitMenuBar;
var
  R: TRect;
begin
  GetExtent(R);
  R.B.Y := R.A.Y+1;
  MenuBar := New(PMenuBar, Init(R, NewMenu(
    NewSubMenu('~'#240'~', hcSystem, NewMenu(
      NewItem('~A~bout', '', kbNoKey, cmAbout, hcSAbout,
      NewLine(
      NewItem('~P~uzzle', '', kbNoKey, cmPuzzle, hcSPuzzle,
      NewItem('Ca~l~endar', '', kbNoKey, cmCalendar, hcSCalendar,
      NewItem('Ascii ~t~able', '', kbNoKey, cmAsciiTab, hcSAsciiTable,
      NewItem('~C~alculator', '', kbNoKey, cmCalculator, hcCalculator, nil))))))),
    NewSubMenu('~F~ile', hcFile, NewMenu(
      NewItem('~O~pen...', 'F3', kbF3, cmFileOpen, hcFOpen,
      NewItem('~C~hange dir...', '', kbNoKey, cmChangeDir, hcFChangeDir,
      NewLine(
      NewItem('~D~OS shell', '', kbNoKey, cmDosShell, hcFDosShell,
      NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, hcFExit, nil)))))),
    NewSubMenu('~W~indows', hcWindows, NewMenu(
      NewItem('~R~esize/move','Ctrl-F5', kbCtrlF5, cmResize, hcWSizeMove,
      NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcWZoom,
      NewItem('~N~ext', 'F6', kbF6, cmNext, hcWNext,
      NewItem('~C~lose', 'Alt-F3', kbAltF3, cmClose, hcWClose,
      NewItem('~T~ile', '', kbNoKey, cmTile, hcWTile,
      NewItem('C~a~scade', '', kbNoKey, cmCascade, hcWCascade, nil))))))),
    NewSubMenu('~O~ptions', hcOptions, NewMenu(
      NewItem('~M~ouse...', '', kbNoKey, cmMouse, hcOMouse,
      NewItem('~C~olors...', '', kbNoKey, cmColors, hcOColors,
      NewLine(
      NewItem('~S~ave desktop', '', kbNoKey, cmSaveDesktop, hcOSaveDesktop,
      NewItem('~R~etrieve desktop', '', kbNoKey, cmRetrieveDesktop, hcORestoreDesktop, nil)))))), nil)))))));
end;

procedure TTVDemo.InitStatusLine;
var
  R: TRect;
begin
  GetExtent(R);
  R.A.Y := R.B.Y - 1;
  StatusLine := New(PStatusLine, Init(R,
    NewStatusDef(0, $FFFF,
      NewStatusKey('~F1~ Help', kbF1, cmHelp,
      NewStatusKey('~F3~ Open', kbF3, cmFileOpen,
      NewStatusKey('~Alt-F3~ Close', kbAltF3, cmClose,
      NewStatusKey('~F5~ Zoom', kbF5, cmZoom,
      NewStatusKey('', kbF10, cmMenu,
      NewStatusKey('', kbCtrlF5, cmResize, nil)))))), nil)));
end;

procedure TTVDemo.OutOfMemory;
begin
  MessageBox('Not enough memory available to complete operation.',
    nil, mfError + mfOkButton);
end;

{ Since the safety pool is only large enough to guarantee that allocating
  a window will not run out of memory, loading the entire desktop without
  checking LowMemory could cause a heap error.  This means that each
  window should be read individually, instead of using Desktop's Load.
}

procedure TTVDemo.LoadDesktop(var S: TStream);
var
  P: PView;

procedure CloseView(P: PView); far;
begin
  Message(P, evCommand, cmClose, nil);
end;

begin
  if Desktop^.Valid(cmClose) then
  begin
    Desktop^.ForEach(@CloseView); { Clear the desktop }
    repeat
      P := PView(S.Get);
      Desktop^.InsertBefore(ValidView(P), Desktop^.Last);
    until P = nil;
  end;
end;

procedure TTVDemo.StoreDesktop(var S: TStream);

procedure WriteView(P: PView); far;
begin
  if P <> Desktop^.Last then S.Put(P);
end;

begin
  Desktop^.ForEach(@WriteView);
  S.Put(nil);
end;

procedure TTVDemo.ViewFile(FileName: PathStr);
var
  W: PWindow;
begin
  W := New(PFileWindow,Init(FileName));
  W^.HelpCtx := hcViewer;
  if ValidView(W) <> nil then
    Desktop^.Insert(W);
end;

var
  Demo: TTVDemo;

begin
  Demo.Init;
  Demo.Run;
  Demo.Done;
end.
