DP Tool Club 21/CD_ASCQ_21_040595.iso/dos/prg/pas/tvgr70/tinydemo.pas

Pascal/Delphi Source File | 1994-09-23 | 6KB | 227 lines

{***************************************}
{                                       }
{     TVGraphic Library TINYDEMO.PAS    }
{        RICHARD P. ANDRESEN            }
{                                       }
{***************************************}

{This demo program illustrates the use of the TVGraphic library.
 It is part of the documentation of TVGraphic.

This program is a very simple TVGraphic program.

NOTE that in TVGraphic, your Application descends
    from TProgram, not TApplication!

See TVGDemo1 for a full featured demo program.

Note: You should replace the default DOS critical error handling
routine (which always returns "Abort") for any program you will use
alot or distribute.  See TVGDemo1.

}

program TinyDemo;

{$F+,X+,V-}    {+X - use Extended syntax so can call a function as if
                  it were a procedure.}

uses DOS, Memory, MyGraph, GObjects, GDrivers,
     MCursor, GMenus,
     GViews,  GDialogs, GMsgBox, GStdDlg,
     GApp, GWindow, GHistLst;

const
  ProgName = 'TinyDemo';
  Ver      = '2.00';

  WinNum : integer = 0;
  cmVersion        = 1116;

var
  OldExitProc : Pointer;  { Saves exit procedure address }
  Graphic  : boolean;     { true if screen is in graphic mode }


procedure GExitProc; far;     {must be Far}
  {Exit procedure - restore screen to text mode if program halts}
begin
  ExitProc := OldExitProc; { Restore exit procedure address }
  CloseGraph;              { Shut down the graphics system }
end;


{--------------------------------}
type
  TDemoApp = object(TProgram)
    constructor Init;
    destructor Done; virtual;
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure InitMenuBar; virtual;
    procedure InitStatusLine; virtual;
    procedure IntroScreen;
  end;


constructor TDemoApp.Init;
var
  GraphDriver,GraphMode,ErrorCode : integer;
begin
  Graphic := false;         {do first}

  InitMemory;
  InitVideo;
  InitEvents;
  InitSysError;
  InitHistory;

     {register linked in EGA/VGA screen driver}
  RegisterBGIdriver(@EGAVGADriverProc);

  GraphDriver := Detect;                { use autodetection }
     {verify graphics mode}
  DetectGraph(GraphDriver, GraphMode);
  if not ((GraphDriver = VGA) or (GraphDriver = EGA)) then begin
    Done;
    Writeln('Error - system does not support EGA or VGA graphics.');
    Halt(1);
  end;

    {enter graphics mode}
  if GraphDriver = VGA then GraphMode := VGAHi
    else GraphMode := EGAHi;
  InitGraph(GraphDriver,GraphMode,'');

  ErrorCode := GraphResult;
  if ErrorCode <> grOK then begin
    Done;
    Writeln('Graphics Error: ',GraphErrorMsg(ErrorCode));
    Halt(1);
  end
  else begin
          {install exit proc to Close graphics}
    OldExitProc := ExitProc;                { save previous exit proc }
    ExitProc := @GExitProc;                { insert our exit proc in chain }
    Graphic := true;
          {install graphic mode DOS critical error handler}
    (* SysErrorFunc := GSystemError; *)
          {improves look of dark gray and brown on VGA monitors,
           no effect in EGA}
    ImprovePaletteColors;
  end;


  TProgram.Init;   {MCur mouse initialized in TProgram.Init}
      {sets default Viewport to just cover the DeskTop.
       The MainMenu,MessageBar and StatusLine temporarily
       reset Viewport when they draw themselves.}


      {following items may be different for your program}

  MCur.SetSpeed(12,12);  {how fast cursor moves, "normal" is 8,8}
  DoubleDelay := 6;   {time between mouse button presses for double press}
                      {TV uses 8 - very slow}

  IntroScreen;
end;

destructor TDemoApp.Done;
begin
  if Graphic then begin
    TProgram.Done;         {calls MCur.Done}
    CloseGraph;
    Graphic := false;
  end;

  DoneHistory;
  DoneSysError;
  DoneEvents;
  DoneVideo;
  DoneMemory;
end;

procedure TDemoApp.HandleEvent(var Event: TEvent);
  procedure ShowVersion;
  var Cmd : integer;
  begin
    Cmd := MessageBox(^C'TVGraphic '+ProgName+' ver '+Ver,
      nil, mfInformation+mfOKButton);
  end;

var
  PDir,FInputBox : PView;
  Cmd : integer;
begin
  TProgram.HandleEvent(Event);    {usual call to ancestor method}

  if Event.What = evCommand then
  begin
    case Event.Command of
      cmOpen:
        begin
          FInputBox := New(PFileDialog, Init('*.*', 'OPEN A FILE', '~N~ame', fdOpenButton,0));
          Cmd := DeskTop^.ExecView(FInputBox);
          Dispose(FInputBox, Done);
        end;
      cmChangeDir:
        begin
          PDir := New(PChDirDialog, Init(cdNormal {+ cdHelpButton},0));
          Cmd := DeskTop^.ExecView(PDir);
          Dispose(PDir, Done);
        end;
      cmVersion      : ShowVersion;
    end;
  end;
end;

procedure TDemoApp.InitMenuBar;
var
  R: TRect;
begin
  GetExtent(R);
  MenuBar := New(PMenuBar, Init(R, NewMenu(
    NewSubMenu('~F~ile', hcNoContext, NewMenu(
      NewItem('~O~pen...', 'F3', kbF3, cmOpen, hcOpen,
      NewLine(
      NewItem('~C~hange dir...', '', kbNoKey, cmChangeDir, hcChangeDir,
      NewItem('E~x~it', 'Alt+X', kbAltX, cmQuit, hcExit,
      nil))))),
    NewSubMenu('~I~nfo', hcNoContext, NewMenu(
      NewItem('~V~ersion #', '', kbNoKey, cmVersion, hcNoContext,
      nil)),
    nil))
  )));
end;

procedure TDemoApp.InitStatusLine;
var
  R: TRect;
begin
  GetExtent(R);
  R.A.Y := R.B.Y - Boxheight+2;
  StatusLine :=   New(PStatusLine, Init(R,
    NewStatusDef(0, $FFFF,
      NewStatusKey('~F6~ Next', kbF6, cmNext,
      NewStatusKey('~Shift+F6~ Prev', kbShiftF6, cmPrev,
      NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit,
      (nil)))),
       nil)));
  StatusLine^.VFont := font8x8;  {select smaller font}
end;

procedure TDemoApp.IntroScreen;
   {^C centers following text. ^M advances to next line}
begin
  MessageBox(^C'HELLO'^M^M^C+ProgName, nil, mfInformation + mfOKButton);
end;


var
  DemoApp: TDemoApp;
begin
  DemoApp.Init;
  DemoApp.Run;
  DemoApp.Done;
end.