Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/OOP-TP55.ZIP/TRIGL.PAS

Pascal/Delphi Source File | 1990-04-16 | 8.2 KB | 296 lines

unit Trigl;
interface

uses ListObj,CRT;

const
MaxGen = 13;

var
   PosStats : array[0..MaxGen] of longint;

type
String15 = string[15];
MoveArray = array[1..3] of integer;
MoveDirection = (no_move, down, up);
MoveFunc = function( i : integer) : MoveDirection;
MoveFuncPtr = ^MoveFunc;

const
MaxNumMove = 18;
LegalMoves : array[1..18] of MoveArray =
             ( (1,2,4),    (1,3,6),    (2,4,7),   (2,5,9),
               (3,5,8),    (3,6,10),   (4,5,6),   (4,7,11),
               (4,8,13),   (5,8,12),   (5,9,14),  (6,9,13),
               (6,10,15),  (7,8,9),    (8,9,10),  (11,12,13),
               (12,13,14), (13,14,15) );

type

{ this would be a great place to have multiple inheritance, what we
really need is an object that acts like both a list and a node }
{ best we can do, then is to have a node with a constituent list
property}

Triangle = object( Node )
           position : String15;
           Offspring : List;
           Generation : integer;
           constructor Init( APosition : String15; Gen : integer );
           destructor Done;
           procedure ShowPosition;
           procedure ShowWin;
           procedure ShowStats;
           function Heuristic : boolean; virtual;
           function FindWin : boolean;
           function FindChildren : boolean;
           function ValidMove( AMove : integer ) : MoveDirection;
           procedure MovePeg( MoveNumber : integer;
                              Direction : MoveDirection;
                              var NewPosition : String15 );
           procedure GenChild( NewPosition : string15 ); virtual;
           function CheckForWin : boolean;
           end;

type
TrianglePtr = ^Triangle;

procedure Step;
procedure InitStats;
procedure DisplayPosition( Position : String15; x, y : integer);

implementation

procedure Step;
var
   Dummy : char;
begin
           Dummy := ReadKey;
end;

destructor Triangle.Done;
begin
     FreeMem( @Offspring, sizeof(Offspring) );
end;

procedure Triangle.ShowWin;
var
   pTriangle : TrianglePtr;
   i : integer;
begin
     if Generation = 0 then
        begin
        ShowPosition;
        Step;
        end;
     if Offspring.Head <> nil then
        begin
        Offspring.Cursor := Offspring.Head;
        pTriangle := Offspring.GetCursor;;
        pTriangle^.ShowPosition;
        Step;
        pTriangle^.ShowWin;
        end;
end;

procedure Triangle.ShowStats;
var
   i : integer;
   t : longint;
begin
     ClrScr;
     t := 0;
     for i := 0 to MaxGen do
         begin
         writeln('Number of generation ', i:2, ' positions: ', PosStats[i]);
         t := t + PosStats[i];
         end;
     writeln;
     writeln('Total number of positions examined: ', t );
     Step;
end;

function Triangle.FindWin : boolean;
var
   pTriangle : TrianglePtr;
   WinFlag  : boolean;
