Programmer 7500/MAX_PROGRAMMERS.iso/CLIPPER/MISC/AIE8906.ZIP/AIAPP.CDE

Text File | 1988-05-04 | 28.0 KB | 1,021 lines

Date:  03-Apr-89 18:26 PDT
From:  Marc Rettig [76703,1037]
Subj:  Minasi Code


************* HEX.PAS CODE FOLLOWS *************************


{Hexapawn version 2.0}
{Copyright 1989 Mark Minasi}
{written for Turbo Pascal versions 5.0 or 4.0}

{$B-}    {Boolean complete evaluation off}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}

Program Hexapawn;
{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 = 'B';
  White = 'W';
  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='';

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

Var

{$I tvarh.ins}
Human, Computer,Side:                  char;
WhoWon:                                Char;
CurrentBoard:                          Ctype;
Nlevels:                               Integer; {Number of levels to search}
T1,T2:                                 Real; {for timekeeping}
LastFound:                             Integer; {used to speed up search}

{$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:char):char;
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;
{Prints out the selected board string}
Begin
  For I:=1 to BD do
  begin
    for j:=1 to bd do write(board[i,j]);
    writeln;
  end;
end;

Procedure ChooseColor(var computer,human:char);
Var Answer:char;
Begin
  Write('Would you like to go first? ');
  Readln(Answer);Answer:=UpCase(Answer);
  If Answer='Y' then Begin
                       Human:=White;
                       Computer:=Black;
                     End Else
                     Begin
                       Human:=Black;
                       Computer:=White;
                     End;
End;

Function MoveDirection(Side:char):Integer;
Begin
  If Side=White then MoveDirection:=-1
  Else If Side=Black Then MoveDirection:=1
  Else Writeln('Error query to MoveDirection.  Side=',Side);
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 Evaluate(Board:Ctype;Side:char):Integer;
{Returns the integer evaluation function value for a given board position
 and a given side.}
Var
  Enemy:                 char;
  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;
  Evaluate := sum;
End;

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

Var
  SoFar : char;
  B:                    Ctype;
  I,J,L,BSum,WSum,DI: Integer;
  Iplus, jright, jleft:integer;
  CheckedColor:char;
  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: Char;

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:char;
         Var FilledTree:Boolean;PreviousMove:Integer;OriginalSide:char;
         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:               Char;
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
          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:char;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:                        char;
  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:char);
{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:char);
{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;
    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:char;BottomLevel:Integer);
Const
  Maximum = 10;
  Minimum = 11;
Var
  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);
      SetGValue(N,Evaluate(Temp,Side));
    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:char;Nlevels:integer);
Begin
  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:char;var CurrentBoard:ctype);
Var
  NewBoard:                    Ctype;

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


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

  Write('How many plies to examine? ');Readln(Nlevels);
  ChooseColor(Computer,Human);  {Play white or black?}
  ShowBoard(Currentboard);
  Side:=White;
  Repeat
    MoveSide(Side,CurrentBoard);
    ShowBoard(CurrentBoard);
    WhoWon:=Won(CurrentBoard,Side);
    Side:=Opposite(Side);
  Until WhoWon<>Neither;
  If WhoWon=Computer then Writeln('I have won.')
                     else Writeln('You have won.');
End.



*************** TCONH.INS FOLLOWS **********************

