Programmer 7500/MAX_PROGRAMMERS.iso/CLIPPER/MISC/FUZZY.ZIP/PRINT_ST.B

Text File | 1986-11-30 | 15.4 KB | 466 lines

-------------------------------------------------------------------------------
--                                                                           --
--  Separate Unit:  Print_stuff -- Output routines from Prover               --
--                                                                           --
--  Author:  Bradley L. Richards                                             --
--                                                                           --
--     Version     Date     Notes . . .                                      --
--    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -    --
--       2.3    19 Aug 86   Split out from prover                            --
--    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -    --
--                                                                           --
--  Description:  This file contains all output routines for the Prover.     --
--       This includes output from predicates such as WRITE and LISTING as   --
--       well as the debug output from trace and trace commands.             --
--                                                                           --
-------------------------------------------------------------------------------

separate(prover)
procedure print_argument( argument : argument_ptr; bindings : binding_list;
              level : natural; quotes : boolean) is
    value : argument_ptr;
    value_level : integer;  -- trash variable
  begin
   if argument = null then
    put("ERROR -- null argument");
   else
    case argument.is_a is
    when character_lit  =>  if quotes then put('''); end if;
                put(argument.char);
                if quotes then put('''); end if;
    when predicate      =>  if quotes then put('"'); end if;
                put(argument.name.name);
                if quotes then put('"'); end if;
                if argument.p_arguments /= null then
                  print_arguments(argument.p_arguments,
                          bindings, level, quotes);
                end if;
    when float_num      =>  put(argument.fp_num);
    when integer_num    =>  put(argument.int_num);
    when prolog_list    =>  print_list(argument.list, bindings, level,
                       quotes);
    when variable       =>  if argument.v_name = null then
                  put('_');
                else
                  lookup(argument, level, bindings, value, value_level);
                  if value.is_a = variable then
                    put('_' & argument.v_name.name);
                  else
                    print_argument(value, bindings, value_level,
                           quotes);
                  end if;
                end if;
      end case;
    end if;
  end print_argument;


separate(prover)
procedure print_arguments( in_arguments : argument_ptr; bindings : binding_list;
               level : natural; quotes : boolean ) is
    arguments : argument_ptr := in_arguments;
  begin
    put( '(' );
    loop
      print_argument( arguments, bindings, level, quotes );
      exit when arguments.next_arg = null;
      arguments := arguments.next_arg;
      put( ", " );
    end loop;
    put( ')' );
  end print_arguments;


separate(prover)
procedure print_AST( ast_node : AST_ptr; indent : integer ) is
    node : AST_ptr := ast_node;
  begin
    if node = null then
      space(indent); put_line("null node");
    else
      case node.node_type is
        when implication  =>
      while node.node_type = implication loop -- through linked list
        space(indent); put_line("implication node");
        space(indent+2); put_line("head");
        print_AST(node.head, (indent+4));
        space(indent+2); put_line("tail");
        print_AST(node.tail, (indent+4));
        node := node.next;
        exit when node = null;
      end loop;
      if node = null then
        space(indent); put_line("null node");
      else
        space(indent); put_line("error -- link to invalid node");
      end if;
    when binary_operator     =>  space(indent);
                     print_bin_op(node.binary_op);
                     print_AST(node.left_operand,(indent+2));
                     print_AST(node.right_operand,(indent+2));
    when unary_operator      =>  space(indent);
                     print_un_op(node.unary_op);
                     print_AST(node.operand,(indent+2));
    when predicate           =>  print_predicate(node,indent,null,0);
    when integer_num         =>  space(indent);
                     put(node.int_num); new_line;
    when float_num           =>  space(indent);
                     put(node.fp_num); new_line;
    when character_lit       =>  space(indent);
                     put('''); put(node.char); put(''');
    when fuzzy_value         =>  space(indent);
                     put("fuzzy truth value:  ");
                     put(node.fuzzy_num); new_line;
    when reserved_predicate  =>  print_reserved(node,indent,null,0);
    when variable            =>  space(indent);
                     put("variable:  ");
                     if node.var_name = null then
                       put_line("anonymous");
                     else
                       put('"'); put(node.var_name.name);
                       put('"'); new_line;
                     end if;
    when resolution_marker   =>  space(indent);
                     put("resolution level: ");
                     put(node.level);
                     put("     old threshold level: ");
                     put(node.old_threshold); new_line;
                     print_AST(node.subgoals, (indent+2));
    when threshold_marker    =>  space(indent);
                     put("threshold marker: ");
                     put(node.old_threshold);
                     put("     truth value: ");
                     put(node.fuzzy_value); new_line;
      end case;
    end if;
  end print_AST;


separate(prover)
procedure print_bin_op(operator : binary_operators) is
  begin
    put(operator);
    put_line(" operator");
  end print_bin_op;


