Power-Programmierung/CD1.mdf/pascal/library/dos/tvision/gravis/gv/demo.pas

Pascal/Delphi Source File | 1994-05-23 | 17.4 KB | 652 lines

{*******************************************************}
{                                                       }
{       Graphics Vision Demo program                    }
{                                                       }
{       Copyright (c) 1993 Stefan Milius                }
{                                                       }
{*******************************************************}

Program Demo;

{ Dieses Programm demonstriert die Fähigkeiten der grafischen Oberfläche
  Graphics Vision. Es ist nur lauffähig, wenn zuvor die zugehörige
  Resourcendatei mit Hilfe des Programs DEMOREZ.PAS generiert wird.
  Es ist nicht nötig den Grafiktreiber (BGI) in das Programm zu linken.
  Dies wird durch GV automatisch erledigt.

  This program demonstrates the abilities of the graphical environment
  Graphics Vision. It is only executable if you first build the accessory
  resource file using DEMOREZ.PAS. It is not neccessary to link the graphic
  driver (BGI) into the program. This is done by GV automatically.
}

{$DEFINE change}

Uses CRT, Dos, Objects, Drivers, GVDriver, Views, GVViews, GVDialog, GVMenus,
     GVGadget, GVStdDlg, GVMsgBox, GVColor, GVApp, Graph, BGI, DemoType,
     MyMouse, ExtGraph, MetaGr, HistList;

const

{ Palettes }

  CTextInterior = #21#19;

type

{ TDemoApp object }

  PDemoApp = ^TDemoApp;
  TDemoApp = object (TApplication)
               Heap: PHeapView;
               Clock: PClockView;
               constructor Init;
               procedure InitMenuBar; virtual;
               procedure InitStatusLine; virtual;
               procedure InitDesktop; virtual;
               procedure HandleEvent (var Event: TEvent); virtual;
               procedure Idle; virtual;
             private
               Tune: Word;
               TuneEnabled: Boolean;
               procedure Play;
             end;

{ TTextInterior object }

  PTextInterior = ^TTextInterior;
  TTextInterior = object (TScroller)
                    Strings: TStringCollection;
                    constructor Init (var Bounds: TRect; AHScrollBar,
                        AVScrollBar: PScrollBar; FileName: PathStr);
                    destructor Done; virtual;
                    procedure Draw; virtual;
                    function GetPalette: PPalette; virtual;
                    procedure HandleEvent(var Event: TEvent); virtual;
                  private
                    procedure ReadFile (FileName: PathStr); virtual;
                  end;

{ TTextWindow object }

  PTextWindow = ^TTextWindow;
  TTextWindow = object (TWindow)
                  constructor Init (var Bounds: TRect; WinTitle: String);
                end;

{ TKoord record }

  PKoord = ^TKoord;
  TKoord = record
             x, y, r: Integer;
             Col, fCol: Byte;
           end;

{ TKoordCollection object }

  PKoordCollection = ^TKoordCollection;
  TKoordCollection = object (TCollection)
                       procedure FreeItem (Item: Pointer); virtual;
                     end;

{ TGraphicsInterior object }

  PGraphicInterior = ^TGraphicInterior;
  TGraphicInterior = object (TGView)
                       Rect: TRect;
                       Koords: TKoordCollection;
                       constructor Init (var Bounds: TRect);
                       destructor Done; virtual;
                       procedure Draw; virtual;
                       procedure DrawRect; virtual;
                       procedure ChMCursor; virtual;
                       procedure HandleEvent (var Event: TEvent); virtual;
                     end;

  PGraphicWindow = ^TGraphicWindow;
  TGraphicWindow = object (TWindow)
                     constructor Init (var Bounds: TRect; WinTitle: String);
                   end;

(***************************** TDemoApp object ******************************)

constructor TDemoApp.Init;
var R: TRect;
    Treiber, Mode: Integer;
    RezName: PathStr;

