sandpile.pas

模拟2维沙堆效果

unit Sandpile;
// The sandpile logic (representation and rules of pile)

interface

uses
  SandQue;

const
  ArrayXY = 255;             // Max height and width for a sandpile

type
  TPile = class
  private
    FSize: Byte;             // Size of sandpile as specified by user
  public
    Grid: array[0..ArrayXY, 0..ArrayXY] of 0..8; // Zero-based array of grains
    GrainsAdded, GrainsToppled, GrainsLost: Longint; // Applies to all rounds
    DeltaToppled, DeltaLost: Longint;                // Applies to last round
    property Size: Byte read FSize;
    constructor Create(SizeXY: Byte);
    procedure AddGrain(X, Y: Integer);
    function IsCritical(X, Y: Integer): Boolean;
    procedure Topple(X, Y: Integer; var Q: TQueue);
  protected
    function OnSurface(X, Y: Integer): Boolean;
  end;

  PField = ^TField;          // Used as queue element
  TField = record
    X, Y: Integer;
  end;

implementation

{---------------------- TPile -------------------------}

constructor TPile.Create(SizeXY: Byte);
var
  I, J: Byte;
begin
  inherited Create;
  FSize := SizeXY;            // Set size of sandpile

  GrainsAdded   := 0;
  GrainsToppled := 0;
  GrainsLost    := 0;
  DeltaToppled  := 0;
  DeltaLost     := 0;
  // Clear the Grid array
  for I := 0 to FSize-1 do
    for J := 0 to FSize-1 do
      Grid[I,J] := 0;
end;


procedure TPile.AddGrain(X, Y: Integer);
begin
  Inc(GrainsAdded);          // 1 grain added
  DeltaToppled := 0;         // No points toppled yet in this round
  DeltaLost    := 0;         // No grains lost yet in this round
  if OnSurface(X, Y) then
    Inc(Grid[X,Y]);
end;


function TPile.IsCritical(X, Y: Integer): Boolean;
begin
  IsCritical := (Grid[X,Y] > 4);  // Is local height > 4 ?
end;


function TPile.OnSurface(X, Y: Integer): Boolean;
// Checks if we're inside the pile's size limits.
// Remember that the pile array is zero-based.
begin
  if (X >= 0) and (X <= FSize-1) and
     (Y >= 0) and (Y <= FSize-1) then   // On surface
    OnSurface := True
  else                                 // Not on surface
  begin
    OnSurface := False;
    Inc(GrainsLost);         // 1 grain has fallen off the surface
    Inc(DeltaLost);
  end;
end;


procedure TPile.Topple(X, Y: Integer; var Q: TQueue);
var
  Field: PField;
  GoX, GoY: Integer;
  I: 1..4;
begin
  Inc(GrainsToppled);             // Point (X,Y) is toppled
  Inc(DeltaToppled);
  Grid[X,Y] := Grid[X,Y] - 4;     // Remove 4 grains from (X,Y)

  for I := 1 to 4 do
  begin
    case I of
      1: begin
           GoX := X;              // (GoX,GoY) is neighbor of (X,Y)
           GoY := Y-1;
         end;
      2: begin
           GoX := X;
           GoY := Y+1;
         end;
      3: begin
           GoX := X-1;
           GoY := Y;
         end;
      4: begin
           GoX := X+1;
           GoY := Y;
         end;
    end;

    if OnSurface(GoX, GoY) then   // Is (GoX,GoY) inside the array?
    begin
      Inc( Grid[GoX,GoY] );       // (GoX,GoY) gets 1 extra grain
      New(Field);
      Field^.X := GoX;
      Field^.Y := GoY;
      Q.Enqueue(Field);           // Insert (GoX,GoY) in the queue
    end;

  end;
end;

end.