separate(prover)
procedure put_bin_op(operator : binary_operators) is
  begin
    case operator is
      when bar               =>  put(" | ");
      when comma             =>  put(", ");
      when hat               =>  put(" ^ ");
      when semicolon         =>  put("; ");

      when asterisk          =>  put(" * ");
      when minus             =>  put(" - ");
      when plus              =>  put(" + ");
      when slash             =>  put(" / ");
      when rw_mod            =>  put(" mod ");

      when equal             =>  put(" = ");
      when equality          =>  put(" == ");
      when greater_or_equal  =>  put(" >= ");
      when greater_than      =>  put(" > ");
      when less_or_equal     =>  put(" =< ");
      when less_than         =>  put(" < ");
      when not_equal         =>  put(" \= ");
      when not_equality      =>  put(" \== ");
      when univ              =>  put(" =.. ");
      when rw_is             =>  put(" is ");
    end case;
  end put_bin_op;

separate(prover)
procedure print_bindings(bindings_in : binding_list; indent : natural ) is
    bindings : binding_list := bindings_in;
  begin
    while bindings /= null loop
      space(indent);
      put('_' & bindings.name.name & " (");
      put(bindings.level,4); put(")  =  ");
      --
      --  By giving print_argument a binding list of null, we avoid Lookup and
      --  display the actual entries in the binding list
      --
      print_argument(bindings.value, null, 0, quote);
      put(" ("); put(bindings.value_level,4); put(')');
      new_line;
      bindings := bindings.next_binding;
    end loop;
  end print_bindings;


separate(prover)
procedure print_clause( clause : AST_ptr ) is
  begin
    case clause.node_type is
      when implication  =>
        put('"'); put(clause.head.name.name); put('"');
        if clause.head.p_arguments /= null then
      print_arguments(clause.head.p_arguments, null, 0, quote);
        end if;
        put(" :- ");
        print_clause(clause.tail);
        put_line(" .");
      when binary_operator  =>
        print_clause(clause.left_operand);
        put_bin_op(clause.binary_op);
        print_clause(clause.right_operand);
      when unary_operator  =>
        put_un_op(clause.unary_op);
        print_clause(clause.operand);
      when predicate  =>
    put('"');  put(clause.name.name);  put('"');
    if clause.p_arguments /= null then
      print_arguments(clause.p_arguments, null, 0, quote);
    end if;
      when integer_num  =>  put(clause.int_num);
      when float_num  =>  put(clause.fp_num);
      when character_lit  =>   put(''');  put(clause.char);  put(''');
      when fuzzy_value  =>  put("fuzzy(");  put(clause.fuzzy_num);  put(')');
      when reserved_predicate  =>
    put_reserved(clause.predicate);
    if clause.r_arguments /= null then
      print_arguments(clause.r_arguments, null, 0, quote);
    end if;
      when variable  =>  put(clause.var_name.name);
      when resolution_marker | threshold_marker  =>  raise prover_error;
    end case;
  end print_clause;


separate(prover)
procedure print_list( in_list : p_list_ptr; bindings : binding_list;
              level : natural; quotes : boolean ) is
    list : p_list_ptr := in_list;
    value : argument_ptr;
    value_level : natural;
  begin
    put( '[' );
    while list /= null loop
      print_argument(list.elt, bindings, level, quotes);
      if list.has_tail and then (list.tail /= null) then
    lookup(list.tail, level, bindings, value, value_level);
    if value.is_a = prolog_list then
      if value.list /= null then
        put(", ");
        print_list_tail(value.list, bindings, value_level, quotes);
      end if;
    else
      put( " | " );
      print_argument(value, bindings, value_level, quotes);
    end if;
    exit;
      elsif list.has_tail and then (list.tail = null) then
    error(no_pointer,"tail of list does not exist");
      else
    list := list.next_elt;
    if list /= null then
      put( ", " );
    end if;
      end if;
    end loop;
    put( ']' );
  end print_list;


separate(prover)
procedure print_list_tail( in_list : p_list_ptr; bindings : binding_list;
               level : natural; quotes : boolean ) is
    list : p_list_ptr := in_list;
    value : argument_ptr;
    value_level : natural;
  begin
    while list /= null loop
      print_argument(list.elt, bindings, level, quotes);
      if list.has_tail and then (list.tail /= null) then
    lookup(list.tail, level, bindings, value, value_level);
    if value.is_a = prolog_list then
      if value.list /= null then
        put(", ");
        print_list_tail(value.list, bindings, value_level, quotes);
      end if;
    else
      put( " | " );
      print_argument(value, bindings, value_level, quotes);
    end if;
    exit;
      elsif list.has_tail and then (list.tail = null) then
    error(no_pointer,"tail of list does not exist");
      else
    list := list.next_elt;
    if list /= null then
      put( ", " );
    end if;
      end if;
    end loop;
  end print_list_tail;

