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

Pascal/Delphi Source File | 1994-09-23 | 14KB | 461 lines

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

{This demo program illustrates the use of

 Borland's VESA video driver (VESA16.BGI)

 with the TVGraphic library.

 It is part of the documentation of TVGraphic.

 (******************************************)
 NOTE - source code versions of TVGraphic may be
    modified to use third party graphic libraries
    for direct support (non-VESA) of super VGA cards.
                  Inquire.
 (******************************************)

 Run the Borland supplied program VESATEST.EXE to
 determine if your video card supports VESA.
 If VESATEST cannot locate a VESA Bios, note that
 many video cards require you to run their utility
 program to enable or load the VESA Bios on the card.

 According to one supplier of graphic libraries,
 the VESA utility/TSR programs shipped with a number
 of video cards were buggy. You may need to obtain
 the latest version software from the card manufacturer.

 !! The VESA16.BGI driver must be in the directory !!
      named in DriverDirectory.

    DriverDirectory = '\bp\bgi\';
    Change DriverDirectory to match your computer.


NOTE: When using the VESA16 driver within the IDE, breakpoints
      after InitGraph will scramble the graphic screen.

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 VESADEMO;

{$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,
     BMPdrvr;

const
  ProgName = 'VESAdemo';
  Ver      = '2.00';

  DriverDirectory = '\bp\bgi\'; {directory containing VESA16.BGI}
      {change to match your computer.}

const
  WinNum : integer = 0;
  cmCircleWindow     = 1102;
  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

  {demonstrates very simple Draw method and using TimerTick events}

  PCircles = ^TCircles;
  TCircles = object(TWinBackground)
    Count : integer;
    Speed : integer;
    constructor Init(var Bounds: TRect);
    procedure Draw; virtual;
    procedure DrawCircle;
    procedure HandleEvent(var Event : TEvent); virtual;
  end;

  constructor TCircles.Init(var Bounds: TRect);
  begin
    TWinBackground.Init(Bounds);
    EventMask := evTimerTick;
    VColor := black;               {store drawing color}
  end;

  procedure TCircles.Draw;
  var   Glob : TRect;
  begin
    MCur.Hide;              {hide cursor}
    GetVPRelCoords(Glob);   {get view's outline in viewport relative coords}

    SetFillStyle(solidfill,VColor);            {set background color}
    Bar(Glob.A.x,Glob.A.y,Glob.B.x,Glob.B.y);  {draw background}

    DrawCircle;

    MCur.Show;
  end;

  procedure TCircles.DrawCircle;
  var
    Radius : word;
    Glob : TRect;
    Color : integer;
  begin
    MCur.Hide;              {hide cursor}
    GetVPRelCoords(Glob);   {get view's outline in viewport relative coords}

    if (Count = 0) or (Count =8) then Color := 14
      else Color := Count;
    SetColor(Color);               {set circle Color based on Count}

                                   {compute radius based on view's size}
    if Size.x < Size.y then Radius := Size.x
    else Radius := Size.y;
    Radius := Radius div 3;
                                   {draw circle}
    Circle(Glob.A.x+Size.x div 2, Glob.A.y+Size.y div 2, Radius);
    MCur.Show;               {show the mouse cursor}
  end;

  procedure TCircles.HandleEvent(var Event : TEvent);
  begin
    if Event.What = evTimerTick then begin
         { if you want to avoid overwriting menus and modal dialog boxes,
           must exit if the Application (Desktop's Owner) is not the
           modal view.}
      if TopView <> PView(DeskTop^.Owner) then Exit;

      Inc(Speed);
      if Speed > 1023 then Speed := 0;
      if (Speed mod 8 = 0) then begin
        Inc(Count);
        if Count > 15 then Count := 0;   {limit to highest color}
        if GetState(sfActive) then DrawCircle;
      end;
    end;
  end;

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


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

  InitMemory;
  InitVideo;
  InitEvents;
  InitSysError;
  InitHistory;

     {register screen driver}
  RegisterBGIdriver(@EGAVGADriverProc);

  {NOTE: DetectGraph cannot find user drivers such as VESA16.BGI !!
         Use function DetectVESA16 to see if card is VESA compatible.}

  if DetectVESA16 >= 0 then begin  {VESA video BIOS detected}
     {note that your video card may require you to run the manufacturer's
      VMODE or VESA utility program to enable the VESA BIOS on the card.
      If not enabled, card will not be detected as VESA compatible.}
         {register Borland VESA driver}
    GraphDriver := InstallUserDriver('VESA16', @DetectVESA16);
    GraphMode := 0;  {TVGraphic only supports mode 0 = 800x600}
  end
  else begin
    GraphDriver := Detect;                { use autodetection }
     {verify graphics mode - DetectGraph cannot find User drivers}
    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;
  end;

    {enter graphics mode}
  if GraphDriver = VGA then GraphMode := VGAHi
    else if GraphDriver = EGA then GraphMode := EGAHi;

  InitGraph(GraphDriver,GraphMode, DriverDirectory);
     {DriverDirectory is needed only for VESA16 driver.
      It must point to the directory on your computer
      containing VESA16.BGI}

   {NOTE: When using the VESA driver within the IDE, breakpoints
          after InitGraph will scramble the graphic screen.}


(* {Note that the following autodetection code works but doesn't allow
  checking of the graphic mode prior to entering graphics with InitGraph.
  You would have a problem if the user tried to run on a card that
  didn't support EGA or VGA. The user would get a "driver not found"
  error unless the driver happened to be present - then user would
  get garbage.}

  GraphDriver := InstallUserDriver('VESA16', @DetectVESA16);
  GraphDriver := Detect;                { use autodetection }
  {    DetectGraph will not find user installed drivers.
       DetectGraph(GraphDriver, GraphMode);}
  InitGraph(GraphDriver,GraphMode, DriverDirectory);
*)

  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}

  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
      cmNew: NewWindow;
      cmOpen : LoadBMP;
      cmChangeDir:
        begin
          PDir := New(PChDirDialog, Init(cdNormal {+ cdHelpButton},0));
          Cmd := DeskTop^.ExecView(PDir);
          Dispose(PDir, Done);
        end;
      cmCircleWindow : InsertCircleWin;
      cmVersion      : ShowVersion;
    end;
  end;
end;

procedure TDemoApp.InsertCircleWin;
var
  P : PView;
  W : PWindow;
  R : TRect;
begin
  R.Assign((WinNum+20)*Grid, (WinNum+20)*Grid,
           (WinNum+40)*Grid, (WinNum+40)*Grid);
  Inc(WinNum);  {so next window will be shoved over}

  W := New(PWindow, Init(R,'CIRCLES',wnNoNumber));

  W^.GetMaxSubViewSize(R, false);
  P := New(PCircles, Init(R));
  W^.Insert(P);
  DeskTop^.Insert(W);
end;

procedure TDemoApp.InitMenuBar;
var
  R: TRect;
begin
  GetExtent(R);
  MenuBar := New(PMenuBar, Init(R, NewMenu(
    NewSubMenu('~F~ile', hcNoContext, NewMenu(
      NewItem('~N~ew', '', kbNoKey, cmNew, hcNew,
      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('~W~indows', hcNoContext, NewMenu(
      NewItem('Circle~W~indow', '', kbNoKey, cmCircleWindow , hcNoContext,
      NewLine(
      NewItem('~S~ize/Move','Ctrl+F5', kbCtrlF5, cmResize, hcResize,
      NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcZoom,
      NewItem('~N~ext', 'F6', kbF6, cmNext, hcNext,
      NewItem('~P~revious', 'Shift+F6', kbShiftF6, cmPrev, hcPrev,
      NewItem('~C~lose', 'Alt+F3', kbAltF3, cmClose, hcClose,
      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;
begin
  MessageBox(^C'If your VESA video card is not in 800x600 display, you may'+
     ' need to run the card''s utility program.', nil, mfInformation + mfOKButton);
end;

procedure TDemoApp.LoadBMP;
var
  R : TRect;
  BitPtr : PBitMap;
  Cmd : integer;
  FInputBox : PFileDialog;
  FName : PathStr;
  InFile : file;
  Result : word;
  Buf : array[0..Sizeof(TBitMapInfoHeader)-1] of byte;
  TotalBytes : LONGint; {!!!}
  ErrStr : string;
begin
  BitPtr := nil;
  Inc(WinNum);
  R.A.x := 100; R.A.y := 100;
  FInputBox := New(PFileDialog, Init('*.BMP', 'LOAD AND DRAW A BITMAP', '~N~ame', fdOpenButton,0));
  Cmd := DeskTop^.ExecView(FInputBox);

  if (Cmd = cmFileOpen) or (Cmd = cmOK) then FInputBox^.GetFileName(FName)
      else FName := '';
  Dispose(FInputBox, Done);
  if FName <> '' then begin
    {$I-}
    Assign(InFile, FName);
    Reset(InFile,1);   {reads 1 byte blocks}
    if IOResult <> 0 then begin
      Close(InFile);
      MessageBox('Can''t find file '+ FName, nil, mfError+mfOKButton);
      Exit;
    end;
    {$I+}

      {read just the InfoHeader}
    BlockRead(InFile, Buf, Sizeof(TBitMapInfoHeader), Result);

        {remember - the Infoheader is in Buf, not yet in BitPtr^.}
    ErrStr := BMPFormatOKStr(PBitMap(@Buf), FName);
    If ErrStr = '' then begin
      BitPtr := AllocateBMPmem(PBitMap(@Buf)); {allocate mem,use special call}
      if BitPtr <> nil then begin
        TotalBytes := GetBitImageSize(PBitMap(@Buf));

        Reset(InFile,1);   {start again at beginning of file, read all}
        BlockRead(InFile, BitPtr^, TotalBytes, Result);

        WinToTVColor(BitPtr);
        MCur.Hide;
        PutBitMap(100,100, BitPtr, 0, NormalPut);
        MCur.Show;
      end;
    end
    else
      Cmd := MessageBox(ErrStr, nil, mfError+mfOKButton);

    Close(InFile);

  {! WARNING ! - following line disposes of memory used by this bitmap -
    fine here since just want to draw bitmap once on screen but disaster
    if you assign BitPtr to a View or Button in your own code!}

    if BitPtr <> nil then FreeMem(BitPtr, TotalBytes); {do here for demo}
  end;
end;

procedure TDemoApp.NewWindow;
begin
  MessageBox(^C'Use the Windows Menu to open Windows',nil,
                       mfInformation+mfOKButton);
end;


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