Programmer 7500/MAX_PROGRAMMERS.iso/CLIPPER/MISC/AIE8907.ZIP/APPRENT.CDE

Text File | 1988-05-04 | 19.5 KB | 642 lines

 ************* HEX2 CODE: ************************


{HEX2 code copyright 1989 Mark Minasi.  All Rights Reserved.}
{$B-}    {Boolean complete evaluation off}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}
{$R+}

Program Hexapawn1;
{This demonstrates a straightforward approach to computer game playing: an
 N level search followed by minimax-based back pruning}


Uses
  Dos;

Const
{$I tconh.ins}

  Black:byte = 2;
  White:byte = 1;
  MoveDirection:array[1..2] of integer=(-1,1);
  Computer = 10;
  Human = 11;
  Neither:byte =3;
  names:array[1..3] of string[9]=('White','Black','Neither');

  Expanded = 1;
  Unexpanded = 2;
  BigWin = 32000;
  BigLoss = -32000;
  UnEvaluated = -Maxint;
  {Change the next three things to alter the dimension of the board}
  BD = 4; {Board Dimension}
  emptyctype='';

{Note on players and sides:

  sides are indicated by a byte, 1=white, 2=black 3=neither.
  we know which are computer & which are human with player[].
  player[1]=player[white]=computer, value 10, or human, value 11.
  player[2] ditto.}

Type CType = array[1..BD,1..BD] of byte;
     B2    = array[1..2] of byte;
     {$i ttyph.ins}

Var

{$I tvarh.ins}
Player:                                B2;
WhoWon:                                byte;
CurrentBoard:                          Ctype;
Nlevels:                               Integer; {Number of levels to search}
T1,T2:                                 Real; {for timekeeping}
LastFound:                             Integer; {used to speed up search}
Side:                                  Byte;

{$I tprch.ins}
{$I time.ins}

Procedure Init(var CurrentBoard:Ctype);
Var I,J:Integer;
Begin
  {Set up Board}
  For I:=1 to BD Do For j:=1 to BD do CurrentBoard[I,J]:=Neither;
  For J:=1 to BD Do
  begin
    CurrentBoard[1,J]:=Black;
    CurrentBoard[BD,J]:=White;
  end;
  LastFound:=Root; {initialize for search}
  Assign(outfile,'');
  Rewrite(outfile);
End;

Function Opposite(Side:byte):byte;
Begin
  If Side=White then Opposite:=Black
  Else If Side=Black then Opposite:=White
  Else Writeln('ERROR IN OPPOSITE.  ASKED FOR SIDE=',Side);
End;

Procedure ShowBoard(Board:Ctype);
Var I,J:Integer;
x:byte;
{Prints out the selected board string}
Begin
  For I:=1 to BD do
  begin
    for j:=1 to bd do
    begin
      x:=board[i,j];
      if x=white then write('W')
      else if x=black then write('B')
      else if x=neither then write('[')
      else write('?');
    end;
    writeln;
  end;
end;

Procedure ChooseColor(var player:b2);
Var Answer:char;
Begin
  Write('Should the computer play white? ');
  Readln(answer);answer:=upcase(answer);
  if answer='Y' then player[white]:=computer else player[white]:=human;

  Write('Should the computer play black? ');
  Readln(answer);answer:=upcase(answer);
  if answer='Y' then player[black]:=computer else player[black]:=human;
End;


Procedure Convert(TestBoard:Ctype;Var B:Ctype;Var BSum,WSum:Integer);
Var
  I,J,L: Integer;

Begin;
  {Set up board for ease of analysis}
  BSum := 0;
  WSum := 0;
  B:=TestBoard;
  For I:=1 to BD do
  For J:=1 to BD do
  begin
    if b[i,j]=black then bsum:=bsum+1 else
    if b[i,j]=white then wsum:=wsum+1;
  end;
End;

Function Evaluate1(Board:Ctype;Side:byte):Integer;
{Basic evaluation function}
{Returns the integer evaluation function value for a given board position
 and a given side.}
Var
  Enemy:                 byte;
  I,j,sum:               Integer;
Begin
  {Presumably, this position has already been checked for a win.
   Therefore, this must be an intermediate position.}
  Sum:=0;
  Enemy := Opposite(Side);
  for i:=1 to bd do for j:=1 to bd do
  if board[i,j]=side then sum:=sum+1 else if board[i,j]=enemy then
  sum:=sum-1;
  Evaluate1 := sum;
End;