separate(prover)
procedure print_predicate( node : AST_ptr; indent : natural;
               bindings : binding_list; level : natural ) is
  begin
    space(indent);
    put(node.name.name);
    if node.p_arguments /= null then
      print_arguments(node.p_arguments, bindings, level, quote);
    end if;
    new_line;
  end print_predicate;

separate(prover)
procedure print_reserved( node : AST_ptr; indent : natural;
              bindings : binding_list; level : natural ) is
  begin
    space(indent);
    put_reserved(node.predicate);
    if node.r_arguments /= null then
      print_arguments(node.r_arguments, bindings, level, quote);
    end if;
    new_line;
  end print_reserved;


separate(prover)
procedure put_reserved( reserved_predicate : reserved_predicates ) is
  begin
    case reserved_predicate is
      when cut => put('!');
      when rw_asserta => put("asserta");
      when rw_assertz => put("assertz");
      when rw_atom => put("atom");
      when rw_atomic => put("atomic");
      when rw_call => put("call");
      when rw_clause => put("clause");
      when rw_consult => put("consult");
      when rw_debugging => put("debugging");
      when rw_display => put("display");
      when rw_fail => put("fail");
      when rw_float => put("float");
      when rw_functor => put("functor");
      when rw_fuzzy => put("fuzzy");
      when rw_get => put("get");
      when rw_get0 => put("get0");
      when rw_integer => put("integer");
      when rw_listing => put("listing");
      when rw_ln => put("ln");
      when rw_log => put("log");
      when rw_name => put("rw_name");
      when rw_nl => put("nl");
      when rw_nodebug => put("nodebug");
      when rw_nonvar => put("nonvar");
      when rw_notrace => put("notrace");
      when rw_number => put("number");
      when rw_op => put("op");
      when rw_org => put("org");
      when rw_parse => put("parse");
      when rw_put => put("put");
      when rw_read => put("read");
      when rw_repeat => put("repeat");
      when rw_reset => put("reset");
      when rw_retract => put("retract");
      when rw_see => put("see");
      when rw_seeing => put("seeing");
      when rw_seen => put("seen");
      when rw_skip => put("skip");
      when rw_tab => put("tab");
      when rw_tell => put("tell");
      when rw_telling => put("telling");
      when rw_threshold => put("threshold");
      when rw_told => put("told");
      when rw_trace => put("trace");
      when rw_true => put("true");
      when rw_user => put("user");
      when rw_var => put("var");
      when rw_write => put("write");
      end case;
  end put_reserved;


--
--  Print_result -- display relevant variable bindings to the user along
--                  with the relative truth value of the solution
--
separate(prover)
procedure print_result( bindings_in : binding_list; done : out boolean) is
    answer : string(1..10);
    ans_length : natural;
    bindings : binding_list := bindings_in;
    had_variables : boolean := false;
    template : constant argument_ptr := new argument'(variable, null, null);
    value : argument_ptr;
    value_level : natural;

  begin
    while bindings /= null loop
      if bindings.level = 0 then -- it is a user-specified variable
    had_variables := true;
    template.v_name := bindings.name;
    lookup(template, 0, bindings_in, value, value_level);
    put(bindings.name.name); put(" = ");
    case value.is_a is
      when character_lit  =>  put(value.char);
      when predicate      =>  put(value.name.name);
                  if value.p_arguments /= null then
                    print_arguments(value.p_arguments, bindings,
                              value_level, quote);
                  end if;
      when float_num      =>  put(value.fp_num);
      when integer_num    =>  put(value.int_num);
      when prolog_list    =>  print_list(value.list, bindings_in,
                         value_level, quote);
      when variable       =>  put("variable:  _"); put(value.v_name.name);
                  put('/'); put(value_level,4);
      end case;
    new_line;
      end if;
      bindings := bindings.next_binding;
    end loop;
    put("Certainty:  "); put(current_truth); new_line;
    if had_variables then
      put("more?  ");
      get_line(answer, ans_length);
      if ans_length = 0 then -- assume "yes"
        done := false;
      elsif (answer(1) = 'y') or (answer(1) = 'Y') then
        done := false;
      elsif (answer(1) = ';') then -- Prolog version
    done := false;
      else -- assume "no"
        done := true;
      end if;
    else
      done := true;
    end if;
  end print_result;


separate(prover)
procedure print_un_op(operator : unary_operators) is
  begin
    put(operator);
    put_line(" operator");
  end print_un_op;


separate(prover)
procedure put_un_op(operator : unary_operators) is
  begin
    case operator is
      when rw_nospy  =>  put(" nospy ");
      when rw_not    =>  put(" not ");
      when rw_spy    =>  put(" spy ");
    end case;
  end put_un_op;


separate(prover)
procedure space(number : natural) is
  begin
    for i in 1..number loop
    put(' ');
      end loop;
  end space;