Begin
  If Lo (DosVersion)>=3 then RezName := 'DEMO.REZ'
  Else Begin
    RezName := FSearch('DEMO.REZ', GetEnv('PATH'));
    If RezName = '' then WriteLn ('DEMO.REZ konnte nicht gefunden werden');
    Halt(2);
  End;

  { Setting language }

  {$IFDEF change}
  {$IFDEF english }
  Language := lfEnglish;
  {$ENDIF}
  {$ENDIF}

  { Initialize resource file }

  RezStream := New(PProtectedStream, Init (RezName, stOpenRead, 4096));
  RezFile.Init(RezStream);

  RegisterType (RStringList);
  RegisterDemo;

  StatusHints:=PStringList (RezFile.Get ('StatusHints'));

  { Initialize Application }

  {$IFNDEF VER60}
  PathToDriver := 'C:\BP\BGI';
  {$ELSE}
  PathToDriver := 'C:\TP\BGI';
  {$ENDIF}

        (* Vergessen Sie nie diese Variable vor der Initialisierung
           der Applikation zu setzen, wenn Sie BGI Routinen zur Ausgabe
           verwenden möchten.

           Do never forget to set this variable before initializing
           the application if you wish to use BGI routines.
        *)

  WindowCmds := WindowCmds + [cmCloseAll];
  DisableCommands([cmCloseAll]);
  TApplication.Init;

  R.Assign (Size.X-71, Size.Y-21, Size.X+1, Size.Y+1);
  Heap:=New (PHeapView, Init (R));
  If Heap<>nil then Insert (Heap);
  R.Assign (Size.X-71, -1, Size.X+1, 21);
  Clock:=New (PClockView, Init (R));
  If Clock<>nil then Insert (Clock);

  Tune := cmIndyTune;
  TuneEnabled := true;
End;

procedure TDemoApp.InitMenuBar;
Begin
  MenuBar := PMenuBar (RezFile.Get ('MenuBar'));
End;

procedure TDemoApp.InitStatusLine;
Begin
  StatusLine := PDemoStatusLine (RezFile.Get ('StatusLine'));
End;

procedure TDemoApp.InitDesktop;
Begin
  Desktop := PDesktop (RezFile.Get ('Desktop'));
End;

procedure TDemoApp.HandleEvent;

 procedure FileOpen;
 var D: PDialog;
     C: Word;
     Filename: PathStr;
     R: TRect;
 Begin
   D := PFileDialog (RezFile.Get ('FOpenDlg'));
   If ValidView (D)<> nil then Begin
     C:=Desktop^.ExecView (D);

     If C=cmFileOpen then Begin
       D^.GetData (Filename);
       Desktop^.GetExtent (R);
       Desktop^.Insert (New (PTextWindow, Init (R, Filename)));
     End;

     Dispose (D, Done);
   End;
 End;

 procedure ChangeDir;
 var D: PDialog;
 Begin
   D := PChDirDialog (RezFile.Get ('FChDirDlg'));
   If ValidView (D)<> nil then Begin
     Desktop^.ExecView (D);
     Dispose (D, Done);
   End;
 End;

 procedure ColorDlg;
 var D: PDialog;
 Begin
   D := PColorDialog (RezFile.Get ('ColorDlg'));

   If ValidView (D)<> nil then Begin
     D^.SetData (Application^.GetPalette^);
     If Desktop^.ExecView (D) = cmOK then Begin
       D^.GetData (Application^.GetPalette^);
       ReDraw;
     End;
     Dispose (D, Done);
   End;
 End;

 procedure ShowInfo;
 var D: PDialog;
 Begin
   D := PDialog (RezFile.Get ('Info'));
   If ValidView (D) <> nil then Begin
     Desktop^.ExecView (D);
     Dispose (D, Done);
   End;
 End;

 procedure NewGWindow;
 const Count: Word = 1;
       Texts: Array [1..2] of String[23] =
          ('Graphical window no. ','Grafisches Fenster Nr. ');
 var S: String [5];
     R: TRect;
 Begin
   Str (Count, S);
   Desktop^.GetExtent (R);
   Desktop^.Insert (New (PGraphicWindow, Init (R, Texts[Language]+S)));

         (* Graphics Vision unterstützt sowohl die englische als auch die
            deutsche Sprache. Die Variable Language (UNIT GVApp) wird auf
            einen Wert, der die entsprechende Sprache symbolisiert, gesetzt
            und wird bei der Erzeugung von Fensterüberschriften u.s.w.
            ausgewertet (z.B. in GVStdDlg).

            Graphics Vision supports the English as well as the German
            language. To use a particular language just set the variable
            Language (UNIT GVApp). It is examined e.g. when creating
            window headlines (e.g. in GVStdDlg).

         *)

   Inc (Count);
 End;

 procedure NewDialog;
 var D: PDialog;
 {$IFDEF VER60}
     S: String;
 {$ENDIF}
 const Texts: Array [1..2] Of String[31] =
           ('A list for input recording!',
        'Eine Eingabeaufzeichnungsliste!');
 Begin
   D := PDialog (RezFile.Get ('DemoDialog'));
   If ValidView (D)<>nil then Begin
     {$IFNDEF VER60}
     HistoryAdd(40, Texts[Language]);
     {$ELSE}
     S := Texts[Language];
     HistoryAdd(40, S);
     {$ENDIF}
     If TuneEnabled then Play;
     Desktop^.ExecView (D);
     Dispose (D, Done);
   End;
 End;

 procedure CloseAll;
 var Win, NWin: PGView;
 Begin
   Win := Desktop^.First;
   With Desktop^ do While (Win <> Last) and (Win <> nil) do Begin
     NWin := Win^.NextView;
     Message(Win, evCommand, cmClose, nil);
     Win := NWin;
   End;
 End;

