Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TVLIFE.ZIP/TVLIFE.PAS

Pascal/Delphi Source File | 1992-02-16 | 10.9 KB | 423 lines

PROGRAM TVLife;

{                        Turbo Vision Life  v1.0                         }
{                            by Ben Ziegler                              }
{                          February 16, 1992                             }
{                                                                        }
{  TVLife is a simple program that illustrates a few of Turbo Visions's  }
{  features:  1) how to use the Idle event to execute background tasks,  }
{  and 2) how to incorporate menus inside of Twindows.  It is merely     }
{  meant to be a demonstration program for Turbo Pascal v6.0             }
{                                                                        }
{  Send any questions or comments to:                                    }
{                                                                        }
{     Ben Ziegler                  Internet Email Address:               }
{     4010 Terrace Dr              [e-mail]                    }
{     Annandale, VA  22003         (email valid until May 1992)          }


{$R-,S-}                          { This will speed up program execution }

USES Objects, Drivers, Views, Menus, App;

CONST
  cmLife        = 101;            { Opens a Life window           }
  cmIdle        = 102;            { issued when TV is Idle        }
  cmStart       = 103;            { Starts a Life window running  }
  cmStop        = 104;            { Stops a Life window           }
  cmClearBoard  = 105;            { Clears the Life Board         }
  cmRandom      = 106;            { Randomly fills the Life Board }
  cmHighRes     = 107;            { Set Screen to VGA 43/50 Lines }
  cmLowRes      = 108;            { Set Screen to 25 Lines        }

  Xm            = 80;             { Max X Size of Life Window     }
  Ym            = 48;             { Max Y Size of Life Window     }

TYPE
  Board         = array[1..Xm, 1..Ym] of byte;

  TMyApp        = object(TApplication)
    constructor Init;
    procedure   HandleEvent(var Event: TEvent); virtual;
    procedure   InitMenuBar; virtual;
    procedure   InitStatusLine; virtual;
    procedure   idle; virtual;
    procedure   DoLife;
    procedure   HighRes;
    procedure   LowRes;
  end;

  PMyMenuBar    = ^TMyMenuBar;
  TMyMenuBar    = object(TMenuBar)
     function   GetPalette: PPalette; virtual;
  end;

  PLifeInterior = ^TLifeInterior;
  TLifeInterior = object(Tview)
    OldB        : ^Board;
    mx,my       : integer;
    running     : boolean;
    constructor Init(var Bounds: TRect);
    procedure   HandleEvent(var Event:TEvent); virtual;
    procedure   Iterate(var o : Board);
    procedure   InitBoard(var b : Board);
    procedure   ClearBoard(var b : Board);
    procedure   Update; virtual;
    procedure   Draw; virtual;
  end;

  PLifeView     = ^TLifeView;
  TLifeView     = object(TWindow)
    MyInterior  : PLifeInterior;
    MB          : PMyMenuBar;
    constructor Init(Bounds:Trect; s : string; num:integer);
    procedure   handleevent(var event : Tevent); virtual;
    procedure   SizeLimits(var Min, Max: TPoint); virtual;
    end;

{ ************* }
{ TLifeInterior }
{ ************* }

CONSTRUCTOR TLifeInterior.Init(var Bounds: TRect);
BEGIN
   TView.Init(Bounds);
   GrowMode  := gfGrowHiX + gfGrowHiY;
   Options   := Options OR ofFramed;
   EventMask := $FFFF;                   { Listen for all types of events }
   mx        := 0;
   my        := 0;

   NEW(OldB);
   InitBoard(OldB^);
end;

PROCEDURE TLifeInterior.InitBoard(var b : Board);
VAR
   x,y,i : integer;
BEGIN
   FOR x := 1 TO Xm DO
      FOR y := 1 TO Ym DO
         b[x,y] := 0;
   Randomize;
   FOR i := 1 TO 999 DO BEGIN
      x := Random(Xm-2)+2;
      y := Random(Ym-2)+2;
      b[x,y] := 1;
      END;
END;

PROCEDURE TLifeInterior.ClearBoard(var b : Board);
VAR
   x,y   : integer;
BEGIN
   FOR x := 1 TO Xm DO
      FOR y := 1 TO Ym DO
         b[x,y] := 0;
END;

PROCEDURE TLifeInterior.Draw;
VAR
   x,y   : integer;
   R     : TRect;
   ex,ey : integer;
   B     : array[0..2047] of word;    { Buffer used to speed up Draw }