Function Evaluate2(Board:Ctype;Side:byte):Integer;
{Aggressive evaluation function}
{Returns the integer evaluation function value for a given board position
 and a given side.}
Var
  Enemy:                 byte;
  I,j,sum,attack,i1:               Integer;
Begin
  {Presumably, this position has already been checked for a win.
   Therefore, this must be an intermediate position.}
  Sum:=0;
  Attack:=0;
  Enemy := Opposite(Side);
  for i:=1 to bd do for j:=1 to bd do
  begin
  if board[i,j]=side then sum:=sum+1 else if board[i,j]=enemy then
  sum:=sum-1;
  if (board[i,j]=side) and (i+MoveDirection[Side]>0) and
  (i+MoveDirection[Side]<=BD)  then
  begin
    i1:=i+MoveDirection[Side];
    if (j+1<=BD) and (board[i1,j+1]=enemy) then attack:=attack+1;
    if (j-1>0) and (board[i1,j-1]=enemy) then attack:=attack+1;
  end;
  end;
  Evaluate2 := 4*sum+attack;
End;

Function Won(B1:Ctype;WhosMove:byte):byte;
{Examines board TestBoard to see, given that WhosMove just moved, whether or
 not WhosMove just won.}

Var
  CheckedColor,SoFar : byte;
  B:                    Ctype;
  I,J,L,BSum,WSum,DI: Integer;
  Iplus, jright, jleft:integer;
  istart,iend:integer;
  AllBlocked, blackback, whiteback:               boolean;
Begin
  SoFar := Neither;

  {check back row}
  j:=1;
  repeat
    if b1[1,j]=white then sofar:=white else if b1[bd,j]=black then sofar:=black;
    j:=j+1;
  until (J>BD) or (SoFar<>Neither);

   {check for blocked moves}
   If SoFar = Neither Then
   Begin
      {Check for blocked pieces}
      CheckedColor := Opposite(WhosMove);
      if CheckedColor=white then
      begin
        istart:=2;iend:=4;
      end else
      begin
        istart:=1;iend:=3;
      end;
      DI := MoveDirection[CheckedColor];
      AllBlocked := True;
      For I:=1 to BD Do
        For J:=1 to BD Do
        Begin     {check piece at i,j}
          If b1[I,J] = CheckedColor Then
          Begin  {Look to see if the piece cannot move}
            Iplus := I+DI;
            Jleft := J-1;
            Jright := J+1;
            If (b1[iplus,j]<>whosmove)
                                          {white not in front}
            Or ((jleft>0) and (jleft<=bd) and (b1[iplus,jleft]=whosmove))
                                          {white to right and ahead}
            Or ((jright>0) and (jright<=bd) and (b1[iplus,jright]=whosmove))
                                          {white to left and ahead}
            Then Allblocked:=False;
          End;
        End;     {Checking piece at i,j}

      If AllBlocked Then SoFar := WhosMove;
    End; {Looking for blocked pieces}


  if SoFar=Neither Then
  begin
    Convert(B1,B,BSum,WSum);
    {Check to see if either side is depleted}
    If BSum = 0 Then SoFar := White
    Else If WSum = 0 Then SoFar := Black;
  end;

  Won:=SoFar;
End; {Procedure}

Procedure Mirror(Board:Ctype;var B:Ctype);
{Given a board, it inverts it about the middle column}
var
    I,J,MJ,Bsum,Wsum:Integer;
    NSwaps:Integer;
    T: Byte;

Begin
  NSwaps := BD div 2;
  B:=Board;
  For J:=1 To NSwaps Do
  Begin
    MJ := BD + 1 - J;
    For I:=1 To BD Do
    Begin
      T:=B[I,J];
      B[I,J]:=B[I,MJ];
      B[I,MJ]:=T;
    End;
  End;
End;


Procedure CheckBeforeAdding(NewBoard:Ctype;Var OkayToAdd:Boolean;
                            PreviousMove:Integer);
{This is where any kind of control strategy would go.  In the particular
 case of Hexapawn, you can never have an ancestor identical to a descendant
 node, as no moves are irreversible.  However, to reduce the tree, no
 siblings will be allowed that are mirror images of each other.
 PreviousMove is the node number of the previous board position.}

Var
  RBoard :Ctype;
  I,J,N:      Integer;
  temp:ctype;
  match:boolean;
Begin

OkayToAdd:=true;