const Texts: Array [1..2,0..2] of String[86] =
    ((#13'A standard information box in Graphics Vision', 'By the way...',
      '... in Graphics Vision there are information boxes with user defined '+
      'window headlines.'),
     (#13'Eine Standard Informations - Box in Graphics Vision','Übrigens...',
      '... es gibt in Graphics Vision auch Info-Boxen mit veränderlichen '+
      'Überschriften.'));
Begin
  TApplication.HandleEvent (Event);
  If Event.What = evCommand then Begin
    Case Event.Command Of
      cmOpen        : FileOpen;
      cmChDir       : ChangeDir;
      cmColor       : ColorDlg;
      cmInfo        : ShowInfo;
      cmGWindow     : NewGWindow;
      cmDialog      : NewDialog;
      cmCloseAll    : CloseAll;
      cmEnableMusic : TuneEnabled := not TuneEnabled;
      cmIndyTune,
      cmNormalTune  : Tune := Event.Command;
      cmPlay        : Play;
     else Exit;
    End;
    ClearEvent (Event);
  End
  Else If Event.What = evBroadCast then Begin
         Case Event.Command Of
           cmGButton : MessageBox (Texts[Language,0], nil, mfOKCancel+mfInformation);
           cmButton  : MessageBoxTitle (Texts[Language,1], Texts[Language,2],
                          nil, mfOKCancel + mfError);
          else Exit;
         End;
         ClearEvent (Event);
       End;
End;

procedure TDemoApp.Idle;
Begin
  TApplication.Idle;
  Heap^.UpDate;
  Clock^.UpDate;
End;

procedure TDemoApp.Play;
var I, J: Integer;
Begin
  If Tune = cmIndyTune then Begin
    SetCurrentCursor(mcHourGlass);
    Sound (659 {Round (164.810*4)});
    Delay (220);
    NoSound;
    Delay (30);

    Sound (698 {Round (174.610*4)});
    Delay (150);
    NoSound;

    Sound (784 {Round (196.000*4)});
    Delay (100);
    NoSound;
    Delay (200);

    Sound (1047 {Round (261.630*4)});
    Delay (600);
    NoSound;
    SetCurrentCursor(mcNoCursor);
  End else If Tune = cmNormalTune then Begin
    SetCurrentCursor(mcHourGlass);
    For J := 1 to 3 do
      For I := 50 to 1000 do Begin
        Sound(I);
        Delay(1);
       End;
    NoSound;
    SetCurrentCursor(mcNoCursor);
  End;
End;

(*************************** TTextInterior object ***************************)

constructor TTextInterior.Init;
Begin
  TScroller.Init (Bounds, AHScrollBar, AVScrollBar);
  GrowMode:=gfGrowHiX + gfGrowHiY;
  ReadFile (FileName);
