Programmer 7500/MAX_PROGRAMMERS.iso/CLIPPER/MISC/AIE8901.ZIP/AIAPRENT.CDE

Text File | 1988-05-04 | 12.1 KB | 457 lines

The complete listing for the Nuclear reactor simulator code to
accompany AI Apprentice for January 1989.
Copyright 1989 Mark Minassi and AI EXPERT


{$R-}    {Range checking off}
{$B+}    {Boolean complete evaluation on}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}
{$N-}    {No numeric coprocessor}
{$M 65500,16384,655360} {Turbo 3 default stack and heap}

Program MoveRods;


{AKT Version of rod moving problem converted to Turbo 4.0}

Uses
  Dos;

Const
 maxnode=3000;
 {$I treecons.ins}
 Nrules = 16;             {Problem Specific}
 Goal = 1;
 DeadEnd = 2;
 UnFinished = 3;
 Finished = 4;
 EmptyCType=0;

{Goal State here can be any of four goals:  2534,2543,5234,5243}

Type CType = Integer;

Var
 {$I treevars.ins}

 Hval:                               array[1..maxnode] of integer;
 FoundGoal, Impossible, RuleApplied, FoundEarlier:    Boolean;
 NN, Rule, TestState, GoalNode:                       Integer;
 I, Cost,BestGoalSoFar:                                 Integer;
 OK:                                                  Boolean;
 T1,T2:                                               Real;

 {$I treeproc.ins}

function time:real;
var  h,m,s,t:word;
begin
  gettime(h,m,s,t);
  time := h*3600.0 + m*60.0 + s + t/100.0;
end;

{Routines to allow new node attributes, the G and H functions}


Function HValue(N:integer):integer;
Begin
  HValue:=HVal[Nodelist[N]];
End;

Procedure SetHValue(N,V:integer);
Begin
  HVal[NodeList[N]] := V;
End;

Procedure CheckForGoal(N:integer;Var FoundGoal:boolean);
{This routine is problem specific }
var X:integer;
Begin
  X := Characteristic(N);
  If (X = 2534) or (X = 2543) or (X= 5243) or (X = 5234) then FoundGoal:=True
  else FoundGoal := False;
end;

**********************
Kay: Here starts the function containing the six heuristics
**********************
Function FindH(TestState:Integer):integer;
{This routine is problem specific}
{Computes guess of distance from TestState to the goal}
Var
  X,B1,B2,U1,U2,Uouts,Bouts:integer;
  BB1,UU1,BB2,UU2,B,U:integer;
Begin
  X := Characteristic(NN);
  B1 := X div 1000; X:=X - B1*1000;
  B2 := X div 100; X:= X - B2*100;
  U1 := X div 10;  X:= X - U1*10;
  U2 := X;

  {Count the number of borons and uraniums out of place}
  if (B1<>2) and (B2<>2) then Bouts:=1 else Bouts:=0;
  if (B1<>5) and (B2<>5) then Bouts := Bouts + 1;
  if (U1<>3) and (U2<>3) then Uouts :=1 else Uouts:=0;
  if (U1<>4) and (U2<>4) then Uouts := Uouts+1;

  {First formula in text:  no heuristic}
  {FindH := 0;}

  {Second formula in text:  borons out of place + uraniums out of place}
  {FindH := Bouts + Uouts;}

  {Third formula:  weight the borons and uranium by minimum cost}
  {FindH := Bouts + 4*Uouts;}

  {Fourth:  sum minimum uranium move}
  {FindH := abs(U1 - 3) + abs(U2 - 3) - 1;}

  {Fifth:  Weight the previous}
  {FindH := (abs(U1 - 3) + abs(U2 - 3) - 1)*4;}

  {Sixth:  see text}
  {BB1 := abs(B1-2) + abs(B2-5);
  BB2 := abs(B1-5) + abs(B2-2);
  UU1 := abs(U1-3) + abs(U2-4);
  UU2 := abs(U2-3) + abs(U1-4);
  if BB1<BB2 then B:=BB1 else B:=BB2;
  if UU1<UU2 then U:=UU1*4 else U:=UU2*4;
  FindH:=U+B;}

  Uncomment one of the above before using!
End;
**********************
Kay: That's all.  No more of those.  The rest is cream.
**********************


Procedure CheckAncestry(Test,TestCost:integer;var OK:boolean);
{ Check to see that no node that is an ancestor of N has the same character-
  istics of N}
Var
  M,X:integer;
