Collection of Hack-Phreak Scene Programs

home *** CD-ROM | disk | FTP | other *** search

/ Collection of Hack-Phreak Scene Programs / cleanhpvac.zip / cleanhpvac / FUZZY.ZIP / EXECUTE.B < prev next >

Wrap

Text File | 1986-11-30 | 16KB | 399 lines

------------------------------------------------------------------------------- -- -- -- Separate Unit: Execute -- Execute operators 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 Split do_reserved into separate file -- -- 2.5 1 Sep 86 Split execute into separate file -- -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- -- -- -- Description: This file contains the routine Execute. Given an AST -- -- operator node which has its operands defined, this routine will -- -- execute that operator (and any operators beneath it) and alter -- -- the AST to reflect the result. -- -- -- -- It is possible that an error will creep in and the operands will -- -- not be of the appropriate types. In this case notify the user of -- -- the error. If thorough type-checking were included in the parser -- -- then the only way this error could arise would be through variable -- -- bindings. -- -- -- ------------------------------------------------------------------------------- separate(prover) procedure execute( operator : in out AST_ptr; bindings : in out binding_list; level : natural; failed : in out boolean ) is temp : AST_ptr := null; is_int_1, is_int_2, use_threshold : boolean := false; matched, unified : boolean; int_result, trash : integer; fp_1, fp_2, fp_result : float; fuzzy_1, fuzzy_2, fuzzy_result : fuzzy_values; left_value, right_value : argument_ptr; temp_bindings : binding_list; procedure binary_arithmetic is begin -- -- Execute a binary arithmetic operator -- lookup(operator.left_operand,level,bindings,left_value,trash); lookup(operator.right_operand,level,bindings,right_value,trash); if (left_value.is_a = integer_num) and (right_value.is_a = integer_num) then if operator.binary_op = asterisk then int_result := left_value.int_num * right_value.int_num; elsif operator.binary_op = minus then int_result := left_value.int_num - right_value.int_num; elsif operator.binary_op = rw_mod then int_result := left_value.int_num mod right_value.int_num; elsif operator.binary_op = plus then int_result := left_value.int_num + right_value.int_num; else -- operator.binary_op = slash int_result := left_value.int_num / right_value.int_num; end if; temp := new AST'(integer_num,int_result); else if left_value.is_a = integer_num then fp_1 := float(left_value.int_num); elsif left_value.is_a = float_num then fp_1 := left_value.fp_num; else error(no_pointer,"invalid type to arithmetic operator"); failed := true; end if; if right_value.is_a = integer_num then fp_2 := float(right_value.int_num); elsif right_value.is_a = float_num then fp_2 := right_value.fp_num; else error(no_pointer,"invalid type to arithmetic operator"); failed := true; end if; if not failed then if operator.binary_op = asterisk then fp_result := fp_1 * fp_2; elsif operator.binary_op = minus then fp_result := fp_1 - fp_2; elsif operator.binary_op = rw_mod then error(no_pointer,"'mod' only valid for integer arguments"); failed := true; elsif operator.binary_op = plus then fp_result := fp_1 + fp_2; else -- operator.binary_op = slash fp_result := fp_1 / fp_2; end if; if not failed then temp := new AST'(float_num,fp_result); end if; end if; end if; end binary_arithmetic; procedure binary_logic is begin -- -- Execute logic operator -- if operator.left_operand.node_type = fuzzy_value then fuzzy_1 := operator.left_operand.fuzzy_num; elsif operator.left_operand.node_type = threshold_marker then fuzzy_1 := operator.left_operand.fuzzy_value; threshold := operator.left_operand.threshold; use_threshold := true; else failed := true; put("Error -- fuzzy operator "); put(operator.binary_op); put(" given invalid operand of type "); put(operator.left_operand.node_type); new_line; end if; if operator.right_operand.node_type = fuzzy_value then fuzzy_2 := operator.right_operand.fuzzy_num; elsif operator.right_operand.node_type = threshold_marker then fuzzy_2 := operator.right_operand.fuzzy_value; threshold := operator.right_operand.threshold; use_threshold := true; else failed := true; put("fuzzy operator "); put(operator.binary_op); put(" given invalid operand of type "); put(operator.right_operand.node_type); new_line; end if; if failed then fuzzy_result := 0.0; else if operator.binary_op = bar then fp_result := fuzzy_1 + fuzzy_2 - (fuzzy_1 * fuzzy_2); -- -- Occasionally borderline inaccuracies in floating point -- arithmetic cause a result greater than one, which in turn -- causes a constraint error. -- if fp_result > 1.0 then fuzzy_result := 1.0; else fuzzy_result := fp_result; end if; elsif operator.binary_op = comma then if fuzzy_1 < fuzzy_2 then fuzzy_result := fuzzy_1; else fuzzy_result := fuzzy_2; end if; elsif operator.binary_op = hat then fuzzy_result := fuzzy_1 * fuzzy_2; else -- operator.binary_op = semicolon if fuzzy_1 > fuzzy_2 then fuzzy_result := fuzzy_1; else fuzzy_result := fuzzy_2; end if; end if; end if; if use_threshold then temp := new AST'(threshold_marker, fuzzy_result, threshold); else temp := new AST'(fuzzy_value, fuzzy_result); end if; current_truth := fuzzy_result; end binary_logic; procedure binding_comparator is begin -- -- Execute a comparator -- temp_bindings := bindings; unify_arg(operator.left_operand, operator.right_operand, level, level, temp_bindings, unified); if (unified xor (operator.binary_op /= not_equal)) then temp := new AST'(fuzzy_value, 0.0); current_truth := 0.0; failed := true; else temp := new AST'(fuzzy_value, 1.0); current_truth := 1.0; end if; if not (operator.binary_op = not_equal) then -- save the bindings bindings := temp_bindings; end if; end binding_comparator; procedure comparator is begin -- -- Execute a comparator -- lookup(operator.left_operand,level,bindings,left_value,trash); lookup(operator.right_operand,level,bindings,right_value,trash); if (left_value.is_a = right_value.is_a) or ((left_value.is_a = integer_num) and (right_value.is_a = float_num)) or ((left_value.is_a = float_num) and (right_value.is_a = integer_num)) then -- possible to compare the two case left_value.is_a is when predicate => if (operator.binary_op = equality) or (operator.binary_op = not_equality) then matched := left_value.name.name = right_value.name.name; elsif operator.binary_op = less_than then matched := left_value.name.name < right_value.name.name; elsif operator.binary_op = greater_than then matched := left_value.name.name > right_value.name.name; elsif operator.binary_op = less_or_equal then matched := left_value.name.name <= right_value.name.name; else -- operator.binary_op = greater_or_equal then matched := left_value.name.name >= right_value.name.name; end if; when variable => if (operator.binary_op = equality) or (operator.binary_op = not_equality) then matched := (left_value.v_name.name = right_value.v_name.name); else error(no_pointer,"uninstantiated variable to <, =<, >, or >="); failed := true; end if; when integer_num | float_num => if left_value.is_a = integer_num then fp_1 := float(left_value.int_num); else fp_1 := left_value.fp_num; end if; if right_value.is_a = integer_num then fp_2 := float(right_value.int_num); else fp_2 := right_value.fp_num; end if; if (operator.binary_op = equality) or (operator.binary_op = not_equality) then matched := fp_1 = fp_2; elsif operator.binary_op = less_than then matched := fp_1 < fp_2; elsif operator.binary_op = greater_than then matched := fp_1 > fp_2; elsif operator.binary_op = less_or_equal then matched := fp_1 <= fp_2; else -- operator.binary_op = greater_or_equal then matched := fp_1 >= fp_2; end if; when character_lit => if (operator.binary_op = equality) or (operator.binary_op = not_equality) then matched := left_value.char = right_value.char; elsif operator.binary_op = less_than then matched := left_value.char < right_value.char; elsif operator.binary_op = greater_than then matched := left_value.char > right_value.char; elsif operator.binary_op = less_or_equal then matched := left_value.char <= right_value.char; else -- operator.binary_op = greater_or_equal then matched := left_value.char >= right_value.char; end if; when others => put("Error -- comparator "); put(operator.node_type); put(" received invalid operand of type "); put(left_value.is_a); new_line; failed := true; end case; else matched := false; if (left_value.is_a = variable) or (right_value.is_a = variable) then if (operator.binary_op /= equality) and (operator.binary_op /= not_equality) then error(no_pointer, "uninstantiated variable to <, =<, >, or >="); failed := true; -- else -- no error since == and \== can have uninstantiated variables end if; else if (operator.binary_op /= equality) and (operator.binary_op /= not_equality) then error(no_pointer, "cannot compare different node types"); failed := true; -- else -- no error since == and \== can compare different node types end if; end if; end if; if operator.binary_op = not_equality then matched := not matched; end if; if matched and (not failed) then temp := new AST'(fuzzy_value, 1.0); current_truth := 1.0; else temp := new AST'(fuzzy_value, 0.0); current_truth := 0.0; failed := true; end if; end comparator; procedure unary_logic is begin -- -- Execute a unary logic operator. Turns out "not" is the only one -- if operator.operand.node_type = fuzzy_value then fuzzy_1 := operator.operand.fuzzy_num; elsif operator.operand.node_type = threshold_marker then fuzzy_1 := operator.operand.fuzzy_value; use_threshold := true; else put("fuzzy operator "); put(operator.unary_op); put(" given invalid operand of type "); put(operator.operand.node_type); new_line; failed := true; end if; if failed then fuzzy_result := 0.0; else fuzzy_result := 1.0 - fuzzy_1; end if; if use_threshold then temp := new AST'(threshold_marker, fuzzy_result, threshold); else temp := new AST'(fuzzy_value, fuzzy_result); end if; current_truth := fuzzy_result; end unary_logic; begin -- execute case operator.node_type is when binary_operator => -- -- If the operands are themselves operators, execute them -- if (operator.left_operand.node_type = binary_operator) or (operator.left_operand.node_type = binary_operator) then execute(operator.left_operand, bindings, level, failed); end if; if (operator.right_operand.node_type = binary_operator) or (operator.right_operand.node_type = binary_operator) then execute(operator.right_operand, bindings, level, failed); end if; -- -- If successful so far, execute this operator -- if not failed then case operator.binary_op is when asterisk | minus | rw_mod | plus | slash => binary_arithmetic; when equal | rw_is | not_equal => binding_comparator; when equality | not_equality | less_than | greater_than | less_or_equal | greater_or_equal => comparator; when bar | comma | hat | semicolon => binary_logic; when others => error(no_pointer, "binary operator not implemented"); failed := true; end case; end if; when unary_operator => -- -- If the operands are themselves operators, execute them -- if (operator.operand.node_type = binary_operator) or (operator.operand.node_type = binary_operator) then execute(operator.operand, bindings, level, failed); end if; -- -- If successful so far, execute this operator -- if not failed then case operator.unary_op is when rw_not => unary_logic; when others => warning(no_pointer, "unary operator not implemented"); failed := true; end case; end if; when others => error(no_pointer, "invalid operator node to 'execute'"); failed := true; end case; -- -- Now release everything from this operator on down -- release(operator, null); operator := temp; end execute;