home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 September / Simtel20_Sept92.cdr / msdos / aijournl / ai_dec88.arc / AIAPP.CDE next >
Text File  |  1988-05-04  |  10KB  |  369 lines
  1.  
  2. Listing 1: The Fission Reactor problem, solved in Turbo Pascal.
  3.            Requires the tree handling routines described in 
  4.    previous AI Apprentice columns, available on the
  5.    AI-Expert bulletin boards and Compuserve Forum.
  6.  
  7. [Philip--I've uploaded a condensed version of the code
  8.  as a separate file, in case you need it.  - Marc R]
  9.  
  10.  
  11. Program MoveRods;
  12.  
  13. {An A super T implementation of the reactor problem}
  14. Const
  15.  maxnode = 3000;
  16.  {$Itreecons.ins}
  17.  Nrules = 16;             {Problem Specific}
  18.  Goal = 1;
  19.  DeadEnd = 2;
  20.  UnFinished = 3;
  21.  Finished = 4;
  22.  EmptyCType=0;
  23.  
  24. {Goal State here can be any of four goals:  2534,2543,5234,5243}
  25.  
  26. Type CType = Integer;
  27.  
  28. Var
  29.  {$Itreevars.ins}
  30.  
  31.  FoundGoal, Impossible, RuleApplied, FoundEarlier:    Boolean;
  32.  NN, Rule, TestState, GoalNode:                       Integer;
  33.  I, Cost,BestGoalSoFar:                               Integer;
  34.  OK:                                                  Boolean;
  35.  
  36.  {$Itreeproc.ins}
  37.  
  38. Procedure CheckForGoal(N:integer;Var FoundGoal:boolean);
  39. {This routine is problem specific }
  40. var X:integer;
  41. Begin
  42.   X := Characteristic(N);
  43.   If (X = 2534) or (X = 2543) or (X= 5243) or (X = 5234) then FoundGoal:=True
  44.   else FoundGoal := False;
  45. end;
  46.  
  47. Procedure CheckAncestry(Test,TestCost:integer;var OK:boolean);
  48. { Check to see that no node that is an ancestor of N has the same character-
  49.   istics of N}
  50. Var
  51.   M,X:integer;
  52. Begin
  53.   M:=Root;
  54.   OK:=true;
  55.   {Do branch & bound: if we've already found a goal node that is easier to
  56.    get to than this node, there's no point in considering this node}
  57.   If TestCost >= BestGoalSoFar Then OK:=False Else
  58.   Begin
  59.     While (M<>Null) and OK do
  60.       If (Characteristic(M)=Test) and (TestCost>=GValue(M)) then OK:=false
  61.       else M := NextNode(M);
  62.   End;
  63. End;
  64.  
  65.  
  66. Function BestUnfinished:integer;
  67. var n,bestg,BestNode,G:integer;
  68.     FoundOne,ExhaustedTree:boolean;
  69. Begin
  70.   { Find unfinished node with minimum value of g(node)}
  71.   if debug[5] then writeln(outfile,'  Started Search for best unfinished');
  72.   N := Root;
  73.   BestG := 1000;
  74.   While N<>Null Do
  75.   Begin
  76.     G := GValue(N);
  77.     If (G < BestG) and (NodeValue(N)=Unfinished) Then
  78.     Begin
  79.       BestNode:=N;
  80.       BestG:=G;
  81.     End;
  82.     N:=NextNode(N);
  83.   End;
  84.   If BestG = 1000 then BestUnfinished:=Null else BestUnfinished:=BestNode;
  85.   if debug[5] then writeln(outfile,'  Ended search for best unfinished.');
  86. End;
  87.  
  88. Procedure ApplyRule(Rule,NN:integer;var RuleApplied:boolean;var TestState:
  89.                     integer; var Cost:Integer);
  90.  
  91. {This entire procedure is problem specific}
  92.  
  93. { Applies input rule Rule to node NN, if possible.  If it was possible,
  94.   reports in RuleApplied.  New state is in TestState}
  95.  
  96.  
  97. Var
  98.  
  99.     X,G3,G4,T:                  Integer; (* current state of jugs *)
  100.     Reactor:                    array[0..7] of integer;
  101.     N,B1,B2,U1,U2: Integer;
  102.  
  103. Function NextHole(Strt,Direction:integer):integer;
  104. Var
  105.   NH, J: integer;
  106.   NotFound:boolean;
  107.  
  108. Begin
  109.   If ((direction = 1) and (Strt = 6)) or ((direction = -1) and (Strt = 1))
  110.   Then NH:=0 Else
  111.   if reactor[Strt+direction]=0 then NH:=0 else
  112.   Begin
  113.     NotFound:=true;
  114.     J:=Strt + direction;
  115.     While (j>0) and (J<7) and NotFound do
  116.        If Reactor[J] = 0 then
  117.        begin
  118.          NH := J;
  119.          NotFound:=False;
  120.        end else J:=J+direction;
  121.     If NotFound then NH:=0;
  122.   End;
  123.   NextHole:=NH;
  124. End;
  125.  
  126. Begin
  127.  
  128.   RuleApplied:=False;
  129.   {Decode state}
  130.   X := Characteristic(NN);
  131.   If Debug[4] then writeln(outfile,'  Applying rule ',rule,' to ',X);
  132.   For I:=1 to 6 do Reactor[i]:=0;reactor[0]:=1;reactor[7]:=1;
  133.   B1 := X div 1000; X:=X - B1*1000;
  134.   B2 := X div 100; X:= X - B2*100;
  135.   U1 := X div 10;  X:= X - U1*10;
  136.   U2 := X;
  137.   reactor[B1]:=1;
  138.   reactor[B2]:=1;
  139.   reactor[U1]:=1;
  140.   reactor[U2]:=1;
  141.   If debug[4] then writeln(outfile,'  States: B1/2, U1/2=',B1,' ',B2,' ',U1
  142.                            ,' ',U2);
  143.  
  144.   Case Rule of
  145.       1: If (B1>1) and (Reactor[B1-1]=0) then
  146.          begin
  147.            B1:=B1-1;
  148.            Cost:=1;
  149.            RuleApplied:=True;
  150.          end;
  151.       2: If (B1<6) and (Reactor[B1+1]=0) then
  152.          begin
  153.            B1:=B1+1;
  154.            Cost:=1;
  155.            RuleApplied:=True;
  156.          end;
  157.       3: If (B2>1) and (Reactor[B2-1]=0) then
  158.          begin
  159.            B2:=B2-1;
  160.            Cost:=1;
  161.            RuleApplied:=True;
  162.          end;
  163.       4: If (B2<6) and (Reactor[B2+1]=0) then
  164.          begin
  165.            B2:=B2+1;
  166.            Cost:=1;
  167.            RuleApplied:=True;
  168.          end;
  169.       5: If (U1>1) and (Reactor[U1-1]=0) then
  170.          begin
  171.            U1:=U1-1;
  172.            Cost:=4;
  173.            RuleApplied:=True;
  174.          end;
  175.       6: If (U1<6) and (Reactor[U1+1]=0) then
  176.          begin
  177.            U1:=U1+1;
  178.            Cost:=4;
  179.            RuleApplied:=True;
  180.          end;
  181.       7: If (U2>1) and (Reactor[U2-1]=0) then
  182.          begin
  183.            U2:=U2-1;
  184.            Cost:=4;
  185.            RuleApplied:=True;
  186.          end;
  187.       8: If (U2<6) and (Reactor[U2+1]=0) then
  188.          begin
  189.            U2:=U2+1;
  190.            Cost:=4;
  191.            RuleApplied:=True;
  192.          end;
  193.  
  194.       {Nonadjacency Rules}
  195.  
  196.       9: Begin
  197.            N := NextHole(B1,1);
  198.            If N <> 0 Then
  199.            Begin
  200.              RuleApplied:=True;
  201.              Cost := 2 * Abs(N - B1);
  202.              B1 := N;
  203.            End;
  204.          End;
  205.      10: Begin
  206.            N := NextHole(B1,-1);
  207.            If N <> 0 Then
  208.            Begin
  209.              RuleApplied:=True;
  210.              Cost := 2 * Abs(N - B1);
  211.              B1 := N;
  212.            End;
  213.          End;
  214.      11: Begin
  215.            N := NextHole(B2,1);
  216.            If N <> 0 Then
  217.            Begin
  218.              RuleApplied:=True;
  219.              Cost := 2 * Abs(N - B2);
  220.              B2 := N;
  221.            End;
  222.          End;
  223.      12: Begin
  224.            N := NextHole(B2,-1);
  225.            If N <> 0 Then
  226.            Begin
  227.              RuleApplied:=True;
  228.              Cost := 2 * Abs(N - B2);
  229.              B2 := N;
  230.            End;
  231.          End;
  232.      13: Begin
  233.            N := NextHole(U1,1);
  234.            If N <> 0 Then
  235.            Begin
  236.              RuleApplied:=True;
  237.              Cost := 8 * Abs(N - U1);
  238.              U1 := N;
  239.            End;
  240.          End;
  241.      14: Begin
  242.            N := NextHole(U1,-1);
  243.            If N <> 0 Then
  244.            Begin
  245.              RuleApplied:=True;
  246.              Cost := 8 * Abs(N - U1);
  247.              U1 := N;
  248.            End;
  249.          End;
  250.      15: Begin
  251.            N := NextHole(U2,1);
  252.            If N <> 0 Then
  253.            Begin
  254.              RuleApplied:=True;
  255.              Cost := 8 * Abs(N - U2);
  256.              U2 := N;
  257.            End;
  258.          End;
  259.      16: Begin
  260.            N := NextHole(U2,-1);
  261.            If N <> 0 Then
  262.            Begin
  263.              RuleApplied:=True;
  264.              Cost := 8 * Abs(N - U2);
  265.              U2 := N;
  266.            End;
  267.          End;
  268.  
  269.  
  270.   End; { Case statement}
  271.   If RuleApplied then TestState:=1000*B1 + 100*B2 + 10*U1 + U2;
  272.   If Debug[4] and RuleApplied then writeln(outfile,'    New state:',TestState);
  273. End;
  274.  
  275. Procedure AddNode(NN,TestState,Cost:integer);
  276. Var NewNd,NewG: Integer;
  277.     Temp:boolean;
  278. Begin
  279.   NewG := GValue(NN) + Cost;
  280.   CreateNode(NN, TestState, NewNd);
  281.   SetValue(NewNd,UnFinished);
  282.   SetGValue(NewNd,NewG); {Set G value = parent g + cost of
  283.                                      getting from parent}
  284.   {Maintain BestGoalSoFar}
  285.   CheckForGoal(NewNd,Temp);
  286.   If Temp and (NewG < BestGoalSoFar) then BestGoalSoFar:=NewG;
  287. End;
  288.  
  289. Procedure TraceBack(GoalNode:integer);
  290. Var trace: array[1..40] of integer;
  291.     T,N,I  : integer;
  292.  
  293. {Starting from the Goal Node, work backwards to the root node, then
  294.  report the entire path. }
  295.  
  296. Begin
  297.   T:=GoalNode;
  298.   N:=0;
  299.   While T <> Root do
  300.   Begin
  301.     N:=N+1;
  302.     Trace[N]:=T;
  303.     T:=Parent(T);
  304.   End;
  305.   N:=N+1;
  306.   Trace[N]:=Root;
  307.   For I:=N downto 1 do writeln(Characteristic(Trace[i]));
  308. End;
  309.  
  310. {Main Program}
  311.  
  312. Begin
  313.   For I:=1 to 5 do debug[i]:=false;debug[2]:=true;
  314.   assign(outfile,'con:');
  315.   rewrite(outfile);
  316.   {Set things up}
  317.   InitTree;
  318.   SetCharacteristic(Root,3546);    {Problem Specific}
  319.   SetValue(Root,Unfinished);
  320.   SetGValue(Root,0);
  321.   FoundGoal:=False;
  322.   Impossible:=False;
  323.   BestGoalSoFar:=32000; {Used to initialize branch & bound}
  324.  
  325.   While (not FoundGoal) and (not Impossible) Do
  326.   Begin
  327.     {Are there any unfinished nodes left?}
  328.     NN:=BestUnfinished;
  329.     {Check to see if it is the goal node}
  330.     CheckForGoal(NN,FoundGoal);
  331.     If Not FoundGoal then
  332.     Begin
  333.       if debug[5] then writeln(outfile,'Considering ',Characteristic(NN),
  334.                                ' Cost=',GValue(NN));
  335.       If NN=Null then Impossible:=true else
  336.       Begin {Generate offspring nodes}
  337.         For Rule:=1 to NRules Do
  338.         Begin
  339.           ApplyRule(Rule,NN,RuleApplied,TestState,Cost);
  340.           If RuleApplied then
  341.           Begin {Ensure no parents are identical.  Also, ensure that an equal
  342.                  or lower cost path doesn't exist already.  Finally,
  343.                  do branch & bound}
  344.             CheckAncestry(TestState,Cost+GValue(NN),OK);
  345.             If OK then
  346.             Begin
  347.               AddNode(NN,TestState,Cost);
  348.               if debug[5] then writeln(outfile,' Created ',TestState,
  349.                                 ' Cost=',Cost+GValue(NN));
  350.             End;
  351.           End;
  352.         End; {Trying all rules}
  353.         {Set node NN finished}
  354.         SetValue(NN,Finished);
  355.       End; { expanding space }
  356.     End;  { search clause if goal not found yet}
  357.   End; { While clause }
  358.  
  359.   If Impossible then writeln('No possible solution to the problem.')
  360.                 else begin
  361.                        writeln('Solution found.');
  362.                        traceback(NN);
  363.                        writeln('Cost: ',Gvalue(NN));
  364.                      end;
  365. End.
  366. 
  367.                        traceback(NN);
  368.                        writeln('Cost: ',Gvalue(NN));
  369.