(* Insert file for main Constant section *)
     null = 0;
     root = 1;
     maxsize=15000; {maximum # of records that nodelist can handle}


*************** TTYPH.INS FOLLOWS **********************


{Insert file for type section}

  NodeType = Record
               Parnt,   {node # of parent}
               Levl,    {depth of node, 0=root}
               Rsib,    {sibling to the immediate right}
               Foff,    {node # of first offspring}
               GV,
               EvalF:   integer;
               Charact: Ctype;  {user must define ctype}
             end;

  PNodeType = ^NodeType;

*************** TVARH.INS FOLLOWS **********************


(* Insert file for main Vars section *)
    nodelist:                   array[1..maxsize] of PNodeType;
    nnodes:                     integer (* Number of nodes used *);
    debug:      array[1..10] of boolean (* debug print flag *);
               { debug[1] is a general "dump it all" flag.
                 debug[2] reports when every 1000th node is created.
                 debug[3] reports every try to generate a node when tree is
                          full }
    lastnum:                    integer (* speeds up node generation *);
    outfile:                    text    (* Debug output file *);
    maxnode:                    integer  {max # nodes to use};


*************** TPRCH.INS FOLLOWS **********************

(* Insert file for tree handling procedures *)

{Copyright 1989 Mark Minasi}

(* T R E E   R E A D / W R I T E   F U N C T I O N S

   The following six functions and six procedures read from and write to the
   tree's six items of information.  They are:

Item                    Name of Read Function      Name of Write Procedure

Characteristic         Characteristic()            Setcharacteristic()
Parent                 Parent()                    SetParent()
Depth or Level         Depth()                     SetDepth()
Sibling to Right       RSibling()                  SetRSibling()
First Offspring        FirstOffspring()            SetFirstOffspring()
Evaluation Func. Value Nodevalue()                 SetValue()
*)

Function Parent(node:integer):integer;

(* Returns node number of parent to input node number.  Does not check if
   input node number exists. *)


var nn: PNodeType;  {DO NOT say ^NodeType -- Pascal will squawk that it's
                     foreign to PNodeType}

begin
  if debug[1] then if ((node<1) or (node>maxnode)) then
   writeln(outfile,'PARENT:',' requested for illegal node.  Node #=',node);
  nn:=NodeList[node];
  parent:=nn^.Parnt;
end;

Procedure Characteristic(node:integer;var Outc:ctype);

var nn: PNodeType;

begin
  nn:=NodeList[node];
  OutC:=nn^.Charact;
end;

Function Depth(node:integer):integer;

var nn:PNodeType;

begin
  nn:=NodeList[node];
  depth:=nn^.Levl;
end;

Function RSibling(node:integer):integer;

var nn:PNodeType;

begin
  nn:=NodeList[node];
  RSibling:=nn^.RSib;
end;

Function FirstOffspring(node:integer):integer;

var nn:PNodeType;

begin
  nn:=NodeList[node];
  FirstOffspring:=nn^.Foff;
end;

Function NodeValue(node:integer):integer;

var nn:PNodeType;

begin
  nn:=NodeList[node];
  NodeValue:=nn^.EvalF;
end;

Function GValue(Node:Integer):Integer;
Var nn:PNodeType;
Begin
  NN := NodeList[node];
  GValue:=nn^.GV;
End;

Procedure Setcharacteristic(node:integer;i:ctype);

var nn:PNodeType;
begin
  NN := NodeList[node];
  nn^.Charact := i
end;

Procedure SetParent(node,i:integer);

var nn:PNodeType;

begin
  nn:=NodeList[node];
  nn^.Parnt := i
end;

Procedure SetDepth(node,i:integer);

var nn:PNodeType;

begin
  nn:=NodeList[node];
  nn^.Levl := i
end;

Procedure SetRSibling(node,i:integer);

var nn:PNodeType;

begin
  nn:=NodeList[node];
  nn^.Rsib := i
end;

Procedure SetFirstOffspring(node,i:integer);

var nn:PNodeType;

begin
  nn:=NodeList[node];
  nn^.Foff:= i
end;

Procedure SetValue(node,i:integer);

var nn:PNodeType;

begin
  nn:=NodeList[node];
  nn^.EvalF := i
end;

Procedure SetGValue(node,i:integer);

var nn:PNodeType;

begin
  nn:=NodeList[node];
  nn^.GV := i
end;

Procedure Inittree;

(* Initializes tree by resetting root node *)

var i:         integer;
    numrecs:   integer;
    maxrecs:   longint;
    temprec:   NodeType;

begin (* Clean out nodelist*)

  if debug[1] then writeln('INITTREE: Initializing tree.');

  release(heaporg);  {that statement cleans out the heap}
  {How much space do we have?}
  maxrecs:=Maxavail div sizeof(temprec);
  if maxrecs>maxsize then maxnode:=maxsize else maxnode:=maxrecs;
  maxnode:=maxnode-1; {leave a little room}
  if debug[2] then writeln('INITTREE: There is room for ',maxnode,' nodes.',
               ' Maxrecs=',maxrecs);
  {create root}
    GetMem(nodelist[root],sizeof(temprec));
    SetParent(root,null);
    SetRSibling(Root,Null);
    SetFirstOffspring(Root,Null);
    SetDepth(Root,0);
    nnodes:=1;
    lastnum:=2;
    {Set up root: no parents, no offspring.  Using program must set character-
    istic and value. }
  for i:=2 to maxnode do NodeList[i]:=nil;
end;

Function Nextnum:integer;

(* Finds first open space in NODELIST.  Returns -1 if network full.
   Remember not to use the MAXNODEth node. *)

var i:integer;

Begin
{Just keep counting up to the top.}
  i:=lastnum;
  if i>=maxnode then
  begin
    nextnum:=null;
    if (debug[3] or debug[1] or debug[2]) then
    writeln(outfile,'NEXTNUM: >>> Tree Overflow <<');
  end
  else nextnum:=lastnum;
  lastnum:=lastnum+1;
End;

Procedure Createnode(pnode:integer;charn:ctype;var node:integer);

(* Creates a node with parent pnode and characteristic charn.  Node
   number of new node is output unless no nodes are left: if so, node
   = null *)

var tempnode,n:integer;
    temprec:NodeType;

begin

(* Find a node to start from *)

  node:=nextnum;
  if node<>null then
  begin

    (* Register the value in nodelist *)
    GetMem(Nodelist[Node],SizeOf(temprec));
    nnodes:=nnodes+1;
    if debug[2] then if (nnodes mod 1000) = 0 then writeln(outfile,
                      'CREATENODE: Total Nodes: ',nnodes);
    (* Set attributes *)
    setcharacteristic(node,charn);
    setParent(node,pnode);
    setDepth(node,Depth(pnode)+1);
    setRSibling(node,null);
    setFirstOffspring(node,null);
    SetValue(node,null);

    (* Set pointer into node.  Either from parent (if only child) or
       sibling to the left. *)

    if FirstOffspring(pnode)=null then setFirstOffspring(pnode,node)
    else begin
      (* Find closest sibling *)
      tempnode:=FirstOffspring(pnode);
      repeat
        n:=RSibling(tempnode);
        if n=null then setRSibling(tempnode,node) else tempnode:=n;
      until n=null;
    end;
  end else
  begin
    {overflow}
    node:=null;
  end;
  if debug[1] then writeln(outfile, 'CREATENODE: Created node for parent '
                               ,pnode,'.  Node =',node);
end;

{Search routines}

Function Nextnode(node:integer):integer;

(* Finds node number of the next node from the input, for a depthwise
   search.  Returns null if tree exhausted *)

Var n:integer;

Begin

if node=null then nextnode:=null else
if FirstOffspring(node) <> null then nextnode:=FirstOffspring(node)
   else if RSibling(node) <> null then nextnode:=RSibling(node)
        else if Depth(node)<=1 then nextnode:=null
                     { if no offspring, no sibs, and level=1, exhausted }
            else begin
               n:=node;
               repeat
                 n:=Parent(n)
               until (Parent(n)=root) or (RSibling(n) <> null);
               nextnode:=RSibling(n)
             end;
End;


Function NNTL(node:integer):integer;

(* Finds the next node on the same level as input node. Good for level-wise
   search.  Again, returns null if exhausted at this level. *)

Var basedepth,n,d:integer;

Begin

   basedepth:=Depth(node);
   n:=node;
   repeat
     n:=nextnode(n);
     if n<>null then d:=Depth(n) else d:=basedepth;
   until d=basedepth;
   nntl:=n;
if debug[1] then writeln(outfile,' Next node after ',node,' is ',n);
End;

Function NTOL(node:integer):integer;
(* Finds first node after input node that either (1) is the same depth as
   the input node or (2) is terminal (no offspring) and closer to the root
   than the input node.  Returns null if none. *)

Var BaseDepth,N,TempNode,D: integer;
Begin
  BaseDepth:=Depth(node);
  n:=node;
  repeat
    n:=nextnode(n);
    if n<>null then begin
                      d:=Depth(n);
                      TempNode:=FirstOffspring(n);
                    end else begin
                      d:=basedepth;
                      TempNode:=1; (*Any non null value*)
                    end;

  until (d=basedepth) or (TempNode=Null);
  NTOL:=n;
End;


Function Firlevel(level:integer):integer;

(* Finds leftmost node at depth or level = input level *)

var tempnode,dtemp:integer;
begin
if level=0 then tempnode:=root else

  begin
    tempnode:=root;dtemp:=Depth(tempnode);
    while (dtemp<>level) and (tempnode<>null) do
    begin
      tempnode:=nextnode(tempnode);
      if tempnode=null then dtemp:=10000 else dtemp:=Depth(tempnode);
    end;
  end;
firlevel:=tempnode;
if debug[1] then writeln(outfile,'First node at level ',level,' is ',tempnode);
end;

Function BFNextNode(node:integer):integer;
(* Returns next node in breadth first search *)
Var
  n,n1,level:integer;
Begin
  if debug[1] then writeln('Looking for next node after ',node);
  If (NNodes=1) or (node=Null) then BFNextNode:=Null else
  Begin
    n:=nntl(node); (* next node this level *)
    if debug[1] then begin
    write('  NNTL returned ');if n=null then writeln('null.') else
                      writeln(n,'.');
                     end;
    If n<>Null then BFNextNode:=n else
    Begin
      level:=Depth(node) + 1;
      if debug[1] then writeln('  Searching level ',level);
      BFNextNode := FirLevel(level);
    End;
  End;
End;

Procedure PrintTree;
const col = 5;
      spaces:string[40] = '                                        ';
var n,l:integer;

Begin

writeln(outfile);
writeln(outfile,'Number   Charac.  Depth  Value GValue');

n:=root;
while n<>null do
begin
  l:=Depth(n);
  write(outfile,copy(spaces,1,l*2));
  writeln(outfile,n:col,'Chrctc',Depth(n):col,NodeValue(n):col,
          GValue(n):col);

  n:=NextNode(n);
end;
writeln(outfile,nnodes,' total nodes.');
end;