-- *********** This file contains most of the logic system code ***********
-- It consists of four packages, the first two quite short, the final one long.
-- The first package merely concentrates various global variables used in this file
-- (some of which are accessed externally).
-- The third package contains many of the principal logic system procedures, plus
-- an extensive collection (1300 lines) of direct tests of these routines, used in debugging
-- them, and potentially useful for reversion testing.
-- ************************************************************************
--
package logic_parser_globals; -- this is a package of global variables used by logic parser and other basic packages
var running_on_server := true; -- flag: are we running on the server, or standalone
var user_prefix := ""; -- prefix identifying user in shared web environment
var debug_count := 0; -- utility count for debugging
var debug_handle := OM; -- file for writing debug information
var debug_var := false; -- an externally visible debug var that can be writtn by codes using this package
var debug_blobbed_tree,debug_conj,debug_conj2,formula_after_blobbing,formula_after_boil_down;
-- debug_conj2 and formula_after_blobbing are used to indicate the conjunct being tried when inferences are getting slow
var blob_counter := 0; -- used to support special usare of the variable name 'BLOB'
var satisfying_cases := {"2","6","7","10","11"}; -- satisfying case for MLSS model
var equalities_rep_map := {}; -- maps nodes being blobbed into their parsed equality-simplified forms
var allow_blob_simplify := true; -- flag for turning special blob simplifications on and off
-- convenient abbreviations of parse-tree headers
var abbreviated_headers := "ast_list`[]~ast_of`()~ast_iter_list`itr~ast_genset`{}~ast_in`in~ast_ofa`{.}~ast_eq`=~" +
"ast_exists`EX~ast_ex_iter`Etr~ast_forall`ALL~ast_enum_set`{-}~ast_and`and~ast_or`or~DOT_EQ`==~" +
"ast_add`+~ast_mult`*~ast_sub`-~ast_enum_tup`[-]~ast_not`not~ast_notin`notin~DOT_NEQ`/==~ast_ne`/=~" +
"ast_incs`incs~DOT_INCIN`incin~TILDE_`->~DOT_IMP`imp~_nullset`0~ast_genset_noexp`{/}~" +
"ast_null`null~ast_arb`arb~ast_assign`:=~AMP_`and~ast_domain`domain~ast_range`range~AT_`@~ast_nelt`#~" +
"ast_gt`>~ast_ge`>=~ast_lt`<~ast_le`<=~ast_pow`pow~ast_if_expr`if";
-- note that ast_ex_iter, abbreviated as 'itr',is the iterator list form used in existentials
-- other convenient abbreviations
const external_rep := {["_nullset","{}"],["ast_domain","domain"],["ast_range","range"]};
-- source representation of some constants, special maps, etc.
const specials_1 := {"pow","domain","range"}; -- special one-variable operators
const special_set_names := {"0","1","2","3","4","5","6","7","ZA","SI","FR","RA","RE","TRUE","FALSE","S_INF","RA_0","RA_1"};
-- names reserved by the logic codes and in scenario
-- functions for which various decision procedures are available., and which are therefore
-- carried unblobbed in some cases
const unblobbed_functions := {"CAR","CDR","MON","MONDN","BIG_MON","MON2","IDEMP",
"SELFINV","EQRELN","PORDRELN","TOTORDRELN","WINV","INV_OF","FINITE","IS_MAP"};
const monup_functions := {"MON","BIG_MON","MON2"};
-- these properties are used (a bit temporarily; prob. obsolete) in the
-- special processing annex of decompose_post_blobbing;
-- cf. special_mon, special_mondn, special_bigger_op, special_mon2
const mondn_functions := {"MONDN"};
var monotonicity_props := {}; -- maps operators to their monotonicity properties, for use in blob-to-monotone
var all_equalities := {}; -- variables which have been equated to each other in 'mlss_decider' routine
var allow_unblobbed_fcns := true; -- flag to determine whether internal examination of list of
-- specially declared functions is wanted
var allow_unblobbed_card := false; -- flag to determine whether cardinality operator can go unblobbed
-- or builtins like 'car' is desired
var branches_limit := 1000; -- limit for number of branches tried in MLSS decider nondeterministic
-- search before check of time
var seconds_limit := 25; -- limit for time allowed in MLSS decider
-- constants for conditional emission of parentheses on unparsing
const associative_ops_for_oup := {"and","or","+","*"}, paren_syntax_ops := {"{-}","[-]"};
-- global variables used in blobbing and related routines
var num_occurences_of := {}; -- global for equisatisfibility simplification
var the_prop_sgns := {}; -- global for find_prop_signs routine: determination of positivity/negativity of tree nodes.
var nuhblob := {}; -- auxiliary global to generate blobs for variables occuring in just one context
var simp1,simp2,simp3; -- store intermedate simplification values formed in 'boil_down_blobbed',
-- for scenario debug reporting
var vars_in_ifs; -- global used by 'find_vars_in_ifs'
var debug_tree; -- for debugging unicode_unparse
var unicode_mapping; -- maps input forms of logic names to their unicode representations
var entity_mapping; -- version of mapping actually used by unparse
const unicode_stg := -- encoding of logic names as unicode representations
"not,00AC;and,`0026`;AMP_,`0026`;•imp,`2192`;imp,`2192`;or,`2228`;•eq,`2194`;" +
"•incin,`2286`;incs,`2287`;in,`2208`;notin,`2209`;•NINCIN,`00AC⊆.`;•NINCS,`00AC⊇.`;" +
"ALL,2200;EX,2203;ast_assign,`2261Df`;:=,`2261Df`;" +
"+,222A;*,2229;•PROD,`00D7`;•PLUS,`002B`;•MINUS,`002D`;•TIMES,`2022`;•PLUZ,`2295`;•MINZ,`2296`;•TIMZ,`2297`;REVZ,1100;" +
"•neq,00AC↔.;/=,`2260`;<,003C;>,003E;>=,2265;<=,2264;" + -- ARE THESE REALLY NEEDED??
"arb,220B;pow, ℘.;UN, ∪.;" +
"domain,0414;range,042F;CAR,[1];CDR,[2];" +
"ORD,0049sO;CARD,0049sC;FINITE,0049sΦ.;NEXT, +.;OM,03A9;" +
"S_INF,0073∞.;ZA,2115;SI,2124;RA,211A;RE,211D;CM,2102;PI,043F;" +
"INT,222B`;ULEINT,222B+;LINE_INT,222B⋄.;" +
"•S_PLUS,`002Bℤ.`;•RA_PLUS,`002Bℚ.`;•R_PLUS,`002Bℝ.`;" +
"•C_PLUS,`002Bℂ.`;_nullset, {};" +
"S_REV,2212ℤ.;RA_REV,2212ℚ.;R_REV,2212ℝ.;C_REV,2212ℂ.;" +
"•S_MINUS,`002Dℤ.`;•RA_MINUS,`002Dℚ.`;•R_MINUS,`002Dℝ.`;" +
"•C_MINUS,`002Dℂ.`;" +
"•S_TIMES,`2022ℤ.`;•RA_TIMES,`2022ℚ.`;•R_TIMES,`2022ℝ.`;" +
"•C_TIMES,`2022ℂ.`;" +
"•H_TIMES,`2022ℇ.`;" +
"•H_PROD,`2297`;" +
"•S_GT,`003Eℤ.`;•S_LT,`003Cℤ.`;•S_GE,`2265ℤ.`;•S_LE,`2264ℤ.`;" +
"•RA_GT,`003Eℚ.`;•RA_LT,`003Cℚ.`;•RA_GE,`2265ℚ.`;•RA_LE,`2264ℚ.`;" +
"•R_GT,`003Eℝ.`;•R_LT,`003Cℝ.`;•R_GE,`2265ℝ.`;•R_LE,`2264ℝ.`;" +
"•C_GT,`003Eℂ.`;•C_LT,`003Cℂ.`;•C_GE,`2265ℂ.`;•C_LE,`2264ℂ.`;" +
"S_ABS,01C1ℤ.;RA_ABS,01C1ℚ.;ABS,01C1ℝ.;C_ABS,01C1ℂ.;" +
"RAS_ABS,01C1ℚ.ℕ.;" +
"RECIP,215Fℚ.;R_RECIP,215Fℝ.;C_RECIP,215Fℂ.;" +
"•RAS_PLUS,`002Bℚ.ℕ.`;•RAS_MINUS,`002Dℚ.ℕ.`;" +
"•RAS_TIMES,`2022ℚ.ℕ.`;RAS_REV,`2212ℚ.ℕ.`;" +
"RAS_RECIP,`215Fℚ.ℕ.`;•RAS_OVER,`002Fℚ.ℕ.`;" +
"IS_MAP,0049sM;" +
"•OVER,`002F`;•RA_OVER,`002Fℚ.`;•R_OVER,`002Fℝ.`;•C_OVER,`002Fℂ.`;" +
"@,25CA;•ON,026D;->,02C6;•IM,21B7;•INV_IM,21B6;INV, ←.;" +
"SAME_FRAC,`2248ℚ.`;RA_EQSEQ,`2248ℝ.`;ARG1_BEF_ARG2,`2220`;" +
"ONE_1_MAP,00311.;SVM,0049s1.;IDENT,03CA;" +
"•GT,`227B`;•LT,`227A`;•GE,` ≻.`;•LE,` ≺.`;ORD1P2,226A;" +
"SQRT,221A;EPS,03B5;DELT,03B4;" +
"FR, Fr;RF,211DF;SIGMA,2211;SIG,2211ℝ.;FSIG,2211ℝ.F;" +
"SIG_INF,2211ℝ.∞.;FSIG_INF,2211ℝ.F∞.;" +
"RF_REV,2212ℝ.F;•RF_GT,`003Eℝ.F`;•ToThe,`2191;" +
"CF,2102F;•CF_MINUS,`002Dℂ.F`;CEUC,2130ℂ.;EUC,2130;" +
"RECAUCHY,0043auℝ.;RESEQ,0053eqℝ.;" +
"•RES_PLUS,`002Bℝ.ℕ.`;•RES_MINUS,`002Dℝ.ℕ.`;•RES_TIMES,`2022ℝ.ℕ.`;" +
"RES_REV,`2212ℚ.ℕ.`;RES_RECIP,`215Fℝ.ℕ.`;•RES_OVER,`002Fℝ.ℕ.`;" +
"•POLPLUS,`002Bⓟ.`;•POLMINUS,`002Dⓟ.`;•POLTIMES,`2022ⓟ.`;" +
"RA_0,0030ℚ.;R_0,0030ℝ.;C_0,0030ℂ.;RF_0,0030ℝ.F;" +
"RA0SEQ,0030ℚ.ℕ.;RA1SEQ,0031ℚ.ℕ.;" +
"RA_1,0031ℚ.;R_1,0031ℝ.;C_1,0031ℂ.;" +
"IS_ANALYTIC_CF,25C8;IS_CONTINUOUS_RF,2240ℝ.F;IS_CONTINUOUS_CF,2240ℂ.F;" +
"IS_CONTINUOUS_RENF,2240ℝ.Fn;IS_CONTINUOUS_CENF,2240ℂ.Fn;" +
"IS_CONTINUOUS_CORF,2240ℂ.ℝ.;CDER,2181;CRDER,2181ℂ.;NORM,01C1;" +
"RAS_ABS,01C1ℚ.ℕ.;" +
"RED, ➮.ℤ.;FR_TO_RA, ➮ℚ.;CAUCHY_TO_RE, ➮.ℝ.;" +
"•MOD,`2193`;CONCAT,`002Bσ.`;SUBSEQS,03C3⊆.;FIN_SEQS,0049sΦ.σ.;" +
"ULT_MEMBS,2208....;IS_NONNEG,0049s≥.0ℤ.;" +
"RA_IS_NONNEG,0049s≥.0ℚ.;FR_IS_NONNEG,0049s≥.0Fr;" +
"R_IS_NONNEG,0049s≥.0ℝ.;C_IS_NONNEG,0049s≥.0ℂ.;" +
"RACAUCHY,0043auℚ.;RASEQ,0053eqℚ.;" +
"•F_TIMES,`2022F`;•F_PLUS,`2022F`;•F_MINUS,`2022F`;•F_OVER,`002FF`;" +
"_THRYVAR,Θ.;" +
"==>,27A8;DEF, ";
const priority_info := {
-- priority from strongest to weakest is:
-- monadics, set binaries, arithmetic binaries and builtin set binaries, comparators, quantifiers, propositionals
-- syntactics
["THEORY", [1801,"FX"]], ["ENTER_THEORY", [1801,"FX"]], ["DISPLAY_THEORY", [1801,"FX"]], ["FINISH_THEORY", [1801,"FX"]],
["APPLY_THEORY", [1801,"FX"]],
["==>", [800,"YFX"]], [":=", [801,"XFX"]],
-- the tags used are FX (left monadic); YF (right monadic); YFX (binary associating to the left), XFY, XFX
-- monadics
["#", [1800,"FX"]], ["INV", [1801,"YF"]], ["arb", [1800,"FX"]], ["UN", [1800,"FX"]],
["pow", [1800,"FX"]], ["domain", [1800,"FX"]], ["range", [1800,"FX"]], ["FINITE", [1800,"FX"]],
["CARD", [1800,"FX"]], ["ORD", [1800,"FX"]], ["CAR", [1801,"YF"]], ["CDR", [1801,"YF"]], ["NEXT", [1801,"YF"]],
["IS_MAP", [1800,"FX"]],["DEF", [1800,"FX"]],["RAS_REV", [1800,"FX"]],["RAS_RECIP", [1800,"FX"]],["RAS_ABS", [1800,"FX"]],
["RA_ABS", [1800,"FX"]],["ABS", [1800,"FX"]],["C_ABS", [1800,"FX"]],["RA_REV", [1800,"FX"]],
["UN", [1800,"FX"]],["RED", [1800,"FX"]],["FR_TO_RA", [1800,"FX"]],["CAUCHY_TO_RE", [1800,"FX"]],["R_REV", [1800,"FX"]],
["RF_REV", [1800,"FX"]],["S_REV", [1800,"FX"]],["S_ABS", [1800,"FX"]],["ULT_MEMBS", [1800,"FX"]],["IDENT", [1800,"FX"]],
["SQRT", [1800,"FX"]],["LUB", [1800,"FX"]],["RA_RECIP", [1800,"FX"]],["R_RECIP", [1800,"FX"]],["C_RECIP", [1800,"FX"]],
-- arithmetic monadics
["RAS_REV", [1800,"FX"]], ["RAS_RECIP", [1800,"FX"]], ["RAS_ABS", [1800,"FX"]], ["RA_ABS", [1800,"FX"]], ["R_ABS", [1800,"FX"]],
["NORM", [1800,"FX"]], ["CDER", [1800,"FX"]], ["CRDER", [1800,"FX"]], ["ABS", [1800,"FX"]], ["C_ABS", [1800,"FX"]],
["RA_REV", [1800,"FX"]], ["S_REV", [1800,"FX"]], ["R_REV", [1800,"FX"]], ["C_REV", [1800,"FX"]],
["RF_REV", [1800,"FX"]],
["RECIP", [1800,"FX"]], ["S_RECIP", [1800,"FX"]], ["R_RECIP", [1800,"FX"]], ["C_RECIP", [1800,"FX"]], ["SQRT", [1800,"FX"]],
-- other set binaries
["•ON", [1650,"YFX"]], ["DOT_ON", [1650,"YFX"]], ["•INV_IM", [1650,"YFX"]], ["•IM", [1650,"YFX"]], ["•PROD", [1650,"YFX"]], ["@", [1650,"YFX"]],
["->", [1650,"YFX"]],
-- builtin set binaries
["+", [1500,"YFX"]], ["-", [1500,"YFX"]], ["*", [1600,"YFX"]],
-- arithmetic binaries
["•OVER", [1600,"YFX"]], ["•PLUS", [1500,"YFX"]], ["•MINUS", [1500,"YFX"]], ["•TIMES", [1600,"YFX"]], ["•MOD", [1600,"YFX"]],
["•RA_PLUS", [1500,"YFX"]], ["•RA_MINUS", [1500,"YFX"]], ["•RA_TIMES", [1600,"YFX"]], ["•RA_OVER", [1600,"YFX"]],
["•RAS_PLUS", [1500,"YFX"]], ["•RAS_MINUS", [1500,"YFX"]], ["•RAS_TIMES", [1600,"YFX"]], ["•RAS_OVER", [1600,"YFX"]],
["•OVER", [1600,"YFX"]], ["•TOTHE", [1600,"YFX"]],
["•R_MAX", [1500,"YFX"]], ["•R_PLUS", [1500,"YFX"]], ["•R_MINUS", [1500,"YFX"]], ["•R_TIMES", [1600,"YFX"]],
["•R_PROD", [1600,"YFX"]], ["•R_TIMES_ABS", [1600,"YFX"]], ["•R_PLUS", [1500,"YFX"]], ["•R_OVER", [1600,"YFX"]],
["•RES_PLUS", [1500,"YFX"]], ["•RES_MINUS", [1500,"YFX"]], ["•RES_TIMES", [1600,"YFX"]], ["•RES_OVER", [1600,"YFX"]],
["•S_PLUS", [1500,"YFX"]], ["•S_MINUS", [1500,"YFX"]], ["•S_TIMES", [1600,"YFX"]],
["•C_OVER", [1600,"YFX"]], ["•C_PLUS", [1500,"YFX"]], ["•C_MINUS", [1500,"YFX"]], ["•C_TIMES", [1600,"YFX"]],
["•H_TIMES", [1600,"YFX"]], ["•H_PROD", [1600,"YFX"]],
["CONCAT", [1500,"YFX"]], ["•POLPLUS", [1500,"YFX"]], ["•POLMINUS", [1500,"YFX"]], ["•POLTIMES", [1600,"YFX"]],
-- pointwise arithmetic binaries
["•CF_MINUS", [1500,"YFX"]],
["•F_PLUS", [1500,"YFX"]], ["•F_MINUS", [1500,"YFX"]], ["•F_TIMES", [1600,"YFX"]], ["•F_OVER", [1600,"YFX"]],
["SIG", [1500,"YFX"]], ["SIG_INF", [1500,"YFX"]],
["FSIG", [1500,"YFX"]], ["FSIG_INF", [1500,"YFX"]],
["INT", [1500,"YFX"]], ["ULEINT", [1500,"YFX"]],
-- generic binaries
["•PLUZ", [1500,"YFX"]], ["•TIMZ", [1600,"YFX"]], ["•MINZ", [1500,"YFX"]],
-- built-in and related comparators
["=", [1300,"XFX"]], ["/=", [1300,"XFX"]], ["in", [1300,"XFX"]], ["notin", [1300,"XFX"]],
["•incin", [1300,"XFX"]], ["incin", [1300,"XFX"]], ["incs", [1300,"XFX"]], ["•NINCIN", [1300,"XFX"]], ["•NINCS", [1300,"XFX"]],
-- other comparators
["•RA_LE", [1300,"XFX"]], ["•RA_LT", [1300,"XFX"]], ["•RA_GE", [1300,"XFX"]], ["•RA_GT", [1300,"XFX"]],
["•R_GT", [1300,"XFX"]], ["•R_GE", [1300,"XFX"]], ["•R_LT", [1300,"XFX"]], ["•R_LE", [1300,"XFX"]],
["•RF_GT", [1300,"XFX"]],
["•S_LE", [1300,"XFX"]], ["•S_LT", [1300,"XFX"]], ["•S_GE", [1300,"XFX"]], ["•S_GT", [1300,"XFX"]],
["•G_GE", [1300,"XFX"]], ["•G_GT", [1300,"XFX"]], ["•G_LE", [1300,"XFX"]], ["•G_LT", [1300,"XFX"]],
["•GE_THRYVAR", [1300,"XFX"]], ["•LE_THRYVAR", [1300,"XFX"]], ["•GT_THRYVAR", [1300,"XFX"]], ["•LT_THRYVAR", [1300,"XFX"]],
["/==", [1300,"XFX"]],
-- other comparators, written as binary functions
["SAME_FRAC", [1300,"XFX"]], ["ARG1_BEF_ARG2", [1300,"XFX"]], ["ORD1P2_THRYVAR", [1300,"XFX"]],
["RA_EQSEQ", [1300,"XFX"]],
-- quantifiers
["EX", [1260,"FX"]], ["ALL", [1260,"FX"]],
-- boolean monadic
["not", [1250,"FX"]],
-- boolean binaries
["and", [1000,"YFX"]], ["AMP_", [1000,"YFX"]], ["or", [900,"YFX"]],
["•eq", [820,"XFX"]], ["==", [820,"XFX"]], ["imp", [820,"YFX"]], ["ast_assign", [820,"YFX"]]};
-- removed
--["BLANK", [801,"YFX"]], ["DOTBLANK", [801,"YFX"]], ["COMMA", [1301,"YFX"]],
--["::", [800,"YFX"]], [";", [900,"YFX"]], [",", [1000,"YFX"]],
--["{}", [810,"FX"]], ["WT", [810,"YFX"]], ["ST", [810,"YFX"]], ["OPP", [1800,"YF"]],
--["SHADOW_BIIMP", [820,"XFX"]], ["SHADOW_IMP", [850,"YFX"]],
const max_prio := 2000; -- nominal priority of variables and function applications
const fcn_prio := 1998; -- nominal priority of variables and function applications
const left_associators := {"YFX","XFX","ToThe"}; -- tags of left-associating infix operators
const monadic_prios := {1800,1801,1250}; -- priorities of monadic operators
const monadics_set := {"RAS_REV","RAS_RECIP","RAS_ABS","RA_ABS","ABS","C_ABS","RA_REV","CDR","CAR","NEXT","INV",
"UN","RED","FR_TO_RA","CAUCHY_TO_RE","DEF","R_REV","RF_REV","S_REV","S_ABS","ULT_MEMBS","IDENT","SQRT","LUB",
"RA_RECIP","R_RECIP","C_RECIP","INT"};
const right_monadics := {"CDR","CAR","NEXT","INV","RED","FR_TO_RA","CAUCHY_TO_RE"};
const infixes_set := {"CONCAT","SAME_FRAC","RA_EQSEQ"}; -- ,"ARG1_BEF_ARG2"
var parent_prio; -- global for return of priorities from routines larg, rarg, and marg
end logic_parser_globals;
package body logic_parser_globals; -- global variables for logic parser and other basic packages
-- body is empty since only the globalizing header of thes package is used.
end logic_parser_globals;
package logic_parser_aux; -- auxiliary routines for basic logic routines
procedure build_model(membs_inv,givn_vars,sorted_membs); -- build a model for a saturated set of memberships
procedure set_rep(n); -- returns the set representation of an integer (memoized using globals)
end logic_parser_aux;
package body logic_parser_aux; -- auxiliary routines for logic basic routines
use logic_parser_globals; -- global variables for logic parser and other basic packages
procedure build_model(membs_inv,givn_vars,sorted_membs); -- build a model for a saturated set of memberships
-- variables not in the set of givn_vars need only be distinct, and distinct from all givn_vars.
-- For this, we use integers n larger than the largest number of members known to belong to any set
--dump_handle := open("dump_file","TEXT-OUT") ;print(dump_handle,"build_model -- membs_inv = \n",membs_inv,"\ngivn_vars =\n",givn_vars,"\nsorted_membs =\n",sorted_membs); stop;
-- memb_counts := []; dmi := domain(membs_inv); print("dmi",dmi); for x in dmi loop mix := membs_inv{x}; memb_counts with:= #mix; end loop;
-- memb_ctr := 0 max/ memb_counts;
--print("*********** build_model *********** ",all_equalities);
memb_ctr := 0 max/ [#membs_inv{x}: x in domain(membs_inv)]; -- the integer with which we start
modl := {}; -- the model to be built
-- the pairs of variables relted by available equalities
ae_symm := all_equalities + {[y,x]: [x,y] in all_equalities};
sorted_set := {x: x in sorted_membs}; -- the variables not previously identified with any other
rep_of := {[x,arb(ae_symm{x} * sorted_set)]: x in domain(ae_symm)};
-- find some surviving variable equal to each variable previously identified with some other
for v in sorted_membs loop
modl(v) := if v notin givn_vars then set_rep(memb_ctr +:= 1) else {modl(if x = "0" then "_nullset" else x end if): x in membs_inv{v}} end if;
end loop;
--print("membs_inv: membs_inv = ",membs_inv," modl = ",modl,"\nrep_of = ",rep_of,"\nsorted_set = ",sorted_set,"\nall_equalities = ",all_equalities);
givn_vars -:= {"0","_nullset"}; -- dont show the models for these special variables
return {[v,modl(v)?modl(rep_of(v))?{}]: v in givn_vars | is_string(v)};
-- we are only interested in the model values for the original vars
end build_model;
procedure set_rep(n); -- returns the set representation of an integer (memoized using globals)
-- the globals used are set_rep_param, which records the largest integer whose value was calculated
-- previously by this recursion, and set_rep_val, which records the set encoding of set_rep_val
--return n; -- temporarily disabled
if n = 0 then set_rep_param := 0; return set_rep_val := {}; end if;
if set_rep_param = n - 1 then -- if the set encoding of the preceding integer is available, use i
set_rep_param := n;
set_rep_val with:= set_rep_val;
return set_rep_val;
end if;
-- otherwise proceed recursively
set_rep_val := (prev := set_rep(n - 1)) with prev;
set_rep_param := n;
return set_rep_val;
end set_rep;
end logic_parser_aux;
-- *********** Layout of the routines in the following package ***********
-- Section (1): utilities
-- (1.1) utility parse and print routines
-- (1.2) topological sort of strings
-- Section (2): logic procedures proper (approx. 4800 lines)
-- (2.1) blobbing routines, which prepare for use of the battery of decision algorithms
-- (2.2) routines intermediate between blobbing and MLSS inference proper
-- (2.3) simplifications of various built-in operations
-- (2.4) additional special simplifications, for use with the ELEM decision routines
-- (2.5) propositional-level simplifications involving the signs of propositional variables
-- (2.6) direct interfaces between blobbing and the 'ELEM' logical inference mechanism
-- (2.7) analysis of formulae for monotonicity
-- (2.8) auxiliary routine for standardizing chains of associative operators
-- (2.9) routines which handle 'algebraic' deduction
-- (2.10) substitution routines: replace free variables in a formula by specified expression
-- (2.11) simplification of setformers (these routines are invoked by the 'SIMPLF' hint)
-- (2.12) equality inference routines (these routines are invoked by the 'EQUAL' hint)
-- Section (3): additional utilities
-- ***************************************************************
package logic_syntax_analysis_pak; -- syntax_analysis routines for logic system
-- ********** syntax analysis, supplements to syntax analysis and syntactic inference mechanisms **********
var blob_name := {}; -- maps currently bound variable to its generated name (made external for debugging only)
var blob_name_ctr := 0; -- counter for naming of blobs
-- (made external for termination of equation saturation in extract_equalities routine)
-- extract_equalities is in file logic_main_architecture
var blab_name_ctr := 0; -- counter for naming of variables BLA_nnn
procedure init_logic_syntax_analysis(); -- initialize for logic syntax-tree operations
procedure parze_expr(stg); -- print source; then parse
procedure unparse(tree); -- puts a tree back into string format
procedure apparently_pred(tree); -- routine determining wheter an expression is a predicate or not
procedure unicode_unparse(tree); -- puts a tree back into a unicode version of its original string format
procedure convert_to_unicode(stg); -- convert a formula to unicode
procedure cleanup(parse_tree); -- simplifies the parse_tree; returns string
procedure clean_tree(parse_tree); -- simplifies the parse_tree; returns tree
procedure dump_tree(parse_tree); -- dumps the parse_tree in indented format
procedure dump_in(parse_tree,indent); -- recursive workhorse for dump-tree
procedure prant(stg); -- auxiliary compressing print
procedure end_prant(); -- terminates compressing print sequence
-- ********** srecursive tree-walkers, which detect and summarize various aspects of syntax trees **********
procedure standardize_bound_vars(formula); -- standardize the bound variable names in a formula
procedure standardize_bound_vars_noad(formula);
-- standardize the bound variable names in a formula, restarting bound variable names counter
procedure drop_parens(stg); -- drop some unnecessary parens
procedure tree_starts(treetop_tup,node); -- tests the structure of the top of a tree
procedure flatten_same_ops(node);
-- get the chain of all identical infix operations starting at a given node at which this operation appears
----* procedure defmemb(tree1,tree2,substitution_map);
-- check validity of a defmemb deduction involving a quantified statement or a set membership relation
procedure substitute(tree,substitution_map);
-- makes substitutions for specified free variables of a formula. (main entry; uses workhorse)
procedure substitute_in(tree,substitution_map,bound_vars);
-- inner recursive workhorse of substitution routine
procedure gen_name(rw name_ctr); -- generate a new blob name
----* procedure check_definition(tree,symbols); -- check a recursive or nonrecursive definition for validity
----* procedure check_pred_definition(tree,statement,symbols); -- checks skolem-type definition for validity
----* procedure range_blob(node);
-- this blobs a set expressions and quantifiers down functions involving basic set-theretic operators
-- which may be amenable to specialized decison algorithms
procedure find_free_vars(node); -- find the free variables in a tree (main entry)
procedure find_free_vars_in(node,bound_vars); -- find the free variables in a tree (recursive workhorse)
procedure find_free_vars_from(node,bound_vars);
-- find the free variables in a tree (alternative main entry, used by blob_to_monotone)
procedure find_bound_vars(node); -- find the bound variables at the top of an iterator tree
procedure find_all_vars(node); -- find all the variables in a formula
procedure find_iterators(node); -- find the iterator list at the top of an iterator tree
procedure new_name(stg,nameset); -- generates new names for bound variables during a simplification operation
procedure simplify_setformer(tree);
-- removes specified membership iterators over setformer expressions
procedure top_sort_stgs(G);
-- topological sorting procedure. G is a dependency graph for a set of strings; used to sort iterators
-- ********** formula blobbing **********
procedure blob_tree(tree); -- blobs a tree down to extended MLSS (other versions will also be needed); top entry
procedure get_blob(stg); -- once a tree has been blobbed to a structured string, this routine looks it up
-- in the collection of all such strings, to determine its blob number
procedure blob_tree_in(node); -- blobs a tree down to extended MLSS; recursive workhorse
procedure blob_to_string(node,bound_vars,name_ctr); -- blobs a tree down to a string (main subroutine for blob_tree_in)
procedure boil_down_blobbed(tree); -- this vital routine removes useless clauses from the blobbed version of a formula
-- performs simplify_builtins, simplify_onces, exploit_prop_sign in order
procedure simplify_builtins(tree); -- simplifies various expressions involving built-in operators
-- ********** interface to the 'ELEM' logical inference mechanism **********
procedure model_blobbed(formula);
-- models a blobbed mlss formula, or pronounces it unsatisfiable by returning OM
procedure decompose_post_blobbing(formula); -- decomposition procedure for formulae blobbed to a decidable language
procedure Davis_Putnam(clause_set,term_decider,td_prms);
-- Extended Davis-Putnam procedure for verifying propositional consistency.
procedure mlss_decider(truth_value,td_params); -- tableau-based term decider for mlss
procedure find_repmap(equalities); -- find mapping of items to representatives for a set of equalities
procedure reduce_by_repmap(items,repmap); -- reduce a set of tuples using a mapping of items to representatives
-- ********** interface to the 'ALGEBRA' logical inference mechanism **********
procedure enable_algebra(operator_list,context);
-- enables elementary algebraic deduction for elements of a set and operators on it
procedure algebra(formula,context); -- handles elementary algebraic deduction
procedure standardize_formula(poly_tree,op_obj_tup); -- standardizes a polynomial tree belonging to a specified algebraic theory
procedure check_member(blob_tree,alg_objects_set,context);
-- ********** interface to the 'DIFFERENCE' logical inference mechanism **********
procedure verify_equality(tree1,tree2,context,is_pred); -- verifies equality or equivalence of two formulae (main entry)
procedure verify_equality_in(tree1,tree2,bound_vars_with_ranges,context,is_pred); -- verifies equality or equivalence of two formulae (workhorse)
procedure flatten_universal(node); -- get the chain of universal quantifiers starting at a given node a first universal appears
procedure flatten_existential(node); -- get the chain of all existential quantifiers starting at a given node a first existential appears
procedure common_iter_len(list_of_iters_1,list_of_iters_2,body_1,body_2); -- find the iterator portions which are of the same types
procedure build_quantified_version(formula,bnd_vars_with_ranges); -- add appropriate quantifiers to a formula
-- ********** monotonicity interface **********
procedure post_monotone(op_and_arg_string); -- note the monotonicity property of one or more function symbols
procedure drop_monotone(ops);
-- drop the monotonicity property of one or more function symbols
-- procedure monotone_inference(node1,node2);
-- [MOVED] calculates conditions for value defined by node 1 to include value defined by node 2 [MOVED TO logic_syntax_analysis_pak2]
-- *********** Test Collection ***********
procedure test_basic_parses; -- view parse trees of basic constructions
procedure test_standardize_bound_vars; -- tests of standardize bound variables function
procedure test_blob_to_string; -- tests of blob_to_string function
procedure test_blobbing; -- test the blob_tree function
procedure test_top_sort_stgs; -- test the top_sort_stgs function
procedure unparse_test; -- test unparse operation
procedure blobstring_tests; -- direct test of blobstring operation
procedure test_find_bound_vars; -- test the 'find_bound_vars' operation, for setformer and iteration nodes
procedure test_find_free_vars; -- test the 'find_free_vars' operation, for setformer and iteration nodes
-- procedure test_monotone_inference; -- [MOVED] test of the monotone_inference procedure [MOVED TO logic_syntax_analysis_pak2]
procedure test_simplify_setformer; -- test the simplify_setformer routine
procedure test_bool_exp(stg,fcn); -- check agreement of davis_putnam and truth-table for 4-varialbe boolean expressions
procedure small_mlss_test; -- initial explicit test of mlss decider
procedure test_model_blobbed(); -- initial tests and timing of the mlss verifier
procedure test_build_quantified; -- test of 'build_quantified_version' routine
procedure test_algebra(); -- initial tests of ALGEBRA deduction
procedure test_equality_inference(); -- initial tests of equality inferencing
procedure test_equality_more; -- supplemental equality tests
procedure timing_tests; -- a few tests of MLSS timing
procedure test_mls(); -- Eugenio's collection of MLS tests
procedure substitution_test; -- substitution test
procedure test_find_diffs; -- test of 'find_diffs' procedure
procedure test_simplify_builtins; -- test of special simplifications for builtin operators
procedure test_simplify_onces; -- test of special simplifications for variables appearing once
procedure test_count_free_vars; -- test of count_free_vars routine
procedure test_find_prop_signs; -- test of search routine for propositional variables of one sign
procedure test_exploit_prop_signs; -- test of search routine exploiting propositional variables of one sign
procedure test_boil_down_blobbed; -- test overall simplification of blobbed expression
procedure test_proof_by_computation; -- proof by computation test
-- *********** decision algorithm tests ***********
procedure test_Davis_Putnam; -- test the Davis_Putnam propositional decision algorithm
-- *********** Miscellaneous additional routines ***********
-- ******* algebra auxiliaries *******
-- procedure algebra_blob_in(formula); -- recursive workhorse for algebra bolobbing; builds blobbed_formula and global algebra_blobs_map
-- procedure algebra_get_blob(stg); -- once a tree has been blobbd to a structured string, this routine looks it up in the collection of all such strings,
-- procedure enable_algebra(operator_list,context); -- enables elementary algebraic deduction for elements of a set and operators on it
-- procedure replace_symbols(stg,replacement_map); -- replace specified letters by corresponding range elements
-- ******* auxiliaries for decompose_post_blobbing *******
-- procedure decompose_in(formula,is_prop); -- recursive inner workhorse for formula decomposition
-- procedure atom_with_meaning(tup); -- find or form an atom with the specified meaning
-- procedure atom_with_set_meaning(tup); -- find or for an atom with the specified set-value meaning
-- procedure atom_with_sp_set_meaning(tup); -- find or for an atom with the specified set-value meaning
-- procedure special_bigger_op(bigop,op); -- special processing for pair of monotone operators in known inclusion relationship
-- procedure special_equiv_reln(reln); -- special processing for equivalence relationships
-- procedure special_idempotent(op); -- special processing for idempotent functions
-- procedure special_inher_add(pred); -- special processing for inherited-additive predicates
-- procedure special_mon(op); -- special processing for monotone operator
-- procedure special_mon2(op); -- special processing formonotone operator with 2 arguments
-- procedure special_mondn(op); -- special processing for monotone decreasing operator
-- procedure special_part_order(reln); -- special processing for partial-order relationships
-- procedure special_self_inverse(op); -- special processing for self_inverse functions
-- procedure special_tot_order(reln); -- special processing for total-order relationships
-- ******* auxiliaries for mlss deduction and Davis-Putnam *******
-- procedure find_mlss_model(op_app_0,op_app_1,op_app_2, -- find a model of a predigestd set of mlss clauses
-- procedure find_mlss_model_with_new(new_pos_cl,new_neg_cl,op_app_0,op_app_1,op_app_2, -- variant of find_mlss_model; processes 1 or 2 new clauses at very start
-- procedure DP_biased_pos(term,unsatisfied_clauses,singles,one_sign,
-- procedure DP_in(unsatisfied_clauses,singles,one_sign, -- inner workhorse of the Davis-Putnam procedure
-- procedure deduce_from_neg_memb(x,y); -- make all deductions from a positive membership relation 'x notin y'
-- procedure deduce_from_pos_memb(x,y); -- make all deductions from a positive membership relation 'x in y'
-- procedure remove_clause(clause,rw unsatisfied_clauses, -- used to remove a clause which has been satisfied
-- ******* auxiliaries for handle_quant_clause *******
-- procedure match_to(tree1,tree2); -- tree matching algorithm, biases toward sustitutions in tree1 (ain entry)
-- procedure match_to_in(tree1,tree2,bound_vars); -- tree matching algorithm, biases toward substitutions in tree1 (workhorse)
-- procedure strip_and_match(tree1,tree2,num_quants,num_conj,quant_list);
-- ******* auxiliaries for Horn resolution *******
-- procedure next_vect(v,limit); -- increments a vector of integers, up to the final vector [limiit,limit,...]
-- ******* debugging auxiliaries *******
-- procedure maytrace(n); if debug_trace_details or debug_was_shown then print("maytrace: ",n); end if; end maytrace;
-- procedure atom_stg(x); -- converts atom to string
-- procedure blob_and_check(a1,a2,op_obj_tup,context); -- perform blob_and_check test in specified theory
-- procedure check_in_context(formula,bnd_vars_with_ranges,context);
-- procedure top_sort(G); -- 'plain' topological sorting procedure, done crudely
end logic_syntax_analysis_pak;
package proof_by_computation; -- package for proof by computation
procedure compute_check(tree); -- main proof by computation routine
procedure test_equality(u,v); -- recursive test for object equality
procedure test_membership(u,v); -- test for object membership
procedure set_encoding(n); -- compute the set encoding of an integer n
procedure map_comp_simplif(tree); -- simplify a map composition (see comment attached to code)
end proof_by_computation;
package body logic_syntax_analysis_pak; -- syntax_analysis routines for logic system
use string_utility_pak,parser,sort_pak; -- various auxiliary packages used. 'parser' is the standard SETL parser
use logic_parser_globals; -- global variables for logic parser and other basic packages
use logic_parser_aux; -- auxiliary routines for logic basic routines
use proof_by_computation; -- proof_by_computation routines
-- *********** declarations of global constants and variables ***********
const nblanks := 4; -- number of spaces to indent at each level of indented print
var prior_prant_stg := "",len_prior_stg := 0; -- globals for indented printing
var truth_value_debug; -- for closer examination of Davis_Putnam inferences
var debug_equality_atom; -- for closer examination of Davis_Putnam inferences
var debug_trace_details := false; -- for closer examination of Davis_Putnam inferences
var debug_was_shown := false; -- for closer examination of Davis_Putnam inferences
var DP_branches_count := 0; -- count used to suppress excess Davis_Putnam branching
var DP_start_secs := 0; -- time at which Davis_Putnam branching begins
var trying_count := 0; -- count used to issue extra messages on longish ELEM inferences
var restore_bvar_name_ctr2 := true; -- flag controlling recursive backtracking of bound variable name generator
var OK_for_algebra := {["SI", "DOT_S_PLUS", "DOT_S_TIMES", "DOT_MINUS", "S_0", "S_1"]};
-- tuples of object and operator names for which elementary algebraic reasoning applies.
var algebra_blob_name_ctr := 0, algebra_blob_name := {}; -- blobbing globals for special 'algebra' processing
var bvar_name_ctr := 0; -- counter for generating new bound variable names
var bvar_name_ctr2 := 0; -- counter for generating new bound variable names, in standardize_bound_vars_in
var full_bvar_name_ctr2; -- communication global for 'standardize_bound_vars_noad' and 'standardize_bound_vars_adv'
var all_free_vars := {},free_vars_count := {},prior_free_vars_context := {}; -- used in 'find_free_vars'
var pred_atom := {}; -- maps special predicates and functions into their associated atoms
var value_of_variable := {}, existentially_quantified := {}; -- used by verify_instance
var defined_symbols := {}; -- the collection of all defined symbols
var diffs_vars_ranges := []; -- global for 'find_diffs' procedure
var op_appearances_0, op_appearances_1, op_appearances_2,prior_addnal_setrelns; -- globals for 'mlss_decider' routine
var singletons,only_memb,given_vars; -- more globals for 'mlss_decider' routine
const infix_set_ops := {"+","-","*"}; -- constants for 'mlss_decider' routine
-- this maps various special infix operators to their negated forms
const reverse_meaning := {["in","notin"],["notin","in"],["incs","nincs"],["nincs","incs"],["incin","nincin"],["nincin","incin"],["=","/="],["/=","="]};
-- the more limited set of logical negations supported by the SETL syntax
const logical_negation := {["=","/="],["in","notin"],["•eq","•neq"],["/=","="],["notin","in"],["•neq","•eq"]};
const verify_specials := {"EX","ALL","in","notin","not","imp"}; -- special node types for 'verify_instance_in'
var is_contradiction := false; -- global failure flag for 'mlss_decider' routine
var bound_vars_global := {}; -- set used in 'sbstitute' setformer and existential processing
var set_rep_param := OM,set_rep_val; -- globals for von Neumann set_rep(n) calculation
var extra_monotone_ops := {},associative_ops := {},associative_commutative_ops := {}; -- operators of exploitable syntactic character
const additive_kind := 2, increasing_kind := 1, decreasing_kind := -1, mixed_kind := 0; -- characteristics used in 'blob_to_monotone'
const up_set := {additive_kind,increasing_kind}; -- additional constants for monotonicity calculation
const elem_ops := {"and", "or", "==", "=", "+", "*", "-", "{-}", "[-]", "in", "not", "notin", "/=="}; -- elementary operations;
-- note that "+", "*", "-" are set uninon, intersection, and difference; "{-}" and "[-]" are enumerated set and ordered tuple
const negateds := {"/=","notin","•eq","•neq"}; -- the 'pre-negated' operations
--->special case templates
-- various constants for parse-tree top special casing *****
-- for detecting node structures that may be subject to special simplifications
const map_of_mapformer_treetop := ["ast_of", "IS_MAP", ["ast_list", ["ast_genset", ["ast_enum_tup"]]]];
const svm_of_svmformer_treetop := ["ast_of", "SVM", ["ast_list", ["ast_genset", ["ast_enum_tup"]]]];
const oneone_of_oneone_former_treetop := ["ast_of", "ONE_1_MAP", ["ast_list", ["ast_genset", ["ast_enum_tup"]]]];
const car_of_pair_treetop := ["ast_of", "CAR", ["ast_list", ["ast_enum_tup"]]];
const cdr_of_pair_treetop := ["ast_of", "CDR", ["ast_list", ["ast_enum_tup"]]];
const arb_of_singleton_treetop := ["ast_arb", ["ast_enum_set"]];
const finite_of_number_treetop := ["ast_of", "FINITE", ["ast_list", ["ast_nelt"]]];
const svm_map_composition_treetop := ["AT_", ["ast_genset", ["ast_enum_tup"], ["ast_iter_list"]], ["ast_genset", ["ast_enum_tup"], ["ast_iter_list"]]];
const ord_of_next_treetop := ["ast_of", "ORD", ["ast_list", ["ast_of", "NEXT"]]];
const domain_of_genmap_treetop := ["ast_domain", ["ast_genset", ["ast_enum_tup"]]];
const range_of_genmap_treetop := ["ast_range", ["ast_genset", ["ast_enum_tup"]]];
-- *********** globals for Proof-by-computation ***********
var set_of_patterns,remaining_to_subdivide,list_of_atoms,atom_of_var;
-- atom_of_var is also used to store the value temporaily associated with bound variables in iterators and
-- setformers.
var card; -- cardinality produced by get_cardinality to avoid recalculation
-- *********** start of procedures ***********
-- *********** we begin with a collection of utility parse and print routines ***********
procedure init_logic_syntax_analysis(); -- initialize for logic syntax-tree operations
-- this setup procedure must be called (just once!) before any parsing begins
-- it just sets up a map of standard SETL syntactic markers to more readable abbreviated forms of the same
if is_string(abbreviated_headers) then abbreviated_headers := {p: p in breakup(breakup(abbreviated_headers,"~"),"`")}; end if;
unicode_mapping := setup_unicode_mapping(unicode_stg); -- maps input forms of logic names to their unicode representations
--print("unicode_mapping",unicode_mapping);
end init_logic_syntax_analysis;
procedure setup_unicode_mapping(ucode_stg); --- maps input forms of logic names to their unicode representations
return {[x,make_spaces(y)]: [x,y] in breakup(breakup(unicode_stg,";"),",")};
end setup_unicode_mapping;
procedure make_spaces(stg); -- maps input forms of logic names to their unicode representations; adds strings indicated by '`'
if stg = OM then return "***ERROR***"; end if;
return "" +/ [if x(1) = "`" then #x * " " else
if (xf4 := x(1..4)) = " " then "" else "&#x" + xf4 + ";" end if + dot_to_semi(x(5..)) end if: x in segregate(stg,"`") | x /= ""];
end make_spaces;
procedure dot_to_semi(stg); -- convert periods to semicolons
span(stg," ");
return "" +/ [if piece(1) = "." then #piece * ";" else piece end if: piece in segregate(stg,".")];
end dot_to_semi;
procedure parze_expr(stg); -- preliminary printing/diagnosing parse; parses and echos semicolon terminated formula
-- note: this expects a semicolon-terminated string as input,
-- and returns a pair ["ast_list",parse_tree], where 'parse_tree' is the parse tree of the input formula
nprint(".....parsing: ",stg); -- this just echos the formula being parsed, and then
-- calls the built-in parse. If parse fails, an abbreviated report
-- is printed.
if (ps := parse_expr(stg)) /= OM then print(" OK"); return ps; end if;
print("\n",setl_num_errors()," ************* ERRORS"); abort(setl_err_string(1));
end parze_expr;
procedure cleanup(parse_tree); -- simplifies the parse_tree by converting the built-in SETL parser's
-- syntactic marks to more readable abbreviated form
-- and removing unneeded quote marks
-- returns the cleaned-up parse tree as a string
-- the standard SETL node names are simply replaced by their abbreviated forms,
-- and quotation characters filtered out
if is_string(parse_tree) then return abbreviated_headers(parse_tree)?parse_tree; end if;
head_sign := parse_tree(1);
cleaned_tup := [abbreviated_headers(pt1 := parse_tree(1))?pt1] + [cleanup(x): x in parse_tree(2..)];
return suppress_chars(str(cleaned_tup),"\""); -- filter out quotation characters
end cleanup;
procedure clean_tree(parse_tree); -- simplifies the parse_tree; returns tree
-- the standard SETL node names are simply replaced by their abbreviated forms,
-- but quotation characters are not filtered out
if is_string(parse_tree) then return abbreviated_headers(parse_tree)?parse_tree; end if;
head_sign := parse_tree(1);
return [abbreviated_headers(pt1 := parse_tree(1))?pt1] + [clean_tree(x): x in parse_tree(2..)];
end clean_tree;
-- auxiliary parse-tree dump routine
procedure dump_tree(parse_tree); -- dumps the parse_tree in indented format
print(); dump_in(parse_tree,0); -- just call the recursive workhorse
end dump_tree;
procedure dump_in(parse_tree,indent); -- recursive workhorse for tree dump
-- tracjs indentation
-- this prints each tree node encountered in abbreviated form,
-- followed by more indented prints of the node's descendants
if is_string(parse_tree) then prant(indent * " " + parse_tree); return; end if;
head_sign := parse_tree(1);
prant(indent * " " + (ah := abbreviated_headers(pt1 := parse_tree(1))?pt1));
for x in parse_tree(2..) loop dump_in(x,indent + nblanks); end loop;
end dump_in;
procedure prant(stg); -- auxiliary for parse-tree dump routine
-- tries to keep successively printed sections on a single line,
-- but starts new lines whennecesary
blanks := span(stg," "); nb := #blanks; -- separate and count the blanks at the start of the line
if prior_prant_stg = "" then -- we are starting over
prior_prant_stg := stg; len_prior_stg := #prior_prant_stg;
return;
end if;
if len_prior_stg < nb then -- append the new line to the old, deleting leading blanks
prior_prant_stg +:= (nb - len_prior_stg) * " " + stg; len_prior_stg := #prior_prant_stg; return;
end if;
print(prior_prant_stg); prior_prant_stg := blanks + stg; len_prior_stg := #prior_prant_stg;
end prant;
procedure end_prant(); -- terminates sequence of lines set up by 'prant'
if len_prior_stg > 0 then print(prior_prant_stg); len_prior_stg := 0; end if;
end end_prant;
procedure looky(x); print("looky: ",x); return x; end looky;
-- used for debugging; prints its argument, and then returns it
procedure unparse(tree); -- puts a tree back into an approximation of its original string format
op_above := OM; emit_right := []; -- for suppressing unwanted parentheses; initialize recursion stack to empty
entity_mapping := {};
debug_tree := tree; if type(tree) notin ["TUPLE","STRING"] then return "****** BAD TREE IN unparse: not tuple or string " + str(tree?"OM. "); end if;
return unparse_in(tree); -- just call the recursive workhorse
end unparse;
procedure unicode_unparse(tree); -- puts a tree back into a unicode version of its original string format
op_above := OM; emit_right := []; -- for suppressing unwanted parentheses; initialize recursion stack to empty
entity_mapping := unicode_mapping;
debug_tree := tree; if type(tree) notin ["TUPLE","STRING"] then return "****** BAD TREE IN unicode-unparse: not tuple or string: " + str(tree?"OM. "); end if;
res := unicode_unparse_in(tree)(2); -- just call the recursive workhorse, but drop the 'priority' component of the result
--print("unicode_unparse result: ",res);
return res;
end unicode_unparse;
procedure unparse_in(tree); -- recursive workhorse for unparsing routine.
-- unparses nodes recursively by combining uparsed subnodes appropriately
-- most of this just handles SETL builtin operators
-- this routine suppresses many (but not all) superfluous parentheses
-- by using some operator precedence info.
-- control variables for conditional emission of parentheses on unparsing
var op_above,pri_op_above,emit_right := [false];
if tree = OM then print("bad tree for unparsing: ",debug_tree); stop; end if;
--print("unparse_in: ",type(tree)," ",tree," op_above: ",op_above," new op_above: ",abbreviated_headers(tree(1))?tree(1));
if is_string(tree) then return entity_transform(tree)?external_rep(tree)?tree; end if; -- case of bottom-level name
pri_op_above := op_above;
[n1,n2,n3] := tree; -- tree nodes most often (but not always) represent infix operators
case (op_above := abbreviated_headers(n1)?n1) -- note the lead operator for later use
when "if" => -- we have an if statement or expression
conds_and_vals := [n2,n3]; -- we flattten nested if-then-elses into a simpler
-- if .. then .. eseif.. else .. end if string form
while abbreviated_headers((else_part := tree(4))(1)) = "if" loop
conds_and_vals +:= else_part(2..3); tree := else_part;
end loop;
return join(["if " + unparse_in(conds_and_vals(j)) + " then " + unparse_in(conds_and_vals(j + 1)): j in [1,3..#conds_and_vals]]," else")
+ " else " + unparse_in(else_part) + " end if";
when "and","AMP_" => return lpa() + unparse_in(n2) + entity_mapping("and")?" and " + unparse_in(n3) + rpa(); -- conjunction
when "or" => return lpa() + unparse_in(n2) + entity_mapping("or")?" or " + unparse_in(n3) + rpa(); -- disjunction
when "==" => return lpa() + unparse_in(n2) + entity_mapping("•eq")?" •eq (" + unparse_in(n3) + ")" + rpa(); -- equivalence
when "=" => return lpa() + unparse_in(n2) + " = " + unparse_in(n3) + rpa(); -- identity
when "+" => return lpa() + unparse_in(n2) + entity_mapping("+")?" + " + unparse_in(n3) + rpa(); -- union
when "*" => return lpa() + unparse_in(n2) + entity_mapping("*")?" * " + unparse_in(n3) + rpa(); -- intersection
when "-" => return lpa() + unparse_in(n2) + entity_mapping("-")?" - " + unparse_in(n3) + rpa(); -- difference
when "@" => return lpa() + unparse_in(n2) + entity_mapping("@")?" @ " + unparse_in(n3) + rpa(); -- map composition
when "{-}" => return "{" + join([unparse_in(nj): nj in tree(2..)],",") + "}"; -- enumerated set
when "[-]" => return "[" + join([unparse_in(nj): nj in tree(2..)],",") + "]"; -- ordered pair
when "in" => return lpa() + unparse_in(n2) + entity_mapping("in")?" in " + unparse_in(n3) + rpa(); -- membership
when "not" => return "(" + entity_mapping("not")?"not " + unparse_in(n2) + ")"; -- negation
when "pow" => return "(" + entity_mapping("pow")?"pow " + unparse_in(n2) + ")"; -- powerset
when "#" => return "(#" + unparse_in(n2) + ")"; -- cardinality
when "arb","domain","range" => return "(" + entity_mapping(op_above)?op_above + " " + unparse_in(n2) + ")";
-- arb, domain, range
when "notin" => return lpa() + unparse_in(n2) + entity_mapping("notin")?" notin " + unparse_in(n3) + rpa(); -- nonmembership
when "/==" => return lpa() + unparse_in(n2) + entity_mapping("•neq")?" •neq " + "(" + unparse_in(n3) + ")" + rpa();
-- inequivalence
when "/=" => return lpa() + unparse_in(n2) + entity_mapping("/=")?" /= " + unparse_in(n3) + rpa(); -- inequality
when "incs" => return lpa() + unparse_in(n2) + entity_mapping("incs")?" incs " + unparse_in(n3) + rpa(); -- inclusion
when "incin" => return lpa() + unparse_in(n2) + entity_mapping("•incin")?" •incin (" + unparse_in(n3) + ")" + rpa();
-- inclusion in
when "imp" => return lpa() + unparse_in(n2) + entity_mapping("•imp")?" •imp " + "(" + unparse_in(n3) + ")" + rpa();
-- implication
when "->" => return lpa() + unparse_in(n2) + entity_mapping("->")?" ~" + unparse_in(n3) + rpa(); -- map application
when "[]" => return unparse_in(n2); -- list; should be of length 1
when "()" => return unparse_in(n2) + "(" + join([unparse_in(x): x in n3(2..)],",") + ")"; -- function application
when "itr","Etr" => return join([drop_parens(unparse_in(x)): x in tree(2..)],", "); -- iteration
when "{/}" => return "{" + unparse_in(n2) + if n3(1) /= "null" then " | " + unparse_in(n3) else "" end if + "}"; -- setformer, no exp
when "{}" => return "{" + unparse_in(n2) + ": " + unparse_in(n3) -- setformer
+ if (n4 := tree(4)) /= OM and abbreviated_headers(n4(1)) /= "null" then " | " + unparse_in(n4) else "" end if + "}";
when "{.}" => return unparse_in(n2) + "{" + join([unparse_in(x): x in n3(2..)],",") + "}"; -- multivalued function application
when "EX" => return "(" + entity_mapping("EX")?"EXISTS " + unparse_in(n2) + " | " + unparse_in(n3) + ")";
-- existential
when "ALL" => return "(" + entity_mapping("ALL")?"FORALL " + unparse_in(n2) + " | " + unparse_in(n3) + ")"; -- universal
when "ast_end" => return "(" + unparse_in(n2) + "(" + unparse_in(n3) + "..)"; -- end_slice
when ">","<",">=","<=" => return "(" + unparse_in(n2) + " " + entity_mapping(op_above)?op_above + " " + unparse_in(n3) + ")"; -- comparisons
otherwise => -- can be monadic or binary operator
if #n1 > 4 and n1(1..4) = "DOT_" then n1(1..4) := "•"; end if;
-- stay alert for •-prefixed operators
-- distinguish between monadic and binary cases
return if n3 = OM then if n2 = OM then n1 else "(" + entity_transform(n1)?n1 +
" " + entity_transform(n2)?n2 + ")" end if
else "(" + unparse_in(n2) + " " + entity_mapping(n1)?n1 +
if n1(1) = "•" then " (" else "(" end if + unparse_in(n3) + if n1(1) = "•" then "))" else "))" end if end if;
end case;
procedure lpa(); -- suppression of some parentheses unneeded during reparsing: conditional left parenthesis
-- omit parentheses for series of identical associative operators, or for the direct children of function-call operators
if (op_above = pri_op_above and pri_op_above in associative_ops_for_oup)
or pri_op_above in paren_syntax_ops then
emit_right with:= false; return "";
end if;
emit_right with:= true; return "(";
-- if the left-parenthesis is omitted, signal for omission of the corresponding right parenthesis
end lpa;
procedure rpa(); -- suppression of some parentheses unneeded during reparsing: conditional right parenthesis
em frome emit_right; return if em?false then ")" else "" end if;
end rpa;
end unparse_in;
procedure apparently_pred(tree); -- routine determining wheter an expression is a predicate or not
-- returns 'true' for predicates, 'false' otherwise
return apparently_pred_in(tree); -- recursive workhorse
end apparently_pred;
procedure apparently_pred_in(tree); -- recursive workhorse for routine determining wheter an expression is a predicate or not
-- returns 'true' for predicates, 'false' otherwise
if is_string(tree) then return false; end if; -- case of bottom-level name
[n1,n2,n3] := tree; -- tree nodes most often (but not always) represent infix operators
case (op_above := abbreviated_headers(n1)?n1) -- note the lead operator for later use
when "if" =>
conds_and_vals := [n2,n3]; -- we flattten nested if-then-elses into a simpler
-- if .. then .. elseif.. else .. end if string form
while abbreviated_headers((else_part := tree(4))(1)) = "if" loop
conds_and_vals +:= else_part(2..3); tree := else_part;
end loop;
return apparently_pred_in(conds_and_vals(2)); -- take the first value, assuming that it is typical
when "and","AMP_","or","==","=","in","not","notin","/==","/=","incs","incin","imp","EX","ALL" => return true;
when ">","<",">=","<=" => return true; -- comparisons
-- we have a logical expression
when "+","*","-","@","{-}","[-]","pow","#","arb","domain","range","->","()","{.}","{/}","ast_end" => return false;
-- obviously a set expression
otherwise => -- can be monadic or binary operator
if #n1 > 4 and n1(1..4) = "DOT_" then
return if n1(#n1 - 1..) in {"GE","GT","LE","LT"} then true else false end if;
end if;
return false;
end case;
end apparently_pred_in;
procedure unicode_unparse_in(tree); -- recursive workhorse for unparsing routine, unicode version
-- unparses nodes recursively by combining uparsed subnodes appropriately
-- most of this just handles SETL builtin operators
-- this routine suppresses many (but not all) superfluous parentheses
-- by using some operator precedence info.
-- control variables for conditional emission of parentheses on unparsing
-- this routine returns a pair [pro,stg], where stg is the unparsed string version of a node, and
-- prio is the priority of its topmost operator. To determine wheter parentheses are needed,
-- we combine this priority with the priority of the parent node, in a manner depending on the
-- operator position in which it appears among the children of its parent. The procedures which
-- do this are larg(parent_op,child_info) [used for left arguments of binaries],
-- rarg(parent_op,child_info) [used for left arguments of binaries],
-- marg(parent_op,child_info) [used for arguments of monadics],
-- and aarg(child_info) [used for function arguments, which never require parentheses]
-- Unparsing also depends on whether an operator is marked as 'postfix', and for functions
-- of two variables on whether it is marked as translate_to_binary.
-- Successive monadics on opposite sides of their argument are always parenthesized.
var op_above;
--if (debug_count -:=1) <= 0 then print("reached debug limit: "); stop; end if;
--print("unicode_unparse_in: ",type(tree)," ",unparse(tree)," new op_above: ",abbreviated_headers(tree(1))?tree(1));
if tree = OM then print("****** ERROR - undefined tree node: @",debug_tree,"@",type(debug_tree),"@"); stop; end if;
if is_string(tree) then return [max_prio,entity_transform(tree)?external_rep(tree)?tree]; end if; -- case of bottom-level name
pri_op_above := op_above;
[n1,n2,n3] := tree; -- tree nodes most often (but not always) represent infix operators
case (op_above := abbreviated_headers(n1)?n1) -- note the lead operator for later use
when "if" => -- we have an if statement or expression
conds_and_vals := [n2,n3]; -- we flattten nested if-then-elses into a simpler
-- if .. then .. elseif.. else .. end if string form
while abbreviated_headers((else_part := tree(4))(1)) = "if" loop
conds_and_vals +:= else_part(2..3); tree := else_part;
end loop;
return [max_prio,join(["if " + aarg(conds_and_vals(j)) + " then " + aarg(conds_and_vals(j + 1)): j in [1,3..#conds_and_vals]]," else")
+ " else " + aarg(else_part) + " end if"];
when "and","AMP_" => res := larg(op_above,n2) + entity_mapping("and")?" and " + rarg(op_above,n3); -- conjunction
return [parent_prio,res];
when "or" => res := larg(op_above,n2) + entity_mapping("or")?" or " + rarg(op_above,n3); -- disjunction
return [parent_prio,res];
when "==" => res := larg(op_above,n2) + entity_mapping("•eq")?" •eq " + rarg(op_above,n3); -- equivalence
return [parent_prio,res];
when "=" => res := larg(op_above,n2) + " = " + rarg(op_above,n3); -- identity
return [parent_prio,res];
when "+" => res := larg(op_above,n2) + entity_mapping("+")?" + " + rarg(op_above,n3); -- union
return [parent_prio,res];
when "*" => res := larg(op_above,n2) + entity_mapping("*")?" * " + rarg(op_above,n3); -- intersection
return [parent_prio,res];
when "-" => res := larg(op_above,n2) + entity_mapping("-")?" - " + rarg(op_above,n3); -- difference
return [parent_prio,res];
when "@" => res := larg(op_above,n2) + entity_mapping("@")?" @ " + rarg(op_above,n3); -- map composition
return [parent_prio,res];
when "{-}" => return [max_prio,"{" + join([aarg(nj): nj in tree(2..)],",") + "}"]; -- enumerated set
when "[-]" => return if #tree = 2 then [max_prio,"(" + aarg(tree(2)) + ")"] else -- ordered pair or map-application singleton
[max_prio,"[" + join([aarg(nj): nj in tree(2..)],",") + "]"] end if;
when "in" => res := larg(op_above,n2) + entity_mapping("in")?" in " + rarg(op_above,n3); -- membership
return [parent_prio,res];
when "not" => res := entity_mapping("not")?"not " + marg(op_above,n2); -- negation
return [parent_prio,res];
when "pow" => res := entity_mapping("pow")?"pow " + marg(op_above,n2); -- powerset
return [parent_prio,res];
when "#" => res := "#" + marg(op_above,n2); -- cardinality
return [parent_prio,res];
when "arb","domain","range" => res := entity_mapping(op_above)?op_above + marg(op_above,n2);
-- arb, domain, range
return [parent_prio,res];
when "notin" => res := larg(op_above,n2) + entity_mapping("notin")?" notin " + rarg(op_above,n3); -- nonmembership
return [parent_prio,res];
when "/==" => res := larg(op_above,n2) + entity_mapping("•neq")?" •neq " + rarg(op_above,n3); -- inequivalence
return [parent_prio,res];
when "/=" => res := larg(op_above,n2) + entity_mapping("/=")?" /= " + rarg(op_above,n3); -- inequality
return [parent_prio,res];
when "incs" => res := larg(op_above,n2) + entity_mapping("incs")?" incs " + rarg(op_above,n3); -- inclusion
return [parent_prio,res];
when "incin" => res := larg(op_above,n2) + entity_mapping("•incin")?" •incin " + rarg(op_above,n3); -- inclusion in
return [parent_prio,res];
when "imp" => res := larg(op_above,n2) + entity_mapping("•imp")?" •imp " + rarg(op_above,n3); -- implication
return [parent_prio,res];
when "->" => res := larg(op_above,n2) + entity_mapping("->")?"~" + rarg(op_above,n3); -- map application
return [parent_prio,res];
when "[]" => return unicode_unparse_in(n2); -- list; should be of length 1
when "()" => if n2 in right_monadics then -- function application, with function treated as right monadic operator
return [fcn_prio,join([marg(n2,x): x in n3(2..)],",") + aarg(n2)];
elseif n2 in monadics_set then -- function application, with function treated as monadic operator
return [fcn_prio,aarg(n2) + join([marg(n2,x): x in n3(2..)],",")];
elseif n2 in infixes_set then -- function application, with function treated as infix operator
return [fcn_prio,larg(n2,n3(2)) + entity_transform(n2)?n2 + rarg(n2,n3(3))];
else
return [fcn_prio,aarg(n2) + "(" + join([aarg(x): x in n3(2..)],",") + ")"];
end if;
when "itr","Etr" => res := join([aarg(x): x in tree(2..)],", "); -- iteration
return [max_prio,res];
when "{/}" => return [max_prio,"{" + aarg(n2) + if n3(1) /= "null" then " | " + aarg(n3) else "" end if + "}"];
-- setformer, no exp
when "{}" => return [max_prio,"{" + aarg(n2) + ": " + aarg(n3) -- setformer
+ if (n4 := tree(4)) /= OM and abbreviated_headers(n4(1)) /= "null" then " | " + aarg(n4) else "" end if + "}"];
when "{.}" => return [fcn_prio,aarg(n2) + "{" + join([aarg(x): x in n3(2..)],",") + "}"]; -- multivalued function application
when "EX" => res := "(" + entity_mapping("EX")?"EXISTS " + aarg(n2) + " | " + aarg(n3) + ")"; -- existential
return [max_prio,res];
when "ALL" => res := "(" + entity_mapping("ALL")?"FORALL " + aarg(n2) + " | " + aarg(n3) + ")"; -- universal
return [max_prio,res];
when "ast_end" => res := aarg(n2) + "(" + aarg(n3) + "..)"; -- end_slice
return[fcn_prio,res];
when ">","<",">=","<=" => res := larg(op_above,n2) + entity_mapping(op_above)?op_above + rarg(op_above,n3);
-- comparisons
return [parent_prio,res];
otherwise => -- can be monadic or binary operator
if #n1 > 4 and n1(1..4) = "DOT_" then n1(1..4) := "•"; end if;
-- stay alert for •-prefixed operators
-- distinguish between monadic and binary cases
res := if n2 = OM then entity_transform(n1)?n1
elseif n3 = OM then entity_transform(n1)?n1 + marg(op_above,n2)
else larg(n1,n2) + entity_transform(n1)?n1 + rarg(n1,n3) end if;
return [parent_prio,res];
end case;
procedure larg(parent_op,child); -- used for left arguments of binaries
-- if the child priority is less than that of the parent, so that it has bound, but not due to
-- priority, then it must be parenthesized. Also, if the child priority equals that of the parent,
-- and the parent binds to the right (relative to operators of equal precedence), then the
-- binding of the child is not due to precedence, so parentheses must be inserted.
-- for monadic operators, we need consider the priority only if it is a left monadic.
-- the tags used are FX (left monadic); YF (right monadic); YFX and XFX (binary associating to the left),
-- also XFY (binary associating to the right; but none of these are used as yet; exponential may eventually be one such)
if priority_info(parent_op) = OM then print("stopped prio OM: ",parent_op," ",debug_tree); stop; end if;
--if unicode_unparse_in(child) = OM then print("stopped at: ",parent_op); stop; end if;
[chpri,chstg] := unicode_unparse_in(child); -- unpack the child info
child_is_monadic := chpri in monadic_prios;
child_is_left_monadic := (chpri mod 2) = 0;
[parent_prio,parent_tag] := priority_info(parent_op); -- get the priority of the parent
parent_associates_left := parent_tag in left_associators;
--print("child parsed: ",parent_op," ",chpri," ",chstg," ");
need_parens := false; -- but might be set to true by the following lines
if not child_is_monadic then -- have a non-monadic child
need_parens := parent_prio > chpri or (parent_prio = chpri and (not parent_associates_left));
elseif child_is_left_monadic and parent_prio > chpri then -- have a monadic child
need_parens := true;
end if;
--print("larg done: ",parent_op," ",chstg);
return if need_parens then "(" + chstg + ")" else chstg end if;
end larg;
procedure rarg(parent_op,child); -- used for right arguments of binaries
-- if the child priority is less than that of the parent, so that it has bound, but not due to
-- priority, then it must be parenthesized. Also, if the child priority equals that of the parent,
-- and the parent binds to the left (relative to operators of equal precedence), then the
-- binding of the child is not due to precedence, so parentheses must be inserted.
-- for monadic operators, we need consider the priority only if it is a right monadic.
-- the tags used are FX (left monadic); YF (right monadic); YFX and XFX (binary associating to the left),
-- also XFY (binary associating to the right; but none of these are used as yet; exponential may eventually be one such)
[chpri,chstg] := unicode_unparse_in(child); -- unpack the child info
child_is_monadic := chpri in monadic_prios;
child_is_right_monadic := (chpri mod 2) = 1;
[parent_prio,parent_tag] := priority_info(parent_op); -- get the priority of the parent
parent_associates_left := parent_tag in left_associators;
need_parens := false; -- but might be set to true by the following lines
if not child_is_monadic then -- have a non-monadic child
need_parens := parent_prio > chpri or (parent_prio = chpri and parent_associates_left);
elseif child_is_right_monadic and parent_prio > chpri then -- have a monadic child
need_parens := true;
end if;
--print("parent_op,child: ",parent_op," ",child," ",priority_info(parent_op)," ",chpri," ",need_parens);
return if need_parens then "(" + chstg + ")" else chstg end if;
end rarg;
procedure marg(parent_op,child); -- used for arguments of monadics
-- if a monadic has a non-monadic child of lesser or equal priority, parentheses are needed
-- if a monadic has a monadic child of equal priority but of different sidedness parentheses are needed
-- if a monadic has a monadic child of lesser priority but of different sidedness parentheses are needed
--print("marg: ",parent_op," ",child);
if priority_info(parent_op) = OM then print("parent_op priority OM: ",parent_op," ",debug_tree); stop; end if;
--if unicode_unparse_in(child) = OM then print("child OM:"); stop; end if;
[chpri,chstg] := unicode_unparse_in(child); -- unpack the child info
child_is_monadic := chpri in monadic_prios;
child_is_right := (cpm := chpri mod 1) = 1;
[parent_prio,-] := priority_info(parent_op); -- get the priority of the parent
parent_is_right := (ppm := parent_prio mod 1) = 1;
parent_prio_even := parent_prio - ppm;
child_prio_even := chpri - cpm;
--print("child_is_monadic: ",child_is_monadic," ",parent_prio_even," ",child_prio_even);
need_parens := false; -- but might be set to true by the following lines
if child_prio_even <= parent_prio_even and (not child_is_monadic) then need_parens := true; end if;
if child_prio_even <= parent_prio_even and child_is_monadic and child_is_right /= parent_is_right then need_parens := true; end if;
--print("returning marg: "); stop;
return if need_parens then "(" + chstg + ")" else chstg end if;
end marg;
procedure aarg(child); -- used for function arguments, which never require parentheses
[chpri,chstg] := unicode_unparse_in(child); -- unpack the child info
return chstg; -- return the string, unparenthesized
end aarg;
end unicode_unparse_in;
procedure convert_to_unicode(stg); -- convert a formula to unicode
init_logic_syntax_analysis();
if (tree := parse_expr(fixup_char(stg + ";"))) = OM then
return "******** SYNTAX ERROR in " + stg;
end if;
return unicode_unparse(tree);
end convert_to_unicode;
procedure fixup_char(stg); -- comment
return "" +/ [if piece(1) = char(149) then #piece * char(165) else piece end if: piece in segregate(stg,char(149))];
end fixup_char;
procedure entity_transform(stg); -- special mapping of operator and variable names, especially for '_THRYVAR'
if entity_mapping = {} then return OM; end if; -- enabled only if has been called via unicode_unparse
tail := rmatch(stg,"_THRYVAR");
if tail /= "" then return entity_mapping(stg)?stg + "Θ"; end if;
if (em := entity_mapping(stg)) /= OM then return em; end if;
ostg := stg;
tail := rspan(stg,"0123456789");
if tail /= "" and stg /= "" then return entity_mapping(stg)?stg + "" + tail + ""; end if;
return entity_mapping(ostg)?ostg;
end entity_transform;
procedure drop_parens(stg); match(stg,"("); rmatch(stg,")"); return stg; end drop_parens;
-- drops miscellaneous unnecessary parentheses
-- ************ utility topological sort of strings ************
procedure top_sort_stgs(G); -- topological sorting procedure. G is a dependency graph for a set of strings
-- we sort them by keeping track of those which are 'ready'.
-- If multiple elements are ready we take the smallest of them, to standardize
nodes := (domain G) + (range G); -- build collection of items too be sorted
count := {}; -- initialize a count function
ready := nodes; -- The following loop will remove elements that have any predecessors from ready
for [x,y] in G loop -- initialize 'count' to map each node int its number of predecessors
count(y) := (count(y)?0) + 1;
ready less := y; -- since y has a predecessor
end loop;
-- At this point 'ready' is the set of all nodes without predecessors
t := []; -- t is the tuple being built up
while ready /= {} loop
ready less:= (n := merge_sort(ready)(1)); -- take the smallest of the ready elements
t with:= n;
for n1 in G{n} loop -- reduce the count of all successors of the node chosen
if (count(n1) -:= 1) = 0 then ready with:= n1; end if;
end loop;
end loop;
return t; -- return the tuple constructed
end top_sort_stgs;
procedure top_sort(G); -- 'plain' topological sorting procedure, done crudely
-- we sort them by keeping track of those which are 'ready'.
-- this simply omits the standardization step from the previous routine
nodes := (domain G) + (range G); -- build collection of items too be sorted
count := {}; -- initialize a count function
ready := nodes; -- The following loop will remove elements that have any predecessors from ready
for [x,y] in G loop -- initialize 'count' to map each node int its number of predecessors
count(y) := (count(y)?0) + 1;
ready less := y; -- since y has a predecessor
end loop;
-- At this point 'ready' is the set of all nodes without predecessors
t := []; -- t is the tuple being built up
while ready /= {} loop
n from ready; -- take the smallest of the ready elements
t with:= n;
for n1 in G{n} loop -- reduce the count of all successors of the node chosen
if (count(n1) -:= 1) = 0 then ready with:= n1; end if;
end loop;
end loop;
return t; -- return the tuple constructed
end top_sort;
-- *********** start of logic procedures proper (approx. 4800 lines) ***********
-- ** we begin with a collection of utility routines that standardize the bound variables in formulae **
procedure standardize_bound_vars(formula); -- standardize the bound variable names in a formula
-- This top-level routine is provided in two forms,
-- one of which maps initially identical bound variable names into identical standardized forms,
-- the other of which does not.
-- The code descends recursively through a parse tree, in left-to-right order,
-- finding operations which have bound variables. Each such variable is issued a reserved name
-- of the form BVX_nn, in the order in which they are encountered. A map from the original names
-- to these standardized names is maintained, and used to map subsequent occurrences of the same bound variables
-- to their new forms.
bvar_name_ctr2 := 0;
return standardize_bound_vars_in(formula,{}); -- just call the recursive workhorse
-- the second parameter initializes the 'std_bv_names' map
-- used in the recursive workhorse to {}
end standardize_bound_vars;
procedure standardize_bound_vars_in(tree,std_bv_names); -- standardize the bound variable names in a formula
-- We descend the tree recursively, keeping track of all the variables which are bound by iterators
-- encountered along the way. Whenever an iterator is encountered, the variables bound by it
-- are issued variant reserved forms like BVX_nnn, which are recorded in the
-- (local, hence restored on procedure return) map 'std_bv_names'. Each variable v lower in the tree for which
-- replace_v := std_bv_names(v) is defined is replaced by replace_v
if is_string(tree) then return std_bv_names(tree)?tree; end if; -- case of bottom-level name
-- if this variable has been bound by any preceding iterator, replace it by its BVX_nn form
--print("standardize_bound_vars_in: ",tree," ",std_bv_names);
[n1,n2,n3] := tree; -- unpack the parse_tree node, which is often infix (but not always)
case abbreviated_headers(n1)
-- the cases listed first are those tree nodes in which iterators appear
when "EX","ALL" => iter_list := n2(2..); more_bv_list := []; new_iter_list := []; -- existential, universal
--print("\nexistential, universal: ",tree," restore_bvar_name_ctr2: ",restore_bvar_name_ctr2);
save_bvar_name_ctr2 := bvar_name_ctr2; -- prepare to restore bound variable name counter
save_restoration_flag := restore_bvar_name_ctr2; restore_bvar_name_ctr2 := false;
for iter = iter_list(j) loop -- iterate over the variables bound by the iterator, issuing them unique standard names.
std_bv_names(if is_tuple(iter) then iter(2) else iter end if) := "BVX_" + (bvar_name_ctr2 +:= 1);
-- std_bv_names(iter(2)) := "BVX_" + (bvar_name_ctr2 +:= 1);
new_iter_list with:= standardize_bound_vars_in(iter,std_bv_names);
-- reformat each iterator in the list, replacing old bound variable names by new
-- Note: a Legality Test ought to be applied here or elsewhere: all iterators in setformers must be limited
end loop;
bdy := standardize_bound_vars_in(n3,std_bv_names); -- standardize the bound variable names in the quantifier body.
restore_bvar_name_ctr2 := save_restoration_flag;
if restore_bvar_name_ctr2 then bvar_name_ctr2 := save_bvar_name_ctr2; end if;
-- restore the bound variable name counter if it is not to advance systematically
-- restore_bvar_name_ctr2 is set false for 'both' blobbing; see routine blob_tree_inr
--print("standardized quantifier: ",[n1,["ast_iter_list"] + new_iter_list,bdy]);
return [n1,["ast_iter_list"] + new_iter_list,bdy]; -- return the reformatted quantifier
when "{/}" => iter_list := n2(2..); more_bv_list := []; new_iter_list := []; -- setformer, no exp
save_bvar_name_ctr2 := bvar_name_ctr2; -- prepare to restore bound variable name counter
for iter = iter_list(j) loop -- iterate over the variables bound by the iterator, issuing them unique standard names.
--print("iter_list: ",iter_list," ",j);
std_bv_names(iter(2)) := "BVX_" + (bvar_name_ctr2 +:= 1);
-- std_bv_names(iter(2)) := "BVX_" + (bvar_name_ctr2 +:= 1);
new_iter_list with:= standardize_bound_vars_in(iter,std_bv_names);
end loop;
result := [n1,["ast_iter_list"] + new_iter_list,standardize_bound_vars_in(tree(3),std_bv_names)];
-- standardize the bound variables in the setformer condition
if restore_bvar_name_ctr2 then bvar_name_ctr2 := save_bvar_name_ctr2; end if; -- restore bound variable name counter
-- restore the bound variable name counter if it is not to advance systematically
-- restore_bvar_name_ctr2 is set false for 'both' blobbing; see routine blob_tree_inr
return result; -- return the reformatted setformer
when "{}" => iter_list := n3(2..); more_bv_list := []; new_iter_list := []; -- setformer
save_bvar_name_ctr2 := bvar_name_ctr2; -- prepare to restore bound variable name counter
for iter = iter_list(j) loop -- iterate over the variables bound by the iterator, issuing them unique standard names.
std_bv_names(iter(2)) := "BVX_" + (bvar_name_ctr2 +:= 1);
-- std_bv_names(iter(2)) := "BVX_" + (bvar_name_ctr2 +:= 1);
new_iter_list with:= standardize_bound_vars_in(iter,std_bv_names);
end loop;
bdy := standardize_bound_vars_in(n2,std_bv_names); -- standardize the bound variables in the lead expression of the setformer
result := [n1,bdy,["ast_iter_list"] + new_iter_list,standardize_bound_vars_in(tree(4),std_bv_names)];
-- standardize the bound variables in the setformer condition
if restore_bvar_name_ctr2 then bvar_name_ctr2 := save_bvar_name_ctr2; end if; -- restore bound variable name counter
-- restore the bound variable name counter if it is not to advance systematically
-- restore_bvar_name_ctr2 is set false for 'both' blobbing; see routine blob_tree_inr
return result;
when "itr","Etr" => print("standardize_bound_vars_in shouldnt_happen: ",tree); return tree; -- iteration; handled elsewhere
when "[]" => print("standardize_bound_vars_in shouldnt_happen: ",tree); return tree; -- list; handled elsewhere
-- no iterators appear in the following node types, so we simply process the subnodes and combine them
-- in the manner that the node requires.
when "if" => -- if statement/expression
return [n1,standardize_bound_vars_in(n2,std_bv_names),standardize_bound_vars_in(n3,std_bv_names),
standardize_bound_vars_in(tree(4),std_bv_names)];
when "and","or","==","=","+","*","-","in","notin","/==","/=","incs","incin","imp","->" =>
return [n1,standardize_bound_vars_in(n2,std_bv_names),standardize_bound_vars_in(n3,std_bv_names)];
when "{-}","[-]" => return [n1] + [standardize_bound_vars_in(nj,std_bv_names): nj in tree(2..)];
-- enumerated set, ordered pair
when "not","arb" => return [n1,standardize_bound_vars_in(n2,std_bv_names)]; -- negation, arb
when "()","{.}" => return [n1,n2,[n3(1)] + [standardize_bound_vars_in(x,std_bv_names): x in n3(2..)]];
-- (multivalued) function application
otherwise => -- can be monadic or binary operator
res := if n2 = OM then [n1] elseif n3 = OM then [n1,standardize_bound_vars_in(n2,std_bv_names)]
else [n1,standardize_bound_vars_in(n2,std_bv_names),standardize_bound_vars_in(n3,std_bv_names)] end if;
return res;
end case;
end standardize_bound_vars_in;
-- modified bound variables standardization routines,
-- used subsequently in 'verify_instance' (formula matching routine)
procedure standardize_bound_vars_noad(formula); -- standardize the bound variable names in a formula,
-- restarting bound variable names counter
save_bvar_name_ctr2 := bvar_name_ctr2; -- save the bound variables name counter
res := standardize_bound_vars_in(formula,{}); -- call the recursive workhorse
full_bvar_name_ctr2 := bvar_name_ctr2; -- note maximum advance of name counter for use in 'standardize_bound_vars_adv'
bvar_name_ctr2 := save_bvar_name_ctr2; -- restore counter to its original value
return res;
end standardize_bound_vars_noad;
procedure standardize_bound_vars_adv(formula); -- standardize the bound variable names in a formula,
-- without restarting bound variable names counter
save_bvar_name_ctr2 := bvar_name_ctr2 ; -- save the bound variables name counter
res := standardize_bound_vars_in(formula,{}); -- call the recursive workhorse
bvar_name_ctr2 max:= full_bvar_name_ctr2; -- advance counter to its maximum value
return res;
end standardize_bound_vars_adv;
-- ************ blobbing routines, which prepare for use of the available battery of decision algorithms ************
procedure blob_tree(tree); -- blobs a tree down to MLSS (other versions will also be needed); top entry
blob_name_ctr := 0; blob_name := {}; -- clear auxiliary global counter and map
sbvt := standardize_bound_vars(tree);
--print("sbvt: ",unicode_unparse(sbvt)," ",sbvt);
return blob_tree_in(sbvt); -- just call the recursive workhorse
end blob_tree;
procedure get_blob(stg); -- once a tree has been blobbed to a structured string,
-- this routine looks it up in the collection of all such strings,
-- and returns its blob name if it has one; otherwise a new blob name is issued
--print("get_blob: ",stg," ",blob_name(stg)," ",blob_name_ctr);
if (bn := blob_name(stg)) /= OM then return bn; end if;
blob_name(stg) := gend := "BLB_" + str(blob_name_ctr +:= 1); return gend;
end get_blob;
procedure blob_tree_in(node); -- 'outer' recursive workhorse for blobbing; imposes use of equalities
-- Note: this should also handle classes of associative operators,
-- commutative operators, and algebra more generally
res := blob_tree_inr(node);
-- this next line modifies the blobbing procedure to use precalculated sets of identities among blobbed strings,
-- by replacing each string belonging to a set of strings known to be equal by a designated representative string chosen from the set.
res2 := if (eq_simp_res := equalities_rep_map(unparse(res))) /= OM then eq_simp_res else res end if;
-- if there is an equality which simplifies the blobbed result, then return that;
-- else simply the blobbed result
--print("node: ",unparse(node)," first blob result: ",unparse(res)," final blob result: ",unparse(res2)," equalities_rep_map ",equalities_rep_map);
return res2;
end blob_tree_in;
procedure blob_tree_inr(node); -- 'inner' recursive workhorse for blobbing:
-- blobs a tree down to MLSS (other versions will also be needed);
-- this routine handles the 'top' of the tree
-- (the unblobbed part of the tree structure)
-- nodes that need to be blobbed are handled by the
-- 'blob_to_string' procedure which follows this one.
-- We descend the tree, checking the nodes. As soon as an 'unmanageable' node is found,
-- the remainder is blobbed to a string, which is given a generated 'blob_name',
-- equal strings always being given identical blob_names. The blobbed parse tree is returned.
-- The built-in unblobbed operations in this version are:
-- and, or, •imp, if, ==, =, :=, +, *, -, {-}, [-], incs, •incin, in, not, notin, /==, /=, •nincs, •nincin.
-- The following special simplifications can be detected and made during the blobbing process.
-- (not all of them have yet been implemented).
-- Note that these need to be turned off during equality deduction, to ensure that equality detection
-- reflects the external form of formulae; but should be turned on during processing of
-- inference procedures for which this is not an issue.
--->simplifications list
-- Is_map({[anything_1,anything_2]: ..}) --> true -- *Done*
-- Is_svm({[x,anything]: x in s | P}) --> true -- *Done*
-- {x: x in s} --> s -- *Done*
-- {expn: iters | true} --> {expn: iters} -- *Done*
-- {expn: iters | false} --> {} -- *Done*
-- One_one({[anything,anything]: ...}) --> true -- *Done* (more generally)
-- One_one({[[anything_1,anything_2],[anything_2,anything_1]]: ...}) --> true -- *Done*
-- {[x,e(x)]: x in s | P} @ {[y,ee(y)]: y in ss | PP} --> {[y,e(ee(y))]: y in ss | PP & ee(y) in s & P(ee(y))} -- *Done*
-- Finite(#s) --> Finite(s) -- *Done*
-- ##s --> #s -- *Done*
-- {e_independent_of_x: x in s| P} --> if {x: x in s | P} = {} then {} else {e_independent_of_x} end if
-- ***** Note: should also do if any iterator is null
-- {e(x): iterator,...,x in 0,iterator,... | P} --> 0 -- *Done*
-- {e(x): x in {a} | P(x)} --> if P(a) then {e(a)} else 0 end if
-- (FORALL iterator,...,x in 0,iterator,... | P) --> true -- *Done*
-- (EXISTS iterator,...,x in 0,iterator,... | P) --> false -- *Done*
-- arb({s}) --> s -- *Done*
-- car([x,y]) --> x -- *Done*
-- cdr([x,y]) --> y -- *Done*
-- domain({[anything,anything']: iterator | P}) --> {anything: iterator (reduced_if_no_condition) | P} -- *Done*
-- range({[anything,anything']: iterator | P}) --> {anything': iterator (reduced_if_no_condition) | P} -- *Done*
-- #{[x,e(x)]: x in s} --> #s
-- Ord(next(s)) --> Ord(s) -- *Done*
-- N •PROD 0 --> 0
-- 0 •PROD N --> 0
-- N •TIMES 0 --> 0
-- 0 •TIMES N --> 0
-- N •PLUS 0 --> #N
-- #({C} •PROD N) --> #N
-- #(N •PROD {C}) --> #N
-- 1 •TIMES N --> #N
-- N •TIMES 1 --> #N
-- N •MINUS N --> 0
-- N •MINUS 0 -->#N
-- ***** Note: algebra should be integrated into blobbing by finding asd standardizing
-- subtrees all of whose operations belong to an algebraic family
if is_string(node) then return if node = "0" then "_nullset" elseif node = "BLOB" then node + "_" + str(blob_counter +:= 1) + "_"
else node end if; end if; -- case of bottom-level name; note special use of 'BLOB',
-- which generates a new version whenever encountered
[n1,n2,n3] := node; -- break node into operands and operator: generally infix (but not always)
--print("
blob_tree_inr: ",node," ",abbreviated_headers(n1));
case abbreviated_headers(n1)?n1 -- treatment of unblobbed, generally builtin operators:
-- recursively blob the arguments and then combine into a tree
-- the following nodes need not be reduced to blobs, since they can be handled by the MLSS decider
when "if" => return [n1,blob_tree_in(n2),blob_tree_in(n3),blob_tree_in(node(4))]; -- if expression
when "and" => --if unparse(n2) > unparse(n3) then [n2,n3] := [n3,n2]; end if;
return [n1,blob_tree_in(n2),blob_tree_in(n3)]; -- conjunction
when "or" => return [n1,blob_tree_in(n2),blob_tree_in(n3)]; -- disjunction
when "==" => return [n1,blob_tree_in(n2),blob_tree_in(n3)]; -- equivalence
when "=",":=" => return ["ast_eq",blob_tree_in(n2),blob_tree_in(n3)];
-- equality; note that local definitions involving the sign "=" are treated as equalities
when "incs" => return [n1,blob_tree_in(n2),blob_tree_in(n3)]; -- inclusion
when "incin" => return [n1,blob_tree_in(n2),blob_tree_in(n3)]; -- inclusion in
when "imp" => return [n1,blob_tree_in(n2),blob_tree_in(n3)]; -- implication
when "+" => return [n1,blob_tree_in(n2),blob_tree_in(n3)]; -- union
when "*" => return [n1,blob_tree_in(n2),blob_tree_in(n3)]; -- intersection
when "-" => return [n1,blob_tree_in(n2),blob_tree_in(n3)]; -- difference
when "{-}" => return [n1] + [blob_tree_in(nj): nj in node(2..)]; -- enumerated set
when "[-]" => if not allow_unblobbed_fcns and n3 /= OM then -- blob coarsely
return get_blob(blob_to_string([n1,blob_tree_in(n2),blob_tree_in(n3)],[],0));
end if;
return [n1,blob_tree_in(n2),if n3 /= OM then blob_tree_in(n3) else OM end if];
-- ordered pair, or singleton for tilde application
when "arb" => n2_simp := blob_tree_in(n2);
if allow_blob_simplify and is_tuple(n2) then
if (n21 := n2(1)) = "ast_enum_set" and #n2 = 2 then return n2(2); end if;
if n21 = "_nullset" then return "_nullset"; end if; --- special case: arb of singleton and nullset
end if;
-- if unblobbed consideration of special functions in not allowed, disallow for 'arb' also.
--print("allow_unblobbed_fcns: ",allow_unblobbed_fcns);
if not allow_unblobbed_fcns then return get_blob(blob_to_string([n1,n2_simp],[],0)); end if;
return [n1,blob_tree_in(n2)]; -- arb operator
when "in" => return [n1,blob_tree_in(n2),blob_tree_in(n3)]; -- membership
when "not" => return [n1,blob_tree_in(n2)]; -- negation
when "notin" => return [n1,blob_tree_in(n2),blob_tree_in(n3)]; -- nonmembership
when "/=" => return [n1,blob_tree_in(n2),blob_tree_in(n3)]; -- nonidentity
when "/==" => return [n1,blob_tree_in(n2),blob_tree_in(n3)]; -- inequivalence
when "DOT_NINCS" => return ["ast_not",["ast_incs",blob_tree_in(n2),blob_tree_in(n3)]]; -- not includes
when "DOT_NINCIN" => return ["ast_not",["ast_incs",blob_tree_in(n3),blob_tree_in(n2)]]; -- not included in
when "EX","ALL" => -- existential and universal
if exists iter_op_skip_iter_set in n2(2..) | (is_tuple(iter_op_skip_iter_set)
and iter_op_skip_iter_set(1) = "ast_in" and iter_op_skip_iter_set(3) = "_nullset") then
-- we have an iterator over a nullset
return if n1 = "ast_exists" then "ast_false" else "ast_true" end if;
end if;
--print("now blobbing quantified: ",node," ",n2);
-- otherwise we are not dealing with an iterator over a nullset
[n2,n3] := [blob_tree_in(n2),blob_tree_in(n3)]; -- blob the subparts
--print("quantif_blob: ",unparse([n1,n2,n3])," ",unparse(node));
return get_blob(blob_to_string([n1,n2,n3],[],0));
-- otherwise treat as inadmissible operator;
-- blob to a string, starting with no bound vars at the outer level
when "@" =>
if tree_starts(svm_map_composition_treetop,node) then -- possible simplification of map composition
nohd := n2; [nh1,nh2,nh3,nh4] := nohd; -- the first argument
nowhd := n3; [nw1,nw2,nw3,nw4] := nowhd; -- the second argument
if is_string(car_var := nh2(2)) and #nh3 < 3 and nh3(2)(2) = car_var
and ((n321 := nh3(2)(1)) = "ast_in" or n321 = "DOT_INCIN")
and is_string(cawr_var := nw2(2)) and #nw3 < 3 and nw3(2)(2) = cawr_var
and ((nw321 := nw3(2)(1)) = "ast_in" or nw321 = "DOT_INCIN")then
-- the two maps in the composition are both single valued
-- return the syntax tree of {[y,e(ee(y))]: y in ss | PP & (ee(y) in s) & P(ee(y))}
--->working_blob
--print("working: ",nohd); print(nowhd);
condition_clause := ["ast_and",["ast_and",nw4,[n321,nw2(3),nh3(2)(3)]],substitute(nh4,{[car_var,nw2(3)]})];
-- the condition of the setformer being built
iterator_clause := nw3; -- the iterator of the setformer being built
value_clause := ["ast_enum_tup",cawr_var,substitute(nh2(3),{[car_var,nw2(3)]})];
-- the value_expression [y,e(ee(y))] of the setformer being built
--print("condition_clause: ",condition_clause); print("iterator_clause: ",iterator_clause); print("value_clause: ",value_clause);
res := ["ast_genset",value_clause,iterator_clause,condition_clause];
--print("res: ",unparse(res));
return blob_tree_in(res);
end if;
end if;
-- otherwise, if no simplification is available:
return get_blob(blob_to_string([n1,blob_tree_in(n2),blob_tree_in(n3)],[],0));
-- can't do anything; but process subtrees to look for sub-simplifications
-- the cardinality operator can be handled by one form of the MLSS decider, but its treatement is very expensive.
-- hence blobbing of nodes involving "#" is made optional (it can be turned off by including a "*" flag in a hint;
-- this flag is used to drop the 'allow_unblobbed_fcns' flag seen here
when "{/}" => -- setformer, no expr; look for case in which one of the iterators is over a nullset
-- otherwise just process the subparts to catch simplifications
[n2,n3,n4] := [n2(2)(2),n2,n3]; -- first expand to standard form by inserting iteration variable
--print("setformer, no expr: ",unparse(["ast_genset",n2,n3,n4]));
-- Note: the condition is blobbed only if nonnull
[n2,n3,n4] := [blob_tree_in(n2),blob_tree_in(n3)] with -- blob the subparts first
if #(n4?["ast_null"]) = 1 and n4(1) = "ast_null" then n4 else blob_tree_in(n4) end if;
--print("setformer, no expr:: ",unparse(["ast_genset",n2,n3,n4]));
-- handle special cases in which the setformer condition is true, false, or void.
if n4 = "TRUE" or n4 = "ast_null" then n4 := ["ast_null"]; end if;
if n4 = "FALSE" then return "_nullset"; end if;
-- handle special case of iteration over a nullset
if is_tuple(n3(2)) and
(exists [iter_op,-,iter_set] in n3(2..) | (iter_op = "ast_in" and iter_set = "_nullset")) then return "_nullset";
end if;
if is_string(n2) and n4 = ["ast_null"] and #n3 = 2 and (n32 := n3(2))(1) = "ast_in" and n32(2) = n2 then -- NOte: **** inspect this line
return blob_tree_in(n32(3));
end if;
return get_blob(blob_to_string(["ast_genset",n2,n3,n4],[],0));
when "{}" => -- setformer; look for case in which one of the iterators is over a nullset
--print("setformer: ",unparse(node));
-- otherwise just process the subparts to catch simplifications
-- Note: the condition subpart is blobbed only if non-null
[n2,n3,n4] := [blob_tree_in(n2),blob_tree_in(n3)] with -- blob the subparts first
if #(n4 := node(4)?["ast_null"]) = 1 and n4(1) = "ast_null" then n4 else blob_tree_in(node(4)) end if;
-- note that the iterator list is blobbed as a whole
-- handle cases in which the setformer condition is 'true' or 'false'
if n4 = "TRUE" or n4 = "ast_true" then n4 := ["ast_null"]; end if;
if n4 = "FALSE" or n4 = "ast_false" then return "_nullset"; end if;
-- check for iteration over a nullset
if is_tuple(n3(2)) and
(exists [iter_op,-,iter_set] in n3(2..) | (iter_op = "ast_in" and iter_set = "_nullset")) then return "_nullset"; end if;
if is_string(n2) and n4 = ["ast_null"] and #n3 = 2 and (n32 := n3(2))(1) = "ast_in" and n32(2) = n2 then
return blob_tree_in(n32(3));
end if;
--print("blobbing_to_string: ",[n1,n2,n3,n4],blob_to_string([n1,n2,n3,n4],[],0));
return get_blob(blob_to_string([n1,n2,n3,n4],[],0));
when "[]" => -- list, e.g. of arguments; just process the individual components to catch simplifications
--print("blobbing list: ",node);
return [n1] + [blob_tree_in(nj): nj = node(j) | j > 1];
when "itr","Etr" => -- iterator list; just process the individual iteration limits to catch simplifications
res := [n1] + (r2 := [if is_string(iter) then iter else
[iter(1),iter(2),if (it3 := iter(3)) = OM then OM else blob_tree_in(it3) end if] end if: iter = node(j) | j > 1]);
--print("iterator list: ",[unparse(nj): nj in node(2..)]," blobs to ",[unparse(nj): nj in r2]);
return res;
when "#" => -- cardinality operator. This is normally blobbed, but can be left unblobbedd if a special control flag is set
if allow_blob_simplify and is_tuple(n2) and n2(1) = "ast_nelt" then -- cardinality operator; simplify double cardinality
return blob_tree_in(n2);
elseif allow_unblobbed_card then -- cardinality operator; remove this if blobbing desired
-- Note: **** this should have a special control, normally off
return [n1,blob_tree_in(n2)];
else -- do not leave cardinality operators unblobbed
return get_blob(blob_to_string(node,[],0));
end if;
-- The following nodes must generally be reduced to blobs, since they cannot be handled by the MLSS decider
-- However, the simplifications listed above may apply. This is tested by the 'tree_starts' routine
-- seen in the code below which tests for match to the template required for each listed specification
-- the templates used are defined as constants in the header section of this package.
when "()" => -- function and predicate application
if tree_starts(map_of_mapformer_treetop,node) and #n3(2)(2) = 3 then -- special case Is_map({[x,y]:..}
return "ast_true";
end if;
if tree_starts(car_of_pair_treetop,node) then -- special case car([x,y]}
return blob_tree_in(n3(2)(2));
end if;
if tree_starts(cdr_of_pair_treetop,node) then -- special case cdr([x,y]}
return blob_tree_in(n3(2)(3));
end if;
if tree_starts(finite_of_number_treetop,node) then return blob_tree_in([n1,n2,["ast_list",n3(2)(2)]]); end if;
-- special case Finite(#s)
if tree_starts(svm_of_svmformer_treetop,node) then -- special case Svm({[x,e(x)]: x in ...)
nohd := n3(2); [nh1,nh2,nh3] := nohd;
if is_string(car_var := nh2(2)) and nh3(1) = "ast_iter_list"
and #nh3 < 3 and nh3(2)(2) = car_var and ((n321 := nh3(2)(1)) = "ast_in" or n321 = "DOT_INCIN") then
-- and the first component of the tuple argument is a simple variable and which is the variable
-- controlled by a simple iterator (which can be of membership or inclusion type) then reduce to 'true'
return "ast_true";
end if;
-- THE FOLLOWING LINES HAVE BEEN ELIMINATED BECAUSE THEY CAUSED UNSOUNDNESS
-- test for the case in which the lead expression in the setformer is composed entirely of cons operators after blobbing
-- if is_tuple(main_expn := nh2) and (acme := all_cons(main_expn)) /= OM and all_cons(main_expn(2)) incs acme then
-- -- test a pre-blobbed tree for being all cons operators, and return the set of blobs
-- -- the top node must be a cons, and the set of blobs in its left argument must
-- return "ast_true";
-- end if;
end if;
--***
if tree_starts(svm_of_svmformer_treetop,node) then -- special case Svm({[x,e(x)]: x in ...)
nohd := n3(2); [nh1,nh2,nh3] := nohd;
-- if is_string(car_var := nh2(2)) and nh3(1) = "ast_iter_list"
-- and #nh3 < 3 and nh3(2)(2) = car_var and ((n321 := nh3(2)(1)) = "ast_in" or n321 = "DOT_INCIN") then
-- -- and the first component of the tuple argument is a simple variable and which is the variable
-- -- controlled by a simple iterator (which can be of membership or inclusion type) then reduce to 'true'
-- return "ast_true";
-- end if;
-- test for the case in which the lead expression in the setformer is composed entirely of cons operators after blobbing
-- if is_tuple(main_expn := nh2) and (acme := all_cons(main_expn)) /= OM and all_cons(main_expn(2)) incs acme then
-- -- test a pre-blobbed tree for being all cons operators, and return the set of blobs
-- -- the top node must be a cons, and the set of blobs in its left argument must
-- return "ast_true";
-- end if;
if is_tuple(main_expn := nh2) and #nh2 = 3 and (acme := all_cons(main_expn(2))) /= OM and acme incs find_free_vars(main_expn(3)) * {nh3(i)(2): i in [2..#nh3]} then
-- test a pre-blobbed tree for being all cons operators, and return the set of blobs
-- the top node must be a cons, and the set of blobs in its left argument must
return "ast_true";
end if;
end if;
if tree_starts(oneone_of_oneone_former_treetop,node) then -- special case One_1_map({[x,e(x)]: x in ...), where uniqueness is ovious
nohd := n3(2); [nh1,nh2,nh3] := nohd;
-- test for the case in which the lead expression in the setformer is composed entirely of cars and cons operators after blobbing,
-- and the outermost pair has the form [a,v], where a is a nested cons in which b appers.
if is_tuple(main_expn := nh2) and #nh2 = 3 and (acme := all_cons(main_expn)) /= OM and (acme2 := all_cons(main_expn(2))) = acme
and all_cons(main_expn(3)) = acme then
-- print("acme: ",acme," ",acme2," ",main_expn);
-- test a pre-blobbed tree for being all cons operators, and return the set of blobs
-- the top node must be a cons, and the set of blobs in its left argument must
return "ast_true";
end if;
end if;
if tree_starts(ord_of_next_treetop,node) then -- reduce Ord(next(s)) to Ord(s)
return blob_tree_in(["ast_of", "ORD",n3(2)(3)]);
end if;
--***
if node(2) = "BOTH_" then -- special dummy function; return separate blobs of two parts
-- the second of these two parts is blobbed using standardize-bound-vars_in to prevent resetting of the blob_names counter,
-- thereby preventing indevertent identification of different variables in n2 and n3 simply because they appear in corresponding positions
--print("examining BOTH_: ",blob_tree(standardize_bound_vars(n3(2)))," ",blob_tree(standardize_bound_vars(n3(2))));
restore_bvar_name_ctr2 := false; -- turn off recursive backtracking of bound variable name generator
result := [get_blob(blob_to_string(blob_tree(standardize_bound_vars(n3(2))),[],0)),
get_blob(blob_to_string(blob_tree_in(standardize_bound_vars(n3(3))),[],0))];
restore_bvar_name_ctr2 := true; -- restore recursive backtracking of bound variable name generator
return result;
end if;
if allow_unblobbed_fcns and n2 in unblobbed_functions then -- function application; check for functions known as special
arg_list := [blob_tree_in(arg): arg in n3(2..)]; -- process the arguments recursively
return ["ast_of",n2,["ast_list"] + arg_list]; -- return special function with blobbed arguments
else -- function is not special
arg_list := [blob_tree_in(arg): arg in n3(2..)]; -- process the arguments recursively
res := get_blob(blob_to_string(["ast_of",n2,["ast_list"] + arg_list],[],0));
-- return function blob after blobbing arguments
--print("function is not special: ",[n1,n2,n3]," blobs to: ",res);
return res;
end if;
when "domain","range" => -- domain and range builtins
-- check for domain({[e(x),e2(x)]:...})
if tree_starts(domain_of_genmap_treetop,node) and #(lead_expn := (set_former := n2)(2)) = 3 then
--print("domain: ",node);
--print("constructed tree: ",["ast_genset",lead_expn(2)] + set_former(3..));
return blob_tree_in(["ast_genset",lead_expn(2)] + set_former(3..));
end if;
-- check for range({[e(x),e2(x)]:...})
if tree_starts(range_of_genmap_treetop,node) and #(lead_expn := (set_former := n2)(2)) = 3 then
--print(["ast_genset",lead_expn(3)] + set_former(3..));
return blob_tree_in(["ast_genset",lead_expn(3)] + set_former(3..));
end if;
return get_blob(blob_to_string([n1,blob_tree_in(n2)],[],0)); -- otherwise just blob argument
otherwise => -- otherwise just blob operator arguments
return get_blob(blob_to_string([n1] + [blob_tree_in(arg): arg in node(2..)] ,[],0));
-- inadmissible operator; blob to a string, starting with no bound vars at the outer level
end case;
end blob_tree_inr;
procedure tree_starts(treetop_tup,node); -- tests node for match to the template required for a specification
-- if either the node or the template is a simple string, we require exact match
-- otherwise we require match to all the elements of the template,
-- (which omits those elements of the tree node for which match is inessential)
-- this test always fails if the global allow_blob_simplify flag is dropped
if not allow_blob_simplify then return false; end if; -- force mismatch if blob simplification is turned off
if not (is_tuple(node) and is_tuple(treetop_tup)) then return node = treetop_tup; end if;
return forall x = treetop_tup(j) | if is_string(x) then x = node(j) else tree_starts(x,node(j)) end if;
end tree_starts;
procedure blob_to_string(node,bound_vars,name_ctr); -- blobs a tree down to a string
-- this routine, called from blob_tree_in, handles portions of
-- an original parse tree which need to be blobbed
-- by reducing them to strings which identify them uniquely
-- we descend the tree, collecting additional bound variables as we descend. These variables are given generated names "BV_n"
-- The strings formed are standardized by permuting the arguments of 'ands', 'ors', '=', '•eq' into alphabetical order, and
-- by rewriting 'not (x = y)' as x /= y, likewise for 'not (x •eq y)'
-- the commutative operations to be permuted are: and, or, ==, =, +, *, {-}, /==
-- the operations -, in, not, and notin, are worth treating in a special way. a - b - c can be standardized to a - (b + c);
-- 'not (x in y)' is standardized to 'x notin y'; 'not (x and y)' is standardized to '(not a) or (not y)';
-- 'not (x or y)' is standardized to '(not a) and (not y)';
-- 'not forall' and 'not exists' is standardized to 'exists not' and 'forall not' respectively
--print("blob_to_string: ",unparse(node));
if is_string(node) then return if exists c = bound_vars(j) | node = c then "BV_" + str(j) else node end if; end if;
-- free variable names are their own blobs; bound variables are standardized by the order in which they occur
[n1,n2,n3] := node; -- nodes are generally (but not always) infix operators
ah := " " + (sah := abbreviated_headers(n1))?n1 + " "; -- get the node tag, but pad it with blanks
case sah -- handle various special cases described above
when "if" => -- 'if expresssion': blobs subparts and joins string subparts using 'if' and 'else'
b2 := blob_to_string(n2,bound_vars,name_ctr); b3 := blob_to_string(n3,bound_vars,name_ctr); b4 := blob_to_string(node(4),bound_vars,name_ctr);
return "(if " + b2 + " then " + b3 + " else " + b4 + ")";
when "and" => flatted := flatten_same_ops(node);
-- conjunction: we look as far down the syntax tree as only "and" operators are seen,
-- and blob_string all these items. The resulting strings are then sorted and
-- conjoined in their sorted order.
blobbed_args := merge_sort([blob_to_string(arg,bound_vars,name_ctr): arg in flatted(2..)]);
-- blob and sort the conjunction arguments
return sah + "(" + join(blobbed_args,",") + ")";
when "or" => flatted := flatten_same_ops(node);
-- disjunction: we look as far down the syntax tree as only "or" operators are seen,
-- and blob_string all these items. The resulting strings are then sorted and
-- disjoined conjunctionin their sorted order.
blobbed_args := merge_sort([blob_to_string(arg,bound_vars,name_ctr): arg in flatted(2..)]);
-- blob and sort the disjunction arguments
return sah + "(" + join(blobbed_args,",") + ")";
when "==" => -- equivalence: we blob the two arguments, but then permute them into sorted order
b2 := blob_to_string(n2,bound_vars,name_ctr); b3 := blob_to_string(n3,bound_vars,name_ctr);
if b2 > b3 then [b2,b3] := [b3,b2]; end if;
return "(" + b2 + ah + b3 + ")";
when "=" => -- equality: we blob the two arguments, but then permute them into sorted order
b2 := blob_to_string(n2,bound_vars,name_ctr); b3 := blob_to_string(n3,bound_vars,name_ctr);
if b2 > b3 then [b2,b3] := [b3,b2]; end if;
return "(" + b2 + ah + b3 + ")";
when "+" => flatted := flatten_same_ops(node);
-- union: we look as far down the syntax tree as only "+" operators are seen,
-- and blob_string all these items. The resulting strings are then sorted and
--unioned in their sorted order.
blobbed_args := merge_sort([blob_to_string(arg,bound_vars,name_ctr): arg in flatted(2..)]);
-- blob and sort the union arguments
return sah + "(" + join(blobbed_args,",") + ")";
when "-" => flatted := flatten_same_ops(node);
-- difference: we look as far down the syntax tree as only "-" operators are seen,
-- and blob_string all these items. The resulting strings are then sorted and
-- conjoined in their sorted order, with a - b - c - .. standardized to a - (b + c + ..)
blobbed_args := merge_sort([blob_to_string(arg,bound_vars,name_ctr): arg in flatted(3..)]);
-- blob and sort the set difference arguments
all_but_first_as_sum := "+(" + join(blobbed_args,",") + ")";
return "-(" + blob_to_string(flatted(2),bound_vars,name_ctr) + "," + all_but_first_as_sum + ")";
when "*" => flatted := flatten_same_ops(node);
-- intersection: we look as far down the syntax tree as only "*" operators are seen,
-- and blob_string all these items. The resulting strings are then sorted and
-- intersected in their sorted order.
blobbed_args := merge_sort([blob_to_string(arg,bound_vars,name_ctr): arg in flatted(2..)]);
-- blob and sort the intersection arguments
return sah + "(" + join(blobbed_args,",") + ")";
when "{-}" => -- enumerated set: we blob the arguments, and then permute them into sorted order
return "{" + join(merge_sort([blob_to_string(nj,bound_vars,name_ctr): nj in node(2..)]),",") + "}";
when "/==" => -- inequivalence: we blob the two arguments, but then permute them into sorted order
b2 := blob_to_string(n2,bound_vars,name_ctr); b3 := blob_to_string(n3,bound_vars,name_ctr);
if b2 > b3 then [b2,b3] := [b3,b2]; end if;
return "(" + b2 + ah + b3 + ")";
when "/=" => -- inequality: we blob the two arguments, but then permute them into sorted order
b2 := blob_to_string(n2,bound_vars,name_ctr); b3 := blob_to_string(n3,bound_vars,name_ctr);
if b2 > b3 then [b2,b3] := [b3,b2]; end if;
return "(" + b2 + ah + b3 + ")";
when "not" => -- negation: we look for 'not in' and convert it to 'notin';
-- 'not notin' and convert it to 'in';
-- also for 'not =' and convert it to '/='; 'not /=' and convert it to '=';
-- also for 'not •eq' and convert it to '•neq'; 'not •neq' and convert it to '•eq';
-- also for 'not not' and eliminate both;
-- also for 'not imp' and onvert to "n2 and not n3"
-- also for 'not FORALL' and convert it to 'EXISTS not';
-- also for 'not EXISTS' and convert it to 'FORALL not';
if is_tuple(n2) then -- look for special cases noted in the preceding comment
ahn2 := abbreviated_headers(n2(1)); -- examine the following operand
if (rev := logical_negation(ahn2)) /= OM then
-- we have one of the special cases noted in the preceding comment
return "(" + blob_to_string(n2(2),bound_vars,name_ctr) + " " + rev
+ " " + blob_to_string(n2(3),bound_vars,name_ctr) + ")";
-- change to the reversed operator
elseif ahn2 = "not" then -- drop both 'nots'
return blob_to_string(n2(2),bound_vars,name_ctr);
elseif ahn2 = "imp" then -- convert to "n2 and not n3";
return "(" + blob_to_string(n2(2),bound_vars,name_ctr) + " and not "
+ blob_to_string(n2(3),bound_vars,name_ctr) + ")";
elseif ahn2 = "ALL" then -- convert to "EXISTS not"; the original existential syntax is [op, iter, pred]
return blob_to_string(["ast_exists",n2(2),["ast_not",n2(3)]],bound_vars,name_ctr);
elseif ahn2 = "EX" then -- convert to "FORALL not"; the original existential syntax is [op, iter, pred]
return blob_to_string(["ast_forall",n2(2),["ast_not",n2(3)]],bound_vars,name_ctr);
end if;
end if; -- otherwise just handle in the ordinary way
return "(" + sah + " " + blob_to_string(n2,bound_vars,name_ctr) + ")";
when "arb" => -- arb; nothing to do here
return "(" + sah + " " + blob_to_string(n2,bound_vars,name_ctr) + ")";
when "notin" => -- nonmembership; nothing to do here
b2 := blob_to_string(n2,bound_vars,name_ctr); b3 := blob_to_string(n3,bound_vars,name_ctr);
return "(" + b2 + ah + b3 + ")";
when "in" => -- membership; nothing to do here
b2 := blob_to_string(n2,bound_vars,name_ctr); b3 := blob_to_string(n3,bound_vars,name_ctr);
return "(" + b2 + ah + b3 + ")";
when "[-]" => -- ordered pair or bracketed singleton; nothing to do here
b2 := blob_to_string(n2,bound_vars,name_ctr);
if n3 /= OM then b3 := blob_to_string(n3,bound_vars,name_ctr); end if;
return "[" + b2 + if n3 /= OM then "," + b3 else "" end if + "]";
-- inclusion - nothing to do here
when "incs" => return "(" + blob_to_string(n2,bound_vars,name_ctr) + " incs "
+ blob_to_string(n3,bound_vars,name_ctr) + ")"; -- includes
-- reversed inclusion - nothing to do here
when "incin" => return "(" + blob_to_string(n2,bound_vars,name_ctr) + " •incin "
+ blob_to_string(n3,bound_vars,name_ctr) + ")"; -- inclusion in
-- implication - nothing to do here
when "imp" => return "(" + blob_to_string(n2,bound_vars,name_ctr) + " •imp "
+ blob_to_string(n3,bound_vars,name_ctr) + ")"; -- implication
-- map application- nothing to do here
when "->" => return "(" + blob_to_string(n2,bound_vars,name_ctr) + " ~[ "
+ drop_parens(blob_to_string(n3,bound_vars,name_ctr)) + "])"; -- map application
when "[]" => return unparse(n2); -- list; nothing to do here; should be of length 1
when "()" => -- function application; blob the arguments and attach function name
if not is_string(n2) then print("****** bad function application: ",unparse(node)); end if;
-- armoring against compound funuction-symbol applications in source
return n2 + "(" + join([blob_to_string(x,bound_vars,name_ctr): x in n3(2..)],",") + ")";
when "{.}" => return blob_to_string(n2,bound_vars,name_ctr) + "{"
+ join([blob_to_string(x,bound_vars,name_ctr): x in n3(2..)],",") + "}";
-- multivalued function application; nothing to do here
when "itr","Etr" => -- iteration. We divide these into permutable groups and
-- sort each of them into alphabetical order; aside from this, nothing to do
-- Note: **** Add standardization of permutable iterator groups
return join([drop_parens(blob_to_string(x,bound_vars,name_ctr)): x in node(2..)],",");
when "{}" => bound_vars +:= find_bound_vars(node);
-- setformer; first collect the bound variables and append to the bound variable list
-- blob the setformer parts separately and recommbine
-- Note: **** Add standardization of permutable iterator groups
res := "{" + blob_to_string(n2,bound_vars,name_ctr) + ": " + blob_to_string(n3,bound_vars,name_ctr)
+ if (n4 := node(4)) /= OM and abbreviated_headers(n4(1)) /= "null" then " | "
+ blob_to_string(n4,bound_vars,name_ctr) else "" end if + "}";
--print("string blob of set: ",unparse(node)," ",res);
return res;
when "{/}" => bound_vars +:= find_bound_vars(node);
-- setformer, no exp; first collect the bound variables and append to the bound variable list
-- blob the setformer parts separately and recommbine
-- Note: **** Add standardization of permutable iterator groups
return "{" + blob_to_string(n2,bound_vars,name_ctr)
+ if n3(1) /= "null" then " | " + blob_to_string(n3,bound_vars,name_ctr) else "" end if + "}";
when "EX" => bound_vars +:= find_bound_vars(node);
-- existential; first collect the bound variables and append to the bound variable list
-- blob the quantifier parts separately and recommbine
-- Note: **** Add standardization of permutable iterator groups
--print("existential node: ",node);
return "(EXISTS " + blob_to_string(n2,bound_vars,name_ctr) + " | "
+ blob_to_string(n3,bound_vars,name_ctr) + ")";
when "ALL" => bound_vars +:= find_bound_vars(node); -- universal
-- blob the quantifier parts separately and recommbine
-- Note: **** Add standardization of permutable iterator groups
return "(FORALL " + blob_to_string(n2,bound_vars,name_ctr) + " | "
+ blob_to_string(n3,bound_vars,name_ctr) + ")";
otherwise => -- might be some other infix or prefix operator, or variable name in simple quatifier iterator
if n2 = OM then return n1; end if; -- variable name in simple quatifier iterator
if n3 = OM then return "(" + external_rep(n1)?n1+ "("
+ blob_to_string(n2,bound_vars,name_ctr) + "))"; end if; -- prefix operator
return "((" + blob_to_string(n2,bound_vars,name_ctr) + ")"
+ external_rep(n1)?n1+ "(" + blob_to_string(n3,bound_vars,name_ctr) + "))";
-- Infix operator
end case;
end blob_to_string;
-- ************ routines intermediate between blobbing and MLSS inference proper ************
-- these routines prepare for the application of the generalized MLSS inference procedures by
-- eliminating all elements which are irrelevant to satisfiability. See the extended comment below,
-- headed 'additional special simplifications'
--->boil_down_blobbed
procedure boil_down_blobbed(tree); -- performs simplify_builtins, simplify_onces, exploit_prop_sign in order
-- Note that the trees passed to this routine (from the package 'verifier_top_level) have already been blobbed down
-- to include only those function calls and other constants meaningful to the underlying decison algorithm (extended MLSS) being used.
simp1 := exploit_prop_signs(simp2 := simplify_onces(simp3 := simplify_builtins(tree)));
--print("
tree: ",unicode_unparse(tree)); print("simp2: ",unicode_unparse(simp2)); print("simp3: ",unicode_unparse(simp3)); print("
simp1: ",unicode_unparse(simp1));
-- since further simplifications are possible we apply our sequence of three simplifications once more
res := exploit_prop_signs(simplify_onces(simplify_builtins(simp1)));
--print("boil_down_blobbed: ",unparse(res));
return res;
end boil_down_blobbed;
-- ************ simplifications of various built-in operations ************
procedure simplify_builtins(tree); -- simplifies various expressions involving built-in operators
-- arb({x}) is simplified to x
-- car([x,y]) is simplified to x; cdr([x,y]) is simplified to y
-- {[x,y]}~[x] is simplified to y
-- x in {y_1,y_2,...} is simplified to x = y_1 or x = y_2 or ...
-- x = x is simplified to true
-- x /= x is simplified to false
-- boolean opearators invoving 'true', 'false', a == a, multiple occurences of 'or' or of 'and' are simplified.
-- other similar simplifications may be added.
-- these simplifications apply even to appearances of the constructs shown within other functions.
-- and in the scope of bound variables
return simplify_builtins_in(tree); -- just call the recursive workhorse
end simplify_builtins;
procedure simplify_builtins_in(tree);
-- recursive workhorse: simplifies the expressions listed above
-- we process the given syntax tree recursively, simplifying the arguments of nodes which
-- can be processed, and then applying the simplifications listed above to the
-- individual nodes. Most of the operators processed are SETL builtins
if not is_tuple(tree) then return if tree = "ast_null" then "TRUE" elseif tree = "ast_false" then "FALSE" else tree end if; end if;
-- bottom-level leaf; just note the 'true' and 'false' special cases
[n1,n2,n3] := tree; -- unpack node, which is possibly but not nesssarily a binary operation
case abbreviated_headers(n1)?n1
when "arb" => -- arb({x}) is simplified to x
n2 := simplify_builtins_in(n2);
if abbreviated_headers(n2(1)) = "{-}" and (nn2 := #n2) = 2 then return n2(2); end if;
return [n1,n2];
when "()" => -- function application: car([x,y]) is simplified to x; cdr([x,y]) is simplified to y
-- example [(), CAR, [[], [[-], X, Y]]]
n32 := simplify_builtins_in(n3(2)); -- first simplify the argument of 'car', 'cdr', or some other function symbol
if n2 = "CAR" and n32(1) = "ast_enum_tup" and #n32 = 3 then return n32(2); end if;
if n2 = "CDR" and n32(1) = "ast_enum_tup" and #n32 = 3 then return n32(3); end if;
return [n1,n2,["ast_list"] + [simplify_builtins_in(n3(j)): j in [2..#n3]]];
-- if not car or cdr, just simplify the function arguments and return
when "{.}" => -- multivalued map application.
-- This is handled like ordinary map application, but returns a set
n2 := simplify_builtins_in(n2); n3 := simplify_builtins_in(n3);
-- special cse {[x,y]}~[{x}] to {y}
if n2(1) = "ast_enum_set" and #n2 = 2 and n2(2)(1) = "ast_enum_tup" and #n2(2) = 3 and
n3(1) = "ast_list" and #n3 = 2 and blob_to_string(n2(2)(2),[],0) = blob_to_string(n3(2),[],0) then
-- simplifiable case
return ["ast_enum_set",n2(2)(3)]; -- return a singleton
end if;
return [n1,n2,n3]; -- otherwise return a multivalued application with simplified arguments
when "{-}" => -- enumerated set: simplify the elements.
-- but also look for identical elements which can be eliminated
args := [simplify_builtins_in(arg): arg in tree(2..)];
arg_blobs := [blob_to_string(a,[],0): a in args];
blobs_seen := {}; ok_args := []; -- loop over args eliminating duplicates
for arg = args(j) | (abj := arg_blobs(j)) notin blobs_seen loop
blobs_seen with:= abj; ok_args with:= arg;
end loop;
return [n1] + ok_args; -- return a setformer with the pruned set of arguments
when "[-]" => -- enumerated tuple (pair or singleton): just simplify the components and return
return [n1] + [simplify_builtins_in(arg): arg in tree(2..)];
when "[]" => -- list: just simplify the elements and return
return [n1] + [simplify_builtins_in(arg): arg in tree(2..)];
when "->" => -- map application: {[x,y]}~[x] is simplified to y
n2 := simplify_builtins_in(n2); n3 := simplify_builtins_in(n3);
if n2(1) = "ast_enum_set" and #n2 = 2 and n2(2)(1) = "ast_enum_tup" and #n2(2) = 3 and
n3(1) = "ast_enum_tup" and #n3 = 2 and blob_to_string(n2(2)(2),[],0) = blob_to_string(n3(2),[],0) then
-- simplifiable case
return n2(2)(3);
end if;
return [n1,n2,n3]; -- otherwise return a map application with simplified arguments
when "in" => -- x in {y_1,y_2,...} is simplified to x = y_1 or x = y_2 or ...
-- this is special-cased to 'true' if x agrees with a blob of some argument
n2 := simplify_builtins_in(n2); n3 := simplify_builtins_in(n3o := n3);
--if n3 = OM then print("tree is: ",tree); end if;
if n3 = "_nullset" or n3 = "0" then return "FALSE"; end if; -- x in {} simplifies to FALSE
if n3(1) /= "ast_enum_set" then return [n1,n2,n3]; end if;
-- case where membership test does not refer to an enumerated set; just simplify the parameters of the relationsip and return
n2_blob := blob_to_string(n2,[],0); -- enumerated set case. If equal to one ofthe elements, then return "TRUE"
if exists n3a in (args := n3(2..)) | n2_blob = blob_to_string(n3a,[],0) then return "TRUE"; end if;
eq_stat := ["ast_eq",n2,args(1)]; -- form a first equality, and disjoin the remaining equalities
for j in [2..#args] loop eq_stat := ["ast_or",eq_stat,["ast_eq",n2,args(j)]]; end loop;
return simplify_builtins_in(eq_stat); -- further simplification of the generated equalities may be possible
when "notin" => null; -- nonmembership x notin {y_1,y_2,...} is simplified to x = y_1 or x = y_2 or ...
-- this is special-cased to 'flase' if x agrees with a blob of some argument
n2 := simplify_builtins_in(n2); n3 := simplify_builtins_in(n3);
-- simplify the parts of the nonmembership relation
if n3 = "_nullset" or n3 = "0" then return "TRUE"; end if; -- nonmembership in nullset is "TRUE"
if n3(1) /= "ast_enum_set" then return [n1,n2,n3]; end if;
n2_blob := blob_to_string(n2,[],0); -- if visibly equal to any element, then return "FALSE";
if exists n3a in (args := n3(2..)) | n2_blob = blob_to_string(n3a,[],0) then return "FALSE"; end if;
-- otherwise return conjunction of inequlity with all element
eq_stat := ["ast_ne",n2,args(1)]; -- form a first equality
for j in [2..#args] loop eq_stat := ["ast_and",eq_stat,["ast_ne",n2,args(j)]]; end loop;
return simplify_builtins_in(eq_stat); -- further simplification of the generated inequalities may be possible
when "=" => -- x = x is simplified to true
-- we also special case x = {x,..} to false
-- (this could be done to multiple levels, but we desist)
-- we also special_case [x,y] = [u,v] to x = u and y = v
n2 := simplify_builtins_in(n2); n3 := simplify_builtins_in(n3);
if n3(1) = "ast_enum_set" then -- special case x = {x,..} to false
n2_blob := blob_to_string(n2,[],0);
if exists arg in n3(2..) | n2_blob = blob_to_string(arg,[],0) then return "FALSE"; end if;
end if;
if n2(1) = "ast_enum_set" then -- special case {x,..} = x to false
n3_blob := blob_to_string(n3,[],0);
if exists arg in n2(2..) | n3_blob = blob_to_string(arg,[],0) then return "FALSE"; end if;
end if;
if n2(1) = "ast_enum_tup" and n3(1) = "ast_enum_tup" and #n2 = 3 and #n3 = 3 then
-- simplify equality between pairs, as described above
[-,n22,n23] := n2; [-,n32,n33] := n3; -- unpack
eq1 := simplify_builtins_in(["ast_eq",n22,n32]); -- form the two implied equalities
eq2 := simplify_builtins_in(["ast_eq",n23,n33]);
return ["ast_and",eq1,eq2]; -- return their conjunction
end if;
-- simplify a = a to "TRUE"
if blob_to_string(n2,[],0) = blob_to_string(n3,[],0) then return "TRUE"; end if;
return [n1,n2,n3]; -- otherwise just return the node with simplified arguments
when "==" => -- x •eq x is simplified to true
n2 := simplify_builtins_in(n2); n3 := simplify_builtins_in(n3);
if blob_to_string(n2,[],0) = blob_to_string(n3,[],0) then return "TRUE"; end if;
return [n1,n2,n3];
when "/=" => -- x /= x is simplified to false
-- we also special case x /= {x,..} and {x,..} /= x to true
-- (this could be done to multiple levels, but we desist)
-- we also special_case [x,y] = [u,v] to x = u and y = v
if n3(1) = "ast_enum_set" then -- look for cases in which n2 is evidently a member of the enumerated set n3,
-- returning "TRUE" in these cases
n2_blob := blob_to_string(n2,[],0);
if exists arg in n3(2..) | n2_blob = blob_to_string(arg,[],0) then return "TRUE"; end if;
end if;
if n2(1) = "ast_enum_set" then -- look for cases in which n3 is evidently a member of the enumerated set n2,
-- returning "TRUE" in these cases
n3_blob := blob_to_string(n3,[],0);
if exists arg in n2(2..) | n3_blob = blob_to_string(arg,[],0) then return "TRUE"; end if;
end if;
-- otherwise just simplify the arguments ...
n2 := simplify_builtins_in(n2); n3 := simplify_builtins_in(n3);
-- if n2 is visbly equal to n3, then return "FALSE"
if blob_to_string(n2,[],0) = blob_to_string(n3,[],0) then return "FALSE"; end if;
return [n1,n2,n3]; -- otherwise return operation with simplified arguments
when "/==" => -- x /= x is simplified to false
n2 := simplify_builtins_in(n2); n3 := simplify_builtins_in(n3);
if blob_to_string(n2,[],0) = blob_to_string(n3,[],0) then return "FALSE"; end if;
return [n1,n2,n3];
when "and" => -- x and true is simplified to x; x and false is simplified to false
-- x and x is simplified to x
--print("tree at and: ",tree);
n2 := simplify_builtins_in(on2 := n2); n3 := simplify_builtins_in(on3 := n3);
-- simplify the conjunction arguments
--print("on2: ",on2,n2); print(on3,n3);
if blob_to_string(n2,[],0) = blob_to_string(n3,[],0) then return n2; end if;
-- if they are equal, return either one
-- otherwise see if either argument is visibly "TRUE" or "FALSE", and handle accordingly.
res := if n2 = "TRUE" then n3 elseif n3 = "TRUE" then n2
elseif n2 = "FALSE" or n3 = "FALSE" then "FALSE" else [n1,n2,n3] end if;
--print("and input: ",unparse(tree)," res: ",unparse(res)," n2 is: ",unparse(n2)," n3 is: ",unparse(n3));
return res;
when "or" => -- x or true is simplified to true; x or false is simplified to x
-- x or x is simplified to x
n2 := simplify_builtins_in(n2); n3 := simplify_builtins_in(n3);
-- simplify the disjunction arguments
if blob_to_string(n2,[],0) = blob_to_string(n3,[],0) then return n2; end if;
-- if they are equal, return either one
-- otherwise see if either argument is visibly "TRUE" or "FALSE", and handle accordingly.
res := if n2 = "FALSE" then n3 elseif n3 = "FALSE" then n2
elseif n2 = "TRUE" or n3 = "TRUE" then "TRUE" else [n1,n2,n3] end if;
--print("or input: ",unparse(tree)," res: ",unparse(res)," n2 is: ",unparse(n2)," n3 is: ",unparse(n3));
return res;
when "imp" => null; -- implication; x implies x is simplified to true
-- false implies x is simplified to true
-- x implies false is simplified to (not x)
-- x implies true is simplified to true
-- true implies x is simplified to true
n2 := simplify_builtins_in(n2); n3 := simplify_builtins_in(n3);
-- simplify the implication arguments
if blob_to_string(n2,[],0) = blob_to_string(n3,[],0) then return "TRUE"; end if;
-- if they are equal, return either "TRUE"
-- otherwise see if either argument is visibly "TRUE" or "FALSE", and handle accordingly.
return if n2 = "FALSE" then "TRUE" elseif n3 = "FALSE" then ["ast_not",n2]
elseif n3 = "TRUE" then "TRUE" elseif n2 = "TRUE" then n3 else [n1,n2,n3] end if;
when "not" => -- (not false) is simplified to true; (not true) is simplified to false;
n2 := simplify_builtins_in(on2 := n2);
--print("not: ",unparse(n2));
return if n2 = "FALSE" then "TRUE" elseif n2 = "TRUE" then "FALSE" else [n1,n2] end if;
when "if" => -- when any branch of an if is known to be impossible it is dropped;
-- when any branch is konown to be true then the if is truncated
-- the syntax is [if,cond,res,else_res]
n2 := simplify_builtins_in(n2); n3 := simplify_builtins_in(n3);
n4 := simplify_builtins_in(tree(4));
return if n2 = "FALSE" then n4 elseif n2 = "TRUE" then n3 else [n1,n2,n3,n4] end if;
when "+" => -- union: we special case the union of two enumerated sets,
-- writing it as an enumerated set. Also x + 0 and 0 + x are special cased to x
n2 := simplify_builtins_in(n2); n3 := simplify_builtins_in(n3);
if n2(1) = "ast_enum_set" and n3(1) = "ast_enum_set" then
-- both argument are enumerated sets: form the union, eliminating duplicates
args := n2(2..) + n3(2..); -- take the union of all the args
arg_blobs := [blob_to_string(a,[],0): a in args];
blobs_seen := {}; ok_args := []; -- loop over args eliminating duplicates
for arg = args(j) | (abj := arg_blobs(j)) notin blobs_seen loop
blobs_seen with:= abj; ok_args with:= arg;
end loop;
return [n2(1)] + ok_args; -- return enumerated setformer with the pruned set of arguments
end if;
-- handle cases in which one argument isvisibly null.
return if n2 = "0" or n2 = "_nullset" then n3 elseif n3 = "0" or n3 = "_nullset" then n2 else [n1,n2,n3] end if;
when "-" => -- difference: x - 0 is special cased to x; 0 - x is special cased to 0
-- we also special case the difference of two enumerated sets, removing common elements from both
n2 := simplify_builtins_in(n2); n3 := simplify_builtins_in(n3);
if (n21 := n2(1)) = "ast_enum_set" and n3(1) = "ast_enum_set" then
-- simplify the difference, eliminating comon elements from both sets
-- find the set-element blobs which are evidently common to both sets
common_arg_blobs := {blob_to_string(a,[],0): a in (args1 := n2(2..))}
* {blob_to_string(a,[],0): a in (args2 := n3(2..))};
-- find the elements of the first set which do not belong to the common part
if (ok_args_1 := [arg in args1 | blob_to_string(arg,[],0) notin common_arg_blobs]) = [] then
return "_nullset"; -- everything has been subtracted away
end if;
if (ok_args_2 := [arg in args2 | blob_to_string(arg,[],0) notin common_arg_blobs]) = [] then
return [n2(1)] + ok_args_1; -- the whole subtraction has been handled
end if;
-- attach remaining elements to 'enum_set' header
return [n1,[n21] + ok_args_1,[n21] + ok_args_2];
-- return difference of enumerated setformers with the pruned set of arguments
end if;
-- special case the situations in which one of the difference arguments is known to be a nullset
return if n2 = "0" or n2 = "_nullset" then "_nullset"
elseif n3 = "0" or n3 = "_nullset" then n2 else [n1,n2,n3] end if;
when "*" => -- intersection: special case x * 0 and 0 * x to 0
n2 := simplify_builtins_in(n2); n3 := simplify_builtins_in(n3); -- implify the intesection arguments
-- if either argument is evidently a nulset then return a nulllset
return if n2 = "0" or n2 = "_nullset" or n3 = "0" or n3 = "_nullset" then "_nullset" else [n1,n2,n3] end if;
when "incs" => -- includes: x incs 0 is special cased to true
-- we also special case inclusion for two enumerated sets, removing common elements from both
n2 := simplify_builtins_in(n2); n3 := simplify_builtins_in(n3);
if (n21 := n2(1)) = "ast_enum_set" and n3(1) = "ast_enum_set" then -- eliminate duplicates
-- find the blobs of set elements which are evidently common to both sets
common_arg_blobs := {blob_to_string(a,[],0): a in (args1 := n2(2..))}
* {blob_to_string(a,[],0): a in (args2 := n3(2..))};
-- if the difference n3 - n2 is evidently empty, then return 'true'
if (ok_args_2 := [arg in args2 | blob_to_string(arg,[],0) notin common_arg_blobs]) = [] then
return "TRUE"; -- second argument has become null
end if;
ok_args_1 := [arg in args1 | blob_to_string(arg,[],0) notin common_arg_blobs];
return [n1,[n21] + ok_args_1,[n21] + ok_args_2];
-- return simplified inclusion with the pruned set of arguments
end if;
return if n3 = "0" or n3 = "_nullset" then "TRUE" else [n1,n2,n3] end if;
when "incin" => -- inclusion in: 0 incs x is special cased to true
-- we also special case inclusion-in for two enumerated sets, removing common elements from both
n2 := simplify_builtins_in(n2); n3 := simplify_builtins_in(n3);
if (n21 := n2(1)) = "ast_enum_set" and n3(1) = "ast_enum_set" then -- eliminate duplicates
common_arg_blobs := {blob_to_string(a,[],0): a in (args1 := n2(2..))}
* {blob_to_string(a,[],0): a in (args2 := n3(2..))};
if (ok_args_1 := [arg in args1 | blob_to_string(arg,[],0) notin common_arg_blobs]) = [] then
return "TRUE"; -- first argument has become null
end if;
ok_args_2 := [arg in args2 | blob_to_string(arg,[],0) notin common_arg_blobs];
return [n1,[n21] + ok_args_1,[n21] + ok_args_2];
-- return simplified inclusion with the pruned set of arguments
end if;
return if n2 = "0" or n2 = "_nullset" then "TRUE" else [n1,n2,n3] end if;
when "itr","Etr" => -- iteration; we just simplify the constraint sets.
-- a syntactic example is: ["ast_iter_list", ["ast_in", "X", "S"], ["DOT_INCIN", "Y", "T"]].
simplified := [n1];
if exists xxx in tree(2..) | is_string(xxx) then printy(["string in iterator",tree]); stop; end if;
for [ikind,ivar,irange] in tree(2..) loop
simplified with:= [ikind,ivar,simplify_builtins_in(irange)];
end loop;
return simplified;
when "{}" => -- setformer; simplify each of the three parts and reassemble them
-- a syntactic example is: {e(x,y): x in s, y •incin t | P(x,y)}
-- parses to ["ast_genset", ["ast_of", "E", ["ast_list", "X", "Y"]],
-- ["ast_iter_list", ["ast_in", "X", "S"], ["DOT_INCIN", "Y", "T"]], ["ast_of", "P", ["ast_list", "X", "Y"]]]
n2 := simplify_builtins_in(n2); n3 := simplify_builtins_in(n3); n4 := simplify_builtins_in(tree(4));
return [n1,n2,n3,n4];
-- return simplify_setformer([n1,n2,n3,n4]);
-- pass the result to 'simplify_setformer' for further processing (temporarily disabled)
when "EX","{/}" => -- existential quantifier; also setformer, no exp;
-- we simplify each of the two parts and reassemble them
n2 := simplify_builtins_in(n2); n3 := simplify_builtins_in(n3);
return [n1,n2,n3]; -- return the quantifier, reassembled after simplification
when "ALL" => -- universal quantifier
n2 := simplify_builtins_in(n2); n3 := simplify_builtins_in(n3);
return [n1,n2,n3]; -- return the quantifier, reassembled after simplification
otherwise => -- might be some other infix or prefix operator
n2 := simplify_builtins_in(n2); -- simplify the first argument
if n3 = OM then return [n1,n2]; end if;
-- if there is no second arument we have a prefix operator
n3 := simplify_builtins_in(n3); -- binary operator; simplify the second argument
return [n1,n2,n3]; -- return the operator after simplification of its arguments
end case;
end simplify_builtins_in;
-- ************ additional special simplifications, designed for use with the ELEM ************
-- ************ decision routines ************
-- the following routines, which make a great contribution to the efficiency of ELEM routines, replace
-- formulae, not by equivalent formulae, but by formule which must be unsatifiable if the formula
-- originally passed to them is unsatifiable. A prototypical example is 'a = b', where the variable
-- b occurs only once, and so can have any set value. This eauality can clearly have any boolean value,
-- since b can be anything; hence we can simplify it to ;once', ehere now 'once' is a new boolean
-- variiable that occurs only once, and so can have either of the two boolen values 'true' and 'false'.
-- Additional cases of this kind are noted in the comment just below.
procedure simplify_onces(tree); -- heuristic (but always sound) equisatisfiability simplification
-- for variables occurring only once
-- this routine is intended for use in connection with unquantified ELEM and related deductions.
-- note that the tree passed to this routine has been pre-blobbed. Hence we test only for variables
-- (including blob-names) which occur olu once (in their 'parent context', ssee below, and remove these
-- from the conjunct to be tested for unsatifiability. Note that if too much is removed, unsatisfiability tests
-- that might otherwise succedd sill fail, but nevertheless the result obtained will remain sound.
-- the following simplifications are applied:
-- (A) simplifications below the clause level:
-- arb(once) is simplifed to 'once'
-- car(once) is simplifed to 'once'
-- cdr(once) is simplifed to 'once'
-- once~[x] is simplifed to 'once'
-- once{x} is simplifed to 'once'
-- once + once, once * once, once - once is simplifed to 'once'
-- if once then once else x end if is simplifed to 'once'; likewise if once then x else once end if
-- if x then once else once end if is simplifed to 'once'
-- (B) simplifications at the clause level:
-- x = once is is simplifed to 'once'; likewise x /= once, etc.
-- x incs once can is simplifed to 'once'
-- once incs x is (x = {} or once)
-- x in once is is simplifed to 'once'; likeise notin
-- once in x is (x /= {} and once)
-- tis routine also deects cases in which the whole of a top-level conjuct reduces to 'once',
-- in which case the information which it contains is irrelevant to satisfiabilit.
-- If this happens for the final clause (the conclusion) of the conjuct submitted, testing is elided.
num_occurences_of := count_free_vars(tree); -- find and count the free variables in the tree
--print("num_occurences_of: ",{[x,y] in num_occurences_of | y /= 999999});
nuhblob := {}; -- auxiliary global to generate blobs for variables occuring in just one context
return simplify_onces_in(tree); -- call the recursive workhorse
end simplify_onces;
procedure simplify_onces_in(tree); -- equisatisfiability workhorse for variables occurring only once
--print("simplify_onces_in: ",unparse(tree));
if not is_tuple(tree) then return tree; end if; -- bottom-level leaf; no simplification is appled.
[n1,n2,n3] := tree; -- unpack node, which is possibly but not nesssarily binary
case (ah := abbreviated_headers(n1)?n1)
when "arb" => -- arb(once) is simplified to once
n2 := simplify_onces_in(n2); if is_string(n2) and num_occurences_of(n2) = 1 then
return newblob(n2); -- since the context of the variable has changed
end if;
return [n1,n2]; -- otherwise return the node with only the argument simplified
when "()" => -- function application: car(once) is simplified to once; cdr(once) is simplified to once
-- example [(), CAR, [[], once]]
if n2 = "CAR" or n2 = "CDR" then
n32 := simplify_onces_in(n3(2));
if is_string(n32) and num_occurences_of(n32) = 1 then
return newblob(n32); -- since the context of the variable has changed
end if;
end if;
return [n1,n2,["ast_list"] + [simplify_onces_in(n3(j)): j in [2..#n3]]];
-- just simplify the function arguments(e.g. might be unblobbed pair)
when "{.}" => -- multivalued map application. once{x} can be simplifed to 'once'
n2 := simplify_onces_in(n2); n3 := simplify_onces_in(n3);
if is_string(n2) and num_occurences_of(n2) = 1 then
-- simplifiable case: the map being applied has appeared only once
return newblob(n2); -- since the details of this subtree
-- are probably useless for subsequent satifiability testing
end if;
return [n1,n2,n3]; -- otherwise return a multivalued application with simplified arguments
when "{-}" => -- enumerated set: simplify the elements.
-- but also look for identical elements which can be eliminated
args := [simplify_onces_in(arg): arg in tree(2..)];
arg_blobs := [blob_to_string(a,[],0): a in args];
blobs_seen := {}; ok_args := []; -- loop over args eliminating duplicates
for arg = args(j) | (abj := arg_blobs(j)) notin blobs_seen loop
blobs_seen with:= abj; ok_args with:= arg;
end loop;
return [n1] + ok_args; -- return enumerated set with the pruned set of arguments
when "[-]" => -- enumerated tuple (pair or singleton): just simplify the elements
return [n1] + [simplify_onces_in(arg): arg in tree(2..)];
when "[]" => -- list: just simplify the elements
return [n1] + [simplify_onces_in(arg): arg in tree(2..)];
when "->" => -- the map application once~[x] is simplified to 'once';
-- x~[once] is simplified to if x = 0 then 0 else once end if
n2 := simplify_onces_in(n2); n3 := simplify_onces_in(n3);
if is_string(n2) and num_occurences_of(n2) = 1 then -- simplifiable case once~[x]
return newblob(n2); -- since the context of the variable has changed
end if;
if #n3 = 2 and is_string(n32 := n3(2)) and num_occurences_of(n32) = 1 then
-- simplifiable case x~[once]
return ["ast_if_expr",["ast_eq",n2,"_nullset"],"_nullset",newblob(n32)];
-- return if x = 0 then 0 else once end if
end if;
return [n1,n2,n3]; -- otherwise just return a map application with simplified arguments
when "in" => -- x in once is simplifed to 'once'
-- once in x can be (x /= {} and once)
n2 := simplify_onces_in(n2); n3 := simplify_onces_in(n3);
if is_string(n3) and num_occurences_of(n3) = 1 then -- simplifiable case x in once
return newblob(n3); -- since the details of this subtree
-- are probably useless for subsequent satifiability testing
end if;
if is_string(n2) and num_occurences_of(n2) = 1 then -- simplifiable case once in x
return ["ast_and",["ast_ne",n3,"_nullset"],newblob(n2)]; -- return (x /= {} and once)
end if;
return [n1,n2,n3]; -- otherwise just return the node with its simplified arguments
when "notin" => -- x notin once is simplifed to 'once'; likeise
-- once notin x can be (x = {} or once)
n2 := simplify_onces_in(n2); n3 := simplify_onces_in(n3);
if is_string(n3) and num_occurences_of(n3) = 1 then -- simplifiable case x notin once
return ["ast_not",newblob(n3)]; -- since the details of this subtree
-- are probably useless for subsequent satifiability testing
end if;
if is_string(n2) and num_occurences_of(n2) = 1 then -- simplifiable case once notin x
return ["ast_or",["ast_eq",n3,"_nullset"],newblob(n2)]; -- return (x /= {} and once)
end if;
return [n1,n2,n3]; -- otherwise just return the node with its simplified arguments
when "=","/=","==","/==" => -- x = x is simplified to true
-- x = once can be can be simplifed to 'once'; likewise x /= once, etc.
n2 := simplify_onces_in(n2); n3 := simplify_onces_in(n3);
if is_string(n3) and num_occurences_of(n3) = 1 then -- simplifiable case x = once, etc.
return if ah in {"=","=="} then newblob(n3) else ["ast_not",newblob(n3)] end if;
-- since the details of this subtree
-- are probably useless for subsequent satifiability testing
end if;
if is_string(n2) and num_occurences_of(n2) = 1 then -- simplifiable case once = x, etc.
return if ah in {"=","=="} then newblob(n2) else ["ast_not",newblob(n2)] end if;
-- since the details of this subtree
-- are probably useless for subsequent satifiability testing
end if;
return [n1,n2,n3]; -- otherwise just return the node with its simplified arguments
when "and","or","imp" => -- once and once is simplified to once; likewise 'or' and 'imp'
n2 := simplify_onces_in(n2); n3 := simplify_onces_in(n3);
if is_string(n2) and is_string(n3) and num_occurences_of(n2) = 1 and num_occurences_of(n3) = 1 then
return newblob(n2); -- since the details of this subtree
-- are probably useless for subsequent satifiability testing
end if;
return [n1,n2,n3]; -- otherwise just return the node with its simplified arguments
when "not" => -- (not once) is simplified to once
--print("not: ",unparse(n2)," ",num_occurences_of(n2));
n2 := simplify_onces_in(n2);
--print("not:: ",unparse(n2)," ",num_occurences_of(n2));
if is_string(n2) and num_occurences_of(n2) = 1 then -- simplifiable case
return newblob(n2); -- since the context of the variable has changed
end if;
return [n1,n2]; -- otherwise just return the node sith its simplified argument
when "if" => -- if any branch of an if is known to be false it is dropped;
-- if true then it truncates
-- the syntax is [if,cond,res,else_res]
-- note that this simplification coud be handled in a more sophisticated way
-- by exploiting cases in which the 'if' condition blobs to a string which appears only once
n2 := simplify_onces_in(n2); n3 := simplify_onces_in(n3);
n4 := simplify_onces_in(tree(4));
if n2 = "FALSE" then -- take the last branch of this if when its condition is known to be false
return n4;
elseif n2 = "TRUE" then -- take the first branch of this if when its condition is known to be true
return n3;
else
return [n1,n2,n3,n4]; -- otherwise just return the node with its simplified arguments
end if;
when "+","-","*" => -- union: once + once simplifies to 'once'; likewise "-" and "*"
-- we also special case the union of two enumerated sets
n2 := simplify_onces_in(n2); n3 := simplify_onces_in(n3); -- simplify the operation arguments
if is_string(n2) and is_string(n3) and num_occurences_of(n2) = 1 and num_occurences_of(n3) = 1 then
return newblob(n2); -- since the context of the variable has changed
end if;
return [n1,n2,n3]; -- otherwise just return the node with its simplified arguments
when "incs" => -- includes
-- x incs once can can be simplifed to 'once'
-- once incs x can be (x = {} or once)
n2 := simplify_onces_in(n2); n3 := simplify_onces_in(n3);
if is_string(n3) and num_occurences_of(n3) = 1 then -- simplifiable case x incs once
return newblob(n3); -- since the context of the variable has changed
end if;
if is_string(n2) and num_occurences_of(n2) = 1 then -- simplifiable case once incs x
return ["ast_or",["ast_eq",n3,"_nullset"],newblob(n2)]; -- return (n2 = {} or once)
end if;
return [n1,n2,n3]; -- otherwise just return the node with its simplified arguments
when "incin" => -- inclusion in
-- x •incin once can can be simplifed to 'once'
-- once •incin x can be (x = {} or once)
n2 := simplify_onces_in(n2); n3 := simplify_onces_in(n3);
if is_string(n2) and num_occurences_of(n2) = 1 then -- simplifiable case x •incin once
return newblob(n2); -- since the context of the variable has changed
end if;
if is_string(n3) and num_occurences_of(n3) = 1 then -- simplifiable case once •incin x
return ["ast_or",["ast_eq",n2,"_nullset"],newblob(n3)]; -- return (n3 = {} or once)
end if;
return [n1,n2,n3]; -- otherwise just return the node with its simplified arguments
when "itr","Etr" => -- iteration
-- a syntactic example is: ["ast_iter_list", ["ast_in", "X", "S"], ["DOT_INCIN", "Y", "T"]].
-- we just simplify the constraint sets.
simplified := [n1];
for [ikind,ivar,irange] in tree(2..) loop
simplified with:= [ikind,ivar,simplify_onces_in(irange)];
end loop;
return simplified; -- otherwise just return the node with its simplified arguments
when "{}" => -- setformer; first collect the bound variable
-- a syntactic example is: {e(x,y): x in s, y •incin t | P(x,y)}
-- parses to ["ast_genset", ["ast_of", "E", ["ast_list", "X", "Y"]],
-- ["ast_iter_list", ["ast_in", "X", "S"], ["DOT_INCIN", "Y", "T"]], ["ast_of", "P", ["ast_list", "X", "Y"]]]
-- we simplify each of the three parts, reassemble them,
n2 := simplify_onces_in(n2); n3 := simplify_onces_in(n3); n4 := simplify_onces_in(tree(4));
return [n1,n2,n3,n4];
-- return simplify_setformer([n1,n2,n3,n4]);
-- pass the result to 'simplify_setformer' for further processing (temporarily disabled)
when "EX","{/}" => -- existential quantifier; also setformer, no exp;
-- we simplify each of the two parts and reassemble them
n2 := simplify_onces_in(n2); n3 := simplify_onces_in(n3);
return [n1,n2,n3];
-- return simplify_setformer([n1,n2,n3,n4]);
-- pass the result to 'simplify_setformer' for further processing (temporarily disabled)
when "ALL" => -- universal quantifier
n2 := simplify_onces_in(n2); n3 := simplify_onces_in(n3);
return [n1,n2,n3];
-- return simplify_setformer([n1,n2,n3,n4]);
-- pass the result to 'simplify_setformer' for further processing (temporarily disabled)
otherwise => -- might be some other infix or prefix operator
n2 := simplify_onces_in(n2); -- simplify the first argument
if n3 = OM then return [n1,n2]; end if; -- if there is no n3 argument this is a prefix operator
n3 := simplify_onces_in(n3); -- binary operator; simplify the second argument
return [n1,n2,n3]; -- recombine, and return the result
end case;
end simplify_onces_in;
procedure count_free_vars(node); -- find the free variables in a tree and count theor number of occurrences (main entry)
free_vars_count := {["0",999999],["TRUE",999999],["_nullset",999999],["ast_true",999999],["ast_false",999999],["FALSE",999999]} + {[spna,999999]: spna in special_set_names};
-- all constants nominally 'pre-occur' frequently
prior_free_vars_context := {}; -- initialize the global map used by the recursive workhorse
count_free_vars_in(node,[],OM); -- then just call the recursive workhorse
res := free_vars_count; -- the recursive workhorse develops its result in this global variable
--print("free_vars_count: ");
return res;
end count_free_vars;
procedure count_free_vars_in(node,bound_vars,parent_context);
-- find the free variables in a tree and count their number of occurrences (recursive workhorse)
if is_string(node) then -- we have descended to a variable or constant
--print("encountered: ",node," ",free_vars_count(node)," ",parent_context);
-- record the first context in which the variable is seen
if (fvc := free_vars_count(node)) = OM then
-- variable or constant has not been seen before;
-- record the context in which it is initially seen
prior_free_vars_context(node) := parent_context;
free_vars_count(node) := 1; return;
end if;
-- multiple occurences of a variable in the same parent context are not counted as different.
-- for example, if a variable v occurs twice in the context x incs v, we deem it
-- to have occurred only once; this my lead to slightly excessive blobbing, but is sound
-- since the context in which this variable is see is not new
if parent_context = (pcn := prior_free_vars_context(node))
or reverse_context(parent_context) = pcn then return; end if;
-- since this is not really different from the first occurence of the variable in question;
-- e.g. the reverse context of 'x in y' is 'x notin y'
if node notin bound_vars and node /= "OM" and node /= "_nullset" and node notin special_set_names then
-- the variable is being seen again, in a context different from that in which it was seen initially
free_vars_count(node) := (free_vars_count(node)?0) + 1; end if;
return;
end if;
case (ah := abbreviated_headers(node(1)))
-- handle non-string parse trees by descencing them recursively, unless they bind variables, in which case the
-- bound_variables argument o this procedure must be adjusted accordingly
when "()" => -- this is the case of functional and predicate application;
-- here node(2) is a reserved symbol, not a set
for sn = node(3)(2..)(j) loop count_free_vars_in(sn,bound_vars,[node,j]); end loop;
when "{}","{/}","EX","ALL" => -- setformer and quantifier cases
bound_vars +:= find_bound_vars(node); -- setformer or quantifier; note the new bound variables
-- and then process the parts of the node recursively
for sn = node(2..)(j) loop count_free_vars_in(sn,bound_vars,[node,j]); end loop;
-- now collect free variables in args
when "@" => -- functional application
for sn = node(2..)(j) loop count_free_vars_in(sn,bound_vars,[node,j]); end loop;
-- now collect free variables in args
otherwise => -- additional infix and prefix operators
for sn = node(2..)(j) loop count_free_vars_in(sn,bound_vars,[node,j]); end loop;
-- now collect free variables in args
end case;
end count_free_vars_in;
procedure newblob(stg); -- modified blob-name generator for use with 'simplify_onces';
-- generates unique blob names of the modified form 'BLA_nnn'
-- note that this routine is called when an operator is being applied to a string
-- considered unique because it occurs in only one parent context, or to a previously
-- generated blob of the form BLA-nnn. When called, it generates a unique blob of the same form,
-- and notes that this blob has occured only once.
if (nb := nuhblob(stg)) /= OM then return nb; end if;
nuhblob(stg) := (nb := "BLA_" + str(blab_name_ctr +:= 1));
-- num_occurences_of(nb) := 1; -- ****** check this before enabling
return nb;
end newblob;
-- ************ propositional-level simplifications involving the implicit signs of propositional variables ************
procedure exploit_prop_signs(node); -- use the signs of propositional variables to simplify (main entry)
find_prop_signs(node); -- find the signs of the propostional-level variables (returned in global the_prop_sgns)
-- these propositional variables are regarded as having no particular sign, so that they are immune
-- to the simplifications applied by this procedure, which can only deal with propositional variables
-- which have the same propositional sign at each of their occurences, and then repalces them with
-- 'true' or 'false' as appropriate.
find_vars_in_ifs(node); -- find all the variables nested within if-conditions
--print("the_prop_sgns: ",the_prop_sgns);
return exploit_prop_signs_in(node); -- use the signs of propositional variables to simplify this conjunct
end exploit_prop_signs;
procedure exploit_prop_signs_in(node); -- use the signs of propositional variables to simplify (workhorse)
-- when a propositional variable with a desired sign is encountered, we reduce it to 'true' or 'false',
-- if it occurs just once and then make the appropriate calculation at the next higher level
if is_string(node) then
if node in vars_in_ifs then return node; end if; -- do not try to handle vars in ifs
if node = "ast_true" or node = "TRUE" then return "TRUE"; end if; -- special case boolean constants
if node = "ast_false" or node = "FALSE" then return "FALSE"; end if; -- special case boolean constants
--print("exploit_prop_signs_in: ",node," ",the_prop_sgns(node));
return if (tps := the_prop_sgns(node)) = 1 then "TRUE" elseif tps = 0 then "FALSE" else node end if;
-- if all of a variable's occurence are positive, give it the value 'true';
-- if all are negative, give it the value 'false'; if the variable occurs with both signs, just keep it
end if;
[n1,n2,n3] := node; -- unpack
case (ah := abbreviated_headers(n1))
when "and" => -- boolean operators
-- if a 'true' or false' value is available for either branch of a conjunction, give it an appropriate value,
-- or simplify it to the other branch.
n2 := exploit_prop_signs_in(n2); n3 := exploit_prop_signs_in(n3);
return if n2 = "TRUE" then n3 elseif n3 = "TRUE" then n2
elseif n2 = "FALSE" or n3 = "FALSE" then "FALSE" else [n1,n2,n3] end if;
when "or" => -- boolean operators
n2 := exploit_prop_signs_in(n2); n3 := exploit_prop_signs_in(n3);
-- if a 'true' or false' value is available for either branch of a disjunction, give it an appropriate value,
-- or simplify it to the other branch.
return if n2 = "FALSE" then n3 elseif n3 = "FALSE" then n2
elseif n2 = "TRUE" or n3 = "TRUE" then "TRUE" else [n1,n2,n3] end if;
when "not" => -- inverting Boolean
-- if a 'true' or false' value is available for the argument, just reverse it
n2 := exploit_prop_signs_in(n2);
return if n2 = "FALSE" then "TRUE" elseif n2 = "TRUE" then "FALSE" else [n1,n2] end if;
when "imp" => -- implicationl treat ans (not n2) or ne
n2 := exploit_prop_signs_in(n2); n3 := exploit_prop_signs_in(n3);
return if n2 = "FALSE" or n3 = "TRUE" then "TRUE"
elseif n2 = "TRUE" then n3 elseif n3 = "FALSE" then ["ast_not",n2] else [n1,n2,n3] end if;
otherwise => -- all other cases
return node; -- don't descend past Boolean level
end case;
end exploit_prop_signs_in;
procedure find_vars_in_ifs(node); -- find all the free variables nested within if-conditions in a tree (main entry)
vars_in_ifs := {}; -- global set in which the result will be developed
find_vars_in_ifs_in(node,[],false); return vars_in_ifs; -- use the recursive workhorse and a global variable
end find_vars_in_ifs;
procedure find_vars_in_ifs_in(node,bound_vars,is_in);
-- find all the free variables nested within if-conditions in a tree (recursive workhorse)
if is_string(node) then
if is_in and node notin bound_vars then vars_in_ifs with:= node; end if; -- put the variable into vars_in_ifs if is_in
return;
end if;
case (ah := abbreviated_headers(node(1)))
when "()" => -- this is the case of functional and predicate application;
-- the second variable is a reserved symbol, not a set;
-- proces the function arguments successively.
for sn = node(3..)(j) loop find_vars_in_ifs_in(sn,bound_vars,is_in); end loop;
when "{}","{/}","EX","ALL" =>
bound_vars +:= find_bound_vars(node);
-- setformer or quantifier; note the bound variables, then process the body of the condition
for sn = node(2..)(j) loop find_vars_in_ifs_in(sn,bound_vars,is_in); end loop;
when "@" => -- function omposition
for sn = node(2..)(j) loop find_vars_in_ifs_in(sn,bound_vars,is_in); end loop;
-- process the arguments of the composition
when "if" => -- set is_in flag
find_vars_in_ifs_in(node(2),bound_vars,true);
-- variables in the second argument of the 'if' (i.e. the 'if-condition' ae added to our
-- developing collection of variables.
-- process 'elseif' recursively
if is_tuple(n4 := node(4)) and n4(1) = "ast_if_expr" then find_vars_in_ifs_in(node(4),bound_vars,is_in); end if;
otherwise => -- additional infix and prefix operators
for sn = node(2..)(j) loop find_vars_in_ifs_in(sn,bound_vars,is_in); end loop;
-- process the operation arguments recursively
end case;
end find_vars_in_ifs_in;
procedure find_prop_signs(node); -- find the signs of propositional variables if these are definite (main entry)
the_prop_sgns := {}; find_prop_signs_in(node,1); -- use the recursive workhorse and a global variable
-- 'the_prop_sgns' will map propositional variables to their unique signs, or to '2' if the variable
-- occurs with both signs
return the_prop_sgns;
end find_prop_signs;
procedure find_prop_signs_in(node,psgn);
-- find the signs of propositional variables if these are definite (recursive workhorse)
if is_string(node) and node /= "TRUE" and node /= "FALSE" then
the_prop_sgns(node) := if (osgn := the_prop_sgns(node)) = OM or osgn = psgn or psgn = 2 then psgn
else 2 end if; -- '2' is the sign of an indefinite value
return;
end if;
case (ah := abbreviated_headers(node(1)))
when "and","or" => -- boolean operators preserving positivity
-- descend the tree to the operator arguments, preserving signs
for sn in node(2..) loop find_prop_signs_in(sn,psgn); end loop;
when "not" => -- inverting Boolean
-- descend the tree to the operator arguments, reversing signs
find_prop_signs_in(node(2),if psgn = 2 then 2 else 1 - psgn end if);
when "==","/==" => -- scrambling Boolean
-- descend the tree to the operator arguments, transmitting indefinite sign
for sn in node(2..) loop find_prop_signs_in(sn,2); end loop; -- args are of indefinite sign
when "imp" => -- implication
-- treat as (not n2) or n3
find_prop_signs_in(node(2),if psgn = 2 then 2 else 1 - psgn end if); -- first arg is inverted
find_prop_signs_in(node(3),psgn); -- second arg is direct
otherwise => -- all other cases
return; -- don't descend past Boolean level
end case;
end find_prop_signs_in;
procedure find_bound_vars(node); -- find the bound variables at the top of an iterator tree
case abbreviated_headers(node(1))
-- get the iterator list if the node at hand binds some variables
when "{}" => iter_list := node(3); -- setformer; get iteration list from position 3
when "EX","{/}" => iter_list := node(2); -- existential or setformer without exp; get iteration list from position 2
when "ALL" => iter_list := node(2); -- universal; get iteration list from position 2
otherwise => return {}; -- no bound variables at this node
end case; -- now process the iteration list
bound_vars := []; -- start to collect ordered set of bound variables
for iter_clause in iter_list(2..) loop
--print("iter_clause: ",iter_clause," ",abbreviated_headers(iter_clause(1)));
if is_string(iter_clause) then bound_vars with:= iter_clause; continue; end if;
-- case of an unconstrained iterator in a quantifier; collect the variable it binds
case abbreviated_headers(iter_clause(1))
when "=" => bound_vars with:= iter_clause(2); -- x = f(y) or x = f{y} iterator.
-- note: this starts to handle an iterator syntax somewhat more general than that actually allowed
-- in the scenarios as currently supported.
bound_vars with:= iter_clause(3)(3)(2);
-- from the 'functional' tail of the iterator, dig out the argument list and then its first element
-- Note: in iterator constructions like x = f(y,z,w), only the first argument is bound by the iterator
when "in","incin" => bound_vars with:= iter_clause(2); -- x in s or x incin s iterator; collect x
end case;
end loop;
return bound_vars;
end find_bound_vars;
procedure find_iterators(node); -- find the iterator list at the top of an iterator tree
case abbreviated_headers(node(1))
when "{}" => iter_list := node(3); -- setformer; get iteration list from position 3
when "EX","{/}","ALL" => iter_list := node(2); -- existential,universal, or setformer without exp; get iteration list from position 2
otherwise => return {}; -- no bound variables at this node
end case; -- now process the iteration list
return iter_list;
end find_iterators;
procedure find_all_vars(node); return find_free_vars(node) + {x: x in find_bound_vars(node)}; end find_all_vars;
-- find all the free or bound variables in a formula
procedure new_name(stg,nameset); -- generates new names for bound variables during a simplification operation
rspan(stg,"_0123456789"); for j in [1..#nameset + 1] | (newn := stg + "_" + str(j)) notin nameset loop return newn; end loop;
end new_name;
-- **********************************************************************************************************************************************
-- ********** Direct interface routines between blobbing and the decision algorithms underlying the 'ELEM' logical inference mechanism **********
-- **********************************************************************************************************************************************
procedure model_blobbed(formula); -- models a blobbed mlss formula, or pronounces it unsatisfiable by returning OM
--print("model_blobbed: ",unparse(formula));
if formula = "TRUE" then return {["TRUE",true]}; elseif formula = "FALSE" then return OM; end if; -- degenerate cases
[set_of_disjunctions,meaning_of_propsymbol,addnal_setrelns] := decompose_post_blobbing(formula);
-- decompose the formula into a purely propositional formula and a mapping of propostional symbols
-- to the settheortietic relationships which they represent.
--->DP_input
--print("Davis_Putnam input: set_of_disjunctions: \n",set_of_disjunctions,"\nmeaning_of_propsymbol: \n",meaning_of_propsymbol,"\naddnal_setrelns: \n",addnal_setrelns);
-- analyze into propsitional and non-propositional level information
DP_branches_count := 0; -- count used to suppress excess Davis_Putnam branching
DP_start_secs := unstr(time()(7..8)); -- get the number of seconds in the starting time
trying_count := 0; -- count used to issue extra messages on longish ELEM inferences
-- call the Davis_putnam decider, also passing the map of propositional symbols to the set-theoretic
-- relationships wich they represent.
--print("Davis_Putnam start: ",time()," ",set_of_disjunctions," ",[meaning_of_propsymbol,addnal_setrelns]);
res := Davis_Putnam(set_of_disjunctions,mlss_decider,[meaning_of_propsymbol,addnal_setrelns]);
--print("Davis_Putnam finished: ",res," ",time());
return res;
end model_blobbed;
-- the following routiine transforms blobbed and the simplified conjunctions into the form
-- with which the base-level satisfiability-testing routines will actually work.
procedure decompose_post_blobbing(formula); -- decomposition procedure for formulae blobbed to a decidable language
-- The 'base language' of the logic system, which the blobbing algorithm leaves unblobbed,
-- allows all the propositional operators, plus all the elementary set-theoretic operations and
-- comparisons, plus the conditional operator 'if'. The unary functions
-- 'range' and 'domain', plus the infix operator '!' (map restriction) may be added later.
-- special functions like 'car', cdr' and 'cons', for which satifiability are available, can appear in the blobbed
-- conjucts transmitted to this routine. This routine elimainates them and replaces them by roughly equivalent
-- (but always somewhat weakened) sets of pure MLSS conditions, which are then submitted to the MLSS decider.
-- Formulae initially written in standard fashion as trees of tuples are converted into a collection
-- of elementary equalities, inequalities, boolean relationships, and pairs of positive and negative
-- propositional terms, these lst representing disjunctions in the form expected by the extended Davis_Putnam procedure.
-- INPUT: A formula written as a tree of tuples;
-- OUTPUT: a triple [set_of_disjunctions,meaning_of_propsymbol,addnal_setrelns]
-- set_of_disjunctions is a set of pairs [positive_clauses,negative_clauses]
-- both positive_clauses and negative_clauses are sets of atoms, the first representing propositional terms
-- positive in the disjunction, the second representing propositional terms negative in the disjunction.
-- A meaning_of_propsymbol entry is made for each relationship between sets encountered at the set-to-boolean boundary.
-- This maps a name (an atom) assigned to the relationship into the triple [op,arg1,arg2] which it represents, where 'op'
-- can be any of "=", "\=", "in", "notin". Once boolean values hve been assigned to the propositional
-- names, these meaning_of_propsymbol entries give rise to known relatioships of which can be added to the collection
-- 'addnal_setrelns' of elements quadruples [name, op, arg1,arg2] for processing by a term decider acting at the set level.
var
set_of_disjunctions := { }, -- global for collecting Davis-Putnam disjunctive clauses
-- prop_collection := { }, -- global for collecting Davis-Putnam equalities generated by 'if' expressions
meaning_of_propsymbol := { }, -- global for map translating bottom-level propositional symbols into elementary set relationships.
addnal_setrelns := { }, -- global for collecting additonal set-theoretic equalities
special_setrelns := { }; -- global for collecting special set-theoretic equalities, to be replaced by extension conditions
var atom_having_meaning := {}; -- maps meaning tuple into atom with that meaning
var op_to_occs := {}; -- will map each operator into the tuples in which it occurs
-- the collection of addnal_setrelns built consists of triples of the form ["+",x,y,z]
-- (x is the union of y and z), ["-",x,y,z] (x is the difference of y and z),
-- ["*",x,y,z] (x is the intersection of y and z), ["=",x,y] (x equals y),
-- ["/=",x,y] (x is distinct from y), ["incs",x,y] (x includes y), and ["in",x,y]
set_of_disjunctions with:= [{decompose_in(formula,true)},{ }]; -- call recursive inner workhorse
-- the second parameter is true when this routine has been called from the propositional level
-- note that the above instruction adds one final disjunct, which states that
-- the atom representing the 'top level' proposition must be assigned the value 'true'
-- now we process the special_setrelns, transforming them into the equivalent extension conditions,
-- which are added to the addnal_setrelns
--print("post_blobbing set_of_disjunctions: ",set_of_disjunctions); print("special_setrelns: ",special_setrelns); print("meaning_of_propsymbol: ",meaning_of_propsymbol);
for triple in special_setrelns loop
[res_atm,op_atm,-] := triple; -- format is [res_atm,op_atm,args....]
op_to_occs with:= [op_atm,triple]; -- collect the operator occurence
case op_atm
when "arb" => -- [x,arb,y], representing x = arb(y)
y_arg := triple(3); -- the one argument of 'arb'
x_is_null_atm := atom_with_meaning(["=",res_atm,"0"]); -- define x_is_null_atm to mean 'x = 0'
y_is_null_atm := atom_with_meaning(["=",y_arg,"0"]); -- define y_is_null_atm to mean 'y = 0'
x_in_y_atm := atom_with_meaning(["in",res_atm,y_arg]); -- define x_in_y_atm to mean 'x in y'
intersect_atm := atom_with_set_meaning(["*",res_atm,y_arg]); -- define intersect_atm to mean 'x * y'
intr_is_null_atm := atom_with_meaning(["=",intersect_atm,"0"]); -- define intr_is_null_atm to mean 'x * y = 0'
--print("adding: ",[x_is_null_atm,["=",res_atm,"0"]]," ",[y_is_null_atm,["=",y_arg,"0"]]," ",[x_in_y_atm,["in",res_atm,y_arg]]," ",[intersect_atm,"*",res_atm,y_arg]);
set_of_disjunctions +:= {[{x_is_null_atm,x_in_y_atm},{}],[{y_is_null_atm,x_in_y_atm},{}],[{intr_is_null_atm},{}]};
-- add the clauses x = 0 or y in x. y = 0 or y in x, x * y = 0, as the extension conditions for arg
end case;
end loop;
-- now we must add conditions which guarantee that all the function symbols accumulated in 'op_to_occs' are single-valued
for x in domain(op_to_occs) | (ntfo := #(tups_for_op := op_to_occs{x})) > 1 loop
tups_for_op := [y: y in tups_for_op]; -- make into an ordered list
for tup_jj = tups_for_op(jj), kk in [jj + 1..ntfo] loop
tup_kk := tups_for_op(kk);
if (ntjj := #tup_jj) /= #tup_kk then print("ARGUMENT COUNT DISCREPANCY: ",tup_jj," ",tup_kk); end if;
hypothesis_equality_atoms := {}; -- these will be collected to form a single-valuedness clause
for argno in [3..ntjj] loop -- iterate over all the operator arguments
arg_of_jj := tup_jj(argno); arg_of_kk := tup_kk(argno); -- get the function arguments from matching positions
hypothesis_equality_atoms with:= (hypat := atom_with_meaning(["=",arg_of_jj,arg_of_kk]));
end loop;
val_jj := tup_jj(1); val_kk := tup_kk(1); -- get the function results
conclusion_atom := atom_with_meaning(["=",val_jj,val_kk]); -- define conclusion_atom to mean 'val_jj = val_kk'
set_of_disjunctions with:= [{conclusion_atom},hypothesis_equality_atoms]; -- add the clause hypotheses_equalities •imp conclusions_equality
end loop;
end loop;
if (ntfo := #(tups_for_op := op_to_occs{"[-]"})) > 1 then -- special processing for 'cons' oprator; force it to be '1-1- in each of its arguments'
tups_for_op := [y: y in tups_for_op]; -- make into an ordered list
for tup_jj = tups_for_op(jj), kk in [jj + 1..ntfo] loop
tup_kk := tups_for_op(kk);
hypothesis_equality_atoms := {}; -- these will be collected to form a 1-to-1-ness clause
val_jj := tup_jj(1); val_kk := tup_kk(1); -- get the function results
hypat := atom_with_meaning(["=",val_jj,val_kk]); -- define conclusion_atom to mean 'val_jj = val_kk'
for argno in [3..4] loop -- iterate over all the operator arguments
arg_of_jj := tup_jj(argno); arg_of_kk := tup_kk(argno); -- get the function arguments from matching positions
conclusion_atom := atom_with_meaning(["=",arg_of_jj,arg_of_kk]); -- define conc_at to mean 'arg_of_jj = arg_of_kk
set_of_disjunctions with:= [{conclusion_atom},{hypat}]; -- add the clause hypat •imp (each) conclusion_atom
end loop;
end loop;
--print("set_of_disjunctions: ",set_of_disjunctions," ",meaning_of_propsymbol);
end if;
for [a,-,b,c] in op_to_occs{"[-]"} loop -- for inverse cons/car and cons/cdr relationships
for [d,-,e] in op_to_occs{"CAR"} loop
hypat := atom_with_meaning(["=",a,e]); -- result of cons is input to car
concl_at := atom_with_meaning(["=",b,d]); -- result of car is first argument of cons
set_of_disjunctions with:= [{concl_at},{hypat}];
end loop;
for [d,-,e] in op_to_occs{"CDR"} loop
hypat := atom_with_meaning(["=",a,e]); -- result of cons is input to car
concl_at := atom_with_meaning(["=",c,d]); -- result of car is first argument of cons
set_of_disjunctions with:= [{concl_at},{hypat}];
end loop;
end loop;
--->special_props
special_mon("#"); -- special processing for cardinality as monotone operator
special_mon("MON"); -- special processing for monotone operator
special_mon("BIG_MON"); -- special processing for second monotone operator
special_mondn("MONDN"); -- special processing for monotone operator
special_bigger_op("BIG_MON","MON"); -- special processing for pair of monotone operators in known inclusion relationship
special_mon2("MON2"); -- special processing for monotone operator with 2 arguments
special_idempotent("IDEMP"); -- special processing for idempotent functions
special_self_inverse("SELFINV"); -- special processing for self_inverse functions
special_inher_add("FINITE"); -- special processing for inherited-additive predicates
special_inher_add("IS_MAP"); -- special processing for inherited-additive predicates
special_equiv_reln("EQRELN"); -- special processing for equivalence relationships
special_part_order("PORDRELN"); -- special processing for partial-order relationships
special_tot_order("TOTORDRELN"); -- special processing for total-order relationships
--print("end of decompose_post_blobbing: set_of_disjunctions:: ",set_of_disjunctions, "meaning_of_propsymbol = ",meaning_of_propsymbol," addnal_setrelns = ",addnal_setrelns);
return [set_of_disjunctions,meaning_of_propsymbol,addnal_setrelns];
procedure special_bigger_op(bigop,op); -- special processing for pair of monotone operators in known inclusion relationship
for [resbig,-,inpbig] in op_to_occs{bigop}, [res,-,inp] in op_to_occs{op} loop
hypat := atom_with_meaning(["incs",inpbig,inp]); -- inclusion between inputs
concl_at := atom_with_meaning(["incs",resbig,res]); -- inclusion between outputs
set_of_disjunctions with:= [{concl_at},{hypat,hypat2}]; -- the two hypotheses imply the conclusion
end loop;
end special_bigger_op;
procedure special_mon2(op); -- special processing formonotone operator with 2 arguments
if (ntfo := #(tups_for_op := op_to_occs{op})) > 1 then -- special processing for monotone operators
tups_for_op := [y: y in tups_for_op]; -- make into an ordered list
for [resjj,-,inpjj,inp2jj] = tups_for_op(jj), kk in [1..ntfo] | jj /= kk loop
[reskk,-,inpkk,inp2kk] := tups_for_op(kk); -- get the reult and argument atoms
hypat := atom_with_meaning(["incs",inpjj,inpkk]); -- inclusion between inputs
hypat2 := atom_with_meaning(["incs",inp2jj,inp2kk]); -- inclusion between second inputs
concl_at := atom_with_meaning(["incs",resjj,reskk]); -- inclusion between outputs
set_of_disjunctions with:= [{concl_at},{hypat,hypat2}]; -- the two hypotheses imply the conclusion
end loop;
end if;
end special_mon2;
procedure special_idempotent(op); -- special processing for idempotent functions
tups_for_op := op_to_occs{op};
tups_for_op := [y: y in tups_for_op]; -- make into an ordered list
for [resjj,-,inpjj] = tups_for_op(jj), [reskk,-,inpkk] = tups_for_op(kk) | jj /= kk loop
hypat := atom_with_meaning(["=",resjj,inpkk]); -- equality of input and output
concl_at := atom_with_meaning(["=",resjj,reskk]); -- inclusion between first and second outputs
set_of_disjunctions with:= [{concl_at},{hypat}]; -- the two hypotheses imply the conclusion
end loop;
end special_idempotent;
procedure special_self_inverse(op); -- special processing for self_inverse functions
tups_for_op := op_to_occs{op};
tups_for_op := [y: y in tups_for_op]; -- make into an ordered list
for [resjj,-,inpjj] = tups_for_op(jj), [reskk,-,inpkk] = tups_for_op(kk) | jj /= kk loop
hypat := atom_with_meaning(["=",resjj,inpkk]); -- equality of input and output
concl_at := atom_with_meaning(["=",inpjj,reskk]); -- inclusion between first input and second output
set_of_disjunctions with:= [{concl_at},{hypat}]; -- the two hypotheses imply the conclusion
end loop;
end special_self_inverse;
procedure special_inher_add(pred); -- special processing for inherited-additive predicates
pr_atom := pred_atom(pred)?(pred_atom(pred) := newat()); -- get the special atom for the predicate
for [atm,-,arg] in op_to_occs{pred} loop
meaning_of_propsymbol with:= [atm,["incs",pr_atom,arg]];
end loop;
end special_inher_add;
procedure special_equiv_reln(reln); -- special processing for equivalence relationships
reln_atom := pred_atom(reln)?(pred_atom(reln) := newat()); -- get the special atom for the relationship; this denotes the 'representing function'
assoc_atom := {}; -- maps each element in domain of relationship into associated range element f(x), where f is the representing function
for [atm,-,arg1,arg2] in op_to_occs{reln} loop -- process all the pairs generated by the equivalence relationship
rep_atm1 := assoc_atom(arg1)?(assoc_atom(arg1) := newat()); -- generate a new value atom if none exists already
rep_atm2 := assoc_atom(arg2)?(assoc_atom(arg2) := newat()); -- generate a new value atom if none exists already
meaning_of_propsymbol with:= [atm,["=",rep_atm1,rep_atm2]]; -- the relationship reduces to equality of the representing atoms
end loop;
naa := #(assoc_atom := [pair: pair in assoc_atom]); -- convert to tuple
for [dj,valj] = assoc_atom(j), k in [j + 1..naa] loop -- the representing function is single_valued
[dk,valk] := assoc_atom(k);
hypat := atom_with_meaning(["=",dj,dk]); -- equality of inputs
concl_at := atom_with_meaning(["=",valj,valk]); -- equality of outputs
set_of_disjunctions with:= [{concl_at},{hypat}]; -- the two hypotheses imply the conclusion
end loop;
end special_equiv_reln;
procedure special_part_order(reln); -- special processing for partial-order relationships
reln_atom := pred_atom(reln)?(pred_atom(reln) := newat()); -- get the special atom for the relationship; this denotes the 'representing function'
assoc_atom := {}; -- maps each element in domain of relationship into associated range element f(x), where f is the representing function
for [atm,-,arg1,arg2] in op_to_occs{reln} loop -- process all the pairs generated by the equivalence relationship
rep_atm1 := assoc_atom(arg1)?(assoc_atom(arg1) := newat()); -- generate a new value atom if none exists already
rep_atm2 := assoc_atom(arg2)?(assoc_atom(arg2) := newat()); -- generate a new value atom if none exists already
meaning_of_propsymbol with:= [atm,["incs",rep_atm1,rep_atm2]]; -- the relationship reduces to inclusion of the representing atoms
end loop;
naa := #(assoc_atom := [pair: pair in assoc_atom]); -- convert to tuple
for [dj,valj] = assoc_atom(j), k in [j + 1..naa] loop -- the representing function is single_valued
[dk,valk] := assoc_atom(k);
hypat := atom_with_meaning(["=",dj,dk]); -- equality of inputs
concl_at := atom_with_meaning(["=",valj,valk]); -- equality of outputs
set_of_disjunctions with:= [{concl_at},{hypat}]; -- the two hypotheses imply the conclusion
end loop;
end special_part_order;
procedure special_tot_order(reln); -- special processing for total-order relationships
reln_atom := pred_atom(reln)?(pred_atom(reln) := newat()); -- get the special atom for the relationship; this denotes the 'representing function'
assoc_atom := {}; -- maps each element in domain of relationship into associated range element f(x), where f is the representing function
for [atm,-,arg1,arg2] in op_to_occs{reln} loop -- process all the pairs generated by the equivalence relationship
rep_atm1 := assoc_atom(arg1)?(assoc_atom(arg1) := newat()); -- generate a new value atom if none exists already
rep_atm2 := assoc_atom(arg2)?(assoc_atom(arg2) := newat()); -- generate a new value atom if none exists already
meaning_of_propsymbol with:= [atm,["incs",rep_atm1,rep_atm2]]; -- the relationship reduces to inclusion of the representing atoms
end loop;
naa := #(assoc_atom := [pair: pair in assoc_atom]); -- convert to tuple
for [dj,valj] = assoc_atom(j), k in [j + 1..naa] loop -- the representing function is single_valued
[dk,valk] := assoc_atom(k);
hypat := atom_with_meaning(["=",dj,dk]); -- equality of inputs
concl_at := atom_with_meaning(["=",valj,valk]); -- equality of outputs
set_of_disjunctions with:= [{concl_at},{hypat}]; -- the two hypotheses imply the conclusion
-- we must also force the range of the representing function to be linearly ordered by inclusion
alt1 := atom_with_meaning(["incs",valj,valk]); -- inclusion of outputs
alt2 := atom_with_meaning(["incs",valk,valj]); -- inclusion of outputs
set_of_disjunctions with:= [{alt1,alt2},{}]; -- the two hypotheses imply the conclusion
end loop;
end special_tot_order;
procedure special_mon(op); -- special processing for monotone operator
if (ntfo := #(tups_for_op := op_to_occs{op})) > 1 then -- special processing for monotone operators
tups_for_op := [y: y in tups_for_op]; -- make into an ordered list
for [resjj,-,inpjj] = tups_for_op(jj), kk in [1..ntfo] | jj /= kk loop
[reskk,-,inpkk] := tups_for_op(kk);
hypat := atom_with_meaning(["incs",inpjj,inpkk]); -- inclusion between inputs
concl_at := atom_with_meaning(["incs",resjj,reskk]); -- inclusion between outputs
set_of_disjunctions with:= [{concl_at},{hypat}];
end loop;
end if;
--print("set_of_disjunctions: ",set_of_disjunctions);
end special_mon;
procedure special_mondn(op); -- special processing for monotone decreasing operator
if (ntfo := #(tups_for_op := op_to_occs{op})) > 1 then -- special processing for monotone decreasing operators
tups_for_op := [y: y in tups_for_op]; -- make into an ordered list
for [resjj,-,inpjj] = tups_for_op(jj), kk in [1..ntfo] | jj /= kk loop
[reskk,-,inpkk] := tups_for_op(kk);
hypat := atom_with_meaning(["incs",inpjj,inpkk]); -- inclusion between inputs
concl_at := atom_with_meaning(["incs",reskk,resjj]); -- inclusion between outputs
set_of_disjunctions with:= [{concl_at},{hypat}];
end loop;
end if;
end special_mondn;
procedure decompose_in(formula,is_prop); -- recursive inner workhorse for formula decomposition
-- the 'is_prop' parameter is true if this routine
-- has been called from a propositional level, otherwise false.
-- we collect equality, inequality, membership, and nonmembership relationships at the set level,
-- and propositional pairs at the propositional level. The routine returns the name of the result generated.
if not is_tuple(formula) then return formula; end if; -- case of a bottom_level blob (just a name)
[op,x,y] := formula; -- break into parts
case (kind := abbreviated_headers(op))
when "and","or","imp","==","/==" => -- clauses for the boolean cases are collected below; --
-- those at the 'set' level are collected in the branches of this case statement
x := decompose_in(x,true); y := decompose_in(y,true); -- process the two propositional parts
when "not" => -- clauses for the boolean cases are collected below;
x := decompose_in(x,true); -- process the one propositional part
when "if" => -- decomposition of 'if' construct
-- here we deal with a construct of the form if a then b else c
-- we introduce a new name 'result' for the value of the construct; at the propositional level
-- we then convert the 'if' into the set of propositions a -> (result == b),
-- (not a) -> (result <-> c). At the non-propositional level we proceed similarly,
-- but generate equalities instead of propositional equivalences.
a := decompose_in(x,true); b := decompose_in(y,is_prop); c := decompose_in(formula(4),is_prop);
result := newat(); -- new name to represent result
if is_prop then -- decompose as in remark above
set_of_disjunctions +:= {[{b},{a,result}],[{result},{a,b}],[{a,c},{result}],[{a,result},{c}]};
return result;
else -- decompose into set of equalities
-- again we deal with a construct of the form if a then b else c
-- here we must introduce a new name 'n' for the value of the construct, and also
-- for each of the propositions b = n and c = n, etc.
-- That is, we generate a -> t1, where t1 <-> (n = b1) and a -> t2, where t2 <-> (n = c)
result := newat(); -- generate a new atom to represent the result-value of the 'if'
set_of_disjunctions +:= {[{t1 := newat()},{a}],[{t2 := newat(),a},{}]};
-- if a is true so must t1 be true, but if a is false t2 must be true
meaning_of_propsymbol(t1) := ["=",result,b]; meaning_of_propsymbol(t2) := ["=",result,c];
end if;
return result;
when "+", "-", "*" => -- these are the set-to-set operators
[-,t1,t2] := formula; -- break out the two argument subitems
t1n := decompose_in(t1,false); t2n := decompose_in(t2,false); -- process them separately, obtaining names
return atom_with_set_meaning([kind,t1n,t2n]); -- generate a name for the opn result, and put relationship on record
when "arb" => -- this is a set-to-set operator
[-,t1] := formula; -- break out the argument item
t1n := decompose_in(t1,false); -- process it obtaining a name
return atom_with_sp_set_meaning([kind,t1n]); -- generate a name for the opn result, and put relationship on record
when "#" => -- cardinality is a set-to-set operator
[-,t1] := formula; -- break out the argument item
t1n := decompose_in(t1,false); -- process it obtaining a name
return atom_with_sp_set_meaning([kind,t1n]); -- generate a name for the opn result, and put relationship on record
when "[-]" => -- this is a 2-sets-to-set operator
[-,t1,t2] := formula; -- should be a pair; break out the components
t1n := decompose_in(t1,false); -- process them separately, obtaining names
if t2 = OM then return result := newat(); end if; -- singleton is just argument list
t2n := decompose_in(t2,false); -- process second argument
return atom_with_sp_set_meaning([kind,t1n,t2n]); -- generate a name for the opn result, and put relationship on record
when "()" => -- functional application, involving function with special known properties
[-,fname,arglist] := formula; -- should be a pair; break out the components
arg_atms := [decompose_in(subt,false): subt in arglist(2..)]; -- process the arguments, obtaining representative toms
return atom_with_sp_set_meaning([fname] + arg_atms); -- generate a name for the opn result, and put relationship on record
when "{-}" => -- enumerated set
enum_membs := [atom_with_set_meaning([kind,decompose_in(tj,false)]): tj in formula(2..)]; -- break out and generate triples for the members of the argument list
result := enum_membs(1); -- now begin a chain of union operations
for j in [2..#enum_membs] loop
result := atom_with_set_meaning(["+",result,enum_membs(j)]);
end loop;
return result; -- processing finished in this case; we return the final sum (or the name of the unique singleton)
otherwise => -- these are the set-to-boolean comparison and relationship operators
-- namely "=", "\=", "incs", "incin", "in", "notin"
[-,t1,t2] := formula; -- break out the two argument subitems
t1n := decompose_in(t1,false); t2n := decompose_in(t2,false); -- process them, and return representative names for their set values
return atom_with_meaning([kind,t1n,t2n]); -- result of cons is input to car
end case; -- ******* here follows the treatment of propositional cases *******
z := newat( ); -- variable for result
set_of_disjunctions +:= case kind -- add the appropriate dsisjunctive cluase to the collection of disjuctions being built,
-- and return its representing atom
when "and" => {[{x},{z}],[{y},{z}],[{z},{x,y}]} -- [(not z) or x] & [(not z) or y] & [(not x or not y) or z]
when "or" => {[{z},{x}],[{z},{y}],[{x,y},{z}]} -- [(not x) or z] & [(not y) or z] & [(x or y) or not z]
when "imp" => {[{z},{y}],[{z,x},{ }],[{y},{z,x}]} -- [(not y) or z] & [x or z] & [y or ((not x) or (not z))]
when "==" => {[{y},{z,x}],[{x},{z,y}],[{z},{x,y}],[{z,x,y},{ }]} -- equivalence: [x or y or z] & [(not x) or (not y) or z] &
-- [y or ((not z) or (not x))] & [x or ((not z) or (not y))]
when "/==" => {[{x,y},{z}],[{},{x,y,z}],[{y,z},{x}],[{x,z},{y}]}
-- inequivalence: [x or y or (not z)] & [(not x) or (not y) or (not z)] &
-- [y or z or (not x)] & [x or z or (not y)]
when "not" => {[{z,x},{}],[{ },{x,z}]} -- x or z & (not x) or (not z)
end case;
return z; -- return the representing atom if the disjunction just constructed
end decompose_in;
procedure atom_with_meaning(tup); -- find or form an atom with the specified meaning
if (atm := atom_having_meaning(stup := str(tup))) /= OM then return atm; end if;
atom_having_meaning(stup) := atm := newat(); meaning_of_propsymbol with:= [atm,tup]; return atm;
end atom_with_meaning;
procedure atom_with_set_meaning(tup); -- find or for an atom with the specified set-value meaning
if (atm := atom_having_meaning(stup := str(tup))) /= OM then return atm; end if;
atom_having_meaning(stup) := atm := newat(); addnal_setrelns with:= [atm] + tup; return atm;
end atom_with_set_meaning;
procedure atom_with_sp_set_meaning(tup); -- find or for an atom with the specified set-value meaning
if (atm := atom_having_meaning(stup := str(tup))) /= OM then return atm; end if;
atom_having_meaning(stup) := atm := newat(); special_setrelns with:= [atm] + tup; return atm;
end atom_with_sp_set_meaning;
end decompose_post_blobbing;
-- **************************************************************************************************************
-- ********** Next follow the innermost satifiability testing routines of the present verifier, **********
-- ********** consisting of a modified Davis-Putnam propositional routine which triggers tests of **********
-- ********** collections of MLSS statements generated whenever a truth-value pattern satisfying the **********
-- ********** input set of clauses at the propositional level is found. **********
-- **************************************************************************************************************
procedure Davis_Putnam(clause_set,term_decider,td_prms); -- Extended Davis-Putnam procedure for verifying propositional consistency.
-- This routine is set up for use with a decision procedure for unquantified theories.
-- the 'term_decider' procedure should accept the truth_value map calculated by the
-- Davis-Putnam routine, along with the additional information contained in 'td_params'
-- and test the set of signed terms in its domain for consistency,
-- returning OM if these are not consistent, but a standard_form model if they are
-- consistent.
-- The clause_set is assumed to be a set of pairs, the first (resp. second) component of
-- each pair being a set of positive (resp. negative) terms.
-- Note that disjunctive normal form is assumed.
-- If term decider \= OM then clause_set is a tuple containing a set of clauses
-- of the structure described above, and term_decider expects a map of propositional atoms to truth values
-- and a pair [meaning_of_propsymbol,addnal_setrelns] as its two parameters. The inputs to this routine are therefore
-- the outputs [clause_set,meaning_of_propsymbol,addnal_setrelns] of the procedure decompose_blob.
-- OUTPUT: if term_decider = OM the output is truth_table: a map that maps each variable
-- into its true value, else the output of the corresponding term_decider (e.g. MLSS or other).
var td_params; -- globalize the decider parameters, for possible use in the workhorse below
td_params := td_prms; -- globalize the decider parameters, for possible use in the workhorse below
undefined_terms := { };
-- terms in the set of clauses which have not been assigned truth-values
num_undefined_terms := { }; -- maps each clause into its number of undefined terms
clauses_with_term_pos := { };
-- maps each term into the set of clauses containing the unnegated term
clauses_with_term_neg := { };
-- maps each term into the set of clauses containing the negated term
--truth_value := {["TRUE",true],["FALSE",false]}; -- maps each variable into its truth_value
truth_value := {};
singles := { }; -- clauses with only one term
one_sign := { }; -- terms appearing with only one sign
clause_set := {cl: cl in clause_set | (cl1 := cl(1)) * (cl2 := cl(2)) = { } and "TRUE" notin cl1 and "FALSE" notin cl2}; -- drop tautological clauses
clause_set := {[cl1 less "FALSE",cl2 less "TRUE"]: [cl1,cl2] in clause_set};
if [{},{}] in clause_set then return OM; end if; -- the original clause set contains a contradictort clause
for clause in clause_set loop
[clp,cln] := clause;
undefined_terms +:= (clp + cln); -- collect the terms of this clause
if (sum := #clp + #cln) = 1 then singles with:= clause; end if;
-- note the singleton clauses
num_undefined_terms(clause) := sum; -- record the total number of undefined terms in the clause
for variab in clp loop
clauses_with_term_pos with:= [variab,clause];
end loop;
for variab in cln loop
clauses_with_term_neg with:= [variab,clause];
end loop;
end loop;
one_sign := {term in (domain clauses_with_term_pos) + (domain clauses_with_term_neg) |
(#(clauses_with_term_pos{term}) = 0) or (#(clauses_with_term_neg{term}) = 0)};
--print("DP_in call: ",clause_set," ",singles," ",one_sign);
res := DP_in(clause_set,singles,one_sign, -- call the inner workhorse
undefined_terms,num_undefined_terms,clauses_with_term_pos,clauses_with_term_neg,
truth_value);
--print("truth_value_debug: ",truth_value_debug);
return res;
procedure DP_in(unsatisfied_clauses,singles,one_sign, -- inner workhorse of the Davis-Putnam procedure
undefined_terms,num_undefined_terms,clauses_with_term_pos,clauses_with_term_neg,
truth_value);
-- this procedure returns a satisfying model, if any can be found; otherwise OM.
while true loop -- START OF OUTERMOST SEARCH LOOP
while exists clause in singles | (clause in unsatisfied_clauses) loop -- get a clause with just one remaining term
singles less:= clause; -- remove this clause from singles
[clp,cln] := clause; -- get its positive and negative parts
if exists term in clp | truth_value(term) = OM then -- remaining term is positive
truth_value(term) := true; -- record its positivity
-- we will delete all clauses in which the term appears with the same sign.
cls := clauses_with_term_pos{term}; -- clauses in which term appears with same sign
clo := clauses_with_term_neg{term}; -- clauses in which term appears with opposite sign
elseif exists term in cln | truth_value(term) = OM then -- remaining term is negative
truth_value(term) := false; -- record its negativity
-- perform deletions and checks symmetric to those in the preceding case
cls := clauses_with_term_neg{term}; -- clauses in which term appears with same sign
clo := clauses_with_term_pos{term}; -- clauses in which term appears with opposite sign
end if;
for clause in cls loop -- delete these satisfied clauses by removing references to them
remove_clause(clause,unsatisfied_clauses,clauses_with_term_pos,clauses_with_term_neg,one_sign);
end loop;
-- those clauses in which it appears with the opposite sign lose one term;
-- if no terms remain,then we have a contradiction and return OM.
for clause in clo loop -- reduce by decrementing counts
if (nu := (num_undefined_terms(clause) -:= 1)) = 0 then return OM; end if; -- contradiction
if nu = 1 then singles with:= clause; end if; -- just one undefined remains in the clause, so it becomes a 'single'
end loop;
if (undefined_terms less:= term) = { } then -- truth values have been assigned to all propositional variables
--print("truth_value: ",truth_value);
if term_decider = OM then -- simple propositional case
return truth_value;
else -- propositional case connects to a lower-level decision algorithm
truth_value_debug := truth_value;
res := term_decider(truth_value,td_params); -- conjoin these with the identities
--print("term_decider returns::: ",res);
return res;
end if;
end if; -- finished
end loop; -- on exiting this loop there exist no more clauses with just one unremoved term
if term_decider = OM then -- simple propositional case; symbols with just one sign can be given the corresponding truth value
one_sign := {term: term in one_sign |truth_value(term) = OM}; -- terms not yet assigned
while exists term in one_sign | true loop
-- there is a term with only one sign in the remaining clauses;
-- assign this term the satisfying sign and remove all the clauses in which it appears
if (cls := clauses_with_term_pos{term}) /= { } then -- term is positive
truth_value(term) := true;
-- give the term the value 'true' if any unsatisfied clause requires this
elseif (cls := clauses_with_term_neg{term}) /= { } then -- term is negative
truth_value(term) := false; -- give the term the value 'false'
else
truth_value(term) := false; -- give the term the value 'false' anyhow by convention
end if;
for clause in cls loop
remove_clause(clause,unsatisfied_clauses,clauses_with_term_pos,clauses_with_term_neg,one_sign);
end loop;
one_sign less:= term; -- this term has been processed
if (undefined_terms less:= term) = { } then return truth_value; end if; -- finished
end loop; -- on exiting this loop there are no unsatisfied clauses with just one term,
-- and no single-sign term.
end if; -- end of special 'one-sign' processing for the purely propositional case
-- here our processing becomes nondeterministic
-- We select some term for which no truth value has as yet been assigned, assign its sign
-- arbitrarily as 'true', and pass this information down recursively,
-- recovering if our first guess was wrong.
term := arb undefined_terms; -- chose some undefined term, and try to give it a positive value
--->inspect_DP
--print("truth_value: ",truth_value,"td_params: ",td_params); stop;
if DP_branches_count = 0 and term_decider(truth_value,td_params) = OM then return OM; end if;
-- try for a 'fast answer', without additional resolution of cases
if (DP_branches_count +:= 1) > branches_limit then -- count and time used to suppress excess Davis_Putnam branching
DP_branches_count := 0;
if (secsnow := unstr(time()(7..8))) > DP_start_secs + seconds_limit or
(DP_start_secs > secsnow and (60 - DP_start_secs) + secsnow > seconds_limit) then
return "??????? Probably can't decide without excess work ??????? ";
end if;
-- print("trying. secsnow = ",secsnow); trying_count +:= 1;
-- if (trying_count = 1) then print("conjunct being tried: ",debug_conj2,"\nblobbed version is: ",unparse(formula_after_blobbing),
-- "\nversion after boil_down is: ",unparse(formula_after_boil_down));
-- end if;
end if; -- if (DP_branches_count
if (val_ret := DP_biased_pos(term,unsatisfied_clauses,singles,one_sign,undefined_terms,
num_undefined_terms,clauses_with_term_pos,clauses_with_term_neg,truth_value)) /= OM then
return val_ret;
else -- take the term to be negative and continue
if (DP_branches_count +:= 1) > branches_limit then -- count and time used to suppress excess Davis_Putnam branching
DP_branches_count := 0;
if (secsnow := unstr(time()(7..8))) > DP_start_secs + seconds_limit or
(DP_start_secs > secsnow and (60 - DP_start_secs) + secsnow > seconds_limit) then
return "??????? Probably can't decide without excess work ??????? ";
end if;
--print("trying. secsnow = ",secsnow);
end if;
truth_value(term) := false; -- record its negativity
cls := clauses_with_term_neg{term}; -- clauses in which term appears with same sign
clo := clauses_with_term_pos{term}; -- clauses in which term appears with opposite sign
for clause in cls loop -- delete these satisfied clauses by removing references to them
remove_clause(clause,unsatisfied_clauses,clauses_with_term_pos,clauses_with_term_neg,one_sign);
end loop;
-- those clauses in which it appears with the opposite sign lose one term;
-- if no terms remain, then we have a contradiction and return OM.
for clause in clo loop -- reduce by decrementing counts
if (nu := (num_undefined_terms(clause) -:= 1)) = 0 then return OM; end if; -- contradiction
if nu = 1 then singles with:= clause; end if;
end loop;
if (undefined_terms less:= term) = { } then
if term_decider = OM then -- simple propositional case
return truth_value;
else -- propositional case connects to a lower-level decision algorithm
--truth_value_debug := truth_value;
res := term_decider(truth_value,td_params); -- conjoin these with the identities
--print("term_decider returns: ",res);
return res;
end if;
end if; -- end if (undefined_terms less:= term) = { }
end if; -- end if (val_ret := DP_biased_pos(.....
end loop; -- END OF OUTERMOST SEARCH LOOP
procedure DP_biased_pos(term,unsatisfied_clauses,singles,one_sign,
undefined_terms,num_undefined_terms,clauses_with_term_pos,clauses_with_term_neg,
truth_value);
-- this 'recursion header' routine exists only to ease recovery from the changes it makes, if it fails
if term = OM then abort("stopping 4484"); stop; end if;
truth_value(term) := true; -- make the term positive
cls := clauses_with_term_pos{term}; -- clauses in which term appears with same sign
clo := clauses_with_term_neg{term}; -- clauses in which term appears with opposite sign
for clause in cls loop -- delete these satisfied clauses by removing references to them
remove_clause(clause,unsatisfied_clauses,clauses_with_term_pos,clauses_with_term_neg,one_sign);
end loop;
-- those clauses in which it appears with the opposite sign lose one term; if no terms remain,
-- then we have a contradiction and return OM.
for clause in clo loop -- reduce by decrementing counts
if (nu := (num_undefined_terms(clause) -:= 1)) = 0 then return OM; end if; -- contradiction
if nu = 1 then singles with:= clause; end if;
end loop;
if (undefined_terms less:= term) = { } then
if term_decider = OM then -- simple propositional case
return truth_value;
else -- propositional case connects to a lower-level decision algorithm
--truth_value_debug := truth_value;
res := term_decider(truth_value,td_params); -- conjoin these with the identities
--print("term_decider returns:: ",res);
return res;
end if;
end if; -- finished
return DP_in(unsatisfied_clauses,singles,one_sign, -- otherwise call the unbiased DP workhorse recursively
undefined_terms,num_undefined_terms,clauses_with_term_pos,clauses_with_term_neg,
truth_value);
end DP_biased_pos;
procedure remove_clause(clause,rw unsatisfied_clauses, -- used to remove a clause which has been satisfied
rw clauses_with_term_pos,rw clauses_with_term_neg,rw one_sign);
unsatisfied_clauses less:= clause; -- this clause has been satisfied
for member_term in clause(1) loop -- for all the positive terms of these clauses
if #(clauses_with_term_pos less:= [member_term,clause]) = 0 then
one_sign with:= member_term; -- only negative appearances can remain
end if;
end loop;
for member_term in clause(2) loop -- for all the negative terms of these clauses
if #(clauses_with_term_neg less:= [member_term,clause]) = 0 then
one_sign with:= member_term; -- only positive appearances can remain
end if;
end loop;
end remove_clause;
end DP_in;
end Davis_Putnam;
-- **************************************************************************************************************
-- ********** Next follows the tableau-based MLSS term-decider routine invoked by Davis-Putnam **********
-- **************************************************************************************************************
procedure mlss_decider(truth_value,td_params); -- tableau-based term decider for mlss
-- The first parameter of this routine is a map from propositional symbols to their true/false values.
-- The second parameter is a pair [meaning_of_propsymbol,addnal_setrelns], the first of which maps propositional symbols
-- to the set-theoretic relationships they represent. These have the form [op,arg1,arg2], where 'op'
-- can be any of "=", "\=", "in", "notin", "incs', and "incin". 'addnal_setrelns' is a collection of quadruples and triples
-- [name, op, arg1,arg2] and [name, op, arg], where 'op' can be any of "+","-","*", or (for tuples) "{-}".
-- the special constant "nullset" is also recognized.
-- The algorithm works with a collection of static and varying maps, which this routine prepares.
-- op_appearances_0, op_appearances_1, op_appearances_2 map each symbol designating a set into
-- the collection of all terms in which the symbol appears as result, first argument, or second argument
-- respectively. incs_appearances_1 and incs_appearances_2 map each sucn symbol into the collection of all
-- inclusion relationships in which the symbol appears as first or second argument respectively.
-- nincs_appearances_1 and nincs_appearances_2 do the same for negated inclusion relationships. For each
-- singleton relationships [s, "{-}", x], the map 'only_memb' maps s onto x, and 'singletons' is the domain
-- of 'only_memb'.
-- As this algorithm begins, the truth_value map is used to reverse each of the comparison operators
-- "=", "in" and "incs" to their negatives where appropriate. (The negative of "incs" is "nincs" )
-- "incin" occurrences are reduced to "incs" by reversing arguments. a /= b relationships are rewritten as
-- alternations (a nincs b) or (b nincs a). Equalities are removed by identifying variables known to be equal.
-- To search for a model of the remaining set of clauses, the algorithm works with several main sets used more
-- dynamically. 'pos_membs' and 'neg_membs' are sets of pairs [x,y], representing collections of variables
-- for which it has been concluded that x in y and x notin y respectively. unprocessed_membs is the set of all such
-- pairs from which not all subsidiary deductions have yet been derived. unresolved_alts is the set of all 2-way
-- disjunctions a or b which have not yet been resolved by exploring their two branches if this is necessary.
-- 'given_vars' is the collection of all set-valued variables initially appearing in 'addnal_setrelns' and in the range
-- of 'meaning_of_propsymbol'. As explained below, the algorithm may generate additional variables as it proceeds.
-- The working of the algorithm can best be understood by understanding the way n which it will build a model
-- of the set of statements with which it is working if one exists. This is done by examining the collection 'pos_membs'
-- of all membership relationships deduced, making sure that this has no cycles (which are impossible if a model exists),
-- assigning distinct sets of sufficently large cardinality to all the variables not in 'given_vars', and then processing
-- all the 'given_vars' in topologically sorted order if the memmbershi relation x in y, modeling each y as the collection
-- of all models associated with x for which a pair [x,y] is present in 'pos_membs'. Exploration fails immediately whenever
-- a pair in the intersection of 'pos_membs' and 'neg_membs' is detected.
-- For this model-building procedure to work, we must be sure that every statement 'a incs b', 'a nincs b', 'a = b + c', 'a = b * c',
-- 'a = b - c', and a = {b} is properly modeled. To this end, we make the following deductions:
-- 'x in a' is deduced whenever 'x in b' and 'a incs b' are present;
-- a new variable and statements 'x in b', 'x notin a' are set up whenever 'a nincs b' is present;
-- 'x in b' and 'x in c' and is deduced whenever 'x in a' and 'a = b * c' are present;
-- This ensures that in the model eventually constructed, M(a) is no larger than M(b) * M(c)
-- whenever the statement x in s has been deduced, and s in singletons, the statement x = only(s) is derived.
-- this equality is immediately removed by identifying the set variables x with only(s)
-- 'x in b and x notin c' is deduced whenever 'x in a' and 'a = b - c' are present;
-- This ensures that in the model eventually constructed, M(a) is no larger than M(b) * M(c)
-- if 'x in a' and 'y notin a' have both been deduced, we deduce an inequality 'x /= y', setting this up as an alternation
-- (x nincs y) or (y nincs x). It is only necessary to do this when both x and y belong to given_vars, since, as previously
-- explained, variable not in given_vars will always be assigned distinct sets as models.
-- 'x in a' is deduced whenever 'x in b' and 'a = b + c' are present;
-- 'x in a' is deduced whenever 'x in c' and 'a = b + c' are present;
-- These ensure that in the model eventually constructed, M(a) is no smaller than M(b) + M(c)
-- 'x in b or x in c' and is added to unresolved_alts whenever 'x in a' and 'a = b + c' are present.
-- This ensures that in the model eventually constructed, M(a) is no larger than M(b) + M(c)
-- 'x in a or x in c' and is added to unresolved_alts whenever 'x in b' and 'a = b - c' are present.
-- This ensures that in the model eventually constructed, M(a) is no smaller than M(b) - M(c)
-- 'x in a or x notin c' and is added to unresolved_alts whenever 'x in b' and 'a = b * c' are present.
-- This ensures that in the model eventually constructed, M(a) is no smaller than M(b) * M(c)
-- These rules would be sufficient, but to accelerate discovery of contradictions (which can cut off a branch
-- of exploration before multiple alternations need to be resolved, an exponentially expensive matter when necessary)
-- all possible deterministic deductions are made. These are:
-- 'x notin b' is deduced whenever 'x notin a' and 'a incs b' are present;
-- 'x notin a' is deduced whenever 'x notin b' and 'a = b * c' are present;
-- 'x notin a' is deduced whenever 'x notin c' and 'a = b * c' are present;
-- 'x notin a' is deduced whenever 'x notin b' and 'a = b - c' are present;
-- 'x notin a' is deduced whenever 'x in c' and 'a = b - c' are present;
-- We must also insist that singletons depend fumctionally on their unique element. Thus we deduce y = z from x in y and x in z
-- when y and z are both singletons
var pos_membs := {},neg_membs := {},pos_membs_inv := {},neg_membs_inv := {},unprocessed_membs := {}; -- used in inested subroutines below
all_equalities := {}; -- no variables have yet been identified
[meaning_of_propsymbol,addnal_setrelns] := td_params; -- unpack the two parmeters
meaning_of_propsymbol := {pair in meaning_of_propsymbol | truth_value(pair(1)) /= OM};
-- process only those propositions for which a truth value is supplied (this allows us to leave Davis_Putnam resolution incomplete)
is_contradiction := false; -- no contradiction yet
--print("mlss_decider addnal_setrelns: ",addnal_setrelns);
op_appearances_0 := {[quadruple(1),quadruple]: quadruple in addnal_setrelns | quadruple(2) in infix_set_ops}; -- infix_set_ops := {"+","-","*"};
op_appearances_1 := {[quadruple(3),quadruple]: quadruple in addnal_setrelns | quadruple(2) in infix_set_ops};
op_appearances_2 := {[quadruple(4),quadruple]: quadruple in addnal_setrelns | quadruple(2) in infix_set_ops};
only_memb := {[triple(1),triple(3)]: triple in addnal_setrelns | triple(2) = "{-}"}; -- the singleton case
singletons := domain(only_memb);
-- note all the variables which appear in the given set of clauses
given_vars := singletons + range(only_memb) + domain(op_appearances_0) + domain(op_appearances_1) + domain(op_appearances_2) + {"_nullset","0"};
--->inspect
--if (trues := {atom_stg(x): x in domain(truth_value) | truth_value(x) = true}) = satisfying_cases then
--debug_var := true; print("\nmeaning_of_propsymbol for: ",merge_sort([unstr(x): x in trues])," ",meaning_of_propsymbol); print("addnal_setrelns: ",addnal_setrelns); print("truth_value: ",truth_value,"op_appearances_1: ",op_appearances_1);
--else print("trues: ",merge_sort([unstr(x): x in trues])); if #trues > 12 then print("#trues: ",#trues); print("\nmeaning_of_propsymbol for: ",merge_sort([unstr(x): x in trues])," ",meaning_of_propsymbol); stop; end if;
--end if;
only_memb := {[triple(1),triple(3)]: triple in addnal_setrelns | triple(2) = "{-}"}; -- the singleton case
singletons := domain(only_memb);
for [sing,memb] in only_memb loop add_memb(memb,sing); end loop; -- note that x in {x} for every singleton
-- now analyze all the set-to-set comparisons given, reversing as necessary
initial_incs := initial_nics := initial_equalities := initial_inequalities := unresolved_alts := {};
neg_membs := incs_appearances_1 := incs_appearances_2 := {};
pos_membs := unprocessed_membs := {[y,x]: [x,y] in only_memb}; -- element of singleton belongs to it
for [symb,[reln,a,b]] in meaning_of_propsymbol loop
given_vars with:= a; given_vars with:= b; -- note the variables which appear in the given set of clauses
--if debug_var then print("[symb,[reln,a,b]]: ",[symb,[reln,a,b]]," ",truth_value(symb)); end if;
case if truth_value(symb)?true then reln else reverse_meaning(reln) end if -- convert the relation to its reverse if its truth value is 'false'
when "in" => add_memb(a,b); unprocessed_membs with:= [a,b]; maytrace(21); -- membership is known
when "notin" => add_nonmemb(a,b); unprocessed_membs with:= [a,b]; -- nonmembership is known
when "incs" => incs_appearances_1 with:= [a,[a,b]]; incs_appearances_2 with:= [b,[a,b]]; -- note inclusion
when "incin" => incs_appearances_1 with:= [b,[b,a]]; incs_appearances_2 with:= [a,[b,a]]; -- note inclusion, in reversed direction
when "=" => if a /= b then initial_equalities +:= {[a,b],[b,a]}; end if; -- note equality, to be digested immediately below
when "/=" => unresolved_alts with:= ["nincs",a,b]; -- set up two alternative non-inclusions
initial_inequalities with:= [a,b]; -- these are used only to deteect immediate contrdictions
when "nincs" => newvar := newat(); -- generate a new variable, and set up a membership and a nonmembership
add_memb(newvar,b); add_nonmemb(newvar,a); maytrace(22);
--if debug_var then print("nincs: ",newvar," ",a," ",b); end if;
when "nincin" => newvar := newat(); -- generate a new variable, and set up a membership and a nonmembership
add_memb(newvar,a); add_nonmemb(newvar,b); maytrace(23);
end case;
end loop;
for x in domain(pos_membs) | #(x_sings := pos_membs{x} * singletons) > 1 loop
initial_equalities +:= {[y,z]: y in x_sings, z in x_sings | y /= z}; -- force singletons with identical members to be identical
end loop;
--if debug_var then print("initial_equalities: ",initial_equalities," op_appearances_1:: ",op_appearances_1,"initial_inequalities: ",initial_inequalities," pos_membs = ",pos_membs," neg_membs = ",neg_membs); end if;
while initial_equalities /= {} loop -- reduce all the preceding data items using the available equalities
all_equalities +:= initial_equalities; -- accumulate all equalities in this set opf pairs, used in construction offinal model
reps := find_repmap(initial_equalities); -- find repmap for the set of equalities
initial_equalities := {}; -- sine thes have just been used
--if debug_var then print("reducing by map reps: ",reps," op_appearances_1 = ",op_appearances_1); end if;
op_appearances_0 := reduce_by_repmap(op_appearances_0,reps);
op_appearances_1 := reduce_by_repmap(op_appearances_1,reps);
op_appearances_2 := reduce_by_repmap(op_appearances_2,reps);
only_memb := reduce_by_repmap(only_memb,reps);
singletons := reduce_by_repmap(singletons,reps);
pos_membs := reduce_by_repmap(pos_membs,reps);
neg_membs := reduce_by_repmap(neg_membs,reps);
unprocessed_membs := reduce_by_repmap(unprocessed_membs,reps);
incs_appearances_1 := reduce_by_repmap(incs_appearances_1,reps);
incs_appearances_2 := reduce_by_repmap(incs_appearances_2,reps);
unresolved_alts := reduce_by_repmap(unresolved_alts,reps);
initial_inequalities := reduce_by_repmap(initial_inequalities,reps);
pos_membs_inv := {[y,x]: [x,y] in pos_membs}; neg_membs_inv := {[y,x]: [x,y] in neg_membs};
for x in singletons | #(sing_membs := pos_membs_inv{x}) > 1 loop
initial_equalities +:= {[y,z]: y in sing_membs, z in sing_membs | y /= z}; -- force equality between mebers of same singletons
end loop;
end loop;
if pos_membs * neg_membs /= {} then return OM; end if; -- we have an immediate contrdiction
if exists [x,y] in pos_membs | y = "_nullset" then return OM; end if; -- we have an immediate contrdiction
if exists [x,y] in initial_inequalities | x = y then return OM; end if; -- we have an immediate contrdiction
pos_membs_inv := {[y,x]: [x,y] in pos_membs}; neg_membs_inv := {[y,x]: [x,y] in neg_membs};
--print("pos_membs with singletons: ",pos_membs," singletons = ",singletons," neg_membs = ",neg_membs," neg_membs_inv = ",neg_membs_inv);
--print("incs_appearances_1: ",incs_appearances_1," incs_appearances_2 = ",incs_appearances_2);
--print("unprocessed_membs: ",unprocessed_membs,"unresolved_alts: ",unresolved_alts,"only_memb: ",only_memb);
--print("op_appearances_1: ",op_appearances_1);
-- we also keep the inverses of pos_membs and neg_membs
-- after the initializations seen above, start searching for a model
--if debug_var then print("\nfind_mlss_model: pos_membs = ",pos_membs," neg_membs = ",neg_membs," unresolved_alts = ",unresolved_alts," only_memb = ",only_memb," singletons = ",singletons," unprocessed_membs = ",unprocessed_membs," op_appearances_1 = ",op_appearances_1); end if;
--print("before find_mlss_model: ");
return find_mlss_model(op_appearances_0,op_appearances_1,op_appearances_2,
only_memb,pos_membs,neg_membs,pos_membs_inv,neg_membs_inv,unprocessed_membs,incs_appearances_1,incs_appearances_2,
unresolved_alts,singletons);
procedure add_memb(x,y); -- respond to the appearance of a new membership relation 'x in y'
--print("add_memb::: x = ",x," y = ",y," pos_membs = ",pos_membs," is_contradiction = ",is_contradiction," alredy_known = ",[x,y] in pos_membs); --if debug_was_shown then abort("where from???"); end if;
if is_contradiction or (xy := [x,y]) in pos_membs then return; end if; -- since things are hopeless, or this item has been seen before
if xy in neg_membs or y = "_nullset" or y = "0" then is_contradiction := true; return; end if; -- since we have detected a contradiction
pos_membs with:= xy; unprocessed_membs with:= xy; -- add the new membership relation, and note that it is unprocessed
pos_membs_inv with:= [y,x]; -- also note the inverse pair
end add_memb;
procedure add_nonmemb(x,y); -- respond to the appearance of a new nonmembership relation 'x notin y'
if is_contradiction or (xy := [x,y]) in neg_membs then return; end if; -- since things are hopeless, or this item has been seen before
if xy in pos_membs then is_contradiction := true; return; end if; -- since we have detected a contradiction
neg_membs with:= xy; unprocessed_membs with:= xy; -- add the new membership relation, and note that it is unprocessed
neg_membs_inv with:= [y,x]; -- also note the inverse pair
end add_nonmemb;
end mlss_decider;
procedure find_mlss_model(op_app_0,op_app_1,op_app_2, -- find a model of a predigestd set of mlss clauses
only_membr,pos_membrs,neg_membrs,pos_membrs_inv,neg_membrs_inv,unprocessed_membrs,incs_apps_1,incs_apps_2,unres_alts,singletns);
--if debug_handle = OM then debug_handle := open("debug_trace","TEXT-OUT"); end if;
--print(debug_handle,"\nfind_mlss_model: pos_membrs = ",pos_membrs," neg_membrs = ",neg_membrs," unres_alts = ",unres_alts," only_membr = ",only_membr," singletns = ",singletns," unprocessed_membrs = ",unprocessed_membrs," op_app_1 = ",op_app_1);
--if (debug_count +:= 1) >= 5 then stop; end if; print("debug_count: ",debug_count);
loop -- outer search loop, including examination of alternatives; process new membership relations as long as any exist
while unprocessed_membrs /= {} loop -- inner search loop, not including examination of alternatives; process new membership relations as long as any exist
new_mnm from unprocessed_membrs; -- select a membership of nonmembership relation whiose consequences have not yet been exploited fully
[x,y] := new_mnm;
if new_mnm in pos_membrs then deduce_from_pos_memb(x,y); else deduce_from_neg_memb(x,y); end if; -- make deterministic deductions and post alternatives
--if debug_var then print("after deduction from: ",new_mnm," is_positive = ",new_mnm in pos_membrs," is_contradiction = ",is_contradiction); end if;
if is_contradiction then return OM; end if; -- break off this search brach if a contradiction has been detected
end loop; -- end of inner search loop
-- on exit, there are no more deductions to be made from the known memberships/nonmemberships alone, so we search for
-- an alternation one of whose branches might be impossible, giving a new membership/nonmembership relation to work with
--->debugging here
alt_chosen := OM; -- no reasonable alternation has been chosen yet
orig_unresolved := unres_alts; -- to allow modification in the following loop
for alt in orig_unresolved loop -- look for an unsatisfied alternation to try; but prefer those with only one branch
[kind,a,b,x] := alt; -- examine its type; the alternation chosen can be a [nincs,nincs] pair, an [in,notin] pair, or an [in,in] pair
if kind = "in_in" then -- we have an 'x in a or x in b' alternation
if [x,a] in pos_membrs or [x,b] in pos_membrs then unres_alts less:= alt; continue; end if; -- since the alternation is already satisfied
if [x,a] in neg_membrs and [x,b] in neg_membrs then is_contradiction := true; return OM; end if; -- since the alternation is impossible
if [x,a] in neg_membrs then -- have just one alternative to try
add_memb(x,b); maytrace(1); -- set up the one possible membership relation
elseif [x,b] in neg_membrs then -- have just one alternation to try
add_memb(x,a); maytrace(2); -- set up the one possible membership relation
else -- there is a true alternation to try
alt_chosen := alt; -- note that the alternation can be explored
end if;
elseif kind = "in_nin" then -- we have an 'x in a or x notin b' alternation
if [x,a] in pos_membrs or [x,b] in neg_membrs then unres_alts less:= alt; continue; end if; -- since the alternation is already satisfied
if [x,a] in neg_membrs and [x,b] in pos_membrs then is_contradiction := true; return OM; end if; -- since the alternation is impossible
if [x,a] in neg_membrs then -- have just one alternative to try
add_nonmemb(x,b); -- set up the one possible membership relation
elseif [x,b] in pos_membrs then -- have just one alternation to try
add_memb(x,a); maytrace(3); -- set up the one possible membership relation
else -- there is a true alternation to try
alt_chosen := alt; -- note that the alternation can be explored
end if;
elseif kind = "nincs" then -- we have an 'a nincs b or b nincs a' alternation. we first see if either branch is already satisfied
--if debug_var then print("nincs: given_vars = ",given_vars); end if;
if a notin given_vars or b notin given_vars then continue; end if;
-- it is only necessary to force these inequalities if one of the variables involved is original rather than generated,
-- since all surviving generated variables will be always given unique models at the end
if neg_membrs_inv{a} * pos_membrs_inv{b} /= {} or pos_membrs_inv{a} * neg_membrs_inv{b} /= {} then unres_alts less:= alt; continue; end if;
alt_chosen := alt; -- note that the alternation can be explored
end if;
end loop; -- end of examination of alternations, to find one allowing only a single branch
--if debug_var then print("end of examination: alt_chosen = ",alt_chosen); print(" singletns = ",singletns," is_contradiction = ",is_contradiction); print("unprocessed_membrs = ",unprocessed_membrs," pos_membrs = ",pos_membrs," neg_membrs = ",neg_membrs," unres_alts = ",unres_alts); end if;
if is_contradiction then return OM; end if; -- break off this search branch if a contradiction has been detected
if unprocessed_membrs /= {} then continue; end if; -- at least one one_branch alternation was found; process the membership relation which they imply
sorted_membs := top_sort(pos_membrs); -- attempt to sort the membership relations topologically. This may detect a membership-cycle contradiction
if #sorted_membs < #(domain(pos_membrs) + range(pos_membrs)) then is_contradiction := true; return OM; end if; -- since there is a membership cycle
--print("*********** REACHED HERE 2 ***********",debug_count);
if alt_chosen = OM then -- no unprocessed alternation so there is a model, which we construct and return
--print("pos_membrs model: ",pos_membrs,"\nall_equalities: ",all_equalities,"\npos_membrs_inv = ",pos_membrs_inv,"\ngiven_vars = ",given_vars,"\nsorted_membs = ",sorted_membs);
res := build_model(pos_membrs_inv,given_vars,sorted_membs); -- the model is defined by the set of positive meberships found, and the set of given vars
return res;
end if; -- otherwise we must explore both branches of the selected alternation, nondeterministically
-- here an examination by cases can no longer be avoided......
[kind,a,b,x] := alt_chosen; unres_alts less:= alt_chosen; -- open the alternation which will now be resolved
save_equalities := all_equalities; -- save for possible backtracking in code below
if is_contradiction then return OM; end if;
--print("find_mlss_model recursions start: ",kind);
if kind = "in_in" then -- we have an 'x in a or x in b' alternation
if (modl := find_mlss_model_with_new([x,a],OM,op_app_0,op_app_1,op_app_2,only_membr, -- explore recursively to achieve backtracking
pos_membrs,neg_membrs,pos_membrs_inv,neg_membrs_inv,unprocessed_membrs,incs_apps_1,incs_apps_2,unres_alts,singletns)) /= OM then
--print("in_in first alt OK:");
return modl;
end if;
--print("in_in first alt fails:");
is_contradiction := false; all_equalities := save_equalities; -- to complete backtrcking of preceding operation
add_nonmemb(x,a); add_memb(x,b); maytrace(4); -- we can conclude that 'x in a' is impossible, so 'x in b' is certain
elseif kind = "in_nin" then -- we have an 'x in a or x notin b' alternation
if (modl := find_mlss_model_with_new([x,a],OM,op_app_0,op_app_1,op_app_2,only_membr, -- explore recursively to achieve backtracking
pos_membrs,neg_membrs,pos_membrs_inv,neg_membrs_inv,unprocessed_membrs,incs_apps_1,incs_apps_2,unres_alts,singletns)) /= OM then
--print("in_nin first alt OK:");
return modl;
end if;
--print("in_nin first alt fails:");
is_contradiction := false; all_equalities := save_equalities; -- to complete backtrcking of preceding operation
add_nonmemb(x,a); add_nonmemb(x,b); -- we can conclude that 'x in a' is impossible, so 'x notin b' is certain
elseif kind = "nincs" then -- we have an 'a nincs b or b nincs a' alternation
new_set := newat(); -- generate a new set
--print("before nincs first alt OK:");
if (modl := find_mlss_model_with_new([new_set,b],[new_set,a],op_app_0,op_app_1, -- explore recursively to achive backtracking
op_app_2,only_membr,pos_membrs,neg_membrs,pos_membrs_inv,neg_membrs_inv,unprocessed_membrs,
incs_apps_1,incs_apps_2,unres_alts,singletns)) /= OM then
--print("nincs first alt OK:");
return modl;
end if;
is_contradiction := false; all_equalities := save_equalities; -- to complete backtrcking of preceding operation
add_memb(new_set,a); add_nonmemb(new_set,b); maytrace(5);
--print("nincs first alt FAILS: try ",new_set," in ",a); print(" unprocessed_membrs = ",unprocessed_membrs," pos_membrs = ",pos_membrs," neg_membrs = ",neg_membrs," new_set = ",new_set," is_contradiction = ",is_contradiction);
-- we can conclude that 'new_set in b and new_set notin a' is impossible, so we must have 'new_set in a and new_set notin b'
end if;
end loop; -- end of outer search loop
procedure deduce_from_pos_memb(x,y); -- make all deductions from a positive membership relation 'x in y'
--print("deduce_from_pos_memb: ",x," ",y," ",y in singletns," unprocessed_membrs = ",unprocessed_membrs," op_app_1 = ",op_app_1); -- first the definite deductions
for [a,y] in incs_apps_2{y} loop add_memb(x,a); maytrace(7); end loop; -- 'x in a' is deduced whenever 'x in y' and 'a incs y' are present;
for [a,op,b,y] in op_app_2{y} | op = "-" loop add_nonmemb(x,a); end loop; -- 'x notin a' is deduced whenever 'x in y' and 'a = b - y' are present;
for [a,op,y,c] in op_app_1{y} | op = "+" loop maytrace(8); add_memb(x,a); end loop; -- 'x in a' is deduced whenever 'x in y' and 'a = y + c' are present;
for [a,op,b,y] in op_app_2{y} | op = "+" loop maytrace(9); add_memb(x,a); end loop; -- 'x in a' is deduced whenever 'x in c' and 'a = b + c' are present;
for [y,op,b,c] in op_app_0{y} | op = "*" loop add_memb(x,b); add_memb(x,c); maytrace(10); end loop;
-- 'x in b' and 'x in c' is deduced whenever 'x in y' and 'y = b * c' are present;
for [y,op,b,c] in op_app_0{y} | op = "-" loop add_memb(x,b); add_nonmemb(x,c); maytrace(11); end loop;
-- 'x in b' and 'x notin c' and is deduced whenever 'x in y' and 'y = b - c' are present;
if y in singletns then -- whenever the statement x in y has been deduced, and y in singletons, the statement x = only(y) is derived.
repmap := {eq_pair := if x = "_nullset" then [only_membr(y),x] else [x,only_membr(y)] end if};
-- this equality is immediately removed by identifying the set variables x with only(y)
all_equalities with:= eq_pair; -- note for later use in model build
op_app_0 := reduce_by_repmap(op_app_0,repmap);
op_app_1 := reduce_by_repmap(op_app_1,repmap);
op_app_2 := reduce_by_repmap(op_app_2,repmap);
only_membr := reduce_by_repmap(only_membr,repmap);
singletns := reduce_by_repmap(singletns,repmap);
pos_membrs := reduce_by_repmap(pos_membrs,repmap);
neg_membrs := reduce_by_repmap(neg_membrs,repmap);
unprocessed_membrs := reduce_by_repmap(unprocessed_membrs,repmap);
incs_apps_1 := reduce_by_repmap(incs_apps_1,repmap);
incs_apps_2 := reduce_by_repmap(incs_apps_2,repmap);
unres_alts := reduce_by_repmap(unres_alts,repmap);
--print("reducing by: ",repmap," only_membr = ",only_membr," pos_membrs = ",pos_membrs," neg_membrs = ",neg_membrs);
if pos_membrs * neg_membrs /= {} then is_contradiction := true; return OM; end if; -- we have an immediate contrdiction
if exists [k,x,y] in unres_alts | k = "nincs" and x = y then return OM; end if; -- we have an immediate contradiction
pos_membrs_inv := {[y,x]: [x,y] in pos_membrs}; neg_membrs_inv := {[y,x]: [x,y] in neg_membrs};
if pos_membrs_inv{"_nullset"} + pos_membrs_inv{"_nullset"} /= {} then is_contradiction := true; return OM; end if;
end if;
for [x,y] in pos_membrs loop -- we reprocess the set of all pos_membrs, which may have been changes by the preceding equlaity-reductionx
-- we must also insist on various alternations
for [y,op,b,c] in op_app_0{y} | op = "+" loop unres_alts with:= ["in_in",b,c,x]; end loop;
-- 'x in b' or 'x in c' is added (e.g. to unres_alts) whenever 'x in y' and 'y = b + c' are present;
-- now the necessary alternations
for [a,op,y,c] in op_app_1{y} | op = "-" loop unres_alts with:= ["in_in",a,c,x]; end loop;
-- 'x in a or x in c' and is added to unres_alts whenever 'x in y' and 'a = y - c' are present.
-- now the necessary alternations
for [a,op,y,c] in op_app_1{y} | op = "*" loop unres_alts with:= ["in_nin",a,c,x]; end loop;
-- 'x in a or x notin c' and is added to unres_alts whenever 'x in y' and 'a = y * c' are present.
--print("deduce_unres_alts: ",x," ",y," ,unres_alts = ",unres_alts," pos_membrs = ",pos_membrs," neg_membrs = ",neg_membrs," op_app_1 = ",op_app_1);
for z in neg_membrs_inv{y} loop unres_alts with:= ["nincs",x,z]; end loop;
-- if 'x in y' and 'z notin y' have both been deduced, we deduce an inequality 'x /= z', setting this up as an alternation
-- (x nincs y) or (y nincs x). But is only necessary to analyze this alternation when both x and y belong to given_vars,
-- since, as previously explained, variables not in given_vars will always be assigned distinct sets as models.
end loop;
end deduce_from_pos_memb;
procedure deduce_from_neg_memb(x,y); -- make all deductions from a positive membership relation 'x notin y'
--if debug_var then print("deduce_from_neg_memb: ",x," ",y," incs_apps_1{y} = ",incs_apps_1{y}," op_app_1{y} = ",op_app_1{y}," op_app_2{y} = ",op_app_2{y}); end if;
if y in singletns then unres_alts with:= ["nincs",x,only_memb(y)]; end if;
for [y,b] in incs_apps_1{y} loop add_nonmemb(x,b); end loop; -- 'x notin b' is deduced whenever 'x notin y' and 'y incs b' are present;
for [a,op,y,c] in op_app_1{y} | op = "*" loop add_nonmemb(x,a); end loop; -- 'x notin a' is deduced whenever 'x notin y' and 'a = y * c' are present;
for [a,op,b,y] in op_app_2{y} | op = "*" loop add_nonmemb(x,a); end loop; -- 'x notin a' is deduced whenever 'x notin y' and 'a = b * y' are present;
for [a,op,y,c] in op_app_1{y} | op = "-" loop add_nonmemb(x,a); end loop; -- 'x notin a' is deduced whenever 'x notin y' and 'a = y - c' are present;
end deduce_from_neg_memb;
procedure add_memb(x,y); -- respond to the appearance of a new membership relation 'x in y'
--print("add_memb: x = ",x," y = ",y," is_contradiction = ",is_contradiction," alredy_known = "," pos_membrs = ",pos_membrs); --if debug_was_shown then abort("where from???"); end if;
if is_contradiction or (xy := [x,y]) in pos_membrs then return; end if; -- since things are hopeless, or this item has been seen before
if xy in neg_membrs or y = "_nullset" or y = "0" then is_contradiction := true; return; end if; -- since we have detected a contradiction
pos_membrs +:= (sxy := {xy});
unprocessed_membrs +:= sxy; -- add the new membership relation, and note that it is unprocessed
pos_membrs_inv +:= {[y,x]}; -- also note the inverse pair
-- pos_membrs with:= xy; unprocessed_membrs with:= xy; -- add the new membership relation, and note that it is unprocessed
-- pos_membrs_inv with:= [y,x]; -- also note the inverse pair
end add_memb;
procedure add_nonmemb(x,y); -- respond to the appearance of a new nonmembership relation 'x notin y'
--if debug_var then print("add_nonmemb: ",x," ",y); end if;
if is_contradiction or (xy := [x,y]) in neg_membrs then return; end if; -- since things are hopeless, or this item has been seen before
if xy in pos_membrs then is_contradiction := true; return; end if; -- since we have detected a contradiction
neg_membrs with:= xy; unprocessed_membrs with:= xy; -- add the new membership relation, and note that it is unprocessed
neg_membrs_inv with:= [y,x]; -- also note the inverse pair
end add_nonmemb;
end find_mlss_model;
procedure find_mlss_model_with_new(new_pos_cl,new_neg_cl,op_app_0,op_app_1,op_app_2, -- variant of find_mlss_model; processes 1 or 2 new clauses at very start
only_membr,pos_membrs,neg_membrs,pos_membrs_inv,neg_membrs_inv,unprocessed_membrs,incs_apps_1,incs_apps_2,unres_alts,singletns);
--print("find_mlss_model_with_new: ",new_pos_cl,new_neg_cl,is_contradiction," unres_alts = ",unres_alts);
[x,y] := new_pos_cl; add_memb(x,y); maytrace(20); -- take note of the new positive clause
if new_neg_cl /= OM then [x,y] := new_neg_cl; add_nonmemb(x,y); end if; -- take note of the new negative clause, if any
if is_contradiction then return OM; end if;
--print("before call: ");
return find_mlss_model(op_app_0,op_app_1,op_app_2, --call the unmodified routine
only_membr,pos_membrs,neg_membrs,pos_membrs_inv,neg_membrs_inv,unprocessed_membrs,incs_apps_1,incs_apps_2,unres_alts,singletns);
procedure add_memb(x,y); -- respond to the appearance of a new membership relation 'x in y'; variant local to this routine
--print("add_memb:: ",x," ",y," ",is_contradiction," pos_membrs = ",pos_membrs," ",neg_membrs," ",unprocessed_membrs," ",pos_membrs_inv);
if is_contradiction or (xy := [x,y]) in pos_membrs then return; end if; -- since things are hopeless, or this item has been seen before
if xy in neg_membrs or y = "_nullset" or y = "0" then is_contradiction := true; return; end if; -- since we have detected a contradiction
--print("add_memba:: ",pos_membrs," ",xy); --return OM;
pos_membrs +:= (sxy := {xy});
unprocessed_membrs +:= sxy; -- add the new membership relation, and note that it is unprocessed
pos_membrs_inv +:= {[y,x]}; -- also note the inverse pair
-- pos_membrs with:= xy; -- Bugbugbug??
--print("add_membbb:: ",pos_membrs," ",xy); return OM;
-- unprocessed_membrs with:= xy; -- add the new membership relation, and note that it is unprocessed
-- pos_membrs_inv with:= [y,x]; -- also note the inverse pair
end add_memb;
procedure add_nonmemb(x,y); -- respond to the appearance of a new nonmembership relation 'x notin y'; variant local to this routine
--print("add_nonmemb:: ",x," ",y," ",is_contradiction," ",neg_membrs," ",pos_membrs);
if is_contradiction or (xy := [x,y]) in neg_membrs then return; end if; -- since things are hopeless, or this item has been seen before
if xy in pos_membrs then is_contradiction := true; return; end if; -- since we have detected a contradiction
neg_membrs with:= xy; unprocessed_membrs with:= xy; -- add the new membership relation, and note that it is unprocessed
neg_membrs_inv with:= [y,x]; -- also note the inverse pair
end add_nonmemb;
end find_mlss_model_with_new;
procedure maytrace(n); if debug_trace_details or debug_was_shown then print("maytrace: ",n); end if; end maytrace;
-- procedure atom_stg(x); stg := str(x); match(stg,""); return stg; end atom_stg; -- converts atom to string
procedure find_repmap(equalities); -- find repmap for a set of equalities. We wuse a very crude method, since not many are expected
repmap := {[x,{x}]: x in domain(equalities)};
for [x,y] in equalities loop
together := repmap(x) + repmap(y); for z in together loop repmap(z) := together; end loop;
end loop;
rep := {[s,if "_nullset" in s or "0" in s then "_nullset" else arb({x in s | is_string(x)})?arb(s) end if]: s in range(repmap)};
return {[x,rep(y)]: [x,y] in repmap};
end find_repmap;
procedure reduce_by_repmap(items,repmap); -- reduce a set of tuples using a repmap
return if is_set(items) then {reduce_by_repmap(x,repmap): x in items}
elseif is_tuple(items) then [reduce_by_repmap(x,repmap): x in items] else repmap(items)?items end if;
end reduce_by_repmap;
-- ************ analysis of formulae for monotonicity ************
procedure post_monotone(op_and_arg_string); -- note the monotonicity property of one or more function symbols
-- this adds information concerning the monotonicity properties of an operator to the map 'monotonicity_props'
-- for use by 'blob_to_monotone'. The parameter is a string of the form op_name,dep_1,...,dep_n,
-- where each dep is either '+' (increasing), '++' (additive), '-' (decreasing), '0' (mixed)
-- these are stored in the map as 1,2,-1,0 respectively. Multiple semicolon-separated declarations ofthis kind can be supplied
op_and_arg_tups := breakup(breakup(op_and_arg_string,";"),",");
for op_and_arg_tup in op_and_arg_tups loop
op := case_change(op_and_arg_tup(1),"lu");
arg_qual := [if x = "+" then 1 elseif x = "++" then 2 elseif x = "-" then -1 else 0 end if: x in op_and_arg_tup(2..)];
monotonicity_props(op) := arg_qual;
end loop;
print("monotonicity_props: ",monotonicity_props);
end post_monotone;
procedure drop_monotone(ops); -- drop the monotonicity property of one or more function symbols
for op in breakup(ops,",") loop monotonicity_props(case_change(op,"lu")) := OM; end loop; -- drop if present
end drop_monotone;
-- ************ auxiliary routine for standardizing chains of associative operators ************
procedure flatten_same_ops(node); -- get the chain of all identical infix operations starting at a given node at which this operation appears,
-- and moving to the left, since constructions like a + b + c are implicitly parenthesized as (a + b) + c
[op,n2,n3] := node; -- we start with an infix operator
flattened := node;
while (not is_string(n2)) and n2(1) = op loop flattened(2..2) := n2(2..); n2 := n2(2); end loop; -- walk to left, collecting arguments
return flattened;
end flatten_same_ops;
-- ************ routines which handle 'algebraic' deduction ************
procedure enable_algebra(operator_list,context); -- enables elementary algebraic deduction for elements of a set and operators on it
const required_theorems := ["(FORALL x in U | (FORALL y in U | x + y in U))", -- closure axiom
"(FORALL x in U | (FORALL y in U | x * y in U))", -- closure axiom
"(FORALL x in U | (FORALL y in U | x - y in U))", -- closure axiom
"(FORALL x in U | (FORALL y in U | x + y = y + x))", -- commutative law
"(FORALL x in U | (FORALL y in U | x * y = y * x))", -- commutative law
"(FORALL x in U | (FORALL y in U | (FORALL z in U | (x + y) + z = x + (y + z)))", -- associative law
"(FORALL x in U | (FORALL y in U | (FORALL z in U | (x * y) * z = x * (y * z)))", -- associative law
"(FORALL x in U | (FORALL y in U | (FORALL z in U | (x + y) * z = (x * z) + (y * z))))", -- distributive law
"(FORALL x in U | x + 0 = x)", -- additive identity
"(FORALL x in U | (FORALL y in U | x + (y - x) = y))", -- subtraction
"(FORALL x in U | 0 - x = -x)" -- additive inverse
];
const more_required_theorems := ["(FORALL x in U | x * 1 = x)"];
[ring,plus_op,times_op,minus_op,zero,one] := operator_list; -- unpack the ring operators and objects
all_required_theorems := if one = OM then required_theorems else required_theorems + more_required_theorems end if;
replacement_map := {["U",ring],["+",plus_op],["*",times_op],["-",minus_op],["0",zero],["1",one?"1"]};
--for thm in required_theorems loop print(replace_symbols(thm,replacement_map)); end loop;
-- ****************** NOTE THAT the following check has been disabled temporarily ******************
-- if true or (exists thm in required_theorems | model_blobbed(blob_tree(parze_expr(reqthm := replace_symbols(thm,replacement_map)))) /= OM) then
-- return "******* Required theorem " + reqthm + " not verifiable from list of theorems supplied.";
-- end if;
OK_for_algebra with:= [if x(1) = "•" then "DOT_" + x(2..) else x end if: x in operator_list];
-- enter appropriately modified tuple into set of tuples OK_for_algebra
print("\n******* Enabling algebraic deduction for ",operator_list);
return OM; -- indciating success
end enable_algebra;
procedure replace_symbols(stg,replacement_map); -- replace specified letters by corresponding range elements
return "" +/ [replacement_map(piece)?piece: piece in segregate(stg,"" +/ domain(replacement_map))];
end replace_symbols;
procedure algebra(formula,context); -- handles elementary algebraic deduction
-- this handles elementary algebraic deduction, in several forms. It applies when a set and a list of operators have been
-- 'registered' for elementary algebraic deduction using the 'enable_algebra' procedure seen above. After applying the necessary checks,
-- this puts a tuple of the form [set_of_objects,sum_op,times_op,minus_op,zero_value, (and possibly) unit_value] on record in the global set
-- 'OK_for_algebra'. formulae submitted to this primitive can then have one of two forms: unquantified equalities or membership statements.
-- In an equality we find the topmost operator on either the left or right side, and locate it in one of the registered tuples. This identifies the
-- algebraic theory to be applied. The formula is then blobbed by reducing all subtrees not headed by operators in the appropriate set
-- to blobbed names. The context is then checked to verify that statements of the form 'subformula_blobbed in relevant_set' are
-- available by ELEM deduction for all the subformulae being blobbed. If this check is passed the blobbed formula is checked by a simple
-- algebraic decision algorithm to verify the equality asserted.
-- Membership statements must assert membership in the set of objects associated with the topmost operator if the expression on the left
-- of the membership relator,and are checked in a manner resembling that just explained.
-- OM is returned if the deduction succeeds; otherwise a diagnostic string indicating the nature of the failure is returned.
[main_op,a1,a2] := formula; -- unpack the formula
if main_op = "ast_eq" then -- we are dealing with an assertion of equality
top_op_left := if is_string(a1) then a1 else a1(1) end if; -- get the top operator of the left-hand expression
top_op_right := if is_string(a2) then a2 else a2(1) end if; -- get the top operator of the right-hand expression
tup_left := if exists tup in OK_for_algebra | top_op_left in tup then tup else OM end if;
-- find the algebraic operator sets to which these operators belong
tup_right := if exists tup in OK_for_algebra | top_op_right in tup then tup else OM end if;
if tup_left = tup_right then -- if these operator sets are the same, the theory to be used is unambiguous
if tup_left = OM then return "***** No known algebraic operators found; algebraic reasoning not applicable"; end if;
-- return string indicating error
return blob_and_check(a1,a2,tup_left,context); -- perform blob_and_check test in the common theory
elseif tup_left /= OM then -- first try the left-hand theory; and if this doesn't work the right hand theory if possible
if tup_right /= OM then return blob_and_check(a1,a2,tup_left,context); end if;
return blob_and_check(a1,a2,tup_left,context)?blob_and_check(a1,a2,tup_right,context);
else -- try the right hand theory
return blob_and_check(a1,a2,tup_right,context); -- perform blob_and_check test in the right hand theory
end if;
elseif main_op = "ast_in" then -- we are dealing with a membership assertion
top_op_left := if is_string(a1) then a1 else a1(1) end if; -- get the topmost operation on the left-hand side
tup_left := if exists tup in OK_for_algebra | top_op_left in tup then tup else OM end if;
if tup_left = OM then
return "***** No known algebraic operators found on left sise of membership relation; algebraic reasoning not applicable";
end if;
else
return "***** algebraic reasoning not applicable to principal operator of formula";
end if;
procedure blob_and_check(a1,a2,op_obj_tup,context); -- perform blob_and_check test in specified theory
[blobbed_formula_left,blobs_map_left] := algebra_blob(a1,op_obj_tup); -- blob the left_hand formula
[blobbed_formula_right,blobs_map_right] := algebra_blob(a2,op_obj_tup); -- blob the right_hand formula
if exists [-,blb_tree] in blobs_map_left | not check_member(blb_tree,univ := op_obj_tup(1),context) then
return "***** FAILURE: Left-hand membership relation " + unparse(["ast_in",blb_tree,univ]) + " not sucessfully derived in context of algebraic deduction";
end if;
if exists [-,blb_tree] in blobs_map_right | not check_member(blb_tree,op_obj_tup(1),context) then
return "***** FAILURE:Right-hand membership relation " + unparse(["ast_in",blb_tree,univ]) + " not sucessfully derived in context of algebraic deduction";
end if; -- otherwise all the preconditions for attempting an algebraic deduction are met
[vars_left,blobbed_formula_left] := standardize_formula(blobbed_formula_left,op_obj_tup);
[vars_right,blobbed_formula_right] := standardize_formula(blobbed_formula_right,op_obj_tup);
if not check_zero_value(["-",blobbed_formula_left,blobbed_formula_right],vars_left + vars_right) then
return "***** FAILURE: Polynomial expression fails value check";
end if;
return OM; -- indicating successful verification
end blob_and_check;
end algebra;
procedure check_member(blob_tree,alg_objects_set,context);
-- checks to see if a subformula can be seen to be a member of alg_objects_set in the given context
-- the context is suppiled as a single formula, presumably a conjuction, from which an "ELEM" deduction is to be made
formula := ["ast_and",["ast_not",["ast_in",blob_tree,alg_objects_set]],context];
--print("formula: ",formula);
return model_blobbed(formula) = OM;
end check_member;
procedure standardize_formula(poly_tree,op_obj_tup); -- standardizes a polynomial tree belonging to a specified algebraic theory
-- returns [set_of_variables,standardized_formula]
var ring,plus_op,times_op,minus_op,zero,one; -- the quantities defining the ring in which we are working
var set_of_variables := {}; -- will be collected by recursive workhorse
[ring,plus_op,times_op,minus_op,zero,one] := op_obj_tup; -- unpack the ring operators and objects
standardized_formula := standardize_formula_in(poly_tree); -- call the recursive workhorse
return [set_of_variables,standardized_formula];
procedure standardize_formula_in(poly_tree); -- recursive workhorse
if is_string(poly_tree) then -- check for the '0' and '1' cases
if poly_tree = zero then return "0"; end if;
if poly_tree = one then return "1"; end if;
set_of_variables with:= poly_tree; return poly_tree; -- collect and return the variable
end if;
[op,arg1,arg2] := poly_tree; -- unpack the formula
op := if op = plus_op then "+" elseif op = times_op then "*" else "-" end if;
return if arg2 = OM then [op,standardize_formula_in(arg1)] else [op,standardize_formula_in(arg1),standardize_formula_in(arg2)] end if;
end standardize_formula_in;
end standardize_formula;
-- ************ substitution routines: replace free variables in a formula by specified expression ************
--->working substitute
procedure substitute(tree,substitution_map);
-- makes substitutions for specified free variables of a formula. (main entry; uses workhorse)
--print("substitute: ",tree);
res := substitute_in(tree,substitution_map,{});
-- call the workhorse with an initially null list of bound variables
--print(res);
return res;
end substitute;
procedure substitute_in(tree,substitution_map,bound_vars); -- inner recursive workhorse of substitution routine
if is_string(tree) then -- we have a free or bound variable
if tree notin bound_vars then return substitution_map(tree)?tree; end if;
-- replace bottom-level names as specified
return tree; -- bound variables are unchanged
end if;
case abbreviated_headers(n1 := tree(1))?n1 -- handle quantifiers and setformers in a special way,to detect bound variables
when "itr","Etr" => -- iteration; first collect the bound variable
-- a syntactic example is: ["ast_iter_list", ["ast_in", "X", "S"], ["DOT_INCIN", "Y", "T"]].
-- we collect the bound variables and then substitute in the constraint sets.
--print("substitute_in itr: ",tree," ",unparse(tree)," ",bound_vars);
bound_vars +:= if is_string(t2 := tree(2)) then {t2} else
{if is_tuple(the_itr) then the_itr(2) else the_itr end if: the_itr in tree(2..)} end if;
-- collect the bound variables
bound_vars_global := bound_vars; -- globalize the bound variables, for use following the iterator
-- now this can conclude in the normal manner, seen below
when "{}" => -- setformer; first collect the bound variable
-- a syntactic example is: {e(x,y): x in s, y •incin t | P(x,y)} parses to ["ast_genset", ["ast_of", "E", ["ast_list", "X", "Y"]],
-- ["ast_iter_list", ["ast_in", "X", "S"], ["DOT_INCIN", "Y", "T"]], ["ast_of", "P", ["ast_list", "X", "Y"]]]
-- we simplify each of the three parts, reassemble them,and pass the result to 'simplify_setformer' for further processing
[n1,n2,n3,n4] := tree; -- unpack the parts of the syntaxnode
n3 := substitute_in(n3,substitution_map,bound_vars); -- here, the iterator comes in the third position
bound_vars := bound_vars_global; -- capture the expanded set of globals produced by processing the iterator
n2 := substitute_in(n2,substitution_map,bound_vars); -- make substitutions in sub-parts
n4 := substitute_in(n4,substitution_map,bound_vars);
return [n1,n2,n3,n4];
when "EX","ALL","{/}" => -- quantifiers; also setformer, no exp;
-- we simplify each of the two parts, reassemble them,and pass the result to 'simplify_setformer' for further processing
[n1,n2,n3] := tree; -- unpack the parts of the syntaxnode
n2 := substitute_in(n2,substitution_map,bound_vars);
bound_vars := bound_vars_global; -- capture the expanded set of globals produced by processing the iterator
n3 := substitute_in(n3,substitution_map,bound_vars); -- make substitutions in sub-part
return [n1,n2,n3];
end case;
return [tree(1)] + [substitute_in(x,substitution_map,bound_vars): x in tree(2..)];
end substitute_in;
-- ************ simplification of setformers (these routines are invoked by the 'SIMPLF' hint) ************
procedure simplify_setformer(tree); -- removes specified membership iterators over setformer expressions
-- this operation acts on setformers like {e(x): x in {f(y): y in t | Q(y)},... | P(x)} and {e(x): x in {f(y): y •incin t | Q(y)},... | P(x)},
-- replacing them with {e(f(y)): y in t,... | P(f(y)) and Q(y)} and {e(f(y)): y •incin t,... | P(f(y)) and Q(y)} respectively.
-- it also handles the corresponding existentials and expression-free setformers
-- (Added Oct. 2002): Cases like {e(x): x in {y} | P(x)} involving singleton ranges are also handled, and reduced to
-- if P(y) then e(x) else {} end if
-- we first find all the variables in the tree to be processed (these names must be avoided as bound variables are exposed), and
-- find all the iterators that have the correct form. Then (in the examples shown above),
-- we substitute f for all the occurences of x in parts 1 and 3 of the setformer,
-- and replace the iterator by the list of iterators in the set-epression over which iteration extends,
-- remembering to issue new names while doing this, to avoid possible name conflicts.
if is_string(tree) then return tree; end if;
[n1,n2,n3] := tree;
-- simplify {x: x in s} and {x: x in s | true} to s
if n1 = "ast_genset_noexp" and n3 = "TRUE" and #n2 = 2 and n2(2)(1) = "ast_in" then
return n2(2)(3);
end if;
if n1 = "ast_genset" and ((n4 := tree(4)) = ["ast_null"] or n4 = "TRUE") and #n3 = 2 and n3(2)(1) = "ast_in" and n3(2)(2) = n2 then
return n3(2)(3);
end if;
all_vars := find_all_vars(tree); -- find all the current variables in the tree being processed; these must be avoided
case (abh := abbreviated_headers(n1))
when "{}" => -- the formula to be standardized is a setformer with expression
--print("tree::: ",tree);
expn := n2; iters := new_iters := n3; cond := simplify_setformer(tree(4)); -- simplify the condition part
all_vars +:= find_all_vars(cond); -- allow for appearance of additional variables in the simplified condition part
-- get setformer expression and iterator list. note that 'iters' starts with 'itr' or 'Etr'
-- note that we make a copy of the iterator list,
-- to allow for a change of length as it is processed into its new form
iterator_indices := []; -- we will collect the indices of the iterators that can be simplified
iterator_list_len := #iters; -- processing in the loop below may change this
for iter = iters(j) | (abbreviated_headers(iter(1)) = "in") -- find the membership iterators over a setformer or singleton
and ((range_kind := abbreviated_headers((iter_range := iter(3))(1))) = "{}"
or range_kind = "{/}" or (range_kind = "{-}" and #iter_range = 2)) loop
iterator_indices with:= j;
-- use only the iterator indices of valid form. Note that only these are numbered
-- and that the header of the iterator list is bypassed
end loop;
--print("simplify_setformer: ",iterator_indices);
if iterator_indices = [] then return tree; end if; -- no simplification found
collect_conds := []; substitution_map := {};
-- we collect the condition clauses and the substitution_map from the qualifying iterators
for iter = iters(ix) | ix > 1 loop -- loop over the qualifying positions, getting the range-set nodes
[it_tag,it_var,iter_range_set] := iter; -- get the iterator range to be processed
if ix notin iterator_indices then -- the limit set is not a setformer, so just substitute in it
new_iters(ixn := ix + #new_iters - iterator_list_len..ixn) := [[it_tag,it_var,substitute(iter_range_set,substitution_map)]];
continue; -- done with this case
end if;
bound_vars_of_range := find_bound_vars(iter_range_set);
-- find the bound variables in the limiting setformer expression for this position
bound_var_subst := {};
for v in bound_vars_of_range loop -- build substitution map which assigns new names to all bound variables
bound_var_subst(v) := newn := new_name(v,all_vars); all_vars with:= newn;
end loop;
--print("simplify_setformer: ",ix," iter_range_set: ",iter_range_set," iters ",iters);
--print("bound_vars_of_range: ",bound_vars_of_range," all_vars: ",all_vars," bound_var_subst: ",bound_var_subst);
if (abhead := abbreviated_headers(iter_range_set(1))) = "{-}" then -- the iterator range-set must be a singleton
sing_memb := iter_range_set(2); -- get the singleton member, and substitute it for the corresponding bound variable
-- replace all the bound variables in the singleton member with generated new variables
sing_memb := substitute(sing_memb,bound_var_subst); -- do the same for the range_expn
substitution_map(iter(2)) := sing_memb; -- note the substitution to be made for the outer bound variable of the iterator
new_iters(ixn := ix + #new_iters - iterator_list_len..ixn) := []; -- delete the iterator in this position
--print("singleton: ",iter_range_set," ",substitution_map);
elseif abhead = "{}" then -- the iterator range-set must be a standard setformer; find its parts;
-- note that range_cond may be null
[-,range_expn,range_iters,range_cond] := iter_range_set;
range_iters := [substitute(ri,bound_var_subst): ri in range_iters];
-- replace all the bound variables in the range_iters with generated new variables
range_expn := substitute(range_expn,bound_var_subst); -- do the same for the range_expn
range_cond := substitute(range_cond,bound_var_subst); -- do the same for the range_cond
collect_conds with:= range_cond; -- collect the modified condition
substitution_map(iter(2)) := range_expn; -- note the substitution to be made for the outer bound variable of the iterator
--print("range_iters: ",range_iters); print("collect_conds: ",collect_conds); print("substitution_map: ",substitution_map);
new_iters(ixn := ix + #new_iters - iterator_list_len..ixn) := range_iters(2..);
--print("new_iters:: ",new_iters," ",range_iters(2..));
else -- "{/}" the iterator range-set is a setformer with no expn; find its parts
[-,range_iters,range_cond] := iter_range_set;
range_iters := [substitute(ri,bound_var_subst): ri in range_iters];
-- replace all the bound variables in the range_iters with generated new variables
range_expn := substitute(range_iters(2)(2),bound_var_subst); -- do the same for the range_expn and the range_cond
range_cond := substitute(range_cond,bound_var_subst); -- do the same for the range_expn and the range_cond
collect_conds with:= range_cond; -- collect the modified condition
substitution_map(iter(2)) := range_expn; -- note the substitution to be made for the outer bound variable of the iterator
--print("no expn: ",iter(2)," ",range_iters(2)(2));
new_iters(ixn := ix + #new_iters - iterator_list_len..ixn) := range_iters(2..);
end if;
--print("range_iters: ",range_iters); print("range_cond: ",range_cond); print("substitution_map: ",substitution_map);
end loop;
new_expn := substitute(expn,substitution_map); -- replace all the affected bound variables in the expression part
--print("omit the initial null condition: ",cond," ",collect_conds);
if cond = ["ast_null"] and collect_conds /= [] then -- omit the initial null condition
new_cond_from_main := collect_conds(1); collect_conds := collect_conds(2..);
else -- start with the substituted inital condition
new_cond_from_main := substitute(cond,substitution_map); -- replace all the affected bound variables in the condition part
end if;
-- build a new condition by appending all the conditions collected from the digested sets to the new_cond_from_main
for cond in collect_conds | abbreviated_headers(cond(1)) /= "null" loop new_cond_from_main := ["ast_and",new_cond_from_main,cond]; end loop;
-- now replace the iterator by the list drawn from the range set
--print("new_expn: ",[n1,new_expn,new_iters,new_cond_from_main]);
if #new_iters = 1 then return if new_cond_from_main = ["ast_null"] then ["ast_enum_set",new_expn]
else ["ast_if_expr",new_cond_from_main,["ast_enum_set",new_expn],"0"] end if; end if;
-- completely degenerate setformer reduces to a conditional expression or a singleton
return [n1,new_expn,new_iters,new_cond_from_main]; -- return the composite result
when "{/}" => -- the formula to be simplified is a setformer, no exp; note that iterator is simple
iters := orig_iters := new_iters := n2; cond := simplify_setformer(n3); -- simplify the condition part
-- note that we make a copy of the iterator list,
-- to allow for a change of length as it is processed into its new form
all_vars +:= find_all_vars(cond); -- allow for appearance of additional variables in the simplified condition part
iterator_indices := []; -- will collect the iterators that can be simplified
iterator_list_len := #iters; -- processing in the loop below may change this
for iter = iters(j) | abbreviated_headers(iter(1)) = "in"
and ((range_kind := abbreviated_headers((iter_range := iter(3))(1))) = "{}"
or range_kind = "{/}" or (range_kind = "{-}" and #iter_range = 2) ) loop
iterator_indices with:= j; -- use only the iterator indices of valid form
end loop;
if iterator_indices = [] then return tree; end if; -- no simplification found
collect_conds := []; substitution_map := {};
-- we collect the condition clauses and the substitution_map from the qualifying iterators
iterator_list_len := #iters; -- processing in the loop below may cchange this
for iter = iters(ix) | ix > 1 loop -- loop over the qualifying positions, getting the range-set nodes
[it_tag,it_var,iter_range_set] := iter; -- get the iterator range to be processed
if ix notin iterator_indices then -- the limit set is not a setformer, so just substitute in it
new_iters(ixn := ix + #new_iters - iterator_list_len..ixn) := [[it_tag,it_var,substitute(iter_range_set,substitution_map)]];
continue; -- done with this case
end if;
bound_vars_of_range := find_bound_vars(iter_range_set);
bound_var_subst := {};
for v in bound_vars_of_range loop bound_var_subst(v) := newn := new_name(v,all_vars); all_vars with:= newn; end loop;
if (abhead := abbreviated_headers(iter_range_set(1))) = "{-}" then -- the iterator range-set must be a singleton
sing_memb := iter_range_set(2); -- get the singleton member, and substitute it for the corresponding bound variable
-- replace all the bound variables in the singleton member with generated new variables
sing_memb := substitute(sing_memb,bound_var_subst); -- do the same for the range_expn
substitution_map(iter(2)) := sing_memb; -- note the substitution to be made for the outer bound variable of the iterator
new_iters(ixn := ix + #new_iters - iterator_list_len..ixn) := []; -- delete the iterator in this position
elseif abhead = "{}" then -- the iterator range-set must be a standard setformer; find its parts;
-- note that range_cond may be null
[-,range_expn,range_iters,range_cond] := iter_range_set;
range_iters := [substitute(ri,bound_var_subst): ri in range_iters];
-- replace all the bound variables in the range_iters with generated new variables
new_iters(ix..ix) := range_iters(2..);
range_expn := substitute(range_expn,bound_var_subst); -- do the same for the range_expn
range_cond := substitute(range_cond,bound_var_subst); -- do the same for the range_expn
collect_conds with:= range_cond; -- collect the modified condition
substitution_map(iter(2)) := range_expn; -- note the substitution to be made for the outer bound variable of the iterator
new_n1 := "ast_genset";
new_iters(ixn := ix + #new_iters - iterator_list_len..ixn) := range_iters(2..);
new_expn := substitute(orig_iters(2)(2),substitution_map);
-- replace all the affected bound variables in the nominal expression part
if cond = ["ast_null"] and collect_conds /= [] then -- omit the initial null condition
new_cond_from_main := collect_conds(1); collect_conds := collect_conds(2..);
else -- start with the substituted inital condition
new_cond_from_main := substitute(cond,substitution_map); -- replace all the affected bound variables in the condition part
end if;
-- build a new condition by appending all the conditions collected from the digested sets to the new_cond_from_main
for cond in collect_conds | abbreviated_headers(cond(1)) /= "null" loop new_cond_from_main := ["ast_and",new_cond_from_main,cond]; end loop;
-- now replace the iterator by the list drawn from the range set
if #new_iters = 1 then return ["ast_if_expr",new_cond_from_main,["ast_enum_set",new_expn],"0"]; end if;
-- completely degenerate setformer reduces to a conditional expression
return [new_n1,new_expn,new_iters,new_cond_from_main]; -- return the composite result
else -- "{/}" the iterator range-set must be a setformer with no expn; find its parts
[-,range_iters,range_cond] := iter_range_set;
range_iters := [substitute(ri,bound_var_subst): ri in range_iters];
-- replace all the bound variables in the range_iters with generated new variables
new_iters(ixn := ix + #new_iters - iterator_list_len..ixn) := range_iters(2..);
range_expn := substitute(range_iters(2)(2),bound_var_subst); -- do the same for the range_expn and the range_cond
range_cond := substitute(range_cond,bound_var_subst); -- do the same for the range_expn and the range_cond
collect_conds with:= range_cond; -- collect the modified condition
substitution_map(iter(2)) := range_expn;
-- note the substitution to be made for the outer bound variable of the iterator
end if;
if cond = ["ast_null"] and collect_conds /= [] then -- omit the initial null condition
new_cond_from_main := collect_conds(1); collect_conds := collect_conds(2..);
else -- start with the substituted inital condition
new_cond_from_main := substitute(cond,substitution_map); -- replace all the affected bound variables in the condition part
end if;
-- build a new condition by appending all the conditions collected from the digested sets to the new_cond_from_main
for cond in collect_conds | abbreviated_headers(cond(1)) /= "null" loop new_cond_from_main := ["ast_and",new_cond_from_main,cond]; end loop;
-- now replace the iterator by the list drawn from the range set
if #new_iters = 1 then return ["ast_if_expr",new_cond_from_main,["ast_enum_set",sing_memb],"0"]; end if;
return [n1,new_iters,new_cond_from_main]; -- return the composite result
end loop;
when "EX","ALL" => -- case of existential, universal
iters := orig_iters := new_iters := n2; cond := simplify_setformer(n3);
-- get the list of iterators and the condition part of the quantifier; simplify the condition part
all_vars +:= find_all_vars(cond); -- allow for appearance of additional variables in the simplified condition part
-- note that we make a copy of the iterator list,
-- to allow for a change of length as it is processed into its new form
iterator_indices := []; -- will collect the iterators that can be simplified
iterator_list_len := #iters; -- processing in the loop below may cchange this
for iter = iters(j) | abbreviated_headers(iter(1)) = "in"
and ((range_kind := abbreviated_headers((iter_range := iter(3))(1))) = "{}"
or range_kind = "{/}" or (range_kind = "{-}" and #iter_range = 2) ) loop
iterator_indices with:= j;
-- use only the iterator indices of valid form
end loop;
if iterator_indices = [] then return tree; end if; -- no simplification found
iterator_list_len := #iters; -- processing in the loop below may change this
collect_conds := []; substitution_map := {};
-- we collect the condition clauses and the substitution_map from the qualifying iterators
for iter = iters(ix) | ix > 1 loop -- loop over the qualifying positions, getting the range-set nodes
[it_tag,it_var,iter_range_set] := iter; -- get the iterator range to be processed
if ix notin iterator_indices then -- the limit set is not a setformer, so just substitute in it
new_iters(ixn := ix + #new_iters - iterator_list_len..ixn) := [[it_tag,it_var,substitute(iter_range_set,substitution_map)]];
continue; -- done with this case
end if;
bound_vars_of_range := find_bound_vars(iter_range_set);
bound_var_subst := {};
for v in bound_vars_of_range loop bound_var_subst(v) := newn := new_name(v,all_vars); all_vars with:= newn; end loop;
if (abhead := abbreviated_headers(iter_range_set(1))) = "{-}" then -- the iterator range-set must be a singleton
sing_memb := iter_range_set(2); -- get the singleton member, and substitute it for the corresponding bound variable
-- replace all the bound variables in the singleton member with generated new variables
sing_memb := substitute(sing_memb,bound_var_subst); -- do the same for the range_expn
substitution_map(iter(2)) := sing_memb; -- note the substitution to be made for the outer bound variable of the iterator
new_iters(ixn := ix + #new_iters - iterator_list_len..ixn) := []; -- delete the iterator in this position
elseif abbreviated_headers(iter_range_set(1)) = "{}" then
-- standard setformer; find its parts; note that range_cond may be null
[-,range_expn,range_iters,range_cond] := iter_range_set;
range_iters := [substitute(ri,bound_var_subst): ri in range_iters];
-- replace all the bound variables in the range_iters with generated new variables
-- now replace the iterator by the list drawn from the range set
new_iters(ixn := ix + #new_iters - iterator_list_len..ixn) := range_iters(2..);
range_expn := substitute(range_expn,bound_var_subst); -- do the same for the range_expn and the range_cond
range_cond := substitute(range_cond,bound_var_subst); -- do the same for the range_expn and the range_cond
collect_conds with:= range_cond; -- collect the modified condition
substitution_map(iter(2)) := range_expn;
-- note the substitution to be made for the outer bound variable of the iterator
else -- "{/}", i.e. setformer with no expn; find its parts
[-,range_iters,range_cond] := iter_range_set;
range_iters := [substitute(ri,bound_var_subst): ri in range_iters];
-- replace all the bound variables in the range_iters with generated new variables
-- now replace the iterator by the list drawn from the range set
new_iters(ixn := ix + #new_iters - iterator_list_len..ixn) := range_iters(2..);
range_expn := substitute(range_iters(2)(2),bound_var_subst); -- do the same for the range_expn and the range_cond
range_cond := substitute(range_cond,bound_var_subst); -- do the same for the range_expn and the range_cond
collect_conds with:= range_cond; -- collect the modified condition
substitution_map(iter(2)) := range_expn;
-- note the substitution to be made for the outer bound variable of the iterator
end if;
--print("collect_conds: ",collect_conds);
collect_conds := [x: x in collect_conds | is_tuple(x) and x /= [] and x(1) /= "ast_null"];
new_cond_from_main := substitute(cond,substitution_map);
-- replace all the affected bound variables in the condition part
if abh = "EX" then -- existential case
-- build a new condition by appending the conjunction of
-- all the conditions collected from the digested sets
-- to the substituted initial condition
for cond in collect_conds loop
new_cond_from_main := ["ast_and",new_cond_from_main,cond];
end loop;
elseif (hyp := collect_conds(1)) /= OM then -- universal case
-- build a new condition by forming the conjunction of
-- all the conditions collected from the digested sets
-- and insisting that this imply the new_cond_from_main
for cond in collect_conds(2..) | abbreviated_headers(cond(1)) /= "null" loop
hyp := ["ast_and",hyp,cond];
end loop;
new_cond_from_main := ["DOT_IMP",hyp,new_cond_from_main];
end if;
end loop;
if #new_iters = 1 then return new_cond_from_main; end if;
return [n1,new_iters,new_cond_from_main]; -- return the composite result
otherwise => return tree;
end case;
end simplify_setformer;
-- ************ equality inference routines (these routines are invoked by the 'EQUAL' hint) ************
procedure verify_equality(tree1,tree2,context,is_pred); -- verifies equality or equivalence of two formulae (main entry)
bvar_name_ctr := 0; -- initialize the counter used for bound variable name generation
diffs_vars_ranges := [];
return verify_equality_in(tree1,tree2,[],context,is_pred); -- call the recursive workhorse.
-- note that the bound variables list starts as empty. The final parameter indicates
-- whether we begin at the expression or at the predicate level.
-- The following issue must be faced in the design of this routine, which examines the differences between two trees
-- in an attempt to find clauses in the 'context' supplied which implies that these two expressions or predicates
-- are identical. Suppose, for example, that we have two set expressions of the form {f(f(x)): x in s} and
-- {f(x): x in s}, in a context in which the function f is known to be idempotent: (FORALL x in s | f(f(x)) = f(x)),
-- implying that these two expressions are equal. The minimal (bottom-level) difference between the two set
-- expressions is that of x vs. f(x). This suggests that the clause (FORALL x in s | f(x) = x) be sought in the
-- context in which the equality of the two set expressions is to be proved. But, in the context considered,
-- no such clause will be found, because the relevant difference is not that of x vs. f(x), but that of
-- f(x) vs. f(f(x)), which lies one level higher in the syntax tree. This shows that we must be prepared to examine
-- differences at all corresponding syntactic positions in the two trees, and to exploit those covered by clauses
-- in the context available.
-- This issue is handled as follows. We descend the two syntax trees in parallel, as long as their structures
-- correspond. Bound variables are collected as we descend recursively. Where structural correspondence between the
-- two trees fails, we form a clause asserting that the two differing expressions or predicates found are identical.
-- This clause is universally quantified by the sequence of bound variables collected up to this point, but with
-- elimination of all irrelevant quantifiers, ie. those which affect no variable free within them. If the clause
-- constructed in this way follows by ELEM reasoning from other clauses available in the context given, we return 'true';
-- otherwise 'false'. When 'false' is returned the same check is repeated at the preceding (i.e. next higher)
-- level in the syntax tree.
end verify_equality;
-- procedure verify_equality_in(tree1,tree2,bound_vars_with_ranges,context,is_pred); -- for debugging
-- res := verify_equality_inn(tree1,tree2,bound_vars_with_ranges,context,is_pred);
-- print("result is: ",res);
-- return res;
-- end verify_equality_in;
procedure verify_equality_in(tree1,tree2,bound_vars_with_ranges,context,is_pred);
-- verifies equality or equivalence of two formulae (workhorse)
--print("verify_equality_in: ",unparse(tree1)," ",unparse(tree2)," bound_vars_with_ranges = ",bound_vars_with_ranges," context = ",unparse(context)," is_pred = ",is_pred);
if check_in_context([if is_pred then "DOT_EQ" else "ast_eq" end if,tree1,tree2],bound_vars_with_ranges,context) then return true; end if;
-- begin by direct attempt to establish by ELEM means
-- tree1 := standardize_bound_vars(tree1); tree2 := standardize_bound_vars(tree2); -- standrdize the bound variables in both frmulae
if is_string(tree1) or is_string(tree2) then -- a variable confronts a subexpression
if tree1 = tree2 then return true; end if; -- no difference in bottom-level leaves; just return
--print("check_in_context: ",tree1," ",tree2," ",check_in_context(["ast_eq",tree1,tree2],bound_vars_with_ranges,context));
return false;
end if; -- otherwise two subexpressions confront each other
[n1_1,n2_1,n3_1] := tree1; [n1_2,n2_2,n3_2] := tree2; -- get the likely parts of the two clauses
if n1_1 = n1_2 then -- the nodes are of the same kind, so go on to look for differences in their arguments
case (ah := abbreviated_headers(tree1(1)))
when "and","or","==","/==","imp","null" => -- boolean operations
-- ordinary operators with a fixed number of arguments; look for differences in their arguments
if (res_1 := verify_equality_in(n2_1,n2_2,bound_vars_with_ranges,context,true)) and -- subparts are predicates
(res_2 := verify_equality_in(n3_1,n3_2,bound_vars_with_ranges,context,true))
then -- the differences are found to be equal at a lower level, so
return true;
end if;
return false;
when "+","-","{.}","in","notin","=","/=","incs","incin","*","[-]" =>
-- ordinary operators with a fixed number of arguments; look for differences in their arguments
-- ast_enum_tup should be ordered pair only; singleton for application operator is handled elsewhere
--print("[n1_1,n2_1,n3_1]: ",[n1_1,n2_1,n3_1]," ",[n1_2,n2_2,n3_2]);
if (res_1 := verify_equality_in(n2_1,n2_2,bound_vars_with_ranges,context,false)) and -- subparts are expressions
(res_2 := verify_equality_in(n3_1,n3_2,bound_vars_with_ranges,context,false))
then -- the differences are found to be equal at a lower level, so
return true;
end if; -- otherwise check for a relevant cluse at this level
--print("ah: ",ah," ",res_1," ",res_2);
return false;
when "->" => -- "->" is the functional application operator "TILDE_"
if verify_equality_in(n2_1,n2_2,bound_vars_with_ranges,context,false) and -- subparts are expressions
verify_equality_in(n3_1(2),n3_2(2),bound_vars_with_ranges,context,false) -- syntax is ["TILDE_", "F", ["ast_enum_tup", "X"]]
then -- the differences are found to be equal at a lower level, so
return true;
end if; -- otherwise check for a relevant clause at this level
return false;
when "not" =>
if verify_equality_in(n2_1,n2_2,bound_vars_with_ranges,context,true) then return true; end if; -- subparts are predicates
return check_in_context(["DOT_EQ",tree1,tree2],bound_vars_with_ranges,context);
when "[]" => -- ast_list
print("****** shouldnt happen - verify_equality_in: ",ah);
when "{-}" => -- enumerated sets. here we try to improve the agreement by sorting the elements
if #(args1 := tree1(2..)) /= #(args2 := tree2(2..)) then -- the nodes differ in their number of arguments; treat as different
check_in_context(["DOT_EQ",tree1,tree2],bound_vars_with_ranges,context);
end if; -- otherwise blob the elements and sort them to bring into the order most likely to agree
args1_with_blobs := [[blob_to_string(a1,[],name_ctr),a1]: a1 in args1]; -- we leave out the bound variables, since these will be common to both sets
args2_with_blobs := [[blob_to_string(a2,[],name_ctr),a2]: a2 in args2];
args1_sorted := [y: [x,y] in merge_sort(args1_with_blobs)];
args2_sorted := [y: [x,y] in merge_sort(args2_with_blobs)];
--print("args1_with_blobs: ",args1_sorted," ",args2_sorted);stop;
-- otherwise look for differences in their arguments
if true and/ [verify_equality_in(sn,args2_sorted(j),bound_vars_with_ranges,context,false): sn = args1_sorted(j)] then return true; end if;
-- if the sorted oreder doesn't work, try the original order
if true and/ [verify_equality_in(sn,args2(j),bound_vars_with_ranges,context,false): sn = args1(j)] then return true; end if;
-- if neither works, try a direct check
return false;
when "()" => -- this is the case of functional and predicate application; the second variable is a reserved symbol, not a set
--print("function trees: ",tree1," ",tree2);
if n2_1 /= n2_2 or #n3_1 /= #n3_2 then -- the function or predicate symbols differ, or have different numbers of arguments
return check_in_context([if is_pred then "DOT_EQ" else "ast_eq" end if,tree1,tree2],bound_vars_with_ranges,context);
end if;
args1 := n3_1(2..); args2 := n3_2(2..); -- get the lists of arguments, which follow and initial "ast_list"
if forall sn = args1(j) | verify_equality_in(sn,args2(j),bound_vars_with_ranges,context,false) then return true; end if;
-- examine differences in the arguments
-- if argument examination is not decisive, try check at this level
return check_in_context([if is_pred then "DOT_EQ" else "ast_eq" end if,tree1,tree2],bound_vars_with_ranges,context);
-- otherwise try direct verification
when "{}" => -- setformer with expression; here there is a fourth argument,
-- namely the predicate (this may be "ast_null", represetnting 'true')
-- here we are attempting to establish the equality of two setformers having structures
-- like {e1(x,y,z): x in s1, y in t1(x), z in w1(x,y) | A(x,y,z)}.
-- if the iterator lists which appear are of the same length and have corresponding structures throughout, then the condition required
-- may simply be (FORALL x in s1, y in t1(x), z in w1(x,y) | A1(x,y,z) •imp e1(x,y,z) = e2(x,y,z)), concatenated with
-- the condition (FORALL x in s1, y in t1(x), z in w1(x,y) | A1(x,y,z) •eq A1(x,y,z)) and with conditions which imply the equality
-- of the two sets of iterator restrictions. An alternative possibility is to use identities like
-- {e1(x,y,z): x in s1, y in t1(x), z in w1(x,y)} = {a: x in s1, a in {e1(x,y,z): y in t1(x), z in w1(x,y)}}
-- to shorten the prefixed sequences of quantifiers. This gives conditions like
-- (FORALL x in s1 | {e1(x,y,z): y in t1(x), z in w1(x,y)} = {e2(x,y,z): y in t2(x), z in w2(x,y)}),
-- again concatenated with conditions imply the equality of the two prefixed sequences of quantifiers.
-- This same transformation can be used if the iterator lists which appear in the setformers are of differing lengths
-- or have corresponding structure only in part, but not throughout.
body_1 := n2_1; body_2 := n2_2; -- get the two expressions being accumulated
list_of_iters_1 := orig_list_of_iters_1 := n3_1(2..); list_of_iters_2 := orig_list_of_iters_2 := n3_2(2..); -- get the two lists of iterators
cond_1 := tree1(4); cond_2 := tree2(4); -- get the two conditions
if cond_1 = ["ast_null"] then cond_1 := "TRUE"; end if; -- replace empty conditions with "TRUE"
if cond_2 = ["ast_null"] then cond_2 := "TRUE"; end if;
-- artificially pack the bodies and conds togther, just for the call to common_iter_len (which statndardizes the bound variables)
[cl,list_of_iters_1,list_of_iters_2,bc_1,bc_2] := common_iter_len(list_of_iters_1,list_of_iters_2,["ast_eq",body_1,cond_1],["ast_eq",body_2,cond_2]);
[-,body_1,cond_1] := bc_1; [-,body_2,cond_2] := bc_2; -- now separate out the artificially packed bodies and conds
--print("body_1: body_1 = ",body_1,"\nbody_2 = ",body_2,"\nlist_of_iters_1 = ",list_of_iters_1,"\nlist_of_iters_2 = ",list_of_iters_2,"\ncond_1 = ",cond_1,"\ncond_2 = ",cond_2);
if cl = #list_of_iters_1 and cl = #list_of_iters_2 then -- the iterators agree out to their full lengths; look for differences in bodies
if not verify_equality_in(body_1,body_2,bound_vars_with_ranges + list_of_iters_1,context,false) then -- the bodies are not identical
return false; -- verification by examination of subparts succeeds
end if; -- otherwise we must check to see if the iterator lists are equivalent
if not verify_equality_in(cond_1,cond_2,bound_vars_with_ranges + list_of_iters_1,context,true) then -- the conditions are not identical
return false; -- verification by examination of subparts succeeds
end if; -- otherwise we must check to see if the iterator lists are equivalent
succeeds := true; -- see if the following loop succeeds
--print("body_1,body_2:: ",body_1," ",body_2," ",list_of_iters_1," ",list_of_iters_2);
for k in [1..cl] loop
[-,-,restr_set_1] := list_of_iters_1(k); [-,-,restr_set_2] := list_of_iters_2(k); -- get the restriction sets
--print("restr_set_1,restr_set_2:: ",restr_set_1," ",restr_set_2," ",bound_vars_with_ranges + list_of_iters_1(1..k - 1)," ",context);
if not verify_equality_in(restr_set_1,restr_set_2,bound_vars_with_ranges + list_of_iters_1(1..k - 1),context,false) then
succeeds := false; exit;
end if;
end loop;
if succeeds then return true; end if; -- otherwise not all of the restriction sets are eqivalent, so we
-- go on to see if identity can be verified 'directly' in some way
for j in [1..cl] loop
if j = cl then -- there are no suffixed qualifiers
required_implication := ["ast_forall",["ast_iter_list"] + orig_list_of_iters_1,["DOT_EQ",cond_1,cond_2]];
required_identity := ["ast_forall",["ast_iter_list"] + orig_list_of_iters_1,["ast_eq",body_1,body_2]];
if not check_in_context(required_implication,bound_vars_with_ranges,context) then continue; end if;
if not check_in_context(required_identity,bound_vars_with_ranges,context) then continue; end if;
succeeds := true; -- see if the following loop succeeds
for k in [1..cl] loop
[-,-,restr_set_1] := list_of_iters_1(k); [-,-,restr_set_2] := list_of_iters_2(k); -- get the restriction sets
if not verify_equality_in(restr_set_1,restr_set_2,bound_vars_with_ranges + list_of_iters_1(1..k - 1),context,false) then
succeeds := false; exit;
end if;
end loop;
if succeeds then return true; end if; -- otherwise keep looing to try to find a verification
else -- there are suffixed qualifiers; use these in setformers
set_1 := ["ast_genset",body_1,["ast_iter_list"] + orig_list_of_iters_1(j + 1..),cond_1];
set_2 := ["ast_genset",body_2,["ast_iter_list"] + orig_list_of_iters_2(j + 1..),cond_2];
required_identity := ["ast_forall",["ast_iter_list"] + orig_list_of_iters_1(1..j),["ast_eq",set_1,set_2]];
if not check_in_context(required_identity,bound_vars_with_ranges,context) then continue; end if;
succeeds := true; -- see if the following loop succeeds
for k in [1..j] loop
[-,-,restr_set_1] := list_of_iters_1(k); [-,-,restr_set_2] := list_of_iters_2(k); -- get the restriction sets
if not verify_equality_in(restr_set_1,restr_set_2,bound_vars_with_ranges + list_of_iters_1(1..k - 1),context,false) then
succeeds := false; exit;
end if;
end loop;
if succeeds then return true; end if; -- otherwise keep looing to try to find a verification
end if;
end loop;
return false; -- if the iterator sequences don't agree, we give up in this case, allowing proof to proceed more manually,
end if;
when "{/}" => -- setformer without expression
-- see comment at start of preceding case
list_of_iters_1 := n2_1(2..); list_of_iters_2 := n2_2(2..); -- get the two lists of iterators
cond_1 := n3_1; cond_2 := n3_2; -- get the two conditions
[cl,list_of_iters_1,list_of_iters_2,cond_1,cond_2] := common_iter_len(list_of_iters_1,list_of_iters_2,cond_1,cond_2);
if cl = #list_of_iters_1 and cl = #list_of_iters_2 then -- the iterators agree out to their full lengths; look for differences in bodies
if not verify_equality_in(cond_1,cond_2,bound_vars_with_ranges + list_of_iters_1,context,true) then -- the conditions are not identical
return false; -- verification by examination of subparts succeeds
end if; -- otherwise we must check to see if the iterator lists are equivalent
--print("cond_1,cond_2:: ",cond_1," ",cond_2," ",list_of_iters_1," ",list_of_iters_2);
[-,-,restr_set_1] := list_of_iters_1(1); [-,-,restr_set_2] := list_of_iters_2(1); -- get the restriction sets
if not verify_equality_in(restr_set_1,restr_set_2,bound_vars_with_ranges,context,false) then
return false;
end if;
end if;
return true; -- if all tests are passed, we return true
when "ALL","EX" => -- universal and existential quantifiers
lead_quantifier := if ah = "ALL" then "ast_forall" else "ast_exists" end if;
[list_of_iters_1,body_1] := flatten_universal(tree1); [list_of_iters_2,body_2] := flatten_universal(tree2);
-- find the full flattened lists of prefixed universal quantifiers in the two trees
-- now find the iterator portions which are of the same types. That is, the operators "ast_in" or "DOT_INCIN"
-- must be the same, and for the "ast_in" case, either both ranges or none must be OM
[cl,list_of_iters_1,list_of_iters_2,body_1,body_2] := common_iter_len(list_of_iters_1,list_of_iters_2,body_1,body_2);
-- find the length of the iterator parts which are common
if cl = #list_of_iters_1 and cl = #list_of_iters_2 then -- the iterators agree out to their full lengths; look for differences in bodies
if not verify_equality_in(body_1,body_2,bound_vars_with_ranges + list_of_iters_1,context,true) then -- the bodies are not identical
return false; -- verification by examination of subparts succeeds
end if; -- otherwise we must check to see if the iterator lists are equivalent
succeeds := true; -- see if the following loop succeeds
for k in [1..cl] loop
[-,-,restr_set_1] := list_of_iters_1(k); [-,-,restr_set_2] := list_of_iters_2(k); -- get the restriction sets
if not verify_equality_in(restr_set_1,restr_set_2,bound_vars_with_ranges + list_of_iters_1(1..k - 1),context,false) then
succeeds := false; exit;
end if;
end loop;
if succeeds then return true; end if; -- otherwise not all of the restriction sets are eqivalent, so we
-- go on to see if identity can be verified 'directly' in some way
elseif cl = #list_of_iters_1 then -- the full first iterator agrees with a prefix of the second iterator
remaining_iters := list_of_iters_2(cl + 1..); -- find the remaining iters in the first group
body_2 := ["ast_forall",["ast_iter_list"] + remaining_iters,body_2]; -- restore the remaining universals to the second clause
elseif cl = #list_of_iters_2 then -- the full second iterator agrees with a prefix of the second iterator; insist on an identity
remaining_iters := list_of_iters_1(cl + 1..); -- find the remaining iters in the second group
body_1 := ["ast_forall",["ast_iter_list"] + remaining_iters,body_1]; -- restore the remaining universals to the first clause
else -- only portions of the iterators agree; insist on an identity of the remaining parts
remaining_iters1 := list_of_iters_1(cl + 1..); -- find the remaining iters in the first group
body_1 := ["ast_forall",["ast_iter_list"] + remaining_iters1,body_1]; -- restore the remaining universals to the first clause
remaining_iters2 := list_of_iters_2(cl + 1..); -- find the remaining iters in the second group
body_2 := ["ast_forall",["ast_iter_list"] + remaining_iters2,body_2]; -- restore the remaining universals to the second clause
end if;
-- here we attempt 'direct', rather than 'subpart' verifiction, by trying identities
-- prefixed by the full list of quantifiers and by any of its initial subparts, any one of which might be relevant
--print("try direct verification: cl = ",cl," lead_quantifier = ",lead_quantifier," list_of_iters_1 = ",list_of_iters_1," list_of_iters_2 = ",list_of_iters_2," body_1 = ",body_1," body_2 = ",body_2);
for j in [cl + 1,cl..1] loop -- try clauses with varying numbers of prefixed quantifiers
qbody_1 := if j > cl then body_1 else [lead_quantifier,["ast_iter_list"] + list_of_iters_1(j..),body_1] end if;
-- prefix the bodies with varying numbers of quantifiers
qbody_2 := if j > cl then body_2 else [lead_quantifier,["ast_iter_list"] + list_of_iters_2(j..),body_2] end if;
required_equivalence := ["DOT_EQ",qbody_1,qbody_2]; -- set up, and then quantify, the required equivalence
if j > 1 then required_equivalence := ["ast_forall",["ast_iter_list"] + list_of_iters_1(1..j - 1),required_equivalence]; end if;
--print("required_equivalence: ",j," ",unparse(required_equivalence));
if not check_in_context(required_equivalence,bound_vars_with_ranges,context) then continue; end if;
-- since the equivalence, quantified using the list of quantifiers drawn from the first formula, fails.
-- otherwise we must verify that the two lists of restriction sets are equivalent.
-- This can be done recursively, since the restriction sets are syntacticallly 'smaller' than the
-- expressions in which thy appear
succeeds := true; -- see if the following loop succeeds
for k in [1..j - 1] loop -- check the restriction sets in the prefixed iterators
[-,-,restr_set_1] := list_of_iters_1(k); [-,-,restr_set_2] := list_of_iters_2(k); -- get the restriction sets
if not verify_equality_in(restr_set_1,restr_set_2,bound_vars_with_ranges + list_of_iters_1(1..k - 1),context,false) then
succeeds := false; exit;
end if;
-- req_ident := ["ast_eq",restr_set_1,restr_set_2]; -- form the body of the required identity
-- required_equivalence := ["ast_and",required_equivalence,build_quantified_version(req_ident,list_of_iters_1(1..k - 1))];
-- -- add the necessary quantifiers and conjoin to the required equivalence
end loop;
if succeeds then return true; end if; -- since a quantified equivalence and all the restriction set equivalences have been verified
end loop;
return false; -- if none of the quantified clauses verifies, we fail at this level
when "itr","Etr" => -- iterators; here the iterators must be of the same kinds, and if one is involves a bounding set
-- so must the other. the bound variable names may differ; if they do we generate a common new name for both,
-- and sustitute it uniformly down both trees.
-- find the common minimum of the iterator lists lengths
if #(args1 := tree1(2..)) /= #(args2 := tree2(2..)) then -- the nodes differ in their number of arguments; treat as different
diffs_vars_ranges with:= [bound_vars_with_ranges,tree1,tree2];
return;
end if;
for sn = args1(j) loop verify_equality_in(sn,args2(j),bound_vars_with_ranges,context,is_pred); end loop;
otherwise => print("shouldn't happen verify_equality_in: ",ah," ",node); -- shouldn't happen
end case;
end if; -- otherwise the nodes differ in their principal operator; collect the difference
diffs_vars_ranges with:= [bound_vars_with_ranges,[if is_pred then "DOT_EQ" else "ast_eq" end if,tree1,tree2]];
-- generate an equivalence if we are in a predicate context, otherwise generate an equality
end verify_equality_in;
procedure check_in_context(formula,bnd_vars_with_ranges,context);
-- form quantified version of formula given, and verify it by ELEM reasoning in the context given
formula := build_quantified_version(formula,bnd_vars_with_ranges); -- add appropriate quantifiers
--print("check_in_context:: ",unparse(["ast_and",context,["ast_not",formula]]));
res := model_blobbed(blob_tree(["ast_and",context,["ast_not",formula]])) = OM; -- verify that the resulting formula is incompatible with the context given
--print("result is-: ",res);
return res;
end check_in_context;
procedure build_quantified_version(formula,bnd_vars_with_ranges); -- add appropriate quantifiers to a formula
-- we process the given list of quantifiers in reverse order, tracking the free variables that appear and attaching quantifiers that
-- bind any one of these free variables
if (nbvwr := #bnd_vars_with_ranges) = 0 then return formula; end if; -- nothing to do if no bound varaiables
free_vars := find_free_vars(formula); -- find the initial set of free variables
quantifs := []; -- will build list of quantifiers
for j in [nbvwr,nbvwr - 1..1] loop
[-,vari,limit] := quantifier := bnd_vars_with_ranges(j); -- examine quantifier
if vari notin free_vars then continue; end if; -- since variable is not relevant
free_vars less:= vari; free_vars +:= find_free_vars(limit); -- add the free variables in the limiting expression
quantifs := [quantifier] + quantifs; -- prefix the new quantifier to the accumulated list
end loop;
if quantifs = [] then return formula; end if;
return ["ast_forall", ["ast_iter_list"] + quantifs,formula]; -- return the universally quantified formula
end build_quantified_version;
procedure common_iter_len(list_of_iters_1,list_of_iters_2,body_1,body_2); -- find the iterator portions which are of the same types
-- That is, the operators "ast_in" or "DOT_INCIN" must be the same, and for the "ast_in" case, either both ranges or neither must be OM
-- this procedure substitutes for the bound varariables in each of the lists and formulae transmitted to it as long as this will force
-- identity of quantifiers and body, and returns the modified iterator lists and bodies.
subst_map_1 := subst_map_2 := {}; -- will map original bound vaiable names into their replacements
for j in [1..nlmin := (nl1 := #list_of_iters_1) min (nl2 := #list_of_iters_2)] loop
[itop_1,bv_1,range_1] := list_of_iters_1(j); [itop_2,bv_2,range_2] := list_of_iters_2(j); -- find kinds and ranges of iterators
if itop_1 /= itop_2 or (range_1 = "OM") /= (range_2 = "OM") then -- we have found the first difference
return [j - 1,list_of_iters_1,list_of_iters_2,body_1,body_2];
-- return length of the common part, with iterator lists and bodies as transformed up to this point
end if; -- otherwise we may generate a new bound variable name, and substitute it for the two bound variable names that appear
if bv_1 = bv_2 then continue; end if; -- if bound variable names are identical, no replacement is necessary
rem_quantif_1 := ["ast_forall",["ast_iter_list"] + list_of_iters_1(j + 1..),body_1]; -- the bodies with the remaining quantifiers
rem_quantif_2 := ["ast_forall",["ast_iter_list"] + list_of_iters_2(j + 1..),body_2];
list_of_iters_1(j) := [itop_1,bvn := "BVR_" + str(bvar_name_ctr +:= 1),range_1]; -- begin to replace the bound varialbe names
list_of_iters_2(j) := [itop_2,bvn,range_2];
subst_map_1(bv_1) := bvn; subst_map_2(bv_2) := bvn; -- the generated bound variable name will repalce the original name in ach formula
rem_quantif_1 := substitute(rem_quantif_1,subst_map_1); -- make the two substitutions
rem_quantif_2 := substitute(rem_quantif_2,subst_map_2);
list_of_iters_1(j + 1..nl1) := rem_quantif_1(2)(2..); -- extract the transformed iterator lists and bodies
list_of_iters_2(j + 1..nl1) := rem_quantif_2(2)(2..);
body_1 := rem_quantif_1(3);
body_2 := rem_quantif_2(3);
end loop;
return [nlmin,list_of_iters_1,list_of_iters_2,body_1,body_2]; -- otherwise the iterator lists match to the very end
end common_iter_len;
procedure flatten_universal(node); -- get the chain of universal quantifiers starting at a given node a first universal appears
[op,n2,n3] := node; -- we start with a universal
iters := n2(2..); -- the iterators, without the prefixed "ast_iter_list"
while (not is_string(n3)) and n3(1) = "ast_forall" loop -- descend thru full chain of following universals
[-,n2,n3] := n3; iters +:= n2(2..); -- keep collecting the iterators
end loop;
return [iters,n3]; -- return the list of iterators and the inner node
end flatten_universal;
procedure flatten_existential(node); -- get the chain of all existential quantifiers starting at a given node a first existential appears
[op,n2,n3] := node; -- we start with a universal
iters := n2(2..); -- the iterators, without the prefixed "ast_iter_list"
while (not is_string(n3)) and n3(1) = "ast_exists" loop -- descend thru full chain of following universals
[-,n2,n3] := n3; iters +:= n2(2..); -- keep collecting the iterators
end loop;
return [iters,n3]; -- return the list of iterators and the inner node
end flatten_existential;
procedure check_definition(tree,symbols); -- check a recursive or nonrecursive definition for validity
-- all the free names in the tree, other than those defined previously, must appear as arguments of the function symbol or object being defined
end check_definition;
procedure check_pred_definition(tree,statement,symbols); -- checks skolem-type definition for validity
-- some of all the free names in the tree, other than those defined previously, can appear as arguments of the function symbols or object being defined
-- the other parameters of the functions being defined must be initial, universally quantified variables of the predicate given,
-- which should be in Praenex form, and the functions being defined should correspond to an initial run of its existentially quantified symbols
-- the predicate asserted of this function in the skolem-type definition should derive in the syntactially appropriate way from the statement
end check_pred_definition;
procedure range_blob(node); -- this blobs a set expressions and quantifiers down functions involving basic set-theretic operators which may be
-- amenable to specialized decison algorithms
-- For example, the set expression {e(x): x in s | x in a - b and P(x)} will blob to range(BLOB | (s * a * BLOB2 * - b)), where BLOB is known to be single-valued,
-- and {[x,e(x)]: x in s | x in a - b and P(x)} will blob to BLOB | (s * a * BLOB2 - b), where BLOB is known to be single-valued.
end range_blob;
procedure gen_name(rw name_ctr); return "BL_" + str(name_ctr +:= 1); end gen_name; -- generate a new nme
procedure find_free_vars(node); -- find the free variables in a tree (main entry)
all_free_vars := {}; find_free_vars_in(node,[]); return all_free_vars; -- use the recursive workhorse and a global variable
end find_free_vars;
procedure find_free_vars_from(node,bound_vars); -- find the free variables in a tree (alternative main entry, used by blob_to_monotone)
all_free_vars := {}; find_free_vars_in(node,bound_vars); return all_free_vars; -- use the recursive workhorse and a global variable
end find_free_vars_from;
procedure find_free_vars_in(node,bound_vars); -- find the free variables in a tree (recursive workhorse)
--print("find_free_vars_in: ",node);
if is_string(node) then
if node notin bound_vars and node /= "OM" and node /= "_nullset" and node notin special_set_names then
all_free_vars with:= node;
end if;
return;
end if;
case (ah := abbreviated_headers(node(1)))
when "and","or","==","+","-","{-}","in","notin","/==","=","/=","[]","[-]","{.}","itr","Etr","incs","incin","imp","*","->","not","null" => -- ordinary operators
for sn in node(2..) loop find_free_vars_in(sn,bound_vars); end loop;
when "arb","range","domain" => -- ordinary operators
for sn in node(2..) loop find_free_vars_in(sn,bound_vars); end loop;
when "()" => -- this is the case of functional and predicate application; the second variable is a reserved symbol, not a set
for sn in node(3..) loop find_free_vars_in(sn,bound_vars); end loop;
when "{}","{/}","EX","ALL" => bound_vars +:= find_bound_vars(node); -- setformer or quantifier; note the bound variables
for sn in node(2..) loop find_free_vars_in(sn,bound_vars); end loop; -- collect free variables in args
when "@" => -- functional application
for sn in node(2..) loop find_free_vars_in(sn,bound_vars); end loop; -- collect free variables in args
otherwise => -- additional infix and prefix operators, including if-expressions
for sn in node(2..) loop find_free_vars_in(sn,bound_vars); end loop; -- collect free variables in args
end case;
end find_free_vars_in;
procedure reverse_context(parent_context); -- reverses = to /=, in to notin. Returns OM otherwise
[pc1,pc2,pc3] := parent_context;
return if pc1 = "ast_eq" then ["ast_ne",pc2,pc3] elseif pc1 = "ast_ne" then ["ast_eq",pc2,pc3]
elseif pc1 = "ast_in" then ["ast_notin",pc2,pc3] elseif pc1 = "ast_notin" then ["ast_in",pc2,pc3] else OM end if;
end reverse_context;
procedure all_cons(tree); -- test a pre-blobbed tree for being all cons operators, and return the set of blobs
-- if not all cons operators then return OM
var leaves := {}; -- will collect the set of all consed leaves
-- print("testing tree for all_cons ",tree);
-- save and restore the map of strings to blobs, so that this has no effect on subsequent blobbing
save_blob_name := blob_name; save_blob_name_ctr := blob_name_ctr;
save_algebra_blob_name_ctr := algebra_blob_name_ctr; save_algebra_blob_name := algebra_blob_name;
all_cons_in(blob_tree(tree)); -- call recursive workhorse
blob_name := save_blob_name; blob_name_ctr := save_blob_name_ctr;
algebra_blob_name_ctr := save_algebra_blob_name_ctr; algebra_blob_name := save_algebra_blob_name;
return leaves;
procedure all_cons_in(tree); -- recursive workhorse
if is_string(tree) then leaves with:= tree; return true; end if;
if (t1 := tree(1)) = "ast_enum_set" and #tree = 2 then
return all_cons_in(tree(2));
end if;
if tree(1) /= "ast_enum_tup" or #tree /= 3 then return OM; end if; -- some illegal unlobbed operator
if all_cons_in(tree(2)) = OM or all_cons_in(tree(3)) = OM then return OM; end if;
return true; -- is ok
end all_cons_in;
end all_cons;
--->tests
-- ************ Assorted tests ************
procedure test_basic_parses; -- view parse trees of basic constructions
print("****** TEST OF BASIC PARSING FEATURES ******\n");
stgs := ["{x,y,z};",
--"", -- stop here
-- "domain({[e(x),f(x)]: x in n | P(x)});",
-- "arb({x});","arb({x,y});","car([x,y]);","car([x,y,z]);",
-- "is_map(f) & (not is_map(f •ON s));",
-- "f(x,y,f(x,y,z));", -- function composition
-- "{e(x): x = f{y} | P(x)};", -- setformer, iteration type 2b
-- "{[x,e(x)]: x = f{y} | P(x)};", -- mapformer, iteration type 2b
-- "{[x,e(x)]: x in f(y) | P(x)};", -- mapformer
-- "{[x,e(x,yy)]: x in f(y), yy in z | P(x)};", -- mapformer, double iteration
-- "{e(x): x in s | P(x)};", -- simple setformer
-- "{e(x): x in s};", -- simple setformer, no condition
-- "exists x in s | P(x);", -- existential, iteration type 2
-- "exists x = f(y) | P(x,y);", -- existential, iteration type 2b
-- "forall x in s | P(x);", -- existential, iteration type 2
-- "forall x = f(y) | P(x,y);", -- existential, iteration type 2b
-- "f~[x];", -- map application
-- "car([x,y]);", -- car of pair
-- "arb({x});", -- arb of singleton
-- "{[x,y]}~[x];", -- map application whch can be simplified
-- "if a then b elseif c then d elseif e then f else g end if;", -- conditional
-- "{[x,e(x)]: x in s | P} @ {[y,ee(y)]: y in ss | PP};", -- composition of mapformers
-- "{car([x,e(x)]): x in f(y) | P(x)} = {x: x in f(y) | P(x)};", -- simplification within mapformer
-- "{cdr([x,e(x)]): x in f(y) | P(x)} = {e(x): x in f(y) | P(x)};", -- simplification within mapformer
-- "a and b and c;", -- multi-conjunction
-- "a or b or c;", -- multi-disjunction
-- "a •eq b;", -- equivalence
-- "a = b;", -- equality
-- "a + b + c;", -- union
-- "a - b - c;", -- difference
-- "##x;", -- double cardinality
-- "{x,y,z};", -- enumerated set
-- "[x,y];", -- ordered pair
-- "a in b;", -- membership
-- "not(a in b);", -- negated membership
-- "a notin b;", -- nonmembership
"range(f @ g);", -- precedence test
"(range f @ g);", -- precedence test
"a •neq b;"]; -- nonequivalence
for stg in stgs loop
if stg = "" then stop; end if;
print(); print(cleanup(tree := parze_expr(stg))); --print(tree);
end loop;
print(cleanup(tree := parze_expr("a in {} and c in {};"))); print(unparse(tree));
print(parze_expr("[a,b];"));
print(cleanup(tree := parze_expr("{e(x): x in s, u •incin v | (P(x,u,v) •imp HH~[x] = {w})};"))); -- setformer
dump_tree(tree);
print(cleanup(tree := parze_expr("{e(x): x in s, u •incin v | (P(x,u,v) •imp HH~[x] = {w})};"))); -- setformer
print("free_vars are: ",find_free_vars(tree));
-- tests of auxiliary routines
quantif_list1 := [["ast_in", "X", "S"], ["DOT_INCIN", "Y", "X"]];
quantif_list2 := [["ast_in", "U", "S1"], ["DOT_INCIN", "Y", "X"]];
body_1 := ["ast_of", "E", ["ast_list", "X", "Y"]];
body_2 := ["ast_of", "E", ["ast_list", "U", "Y"]];
print(common_iter_len(quantif_list1,quantif_list2,body_1,body_2));
quantif_list1 := [["ast_in", "X", "S"], ["DOT_INCIN", "Y", "X"]];
quantif_list2 := [["ast_in", "U", "S1"], ["ast_in", "Y", "X"]];
body_1 := ["ast_of", "E", ["ast_list", "X", "Y"]];
body_2 := ["ast_of", "E", ["ast_list", "U", "Y"]];
print(common_iter_len(quantif_list1,quantif_list2,body_1,body_2));
quantif_list1 := [["ast_in", "X", "S"], ["DOT_INCIN", "Y", "X"]];
quantif_list2 := [["ast_in", "X", "S1"], ["DOT_INCIN", "W", "X"]];
body_1 := ["ast_of", "E", ["ast_list", "X", "Y"]];
body_2 := ["ast_of", "E", ["ast_list", "X", "W"]];
print(common_iter_len(quantif_list1,quantif_list2,body_1,body_2));
tree := parze_expr("(FORALL x in s , y •incin t | P(x,y));")(2); print(tree); print(find_free_vars(tree));
print(cleanup(tree := parze_expr("{e(z): z in OM | R(z)};")));
end test_basic_parses;
procedure test_blob_to_string; -- tests of blob_to_string function
print("\n****** TEST OF BLOB_TO_STRING ******\n");
stgs := ["not (exists x in s,y = f(z) | not P(x,y,z));", -- existential, iteration type 2
"not (exists y in s,z = f(x) | not P(y,z,x));", -- existential, iteration type 2
"(forall x in s |(P(x,y) and (forall y in t | Q(x,y)) and R(x,y)));", -- existential compound
"forall x in s,y = f(z) | not (not P(x,y,z));", -- existential, iteration type 2
"not (not a);", -- double negation
"not (a •imp b);", -- negated impliation
"[{a,b,c,d},{b,a,d,c}];", -- ordered pair withenumerated sets
"{b,a,d,c};"]; -- enumerated set
for stg in stgs loop
print(); tree := parze_expr(stg); t2 := tree(2); print(blob_to_string(t2,[],0));
end loop;
print(); print(unparse(blob_tree(pe := parze_expr("arb(arb(bar(x)));")(2)))," ",pe);
print(); print(unparse(blob_tree(pe := parze_expr("car(cdr(bar(x)));")(2)))," ",pe);
end test_blob_to_string;
procedure test_standardize_bound_vars; -- tests of standardize bound variables function
print("\n****** TEST OF STANDARDIZE_BOUND_VARS FUNCTION ******\n");
stgs := ["(FORALL u in {[a(x,y),b(x,y)]: x in s, y in t | P(x,y)}, v in {[a(xx,yy),b(xx,yy)]: xx in s, yy in t | P(xx,yy)} | " +
"(car(u) = car(v)) •imp (u = v));",
"{enum(u,s): u in x} = {enum(y,s): y in x};",
"{u: v in {u: v in a, u in v}, u in v};",
"{enum(u,s): u in x | P(u)} = {enum(y,s): y in x | P(y)};"];
for stg in stgs loop
if stg = "" then exit; end if;
print(); print("standardized: ",unparse(standardize_bound_vars(tree := parze_expr(stg)(2)))); -- standardization test
-- print(); print("standardized: ",unparse(clean_tree(standardize_bound_vars(tree := parze_expr(stg)(2))))); -- standardization test
end loop;
end test_standardize_bound_vars;
procedure test_blobbing; -- test the blob_tree function
print("\n****** TEST OF BLOB_TREE FUNCTION ******\n");
equalities_rep_map := {["BLB_3", "G"]};
equalities_rep_map := {};
bigstg := "(FORALL t •incin s | ((t /= 0) •imp (EXISTS x in t | (FORALL y in t | (not arg1_bef_arg2(y,x)))))) & (not (FORALL t •incin s | ((t /= 0) •imp (EXISTS v in t | (FORALL y in t | (not arg1_bef_arg2(y,v)))))));";
stgs := ["((not (EXISTS i | R(m_thryvar,i)))) and ( (EXISTS i | R(m_thryvar,i))) and (not(false));",
-- bigstg,
-- "(SVM(F) and (FORALL BVX_1 in F | (FORALL BVX_2 in F | ((CDR(BVX_1) = CDR(BVX_2)) •imp ((BVX_1 = BVX_2)))))) and (not (FORALL X in F | (FORALL Y in F | ((CDR(X) = CDR(Y)) •imp ((X = Y))))));",
-- "{e(x): x in a + b | P(x)} = {ee(x): x in b + a | P(x)};",
-- "{e(x): x in a + b | P(x)};",
-- "{ee(x): x in b + a | P(x)};",
-- "e(x);",
-- "ee(x);",
-- "e(x) = ee(x);",
-- "(x in f(xx)) and (x notin f(xx));",
-- "(not((xx in s) and (yy in f(xx)) and p(xx,yy) and (c = e(xx,yy)))) and (xx in s) and (yy in fp(xx)) and pp2(xx,yy) and (c = ep2(xx,yy)) and (f(xx) = fp(xx)) and (e(xx,yy) = ep2(xx,yy)) and (p(xx,y) •eq pp2(xx,yy));",
-- "both_(e(x),ee(x));",
-- "both_(a,d);",
-- "both_(if ((A and B) •imp (A)) then C else D end if,D);",
-- "both_(d,if ((A and B) •imp (A)) then C else D end if);",
-- "if ((A and B) •imp (A)) then C else D end if;",
-- "({e(x): x in s | P(x)} = 0) and (e(c) in {e(x): x in s | P(x)});",
-- "{x: x in s | P(x)} = {x in s | P(x)};",
-- "{e(x): x in s | P(x)} = {x in s | P(x)};",
-- "(range(0) = 0) and (domain(0) = 0);",
-- "(not(Svm(0) and (domain(0) = 0) and (range(0) = 0) and one_1_map(0)));",
-- "s * t /= 0;",
-- "(range(f •ON (s * t)) /= 0) and (not(range(f •ON 0) /= 0));",
-- "not(f~[car(b)] = f~[car(a)]);",
-- "(arb({p in g | car(p) in {c}}) /= 0) and (g = {[x,f(x)]: x in s}) and ((not(arb({p in {[x,f(x)]: x in s} | car(p) in {c}}) /= 0)));",
-- "(FORALL x | (x in Fr) •imp (Fr_to_Ra(x) in Ra)) &" +
-- "(FORALL x | (x in Ra)) &" +
-- " (FORALL x, y | ((x in Fr)) •imp ((Same_frac(x,y)))) " + ";",
-- "(FORALL x, y | ((x in Fr)) •imp ((Same_frac(x,y)))) &" +
-- "(FORALL x | (x in Ra)) " + ";",
"", -- stop here
"{x: x in s} = s;","{x: x •incin s} = s;",
"{e(x): x in s |true} = {e(x): x in s};","{e(x): x in s};",
"{e(x): x in s |false} = {};","{e(x): x in s |true} = {f(x): x in s};",
"domain({[e(x),f(x)]: x in n | P(x)}) = {e(x): x in n | P(x)};",
"range({[e(x,y),f(x,y)]: x in n, y in m | P(x,y)}) = {f(x,y): x in n,y in m | P(x,y)};",
"domain({[e(x,y),f(x,y)]: x in n, y in m | P(x,y)}) = {f(x,y): x in n,y in m | P(x,y)};",
"([f~[car(x)],g~[cdr(x)]] = [f~[car([x1,y1])],g~[cdr([x1,y1])]]) & ([f~[car(x)],g~[cdr(x)]] = [f~[x1],g~[y1]]);",
"Ord(next(s)) = Ord(s);","Ord(next(next(s))) = Ord(s);","Ord(next(s)) = Ord(t);",
"{[[e(x),[y,f(z)]],[f(z),[y,e(x)]]]: x •incin s,y in {} | P(x,y)};",
"{[[e(x),[y,f(z)]],[f(z),[y,e(x)]]]: x in s,y •incin {} | P(x,y)};",
"{[[e(x),[y,f(z)]],[f(z),[y,e(x)]]]: y in {}, x •incin s | P(x,y)};",
"(EXISTS x •incin s, y in {} | P(x,y));",
"(EXISTS x in s,y •incin {} | P(x,y));",
"(EXISTS y in {}, x •incin s | P(x,y));",
"(FORALL x •incin s, y in {} | P(x,y));",
"(FORALL x in s,y •incin {} | P(x,y));",
"(FORALL y in {}, x •incin s | P(x,y));",
"Svm({[[e(x),[y,f(z)]],[f(y),[y,e(x)]]]: x in s});",
"One_1_map({[[e(x),[y,f(z)]],[f(z),[y,e(x)]]]: x in s});",
"One_1_map({[[e(x),[y,f(z)]],[f(y),[y,e(x)]]]: x in s});",
"Svm({[[e(x),[y,f(z)]],[y,e(x)]]: x in s});",
"One_1_map({[[e(x),[y,f(z)]],[y,e(x)]]: x in s});",
"is_map(f) & (not is_map(f •ON s));",
"{enum(u,s): u in x} = {enum(y,s): y in x};",
"{enum(u,s): u in x | P(u)} = {enum(y,s): y in x | P(y)};", "f(car([e(x),y])) = f(e(x));",
"{car([f(x),e(x)]): x in f(y) | P(cdr([x,e(x)]))} = {f(x): x in f(y) | P(e(x))};", -- simplification within mapformer
"f(car([e(cdr([e(x),y])),y])) = f(e(y));",
"f(car([e(cdr([e(x),y])),y])) = f(e(z));",
"a and (exists x in s | P(x)) and (exists y in s | P(y)) and b;",
"{e(x): x in s};",
"not((a in {e(x): x = f{y} | P(x)}) •neq ({e(x): x = f{y} | P(x)} notin b));",
"not((a = {e(x): x = f{y} | P(x)}) or ({e(x): x = f{y} | P(x)} notin {b,[c,d + e - f]}));",
"not((a = {e(x): x = f{y} | P(x)}) or ({e(x): x = f(y) | P(x)} notin {b,[c,d + e - f]}));",
"if a then {e(x): x in s} elseif b + c then {e(x): x in s} + {e(x): x in t} else {e(x): x in t} end if;",
"((a = aa or b incs bb) and (not (c •incin cc))) •imp (d in dd);",
"arb({x} + {{x,y,z}}) = x;",
"Is_map({[e(x),ee(y)]: x in z, y in w | P(x,y)});",
"Svm({[x,ee(y)]: x in z, y in w | P(x,y)});",
"Svm({[x,e(x)]: x in z | P(x,y)});",
"Svm({[x,e(x)]: x •incin z | P(x,y)});",
"f({x}) = x;",
"car([x,a]);",
"car([x,a]) = x;",
"cdr([x,a]);",
"cdr([x,a]) = a;",
"##x;",
"arb({x});",
"arb({car([x,a])});",
"car([arb({x}),y]);",
"{[x,e(x)]: x in s | P(x,a)} @ {[y,ee(y)]: y in ss | PP(y,b(x))};", -- composition of mapformers
"{car([x,e(x)]): x in f(y) | P(x)} = {x: x in f(y) | P(x)};", -- simplification within mapformer
"{cdr([x,e(x)]): x in f(y) | P(x)} = {e(x): x in f(y) | P(x)};", -- simplification within mapformer
"{car([x,e(x)]): x in f(y)} = {x: x in f(y)};", -- simplification within mapformer, no condition
"{cdr([x,e(x)]): x in f(y)} = {e(x): x in f(y)};", -- simplification within mapformer, no condition
"{car([x,a]): x in n | P(x)} = {x: x in n | P(x)};"];
for stg in stgs loop
if stg = "" then exit; end if;
tree := parze_expr(stg)(2);
print("blobbed: ",unparse(clean_tree(blob_tree(tree)))); -- blobbing testprint(tree);
end loop;
end test_blobbing;
procedure test_top_sort_stgs; -- test the top_sort_stgs function
print("\n****** TEST OF OP_SORT_STRINGS ******\n");
g := {["A","BB"],["AA","BB"],["A","B"],["AA","B"],["B","CCx"],["BB","CC"],["BB","CC"],["B","Cx"],["BB","C"],["BB","C"],["Cx","C"]};
print(top_sort_stgs(g)); -- test the top_sort_stgs function
end test_top_sort_stgs;
procedure unparse_test; -- test unparse operation
print("\n****** TEST OF UNPARSE FUNCTION ******\n");
stgs := ["(d in car(f~[x])) or (a & b);",
"[0,1];",
-- "(N * M = 0) •imp (N •PLUS M = #(N + M));",
-- "(N * {M} = 0) •imp (N •PLUS {M} = #(N + {M}));",
-- "(a * b + c - d = e) •eq (x in f);",
-- "(a * b + c - d = e) •imp (x in f);",
-- "(a * b •PLUS c - d = e) •eq (x in f);",
-- "{[{e(x,y,z): x in s, y = f(z) | P(x,y,z)},g{x,y}],c,d(e,f)};",
-- "{e(x): x in s | P(x)};",
-- "(exists x in s,y in x | P(x,y)) or (forall x = f(y) | P(x,y));",
-- "if a then aa elseif b then bb elseif c then cc else d end if;",
-- "if a then aa else d end if;",
-- "a + b + c + d;",
-- "a + b + c + (a * b * c * (a + b + c + d));",
-- "a and b and c and (a or b or c or (a and b and c and d));",
-- "(a + b + (c + d));",
-- "a and b and (c or d) and e;",
-- "a or (b and e);",
-- "{a + b + c + d,a + b + c + d};",
-- "Card({0}) •eq ({0} = #{0});",
-- "((car(f~[x]) in car(f~[x])) or ((car(f~[x]) = car(f~[x])) & (cdr(f~[x]) in cdr(f~[x]))));",
-- "a or ((car(f~[x]) = car(f~[x])) & (cdr(f~[x]) in cdr(f~[x])));",
-- "((car(f~[x]) in car(f~[x])) or ((car(f~[x]) = car(f~[x])) & b));",
-- "((car(f~[x]) in car(f~[x])) or (a & b));",
-- "((c in d) or (a & b));",
-- "((c in car(f~[x])) or (a & b));",
-- "((car(f~[x]) in d) or (a & b));",
"range(f @ g);",
"(FORALL x | (x in Ra));",
"0;"];
for stg in stgs loop print(); print("unparse: ",unparse(tree := parze_expr(stg)(2))); end loop;
print(unparse(["ast_forall", ["ast_iter_list", "BVX_1", "BVX_2"], ["DOT_IMP", ["ast_in", "BVX_1", "FR"], ["ast_of", "SAME_FRAC", ["ast_list", "BVX_1", "BVX_2"]]]]));
end unparse_test;
procedure blobstring_tests; -- direct test of blobstring operation
print("\n****** TEST OF BLOBSTRING OPERATION ******\n");
stgs := ["a * a + b + c + d;", -- multi-addition
"b + d + c + a * a ;", -- multi-addition, permuted order
"a * b * c * d;", -- multiplication
"b * d * c * a ;", -- multiplication, permuted order
"c •eq a = d;", -- identity/equivalence
"d = a •eq c;", -- identity/equivalence, permuted order
"a * a - b * b - c * c - d * d;", -- multi-subtraction
"a /= b;", -- inequality
"b /= a;", -- inequality
"not(a = b);", -- enumerated set
"not(a /= b);"]; -- enumerated set
for stg in stgs loop
print(); print(cleanup(tree := parze_expr(stg)(2)),"\n",blob_to_string(tree,[],0));
end loop;
end blobstring_tests;
procedure test_find_bound_vars; -- test the 'find_bound_vars' operation, for setformer and iteration nodes
print("\n****** TEST OF FIND_BOUND_VARS ******\n");
stgs := ["{e(x): x = f(y),z in s, w= f{n} | P(x)};", -- setformer, general iteration
"exists x = f(y),z in s, w= f{n} | P(x);", -- existential, general iteration
"forall x = f(y),z in s, w= f{n} | P(x);", -- universal, general iteration
"forall x = f(y),z •incin s, w= f{n} | P(x);"]; -- universal, general iteration
for stg in stgs loop
print(); print("bound vars: ",find_bound_vars(parze_expr(stg)(2)));
end loop;
end test_find_bound_vars;
procedure test_find_free_vars; -- test the 'find_free_vars' operation, for setformer and iteration nodes
print("\n****** TEST OF FIND_FREE_VARS ******\n");
stgs := ["if x then y elseif y then zz else w end if;",
"{e(x): x in y, z in x, w in n | P(x)};", -- setformer, general iteration
"exists x in y, z in x, w in n | P(x);", -- existential, general iteration
"forall x in y, z in x, w in n | P(x);"]; -- universal, general iteration
for stg in stgs loop
print(); print("free vars: ",find_free_vars(parze_expr(stg)(2)));
end loop;
end test_find_free_vars;
procedure test_simplify_setformer; -- test the simplify_setformer routine
print("\n****** TEST OF SIMPLIFY_SETFORMER ******\n");
stgs := ["a;",
"(FORALL u in {[a(x,y),b(x,y)]: x in s, y in t | P(x,y)}, v in {[a(xx,yy),b(xx,yy)]: xx in s, yy in t | P(xx,yy)} | (car(u) = car(v)) •imp (u = v));",
-- "{[car(u),cdr(u)]: u in {[car(x),cdr(y)]: x in g, y in f | cdr(x) = car(y)}};",
-- "{u in {membs_x(s,v): v in s_inf} | P(u)};",
-- "{w: u in {membs_x(s,v): v in s_inf}, w in u};",
-- "{e(w): u in {membs_x(s,v): v in s_inf}, w in u};",
-- "{e(k,w): k in a,u in {membs_x(s,v): v in s_inf}, w in u};",
-- "{e(u,k,w,u,m): k in a,u in {membs_x(s,v): v in s_inf}, w in u, m in b(u,w,u,k)};",
-- "(FORALL u in {membs_x(s,v): v in s_inf}, w in u | P(u,w));",
-- "(FORALL k in a,u in {membs_x(s,v): v in s_inf}, w in u | P(k,u,w));",
-- "(FORALL k in a,u in {membs_x(s,v): v in s_inf}, w in u, m in b(u,w,u,k) | P(k,m,u,w));",
-- "{e(x): x in {s} | P(x)};",
-- "{x in {s} | P(x)};",
-- "{x in {[s,t]} | P(x)};",
-- "{e(x): x in {[s,t]} | P(x)};",
-- "{e(y,x,z): y in a, x in {[s,t]}, z in b | P(y,x,z)};",
-- "{e(y,x,z): y in {a}, x in {[s,t]}, z in b | P(y,x,z)};",
-- "{e(y,x,z): y in a, x in {[s,t]}, z in {b} | P(y,x,z)};",
-- "{e(y,x,z): y in {a}, x in {[s,t]}, z in {b} | P(y,x,z)};",
-- "(FORALL y in a, x in {[s,t]}, z in b | P(y,x,z));",
-- "(FORALL y in {a}, x in {[s,t]}, z in b | P(y,x,z));",
-- "(FORALL y in a, x in {[s,t]}, z in {b} | P(y,x,z));",
-- "(FORALL y in {a}, x in {[s,t]}, z in {b} | P(y,x,z));",
-- "{x in s | true};",
-- "{x: x in s | true};",
-- "{x: x in s};",
-- "(FORALL u in {[a(x),b(x)]: x in s} | (FORALL v in {[a(x),b(x)]: x in s} | (car(u) = car(v)) •imp (u = v)));",
-- "{G(x,y,w,u): x in s, y in {e(z,zz): z in tt,zz in ttt | R(z)},u in uu, w in {e2(z): z in tt2 | R2(z)} | C(x,y,w)};",
-- "{y in {e(z,zz): z in tt,zz in ttt | R(z)} | C(y)};",
-- "(EXISTS x in s, y in {e(z,zz): z in tt,zz in ttt | R(z)},u in uu, w in {e2(z): z in tt2 | R2(z)} | C(x,y,w));",
-- "{e(z): z •incin tt | R(z)};",
-- "{e(x): x in {f(y): y in {g(z): z in a | P(z)} | Q(y)} | R(x)};",
-- "{G(x,y,w): x in s, y in {e(z): z in tt | R(z)}, w in {e2(z): z in tt2 | R2(z)} | C(x,y,w)};",
-- "{G(x,y,w): x in s, y in {e(z): z in tt | R(z)}, w in {e2(z): z in tt2 | R2(z)} | C(x,y,w)};",
-- "{G(x,y,w): x in s, y in {e(z): z •incin tt | R(z)}, w in {e2(z): z in tt2 | R2(z)} | C(x,y,w)};",
-- "{G(x,y,w): x in s, y in {z in tt | R(z)}, w in {e2(z): z in tt2 | R2(z)} | C(x,y,w)};",
-- "{G(x,y,w): x in s, y in {z in tt | R(z)}, w in {e2(z): z in tt2 | R2(z)} | C(x,y,w)};",
-- "{G(x,y,w): x in s, y in {z in tt | R(z)}, w in {e2(z): z in tt2 | R2(z)} | C(x,y,w)};",
-- "{G(x,y,w): x in s, y in {z •incin tt | R(z)}, w in {e2(z): z in tt2 | R2(z)} | C(x,y,w)};",
-- "{y in {e(z): z in tt | R(z)} | C(y)};",
-- "{y in {e(z): z •incin tt | R(z)} | C(y)};",
-- "{y in {z in tt | R(z)} | C(y)};",
-- "{y in {z •incin tt | R(z)} | C(y)};",
-- "(EXISTS x in s, y in {e(z): z in tt | R(z)}, w in {e2(z): z in tt2 | R2(z)} | C(x,y,w));",
-- "(EXISTS x in s, y in {e(z): z in tt | R(z)}, w in {e2(z): z in tt2 | R2(z)} | C(x,y,w));",
-- "(EXISTS x in s, y in {e(z): z in tt | R(z)}, w in {e2(z): z in tt2 | R2(z)} | C(x,y,w));",
-- "(EXISTS x in s, y in {e(z): z •incin tt | R(z)}, w in {e2(z): z in tt2 | R2(z)} | C(x,y,w));",
-- "(EXISTS x in s, y in {z in tt | R(z)}, w in {e2(z): z in tt2 | R2(z)} | C(x,y,w));",
-- "(EXISTS x in s, y in {z in tt | R(z)}, w in {e2(z): z in tt2 | R2(z)} | C(x,y,w));",
-- "(EXISTS x in s, y in {z in tt | R(z)}, w in {e2(z): z in tt2 | R2(z)} | C(x,y,w));",
-- "(EXISTS x in s, y in {z •incin tt | R(z)}, w in {e2(z): z in tt2 | R2(z)} | C(x,y,w));",
-- "(FORALL y in {e(z): z in tt | R(z)} | C(y));",
-- "(FORALL y in {e(z): z •incin tt | R(z)} | C(y));",
-- "(FORALL y in {z in tt | R(z)} | C(y));",
-- "(FORALL y in {z •incin tt | R(z)} | C(y));"
"a;"];
for stg in stgs loop
print(); tree := parze_expr(stg);
print("simplified: ",unparse(simplify_setformer(tree(2))));
end loop;
end test_simplify_setformer;
procedure test_Davis_Putnam; -- test the Davis_Putnam propositional decision algorithm
print("\n****** TEST OF DAVIS-PUTNAM ROUTINE ******\n");
test_bool_exp("((a or b) and (not c)) •imp d;",lambda(a,b,c,d); return implies((a or b) and (not c), d); end lambda);
test_bool_exp("(a or b) and ((not c) or (not d));",lambda(a,b,c,d); return (a or b) and ((not c) or (not d)); end lambda);
test_bool_exp("(a and b) or ((not c) and (not d));",lambda(a,b,c,d); return (a and b) or ((not c) and (not d)); end lambda);
test_bool_exp("(a •imp b) and (b •imp c) and (c •imp d);",lambda(a,b,c,d); return implies(a,b) and implies(b,c) and implies(c,d); end lambda);
test_bool_exp("(a and (a •imp b) and (b •imp c) and (c •imp d)) •imp d;",lambda(a,b,c,d); return true; end lambda);
tree := parze_expr("(not FALSE);"); print(model_blobbed(tree(2))?"UNSATISFIABLE");
tree := parze_expr("(not TRUE);"); print(model_blobbed(tree(2))?"UNSATISFIABLE");
tree := parze_expr("(FALSE);"); print(model_blobbed(tree(2))?"UNSATISFIABLE");
tree := parze_expr("(BLB_1 and BLB_2) and (not BLB_3) and (not FALSE);"); print(model_blobbed(tree(2))?"UNSATISFIABLE"); stop;
set_of_disjunctions := {[{"A11"}, {"A5", "A10"}], [{"A10"}, {"A11"}], [{"A12"}, {"A13"}], [{"A13"}, {}], [{"A11"}, {"A13"}], [{"A13"}, {"A12", "A11"}], [{"A5"}, {"A11"}]};
meaning_of_propsymbol := {["A12", ["/=", "A", "Y"]], ["A5", ["in", "A", "A4"]], ["A10", ["=", "A9", "0"]]};
addnal_setrelns := {["A8", "+", "A6", "A7"], ["A4", "+", "A2", "A3"], ["A9", "*", "A", "A8"], ["A6", "{-}", "X"], ["A7", "{-}", "Y"], ["A2", "{-}", "X"], ["A3", "{-}", "Y"]};
set := {["X", "A4"], ["X", "A8"], ["X", "A2"], ["A", "A4"], ["Y", "A4"], ["Y", "A8"], ["Y", "A3"]}; pair := ["A", "A2"]; print(set with:= pair);
print(Davis_Putnam(set_of_disjunctions,mlss_decider,[meaning_of_propsymbol,addnal_setrelns]));
end test_Davis_Putnam; -- test the Davis_Putnam propositional decision algorithm
procedure test_bool_exp(stg,fcn); -- check agreement of davis_putnam and truth-table for 4-variable boolean expressions
-- second parameter is a function for evaluating boolean experssions corresponding to the boolean formula 'stg'
var all_satisfying := {}; -- will collect all patterns satisying a given Boolean expression
wantall := lambda(truth_vals,extras);
if not (domain(truth_vals) incs {"A","B","C","D"}) then return {}; end if;
-- the Davis-Putnam algorithm will try for a quick solution before making nondeterministic choices.
-- to defeat this, we simply return an empty model (signalling no contradiction)
-- if truth values have not been supplied for everything in the expected domain.
all_satisfying with:= ("" + / [if truth_vals(c) then "" else "-" end if + c: c in "ABCD"]);
end lambda;
tree := parze_expr(stg);
[set_of_disjunctions,meaning_of_propsymbol,addnal_setrelns] := decompose_post_blobbing(tree(2));
Davis_Putnam(set_of_disjunctions,wantall,[meaning_of_propsymbol,addnal_setrelns]); -- call the Davis-Putnam routine, which will be forced to bactrack
tf := [true,false]; tv_satisfying_tt := {{["A",a],["B",b],["C",c],["D",d]}: a in tf,b in tf,c in tf,d in tf | fcn(a,b,c,d)};
all_satisfying_tt := {"" + / [if t_vals(c) then "" else "-" end if + c: c in "ABCD"]: t_vals in tv_satisfying_tt};
print(all_satisfying = all_satisfying_tt);
end test_bool_exp;
procedure implies(a,b); return b or (not a); end implies;
procedure small_mlss_test; -- initial explicit test of mlss decider
print("\n****** SMALL MLLS TEST ******\n");
AA := [newat(): j in [1..60]]; -- generate vector of atoms
truth_value := {[AA(4),TRUE], [AA(8),FALSE], [AA(24),TRUE], [AA(12),FALSE], [AA(28),TRUE], [AA(33),TRUE], [AA(21),FALSE],
[AA(9),FALSE], [AA(25),FALSE], [AA(13),FALSE], [AA(38),TRUE], [AA(26),FALSE], [AA(14),TRUE], [AA(23),TRUE],
[AA(27),TRUE], [AA(15),TRUE]};
td_params := [{[AA(30),["=", AA(19),"0"]], [AA(29),["=", AA(20),"0"]], [AA(35),["=", AA(10),"0"]],
[AA(34),["=", AA(11),"0"]], [AA(18),["=", "S", "T"]], [AA(33),["=", AA(32),"0"]],
[AA(40),["=", AA(19),AA(10)]], [AA(39),["=", AA(5),AA(6)]], [AA(31),["in", AA(20),AA(19)]],
[AA(3),["incin", "T", "S"]], [AA(38),["=", AA(37),"0"]], [AA(12),["=", "T", AA(11)]],
[AA(9),["=", "T", "S"]], [AA(41),["=", AA(20),AA(11)]], [AA(36),["in", AA(11),AA(10)]],
[AA(2),["incin", "S", "T"]], [AA(21),["=", "S", AA(20)]]}, {[AA(10),"-", "S", "T"],
[AA(32),"*", AA(20),AA(19)], [AA(19),"-", "T", "S"], [AA(37),"*", AA(11),AA(10)]}];
pos_membrs_inv := {[AA(11), AA(55)], ["S", AA(55)], [AA(12), AA(53)], [AA(21), AA(54)]};
given_vars := {AA(12), AA(20), "0", "T", "_nullset", AA(21), AA(33), AA(38), AA(11), "S"};
sorted_membs := [AA(53), AA(12), AA(54), AA(21), AA(55), AA(11), "S"];
print("\npos_membrs_inv = ",pos_membrs_inv,"\ngiven_vars = ",given_vars,"\nsorted_membs = ",sorted_membs);
print(build_model(pos_membrs_inv,given_vars,sorted_membs)); --stop;
print("mlss_decider");
print(mlss_decider(truth_value,td_params));
end small_mlss_test;
procedure test_model_blobbed(); -- initial tests and timing of the mlss verifier
print("\n****** TEST OF MODEL_BLOBBED FUNCTION ******\n");
print(model_blobbed(["ast_and", "BLA_86", ["ast_not", "BLA_86"]]?"UNSATISFIABLE")); stop;
stgs := ["-- ******** TESTS OF ELEMENTARY CASES ********",
"(cdr([[[x,y],z],[x,[y,z]]]) = cdr([[[x2,y2],z2],[x2,[y2,z2]]]) and " +
"(not [[[x,y],z],[x,[y,z]]] = [[[x2,y2],z2],[x2,[y2,z2]]])) and " +
"cdr([[[x,y],z],[x,[y,z]]]) = [x,[y,z]] and " +
"cdr([[[x2,y2],z2],[x2,[y2,z2]]]) = [x2,[y2,z2]] and " +
"not([x,[y,z]] = [x2,[y2,z2]]);",
-- "(([X,Y] = [X2,Y2]) and (not ([[X,Y],[Y,X]] = [[X2,Y2],[Y2,X2]])));",
"((X = X2) and (Y = Y2) and (not ((X = X2) and (Y = Y2))));",
-- "((X /= Z) and (BLB_1 /= Y) and (BLB_1 = (arb ({Y} + if (Z = X) then {W} else 0 end if))) and (not (Z /= X)));",
--
-- "((T •incin S) and (not ((#T) •incin (#S))) and (BLB_9 •incin (#S)) and ((#BLB_9) •incin (#S)) and " +
-- "((#S) in (#T)) and ((((#BLB_9) = (#S)) or ((#BLB_9) in (#S))) and ((#S) •incin (#T))) and (not ((#BLB_9) in (#T))));",
-- "a in b and b in c;",
-- "a in b and b in a;",
-- "a in b and aa in b and aa /= a and b in c;",
-- "c in a and c = a + b;",
-- "c in a and c = a + b + d;",
-- "c in a and c = a + b - d;",
-- "(c in a or c in b) and c = a + b;",
-- "(c in a or c in b or c in d) and c = a + b * d;",
-- "(c in a or c in b) and c = a * b;",
-- "(c in a or c in b) and c = a - b;",
-- "(c in a or c in b) and c = (a - b) + (b - a);",
-- "(c in a or c in b) and c = (a - b) + (b - a) and a /= b;",
-- "a in {b,c} and a /= b;",
-- "a in {b,c} and a /= b and a /= c;",
-- "a in {b} and c in {b,d} and a /= c and c /= d;",
-- "not(b incs b);",
-- "a /= b and b incs a and a incs b;",
-- "a /= b and b incs a;",
-- "a /= b and b incs a and (a •incin b);",
-- "b incs a and (not (a •incin b));",
-- "(not (b incs a)) and (a •incin b);",
-- "(not (b incs a)) and (b •incin a);",
-- "b incs a and (not (b •incin a));",
-- "a in {b} and c in {b};",
-- "a in {b} and c in {b} and a /= c;",
-- "a in {b} and c in {b,d};",
-- "a in {b} and c in {b,d} and a /= c;",
-- "a * {} /= a;",
-- "{} incs {a};",
-- "a + {} /= a;",
-- "a in {};",
-- "a - {} /= a;",
-- "a * {} /= {};",
-- "{} incs a and a /= {};",
-- "{} incs (a + b) and a /= {};",
-- "{} incs {a,b,c};",
-- "{a} incs {a,b,c};",
-- "{a} incs {a,b} and a /= b;",
-- "{a} incs {a,b,c} and (a /= b or a /= c);",
-- "{a} incs {a,b,c,d} and (a /= b and a /= c);",
-- "{a} incs {a,b,c,d} and (a /= b or a /= c or a /= d);",
--
-- "-- ******** CASES WITH SINGLETONS ********",
--
-- "a notin {b};",
-- "a notin {b,c};",
-- "{b,c} /= {b};",
-- "a in {b} and c in {b,d} and a /= c and c /= b;",
-- "a in {b,c,d,e} and a /= b and a /= c and a /= d;",
-- "b = {x,{x}} and a = 0 and a in b and a * b = 0 and a /= x;",
-- "arb(x) /= y;",
-- "a in {y} and a /= y;",
-- "arb({y}) /= y;",
-- "arb({x,{x}}) = {x};",
-- "arb({x,{x}}) = x;",
-- "(a = 0 or a in {x,y}) and ({x,y} = 0 or a in {x,y}) and a * {x,y} = 0 and a /= y;",
-- "arb({x,y}) /= y;",
-- "arb({x,{x}}) /= x;",
-- "x = y and arb(y) /= arb(x);",
-- "arb({y}) = y;",
-- "arb({y}) /= x;",
-- "(c in a or c in b) and c = (a - b) + (b - a) and a /= b;",
-- "{b,c,d} /= {b};",
-- "{b,c,c} /= {b,c};",
-- "{b,c,d} /= {d,b,c};",
-- "{b,c,d} /= {d,b,c};",
-- "{b,c,d} /= {b};",
-- "{b,c,d} /= {b,c};",
--
-- -- ******** PROBLEMS OF SOME KIND ********
--
-- --"arb({x,y}) /= y and arb({x,y}) /= x;" -- crash
-- --print(model_blobbed(formula(2))?"UNSATISFIABLE");
--
-- --"x = y and arb(arb(y)) /= arb(arb(x));" -- very long run or some problem
-- --print(model_blobbed(formula(2)));
--
-- "{b,c,d} = {b,c} and b /= c;"
---- "a in {b,c,d} and a /= b and a /= c;" -- SOME SETL ????? BUG HERE
-- "a in {b,c,d} and a /= b and a /= c and a /= d;",
--
-- "x = y and u = v and (car(x) /= car(y) or cdr(x) /= cdr(y) or [x,u] /= [x,v]);" -- hang, possibly because of long run
-- print(model_blobbed(tree(2))?"UNSATISFIABLE");
--
-- "x = y and u = v and (car(x) /= car(y) or cdr(x) /= cdr(y) or [x,u] /= [x,v]);" -- hang, possibly because of long run
-- "[x,y] = [u,v] and (x /= u or y /= v);",
--
-- "-- **************** car/cdr/cons tests ****************",
--
-- "x = y and (car(x) /= car(y) or cdr(x) /= cdr(y));",
-- "x = y and [x,u] /= [x,v];",
-- "x = y and u = v and [x,u] /= [x,v];",
-- "car([x,y]) /= x;",
-- "car([x,y]) /= y;",
-- "cdr([x,y]) /= y;",
-- "cdr([x,y]) /= x;",
-- "cdr(car([[x,z],y])) /= z;",
-- "car(cdr([[x,z],y])) /= x;",
-- "cdr(car([[x,z],y])) /= y;",
-- "car(cdr([[x,z],y])) /= z;",
--
-- "-- ******** Tests for monotone set functions of one variable ********",
--
-- "x = y + z and (not mon(mon(x)) incs mon(mon(y)));",
-- "x incs y and mon(mon(y)) - mon(mon(x)) /= 0;",
-- "x = y + z and mon(mon(y)) - mon(mon(x)) /= 0;",
-- "x incs y and (not mon(mon(mon(x))) incs mon(mon(mon(y))));",
-- "x = y + z and (not mon(mon(mon(x))) incs mon(mon(mon(y))));",
-- "x incs y and (not mon(mon(y)) incs mon(mon(x)));",
-- "mon(x) /= mon(y);",
-- "x incs y and mon(x) - mon(y) /= 0;",
-- "x = y and mon(x) /= mon(y);",
-- "x incs y and mon(y) - mon(x) /= 0;",
--
-- "-- ******** Tests for involving the cardinality operator ********",
--
-- "x incs y and not #x incs #y;",
-- "x = y + z and not #x incs #y;",
-- "not #(x + u) incs #(x * v);",
-- "not #(x * v) incs #(x + u);",
--
-- "not #(x + z) incs #(x + z * w);",
-- "#(x) /= #(y);",
-- "x = y and #(x) /= #(y);",
-- "x incs y and x •incin y and #(x) /= #(y);",
-- "x incs y and #y incs #x and #(x) /= #(y);",
--
-- "-- ******** Tests for monotone decreasing set functions of one variable ********",
--
-- "mondn(x) /= mondn(y);",
-- "x incs y and mondn(x) - mondn(y) /= 0;",
-- "x incs y and mondn(mon(x)) - mondn(mon(y)) /= 0;",
-- "x incs y and mondn(y) - mondn(x) /= 0;",
-- "x = y and mondn(x) /= mondn(y);",
-- "x incs y and mondn(mondn(y)) - mondn(mondn(x)) /= 0;",
-- "x = y + z and mondn(mondn(y)) - mondn(mondn(x)) /= 0;",
-- "x = y + z and (not mon(mondn(x)) incs mon(mondn(y)));",
-- "x incs y and (not mondn(mondn(mondn(y))) incs mondn(mondn(mondn(y))));",
-- "x = y + z and (not mondn(mon(mondn(x))) incs mondn(mon(mondn(y))));",
-- "x incs y and (not mondn(mon(y)) incs mondn(mon(x)));",
-- "x incs y and mondn(x) - mondn(y) /= 0;",
--
-- "-- ******** Tests for pair of monotone set functions of one variable in known comparison ********",
--
-- "x = y + z and (not (big_mon(x) incs mon(y)));",
-- "x = y + z and (not (big_mon(y) incs mon(x)));",
-- "x = y + z and (not big_mon(big_mon(x)) incs mon(mon(y)));",
-- "x = y + z and (not big_mon(big_mon(x)) incs big_mon(mon(y)));",
-- "x = y + z and (not big_mon(big_mon(y)) incs big_mon(mon(x)));",
-- "x incs y and big_mon(big_mon(y)) - mon(mon(x)) /= 0;",
-- "x incs y and mon(mon(y)) - big_mon(big_mon(x)) /= 0;",
-- "x = y + z and mon(mon(y)) - big_mon(big_mon(x)) /= 0;",
-- "x = y + z and mon(mon(y)) - big_mon(mon(x)) /= 0;",
-- "x = y + z and mon(mon(y)) - mon(big_mon(x)) /= 0;",
-- "x incs y and (not big_mon(big_mon(big_mon(x))) incs mon(mon(mon(y))));",
-- "x = y + z and (not big_mon(big_mon(big_mon(x))) incs mon(mon(mon(y))));",
-- "x incs y and (not big_mon(big_mon(mon(x))) incs mon(mon(mon(y))));",
-- "x = y + z and (not big_mon(mon(big_mon(x))) incs mon(mon(mon(y))));",
-- "x incs y and (not big_mon(big_mon(y)) incs mon(mon(x)));",
-- "big_mon(x) /= mon(y);",
-- "x incs y and big_mon(x) - mon(y) /= 0;",
-- "x incs y and mon(x) - big_mon(y) /= 0;",
--
-- "-- ******** Tests for pair of monotone set functions of two variables ********",
--
-- "x incs y and mon2(x,u) - mon2(y,u) /= 0;",
-- "x incs y and mon2(y,u) - mon2(x,u) /= 0;",
-- "x * z = y and mon2(y,u) - mon2(x,u) /= 0;",
-- "x * z = y and u = v + w and mon2(y,v) - mon2(x,u) /= 0;",
-- "mon2(x - z,v) - mon2(x,v + w) /= 0;",
-- "x incs y and mon2(mon2(y,u * w),u * w) - mon2(mon2(x,u),u) /= 0;",
-- "x incs y and u incs v and mon2(mon2(y,v),v) - mon2(mon2(x,u),u) /= 0;",
-- "x = y and u = v and mon2(x,u) /= mon2(y,v);",
-- "x = y and u incs v and v incs u and mon2(x,u) /= mon2(y,v);",
-- "x = y and u incs v and (u •incin v) and mon2(x,u) /= mon2(y,v);",
-- "x incs y and mon2(y * x,mon(y)) - mon2(x,mon(x)) /= 0;",
-- "x incs y and mon2(mon2(y,mondn(x)),x) - mon2(mon2(x,mondn(y)),x + v) /= 0;",
-- "x incs y and mon2(mon2(y,mondn(x)),y) - mon2(mon2(x,mondn(y)),x) /= 0;",
-- "x = y + z and mon2(mon2(y,y),y) - mon2(mon2(x,x),x) /= 0;",
-- "x = y + z and (not mon(mon2(x,u)) incs mon(mon2(y,u)));",
-- "x incs y and (not mon(mon(mon2(x,u))) incs mon(mon(mon2(y,u * w))));",
-- "x = y + z and (not mon2(mon(mon2(x,x + v)),y + v) incs mon2(mon(mon2(y,x)),y));",
-- "x incs y and (not mon2(mon(y),x) incs mon2(mon(x),x));",
-- "x incs y and mon2(x,y) - mon2(y,x) /= 0;",
--
-- "-- ******** Idempotent function tests ********",
--
-- "y = idemp(x) and idemp(x) /= idemp(y);",
-- "idemp(x) incs y and y incs idemp(x) and idemp(x) /= idemp(y);",
-- "idemp(x) /= x;",
-- "idemp(idemp(x)) /= idemp(x);",
-- "idemp(idemp(idemp(x))) /= idemp(x);",
-- "idemp(idemp(idemp(x))) /= idemp(idemp(y));",
-- "idemp(idemp(idemp(x))) /= idemp(y);",
-- "idemp(idemp(x)) /= idemp(y);",
-- "idemp(idemp(x)) /= y;",
-- "idemp(idemp(idemp(x))) /= x;",
--
-- "-- ******** Self-inverse function tests ********",
--
-- "y = selfinv(x) and selfinv(x) /= y;",
-- "selfinv(selfinv(x)) /= x;",
-- "selfinv(selfinv(selfinv(x))) /= selfinv(x);",
-- "selfinv(selfinv(selfinv(x))) /= x;",
-- "selfinv(x) incs y and y incs selfinv(x) and x /= selfinv(y);",
-- "selfinv(x) /= x;",
-- "selfinv(selfinv(idemp(x))) /= idemp(idemp(x));",
-- "selfinv(selfinv(selfinv(x))) /= selfinv(y);",
-- "selfinv(selfinv(x)) /= selfinv(y);",
-- "selfinv(selfinv(x)) /= y;",
--
-- "-- ******** 'Boundedness' predicates ********",
--
-- "Finite(x) and Finite(y) and not Finite(x + y);",
-- "Finite(x) and not Finite(x * y);",
-- "Finite(x) and not Finite(x + y);",
-- "Is_map(x) and Is_map(y) and not Is_map(x + y);",
--
-- "-- ******** 'Is_map' predicates ********",
--
-- "Is_map(x) and not Is_map(x * y);",
-- "Is_map(x) and not Is_map(x + y);",
--
-- "-- ******** Equivalence relationships ********",
--
-- "(not eqreln(x,x)) or (eqreln(x,y) and not eqreln(y,x));",
-- "eqreln(x,y) and eqreln(z,y) and not eqreln(x,z);",
-- "eqreln(x,y) and eqreln(z,y) and not eqreln(x,w);",
-- "eqreln(x,y) and eqreln(z,y) and eqreln(z,w) and not eqreln(x,w);",
-- "eqreln(x,y) and eqreln(z,w) and y incs w and w incs y and not eqreln(x,z);",
-- "eqreln(x,y) and eqreln(z,w) and y incs w and w incs y and not eqreln(x,z);",
--
-- "-- ******** Partial order relationships ********",
--
-- "not pordreln(x,x);",
-- "pordreln(x,y) and not pordreln(y,x);",
-- "pordreln(x,y) and pordreln(y,z) and not pordreln(x,z);",
-- "pordreln(x,y) and pordreln(z,y) and not pordreln(x,z);",
-- "pordreln(x,y) and pordreln(w,z) and y incs w and w incs y and not pordreln(x,z);",
-- "pordreln(x,y) and pordreln(z,y) and not pordreln(x,z);",
-- "pordreln(x,y) and pordreln(y,z) and pordreln(z,w) and not pordreln(x,w);",
-- "not pordreln(x,y) and not pordreln(y,x);",
--
-- "-- ******** Total order relationships ********",
--
-- "not totordreln(x,x);",
-- "totordreln(x,y) and not totordreln(y,x);",
-- "totordreln(x,y) and totordreln(y,z) and not totordreln(x,z);",
-- "totordreln(x,y) and totordreln(z,y) and not totordreln(x,z);",
-- "totordreln(x,y) and totordreln(w,z) and y incs w and w incs y and not totordreln(x,z);",
-- "totordreln(x,y) and totordreln(z,y) and not totordreln(x,z);",
-- "totordreln(x,y) and totordreln(y,z) and totordreln(z,w) and not totordreln(x,w);",
-- "not totordreln(x,y) and not totordreln(y,x);",
"(not (U incs (v))) and (not ((v) incs U)) and (((U •incin ((v))) or ((v) •incin (U))));",
"(not (U incs (#U))) and (not ((#U) incs U)) and (((U •incin ((#U))) or ((#U) •incin (U))));"];
for stg in stgs loop
if #stg > 3 and stg(1..3) = "-- " then print(); print(stg); continue; end if;
print(); tree := blob_tree(parze_expr(stg)(2));
print(model_blobbed(tree)?"UNSATISFIABLE");
end loop;
-- print("-- ******** TIMING LOOPS ********");
--
-- pairs := [["(c in a or c in b) and c = (a - b) + (b - a) and a /= b;",1000], -- 4 ms to find model
-- ["(d in a or d in b or d in c) and (d incs (a + b + c));",1000], -- 6 ms to determine unsatisfiablity
-- ["{a} incs {a,b,c};",1000], -- 10 ms to find model
-- ["{b,c,d} /= {d,b,c};",1000]]; -- 15 ms to determine unsatisfiablity
--
-- for [stg,repts] in pairs loop
-- print("Starting ",n := 1000," verifications. ",time());
-- for j in [1..n] loop
-- res := model_blobbed(tree(2))?"UNSATISFIABLE";
-- end loop;
-- print("Done ",n," verifications. ",time()); print(res);
--
-- end loop;
--
-- -- miscellaneous other tests
-- print(model_blobbed(parse_expr("(b in s * t & c in s * t & (not(b in c or c in b or c = b))) and (b in s & c in s & (not(b in c or c in b or c = b)));")(2)));
-- form:= "( (s •incin t) or (t •incin s)) and ((Ord(s) and Ord(t) and (t •incin s)) •imp " +
-- "(t = s or t = arb(s - t))) and ((Ord(t) and Ord(s) and (s •incin t)) •imp " +
-- "(s = t or s = arb(t - s))) and ((not((t = s or t = arb(s - t) or s = arb(t - s)))));";
--
-- print(tree := parse_expr(form)(2)); print(model_blobbed(tree)); stop;
-- print(model_blobbed(parse_expr("(b in s * t) and (not(b in s));")(2)));
end test_model_blobbed;
procedure test_build_quantified; -- test of 'build_quantified_version' routine
print("\n****** TEST OF BUILD_QUANTIFIED_VERSION FUNCTION ******\n");
print(); tree := parze_expr("e(x,y);")(2); print(tree);
quantif_list := [["ast_in", "X", "S"], ["DOT_INCIN", "Y", "T"]];
print(unparse(build_quantified_version(tree,quantif_list))); -- add appropriate quantifiers to a formula
print(); tree := parze_expr("e(y);")(2);
quantif_list := [["ast_in", "X", "S"], ["DOT_INCIN", "Y", "T"]];
print(unparse(build_quantified_version(tree,quantif_list))); -- add appropriate quantifiers to a formula
print(); tree := parze_expr("e(y);")(2);
quantif_list := [["ast_in", "X", "S"], ["DOT_INCIN", "Y", "X"]];
print(unparse(build_quantified_version(tree,quantif_list))); -- add appropriate quantifiers to a formula
-- tree := parze_expr("(FORALL x in s , y •incin t | P(x,y));")(2); print(tree);
print(); tree := parze_expr("P(x,y);")(2);
vars_and_ranges := [["DOT_INCIN", "Y", "t"],["ast_in", "X", "s"]];
quantif := make_clause(vars_and_ranges,tree);
print(unparse(quantif));
end test_build_quantified;
procedure test_mls(); -- Eugenio's collection of MLS tests
print("\n****** EUGENIO'S MLS TESTS ******\n");
-- tests for merely Boolean formulas
stgs := ["not (((P incs Q) & (Q incs P)) •eq (P = Q));", -- commutativity of intersection
"P * Q /= Q * P;", -- commutativity of intersection
"(P * Q) * R /= P * (Q * R);", -- associativity of intersection
"P * {} /= {};", -- multiplicative annichilator
"P * P /= P;", -- idempotence
"P * (P * Q) /= P * Q;",
"(P * Q = P) & (Q * P = Q) & (Q /= P);",
"(P * Q = Q) & (Q * R = Q) & (P * R /= P);", -- SATISFIABLE
"(P * Q = P) & (Q * R = Q) & (P * R /= P);",
"((P •incin Q) & ((P*Q) /= P)) or ((not(P •incin Q)) & ((P*Q) = P));",
"((Q incs P) & ((P*Q) /= P)) or ((not(Q incs P)) & ((P*Q) = P));",
"(P •incin Q) & (P*Q /= P);",
"(Q incs P) & (P*Q /= P);",
"(not(P •incin Q)) & (P*Q = P);",
"(not(Q incs P)) & (P*Q = P);",
"U incs P and U - (U-P) /= P;",
"(U-P) * P /= {};",
"U incs P and U incs Q and (( P * Q = P and P * (U-Q) /= {} ) or (P * Q /= P and P * (U-Q) = {}));",
"(P + Q) + R /= P + (Q + R) ;", -- associativity of union
"P + Q /= Q + P;", -- commutativity of union
"{} + P /= P;", -- unit element for union
"P + P /= P;", -- idempotence of union
"P*(Q*(P + R)) /= P*Q;",
"P + (P*Q) /= P;",
"U incs P and U incs Q and ((U-P)*Q) + (P*Q) /= Q;",
"U incs P and U incs Q and U-(P + Q) /= (U-P)*(U-Q);",
"P + (P + Q) /= P + Q;",
"P + (Q + R) /= Q + (P + R);",
"(P + Q)*(P + R) /= P + (Q*R);",
"U incs P and U incs Q and U incs R and (U-P) + (Q + (P*R)) /= (U-P) + (Q + R);",
"U incs P and U incs Q and U incs R and (P + Q) + ((U-P)*R) /= P + (Q + R);",
"P + Q={} and P /= {};",
"U incs P and U incs Q and (P + Q)*(U-(P*Q)) /= (P*(U-Q)) + ((U-P)*Q);"];
for stg in stgs loop
print(); tree := blob_tree(parze_expr(stg)(2));
print(model_blobbed(tree)?"UNSATISFIABLE");
end loop;
end test_mls;
procedure substitution_test; -- substitution test
print("\n****** TEST OF SUBSTITUTE ROUTINE ******\n");
tuples := [["(N * M = 0) •imp (N •PLUS M = #(N + M));","N,M","N;","{N};"],
["a - b * c;","B,C","{e(x): x = f{y} | P(x)};","{f(x): x in s | Q(x)};"],
["y + {x + y + {u + y: u in w}: x in a,y in b};","A,B,Y","{e(x): x = f{y} | P(x)};","{f(x): x in s | Q(x)};","{foo(x): x in s | Q(x)};"],
["{x in a | P(x,b)};","A,B,X","{e(x): x = f{y} | P(x)};","{f(x): x in s | Q(x)};","{foo(x): x in s | Q(x)};"],
["(EXISTS x in a | P(x,b));","A,B,X","{e(x): x = f{y} | P(x)};","{f(x): x in s | Q(x)};","{foo(x): x in s | Q(x)};"],
["a * b * c;","A,C","{e(x): x = f{y} | P(x)};","{f(x): x in s | Q(x)};"],
["range(f);","F","g @ h;"], -- use capitalized form of substitution variables
["ran(f);","F","g @ h;"],
["range(f);","F,FF","g @ h;","g @ h;"],
["(not((one_1_map(f) and (range(f) = s) and (domain(f) = t))));","F","g @ inv(h);"],
["a;","A","b;"]];
for [target,varlist,-] = tuples(k) loop
print("\nSubstituting: "); --,tuples(k)(3..)," for: ",varlist," in: ",target,
targ_tree := parze_expr(target); -- parse the substitution target
variables_list := breakup(varlist,","); -- get the list of variables to be replaced
replacement_map := {[varb,parze_expr(tuples(k)(j + 2))]: varb = variables_list(j)};
var_list := breakup(variables_list,",");
-- parse the formulae to replace the vaiables
print("after substitution: ",unparse(substitute(targ_tree,replacement_map))); -- make substitution
end loop;
end substitution_test;
procedure test_find_diffs; -- test of 'find_diffs' procedure
print("\n****** TEST OF FIND_DIFFS ROUTINE ******\n");
pairs := [["a + (b * c) + {e,f};","a + (b - c) + {e,f};"],
["a + (b * c) + {e,f};","a + (b - c) + {e,g};"],
["a + (b * c) + {e,f};","a + (b - c) + {e,f,g};"]];
for [stg1,stg2] in pairs loop print();
print(unparse(find_diffs(parze_expr(stg1)(2),parze_expr(stg2)(2))));
end loop;
end test_find_diffs;
procedure test_simplify_builtins; -- test of special simplifications for builtin operators
print("\n****** TESTS OF SIMPLIFY_BUILTINS ******\n");
stgs := ["arb({x + y});", -- arb of singleton
"{cdr([[x,y],[y,x]]): x in a, y in b} /= (b •PROD a);",
"{cdr([[x,y],[y,x]]): x in a, y in b} /= {[x,y]: x in b, y in a};",
"{cdr([[x,y],[y,x]]): x in a, y in b} /= {[y,x]: y in b, x in a};",
"{[y,x]: x in a, y in b} /= {[y,x]: y in b, x in a};",
"{[y,x]: x in a, y in b} /= {[x,y]: y in a, x in b};",
-- "(cdr([[[x,y],z],[x,[y,z]]]) = cdr([[[x2,y2],z2],[x2,[y2,z2]]]) and " +
-- "(not [[[x,y],z],[x,[y,z]]] = [[[x2,y2],z2],[x2,[y2,z2]]])) and " +
-- "cdr([[[x,y],z],[x,[y,z]]]) = [x,[y,z]] and " +
-- "cdr([[[x2,y2],z2],[x2,[y2,z2]]]) = [x2,[y2,z2]] and " +
-- "not([x,[y,z]] = [x2,[y2,z2]]);",
-- "((BLB_1 /= 0) and (BLB_2 = 0) and (C in BLB_1) and ((C in S) and BLB_3) and " +
-- "(BLB_4 notin BLB_2) and (not ((BLB_4 = BLB_4) and (C in S) and BLB_3)) and (not FALSE));",
-- "arb({x, y});", -- arb of other enumerated set
-- "arb({x,arb({x + y})});", -- composite arb
-- "car([x,y]);", -- car and cdr
-- "cdr([x,y]);", -- car and cdr
-- "f(car([x,y]),cdr([x,y]));", -- nested car and cdr
-- "a and (b or true);", -- booleans
-- "false and (b or true);", -- booleans
-- "a and (b or (not(false)));", -- booleans
-- "{a,b,c,{d,e}} = {{e,d},b,c,a};", -- disguised equality
-- "{{e,d},c,arb({a}),b};", -- nesting within setformer
-- "[{{e,d},c,arb({a}),b},{a,car([b,c]),c,{d,e}}];", -- nesting within ordered pair
-- "{a,car([b,c]),c,{d,e}} /= {{e,d},c,arb({a}),b};",
-- "if {a,b} = {b,a} then car([b,c]) else cdr([b,c]) end if;", -- a few 'if' cases
-- "if {a,b} /= {b,a} then car([b,c]) elseif x then y else cdr([b,c]) end if;",
-- "{[x,y]}~[x];", -- map application
-- "{[{a,b},y]}~[{b,a}];", -- compound map application
-- "{[{a,b},y]}~[{c,a}];", -- compound map application, notsiplifieable
-- "{a,a};", -- elimination of duplicates
-- "if {b,a,b} /= {b,a} then car([b,c]) elseif {b,a,b} = {a,b,a} then {[{a,b,b},y]}~[{b,a,a}] else cdr([b,c]) end if;",
-- "a + 0;", -- union with null
-- "a * 0;", -- intersection with null
-- "a - 0;", -- difference with null
-- "0 * a;", -- intersection with null
-- "0 - a;", -- difference with null
-- "{a,b,a,c,b} + {d,b,a};", -- union of enumerated sets
-- "{a,b,a,c,b} - {d,b,a};", -- difference of enumerated sets
-- "a = {b,a,c};", -- set would be member of self
-- "{b,a,c} = a;", -- set would be member of self
-- "a /= {b,a,c};", -- set can't be member of self
-- "{b,a,c} /= a;", -- set can't be member of self
-- "{a,b} in {{b,a}};", -- membership in enumerated set
-- "{a,b} in {b,a};", -- membership in enumerated set
-- "a in {c,d,e};", -- membership in enumerated set
-- "{a,b} notin {{b,a}};", -- nonmembership in enumerated set
-- "{a,b} notin {b,a};", -- nonmembership in enumerated set
-- "a notin {c,d,e};", -- nonmembership in enumerated set
-- "f{car([x,y])};", -- multivalued map application
-- "{[x,y]}{x};", -- simplifiable multivalued map application
-- "{car([e(x,y),x]): x in arb({s}), y •incin t | P(x,y) or false};",
-- "{x in arb({s}) | P(x) or false};",
-- "(EXISTS x in arb({s}), y •incin arb({t}) | (P(x,y) and true));",
-- "(FORALL x in arb({s}), y •incin arb({t}) | (P(x,y) and true));",
"a + {};"];
for stg in stgs loop print(); print("simplifies to: ",unparse(simplify_builtins(parze_expr(stg)(2)))); end loop;
end test_simplify_builtins;
procedure test_simplify_onces; -- test of special simplifications for variables appearing once
print("\n****** TESTS OF SIMPLIFY_ONCES ******\n");
stgs := ["a in b;", -- membership
"((BLB_1 /= 0) and (BLB_2 = 0) and (C in BLB_1) and ((C in S) and BLB_3) and (BLB_4 notin BLB_2) and (not ((C in S) and BLB_3)));",
"a •incin b;", -- inclusion
"a in a;", -- membership
"a in b or a in b;", -- membership
"arb(a) in b or cdr(c) in b;", -- arb
"arb(a) in b or cdr(c) in d;", -- arb
"arb(a) in b and cdr(c) in d;", -- arb
"(arb(a) in b) •imp (not(cdr(c) in d));", -- car and cdr
"arb(a) notin b or cdr(c) notin b;", -- car and cdr
"x~[a] + a;", -- functional application
"x{a} + a;", -- multivalued functional application
"a incs b or c = b;", -- inclusion
"a incs b or c = a;", -- inclusion
"x~[a] + x;", -- functional application
"a in arb(b) or a in c;"]; -- arb
for stg in stgs loop print(); print("simplifies to: ",unparse(simplify_onces(parze_expr(stg)(2)))); end loop;
end test_simplify_onces;
procedure test_find_prop_signs; -- test of search routine for propositional variables of one sign
print("\n****** TESTS OF FIND_PROP_SIGNS ******\n");
stgs := ["a or (not b);", -- both have signs
"a or (not (b and a));",
"a •eq (not b);"];
for stg in stgs loop print(); print("propsigns are: ",find_prop_signs(parze_expr(stg)(2))); end loop;
end test_find_prop_signs;
procedure test_exploit_prop_signs; -- test of search routine exploiting propositional variables of one sign
print("\n****** TESTS OF EXPLOIT_PROP_SIGNS ******\n");
stgs := ["a or c = d;", -- has sign
"(not a) or c = d;",
"a and c = d;", -- has sign
"(not a) and c = d;",
"a •imp (c = d);", -- has sign
"(not a) •imp (c = d);",
"(a •imp (c = d)) or a;", -- no sign
"((not a) •imp (c = d)) or a;", -- has sign
"a •eq (c = d);", -- no sign
"(not a) •eq (c = d);"];
for stg in stgs loop print(); print("simplified: ",unparse(exploit_prop_signs(parze_expr(stg)(2)))); end loop;
end test_exploit_prop_signs;
procedure test_count_free_vars; -- test of count_free_vars routine
print("\n****** TESTS OF COUNT_FREE_VARS ******\n");
stgs := ["arb({x + y});", -- arb of singleton
"arb({x, y});", -- arb of other enumerated set
"arb({x,arb({x + y})});",
"car([x,y]);",
"cdr([x,y]);",
"f(car([x,y]),cdr([x,y]));",
"a and (b or true);",
"false and (b or true);",
"a and (b or (not(false)));"];
for stg in stgs loop print(); print(count_free_vars(parze_expr(stg)(2))); end loop;
end test_count_free_vars;
procedure test_boil_down_blobbed(); -- test overall simplification of blobbed expression
print("\n****** TESTS OF BOIL_DOWN_BLOBBED ******\n");
stgs := ["a •incin b;",
-- "(a in b) or (c in a) or (c notin d) or (d notin c) or (a in b);", -- identical contexts
-- "(a in b) or (a in c) or (b in c) or (c in a);",
-- "[x,y] =[z,[u,v]] and [x,y] =[z1,[u1,v1]];",
"((((0 /= 1) and (0 /= 1)) and (not ((BLB_1 * BLB_2) = 0))) and ((({0} * {1}) = 0) •imp (((BLB_1 * BLB_2) = 0))));",
-- "[x,y] =[z,[u,v]] and [x,y] =[z1,[u1,v1]];",
-- "cdr([[[x,y],z],[x,[y,z]]]) = cdr([[[x2,y2],z2],[x2,[y2,z2]]]) and x /= x2 and y /= y2;",
--
-- "(cdr([[[x,y],z],[x,[y,z]]]) = cdr([[[x2,y2],z2],[x2,[y2,z2]]]) and " +
-- "(not [[[x,y],z],[x,[y,z]]] = [[[x2,y2],z2],[x2,[y2,z2]]])) and " +
-- "cdr([[[x,y],z],[x,[y,z]]]) = [x,[y,z]] and " +
-- "cdr([[[x2,y2],z2],[x2,[y2,z2]]]) = [x2,[y2,z2]] and " +
-- "not([x,[y,z]] = [x2,[y2,z2]]);",
-- "((S /= 0) and (BLB_1 = 0) and (C in S) and (not (BLB_2 notin BLB_1)));",
--
-- "((BLB_1 /= 0) and (BLB_2 = 0) and (C in BLB_1) and ((C in S) and BLB_3) and " +
-- "(BLB_4 notin BLB_2) and (not ((BLB_4 = BLB_4) and (C in S) and BLB_3)) and (not FALSE));",
--
-- "((not (S and (V in BLB_1) and (C = BLB_2) and BLB_3)) and (S and (V in BLB_4) and " +
-- "(C = BLB_5) and BLB_6) and ((S •imp (BLB_1 = BLB_4)) and ((S and (V in BLB_1)) •imp (BLB_2 = BLB_5)) " +
-- "and ((S and (V in BLB_1)) •eq (BLB_3 •eq BLB_6))));",
--
-- "(((((S •incin T) or (T •incin S)) and (((BLB_1 and BLB_2) and (T •incin S)) •imp " + -- failure case
-- "((T = S) or (T = (arb (S - T)))))) and (((BLB_2 and BLB_1) and (S •incin T)) •imp " +
-- "((S = T) or (S = (arb (T - S)))))) and (not (((T = S) or (T = (arb (S - T)))) or (S = (arb (T - S))))));",
--
-- "((((((BLB_1 /= S) and ((((A in BLB_1) and (A notin S)) or (not (A in BLB_1))) and (A in S))) " + -- failure case
-- "and (((A in BLB_2) and (A notin S)) or ((A notin BLB_2) and (A in S)))) and ((A notin BLB_2) " +
-- "and (A in S))) and (((not ([A,BLB_3] in G)) or (A /= CAR([A,BLB_3]))) and (A in S))) and " +
-- "(not (([A,BLB_3] notin BLB_4) and (A in S))));",
--
-- "((((((((((F = BLB_1) and (((not BLB_2) or (BLB_3 /= BLB_4)) or (BLB_5 /= BLB_6))) and " + -- failure case
-- "((F = BLB_1) and ((not BLB_2) or (BLB_5 /= BLB_6)))) and (BLB_5 /= BLB_6)) and (BLB_7 /= BLB_6)) " +
-- "and (BLB_8 /= BLB_6)) and (BLB_9 /= BLB_6)) and (CDR([[X,Y],[Y,X]]) = [Y,X])) and " +
-- "(BLB_10 /= BLB_6)) and (not FALSE));",
--
-- "((((((((((((F = BLB_1) and (((not BLB_2) or (BLB_3 /= BLB_4)) or (BLB_5 /= BLB_6))) and " +
-- "((F = BLB_1) and ((not BLB_2) or (BLB_5 /= BLB_6)))) and ((F = BLB_1) and (not BLB_2))) " +
-- "and ((not BLB_7) or (not BLB_8))) and (not BLB_7)) and ((not IS_MAP(F)) or (not BLB_9))) " +
-- "and (not BLB_9)) and (not BLB_10)) and (not BLB_11)) and ((CAR([[X,Y],[Y,X]]) = CAR([[X2,Y2],[Y2,X2]])) " +
-- "and (not ([[X,Y],[Y,X]] = [[X2,Y2],[Y2,X2]])))) and (not FALSE));",
--
-- "(((((((((((((((((((BLB_1 and (T •incin S)) and (X in S)) and (Y in X)) and " +
-- "(BLB_2 notin BLB_3)) and (not (BLB_3 incs T))) and (BLB_3 = if (T •incin BLB_4) " +
-- "then T else (arb (T - BLB_4)) end if)) and (((T - BLB_4) /= 0) and " +
-- "(BLB_3 = (arb (T - BLB_4))))) and (BLB_3 in (T - BLB_4))) and (BLB_3 in S)) " +
-- "and (((BLB_5 and BLB_6) and BLB_7) and (Y •incin X))) and (BLB_8 •incin BLB_4)) " +
-- "and (BLB_2 = if (T •incin BLB_8) then T else (arb (T - BLB_8)) end if)) and " +
-- "(((T - BLB_8) /= 0) and (BLB_2 = (arb (T - BLB_8))))) and ((T - BLB_8) incs " +
-- "(T - BLB_4))) and ((BLB_2 in BLB_3) or (BLB_2 = BLB_3))) and ((BLB_2 = BLB_3) and " +
-- "(BLB_2 in (T - BLB_4)))) and (BLB_2 notin BLB_4)) and ((BLB_2 /= BLB_9) or " +
-- "(Y notin X))) and (not FALSE));",
--
--
-- "((x = y) and BLB_10 and (#x = y));",
--
-- "((((((((((((((T •incin S) and (not ((#T) •incin (#S)))) and ((BLB_1 and (BLB_2 = S)) " +
-- "and (BLB_3 = (#S)))) and (((BLB_4 and (F = BLB_5)) and (BLB_6 = BLB_3)) and (BLB_7 = BLB_2))) " +
-- "and BLB_8) and (BLB_9 •incin (#S))) and BLB_10) and ((#BLB_9) •incin (#S))) and (BLB_11 = T)) " +
-- "and ((((BLB_12 and BLB_13) and (BLB_14 = T)) and (BLB_15 = (#T))) and (not BLB_16))) and " +
-- "((#S) in (#T))) and BLB_17) and ((((#BLB_9) = (#S)) or ((#BLB_9) in (#S))) and " +
-- "((#S) •incin (#T)))) and (not ((#BLB_9) in (#T))));",
--
-- "(((((((((not ((BLB_1 and BLB_2) and (BLB_3 = Y))) and BLB_1) and (BLB_3 /= Y)) and " +
-- "(BLB_3 = (arb BLB_4))) and (BLB_3 = (arb BLB_5))) and (BLB_3 = (arb BLB_6))) and " +
-- "(BLB_3 = (arb BLB_7))) and (BLB_3 = (arb if (CAR([X,Y]) in {X}) then {CDR([X,Y])} else 0 end if)))" +
-- " and (not ((CAR([X,Y]) in {X}) and ({CDR([X,Y])} = {Y}))));",
--
-- "(((((((((X /= Z) and (BLB_1 /= Y)) and (BLB_1 = (arb BLB_2))) and (BLB_1 = (arb BLB_3))) " +
-- "and (BLB_1 = (arb BLB_4))) and (BLB_1 = (arb BLB_5))) and (BLB_1 = (arb (BLB_6 + BLB_7)))) " +
-- "and (BLB_1 = (arb (if (CAR([X,Y]) in {X}) then {CDR([X,Y])} else 0 end if " +
-- "+ if (CAR([Z,W]) in {X}) then {CDR([Z,W])} else 0 end if)))) and (not (((CAR([X,Y]) in {X}) " +
-- "and (CDR([X,Y]) = Y)) and (CAR([Z,W]) notin {X}))));",
--
-- "(((((((((((BLB_1 /= BLB_2) and ((#(BLB_3 + BLB_4)) /= (#(BLB_5 + BLB_6)))) and " +
-- "((BLB_7 and (BLB_8 = (#N))) and (BLB_9 = N))) and ((BLB_10 and (BLB_11 = (#M))) and " +
-- "(BLB_12 = M))) and (BLB_13 and BLB_14)) and (F = BLB_15)) and (G = BLB_16)) and " +
-- "((((BLB_17 and (BLB_18 = BLB_19)) and (BLB_20 = BLB_21)) and BLB_22) and BLB_23)) and " +
-- "(BLB_18 = (BLB_24 + BLB_25))) and (BLB_18 = (BLB_26 + BLB_27))) and " +
-- "(not ((((CDR([X,0]) = 0) and (CAR([X,1]) = X)) and (CDR([X,1]) = 1)) and (CAR([X,1]) = X))));",
"(x and a and b) or x;"];
for stg in stgs loop print(); pet2 := parze_expr(stg)(2); print(" simplifies to: ",unparse(boil_down_blobbed(pet2))); end loop;
end test_boil_down_blobbed;
procedure test_algebra(); -- initial tests of ALGEBRA deduction
-- the first component of each of the pairs appearing in the following test gives the ring membership statements
-- needed for an algebraic equality to be deduced, and the second component gives such an algebraic identity.
print("\n****** TESTS OF ALGEBRAIC DEDUCTION ******\n");
pairs := [["b in Si and ((b in Si) •imp (a in Si)) and c in Si;","arb(b) = arb(c);"],
["b in Si and ((b in Si) •imp (a in Si)) and c in Si;",
"(((a •S_TIMES {c}) •MINUS (b •S_TIMES c)) •S_PLUS S_1) = (S_1 •S_PLUS ((a •MINUS b) •S_TIMES {c}));"],
["b in Si and ((b in Si) •imp (a in Si)) and c in Si;",
"(((a •S_TIMES {c}) •MINUS (b •S_TIMES c)) •S_PLUS S_1) incs (S_1 •S_PLUS ((a •MINUS b) •S_TIMES {c}));"],
["b in Si and ((b in Si) •imp (a in Si)) and c in Si;",
"(((a •S_TIMES c) •MINUS (b •S_TIMES c)) •S_PLUS S_1) = (S_1 •S_PLUS ((a •MINUS b) •S_TIMES {c}));"],
["b in Si and ((b in Si) •imp (a in Si)) and c in Si;",
"(((a •S_TIMES c) •MINUS (b •S_TIMES c)) •S_PLUS S_1) = (S_1 •S_PLUS ((a •MINUS b) •S_TIMES c));"],
["b in Si and ((b in Si) •imp (a in Si));",
"(((a •S_TIMES c) •MINUS (b •S_TIMES c)) •S_PLUS S_1) = (S_1 •S_PLUS ((a •MINUS b) •S_TIMES c));"],
["b in Si and ((b in Si) •imp (a in Si)) and c in Si;",
"(((a •S_TIMES c) •MINUS (b •S_TIMES c)) •S_PLUS S_1) = (S_0 •S_PLUS ((a •MINUS b) •S_TIMES c));"],
["b in Si and ((b in Si) •imp (next(b) in Si)) and a in Si;",
"(((a •S_TIMES next(b)) •MINUS (b •S_TIMES next(b))) •S_PLUS S_1) = (S_1 •S_PLUS ((a •MINUS b) •S_TIMES next(b)));"],
["b in RA and ((b in RA) •imp (a in RA)) and c in RA;",
"(((a •RA_TIMES c) •RA_MINUS (b •RA_TIMES c)) •RA_PLUS RA_1) = (RA_1 •RA_PLUS ((a •RA_MINUS b) •RA_TIMES c));"]];
for [context,formula] in pairs loop
print(); print(algebra(parze_expr(formula)(2),parze_expr(context)(2))?"VERIFIED");
end loop;
enable_algebra(["RA", "•RA_PLUS", "•RA_TIMES", "•RA_MINUS", "RA_0", "RA_1"],relevant_theorem_list);
-- enable elementary algebraic deduction for rationals
print(); context := parze_expr("b in RA and ((b in RA) •imp (a in RA)) and c in RA;")(2);
formula := parze_expr("(((a •RA_TIMES c) •RA_MINUS (b •RA_TIMES c)) •RA_PLUS RA_1) = (RA_1 •RA_PLUS ((a •RA_MINUS b) •RA_TIMES c));")(2);
print(algebra(formula,context)?"VERIFIED");
end test_algebra;
procedure test_equality_inference(); -- initial tests of equality inferencing
print("\n****** TESTS OF VERIFY_EQUALITY ROUTINE ******\n");
triples := [["[[x,y],w];","[[u,y],z];","u = x and z = w;"], -- [eq,eq2,supporting_statements]
["[[x,y],w];","[[u,y],z];","u = x;"],
["[[x,y],w] = a;","[[u,y],z] = b;","u = x and a = b;"],
["[[x,y],w] = a;","[[u,y],z] = b;","u = x and z = w and a = b;"],
["f(f(x,y),w);","f(f(u,y),z);","u = x and z = w;"],
["f(f(x,y),w);","f(f(u,y),z);","u = x;"],
["f(f(x,y),w) = a;","f(f(u,y),z) = b;","u = x and a = b;"],
["f(f(x,y),w) = a;","f(f(u,y),z) = b;","u = x and z = w and a = b;"],
["f(g~[f(x,y)],w);","f(g~[f(u,y)],z);","u = x and z = w;"],
["f(g~[f(x,y)],w);","f(g~[f(u,y)],z);","u = x;"],
["f(g~[f(x,y)],w) = a;","f(g~[f(u,y)],z) = b;","u = x and a = b;"],
["f(g~[f(x,y)],w) = a;","f(g~[f(u,y)],z) = b;","u = x and z = w and a = b;"],
["not (f(g~[f(x,y)],w) = a);","not (f(g~[f(u,y)],z) = b);","u = x and a = b;"],
["not (f(g~[f(x,y)],w) = a);","not (f(g~[f(u,y)],z) = b);","u = x and z = w and a = b;"],
["{a + f(x,s),b,c};","{b,a + f(v,s),c};","u = x;"],
["{a + f(x,s),b,c};","{b,a + f(u,s),c};","u = x;"],
["{x + f(x,s),b,c};","{b,u + f(u,s),c};","u = x;"],
["(FORALL x in s, u in v | P(x,u));","(FORALL y in t, w in z | P(y,w));","s = t and v = z;"],
["(FORALL x in s | P(x));","(FORALL y in t | P(y));","s = u;"],
["(FORALL x in s | P(x));","(FORALL y in t| P(y));","s = t;"],
["(FORALL x in s, u in v | P(x,u));","(FORALL y in t, w in v | P(y,w));","s = s2;"],
["(FORALL x in s, u in v | P(x,u));","(FORALL y in t, w in v | P(y,w));","s = t;"],
["(FORALL x in s, u in v | P(x,u));","(FORALL y in t, w in z | P(y,w));","s = s2 and v = z;"],
["(FORALL x in s, u in f(v,z) | P(x,u));","(FORALL y in t, w in f(t,z) | P(y,w));","s = t and v = z;"],
["(FORALL x in s, u in f(v,z) | P(x,u));","(FORALL y in t, w in f(z,v) | P(y,w));","s = t and v = z;"],
["(FORALL x in s, u in f(v,x) | P(x,u));","(FORALL y in t, w in f(x,v) | P(y,w));",
"s = t and (FORALL x in s | f(v,x) = f(x,v));"],
["{P(x,u): x in s, u in f(v,x)};","{P(y,w): y in t, w in f(y,v)};","s = t and (FORALL x in s | f(v,x) = f(x,v));"],
["{P(x,u): x in s, u in f(v,x)};","{R(y,w): y in t, w in f(y,v)};",
"s = t and (FORALL x in s | f(v,x) = f(x,v)) and (FORALL x in s, u in f(v,x)| P(x,u) = R(x,u));"],
["{P(x,u): x in s, u in f(v,x)};","{R(w,y): y in t, w in f(y,v)};",
"s = t and (FORALL x in s | f(v,x) = f(x,v)) and (FORALL x in s, u in f(v,x)| P(x,u) = R(u,x));"],
["{P(x,u): x in s, u in f(v,x)};","{P(y,w): y in t, w in f(y,v)};",
"s = t and (FORALL x in s | f(v,x) = f(x,v));"],
["{x in s | P(x)};","{x in t | P(x)};","s = t;"],
["{x in s | P(x)};","{x in t | P(x)};","s = s2;"],
["{x in s | P(x)};","{x in t | R(x)};","s = t;"],
["{x in s | P(x)};","{x in t | R(x)};","s = t and (FORALL x in s | P(x) •eq R(x));"],
["{x in s | P(x)};","{x in t | R(x)};","s = s2 and (FORALL x in u | P(x) •eq R(X));"],
["{P(x,u): x in s, u in f(v,x) | A(x,y)};","{P(y,w): y in t, w in f(y,v) | A(x,y)};",
"s = t and (FORALL x in s | f(v,x) = f(x,v));"],
["{P(x,u): x in s, u in f(v,x) | A(x,u)};","{P(y,w): y in t, w in f(y,v) | A(y,w)};",
"s = t and (FORALL x in s | f(v,x) = f(x,v));"],
["{P(x,u): x in s, u in f(v,x) | A(x,y)};","{P(y,w): y in t, w in f(y,v) | B(x,y)};",
"s = t and (FORALL x in s | f(v,x) = f(x,v));"],
["{P(x,u): x in s, u in f(v,x) | A(x,u)};","{P(y,w): y in t, w in f(v,y) | A(y,w)};",
"s = t and (FORALL x in s | f(v,x) = f(x,v));"],
["{P(x,u): x in s, u in f(v,x) | A(x,u)};","{P(y,w): y in t, w in f(y,v) | B(y,w)};",
"s = t and (FORALL x in s | f(v,x) = f(x,v)) and (FORALL x in s, y in f(v,x) | A(x,y) •eq B(x,y));"],
["{P(x,u): x in s, u in f(v,x) | A(x,u)};","{P(y,w): y in t, w in f(y,v) | B(w,y)};",
"s = t and (FORALL x in s | f(v,x) = f(v,x)) and (FORALL x in s, y in f(v,x) | A(x,y) •eq B(y,x));"],
["{P(x,u): x in s, u in f(v,x) | A(x,u)};","{P(x,u): x in t, u in f(x,v) | B(u,x)};",
"s = t and (FORALL x in s | f(v,x) = f(x,v)) and (FORALL x in s, y in f(v,x) | A(x,y) •eq B(y,x));"],
["{P(x,u): x in s, u in f(v,x) | A(x,u)} + {P(x,u): x in s, u in f(v,x) | A(x,u)};",
"{P(x,u): x in t, u in f(x,v) | B(u,x)} + {P(x,u): x in t, u in f(x,v) | B(u,x)};",
"s = t and (FORALL x in s | f(v,x) = f(x,v)) and (FORALL x in s, y in f(v,x) | A(x,y) •eq B(y,x));"]];
for [eq1,eq2,supporting_statements] in triples loop
nprint("\nformula1: "); tree1 := parze_expr(eq1)(2);
nprint("formula2: "); tree2 := parze_expr(eq2)(2);
context := parze_expr(supporting_statements)(2);
print("equality follows: ",verify_equality(tree1,tree2,context,false));
end loop;
end test_equality_inference;
procedure test_equality_more; -- supplemental equality tests
print("\n****** SUPPLEMENTAL EQUALITY TESTS ******\n");
triples := [["{x in s| P(x)};","{P(y,w): y in t, w in f(y,v)};","s = t and (FORALL x in s | f(v,x) = f(x,v));"],
["{P(x,u): x in s, u in f(v,x)};","{R(y,w): y in t, w in f(y,v)};",
"s = t and (FORALL x in s | f(v,x) = f(x,v)) and (FORALL x in s, u in f(v,x)| P(x,u) = R(x,u));"],
["{P(x,u): x in s, u in f(v,x)};","{R(w,y): y in t, w in f(y,v)};",
"s = t and (FORALL x in s | f(v,x) = f(x,v)) and (FORALL x in s, u in f(v,x)| P(x,u) = R(u,x));"],
["{P(x,u): x in s, u in f(v,x)};","{P(y,w): y in t, w in f(y,v)};",
"s = t and (FORALL x in s | f(v,x) = f(x,v));"],
["{e(x): x in s};","{e(y): y in t};","s = t;"],
["{e(x): x in s};","{e(y): y in t};","s = u;"],
["{a + f(x,s),b,c};","{b,a + f(v,s),c};","u = x;"],
["{x + f(x,s),b,c};","{b,u + f(v,s),c};","u = x;"],
["{a + {e(x): x in s},b,c};","{b,a + {e(y): y in s},c};","u = x and a = b;"],
["{x + {e(x): x in s},b,c};","{b,u + {e(y): y in s},c};","u = x and a = b;"],
["not (f(g~[f(x,y)],w) = a);","not (f(g~[f(u,y)],z) = b);","u = x and z = w and a = b;"]];
for [eq1,eq2,supporting_statements] in triples loop
nprint("\nformula1: "); tree1 := parze_expr(eq1)(2);
nprint("formula2: "); tree2 := parze_expr(eq2)(2);
context := parze_expr(supporting_statements)(2);
print("equality follows: ",verify_equality(tree1,tree2,context,false));
end loop;
end test_equality_more;
procedure timing_tests; -- a few tests of MLSS timing
print("\n******TESTS OF MLSS TIMING ******\n");
prev_def_consts := {}; -- third param of 'verify_instance'
--test_verify_instance(); stop; -- initial tests of 'verify_instance' procedure
print(time());for j in [1..5000] loop
tree := parse_expr("{a} incs {a,b} and a /= b;");
end loop;
print(time(),model_blobbed(tree(2))?"UNSATISFIABLE");
print(time());for j in [1..5000] loop
tree := parse_expr("(c in a or c in b or c in d) and c = a + b + d;");
end loop;
print(model_blobbed(tree(2))?"UNSATISFIABLE");
print(time());for j in [1..5000] loop
tree := parse_expr("(c in a or c in b or c in d) and c = a + b + c;");
end loop;
print(model_blobbed(tree(2))?"UNSATISFIABLE");
end timing_tests;
procedure test_proof_by_computation; -- proof by computation test
-- Proof by computation gives us a way of evaluating set-theoretic expressions in some fortunate cases.
-- To apply it to a set-theoretic expression e, we find all the free variables of e, and replace these by atoms,
-- equal or distinct, in all possible patterns. It is best to handle expressions of no more than 6,
-- or perhaps 7, free variables. For each of these patterns the expression is evaluated using
-- the recursive definition of all the function symbols appearing in it. However, evaluation aborts
-- and returns the result OM whenever it encounters an illegal operation such as an iteration over an atom,
-- comparison of an atom to a set, or counting of an atom.
print("\n******TESTS OF PROOF BY COMPUTATION ******\n");
-- equality_and_membership_tests(); -- preliminary tests
-- equality tests involving sets
print("test666: ",comp_verif("is_nonneg(x) & is_nonneg(S_Rev(x)) & (x /= [0,0])"));
print("test1000: ",comp_verif("is_SI([1,0])")); -- true
print("test1001: ",comp_verif("is_SI([{{}},0])")); -- true
print("test1002: ",comp_verif("12345 in Z")); -- true
print("test1003: ",comp_verif("[12345,67899] in Si")); -- false
print("test1003a: ",comp_verif("[0,67899] in Si")); -- true
print("test1004: ",comp_verif("[[12345,67899],[12345,67899]] in Fr")); -- true
print("test1004a: ",comp_verif("[[12345,67899],[0,0]] in Fr")); -- false
print("test1005: ",comp_verif("666 •PLUS 666 = 1332")); -- true
print("test1006: ",comp_verif("5 •TIMES 5 = 25")); -- true
print("test1006a: ",comp_verif("5 •TIMES 5 = 24")); -- false
print("test1007: ",comp_verif("25 •TIMES 25 = 625")); -- true
print("test1008: ",comp_verif("2500 •TIMES 2500 = 6250000")); -- true
print("test1009: ",comp_verif("2500 •MOD 333 = 169")); -- true
print("test1010: ",comp_verif("2500 •MINUS 333 = 2167")); -- true
print("test1011: ",comp_verif("2500 •MINUS 2501 = 0")); -- true
print("test1012: ",comp_verif("0 = 2500 •MINUS 2501")); -- true
print("test1013a: ",comp_verif("[1,0] •S_TIMES [0,4]")); -- [0,4]
print("test1013b: ",comp_verif("[0,2] •S_TIMES [2,0]")); -- [0,4]
print("test1013: ",comp_verif("SAME_FRAC([[1,0],[2,0]],[[0,2],[0,4]])")); -- true
print("test1014a: ",comp_verif("([1,0] •S_TIMES [77,0])")); -- [77,0]
print("test1014b: ",comp_verif("([7,0] •S_TIMES [11,0])")); -- [77,0]
print("test1014: ",comp_verif("SAME_FRAC([[1,0],[7,0]],[[11,0],[77,0]])")); -- true
print("test1015a: ",comp_verif("([1,0] •S_TIMES [0,4])")); -- [0,4]
print("test1015b: ",comp_verif("([2,0] •S_TIMES [0,3])")); -- [0,6]
print("test1015: ",comp_verif("SAME_FRAC([[1,0],[2,0]],[[0,3],[0,4]])")); -- false
print("test1016: ",comp_verif("FR_IS_NONNEG([[1,0],[2,0]])")); -- true
print("test1017: ",comp_verif("FR_IS_NONNEG([[1,0],[0,2]])")); -- false
print("test1018: ",comp_verif("FR_IS_NONNEG([[1,0],[0,0]])")); -- OM
print("test1019: ",comp_verif("FR_IS_NONNEG([[0,0],[1,0]])")); -- true
print("test1020: ",comp_verif("FR_IS_NONNEG([[0,0],[0,2]])")); -- true
print("test1021: ",comp_verif("FR_IS_NONNEG([[0,0],[0,0]])")); -- true
stop;
print("test1: ",comp_verif("{x} = {x,x}")); -- true
print("test2: ",comp_verif("{x,x} = {x,x,x}")); -- true
print("test3: ",comp_verif("{x,y} = {y,x,x}")); -- true
print("test4: ",comp_verif("{x,y} = {z,x,x}")); -- OM
print("test5: ",comp_verif("{x,y} = {{y},x,x}")); -- false
print("test6: ",comp_verif("{x,y} = {y,{x},x}")); -- OM
print("test7: ",comp_verif("{{x},y} = {y,{x,x},{x}}")); -- true
print("test8: ",comp_verif("{{x},y} = {{y},{x,x},{x}}")); -- OM (but could possibly do better: see as false)
print("test9: ",comp_verif("[{x},x] = [{x,x},x]")); -- true
print("test10: ",comp_verif("[{x},x] = [{x,x},y]")); -- OM
print("test11: ",comp_verif("[{x},x] = [{x,x},{x,y}]")); -- false
print("test12: ",comp_verif("#{x}")); -- 1
print("test13: ",comp_verif("#x")); -- OM
print("test14: ",comp_verif("#{x,y}")); -- OM
print("test15: ",comp_verif("#{x,{{x},y}}")); -- 2
print("test16: ",comp_verif("#{x,y,{{x},y}}")); -- OM
print("test17: ",comp_verif("#{x,{{y,x}},{{x},y}}")); -- 3
print("test19: ",comp_verif("if x = {y,x} then x elseif y = {y,x} then y else zz end if = zz")); -- true
print("test20: ",comp_verif("if x = {y,x} then x elseif y = {x} then y else zz end if = zz")); -- OM
print("test21: ",comp_verif("if x = {y,x} then x elseif y = {y,x} then y else #{x} end if = #{x}")); -- true
print("test22: ",comp_verif("if x = {y,x} then x elseif y = {y,x} then y else #{x} end if = {{}}")); -- true
print("test23: ",comp_verif("#{x} = {{}}")); -- true
print("test24: ",comp_verif("{{}} = {{}}")); -- true
print("test25: ",comp_verif("{{}}")); -- {{}}
print("test26: ",comp_verif("Is_map({[x,y]})")); -- true
print("test27: ",comp_verif("Svm({[x,y]})")); -- true
print("test28: ",comp_verif("Is_map({[x,y],[y,x]})")); -- true
print("test29: ",comp_verif("Svm({[x,y],[y,x]})")); -- true
print("test30: ",comp_verif("Is_map({[x,y],[y,zz]})")); -- true
print("test31: ",comp_verif("Svm({[x,y],[y,zz]})")); -- OM
print("test32: ",comp_verif("(x /= y) •imp Svm({[x,y],[y,zz]})")); -- true
print("test33: ",comp_verif("({{}} in #{x,y}) •imp Svm({[x,y],[y,zz]})")); -- true
print("test34: ",comp_verif("{{}} in #{x,y}")); -- OM
print("test35: ",comp_verif("{} in #{x,y}")); -- true
print("test36: ",comp_verif("{} in {{}}")); -- true
print("test37: ",comp_verif("One_1_map({[x,y]})")); -- true
print("test37a: ",comp_verif("One_1_map({[s,0]})")); -- true
print("test38: ",comp_verif("One_1_map({[x,y],[y,x]})")); -- true
print("test39: ",comp_verif("One_1_map({[x,y],[y,zz],[zz,x]})")); -- OM
print("test40: ",comp_verif("((x /= y) & (y /= zz) & (zz /= x)) •imp One_1_map({[x,y],[y,zz],[zz,x]})")); -- true
print("test41: ",comp_verif("Is_integer({{}})")); -- true
print("test42: ",comp_verif("Is_integer({{x}})")); -- false
print("test43: ",comp_verif("Is_integer({x})")); -- OM
print("test44: ",comp_verif("Is_seq({[{},x],[{{}},y],[{{},{{}}},y]})")); -- true
print("test45: ",comp_verif("Is_seq({[{{}},y],[{{},{{}}},y]})")); -- false
print("test46: ",comp_verif("domain({[{},x],[{{}},y],[{{},{{}}},y]}) = {{},{{}},{{},{{}}}}")); -- true
print("test47: ",comp_verif("(#{x,y} = {{}}) •eq (x = y)")); -- true
print("test48: ",comp_verif("({[{},x]} •Seq_cat {[{},y]}) = {[{},x],[{{}},y]}")); -- true
print("test49: ",comp_verif("({[{},x]} •Seq_cat {[{},y],[{{}},zz]}) = {[{},x],[{{}},y],[{{},{{}}},zz]}")); -- true
print("test50: ",comp_verif("#({[{},x]} •Seq_cat {[{},y],[{{}},zz]}) = {{},{{}},{{},{{}}}}")); -- true
print("test51: ",comp_verif("(#range({[{},x]} •Seq_cat {[{},y]}) = {{},{{}}}) •eq (x /= y)")); -- true
print("test52: ",comp_verif("{[x,y]}~[x] = y")); -- true
print("test53: ",comp_verif("{[x,y],[u,v]}~[x] = y")); -- OM
print("test54: ",comp_verif("{[x,y],[u,y]}~[x] = y")); -- true
print("test55: ",comp_verif("(x /= u) •imp ({[x,y],[u,v]}~[x] = y)")); -- true
print("test56: ",comp_verif("(#domain({[x,y],[u,v]})= {{},{{}}}) •imp ({[x,y],[u,v]}~[x] = y)")); -- true
print("test57: ",comp_verif("Inv({[x,y]}) = {[y,x]}")); -- true
print("test58: ",comp_verif("Inv({[x,y]} + {[u,v]})= {[y,x],[v,u]}")); -- true
print("test59: ",comp_verif("{[y,u]} @ {[x,y]} = {[x,u]}")); -- true
print("test60: ",comp_verif("((x /= y) & (u = v)) •imp (#({x,y} •PROD {u,v}) = {{},{{}}})")); -- true
print("test61: ",comp_verif("{car([x,y])} = {x}")); -- true
print("test62: ",comp_verif("arb({cdr([x,y])}) = y")); -- true
print("test63: ",comp_verif("([x,y] = [u,v]) •imp ([y,x] = [v,u])")); -- true
print("test64: ",comp_verif("([[x,y],a] = [[u,v],b]) •imp ([y,[x,a]] = [v,[u,b]])")); -- true
print("test65: ",comp_verif("([[x,y],a] = [[u,v],b]) •imp ([y,[x,a]] = [[v,b],u])")); -- OM
print("test66: ",comp_verif("0 /= {0}")); -- true
print("test67: ",comp_verif("0 /= 1")); -- true
print("test68: ",comp_verif("x /= {x}")); -- true
print("test69: ",comp_verif("x /= {y}")); -- OM
print("test70: ",comp_verif("arb({y}) = y")); -- true
print("test71: ",comp_verif("arb({{u,v}}) = {u,v}")); -- true
print("test72: ",comp_verif("arb({u,v}) = v")); -- OM
print("test73: ",comp_verif("arb({u,{u,v}}) = u")); -- true
print("test74: ",comp_verif("arb({{y},{{y},v}}) = {y}")); -- OM (can't handle intermediate logic)
print("test75: ",comp_verif("arb({{y},{w},{{y},{w}}}) = {y}")); -- OM
print("test76: ",comp_verif("arb({{y},{{{y}},v}}) = {y}")); -- OM, because {{{y}},v}} cannot be {y}, so either {y} or {{{y}},v}} ould be the arb
print("test77: ",comp_verif("arb({{{y}},{{{y}},v}}) = {{y}}")); -- true
print("test78: ",comp_verif("{{y}} = {{y}}")); -- true
print("test79: ",comp_verif("arb({{y},{{y},{{y}}}}) = {y}")); -- true
print("test80: ",comp_verif("Svm({[[x,y],[y,x]]: x in s,y in t | P(x,y)})")); -- true
print("test81: ",comp_verif("Svm({[[x,y],x]: x in s,y in t | P(x,y)})")); -- true
print("test82: ",comp_verif("Svm({[x,[x,y]]: x in s,y in t | P(x,y)})")); -- OM
print("test83: ",comp_verif("Svm({[x,{x}]: x in s | P(x)})")); -- true
print("test84: ",comp_verif("One_1_map({[[x,y],[y,x]]: x in s,y in t | P(x,y)})")); -- true
print("test85: ",comp_verif("One_1_map({[[x,y],x]: x in s,y in t | P(x,y)})")); -- OM
print("test86: ",comp_verif("One_1_map({[x,[x,y]]: x in s,y in t | P(x,y)})")); -- OM
print("test87: ",comp_verif("One_1_map({[x,{x}]: x in s | P(x)})")); -- true
tree := parze_expr("{[x,f(x)]: x in s | P(x)} @ {[g(y1,yn),h(y1,yn)]: y1 in t1,yn in tn | Q(y1,yn)}" + ";")(2);
map_comp_simplif(tree); -- simplify a map composition
print("test88: ",comp_verif("{x + y: x in {{}}, y in {{}} | #x = {}} = {}")); -- true
--->current_test
print("test89: ",comp_verif("{x,{}} = {{y},x,x}")); -- (which should produce FALSE);
print("test90: ",comp_verif("({x,{}} = {x}) •imp (x = {})")); -- (which should give TRUE);
print("test91: ",comp_verif("({x,{}} = {x}) •imp (#x = {})")); -- (which should give TRUE);
print("test92: ",comp_verif("({x,{}} = {x}) •imp (#x = {{}})")); -- (which should give FALSE);
print("test93: ",comp_verif("({x,y} = {{x},z}) •imp (#{x,z} = {{}})")); -- (which should give TRUE).
print("test94: ",comp_verif("Svm({[b,c]}) & (range({[b,c]}) = {c}) & (domain({[b,c]}) = {b})")); -- (which should give TRUE).
print("test95: ",comp_verif("next(0) = {0}")); -- (which should give TRUE).
print("test96: ",comp_verif("(next(0) = {0}) & (next({0}) = {0,{0}})")); -- (which should give TRUE).
print("test97: ",comp_verif("3 = {0,1,2}")); -- (which should give TRUE).
print("test97: ",comp_verif("Ord(3)")); -- (which should give TRUE).
print("test98: ",comp_verif("Card(3)")); -- (which should give TRUE).
print("test99: ",comp_verif("c = if (c = a) then a else c end if")); -- (which should give TRUE).
print("test100: ",comp_verif("if c = if (c = a) then a else c end if then b else c end if= b")); -- (which should give TRUE).
print("test101: ",comp_verif("c = if (if (c = a) then b elseif (c = b) then a else c end if = a) then b elseif (if (c = a) then b elseif (c = b) then a else c end if = b) then a elseif (c = a) then b elseif (c = b) then a else c end if"));
print("test102: ",comp_verif("(not ((if (C = A) then B elseif (C = B) then A else C end if in {A,B,C})" +
" and (C = if (if (C = A) then B elseif (C = B) then A else C end if = A) then B elseif (if (C = A) " +
"then B elseif (C = B) then A else C end if = B) then A elseif (C = A) then B elseif (C = B) then A " +
"else C end if)))"));
end test_proof_by_computation;
procedure equality_and_membership_tests(); -- preliminary tests
for n in [0..3] loop print(set_encoding(n)); end loop; -- test set encoding
at1 := newat(); at2 := newat(); at3 := newat(); at4 := newat();
print("testem1: ",test_equality(at1,at2)); -- false
print("testem2: ",test_equality(at1,{at2})); -- OM
print("testem3: ",test_equality(at1,{})); -- OM
print("testem4: ",test_equality(at1,{{{[{at1},at2]}},{at2}})); -- false
print("testem5: ",test_equality({at1},{at1,at1})); -- true
print("testem6: ",test_membership(at1,{{{[{at1},at2]}},{at2}})); -- OM
print("testem7: ",test_membership(at1,{{{[{at1},at2]}},{at1,at2}})); -- false
print("testem8: ",test_membership({at1},{{{[{at1},at2]}},{at2},{at1}})); -- true
print("testem9: ",test_membership(at1,{})); -- false
end equality_and_membership_tests;
procedure comp_verif(stg); -- proof by computation test driver
return compute_check(parze_expr(stg + ";")(2));
end comp_verif;
end logic_syntax_analysis_pak;
-- **********************************************************
-- ************** proof by computation package **************
-- **********************************************************
---> proof_by_computation
package body proof_by_computation; -- package for proof by computation
use string_utility_pak,logic_syntax_analysis_pak,logic_parser_aux,logic_parser_globals;
var set_of_patterns,remaining_to_subdivide,list_of_atoms,atom_of_var := {};
-- atom_of_var is also used to store the value temporarily associated with bound variables in iterators and
-- setformers.
var want_convert_ints := true; -- flag for immediate conversion of ints to von Neumann encoding
var proc_for_function := {["IS_MAP",is_map],["SVM",is_svm_map],["ONE_1_MAP",one_one_map],["IS_INTEGER",is_integher],
["IS_SEQ",is_seq],["DOT_SEQ_CAT",seq_cat],["INV",inv_map],
["CAR",carr],["CDR",cdrr],["DOT_PROD",cartesian_product],["IS_SI",is_signed_integer],
["IS_NONNEG",is_nonneg],["FR_IS_NONNEG",fr_is_nonneg],["SAME_FRAC",same_fraction],
["DOT_PLUS",integer_sum],["DOT_TIMES",integer_times],["DOT_MINUS",integer_pos_minus],
["DOT_MOD",integer_mod],["DOT_S_TIMES",signed_times]};
var expect_integer_args := {"IS_INTEGER","IS_SI","IS_NONNEG","FR_IS_NONNEG","SAME_FRAC","DOT_PLUS","DOT_TIMES","DOT_S_TIMES","DOT_MINUS","DOT_MOD"};
var card; -- cardinality produced by get_cardinality to avoid recalculation
procedure compute_check(tree); -- main proof by computation routine
-- note that this routine handles verification by finite computation only.
-- cases involving potentially infinite sets, verifiable in essentially syntactic fashion,
-- are handled in the simplfication sections of blob_tree_in. The code found there will sometimes call
-- this routine to handle bottom-level cases.
want_convert_ints := true;
-- Still to do: setformer, existential, universal,map composition, other functions and infixes
--print("compute_check: ",tree);
fv := find_free_vars(tree);
-- parse the expression to be processed, and find the free variables in it
fv := [v: v in fv]; -- arrange as ordered list
--print("free variables: ",fv);
list_of_atoms := [newat(): j in [1..nfv := #fv]]; -- generate enough atoms for all the free variables
all_sp := subiv_patterns(nfv); -- generate all the subdivision patterns of these atoms
-- (these patterns are returned as vectors of sets of integers)
val_seen := OM;
--print("all_sp: ",all_sp);
if all_sp = [] then return evaluate_tree_in(tree); end if; -- there are no free variables
for sp in all_sp loop -- iterate over all the subdivision patterns
atom_of_var := {[fv(n),list_of_atoms(setno)]: int_set = sp(setno), n in int_set};
-- convert the pattern into a pattern in which the free vars map to atoms
newval := evaluate_tree_in(tree);
--print("tree value: ",sp," ",newval," ",tree);
if newval = OM or (val_seen /= OM and val_seen /= newval) then return OM; end if;
-- if evaluation aborts or returns a value not previously seen, end with failure
val_seen := newval; -- note the first non-OM value seen
end loop;
return val_seen; -- otherwise return the only value seen
end compute_check;
procedure evaluate_tree_in(tree); -- recursive workhorse for tree evaluation
--print("evaluate_tree_in: ",tree," want_convert_ints: ",want_convert_ints);
if is_string(tree) then
digs := span(tree,"0123456789");
if tree = "" then
return if want_convert_ints then set_encoding(unstr(digs)) else digs end if;
end if;
return if tree = "_nullset" then {} else atom_of_var(tree) end if;
end if;
[n1,n2,n3] := tree; -- tree nodes most often (but not always) represent infix operators
case (op_above := abbreviated_headers(n1)?n1) -- note the lead operator for later use
when "if" => -- we have an if statement or expression
-- recursively evaluate the lead expression of the "if"
-- unless this ealuates to 'true' or 'false, abort
-- if evaluates to true, evaluate the following expression
-- and return the resulting value
-- otherwise return the value of the tail.
--print("if_tree being evaluated: ",tree,"\ncond_val: ",evaluate_tree_in(n2),"\ntail tree: ",tree(4));
if (cond_val := evaluate_tree_in(n2)) = OM then return OM; end if;
if cond_val = true then return evaluate_tree_in(n3); end if;
if cond_val /= false then return OM; end if;
return evaluate_tree_in(tree(4)); -- evaluate the tail
when "and" => if (v2 := evaluate_tree_in(n2)) = false then return false; end if;
if (v3 := evaluate_tree_in(n3)) = false then return false; end if;
if v2 = true and v3 = true then return true; end if;
return OM;
when "or" => if (v2 := evaluate_tree_in(n2)) = true then return true; end if;
if (v3 := evaluate_tree_in(n3)) = true then return true; end if;
if v2 = false and v3 = false then return false; end if;
return OM;
when "imp" => v2 := evaluate_tree_in(n2); -- implication
if v2 = false then return true; end if;
if (v3 := evaluate_tree_in(n3)) = true then return true; end if;
if v2 = true and v3 = false then return false; end if;
return OM;
when "not" => if (v2 := evaluate_tree_in(n2)) = OM or (v2 /= true and v2 /= false) then -- negation
return OM;
end if;
return if v2 = false then true elseif v2 = true then false else OM end if;
when "==","=" => if (v2 := evaluate_tree_in(n2)) = OM or (v3 := evaluate_tree_in(n3)) = OM then -- equivalence, identity
return OM;
end if;
return test_equality(v2,v3);
when "/==","/=" => if (v2 := evaluate_tree_in(n2)) = OM or (v3 := evaluate_tree_in(n3)) = OM then -- inequivalence and inequality; just negate equality
return OM;
end if;
return if (te := test_equality(v2,v3)) = OM then OM else not te end if;
when "+" => if (v2 := evaluate_tree_in(n2)) = OM or (v3 := evaluate_tree_in(n3)) = OM then -- union
return OM;
end if;
if not(is_set(v2) and is_set(v3)) then return OM; end if;
-- both arguments must be sets
return v2 + v3; -- but his might have invisibly duplicate elements, e.g. atom = set
when "*" => if (v2 := evaluate_tree_in(n2)) = OM or (v3 := evaluate_tree_in(n3)) = OM then -- intersection
return OM;
end if;
if v2 = {} or v3 = {} then return {}; end if;
if not(is_set(v2) and is_set(v3)) then return OM; end if;
-- both arguments must be sets
-- find all the elements of the first set which also belong to the second
intersekt := {};
for u in v2 loop
if (tu := test_membership(u,v3)) = OM then return OM; elseif tu then intersekt with:= u; end if;
end loop;
return intersekt;
when "-" => if (v2 := evaluate_tree_in(n2)) = OM or (v3 := evaluate_tree_in(n3)) = OM then -- difference
return OM;
end if;
if not(is_set(v2) and is_set(v3)) then return OM; end if;
-- both arguments must be sets
-- find all the elements of the first set which do not belong to the second
diff := {};
for u in v2 loop
if (tu := test_membership(u,v3)) = OM then return OM; elseif not tu then diff with:= u; end if;
end loop;
return diff;
when "incs" => if (v2 := evaluate_tree_in(n2)) = OM or (v3 := evaluate_tree_in(n3)) = OM then -- inclusion
return OM;
end if;
if not(is_set(v2) and is_set(v3)) then return OM; end if;
-- both arguments must be sets
-- is there an element of the second set which does not belong to the first?
was_OM := false;
for u in v3 loop
if (tu := test_membership(u,v2)) = OM then was_OM := true; elseif not tu then return false; end if;
end loop;
return if was_OM then OM else true end if;
when "incin" => if (v2 := evaluate_tree_in(n2)) = OM or (v3 := evaluate_tree_in(n3)) = OM then -- included in
return OM;
end if;
if not(is_set(v2) and is_set(v3)) then return OM; end if;
-- both arguments must be sets
-- is there an element of the first set which does not belong to the second?
was_OM := false;
for u in v2 loop
if (tu := test_membership(u,v3)) = OM then was_OM := true; elseif not tu then return false; end if;
end loop;
return if was_OM then OM else true end if;
when "{-}" => enum_set := {}; -- enumerated set: we allow invisible duplicates here
for subxep in tree(2..) loop
if (v := evaluate_tree_in(subxep)) = OM then return OM; end if;
enum_set with:= v;
end loop;
--print("enumerated set result: ",tree," ",enum_set);
return enum_set;
when "[-]" => if (v2 := evaluate_tree_in(n2)) = OM or (v3 := evaluate_tree_in(n3)) = OM then -- ordered pair
return OM;
end if;
--print("returning: ",[v2,v3]);
return [v2,v3];
---> working in
when "in" => if n3 = "ZA" then return is_integher(n2); end if;
if n3 = "SI" then return is_signed_integer(n2); end if;
if n3 = "FR" then return is_fraction(n2); end if;
if (v3 := evaluate_tree_in(n3)) = OM or (not is_set(v3)) then -- membership
return OM;
end if;
if v3 = {} then return false; end if;
if (v2 := evaluate_tree_in(n2)) = OM then return OM; end if;
return test_membership(v2,v3);
when "notin" => if (v3 := evaluate_tree_in(n3)) = OM or (not is_set(v3)) then -- nonmembership; just negate membership
return OM;
end if;
if v3 = {} then return true; end if;
if (v2 := evaluate_tree_in(n2)) = OM then return OM; end if;
return if (ismememb := test_membership(v2,v3)) = OM then OM else not ismememb end if;
when "#" => if (v2 := evaluate_tree_in(n2)) = OM or is_atom(v2) then -- cardinality
return OM;
end if;
if is_tuple(v2) then return set_encoding(#v2); end if;
if (n := get_cardinality(v2)) = OM then return OM; end if;
return set_encoding(n); -- return the number of nonduplicate elements
when "arb" => -- arb
if (v2 := evaluate_tree_in(n2)) = OM then return OM; end if;
if is_tuple(v2) then return if #v2 = 2 then {v2(1)} else OM end if; end if;
-- here we let the definition of 'cons' show thru
return get_arb(v2);
when "domain" => if (v2 := evaluate_tree_in(n2)) = OM then return OM; end if;
return domayn(v2);
when "range" => if (v2 := evaluate_tree_in(n2)) = OM or (not is_set(v2)) or (exists x in v2 | not (is_tuple(x) and #x = 2)) then
return OM; -- we don't have a set of pairs
end if;
return range(v2); -- range; but note that this might contain invisible duplicates
when "{}" => -- we perform the iteration indicated in the setformer, evaluating the condition (if any) in each case
--->working
[-,lead_expn,iter_list,cond] := tree;
iter_list := iter_list(2..); -- drop the syntactic header from the iter_list
-- check that none of the free variables in any of the iterator-limiting
-- expressions are bound in any prior iterator
bound_vars_so_far := {};
when "EX" => -- we perform the iteration indicated in the quantifier, evaluating the condition (if any) in each case
-- if any 'true' is found we return 'true'; otherwise if any OM is found we return OM; otherwise 'false'
null; -- existential ****************************
-- the items appearing in the iterators must all be sets
when "ALL" => -- we perform the iteration indicated in the quantifier, evaluating the condition (if any) in each case
-- if any 'false' is found we return 'false'; otherwise if any OM is found we return OM; otherwise 'true'
null; -- ****************************
-- the items appearing in the iterators must all be sets
when "@" => if (v2 := evaluate_tree_in(n2)) = OM or (v3 := evaluate_tree_in(n3)) = OM then return OM; end if; -- map composition
return map_prod(v2,v3);
when "->" => if (v2 := evaluate_tree_in(n2)) = OM or (v3 := evaluate_tree_in(n3(2))) = OM then return OM; end if; -- map application
return map_ap(v2,v3);
when "{.}" => null; -- multivalued function application ****************************
when "[]" => return unparse_in(n2); -- list; should be of length 1
when "()" => -- function application; we apply the recursive definition of functions where possible
--print("function application: ",tree," ",n2);
if n2 = "SVM" and is_tuple(n32 := n3(2)) and n32(1) = "ast_genset" then return is_svm_map_sf(tree); end if;
if n2 = "ONE_1_MAP" and is_tuple(n32 := n3(2)) and n32(1) = "ast_genset" then return one_one_map_sf(tree); end if;
--print("proc_for_function: ",n2," ",proc_for_function(n2));
if (pff := proc_for_function(n2)) = OM then return OM; end if; -- no procedure has been registered for the function
if n2 notin expect_integer_args then
arg_tuple := [evaluate_tree_in(arg): arg in (args := n3(2..))]; -- evaluate all the arguments
--print(n2," arg_tuple: ",arg_tuple," args: ",args," pff: ",pff," n2: ",n2);
if (nat := #arg_tuple) < #args or (exists x in arg_tuple | x = OM) then return OM; end if;
-- return OM if any arg is undefined
else
-- arguments might be integers so pass without imediate conversion
save_want_convert_ints := want_convert_ints; want_convert_ints := false;
-- drop the flag for immediate integer conversion
arg_tuple := [evaluate_tree_in(arg): arg in (args := n3(2..))]; -- evaluate all the arguments
convert_ints := save_want_want_convert_ints;
-- restore the flag for immediate integer conversion
if (nat := #arg_tuple) < #args or (exists x in arg_tuple | x = OM) then return OM; end if;
-- return OM if any arg is undefined
want_convert_ints := save_want_convert_ints;
end if;
return if nat = 1 then pff(arg_tuple(1)) elseif nat = 2 then pff(arg_tuple(1),arg_tuple(2))
elseif nat = 3 then pff(arg_tuple(1),arg_tuple(2),arg_tuple(3)) else pff(arg_tuple) end if;
when "itr","Etr" => null; -- iteration ****************************
when "{/}" => null; -- setformer, no exp ****************************
--print(tree);
when "ast_end" => null; -- end_slice ****************************
when ">","<",">=","<=" => null; -- signed comparisons ****************************
otherwise => -- can be monadic or unary operator; we apply the recursive definition of the operator where possible
--print("proc_for_function: ",n1," ",proc_for_function(n1));
if (pff := proc_for_function(n1)) = OM then return OM; end if; -- no procedure has been registered for the op
--print("operator case:: ",tree);
if n1 notin expect_integer_args then -- function does not expect nteger args so evaluate args without inspection
arg_tuple := [evaluate_tree_in(arg): arg in (args := tree(2..))]; -- evaluate all the arguments
if (nat := #arg_tuple) < #args or (exists x in arg_tuple | x = OM) then return OM; end if;
-- return OM if any arg is undefined
else -- arguments might be integers so pass without imediate conversion
save_want_convert_ints := want_convert_ints; want_convert_ints := false;
-- drop the flag for immediate integer conversion
arg_tuple := [evaluate_tree_in(arg): arg in (args := tree(2..))]; -- evaluate all the arguments
convert_ints := save_want_want_convert_ints;
-- restore the flag for immediate integer conversion
if (nat := #arg_tuple) < #args or (exists x in arg_tuple | x = OM) then return OM; end if;
-- return OM if any arg is undefined
want_convert_ints := save_want_convert_ints;
end if;
--print("operator case: ",tree," ",pff," ",arg_tuple);
return if nat = 1 then pff(arg_tuple(1)) elseif nat = 2 then pff(arg_tuple(1),arg_tuple(2))
elseif nat = 3 then pff(arg_tuple(1),arg_tuple(2),arg_tuple(3)) else pff(arg_tuple) end if;
end case;
end evaluate_tree_in;
procedure evaluate_in_dummy(); -- dummy routine to call all procedures used by evaluate_tree_in;
-- only for purposes of call-graph analysis
is_map(s); is_svm_map(s); one_one_map(s); is_integher(s);
is_seq(s); seq_cat(s,t); inv_map(s); next(s); is_integher(s); is_integher(s);
carr(s); cdrr(s); cartesian_product(s,t);
end evaluate_in_dummy;
procedure domayn(s); -- the 'assured' domain of a set
if (not is_set(s)) or (exists x in s | not (is_tuple(x) and #x = 2)) then
return OM; -- we don't have a set of pairs
end if;
return domain(s); -- domain; but note that this might contain invisible duplicates
end domayn;
procedure get_cardinality(v2); -- calculates cardinality of a set
if not is_set(v2) then return OM; end if;
if v2 = {} then return 0; end if;
-- otherwise, if we have a set, we must eliminate duplicates before we can count.
membs_list := []; -- list of members without duplicates
for x in v2 loop -- iterate, eliminating duplicates
te := false; -- no identical element found yet
for memb in membs_list loop
if (te := test_equality(memb,x)) = OM then return OM; end if;
if te then exit; end if;
end loop;
if not te then membs_list with:= x; end if;
-- since the search loop was exited without finding any possible duplicate
end loop;
return (card := #membs_list);
end get_cardinality;
procedure map_ap(f,x); -- map application
if not (is_map(f) = true) then return OM; end if;
-- form the set of all image elements, returning OM if any cannot be evaluated
image_elements := {};
for [d,y] in f loop
if (te := test_equality(d,x)) = OM then return OM; end if;
if te then image_elements with:= y; end if; -- allow invisible duplicates at this point
end loop;
return get_arb(image_elements); -- if there are no image elements this will be OM
end map_ap;
procedure map_prod(f,g); -- map product
--print("f,g: ",f,g);
if not (is_map(f) = true and is_map(g) = true) then return OM; end if;
-- form the set of all image elements, returning OM if any cannot be evaluated
map_elements := {};
for [d,y] in g, [d2,y2] in f loop
if (te := test_equality(d2,y)) = OM then return OM; end if;
if te then map_elements with:= [d,y2]; end if; -- allow invisible duplicates at this point
end loop;
--print("map_elements: ",map_elements);
return map_elements;
end map_prod;
procedure get_arb(s); -- arb extraction
-- the argument must be a set and can contain at most one atom.
-- if there is an atom and it is an ultimate member of all the constructs which appear, it is the arb.
-- if there is an atom and it is not an ultimate member of all the constructs which appear, return OM
-- otherwise we have to find a unique member which is a composite object
-- and has no intersection with the set itself; and this is the arb.
-- if this does not exist or is not unique, the arb is undefined.
--print("getting arb: ",s);
if not is_set(s) or s = {} then return OM; end if;
if (na := #(atoms := {x in s | is_atom(x)})) > 1 then return OM; end if;
if na = 1 then
atom := arb(atoms);
return if exists u in (s - atoms) | atom notin all_atoms(u) then OM else atom end if;
end if;
-- otherwise there are no atoms in the set.
-- Form the collection of all elements of s none of whose elements belong to s
non_intersecting_membs := {}; -- will build
for x in s loop
--print("trying: ",x);
if not is_set(x) then return OM; end if;
if x = {} then non_intersecting_membs with:= x; continue; end if;
x_intersects_s := false;
for y in x loop
-- print("test_membership: ",y," ",s);
if (tm := test_membership(y,s)) = OM then return OM; end if;
-- print("test_membership result: ",y," ",s," ",tm);
if tm then x_intersects_s := true; exit; end if;
end loop;
if not x_intersects_s then non_intersecting_membs with:= x; end if;
end loop; -- here we are done building intersects_s
nnim := #non_intersecting_membs;
--print("non_intersecting_membs: ",non_intersecting_membs," ",nnim);
if nnim = 1 then return arb(non_intersecting_membs); end if;
return OM; -- since either there are no, or more than 1, non_intersecting_membs
end get_arb;
procedure is_integher(s); -- test a set or string for being an integer
if is_string(s) then
front := span(s,"0123456789"); if s /= "" then return OM; end if;
return true;
end if;
if (card := get_cardinality(s)) = OM then return OM; end if;
return test_equality(s,set_encoding(card));
end is_integher;
procedure convert_to_integer(s); -- convert a set or string to its integer value
--print("convert_to_integer: ",s," ",type(s));
if is_string(s) then
front := span(s,"0123456789"); if s = "" then return unstr(front); end if;
end if;
if (card := get_cardinality(s)) = OM then return OM; end if;
return card;
end convert_to_integer;
procedure is_seq(s); -- test a set for being a sequence
if not is_set(s) then return OM; end if;
if (ds := domayn(s)) = OM then return OM; end if;
if get_cardinality(ds) = OM then return OM; end if;
return test_equality(ds,set_encoding(card)); -- 'card' is global from get_cardinality
end is_seq;
procedure seq_cat(s,t); -- sequence concatenation
--print("seq_cat: ",s," ",t);
if is_seq(t) /= true or is_seq(s) /= true then return OM; end if;
card_s := card; -- 'card' is global from get_cardinality
return s + {[set_encoding(card_s + #n),v]: [n,v] in t};
end seq_cat;
procedure test_equality(u,v); -- recursive test for object equality
--print("test_equality: ",u," ",v," ",type(u)," ",type(v));
if (is_string(u) and (ui := convert_to_integer(u)) /= OM) or is_integer(ui := u) then -- handle integer cases first
if (is_string(v) and (vi := convert_to_integer(v)) /= OM) or is_integer(vi := v) then return u = v; end if;
return v = set_rep(ui);
elseif (is_string(v) and (vi := convert_to_integer(v)) /= OM) or is_integer(vi := v) then
return u = set_rep(vi);
end if;
if u = v then return true; end if; -- SETL equality always implies logical equality
if (iau := is_atom(u)) /= is_atom(v) then
-- we are testing an atom for equality with something else.
-- inequality is certain if the atom is visibly an ultimate member of the other object;
-- otherwise the test must fail
if iau then
if u in all_atoms(v) then return false; end if;
else
if v in all_atoms(u) then return false; end if;
end if;
return OM; -- otherwise result is uncertain, so we must fail
end if;
if iau then return u = v; end if;
if (itu := is_tuple(u)) /= is_tuple(v) then return OM; end if;
if itu then
if (nu := #u) /= #v then return false; end if;
if #(component_test := [test_equality(x,v(j)): x = u(j)]) /= nu or (exists x in component_test | x = OM) then
return OM;
end if;
return true and/ component_test;
end if;
-- otherwise two sets must be tested for equality. We test each member of
-- the first set for equality with some member of the second, and vice-versa
for x in u loop
was_OM := false; -- flag: was an undefined case encountered in the search>
found_true := false;
for y in v loop
if (te := test_equality(x,y)) = true then found_true := true; exit; end if;
if te = OM then was_OM := true; end if;
end loop;
if not found_true then return if was_OM then OM else false end if; end if;
-- since we have found an element of the first set whose membership in
-- the second set is false or uncertain
end loop;
for x in v loop
was_OM := false; -- flag: was an undefined case encountered in the search>
found_true := false;
for y in u loop
if (te := test_equality(x,y)) = true then found_true := true; exit; end if;
if te = OM then was_OM := true; end if;
end loop;
if not found_true then return if was_OM then OM else false end if; end if;
-- since we have found an element of the second set whose membership in
-- the first set is false or uncertain
end loop;
return true; -- since the sets are certainly equal
end test_equality;
procedure all_atoms(u); -- all the ultimate members of a composite object
--print("all_atoms: ",u);
return if is_atom(u) then {u} elseif is_string(u) then {} else {} +/ [all_atoms(v): v in u] end if;
end all_atoms;
procedure test_membership(u,v); -- test for object membership
--print("test for object membership: ",u," ",v);
if not is_set(v) then return OM; end if;
if u in v then return true; end if; -- SETL membership always implies logical equality
was_OM := false; -- flag: was an undefined case encountered in the search>
for y in v loop
if (te := test_equality(u,y)) = true then return true; end if;
if te = OM then was_OM := true; end if;
end loop;
return if was_OM then OM else false end if;
end test_membership;
procedure set_encoding(n);
--print("set_encoding: ",n);
if not is_integer(n) or n < 0 then return OM; end if;
if n > 10 then return str(n); end if;
the_set := {};
for j in [1..n] loop the_set with:= the_set; end loop;
--print("return set_encoding: ",the_set);
return the_set;
end set_encoding;
procedure is_map(s); -- test for map property
--print("test for map property: ",s);
if not is_set(s) then return OM; end if;
return forall x in s | (is_tuple(x) and #x = 2);
end is_map;
procedure is_svm_map(s); -- test for single-valued map property
--print("test for single-valued map property: ",s);
if not is_set(s) then return OM; end if; -- must be set
if not (forall x in s | (is_tuple(x) and #x = 2)) then return OM; end if; -- must be map
found_OM := false;
-- if all implications are true then return true;
-- if any is false then return false
-- otherwise one must be OM and the others true, so return OM
for [x1,x2] in s, [y1,y2] in s loop
if (te1 := test_equality(x1,y1)) = false then continue; end if; -- since implication is true
if (te2 := test_equality(x2,y2)) = true then continue; end if; -- since implication is true
if te1 = true and te2 = false then return false; end if; -- since implication is false
found_OM := true;
end loop;
return if found_OM then OM else true end if; -- return OM if any case was undecided, else true
end is_svm_map;
procedure is_svm_map_sf(tree); -- test for single-valued map property for setformer
-- this routine handles setformers of the form
-- {[e(x_1,..x_n),f(x_1,..x_n)]: .. | ..} with single or multiple iterators and arbitrary conditions
-- the iterators and conditions are ignored, and the implication
-- (e(x_1,..x_n) = e(y_1,..y_n)) •imp (f(x_1,..x_n) = f(y_1,..y_n))
-- is formed and tested. If the test returns true, the single-valuedness assertion
-- is verified, otherwise not.
-- first we check that the argument of the function is a setformer,
-- and that its lead expression is a pair. If not, OM is returned.
lead_expn := tree(3)(2)(2); -- find the lead expression of the setformer
if not (is_tuple(lead_expn) and lead_expn(1) = "ast_enum_tup" and #lead_expn = 3) then
return OM;
end if;
[-,comp1,comp2] := lead_expn; -- get the two components of the lead expression
fvs := find_free_vars(lead_expn); -- find the free variables of the lead expresion
-- generate substituted forms for the free variables of the lead expresion
substitution_map := {[x,x + "_"]: x in fvs};
-- build substituted forms for the first and second component
subst_comp1 := substitute(comp1,substitution_map);
subst_comp2 := substitute(comp2,substitution_map);
--print(substitute(subst_comp1,substitution_map)); print(subst_comp2);
-- build an implication between equalities of these substituted forms
-- check the reulting implication
implication_between_equalities := ["DOT_IMP",["ast_eq",comp1,subst_comp1],["ast_eq",comp2,subst_comp2]];
return compute_check(implication_between_equalities);
end is_svm_map_sf;
procedure one_one_map_sf(tree); -- test for 1-1 map property for setformer
-- this routine handles setformers of the form
-- {[e(x_1,..x_n),f(x_1,..x_n)]: .. | ..} with single or multiple iterators and arbitrary conditions
-- the iterators and conditions are ignored, and the implication
-- (e(x_1,..x_n) = e(y_1,..y_n)) •imp (f(x_1,..x_n) = f(y_1,..y_n))
-- is formed and tested. If the test returns true, the single-valuedness assertion
-- is verified, otherwise not.
-- first we check that the argument of the function is a setformer,
-- and that its lead expression is a pair. If not, OM is returned.
lead_expn := tree(3)(2)(2); -- find the lead expression of the setformer
if not (is_tuple(lead_expn) and lead_expn(1) = "ast_enum_tup" and #lead_expn = 3) then
return OM;
end if;
[-,comp1,comp2] := lead_expn; -- get the two components of the lead expression
fvs := find_free_vars(lead_expn); -- find the free variables of the lead expresion
-- generate substituted forms for the free variables of the lead expresion
substitution_map := {[x,x + "_"]: x in fvs};
-- build substituted forms for the first and second component
subst_comp1 := substitute(comp1,substitution_map);
subst_comp2 := substitute(comp2,substitution_map);
--print(substitute(subst_comp1,substitution_map)); print(subst_comp2);
-- build an implication between equalities of these substituted forms
-- check the reulting implication
implication_between_equalities_1 := ["DOT_IMP",["ast_eq",comp1,subst_comp1],["ast_eq",comp2,subst_comp2]];
implication_between_equalities_2 := ["DOT_IMP",["ast_eq",comp2,subst_comp2],["ast_eq",comp1,subst_comp1]];
if compute_check(implication_between_equalities_1) /= true then return OM; end if;
return compute_check(implication_between_equalities_2);
end one_one_map_sf;
procedure map_comp_simplif(tree); -- simplify a map composition
-- this routine simplifies map compositions of the form
-- {[x,f(x)]: x in s | P(x)} @ {[g(y1,..,yn),h(y1,..,yn)]: y1 in t1,..,yn in tn | Q(y1,..,yn)},
-- converting them to {[g(y1,..,yn),f(h(y1,..,yn))]: y1 in t1,..,yn in tn |
-- h(y1,..,yn) in s & P(h(y1,..,yn)) & Q(y1,..,yn)}
-- the bound variables y1,..,yn must be modified so as not to overlap
-- with any variable free in s or P
print(tree);
end map_comp_simplif;
procedure one_one_map(s); -- test for bi-unique map property
if not is_set(s) then return OM; end if; -- must be set
if not (forall x in s | (is_tuple(x) and #x = 2)) then return OM; end if; -- must be map
--print("one_one_map: ",s);
found_OM := false;
-- if all equivalences are true then return true;
-- if any is false then return false
-- otherwise one must be OM and the others true, so return OM
for [x1,x2] in s, [y1,y2] in s loop
if (te1 := test_equality(x1,y1)) = OM then found_OM := true; continue; end if; -- comparison is impossible
if (te2 := test_equality(x2,y2)) = OM then found_OM := true; continue; end if; -- comparison is impossible
if te1 /= te2 then return false; end if; -- since implication is false
end loop;
return if found_OM then OM else true end if; -- return OM if any case was undecided, else true
end one_one_map;
procedure inv_map(s); -- inverse map
if not is_set(s) then return OM; end if; -- must be set
return {[tup(2),tup(1)]: tup in s | is_tuple(tup) and #tup = 2};
end inv_map;
procedure next(s); -- set-theoretic successor
--print("next: ",[s]);
if not is_set(s) then return OM; end if; -- must be set
return s + {s};
end next;
procedure carr(tup); -- first component of tuple
return if not is_tuple(tup) then OM else tup(1) end if;
end carr;
procedure cdrr(tup); -- second component of tuple
return if not is_tuple(tup) then OM else tup(2) end if;
end cdrr;
procedure cartesian_product(s,t);
-- print("cartesian_product: ",s,t);
if not (is_set(s) and is_set(t)) then return OM; end if; -- both must be sets
return {[x,y]: x in s, y in t};
end cartesian_product;
procedure is_signed_integer(si);
if is_tuple(si) and si(1) = "ast_enum_tup" then si := si(2..); end if; -- input might be raw parsed form of integer
if not is_tuple(si) or #si /= 2 then return OM; end if;
if not (is_integher(s1 := si(1)) and is_integher(s2 := si(2))) then return OM; end if;
if not (is_zero(s1) or is_zero(s2)) then return false; end if;
return true;
end is_signed_integer;
procedure is_fraction(fr);
--print("is_fraction: ",fr);
if is_tuple(fr) and fr(1) = "ast_enum_tup" then fr := fr(2..); end if; -- input might be raw parsed form of integer
if not is_tuple(fr) or #fr /= 2 then return OM; end if;
if is_signed_integer(fr(1)) = OM or is_signed_integer(f2 := fr(2)) = OM then return OM; end if;
if not (is_signed_integer(fr(1)) and is_signed_integer(f2 := fr(2))) then return false; end if;
if f2(1) = "ast_enum_tup" then f2 := f2(2..); end if; -- input might be raw parsed form of integer
if is_zero(f2(1)) and is_zero(f2(2)) then return false; end if;
return true;
end is_fraction;
procedure is_zero(n);
return n = "0" or n = 0 or n = {};
end is_zero;
procedure is_nonneg(si);
if is_tuple(si) and si(1) = "ast_enum_tup" then si := si(2..); end if; -- input might be raw parsed form of integer
if not is_tuple(si) or #si /= 2 then return OM; end if;
if not (is_integher(si(1)) and is_integher(s2 := si(2))) then return OM; end if;
if not is_zero(s2) then return false; end if;
return true;
end is_nonneg;
procedure fr_is_nonneg(fr);
if is_tuple(fr) and fr(1) = "ast_enum_tup" then fr := fr(2..); end if; -- input might be raw parsed form of integer
if not is_tuple(fr) or #fr /= 2 then return OM; end if;
if (b1 := is_nonneg(f1 := fr(1))) = OM or (b2 := is_nonneg(f2 := fr(2))) = OM then return OM; end if;
if f1(1) = "ast_enum_tup" then f1 := f1(2..); end if; -- input might be raw parsed form of integer
if f2(1) = "ast_enum_tup" then f2 := f2(2..); end if; -- input might be raw parsed form of integer
if is_zero(f2(1)) and is_zero(f2(2)) then return OM; end if;
if is_zero(f1(1)) and is_zero(f1(2)) then return true; end if;
return (b1 and b2) or ((not b1) and (not b2));
end fr_is_nonneg;
procedure same_fraction(fr1,fr2);
--print("same_fraction(",fr1,",",fr2,")");
if is_fraction(fr1) /= true or is_fraction(fr2) /= true then return OM; end if;
if is_tuple(fr1) and fr1(1) = "ast_enum_tup" then fr1 := fr1(2..); end if; -- input might be raw parsed form of integer
if is_tuple(fr2) and fr2(1) = "ast_enum_tup" then fr2 := fr2(2..); end if; -- input might be raw parsed form of integer
--print("same_fraction(",fr1,",",fr2,"):: signed_times(",fr1(1),",",fr2(2),")=", signed_times(fr1(1),fr2(2)));
--print("same_fraction(",fr1,",",fr2,"):: signed_times(",fr1(2),",",fr2(1),")=", signed_times(fr1(2),fr2(1)));
return signed_times(fr1(1),fr2(2)) = signed_times(fr1(2),fr2(1));
end same_fraction;
procedure integer_sum(n1,n2);
if (n1 := convert_to_integer(n1)) = OM or (n2 := convert_to_integer(n2)) = OM then return OM; end if;
return str(n1 + n2);
end integer_sum;
procedure integer_times(n1,n2);
if (n1 := convert_to_integer(n1)) = OM or (n2 := convert_to_integer(n2)) = OM then return OM; end if;
return str(n1 * n2);
end integer_times;
procedure signed_times(si1,si2);
--print("signed_times(",si1,",",si2,"):: is_signed_integer(",si1,")=", is_signed_integer(si1),";; is_signed_integer(",si2,")=", is_signed_integer(si2));
if is_signed_integer(si1) /= true or is_signed_integer(si2) /= true then return OM; end if;
if si1(1) = "ast_enum_tup" then si1 := si1(2..); end if; -- input might be raw parsed form of integer
if si2(1) = "ast_enum_tup" then si2 := si2(2..); end if; -- input might be raw parsed form of integer
x := si1(1); y := si1(2);
u := si2(1); v := si2(2);
m := unstr(minuend := integer_sum(integer_times(x,u),integer_times(y,v)));
s := unstr(subtrahend := integer_sum(integer_times(y,u),integer_times(x,v)));
return if m > s then [integer_pos_minus(minuend,subtrahend),"0"]
else ["0",integer_pos_minus(subtrahend,minuend)]
end if;
end signed_times;
procedure integer_pos_minus(n1,n2);
if (n1 := convert_to_integer(n1)) = OM or (n2 := convert_to_integer(n2)) = OM then return OM; end if;
return str((n1 - n2) max 0);
end integer_pos_minus;
procedure integer_mod(n1,n2);
if (n1 := convert_to_integer(n1)) = OM or (n2 := convert_to_integer(n2)) = OM or n2 = 0 then return OM; end if;
return str(n1 mod n2);
end integer_mod;
procedure preliminary_tests();
print(atoms_in({1,[2,3,{4,1}]}));
print(time()); sp := subiv_patterns(n := 6); print(sp); print(#sp); print(time()); stop;
print(equals({1,2},{1,2,3}));
print(equals({1,2},{1,2,1}));
print(equals(1,{1,2}));
print(equals(1,{3,2}));
print(equals(1,{{1,3},2}));
print(equals({2, 3},{1, [3, {2, 3}]}));
print(intersect(1,{1,2}));
print(intersect({2,3},{1,2}));
print(intersect({2,3},{{3,1},2}));
print(intersect({2,3},{{1},2}));
print(intersect({1,{1,2}},{1,2}));
print(intersect({1, [3, {2, 3}]},{{1, [3, {2, 3}]}, 3}));
print(my_arb({{1,3},1}));
print(my_arb({{1,[3,{2,3}]},3}));
print(my_arb({{1,[3,{2,3}]},{2,3}}));
print(is_map({[1,2],[1,3]}));
print(is_svm_map({[1,2],[1,3]}));
print(is_svm_map({[2,1],[3,1]}));
print(one_one_map({[2,1],[1,2]}));
print(my_domain({[2,1],[1,2]}));
print(my_range({[2,1],[1,2]}));
print(one_one_map({[2,1],[1,{2}]}));
end preliminary_tests;
procedure factorial(n); -- factorial
return 1 */ [1..n];
end factorial;
-- procedure comb(m,n); -- combinatorial coefficient
-- return (1 */ [n + 1..m]) / (1 */ [1..m - n]);
-- end comb;
procedure subiv_patterns(n); -- subdivision patterns of [1..n]
intpats := subiv_int(n,n); -- subdivide the integer n in all possible ways
if n = 0 then return []; end if; -- the empty case
pats_as_lists_of_sets := {pat: intpat in intpats, pat in subiv_patterns_in(s := {1..n},intpat,OM)}; -- each pat is a list of sets
return pats_as_lists_of_sets;
return {vect_rep(pat,n): pat in pats_as_lists_of_sets};
procedure subiv_patterns_in(candidate_set,size_vect,candidate_lim); -- internal workhorse; returns collection of lists of sets
temp_candidate_set := if candidate_lim /= OM then {x in candidate_set | x < candidate_lim} else candidate_set end if;
-- the candidates available for choice at this level
if (ntcs := #temp_candidate_set) < (sv1 := size_vect(1)) then
return []; -- no way of subdividing
elseif #candidate_set = sv1 then -- note that this condition will always be satisfied when we reach the end of the size_vect
return [[candidate_set]]; -- one way of subdividing
else
possib_firsts := sv1 npow temp_candidate_set; -- subsets of the size required at this level
return [[s1] + rem_pat: s1 in possib_firsts,
rem_pat in subiv_patterns_in(candidate_set - s1,size_vect(2..),if sv1 > size_vect(2) then OM else max/s1 end if)];
end if;
end subiv_patterns_in;
end subiv_patterns;
procedure subiv_int(n,k); -- generate all decreasing subdivisions of an integer,with parts no larger than k
if n = 0 then return [[]]; elseif n = 1 then return [[1]]; end if;
return [[m] + subli: m in [k,k - 1..1], subli in subiv_int(n - m,k min (n - m) min m)];
end subiv_int;
procedure vect_rep(pat,n); -- vector representation of subdivision pattern
--return pat;
vect := n * [0]; atix := 0;
for s in pat loop atom := atoms(atix +:= 1); for ix in s loop vect(ix) := atom; end loop; end loop;
return vect;
end vect_rep;
-- procedure car(x); if (not is_tuple(x)) or #x /= 2 then abort("car fault " + x); end if; return x(1); end car;
-- procedure cdr(x); if (not is_tuple(x)) or #x /= 2 then abort("cdr fault " + x); end if; return x(2); end cdr;
procedure my_arb(s); -- guaranteed version of arb function
if s = {} then return {}; end if;
if (not is_set(s)) or #(possibs := {x in s | (not is_set(x)) or intersect(x,s) = {}})/= 1 then
abort("arb fault " + possibs);
end if;
return arb(possibs);
end my_arb;
procedure intersect(a,b); print("intersect: ",a," ",b); res := {x in a | x in b or (exists y in b | equals(x,y))};return res; end intersect;
-- guaranteed version of set intersection
procedure equals(a,b); -- guaranteed equality test
--print("equals? ",a," ",b);
if a = b then return true; end if; -- SETL equality always implies logical equality
if ((is_set(b) or is_tuple(b)) and a in b) or ((is_set(a) or is_tuple(a)) and b in a) then return false; end if; -- SETL membership always implies logical inequality
if is_ahtom(a) and is_ahtom(b) then return a = b; end if;
if is_tuple(a) and is_tuple(b) then return #a = #b and (forall x = a(j) | x = b(j)); end if;
if is_set(a) and is_set(b) then
amb := a - b; bma := b - a;
if not (forall x in amb | (exists y in b | equals(x,y))) then return false; end if;
return (forall x in bma | (exists y in a | equals(x,y)));
end if;
if (is_set(a) and is_tuple(b)) or (is_tuple(a) and is_set(b)) then abort("set/tuple fault " + a + " " + b); end if;
if (is_set(a) and is_ahtom(b)) or (is_tuple(a) and is_ahtom(b)) then [a,b] := [b,a]; end if;
if a in atoms_in(b) then return false; end if;
abort("atom equality fault " + a + " " + b);
end equals;
procedure my_domain(s); -- guaranteed domain
if not is_map(s) then abort("domain fault " + s); end if;
return domain(s);
end my_domain;
procedure my_range(s); -- guaranteed range
if not is_map(s) then abort("range fault " + s); end if;
return range(s);
end my_range;
procedure is_ahtom(a); return is_atom(a) or is_integer(a); end is_ahtom;
procedure atoms_in(a); -- the atoms directly or indirectly in a composite structure
return if not (is_set(a) or is_tuple(a)) then {a} else +/[atoms_in(x): x in a] end if;
end atoms_in;
end proof_by_computation;
--->program
program test;
use string_utility_pak,parser,sort_pak,logic_syntax_analysis_pak,logic_parser_aux,logic_parser_globals;
do_tests();
procedure do_tests();
init_logic_syntax_analysis(); -- initialize for logic syntax-tree operations: ******* REQUIRED *******
--
-- preliminary_tests(); -- preliminary 9elementary) tests
-- test_basic_parses(); -- view parse trees of basic constructions
-- unparse_test(); -- test unparse operation
-- blobstring_tests(); -- direct test of blobstring operation
-- test_find_bound_vars(); -- test the 'find_bound_vars' operation, for setformer and iteration nodes
-- test_find_free_vars(); -- test the 'find_free_vars' operation, for setformer and iteration nodes
-- test_standardize_bound_vars(); -- tests of standardize bound variables function
-- test_blob_to_string(); -- tests of blob_to_string function
-- test_blobbing(); -- test the blob_tree function
-- test_top_sort_stgs(); -- test the top_sort_stgs function
-- test_simplify_setformer(); -- test the simplify_setformer routine
-- test_Davis_Putnam(); -- test the Davis_Putnam propositional decision algorithm
-- test_model_blobbed(); -- initial tests and timing of the mlss verifier
-- test_algebra(); -- initial tests of ALGEBRA deduction
-- test_equality_inference(); -- initial tests of equality inferencing
--
-- small_mlss_test(); -- initial explicit test of mlss decider
-- test_mls(); -- perform Eugenio's collection of MLS tests
-- test_equality_more(); -- supplemental equality tests
-- timing_tests(); -- a few tests of MLSS timing
-- test_build_quantified(); -- test of 'build_quantified_version' routine
-- substitution_test(); -- substitution test
-- test_find_diffs(); -- test of 'find_diffs' procedure
-- test_simplify_builtins(); -- test of simplification routine for builtins
-- test_simplify_onces(); -- test of special simplifications for variables appearing once
-- test_find_prop_signs(); -- test of search routine for propositional variables of one sign
-- test_exploit_prop_signs(); -- test of search routine exploiting propositional variables of one sign
-- test_boil_down_blobbed(); -- test overall simplification of blobbed expression
-- test_count_free_vars(); -- test of count_free_vars routine
test_proof_by_computation(); -- test of proof_by_computation routine
end do_tests;
end test;
Forgot your password?
