ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/MAGAZINE/MISC/AI_DEC88.ZIP/AIAPP.CDE

Text File | 1988-05-04 | 9.9 KB | 369 lines

Listing 1: The Fission Reactor problem, solved in Turbo Pascal.
           Requires the tree handling routines described in
   previous AI Apprentice columns, available on the
   AI-Expert bulletin boards and Compuserve Forum.

[Philip--I've uploaded a condensed version of the code
 as a separate file, in case you need it.  - Marc R]


Program MoveRods;

{An A super T implementation of the reactor problem}
Const
 maxnode = 3000;
 {$Itreecons.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
 {$Itreevars.ins}

 FoundGoal, Impossible, RuleApplied, FoundEarlier:    Boolean;
 NN, Rule, TestState, GoalNode:                       Integer;
 I, Cost,BestGoalSoFar:                               Integer;
 OK:                                                  Boolean;

 {$Itreeproc.ins}

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;

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,bestg,BestNode,G: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;
  BestG := 1000;
  While N<>Null Do
  Begin
    G := GValue(N);
    If (G < BestG) and (NodeValue(N)=Unfinished) Then
    Begin
      BestNode:=N;
      BestG:=G;
    End;
    N:=NextNode(N);
  End;
  If BestG = 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}
  {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;

{Main Program}

Begin
  For I:=1 to 5 do debug[i]:=false;debug[2]:=true;
  assign(outfile,'con:');
  rewrite(outfile);
  {Set things up}
  InitTree;
  SetCharacteristic(Root,3546);    {Problem Specific}
  SetValue(Root,Unfinished);
  SetGValue(Root,0);
  FoundGoal:=False;
  Impossible:=False;
  BestGoalSoFar:=32000; {Used to initialize branch & bound}

  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}
            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;
End.

                       traceback(NN);
                       writeln('Cost: ',Gvalue(NN));