home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Hack-Phreak Scene Programs
/
cleanhpvac.zip
/
cleanhpvac
/
FUZZY.ZIP
/
PRINT_ST.B
< prev
next >
Wrap
Text File
|
1986-11-30
|
16KB
|
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;
