Personal tools
You are here: Home Projects SETL SETL2 Source code AEtnaNova_ELEM_collection.stl
Document Actions

AEtnaNova_ELEM_collection.stl

by Paul McJones last modified 2021-02-26 20:20
--			*********** 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;
« March 2024 »
Su Mo Tu We Th Fr Sa
1 2
3 4 5 6 7 8 9
10 11 12 13 14 15 16
17 18 19 20 21 22 23
24 25 26 27 28 29 30
31
 

Powered by Plone CMS, the Open Source Content Management System

This site conforms to the following standards: