Programmer 7500/MAX_PROGRAMMERS.iso/CLIPPER/MISC/AIE8909.ZIP/TOOLBOX

Text File | 1989-09-01 | 13.4 KB | 511 lines

                  Filling an Order using Pascal


procedure ask( var item0 : item;
               var amount : integer);
     begin
     write(" Item ? ");
     read_item( item0 );
     write(" Amount ? ");
     readln( amount)
     end;

function fill( var item0 : item ; amount : integer ) : integer;
    begin
     if item0.on_hand >= amount
      then begin
           item0.on_hand := item.on_hand - amount;
           fill := amount
           end
      else fill := 0
    end;


procedure order;
   var item0 : item;  amount , filled : integer;
   begin
     ask( item0, amount);  { get order info }
     filled := fill( item, amount)  { fill order }
   end;

                 Listing 1



    Filling an Order  -- rewritten for Dead End Debugging

CONST
  trace_flag = true;

function ask( var item0 : item;
               var amount : integer) : boolean;
     begin
     if trace_flag then
         writeln("entering ask");
     write(" Item ? ");
     if read_item( item0 ) then
         begin
         write(" Amount ? ");
         readln( amount)
         ask := true
         end
      else
         begin
           ask := false;
           writeln("ask fails")
         end
      end;

function fill( var item0 : item ;
               amount : integer ) : boolean;
    begin
     if trace_flag then
       begin
         write("entering fill, item = ");
         write_item( item0);
         write( "amount = ");
         writeln( amount)
       end;
     if item0.on_hand >= amount
      then begin
           item0.on_hand := item.on_hand - amount;
           fill := true;
           end
      else begin
           writeln("fill fails");
           fill := false
           end
    end;


boolean function order;
   var item0 : item;  amount ; b1, b2 : boolean;
   begin
     if trace_flag then
       begin
         write("entering order, item = ");
         write_item( item0);
         write( "amount = ");
         writeln( amount);
       end;
     b1 :=  ask( item0, amount);
     if b1 then b2 :=  fill( item0, amount)
        else b2 := false;
     if b1 and b2 then then order := true
                  else begin
                       if trace_flag then writeln("order fails");
                       order := false
                       end
      end;


                 Listing 2

-------------------------------------------------------------------

              Order Filling in Prolog


trace_flag.  % set trace flag to true


order  :-
      trace_message( trace_flag,
                      $entering order$),
      ask( Item, Amount),   % get order info
      fill( Item, Amount),  % fill it
      !.
order  :-
      fail_message( order ).

ask( Item, Amount ) :-
      trace_message( trace_flag, $entering ask$),
      write($item : $),
      read_string( 100, S_item),
      atom_string( Item_name, S_item),
             % get an item from the database
      call( item( Item_info  )),
             % see if it's the one you want
             % if not, backtrack
      frame_slot_val( name, Item_info, Item_name),
      Item = item( Item_info ),
      write($Amount : $),
      read_string( 100, S_amount),
      int_text( Amount, S_amount),
      !.
ask( Item, Amount ) :-
      fail_message( ask   ).

fill( Item, Amount) :-
      trace_message( trace_flag, [$entering fill, Item = $,
                                  Item,
                                  $ Amount = $,
                                  Amount]),
     frame_slot_val( on_hand, Item, On_hand ),
     Left_over is On_hand - Amount,
     Left_over > 0,
     update_frame_slot_val( on_hand, Left_over, Item, New_frame),
     retract( Item),
     assert( New_frame).

fill( Item, Amount) :-
      fail_message( fill  ).

trace_message( Flag , _ ) :-
     call( Flag),
     !.
trace_message( Flag , Message ) :-
     trace_message(  Message ) .

trace_message(  Msg) :-
     var( Msg),
     !,
     write( Msg).
trace_message(  [] ) :-
     !,
     nl.
trace_message(   [ H | T ] ) :-
     write(H),
     tab(1),
     trace_message( T ).
trace_message(  X ) :-
    trace_message(  [ X ]) .

fail_message( Name ) :-
      write(Name),
      tab(1),
      write( $fails.$),
      nl,
      fail.

% some sample items

item( [ name : diskettes,
        on_hand : 1000]).

item( [ name : prolog_tools,
        on_hand : 10]).



                 Listing 3

-------------------------------------------------------------------

          Testing for a list of Integers   -- with Bug


integers( []) :-
    !,
    fail.

integers( [H|T]) :-
    integer(H),
    integers(T).



                     Listing 4

-------------------------------------------------------------------

               Generating Bug Paths

/*
gen_bug_reports( In_bug_calls, Out_bug_calls)

INPUTS

     In_bug_call = list of bug call lists.

OUTPUTS

     Out_bug_call = list of complete bug call lists, each with innermost
                    call first
*/

          %  No way to elaborate an empty bug path list.
gen_bug_reports( [], [] ) :- !.

          % if the initial bug path is as detailed as our
          % current heuristics permit, then elaborate the
          % paths in the tail of the paths list
gen_bug_reports( [H|T], [H|T1] )  :-
      H = [Inside | _      ]  ,
      complete_bug_report( Inside ), !,
      gen_bug_reports(  T , T1  ).

      % otherwise elaborate the head bug report and then elaborate
      % the other bug reports.
      % Note that the head bug report may branch.
gen_bug_reports( [ H | T ], Outputs  )  :-
      H = [Inside | _      ]  ,
      frame_slot_val( failing_subgoal, Inside , Goal ), !,
      current_level_bug_report( Goal,
                                Current_level_report), !,
      (    Current_level_report == [], !,
           gen_bug_reports( T, Rest  ),
           Outputs = [ H | Rest]
        ;          % add the different current level reports
                   % on the front of the head bug report.  Each
                   % current level report represents one reason
                   % at the next level down why a bug exists
           make_head( Current_level_report, H, New_front_list),
           append( New_front_list, T, New_inputs),
           gen_bug_reports( New_inputs , Outputs   )).


complete_bug_report( Bug_report ) :-
      frame_slot_val( system_predicate, Bug_report, true),!.

complete_bug_report( Bug_report ) :-
      not frame_slot_val( failing_subgoal, Bug_report, _ ),!.


             Listing 5

-------------------------------------------------------------------

            A Bug Path List

[  % start of bug path list
  [  % start of first bug path
   goal_report([
     system_predicate : true,
     result : fail,
     call : fail,
     reason : $You called fail$]),

   goal_report([
     call : integers([]),
     clause_no : 1,
     result : fail,
     failing_subgoal_number : 2,
     failing_subgoal : fail,
     cuts_passed : 1 ]),

   goal_report([
     call : integers([1]),
     clause_no : 2,
     result : fail,
     failing_subgoal_number : 2,
     failing_subgoal : integers([]) ]),

   goal_report([
    failing_subgoal : integers([1])
    source : user  ])
  ]  % end of only bug path
]  % end of bug path list

                   Listing 6

-------------------------------------------------------------------

          Reporting a Bug Level

/* rule for system predicate failure .
   Here is an example of such a frame:
          Bug report :
          FRAME goal_report
          system_predicate : true
          result : fail
          call : integer(a)
          END_FRAME  */
report_on_bug_level( Bug_at_one_level ) :-
       frame_slot_val(call   , Bug_at_one_level, Call ),
       frame_slot_val(result , Bug_at_one_level, fail ),
       frame_slot_val(system_predicate,
                      Bug_at_one_level,
                      true  ),
       !,
       write_message_with_tab(2,
         [$The call $,
         Call,
         $ to a system predicate failed.$]),
       nl.


/* rule for when no heads match
     FRAME goal_report
     call : integers(a)
     result : fail
     reason : no_heads_match
     END_FRAME                 */
report_on_bug_level( Bug_at_one_level ) :-
       frame_slot_val(call   , Bug_at_one_level, Call ),
       frame_slot_val(reason , Bug_at_one_level, no_heads_match     ),
       !,
       write_message_with_tab(2,
         [$The goal at this level is $,
         Call,
         $ which failed. $]),
       functor( Call, Name, Arity),
       write_message_with_tab(2,
        [$This is because no heads of rules for $,
         Name / Arity,
         $ match the goal.$  ]),
       nl.

              Listing 7

--------------------------------------------------------------------

              A Bug Report

HERE IS THE BUG ANALYSIS :

THE TOP LEVEL BUG...

     The user-supplied goal integers([1]) failed.


GOING DOWN A LEVEL,

  The goal at this level is integers([1]) which failed.

  Clause 2 of integers / 1 failed.

  Here it is with the failing subgoal marked.

  integers([A|B]) :-
        integer(A),
FAILS==>integers(B).

  Instantiated, this subgoal is integers([]).


GOING DOWN A LEVEL,

  The goal at this level is integers([]) which failed.

  Clause 1 of integers / 1 failed.

  Here it is with the failing subgoal marked.

  integers([]) :-
        !,
FAILS==>fail.

  Instantiated, this subgoal is fail.


GOING DOWN A LEVEL,

  You called 'fail'.


     -- ( end of this particular possible bug explanation ) --

                 Listing 8

--------------------------------------------------------------------

          Writing Clauses in User-Friendly Notation

     % createss an image of a clause with variables in user-friendly
     %  notation when written with write.
           % try to improve what's there
create_image_to_write(  Clause, Image) :-
   create_image_to_write_hlpr(  Clause, Image),
   !.
           % otherwise use it as is
create_image_to_write(  Clause, Clause) :- !.

create_image_to_write_hlpr(  Clause, Image) :-
           % distinguish real strings from variable names
    rewrite_strings( Clause, Image1),         !,
           % create table of variable names
    create_variable_name_table( Clause, Table), !,
           % substitute names for variables
    put_in_var_names( Table, Image1, Image).


     % This predicate substitutes names for variables in Term to
     % produce Result
              % image of a variable is its name
put_in_var_names( Table, Term, Result   ) :-
       var( Term) ,
       !,
      lookup_var_val( Term ,  Table    , Result).

              % image of atoms, numbers, etc. are themselves
put_in_var_names( _    , Term, Term  ) :-
       atomic( Term) ,
       !.
              % image of structures is the structure of the same
              % form built from images of substructures
put_in_var_names( Table, Term, Result) :-
       Term =..List,
       put_in_var_names_for_list(  Table, List, List1),
       Result =.. List1.

              % image of a list is the list of images
put_in_var_names_for_list(  _    , [], []) :- !.
put_in_var_names_for_list(  Table, [H | T], [H1 | T1]) :-
    put_in_var_names( Table,  H, H1 ),
    put_in_var_names_for_list(  Table,  T ,  T1 ).


          % This looks up a variable name in a table.  Arg. 1 is
          % the variable, arg. 2 is the table, and arg. 3 is the
          % name found.  Notice that we have used <I>==<R> for
          % searching the table.  This lets us compare for
          % equivalence without doing unification.  Two
          % variables pass this test only if they are ALREADY
          % unified.
lookup_var_val( Var, []   , Var   ) :- !.
lookup_var_val( Var, [Var1 : Result | _]   , Result) :-
          Var == Var1,
          !.

lookup_var_val( Var, [ _  | Rest]   , Result) :-
    lookup_var_val( Var,  Rest    , Result).


       %  creates table of variables in a clause
       %  with string to represent each
create_variable_name_table( Clause, Table) :-
           % find variables in a clause
       variables( Clause, Vars ),
           % build a table of variable names
       var_table( Vars, Table).


       % Finds list of variables in a term in order they occur
variables( Term, Variables) :-
             % find variables with repeats
      variables_hlpr( [Term],  Vars0), !,
             % remove repeats of variables
             % This is standard list processing, except that
             % we have to use <I>==<R> instead of <I>=<R>
             % for comparing list items.
      remove_list_equivalents( Vars0, Variables).

         % empty list has no variables
variables_hlpr( [], []   ) :- !.

         % add a variable to the found variables list
variables_hlpr( [H | T],   [ H | Vars0] ) :-
     var( H ),
     !,
     variables_hlpr( T,  Vars0).

         % ignore atoms, numbers, etc.
variables_hlpr( [H | T],   Vars ) :-
     atomic( H ),
     !,
     variables_hlpr( T,   Vars).

         % change structures to lists and process the list
variables_hlpr( [H | T],   Vars ) :-
     H =.. List,
     variables_hlpr( List, Vars1),
     variables_hlpr( T, Vars2),
     append( Vars1, Vars2, Vars).


               Listing 9

ables_hlpr(