BEGIN
   GetExtent(R);
   ex := R.B.X+1;
   ey := R.B.Y+1;

   FOR y := 2 TO ey DO BEGIN
      FOR x := 2 TO ex DO BEGIN
         IF OldB^[x,y]=0 THEN BEGIN
            MoveChar(B[x-2], #32, GetColor(2), 1);
            END
         ELSE BEGIN
            MoveChar(B[x-2], #9, GetColor(2), 1);
            END;
         END;
      WriteLine(0, y-2, Size.X, 1, B);
      END;
END;

PROCEDURE TLifeInterior.Iterate(var o : Board);
VAR
   x,y,num : integer;
   n       : Board;
BEGIN
   n := o;

   FOR x := 2 TO Xm-1 DO
      FOR y := 2 TO Ym-1 DO BEGIN
         { Find number of neighbors }
         num := o[x-1,y-1] + o[x,y-1] + o[x+1,y-1]
              + o[x-1,y]              + o[x+1,y]
              + o[x-1,y+1] + o[x,y+1] + o[x+1,y+1];
         IF o[x,y]=1 THEN
            IF ((num=2) OR (num=3)) THEN n[x,y] := 1
               ELSE n[x,y] := 0;
         IF o[x,y]=0 THEN
            IF num=3 THEN n[x,y] := 1   { Birth = 3! }
               ELSE n[x,y] := 0;
         END;

   o := n;
END;

PROCEDURE TLifeInterior.Update;
BEGIN
   Iterate(OldB^);
   Draw;
END;

PROCEDURE TLifeInterior.HandleEvent(var event : Tevent);
VAR
   p,o : Tpoint;
BEGIN
   tview.handleevent(event);
   IF event.what = evCommand THEN
      CASE event.command OF
         cmStart : running := TRUE;
         cmStop  : running := FALSE;
         end;
   IF event.what = evBroadCast THEN
      IF event.command = cmIdle THEN BEGIN
         IF running THEN Update;
         END;
   IF event.what = evCommand THEN
      IF event.command = cmClearBoard THEN BEGIN
         ClearBoard(OldB^);
         Draw;
         ClearEvent(event);
         END;
   IF event.what = evCommand THEN
      IF event.command = cmRandom THEN BEGIN
         InitBoard(OldB^);
         Draw;
         ClearEvent(event);
         END;

   IF (event.what AND (evMouseDown OR evMouseAuto)) <> 0 THEN BEGIN
         o := event.where;
         MakeLocal(o, p);
         p.x := p.x+2;
         p.y := p.y+2;
         IF (mx<>p.x) OR (my<>p.y) THEN BEGIN
            OldB^[p.x, p.y] := 1-OldB^[p.x, p.y];
            Draw;
            mx := p.x;
            my := p.y;
            END;
         END;
END;


{ ********* }
{ TLifeView }
{ ********* }

CONSTRUCTOR TLifeView.Init(Bounds:Trect; s : string; num:integer);
VAR
   R : TRect;
BEGIN
   Twindow.init(Bounds, s, num);

   GetExtent(R);
   R.Grow(-1,-1);
   R.B.Y := R.A.Y + 1;
   MB := New(PMyMenuBar, Init(R, NewMenu(
     NewSubMenu('~A~ction', hcNoContext, NewMenu(
       NewItem('~S~tart', 'Alt-S', kbAltS, cmStart, hcNoContext,
       NewItem('Sto~p~', 'Alt-P', kbAltP, cmStop, hcNoContext,
       NewItem('~C~lear Board', 'Alt-C', kbAltC, cmClearBoard, hcNoContext,
       NewItem('~R~andomize', 'Alt-R', kbAltR, cmRandom, hcNoContext,
       NewLine(
       NewItem('Close ~W~indow', 'Alt-F3', kbAltF3, cmClose, hcNoContext,
       nil))))))),
     nil)
   )));
   Insert(MB);

   GetClipRect(Bounds);
   Bounds.Grow(-1,-2);
   Bounds.B.y := Bounds.b.y + 1;
   MyInterior := New(PLifeInterior, Init(Bounds));
   Insert(MyInterior);

   Options := Options OR (ofFirstClick OR ofTileable);
   dragmode := $F0;                     { Can't move window off screen }
END;

PROCEDURE TLifeView.HandleEvent(var event : Tevent);
VAR
   HelloThere : pointer;
BEGIN
   { NOTE:  HelloThere must come before twindow.he or CRASH! }
   HelloThere := Message(MyInterior, event.what, event.command, nil);
   Twindow.HandleEvent(event);
END;

PROCEDURE TLifeView.SizeLimits(var Min, Max: TPoint);
CONST
   MyMin : TPoint = (X: 28; Y: 11);
VAR
   R     : TRect;
BEGIN
   Desktop^.GetExtent(R);
   Min := MyMin;
   Max := R.B;
END;


{ ********** }
{ TMyMenuBar }
{ ********** }

FUNCTION TMyMenuBar.GetPalette: PPalette;
CONST
   CMyStuff = #4#3#6#5#6#7;
   PMyStuff : string[Length(CMyStuff)] = CMyStuff;
BEGIN
   GetPalette := @PMyStuff;
END;

{ ****** }
{ TMyApp }
{ ****** }

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 TMyApp.HandleEvent(var Event: TEvent);
BEGIN
  TApplication.HandleEvent(Event);
  IF Event.What = evCommand THEN BEGIN
    CASE Event.Command OF
      cmLife    : DoLife;
      cmTile    : Tile;
      cmCascade : Cascade;
      cmHighRes : HighRes;
      cmLowRes  : LowRes;
    ELSE
      Exit;
    END;
    ClearEvent(Event);
  END;
END;

PROCEDURE TMyApp.InitMenuBar;
VAR
   R: TRect;
BEGIN
  GetExtent(R);
  R.B.Y := R.A.Y + 1;
  MenuBar := New(PMenuBar, Init(R, NewMenu(
    NewSubMenu('~F~ile', hcNoContext, NewMenu(
      NewItem('~L~ife Window', 'F9', kbF9, cmLife, hcNoContext,
      NewLine(
      NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, hcNoContext,
      nil)))),
    NewSubMenu('~W~indow', hcNoContext, NewMenu(
      NewItem('~N~ext', 'F6', kbF6, cmNext, hcNoContext,
      NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcNoContext,
      NewItem('~T~ile', '', 0, cmTile, 0,
      NewItem('~C~ascade', '', 0, cmCascade, 0,
      NewItem('~H~igh Res', 'Alt-H', kbAltH, cmHighRes, 0,
      NewItem('~L~ow Res', 'Alt-L', kbAltL, cmLowRes, 0,
      nil))))))),
    nil)
  ))));
END;

PROCEDURE TMyApp.InitStatusLine;
VAR
   R: TRect;
BEGIN
  GetExtent(R);
  R.A.Y := R.B.Y - 1;
  StatusLine := New(PStatusLine, Init(R,
    NewStatusDef(0, $FFFF,
      NewStatusKey('', kbF10, cmMenu,
      NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit,
      NewStatusKey('~F9~ Life Window', kbF9, cmLife,
      NewStatusKey('~Alt-F3~ Close', kbAltF3, cmClose,
      nil)))),
    nil)
  ));
