home *** CD-ROM | disk | FTP | other *** search
- -------------------------------------------------------------------------------
- -- --
- -- Separate Unit: Do_reserved -- process reserved predicates for Prover --
- -- --
- -- Author: Bradley L. Richards --
- -- --
- -- Version Date Notes . . . --
- -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --
- -- 1.0 - - - - - Never existed. First version implemented after --
- -- Parser et al reached version 2.0 --
- -- 2.0 20 Jun 86 Initial Version --
- -- 2.05 13 Jul 86 Split into separate spec and package files --
- -- 2.1 21 Jul 86 Demonstration version -- initial predicates --
- -- implemented; initial debugging completed --
- -- 2.2 28 Jul 86 Initial operational version -- 20 predicates --
- -- implemented, plus lots of squashed bugs --
- -- 2.3 19 Aug 86 Use AVL trees for rule_base, add many reserved --
- -- predicates, and split output routines into --
- -- package print_stuff. --
- -- 2.4 31 Aug 86 Do_reserved split out from Prover --
- -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --
- -- --
- -- Description: The procedure Do_reserved accepts Fuzzy Prolog reserved --
- -- predicates from Seek and processes them. Most predicates have --
- -- their own subprocedure, but a few (e.g. asserta/assertz) are --
- -- combined. After Do_reserved, all routines appear alphabetically. --
- -- --
- -------------------------------------------------------------------------------
-
- separate(prover)
- procedure do_reserved( pred, goal_tree : AST_ptr; result_node : out AST_ptr;
- bindings : in out binding_list; level : natural;
- failed : in out boolean ) is
-
- new_rule, new_rules, temp : AST_ptr;
- template : constant AST_ptr := new AST'(implication,
- new AST'(predicate, null, null), null, null, null);
- a_template : constant argument_ptr := new argument'(float_num, null, 0.0);
- file_ptr, value, value2, read_value : argument_ptr;
- temp_bindings : binding_list;
- int_arg, value_level, value2_level : integer;
- result_done : boolean := false;
- duplicate, not_found, unified : boolean;
- result : float := 0.0;
-
-
- procedure dr_assert is
-
-
- --
- -- Eval -- This set of three routines evalutes arguments. Eval_args
- -- evalutes the arguments in a functor's argument list, and is
- -- the main routine called by dr_assert. Eval evaluates a
- -- single argument, and eval_list evaluates the contents of
- -- a prolog list.
- --
- function eval_args( in_args : argument_ptr; bindings : binding_list;
- level : natural ) return argument_ptr;
-
- function eval_list( in_list : p_list_ptr; bindings : binding_list;
- level : natural ) return p_list_ptr;
-
- function eval( in_arg : argument_ptr; bindings : binding_list;
- level : natural ) return argument_ptr is
- value : argument_ptr;
- value_level : natural;
- begin
- lookup(in_arg, level, bindings, value, value_level);
- if value.is_a = predicate then
- return new argument'(predicate, null, value.name,
- eval_args(value.p_arguments, bindings, value_level));
- elsif value.is_a = prolog_list then
- return new argument'(prolog_list, null,
- eval_list(value.list, bindings, value_level));
- else
- return new argument'(value.all);
- end if;
- end eval;
-
- function eval_args( in_args : argument_ptr; bindings : binding_list;
- level : natural ) return argument_ptr is
- args : argument_ptr := in_args;
- new_arg : argument_ptr := null;
- new_args, temp : argument_ptr;
- begin
- while args /= null loop
- temp := eval(args, bindings, level);
- if new_arg = null then -- this is the first argument
- new_arg := temp;
- new_args := new_arg;
- else
- new_arg.next_arg := temp;
- new_arg := new_arg.next_arg;
- end if;
- new_arg.next_arg := null;
- args := args.next_arg;
- end loop;
- return new_args;
- end eval_args;
-
- function eval_list( in_list : p_list_ptr; bindings : binding_list;
- level : natural ) return p_list_ptr is
- elts : p_list_ptr := in_list;
- new_elt : p_list_ptr := null;
- new_elts, temp : p_list_ptr;
- begin
- while elts /= null loop
- --
- -- Ada, in its infinite error checking, requires the following
- -- useless if statement in order to keep the discriminate static
- --
- if elts.has_tail then
- temp := new p_list'(true, eval(elts.elt, bindings, level), null);
- else
- temp := new p_list'(false, eval(elts.elt, bindings, level), null);
- end if;
- if new_elt = null then -- this is the first argument
- new_elt := temp;
- new_elts := new_elt;
- else
- new_elt.next_elt := temp;
- new_elt := new_elt.next_elt;
- end if;
- if elts.has_tail then
- new_elt.tail := eval(elts.tail, bindings, level);
- exit;
- else
- elts := elts.next_elt;
- end if;
- end loop;
- return new_elts;
- end eval_list;
-
- begin -- dr_assert
- if (pred.r_arguments = null) then
- error(no_pointer,"ASSERTA/Z called without any arguments");
- failed := true;
- else
- lookup(pred.r_arguments, level, bindings, value, value_level);
- if pred.r_arguments.next_arg = null then -- use default truth of 1.0
- a_template.fp_num := 1.0;
- value2 := a_template;
- else
- lookup(pred.r_arguments.next_arg,level,bindings,value2,value2_level);
- end if;
- if value.is_a /= predicate then
- error(no_pointer, "first argument to ASSERTA/Z must be a functor");
- failed := true;
- elsif (value2.is_a /= float_num) or else (value2.fp_num < 0.0) or else
- (value2.fp_num > 1.0) then
- error(no_pointer,"2nd argument to ASSERTA/Z must be a fuzzy value");
- failed := true;
- else
- new_rule :=
- new AST'(implication,
- new AST'(predicate, value.name,
- eval_args(value.p_arguments,bindings,value_level)),
- new AST'(fuzzy_value, value2.fp_num), null, null);
- add_node(rule_base, new_rule, duplicate);
- if duplicate then
- temp := fetch_node(rule_base, new_rule);
- if temp = null then
- update_node(rule_base, new_rule, not_found);
- if not_found then
- raise prover_error;
- end if;
- else
- if pred.predicate = rw_asserta then
- new_rule.next := temp;
- temp.prev := new_rule;
- update_node(rule_base, new_rule, not_found);
- if not_found then
- raise prover_error;
- end if;
- else
- while temp.next /= null loop
- temp := temp.next;
- end loop;
- temp.next := new_rule;
- new_rule.prev := temp;
- end if;
- end if;
- end if;
- result := 1.0;
- end if;
- end if;
- end dr_assert;
-
-
- procedure dr_call is
- begin
- if pred.r_arguments = null then
- error(no_pointer,"CALL requires one argument");
- failed := true;
- else
- lookup(pred.r_arguments, level, bindings, value, value_level);
- if (value.is_a /= predicate) then
- error(no_pointer,"argument to CALL must be a functor");
- failed := true;
- else
- result_node :=
- new AST'(resolution_marker, value_level, threshold,
- new AST'(predicate, value.name, value.p_arguments));
- result_done := true;
- end if;
- end if;
- end dr_call;
-
-
- procedure dr_consult is
-
- rule_count : integer;
-
- --
- -- Append -- Used by consult to add rules to rule base.
- --
- procedure append(rule_base : in out tree_ptr; in_rules : AST_ptr;
- rule_count : out integer) is
- duplicate : boolean;
- next_rule, node : AST_ptr;
- new_rules : AST_ptr := in_rules;
- counter : integer := 0;
- begin
- while new_rules /= null loop
- next_rule := new_rules.next;
- new_rules.prev := null;
- new_rules.next := null;
- add_node(rule_base, new_rules, duplicate);
- if duplicate then
- node := fetch_node( rule_base, new_rules );
- if node /= null then
- while node.next /= null loop
- node := node.next;
- end loop;
- node.next := new_rules;
- new_rules.prev := node;
- else
- raise prover_error;
- end if;
- end if;
- new_rules := next_rule;
- counter := counter + 1;
- end loop;
- rule_count := counter;
- end append;
-
-
- begin -- dr_consult
- file_ptr := pred.r_arguments;
- while file_ptr /= null loop
- if file_ptr.is_a = predicate then
- put(file_ptr.name.name);
- start_parser(file_ptr.name.name, "");
- parse_file(new_rules);
- stop_parser;
- if number_of_errors = 0 then
- append(rule_base, new_rules, rule_count);
- result := 1.0;
- put(" has "); put(rule_count, 1); put(" rules");
- else
- put(file_ptr.name.name & " ignored");
- failed := true;
- end if;
- new_line;
- else
- put_line("invalid file name");
- failed := true;
- end if;
- file_ptr := file_ptr.next_arg;
- end loop;
- end dr_consult;
-
-
- procedure dr_fuzzy is
- begin
- if pred.r_arguments = null then
- error(no_pointer,"FUZZY requires one argument");
- failed := true;
- else
- lookup(pred.r_arguments, level, bindings, value, value_level);
- if value.is_a = float_num then
- if (value.fp_num < 0.0) or (value.fp_num > 1.0) then
- error(no_pointer, "value to FUZZY out of range");
- failed := true;
- else
- result := value.fp_num;
- end if;
- elsif value.is_a = variable then
- a_template.fp_num := current_truth;
- unify_arg(value, a_template, value_level, level, bindings, unified);
- result := current_truth;
- if not unified then
- raise prover_error;
- end if;
- else
- error(no_pointer, "invalid node type to FUZZY");
- failed := true;
- end if;
- end if;
- end dr_fuzzy;
-
-
- procedure dr_listing is
- begin
- if pred.r_arguments = null then
- error(no_pointer,"LISTING requires one argument");
- failed := true;
- else
- lookup(pred.r_arguments, level, bindings, value, value_level);
- if value.is_a /= predicate then
- error(no_pointer,"argument to LISTING must be a functor");
- else
- template.head.name := value.name;
- temp := fetch_node(rule_base, template);
- if temp /= null then
- while temp /= null loop
- print_clause(temp);
- temp := temp.next;
- end loop;
- result := 1.0;
- end if;
- end if;
- end if;
- end dr_listing;
-
-
- procedure dr_log is
- begin
- if (pred.r_arguments = null) or else
- (pred.r_arguments.next_arg = null) then
- error(no_pointer, "LN/LOG requires two arguments");
- failed := true;
- else
- lookup(pred.r_arguments,level,bindings,value,value_level);
- lookup(pred.r_arguments.next_arg,level,bindings,value2,value2_level);
- if value.is_a = variable then
- case value2.is_a is
- when variable =>
- error(no_pointer,"both arguments to LN/LOG uninstantiated");
- failed := true;
- when float_num =>
- if pred.predicate = rw_ln then
- a_template.fp_num := exp(value2.fp_num);
- else -- rw_log
- a_template.fp_num := 10.0 ** value2.fp_num;
- end if;
- when integer_num =>
- if pred.predicate = rw_ln then
- a_template.fp_num := exp(float(value2.int_num));
- else -- rw_log
- a_template.fp_num := 10.0 ** float(value2.int_num);
- end if;
- when others =>
- error(no_pointer,"2nd argument to LN/LOG is an invalid type");
- failed := true;
- end case;
- if not failed then
- unify_arg(value,a_template,value_level,level,bindings,unified);
- if unified then
- result := 1.0;
- else
- raise prover_error;
- end if;
- end if;
- elsif (value.is_a = float_num) or (value.is_a = integer_num) then
- if value.is_a = float_num then
- if pred.predicate = rw_ln then
- a_template.fp_num := nat_log(value.fp_num);
- else -- rw_log
- a_template.fp_num := com_log(value.fp_num);
- end if;
- else -- integer_num
- if pred.predicate = rw_ln then
- a_template.fp_num := nat_log(float(value.int_num));
- else -- rw_log
- a_template.fp_num := com_log(float(value.int_num));
- end if;
- end if;
- case value2.is_a is
- when variable =>
- unify_arg(value2,a_template,value2_level,level,bindings,unified);
- if unified then
- result := 1.0;
- else
- raise prover_error;
- end if;
- when float_num =>
- if a_template.fp_num = value2.fp_num then
- result := 1.0;
- end if;
- when integer_num =>
- if a_template.fp_num = float(value2.int_num) then
- result := 1.0;
- end if;
- when others =>
- error(no_pointer,"2nd argument to LN/LOG is an invalid type");
- failed := true;
- end case;
- else
- error(no_pointer,"1st argument to LN/LOG is an invalid type");
- failed := true;
- end if;
- end if;
- end dr_log;
-
-
- procedure dr_parse is
- begin
- file_ptr := pred.r_arguments;
- while file_ptr /= null loop
- if file_ptr.is_a = predicate then
- put(file_ptr.name.name & ' ');
- start_parser(file_ptr.name.name, (file_ptr.name.name & ".lst"));
- parse_file(new_rules);
- stop_parser;
- put_line("contains:");
- put(number_of_errors); put_line(" errors");
- put(number_of_warnings); put_line(" warnings");
- put(number_of_notes); put_line(" notes");
- result := 1.0;
- else
- error(no_pointer, "invalid file name");
- failed := true;
- end if;
- file_ptr := file_ptr.next_arg;
- end loop;
- end dr_parse;
-
-
- procedure dr_put_tab is
- begin
- if pred.r_arguments = null then
- error(no_pointer,(pred.name.name & " requires one argument"));
- failed := true;
- else
- lookup(pred.r_arguments, level, bindings, value, value_level);
- if (value.is_a /= integer_num) and (value.is_a /= float_num) then
- if pred.predicate = rw_put then
- error(no_pointer, "nonnumeric argument to PUT");
- else
- error(no_pointer, "nonnumeric argument to TAB");
- end if;
- failed := true;
- else
- if value.is_a = integer_num then
- int_arg := value.int_num;
- else -- fp
- int_arg := integer(value.fp_num + 0.00001);
- end if;
- if pred.predicate = rw_put then
- put(character'val(int_arg));
- else
- for i in 1..int_arg loop
- put(' ');
- end loop;
- end if;
- result := 1.0;
- end if;
- end if;
- end dr_put_tab;
-
-
- procedure dr_read is
- eof : boolean;
- begin
- if pred.r_arguments = null then
- error(no_pointer,"READ requires one argument");
- failed := true;
- else
- lookup(pred.r_arguments, level, bindings, value, value_level);
- start_parser("", "");
- parse_read(read_value, eof);
- stop_parser;
- if (number_of_errors = 0) and (not eof) then
- unify_arg(value, read_value, value_level, level, bindings, unified);
- if unified then
- result := 1.0;
- end if;
- else
- failed := true; -- errors have already been displayed to screen
- end if;
- end if;
- end dr_read;
-
-
- procedure dr_reset is
- begin
- release(rule_base);
- rule_base := init_tree;
- put_line("rule base reinitialized");
- result := 1.0;
- end dr_reset;
-
-
- procedure dr_retract is
- begin
- --
- -- This retract logic has one inherent, insidious bug. Clauses which
- -- have been retracted from the rule base may still be pointed to by
- -- db_ptr in various instantiations of Seek already on the call stack.
- -- There appears to be no way to fix this without major program
- -- restructuring. This problem should not arise too often, but
- -- in hopes of mitigating potential damages RETRACT does not
- -- deallocate retracted rules.
- --
- if pred.r_arguments = null then
- error(no_pointer,"RETRACT requires one argument");
- failed := true;
- else
- lookup(pred.r_arguments, level, bindings, value, value_level);
- if value.is_a /= predicate then
- error(no_pointer,"argument to RETRACT must be a functor");
- failed := true;
- else
- template.head.name := value.name;
- template.head.p_arguments := value.p_arguments;
- temp := fetch_node(rule_base, template);
- unified := false;
- while temp /= null loop
- temp_bindings := bindings;
- unify(template.head, temp.head, value_level, integer'last,
- temp_bindings, unified);
- if unified then
- bindings := temp_bindings;
- exit;
- else
- release(temp_bindings, bindings); -- the bindings aren't valid
- end if;
- temp_bindings := bindings;
- temp := temp.next;
- end loop;
- if unified then
- if temp.prev = null then -- the first node, so must update
- if temp.next = null then
- delete_node(rule_base, temp, not_found);
- else
- temp.next.prev := null;
- temp := temp.next;
- update_node(rule_base, temp, not_found);
- end if;
- if not_found then
- raise prover_error;
- end if;
- else
- temp.prev.next := temp.next;
- if temp.next /= null then
- temp.next.prev := temp.prev;
- end if;
- end if;
- result := 1.0;
- else
- failed := true;
- end if;
- end if;
- end if;
- end dr_retract;
-
-
- procedure dr_threshold is
- begin
- if pred.r_arguments = null then
- error(no_pointer,"THRESHOLD requires one argument");
- failed := true;
- else
- lookup(pred.r_arguments, level, bindings, value, value_level);
- if value.is_a = variable then -- set variable to current threshold
- unify_arg(value, new argument'(float_num, null, threshold),
- value_level, level, bindings, unified);
- result := 1.0;
- if not unified then
- raise prover_error;
- end if;
- elsif value.is_a = float_num then -- set the search threshold
- threshold := value.fp_num;
- result_node := new AST'(threshold_marker, 1.0, threshold);
- current_truth := 1.0; -- must complete our result here
- result_done := true;
- else
- error(no_pointer, "invalid argument to THRESHOLD");
- failed := true;
- end if;
- end if;
- end dr_threshold;
-
-
- procedure dr_trace is
- begin
- if pred.predicate = rw_trace then
- trace(true);
- else -- rw_notrace
- trace(false);
- end if;
- result := 1.0;
- end dr_trace;
-
-
- procedure dr_types is
- begin
- lookup(pred.r_arguments, level, bindings, value, value_level);
- result := 0.0;
- case value.is_a is
- when integer_num =>
- if (pred.predicate = rw_integer) or
- (pred.predicate = rw_number) or
- (pred.predicate = rw_atomic) or
- (pred.predicate = rw_nonvar) then
- result := 1.0;
- end if;
- when float_num =>
- if (pred.predicate = rw_float) or
- (pred.predicate = rw_number) or
- (pred.predicate = rw_atomic) or
- (pred.predicate = rw_nonvar) then
- result := 1.0;
- end if;
- when character_lit =>
- if (pred.predicate = rw_atomic) or
- (pred.predicate = rw_nonvar) then
- result := 1.0;
- end if;
- when predicate =>
- if (pred.predicate = rw_atom) or
- (pred.predicate = rw_atomic) or
- (pred.predicate = rw_nonvar) then
- result := 1.0;
- end if;
- when prolog_list =>
- if (pred.predicate = rw_nonvar) then
- result := 1.0;
- end if;
- when variable =>
- if (pred.predicate = rw_var) then
- result := 1.0;
- end if;
- end case;
- if result = 0.0 then
- failed := true;
- end if;
- end dr_types;
-
-
- begin -- do_reserved
-
- --
- -- Call the proper routine for this reserved word. A few very simple
- -- cases are handled within this procedure (for example "cut").
- --
- case pred.predicate is
- when cut => result := 1.0; -- "cut" logic really appears in Seek
- when rw_asserta | rw_assertz => dr_assert;
- when rw_call => dr_call;
- when rw_consult => dr_consult;
- when rw_fail => failed := true;
- when rw_fuzzy => dr_fuzzy;
- when rw_listing => dr_listing;
- when rw_ln | rw_log => dr_log;
- when rw_nl => new_line;
- result := 1.0;
- when rw_parse => dr_parse;
- when rw_put | rw_tab => dr_put_tab;
- when rw_read => dr_read;
- when rw_repeat => result := 1.0; -- real logic appears in Seek
- when rw_reset => dr_reset;
- when rw_retract => dr_retract;
- when rw_threshold => dr_threshold;
- when rw_trace | rw_notrace => dr_trace;
- when rw_true => result := 1.0;
- when rw_var | rw_nonvar | rw_atom |
- rw_atomic | rw_number | rw_integer | rw_float => dr_types;
- when rw_write =>
- print_argument(pred.r_arguments, bindings, level, no_quote);
- result := 1.0;
- when others => put(pred.predicate); new_line;
- error(no_pointer, "reserved predicate not implemented");
- failed := true;
- end case;
- if not result_done then
- current_truth := result;
- result_node := new AST'(fuzzy_value, result);
- end if;
-
- exception
- when name_error => -- this happens in consult, parse, and reconsult
- failed := true;
- put_line("not found--predicate aborted at this point");
-
- end do_reserved;
-