ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/WINDOWS/PROGRAM/PLIFE.ZIP/PLIFE.PAS

Pascal/Delphi Source File | 1991-05-02 | 20.3 KB | 690 lines

{**************************************************}
{                    Life 1.0                      }
{                    Written in                    }
{             Turbo Pascal for Windows             }
{                Copyright (c) 1991                }
{                  Zack Urlocker                   }
{                    05/02/91                      }
{**************************************************}

program PLife;

{ This is a simple implementation of the Game of Life written
  in Turbo Pascal for Windows using the ObjectWindows application
  framework.  The program is divided into three main object types:

  TLifeApplication  --creates and shows the main window
  TLifeWindow       --responds to Windows messages, menu commands,
                      keyboard and mouse events
  TLifeCells        --mutates and draws the cells in the window
}

{$R PLife.res}        { Link in resources }

{$IFDEF Final}        { Remove debug code for final version}
{$D-,I-,L-,R-,S-}
{$ELSE}
{$D+,I+,L+,R+,S+}
{$ENDIF}

uses WObjects, WinTypes, WinProcs, Strings, StdDlgs;

const
  cm_Clear   = 201;        { command menu constant IDs }
  cm_Go      = 202;
  cm_Trace   = 203;
  cm_Stop    = 204;
  cm_Exit    = 209;
  cm_About   = 210;
  cm_Timer   = 301;
  cm_Grid    = 302;
  cm_Zoom    = 303;
  cm_Random  = 401;
  cm_Bloom   = 402;
  cm_Walker  = 403;
  cm_Help    = 501;
  cm_CmdMode = 601;      { For Lotus style slash (/) key commands }

  XMax       = 100;      { Maximum matrix size }
  YMax       = 100;      { Only visible portion is used }
  MaxGrid    = 50;       { Maximum grid size for Zoom }
  MinGrid    = 10;       { Minimum grid size for Zoom }

  Dead =   False;        { cell values }
  Born =    True;

  Black = $000000;       { Windows color constants }
  White = $FFFFFF;
  Blue  = $FF0000;