(*  Mirror code seems useless, so it's commented out *)
  Mirror(NewBoard,RBoard);
  N := FirstOffspring(PreviousMove);
  OkayToAdd:=True;
  While (N<>Null) and (OkayToAdd) Do
  Begin
    Characteristic(N,Temp);
    match:=true;
    for i:=1 to bd do for j:=1 to bd do
     if temp[i,j]<>rboard[i,j] then match:=false;
    If match Then OkayToAdd:=False;
    N:=RSibling(N);
  End;


End;


Procedure ConsiderMove(I,J:Integer;MoveNum:integer;B:Ctype;ThisSide:byte;
         Var FilledTree:Boolean;PreviousMove:Integer;OriginalSide:byte;
         Nlevels:integer);
{Consider move number MoveNum from location (I,J) on the board.
 Other useful information is the side that is doing the moving (ThisSide),
 whether or not this move fills the tree (FilledTree), and what was the node
 number of the previous move (PreviousMove).  OriginalSide is the side that is
 doing the analysis.}

Const
  DJ: array[1..3] of integer = (0,1,-1);
Var
  A: Ctype;
  CanDo,  OkayToAdd: boolean;
  MD, IP,NN                : integer;
  NewBoard        :  Ctype;
  WinFlag:               byte;
Begin
  FilledTree:=False;
  CanDo := False;
  MD := MoveDirection[ThisSide];
  IP := I + MD;
  {Is the proposed move possible?  Is there a blank space to occupy or an
   enemy to attack?}
  If (MoveNum=1) and (B[IP,J]=Neither) Then CanDo := True;
  If ((J+1)<=BD) and (MoveNum=2)
                 and (B[IP,J+1]=Opposite(ThisSide)) Then CanDo := True;
  If ((J-1)>0) and (MoveNum=3)
                and (B[IP,J-1]=Opposite(ThisSide)) Then CanDo := True;
  If CanDo Then
  Begin
    A := B;                  {Set up A to receive new board position}
    A[I,J] := Neither;
    A[IP,J+DJ[MoveNum]] := ThisSide;
    NewBoard:=A;
    {Control Strategies}
    CheckBeforeAdding(NewBoard,OkaytoAdd,PreviousMove);
    If OkaytoAdd Then
    Begin              {Adding node to tree}
      CreateNode(PreviousMove,NewBoard,NN);
      If NN=Null then FilledTree := True Else
      Begin {Check to see if the new node is a terminal node.  This would be
             either due to its being at maximum depth, or a "game over" node.}
        WinFlag := Won(NewBoard,ThisSide);
        If (Depth(NN) = Nlevels) or (WinFlag<>Neither) Then
        Begin   {This is a terminal node.  Set its value}
          SetValue(NN,Expanded);
          If WinFlag=Neither Then SetGValue(NN,UnEvaluated) else
          If WinFlag=OriginalSide Then SetGValue(NN,BigWin-Depth(NN)) else
          {See Note 1, end of program}
          If WinFlag=Opposite(OriginalSide) Then
                   SetGvalue(NN,BigLoss+Depth(NN));
        End Else
        Begin {Non terminal node}
          SetValue(NN,Unexpanded);
          SetGValue(NN,UnEvaluated);
        End
      End {Tree not filled, marking nodes};
    End {adding to tree} ;
  End {"Can Do" clause};
End;

Procedure Expand(N:Integer;OriginalSide:byte;var treefull:boolean;
                 Nlevels:integer);
label escape;
Const
  NMoves = 3;
{ This expands node N, producing all of its offspring nodes.  Any control
  strategies are implemented here.  One such in Hexapawn would be to remove
  mirror images among siblings.
When done, sets node N to "expanded."
Generated offspring are set to "unexpanded" unless they are terminal nodes or
at max depth, in which case they are set to "expanded".
}
Var
  ThisSide:                        byte;
  B:                               Ctype;
  Bsum,Wsum,I,J,K:                 Integer;
  Board:                           Ctype;

Begin
  If N=Null then writeln('Error in Expand.  Null node ',N,' passed.');
  {First, we've got to know which side is doing the moving.}
  If Odd(Depth(N)) Then ThisSide := Opposite(OriginalSide)
                   Else ThisSide:=OriginalSide;
  Characteristic(N,Board);
  Convert(Board,B,Bsum,Wsum);
  {Find the pieces, then see if they can move}
  For I:=1 to BD do For J:=1 to BD Do
  Begin
    If B[I,J]=ThisSide Then For K:=1 to Nmoves Do
    begin
      ConsiderMove(I,J,K,B,ThisSide,TreeFull,N,OriginalSide,Nlevels);
      If TreeFull Then Goto Escape;
    end;
    SetValue(N,Expanded);
  End;
escape:
End;

Procedure FindFirst(Var N:integer);
Var
  M:         Integer;
  Alldone:   Boolean;
{ Locates first unexpanded node.  This version uses a depth-first search.}
{starts from last created node}
Begin
  M:=Lastfound;
  Alldone:=False;
  While not Alldone do
  Begin
    If M=Null then Alldone:=True else
    Begin
      If NodeValue(M) = Unexpanded then Alldone:=True else M:=NextNode(M);
    End;
  End;
  N:=M;
  LastFound:=N;
End;

Procedure Gentree(var Nlevels:Integer;Side:byte);
{Generates a game move tree Nlevels deep for side Side}
Var
  N:Integer;
  AllDone:Boolean;
  Treefull:boolean;
Begin
Repeat
  Treefull:=False;
  LastFound:=Root; {so search is initialized properly}
  Inittree;
  SetCharacteristic(Root,CurrentBoard);
  SetValue(Root,Unexpanded);
  SetGValue(Root,Unevaluated);
  Alldone:=false;
  While (not Alldone) and (not TreeFull) Do
  Begin        {main loop}
    {Find first unexpanded node.}
    FindFirst(N);
    IF N=Null then Alldone:=True Else
    Begin      {expand node n}
      Expand(N,Side,TreeFull,Nlevels);
      If treefull then
      begin    {reduce search depth}
        Nlevels:=Nlevels-1;
        writeln('GENTREE:Tree overflow.  Reducing plies temporarily to ',
               nlevels);
        LastFound:=Root; {reset this or the thing goes crazy}
      end;     {reduce search depth}
    end;       {expand node n}
  End;         {main loop}
Until Not Treefull;
End;

Procedure GetInputMove(var Board:Ctype;Side:byte);
{Gets latest move from human player.  Checks for validity of moves}
Var Valid:boolean;
    Row1,Row2,Column1,Column2:Integer;
    EN:                       Integer;
Begin
  EN := 0; {No errors to start}
  Repeat
    Valid:=True;
    If EN<>0 Then Writeln('Encountered error number ',EN);
    EN := 0;
    write(names[side]);
    writeln(' moves.');
    Writeln('Please enter the source and destination row & column for the',
          ' piece to move.');
    Write('(separate row/col with a space, like "3 3 2 3" ? ');
    Readln(Row1,Column1,Row2,Column2);
    {Check validity}
    If (Row1<1) or (Row1>BD) or (Column1<1) or (Column1>BD) or (Row2<1) or
       (Row2>BD) or (Column2<1) or (Column2>BD) Then
                                     Begin Valid:=False;EN:=1;End;
    If Valid Then If (board[Row1,Column1] <> Side)
             Then Begin Valid:=False;En:=2;End;
    {Check that the piece exists to move}
    If Valid Then If MoveDirection[Side] <> (Row2-Row1)
             Then Begin Valid := False; EN:=3;End;{Check Move direction}
    If Valid Then If (Column1=Column2) And (board[Row2,Column2] <>
              Neither) Then Begin Valid:=False; EN:=4;End;
               {Must move forward to open square}
    If Valid Then If (Column1<>Column2) and (board[Row2,Column2]
              <> Opposite(Side)) Then Begin Valid:=False;EN:=5;End;
               {Must attack enemy only}
  Until Valid;
  Writeln('Valid Move.');
  {Register Change in Board}
  Board[Row1,Column1] := Neither;
  Board[Row2,Column2] := Side;
End; {Procedure}

Procedure Minimax(Var Board:Ctype;Side:byte;BottomLevel:Integer);
{Side is the side that is currently moving}
Const
  Maximum = 10;
  Minimum = 11;
Var
  TempNV,N,Lev,F,NN:          Integer;
  Temp:ctype;
  MoveFound:boolean;

  Procedure FindOptOffspr(Node:Integer;Var BestValue,BestNode:Integer;
                          Direction:Integer);
  {Searches all offspring of node Node to find optimal (minimum or maximum)
   G values.  Best G value and node where it was found are stored in BestValue
   and BestNode.  Direction indicates whether to find minimum or maximum.}
  Var
    N,X,BestSoFar,BestNodeSoFar,Factor:            Integer;
  Begin
    N:=FirstOffspring(Node);
    If Direction=Maximum Then BestSoFar :=-Maxint Else BestSoFar := Maxint;
    BestNodeSoFar := Null;
    While N<>Null Do    {Search all offspring}
    Begin
      X := GValue(N) ;
      If ((X > BestSoFar) and (Direction=Maximum)) Or ((X < BestSoFar) and
                                        (Direction=Minimum)) Then
      Begin
        BestSoFar := X;
        BestNodeSoFar := N;
      End;
      N:=RSibling(N);
    End; {Search all offspring}
    BestNode := BestNodeSoFar;
    BestValue := BestSoFar;
    If BestNode = Null then Writeln('Warning: No moves found in',
     ' FindOptOffspr');
  End; {Procedure}

Begin
  MoveFound:=False;
  {First, evaluate the bottom level}
  N := FirLevel(BottomLevel);
  If N=Null Then Writeln('No bottom level (',bottomlevel,') found in ',
                          'Minimax.');
  While N<>Null Do
  Begin
    If GValue(N)=Unevaluated Then
    begin
      Characteristic(N,Temp);
      if side=white then TempNV:=Evaluate1(Temp,Side)
                    else TempNV:=Evaluate2(Temp,Side);
      {black uses more aggressive approach}
      SetGValue(N,TempNV);
    end;
    N := NNTL(N);
  End;
  {Now do the folding/pruning process}
  Lev := Bottomlevel - 1;
  While Lev >= 0 Do
  Begin
    {For each node on this level that is not already evaluated (nonterminal
     nodes), fold the offspring values into the node.}
    N := FirLevel(Lev);
    While N<>Null Do
    Begin
      If Gvalue(N)=Unevaluated Then
      Begin
        {Alternate looking for maxima and minima}
        If Odd(Lev) Then FindOptOffspr(N,F,NN,Minimum)
                    Else FindOptOffspr(N,F,NN,Maximum);
        {In case this isn't clear, recall (for instance) that the root is
         at depth = 0.  Here, we examine the descendants of the root and
         look for the maximum.}
        SetGValue(N,F);
        {If level = 0, this is the final pass.  Save the result.}
        If Lev=0 Then
        begin
          Characteristic(NN,Board);
          MoveFound:=true;
        end;

      End;
      N:=NNTL(N); {Get next node on this level}
    End;          {Until finished with this level}
    Lev := Lev - 1;
  End; {Get next level}
  If not movefound then writeln('No move found in Minimax.');
End; {Procedure}


Procedure ComputeAMove(var Board:Ctype;Side:byte;Nlevels:integer);
Begin
  writeln('Computing move for ',names[side],'.');
  T1 := Time;
  Gentree(Nlevels,Side); {Generates move tree}
  Minimax(Board,Side,Nlevels); {Returns new board position}
  T2 := Time;
  Writeln('Computed value of move: ',GValue(Root),'.  ',NNodes,
  ' examined.  Required ',(t2-t1):7:2,' seconds.');
End;

Procedure MoveSide(Side:byte;var CurrentBoard:ctype);
Var
  NewBoard:                    Ctype;

{This routine moves the white pieces and checks for win}
Begin
  If Player[Side]=Human then
    GetInputMove(CurrentBoard,Side)
  Else
    ComputeAMove(CurrentBoard,Side,Nlevels);
End;


Begin
  debug[1]:=false;debug[2]:=true;debug[3]:=true;
  Init(Currentboard);

  Write('How many plies to examine? ');Readln(Nlevels);
  ChooseColor(player);  {which roles should computer play?}
  ShowBoard(Currentboard);
  Side:=White;
  Repeat
    MoveSide(Side,CurrentBoard);
    ShowBoard(CurrentBoard);
    WhoWon:=Won(CurrentBoard,Side);
    Side:=Opposite(Side);
  Until WhoWon<>Neither;

  Writeln(names[WhoWon],' has won.');
End.

{Note 1: This is an interesting bug.  You have to do something to make the
 program choose an earlier win rather than a later win.  If it has two paths
 available, both of which guarantee win, it'll take whichever the first it
 sees is.  There may be a one-move path to win, and a three-move path to win,
 and it takes the three move path.  Note that it's not really a bug -- it will
 win either way -- but it does look peculiar.  In fact, it looks a little
 sadistic, choosing to let the victim "twist slowly in the wind."

 Similarly, once the program sees that it will lose for sure, it picks the
 loss that is quickest.  This is dumb, so re-score losses to loss+depth}

ram sees that it will lose for sure, it picks t