End;

destructor TTextInterior.Done;
Begin
  Strings.Done;
  TGView.Done;
End;

procedure TTextInterior.Draw;
var I: Integer;
    C: Byte;
    R: TRect;
    S: String;
Begin
  SetViewPort;
  HideMouse;
  { Hintergrund - background }
  SetFillStyle (SolidFill, GetColor (1));
  Bar (0, 0, Size.X-1, Size.Y-1);
  { Text }
  SetGVStyle (ftMonoSpace);
  R.Assign (0, 0, Size.X, 18);
  C:=GetColor (2);
  For I:=Delta.Y to Delta.Y + Size.Y div TextSize.Y do
    If I<Strings.Count then Begin
      S:=PString (Strings.At (I))^;
      Delete (S, 1, Delta.X);
      OutGVText (R.A, S, C, C, R.B, false);
      Inc (R.A.Y, 18);
    End;
  ShowMouse;
  RestoreViewPort;
End;

procedure TTextInterior.ReadFile;
var F: Text;
    S: String;
    I: Integer;
Begin
  Strings.Init (30,10);
  Strings.Duplicates:=true;
  Assign (F, FileName);
  {$I-}
  Reset (F);
  While not EOF (F) and (IOResult = 0) do Begin
    ReadLn (F, S);
    If S='' then S:=' ';
    Strings.AtInsert (Strings.Count, NewStr (S));
  End;
  Close (F);
  {$I+}
  SetLimit (100, Strings.Count);
End;

function TTextInterior.GetPalette;
const
  P: String [Length (CTextInterior)] = CTextInterior;
Begin
  GetPalette:=@P;
End;

procedure TTextInterior.HandleEvent;
var M: PGView;
    R: TRect;
    P: TPoint;
Begin
  TScroller.HandleEvent(Event);
  If ((Event.What = evMouseDown) and (Event.Buttons = mbRightButton) and
       MouseInView(Event.Where)) or
     ((Event.What = evCommand) and (Event.Command = cmLocalMenu)) then Begin
    M := PGView(RezFile.Get('LocalMenu'));
    LongInt(P) := 0; MakeGlobal(P, P);
    M^.GetExtent(R);
    R.Move(Size.X div 2 - M^.Size.X div 2 + P.X,
           Size.Y div 2 - M^.Size.Y div 2 + P.Y);
    M^.ChangeBounds(R);
    Application^.ExecView(M);
  End;
End;

(**************************** TTextWindow object ****************************)

constructor TTextWindow.Init;
var R: TRect;
Begin
  TWindow.Init (Bounds, WinTitle);
  HelpCtx := hcTextWindow;
  Delete (Background);
  Dispose (Background,Done);
  Background:=nil;
  GetExtent (R);
  R.Grow (-4,-4);
  R.A.Y:=23;
  Dec (R.B.X, 17); Dec (R.B.Y, 17);
  Insert (New (PTextInterior, Init (R,
    StandardScrollBar (sbHorizontal+sbHandleKeyboard),
    StandardScrollBar (sbVertical+sbHandleKeyboard),
    WinTitle)));
End;

(*************************** TKoordCollection object ************************)

procedure TKoordCollection.FreeItem;
Begin
  Dispose (PKoord (Item));
End;

(*************************** TGraphicInterior object ************************)

constructor TGraphicInterior.Init;
var I: Integer;
    K: PKoord;
Begin
  TGView.Init (Bounds);
  Options:=Options or ofPostProcess;
  GrowMode:=gfGrowHiX + gfGrowHiY;
  GetExtent (Rect);

  Koords.Init (20,5);
  Randomize;
  For I:=1 to 10 do Begin
    New (K);
    With K^ do Begin
      x:=Random (Size.X);
      y:=Random (Size.Y);
      r:=Random (Size.Y div 3)+1;
      Col:=Random (15)+1;
      fCol:=Random (15)+1;
    End;
    Koords.Insert (K);
  End;
End;

destructor TGraphicInterior.Done;
Begin
  Koords.Done;
  TGView.Done;
End;