type

  { The application defines startup behavior for the window. }
  TLifeApplication = object(TApplication)
    procedure InitInstance; virtual;
    procedure InitMainWindow; virtual;
  end;

  Matrix = array [0..XMax, 0..YMax] of Boolean;

  { The cells are responsible for mutating and drawing in a window.
    The cells will be notified whenever the size of the grid or
    number of rows and columns in the window changes.    }
  TLifeCells = object(TObject)
    cells : matrix;                { actual cells        }
    scratchCells : matrix;         { scratch work area   }
    rows : integer;                { visible rows        }
    cols : integer;                { visible columns     }
    gridSize : integer;            { for drawing a cell  }
    constructor init;              { initialize cells    }
    procedure mutate(DC:HDC);      { mutate all cells    }
    procedure draw(DC:HDC);        { draw all cells      }
    procedure setCell(i,j:Integer; alive: Boolean);
    function aliveCell(i,j:Integer): Boolean;
    procedure walker(i,j:Integer);
    procedure bloom(i,j:Integer);
    procedure mutateCell(DC:HDC; i,j: integer);
    procedure drawCell(DC:HDC; i, j:Integer; alive: Boolean);
  end;

  { The window handles keyboard, mouse messages and controls cells. }
  PLifeWindow = ^TLifeWindow;
  TLifeWindow = object(TWindow)
    cells : TLifeCells;            { cells being mutated }
    speed : Integer;               { timer speed         }
    running : Boolean;             { is timer running?   }
    rows : Integer;                { visible rows        }
    cols : Integer;                { visible columns     }
    grid : Boolean;                { is grid turned on?  }
    gridSize : Integer;            { for drawing a cell  }
    mouseDown : Boolean;           { is mouse down?      }
    xDown : Integer;               { x location in grid  }
    yDown : Integer;               { y location in grid  }
    mutateDC : HDC;                { draw each mutation  }
    mouseMoveDC : HDC;             { draw mouse moves    }
    constructor Init(AParent: PWindowsObject; ATitle: PChar);
    procedure GetWindowClass(var WndClass: TWndClass); virtual;

    { menu response methods }
    procedure Clear(var Msg: TMessage); virtual cm_First + cm_Clear;
    procedure Randomize(var Msg: TMessage); virtual cm_First + cm_Random;
    procedure Bloom(var Msg: TMessage); virtual cm_First + cm_Bloom;
    procedure Walker(var Msg: TMessage); virtual cm_First + cm_Walker;
    procedure Go(var Msg: TMessage); virtual cm_First + cm_Go;
    procedure Trace(var Msg: TMessage); virtual cm_First + cm_Trace;
    procedure Stop(var Msg: TMessage); virtual cm_First + cm_Stop;
    procedure Exit(var Msg: TMessage); virtual cm_First + cm_Exit;
    procedure About(var Msg: TMessage); virtual cm_First + cm_About;
    procedure Timer(var Msg: TMessage); virtual cm_First + cm_Timer;
    procedure GridToggle(var Msg: TMessage); virtual cm_First + cm_Grid;
    procedure Zoom(var Msg: TMessage); virtual cm_First + cm_Zoom;
    procedure Help(var Msg: TMessage); virtual cm_First + cm_Help;
    procedure CmdMode(var Msg: TMessage); virtual cm_First + cm_CmdMode;

    { windows message response methods }
    procedure Paint(DC: HDC; var PaintInfo: TPaintStruct); virtual;
    procedure DrawGrid(DC: HDC);
    procedure wmSetFocus(var Msg: TMessage); virtual wm_SetFocus;
    procedure wmKillFocus(var Msg: TMessage); virtual wm_KillFocus;
    procedure wmKeyDown(var Msg: TMessage); virtual wm_KeyDown;
    procedure wmLButtonDown(var Msg: TMessage); virtual wm_LButtonDown;
    procedure wmLButtonUp(var Msg: TMessage); virtual wm_LButtonUp;
    procedure wmLButtonDblClk(var Msg: TMessage); virtual wm_LButtonDblClk;
    procedure wmMouseMove(var Msg: TMessage); virtual wm_MouseMove;
    procedure wmRButtonDown(var Msg: TMessage); virtual wm_RButtonDown;
    procedure wmTimer(var Msg: TMessage); virtual wm_Timer + wm_First;
    procedure wmSize(var Msg: TMessage); virtual wm_Size;
    procedure wmGetMinMaxInfo(var Msg: TMessage); virtual wm_GetMinMaxInfo;
    procedure wmDestroy(var Msg: TMessage); virtual wm_Destroy;
  end;