Begin
  M:=Root;
  OK:=true;
  {Do branch & bound: if we've already found a goal node that is easier to
   get to than this node, there's no point in considering this node}
  If TestCost >= BestGoalSoFar Then OK:=False Else
  Begin
    While (M<>Null) and OK do
      If (Characteristic(M)=Test) and (TestCost>=GValue(M)) then OK:=false
      else M := NextNode(M);
  End;
End;


Function BestUnfinished:integer;
var n,bestf,BestNode,F:integer;
    FoundOne,ExhaustedTree:boolean;
Begin
  { Find unfinished node with minimum value of g(node)}
  if debug[5] then writeln(outfile,'  Started Search for best unfinished');
  N := Root;
  BestF := 1000;
  While N<>Null Do
  Begin
    F := GValue(N) + HValue(N);
    If (F < BestF) and (NodeValue(N)=Unfinished) Then
    Begin
      BestNode:=N;
      BestF:=F;
    End;
    N:=NextNode(N);
  End;
  If BestF = 1000 then BestUnfinished:=Null else BestUnfinished:=BestNode;
  if debug[5] then writeln(outfile,'  Ended search for best unfinished.');
End;

Procedure ApplyRule(Rule,NN:integer;var RuleApplied:boolean;var TestState:
                    integer; var Cost:Integer);

{This entire procedure is problem specific}

{ Applies input rule Rule to node NN, if possible.  If it was possible,
  reports in RuleApplied.  New state is in TestState}


Var

    X,G3,G4,T:                  Integer; (* current state of jugs *)
    Reactor:                    array[0..7] of integer;
    N,B1,B2,U1,U2: Integer;

Function NextHole(Strt,Direction:integer):integer;
Var
  NH, J: integer;
  NotFound:boolean;

Begin
  If ((direction = 1) and (Strt = 6)) or ((direction = -1) and (Strt = 1))
  Then NH:=0 Else
  if reactor[Strt+direction]=0 then NH:=0 else
  Begin
    NotFound:=true;
    J:=Strt + direction;
    While (j>0) and (J<7) and NotFound do
       If Reactor[J] = 0 then
       begin
         NH := J;
         NotFound:=False;
       end else J:=J+direction;
    If NotFound then NH:=0;
  End;
  NextHole:=NH;
End;

Begin

  RuleApplied:=False;
  {Decode state}
  X := Characteristic(NN);
  If Debug[4] then writeln(outfile,'  Applying rule ',rule,' to ',X);
  For I:=1 to 6 do Reactor[i]:=0;reactor[0]:=1;reactor[7]:=1;
  B1 := X div 1000; X:=X - B1*1000;
  B2 := X div 100; X:= X - B2*100;
  U1 := X div 10;  X:= X - U1*10;
  U2 := X;
  reactor[B1]:=1;
  reactor[B2]:=1;
  reactor[U1]:=1;
  reactor[U2]:=1;
  If debug[4] then writeln(outfile,'  States: B1/2, U1/2=',B1,' ',B2,' ',U1
                           ,' ',U2);

  Case Rule of
      1: If (B1>1) and (Reactor[B1-1]=0) then
         begin
           B1:=B1-1;
           Cost:=1;
           RuleApplied:=True;
         end;
      2: If (B1<6) and (Reactor[B1+1]=0) then
         begin
           B1:=B1+1;
           Cost:=1;
           RuleApplied:=True;
         end;
      3: If (B2>1) and (Reactor[B2-1]=0) then
         begin
           B2:=B2-1;
           Cost:=1;
           RuleApplied:=True;
         end;
      4: If (B2<6) and (Reactor[B2+1]=0) then
         begin
           B2:=B2+1;
           Cost:=1;
           RuleApplied:=True;
         end;
      5: If (U1>1) and (Reactor[U1-1]=0) then
         begin
           U1:=U1-1;
           Cost:=4;
           RuleApplied:=True;
         end;
      6: If (U1<6) and (Reactor[U1+1]=0) then
         begin
           U1:=U1+1;
           Cost:=4;
           RuleApplied:=True;
         end;
      7: If (U2>1) and (Reactor[U2-1]=0) then
         begin
           U2:=U2-1;
           Cost:=4;
           RuleApplied:=True;
         end;
      8: If (U2<6) and (Reactor[U2+1]=0) then
         begin
           U2:=U2+1;
           Cost:=4;
           RuleApplied:=True;
         end;

      {Nonadjacency Rules}

      9: Begin
           N := NextHole(B1,1);
           If N <> 0 Then
           Begin
             RuleApplied:=True;
             Cost := 2 * Abs(N - B1);
             B1 := N;
           End;
         End;
     10: Begin
           N := NextHole(B1,-1);
           If N <> 0 Then
           Begin
             RuleApplied:=True;
             Cost := 2 * Abs(N - B1);
             B1 := N;
           End;
         End;
     11: Begin
           N := NextHole(B2,1);
           If N <> 0 Then
           Begin
             RuleApplied:=True;
             Cost := 2 * Abs(N - B2);
             B2 := N;
           End;
         End;
     12: Begin
           N := NextHole(B2,-1);
           If N <> 0 Then
           Begin
             RuleApplied:=True;
             Cost := 2 * Abs(N - B2);
             B2 := N;
           End;
         End;
     13: Begin
           N := NextHole(U1,1);
           If N <> 0 Then
           Begin
             RuleApplied:=True;
             Cost := 8 * Abs(N - U1);
             U1 := N;
           End;
         End;
     14: Begin
           N := NextHole(U1,-1);
           If N <> 0 Then
           Begin
             RuleApplied:=True;
             Cost := 8 * Abs(N - U1);
             U1 := N;
           End;
         End;
     15: Begin
           N := NextHole(U2,1);
           If N <> 0 Then
           Begin
             RuleApplied:=True;
             Cost := 8 * Abs(N - U2);
             U2 := N;
           End;
         End;
     16: Begin
           N := NextHole(U2,-1);
           If N <> 0 Then
           Begin
             RuleApplied:=True;
             Cost := 8 * Abs(N - U2);
             U2 := N;
           End;
         End;


  End; { Case statement}
  If RuleApplied then TestState:=1000*B1 + 100*B2 + 10*U1 + U2;
  If Debug[4] and RuleApplied then writeln(outfile,'    New state:',TestState);
End;

Procedure AddNode(NN,TestState,Cost:integer);
Var NewNd,NewG: Integer;
    Temp:boolean;
Begin
  NewG := GValue(NN) + Cost;
  CreateNode(NN, TestState, NewNd);
  SetValue(NewNd,UnFinished);
  SetGValue(NewNd,NewG); {Set G value = parent g + cost of
                                     getting from parent}
  SetHValue(NewNd,FindH(TestState)); {Compute H value}
  {Maintain BestGoalSoFar}
  CheckForGoal(NewNd,Temp);
  If Temp and (NewG < BestGoalSoFar) then BestGoalSoFar:=NewG;
End;

Procedure TraceBack(GoalNode:integer);
Var trace: array[1..40] of integer;
    T,N,I  : integer;

{Starting from the Goal Node, work backwards to the root node, then
 report the entire path. }

Begin
  T:=GoalNode;
  N:=0;
  While T <> Root do
  Begin
    N:=N+1;
    Trace[N]:=T;
    T:=Parent(T);
  End;
  N:=N+1;
  Trace[N]:=Root;
  For I:=N downto 1 do writeln(Characteristic(Trace[i]));
End;

{ M A I N    P R O G R A M}

Begin
  For I:=1 to 5 do debug[i]:=false;debug[2]:=true;
  assign(outfile,'debug.msgs');
  rewrite(outfile);
  {Set things up}
  InitTree;
  SetCharacteristic(Root,3546);    {Problem Specific}
  SetValue(Root,Unfinished);
  SetGValue(Root,0);
  FoundGoal:=False;
  Impossible:=False;
  BestGoalSoFar:=1000;
  T1 := Time;

  While (not FoundGoal) and (not Impossible) Do
  Begin
    {Are there any unfinished nodes left?}
    NN:=BestUnfinished;
    {Check to see if it is the goal node}
    CheckForGoal(NN,FoundGoal);
    If Not FoundGoal then
    Begin
      if debug[5] then writeln(outfile,'Considering ',Characteristic(NN),
                               ' Cost=',GValue(NN));
      If NN=Null then Impossible:=true else
      Begin {Generate offspring nodes}
        For Rule:=1 to NRules Do
        Begin
          ApplyRule(Rule,NN,RuleApplied,TestState,Cost);
          If RuleApplied then
          Begin {Ensure no parents are identical.  Also, ensure that an equal
        or lower cost path doesn't exist already.  Finally, do branch & bound
        Notice that you do this only on the G value.  Don't use H value.}

            CheckAncestry(TestState,Cost+GValue(NN),OK);
            If OK then
            Begin
              AddNode(NN,TestState,Cost);
              if debug[5] then writeln(outfile,' Created ',TestState,
                                ' Cost=',Cost+GValue(NN));
            End;
          End;
        End; {Trying all rules}
        {Set node NN finished}
        SetValue(NN,Finished);
      End; { expanding space }
    End;  { search clause if goal not found yet}
  End; { While clause }

  If Impossible then writeln('No possible solution to the problem.')
                else begin
                       writeln('Solution found.');
                       traceback(NN);
                       writeln('Cost: ',Gvalue(NN));
                     end;
T2 := Time;
Writeln('Took ',(T2-T1):7:2,' seconds.');
Writeln(nnodes,' nodes generated.');
End.
                     end;
T2 := Time;
Writeln('Took ',(T2-