begin
     if FindChildren = true then
        begin
        WinFlag := false;
        OffSpring.Cursor := OffSpring.Head; { point at head }
        while (Offspring.FindNextObject = true) and (WinFlag = false) do
              begin
              pTriangle := OffSpring.GetCursor; { copy head }
              WinFlag := pTriangle^.FindWin;  { find if it leads to win }
              if WinFlag = false then  { if it doesn't }
                 begin
                 pTriangle := Offspring.PopFirst;
                 Dispose( pTriangle, Done );
                 end;
              end;
        FindWin := WinFlag;
        end
     else
        begin
        if CheckForWin = true then { This means that the Self triangle is
                                     a winner! }
           begin
           writeln( 'I found a win!');
           ShowPosition;
           FindWin := true;
           end
        else
           begin
           FindWin := false;
           end;
        end;
end;

{ a triangle node has the ability to find its own children
  if it successfully finds its children, the function returns true.
  if a triangle has no children, then we check to see if a winning
  position has been found. }
function Triangle.FindChildren : boolean;
var
   i : integer;
   vflag : MoveDirection;
   NewPosition : String15;
begin
     FindChildren := false;
     if Heuristic = true then
        for i := 1 to MaxNumMove do
            begin
            vflag := ValidMove(i);
            if vflag <> no_move then
               begin
               Inc(PosStats[Generation+1]);
               MovePeg( i, vflag, NewPosition );
               GenChild(NewPosition);
               FindChildren := true;
               end
            end;
end;

function Triangle.Heuristic : boolean;
begin
        Heuristic := true
end;

{ a triangle knows whether a particular type of move is valid for
  its position.  the function returns NO_MOVE if no move is
  possible, UP if a peg can jump from the 3 position to the 1 position
  (as described in the move array), or DOWN if a peg can jump from
  the 1 to the 3 position. }
function Triangle.ValidMove( AMove : integer ) : MoveDirection;
begin
         if (Position[ LegalMoves[AMove,1] ] = 'X') and
            (Position[ LegalMoves[AMove,2] ] = 'X') and
            (Position[ LegalMoves[AMove,3] ] = 'O') then
            ValidMove := down
         else
            if (Position[ LegalMoves[AMove,1] ] = 'O') and
               (Position[ LegalMoves[AMove,2] ] = 'X') and
               (Position[ LegalMoves[AMove,3] ] = 'X') then
               ValidMove := up
            else
               ValidMove := no_move;
end;

{ given a type of move and a direction (UP or DOWN), a triangle knows
  how to reflect the move in the Position array, and how to create a
  new Triangle object whose position is the new position, and to
  attach the new Triangle object as a member of Offspring list }
procedure Triangle.MovePeg( MoveNumber : integer; Direction : MoveDirection;
                           var NewPosition : String15 );
var
   pNewTriangle : TrianglePtr;
   c : char;
begin
     NewPosition := Position;
     NewPosition[ LegalMoves[MoveNumber, 2] ] := 'O';
     if Direction = down then
        begin
        NewPosition[ LegalMoves[MoveNumber, 1] ] := 'O';
        NewPosition[ LegalMoves[MoveNumber, 3] ] := 'X';
        end
     else
        begin
        NewPosition[ LegalMoves[MoveNumber, 3] ] := 'O';
        NewPosition[ LegalMoves[MoveNumber, 1] ] := 'X';
        end;
end;

procedure Triangle.GenChild( NewPosition : string15 );
var
   pNewTriangle : TrianglePtr;
begin
     New( pNewTriangle, Init( NewPosition, Succ(Generation) ) );
     { if you really want to speed things up, comment out the next line }
     pNewTriangle^.ShowPosition;

     Offspring.Prepend( pNewTriangle );
     Offspring.Cursor := OffSpring.Head;
end;

constructor Triangle.Init( APosition : String15; Gen : integer );
begin
     Position := APosition;
     Offspring.Init;
     Node.Init( SizeOf( Self ) );
     Generation := Gen;
end;

procedure DisplayPosition( Position : String15; x, y : integer);
begin
     gotoXY(x,y);
     writeln( '          ', Position[1]);
     gotoXY(x,y+2);
     writeln( '        ', Position[2], '   ', Position[3] );
     gotoXY(x,y+4);
     writeln( '      ', Position[4], '   ', Position[5],
              '   ', Position[6]);
     gotoXY(x,y+6);
     writeln( '    ', Position[7], '   ', Position[8],
              '   ',  Position[9], '   ', Position[10] );
     gotoXY(x,y+8);
     writeln( '  ', Position[11], '   ', Position[12], '   ',
              Position[13], '   ', Position[14], '   ', Position[15] );
end;

procedure Triangle.ShowPosition;
begin
     gotoXY(16,10);
     writeln( 'Generation: ' , Generation:2 );
     DisplayPosition( Position, 16, 12 );
end;

function Triangle.CheckForWin;
var
   FirstX : integer;
   SubS   : string;
begin
     FirstX := Pos( 'X', Position );
     SubS := Copy( Position, (FirstX+1), 255 );
     if Pos( 'X', SubS ) = 0 then
        CheckForWin := true
     else
        CheckForWin := false;
end;

procedure InitStats;
var
   i : integer;
begin

PosStats[0] := 1;
for i := 1 to MaxGen do
    PosStats[i] := 0;
end;

begin

InitStats;

end.