{--------------------------------------------------}
{ TLifeApplication's method implementations:       }
{--------------------------------------------------}

{ Load the accelerator table for hotkeys }
procedure TLifeApplication.InitInstance;
begin
  Tapplication.InitInstance;
  HAccTable := LoadAccelerators(HInstance, 'LifeKeys');
end;

{ Start the main window }
procedure TLifeApplication.InitMainWindow;
begin
  MainWindow := New(PLifeWindow, Init(nil, 'PLife'));
end;


{--------------------------------------------------}
{ TLifeCell's method implementations:              }
{--------------------------------------------------}

{ Clear out the cell matrices }
constructor TLifeCells.Init;
begin
  fillchar(cells, sizeOf(cells), 0);
  fillchar(scratchCells, sizeOf(scratchCells), 0);
end;

{ Is the cell alive? }
function TLifeCells.aliveCell(i,j:Integer) : Boolean;
begin
  aliveCell := cells[i,j];
end;

{ Set the cell to born or dead state }
procedure TLifeCells.setCell(i,j:Integer; alive:Boolean);
begin
  cells[i, j] := alive;
end;

{ Create an interesting pattern that "walks" across the screen }
procedure TLifeCells.walker(i, j:Integer);
begin
  cells[i,j+2] := Born;
  cells[i+1,j+2] := Born;
  cells[i+2,j+2] := Born;
  cells[i+2,j+1] := Born;
  cells[i+1,j] := Born;
end;

{ Create an interesting pattern that "blooms" across the screen }
procedure TLifeCells.bloom(i, j:Integer);
begin
  cells[i+1,j] := Born;
  cells[i,j+1] := Born;
  cells[i,j+2] := Born;
  cells[i,j+3] := Born;
  cells[i+1,j+3] := Born;
  cells[i+2,j+3] := Born;
  cells[i+2,j+2] := Born;
  cells[i+2,j+1] := Born;
end;

{ Draw a single cell as a borderless rectangle }
procedure TLifeCells.drawCell(DC: HDC; i, j: Integer; alive: Boolean);
var xScreen, yScreen : Integer;
  color : TColorRef;
begin
  xScreen := i * gridSize;
  yScreen := j * gridSize;
  if alive then
    color := Blue
  else
    color := White;
  SelectObject(DC, CreateSolidBrush(color));
  rectangle(DC, xScreen+1, yScreen+1, xScreen+gridSize-1, yScreen+gridSize-1);
  DeleteObject(SelectObject(DC, GetStockObject(Black_Brush)));
end;

{ Redraw active cells on screen }
procedure TLifeCells.draw(DC:HDC);
var i, j, xScreen, yScreen : Integer;
begin
  for i:= 1 to cols do
    for j := 1 to rows do
      if cells[i,j] then
        drawCell(DC, i, j, born);
end;

{ Determine how the cell should mutate by the number of neighbors
  it has.  Too few or too many means it should die.  }
procedure TLifeCells.mutateCell(DC:HDC; i, j : integer);
var neighbors : Integer;
    temp : Integer;
begin
  neighbors := 0;
  if cells[i-1, j]  then inc(neighbors);
  if cells[i+1, j]  then inc(neighbors);
  if cells[i, j-1]  then inc(neighbors);
  if cells[i, j+1]  then inc(neighbors);
  if cells[i-1, j-1] then inc(neighbors);
  if cells[i+1, j+1] then inc(neighbors);
  if cells[i-1, j+1] then inc(neighbors);
  if cells[i+1, j-1] then inc(neighbors);

  if not cells[i, j] then      { it's a dead cell }
    if neighbors = 3 then      { bring it to life }
    begin
      scratchCells[i, j] :=  Born;
      drawCell(DC, i, j, Born);
    end
    else
      scratchCells[i, j] := cells[i, j]

  else                         { it's a live cell }

    if (neighbors < 2) or (neighbors > 3) then   { kill it }
    begin
      scratchCells[i,j] := Dead;
      drawCell(DC, i, j, Dead);
    end
    else
      scratchCells[i,j] := cells[i,j];
end;

{ Mutate all of the visible cells }
procedure TLifeCells.mutate(DC:HDC);
var i, j : Integer;
begin
  for i:= 1 to cols do
    for j := 1 to rows do
      mutateCell(DC, i, j);
  { update the real matrix }
  cells := scratchCells;
end;


{--------------------------------------------------}
{ TLifeWindow's method implementations:            }
{--------------------------------------------------}

{ Initialize all fields to starting values, set attributes }
constructor TLifeWindow.Init(AParent: PWindowsObject; ATitle: PChar);
begin
  TWindow.Init(AParent, ATitle);
  cells.init;
  running := False;
  speed := 500;
  grid := True;
  gridSize := 20;
  cells.gridSize := 20;
  mouseDown := False;
  with attr do
  begin
    w:=400;          { Force window size }
    h:=300;
  end;
end;

{ Override default cursor, icon, menu and style }
procedure TLifeWindow.GetWindowClass(var WndClass: TWndClass);
begin
  TWindow.GetWindowClass(WndClass);
  WndClass.Style := CS_DBLCLKS;    { Respond to double click }
  WndClass.hCursor := LoadCursor(hInstance, 'LifeCur');
  WndClass.hIcon := LoadIcon(hInstance, 'LifeIco');
  WndClass.lpszMenuName := 'LifeMenu';
end;

{ Create a display context for drawing and mutate the cells.
  Use a white pen for the border, then set it back when done. }
procedure TLifeWindow.wmTimer(var Msg: TMessage);
begin
  mutateDC:=getDC(HWindow);
  selectObject(mutateDC, GetStockObject(White_Pen));
  cells.mutate(mutateDC);
  selectObject(mutateDC, GetStockObject(Black_Pen));
  releaseDC(HWindow, mutateDC);
end;

{ Single step by stopping the timer and then mutate once }
procedure TLifeWindow.Trace(var Msg: TMessage);
var DC : HDC;
begin
  stop(Msg);
  wmTimer(Msg);
end;

{ Randomly create a starting pattern }
procedure TLifeWindow.Randomize(var Msg: TMessage);
var i, j : integer;
begin
  clear(Msg);
  for i:= 1 to cols do
    for j := 1 to rows do
      if random(100) < 25 then
    cells.setCell(i, j, born);
  invalidateRect(HWindow, nil, True);
end;

{ Create a non-random starting pattern }
procedure TLifeWindow.Bloom(var Msg: TMessage);
var i, j : Integer;
begin
  clear(Msg);
  for i := 0 to cols div 7 do
    for j := 0 to rows div 7 do
    if not odd(i+j) then
      cells.bloom(4+I*7, 2+j*7);
  invalidateRect(HWindow, nil, True);
end;

{ Create a non-random starting pattern }
procedure TLifeWindow.Walker(var Msg: TMessage);
var i, j : Integer;
begin
  clear(Msg);
  for i := 0 to cols div 7 do
    for j := 0 to rows div 7 do
    if not odd(i+j) then
      cells.Walker(2+I*7, 2+j*7);
  invalidateRect(HWindow, nil, True);
end;

{ Start the timer and update the menus }
procedure TLifeWindow.Go(var Msg: TMessage);
begin
  if SetTimer(HWindow, 1, speed, nil) <> 0 then
  begin
    running := True;
    modifyMenu(GetMenu(HWindow), cm_Go, mf_ByCommand or mf_Grayed,
           cm_Go, '&Go' + #9 + '^G');
    modifyMenu(GetMenu(HWindow), cm_Stop, mf_ByCommand or mf_Enabled,
           cm_Stop,  '&Stop'+ #9 + '^S');
  end
  else
  begin
    running := False;
    messageBeep(0);
    messageBox(HWindow, 'No timers left to run Life;' + #13 +
                        'Close some windows and retry!' ,
                        'Error', mb_Ok + mb_IconStop);
  end;
end;

{ Stop the timers and update the menus }
procedure TLifeWindow.Stop(var Msg: TMessage);
begin
  modifyMenu(GetMenu(HWindow), cm_Go, mf_ByCommand or mf_Enabled,
         cm_Go, '&Go'+#9 + '^G');
  modifyMenu(GetMenu(HWindow), cm_Stop, mf_ByCommand or mf_Grayed,
             cm_Stop,  '&Stop'+ #9 + '^S');
  running := False;
  killTimer(HWindow, 1);
end;

{ Exit the program }
procedure TLifeWindow.Exit(var Msg: TMessage);
begin
  postQuitMessage(0);
end;

{ Display About box }
procedure TLifeWindow.About(var Msg: TMessage);
var  Dlg: TDialog;
begin
  Dlg.Init(@Self, 'AboutDlg');
  Dlg.Execute;
  Dlg.Done;
end;

{ Stop current timer, prompt for new speed, restart }
procedure TLifeWindow.Timer(var Msg: TMessage);
var
  inputText: array[0..9] of Char;
  newSpeed, errorPos: Integer;
begin
  stop(Msg);
  str(speed, inputText);
  if application^.ExecDialog(New(PInputDialog,
      Init(@Self, 'Timer Speed', 'Input new time (milliseconds):',
      inputText, sizeOf(inputText)))) = id_Ok then
  begin
    val(InputText, newSpeed, errorPos);
    if errorPos = 0 then
      speed := newSpeed
    else
      messageBeep(0);
  end;
  go(Msg);
end;

{ Stop, clear the matrix, restart }
procedure TLifeWindow.Clear(var Msg: TMessage);
var paused : Boolean;
begin
  paused := running;
  stop(Msg);
  cells.init;
  invalidateRect(HWindow, nil, True);
  if paused then
    go(Msg);
end;

{ Toggle the displaying of the grid and redraw }
procedure TLifeWindow.GridToggle(var Msg: TMessage);
var  style : word;
begin
  grid := not grid;
  if grid then
    style := mf_Checked
  else
    style := mf_Unchecked;
  checkMenuItem(GetMenu(HWindow), cm_Grid, style);
  drawMenuBar(HWindow);
  invalidateRect(HWindow, nil, True);
end;

{ Zoom the display, update internal info then redraw }
procedure TLifeWindow.Zoom(var Msg: TMessage);
begin
  gridSize := gridSize * 2;
  if gridSize > MaxGrid then
    gridSize := MinGrid;
  cols := attr.w div gridSize;
  rows := attr.h div gridSize;
  { update the cells }
  cells.rows := rows;
  cells.cols := cols;
  cells.gridSize := gridSize;
  invalidateRect(HWindow, nil, True);
end;

procedure TLifeWindow.Help(var Msg: TMessage);
var  Dlg: TDialog;
begin
  Dlg.Init(@Self, 'HelpDlg');
  Dlg.Execute;
  Dlg.Done;
end;

{ Respond to Lotus style commands from slash (/) accelerator }
procedure TLifeWindow.CmdMode(var Msg: TMessage);
begin
  sendMessage(HWindow, WM_SYSCOMMAND, $F100, 0);
end;

{ Draw the grid and the cells }
procedure TLifeWindow.Paint(DC: HDC; var PaintInfo: TPaintStruct);
var i : integer;
begin
  selectObject(DC, GetStockObject(Black_Pen));
  if grid then DrawGrid(DC);
  selectObject(DC, GetStockObject(White_Pen));
  cells.draw(DC);
end;

{ Draw the grid background. }
procedure TLifeWindow.DrawGrid(DC: HDC);
var i : integer;
begin
  for i := 1 to rows do
  begin
    moveTo(DC, 0, i*gridSize);
    lineTo(DC, attr.w, i*gridSize);
  end;
  for i := 1 to cols do
  begin
    moveTo(DC, i*gridSize, 0);
    lineTo(DC, i*gridSize, attr.h);
  end;
end;

{ Ensure that cursor is visible even when no mouse }
procedure TLifeWindow.wmSetFocus(var Msg: TMessage);
begin
  ShowCursor(True);
end;

{ Return cursor to previous state for other windows }
procedure TLifeWindow.wmKillFocus(var Msg: TMessage);
begin
  ShowCursor(False);
end;

{ Use keyboard to simulate mouse events.  Accelerator keys
  are handled as response methods. }
procedure TLifeWindow.wmKeyDown(var Msg: TMessage);
var x, y : Integer;
    pos : TPoint;
    key : word;
begin
  { Determine position of cursor in Window }
  getCursorPos(pos);
  screenToClient(HWindow, pos);
  x:=pos.x;
  y:=pos.y;
  { move the cursor position }
  key := Msg.WParam;
  case key of
    VK_UP    : y := y - gridSize;
    VK_DOWN  : y := y + gridSize;
    VK_RIGHT : x := x + gridSize;
    VK_LEFT  : x := x - gridSize;
    VK_HOME  :
      begin
    x := gridSize div 2;
    y := gridSize div 2;
      end;
    VK_END :
      begin
    x := attr.w - gridSize div 2;
    y := attr.h - gridSize div 2;
      end;
    VK_RETURN,
    VK_SPACE :
      begin
        { Simulate mouse pressing at cursor position }
        Msg.LParam := LongInt(pos);
    wmLButtonDown(Msg);
        wmLButtonUp(Msg);
      end;
    end;
    { Update position of cursor in window with clipping }
    if x < 0 then x := gridSize div 2;
    if y < 0 then y := gridSize div 2;
    if x > cols * gridSize then x:= attr.w - gridSize div 2;
    if y > rows * gridSize then y:= attr.h - gridSize div 2;
    pos.x := x;
    pos.y := y;
    clientToScreen(HWindow, pos);
    setCursorPos(pos.x, pos.y);
end;

{ Begin capturing mouse movement when the left button is pressed.
  A display context is taken; it is freed in the wmLButtonUp method. }

procedure TLifeWindow.wmLButtonDown(var Msg: TMessage);
begin
  if not mouseDown then
  begin
    xDown := -1;     { sentinal values to track movement }
    yDown := -1;
    mouseDown := True;
    mouseMoveDC := GetDC(HWindow);
    selectObject(mouseMoveDC, GetStockObject(White_Pen));
  end;
end;

{ Update the cells as the mouse is dragged }
procedure TLifeWindow.WMMouseMove(var Msg: TMessage);
var
 xScreen, yScreen, x, y : Integer;
 state : Boolean;
begin
  if mouseDown then
  begin
    { determine where clicked }
    xScreen := Msg.LParamLo;
    yScreen := Msg.LParamHi;
    { translate into cell coordinates }
    x := xScreen div gridSize;
    y := yScreen div gridSize;
    if (x <> xDown) or (y <> yDown) then      { a new position }
    begin
      { Invert the cell's state, then redraw }
      xDown := x;                             { store position }
      yDown := y;
      state := not(cells.aliveCell(x, y));
      cells.setCell(x, y, state);
      cells.drawCell(mouseMoveDC, x, y, state)
    end;
  end;
end;

{ Stop capturing mouse movement when mouse is released }
procedure TLifeWindow.wmLButtonUp(var Msg: TMessage);
begin
  wmMouseMove(Msg);  { force drawing in same spot }
  if mouseDown then
  begin
    mouseDown := False;
    selectObject(mouseMoveDC, GetStockObject(Black_Pen));
    releaseDC(HWindow, mouseMoveDC);
  end;
end;

{ Turn off the grid on a double click }
procedure TLifeWindow.wmLButtonDblClk(var Msg: TMessage);
begin
  gridToggle(Msg);
end;

{ Zoom when right mouse button is pressed }
procedure TLifeWindow.wmRButtonDown(var Msg: TMessage);
begin
  zoom(Msg);
end;

{ update internal information when resizing then redraw }
procedure TLifeWindow.wmSize(var Msg: TMessage);
begin
  rows := Msg.lParamHi div gridSize;
  cols := Msg.lParamLo div gridSize;
  { update the cells information }
  cells.rows := rows;
  cells.cols := cols;
  attr.h := Msg.lParamHi;
  attr.w := Msg.lParamLo;
  invalidateRect(HWindow, nil, True);
end;

type
  { In the wmGetMinMaxInfo message, LParam points to an
    array [0..4] of Points.  The last one can be set to
    the maximum tracking size. }
  PPointArray = ^TPointArray;
  TPointArray = Array[0..4] of TPoint;

{ Prevent window from becoming larger than maximum array size }
procedure TLifeWindow.wmGetMinMaxInfo(var Msg: TMessage);
var MaxSize : TPoint;
begin
  MaxSize.x := xMax * MinGrid;
  MaxSize.y := yMax * MinGrid;
  PPointArray(Msg.LParam)^[4]:= MaxSize;
end;

{ When the window is destroyed, stop any timers }
procedure TLifeWindow.wmDestroy(var Msg: TMessage);
begin
  KillTimer(HWindow, 1);
  TWindow.WMDestroy(Msg);
end;

{--------------------------------------------------}
{ Main program:                                    }
{--------------------------------------------------}

var
  Life : TLifeApplication;

begin
  Life.Init('PLife');
  Life.Run;
  Life.Done;
end.