END;

PROCEDURE TMyApp.DoLife;
VAR
   R    : TRect;
   R2   : TRect;
   Life : PLifeView;
BEGIN
   GetExtent(R2);
   R.Assign(0, 0, 28, 11);
   R.Move(Random(R2.B.X-29), Random(R2.B.Y-12));
   Life := New(PLifeView, Init(R, 'Life', 0));
   Desktop^.Insert(Life);
END;

PROCEDURE TMyApp.Idle;
VAR
   HelloThere : pointer;

FUNCTION IsTileable(P: PView): Boolean; far;
BEGIN
   IsTileable := P^.Options and ofTileable <> 0;
END;

BEGIN
   TApplication.Idle;
   IF Desktop^.FirstThat(@IsTileable) <> NIL THEN
      EnableCommands([cmTile, cmCascade])
   ELSE
      DisableCommands([cmTile, cmCascade]);

   HelloThere := Message(DeskTop, evBroadcast, cmIdle, nil);
end;

PROCEDURE TMyApp.HighRes;
BEGIN
   SetScreenMode(ScreenMode OR smFont8x8);
   DisableCommands([cmHighRes]);
   EnableCommands([cmLowRes]);
END;

PROCEDURE TMyApp.LowRes;
BEGIN
   SetScreenMode(ScreenMode AND NOT smFont8x8);
   DisableCommands([cmLowRes]);
   EnableCommands([cmHighRes]);
END;

CONSTRUCTOR TMyApp.Init;
BEGIN
   Tapplication.init;
   DisableCommands([cmLowRes]);
END;


VAR
   MyApp: TMyApp;

BEGIN
  MyApp.Init;
  MyApp.Run;
  MyApp.Done;
END.