procedure TGraphicInterior.Draw;
{ Wichtig ist es, erst SetViewPort und dann HideMouse aufzurufen, um ein
  unnötiges Flackern des Mauskursors zu vermeiden.

  It is important to call SetViewPort first and then HideMouse to avoid
  an unneccessary flicker of the mouse cursor.
}
var I: Integer;
    K: TKoord;
const Pattern: FillPatternType = ($55,$AA,$55,$AA,$55,$AA,$55,$AA);
Begin
  SetViewPort;
  HideMouse;
  SetFillStyle (SolidFill, Black);
  Bar (0, 0, Size.X-1, Size.Y-1);
  For I:=0 to Koords.Count-1 do Begin
    K:=PKoord (Koords.At (I))^;
    SetColor (K.Col);
    SetFillStyle (SolidFill, K.fCol);
    FillCircle (K.x, K.y, K.r);
  End;
  { Ausgaben mit BGI-Routinen - using BGI routines }
  SetFillPattern (Pattern, White);
  SetColor (DarkGray);
  FillEllipse (200,100,100,50);

   (* Bei Ausgaben mit BGI-Routinen, die nicht durch die Unit BGI
      bereitgestellt werden, muß zuvor die Routine GrClipBgi (Unit BGI)
      aufgerufen werden. Außerdem müssen zu den Ausgabekoordinaten
      die Werte BgiX bzw. BgiY addiert werden.

      When using BGI routines which are not supported by the unit BGI
      you first have to call GrClipBgi (unit BGI). Besides you will have
      to add the values BgiX or BgiY to the draw coordinates.
   *)

  Graph.SetColor (LightRed);
  Graph.SetFillStyle (SolidFill, LightRed);
  GrClipBgi;
  PieSlice (400 + BgiX, 200 + BgiY, 0, 285, 70);
  ShowMouse;
  RestoreViewPort;
  DrawRect;
End;

procedure TGraphicInterior.DrawRect;
Begin
  SetViewPort;
  HideMouse;
  SetColor (White);
  SetWriteMode (XORPut);
  With Rect do Rectangle (A.X, A.Y, B.X, B.Y);
  SetWriteMode (NormalPut);
  ShowMouse;
  RestoreViewPort;
End;

procedure TGraphicInterior.ChMCursor;
var R: TRect;
Begin
  R.Assign (0,0,Size.X,Size.Y);
  MakeGlobal (R.A, R.A);
  MakeGlobal (R.B, R.B);
  If R.Contains (MyMouse.MouseWhere) then NewNum:=mcLargeCross;
End;

procedure TGraphicInterior.HandleEvent;
var EvWhere: TPoint;
    First: Boolean;
Begin
  TGView.HandleEvent (Event);
  If (Event.What=evMouseDown) and MouseInView (Event.Where) then Begin
    First:=True;
    Repeat
      MakeLocal (Event.Where, EvWhere);
      If (Rect.B.X <> EvWhere.X) or (Rect.B.Y <> EvWhere.Y) then Begin
        DrawRect;
        If First then Begin
          Rect.A:=EvWhere;
          First:=False;
        End;
        Rect.B:=EvWhere;
        DrawRect;
      End;
    Until not MouseEvent (Event, evMouseMove+evMouseAuto);
  End;
End;

(*************************** TGraphicWindow object **************************)

constructor TGraphicWindow.Init;
var R: TRect;
Begin
  TWindow.Init (Bounds, WinTitle);
  Options := Options and not (ofBuffer+ofMetaFile);

  (* Da ein TGraphicsWindow ein Objekt enthält, daß BGI-Routinen bei der
     Ausgabe nutzt, müssen die Flags ofBuffer und ofMetaFile gelöscht werden.

     Because a TGraphicWindow contains an object that uses BGI routines to
     draw the flags ofBuffer and ofMetaFile has to be cleared in Options.
  *)

  Delete (Background);
  Dispose (Background,Done);
  Background:=nil;
  GetExtent (R);
  R.Grow (-4,-4);
  R.A.Y:=23;
  Insert (New (PGraphicInterior, Init (R)));
End;

var DemoApp: TDemoApp;

Begin
  DemoApp.Init;
  DemoApp.Run;
  DemoApp.Done;
End.