diff --git a/aq1/aq1.metta b/aq1/aq1.metta index 7900780..b86f4ed 100644 --- a/aq1/aq1.metta +++ b/aq1/aq1.metta @@ -1,131 +1,161 @@ +; (convert_to_metta_file aq1 $_111116 aq1/aq1.pl aq1/aq1.metta) !(op 700 xfx ..) -; - - - - (= - (data $FILENAME) - ( (clear) - (nl) - (write '===> loading ') - (write $FILENAME) - (nl) - (see $FILENAME) - (repeat) - (read $X) - (or - (, - (= $X end-of-file) - (seen) - (add-symbol &self - (dataset $FILENAME)) - (set-det)) - (, - (process $X) - (fail))))) -; - - - - (= - (process (domaintype $ATTR $D)) - ( (add-symbol &self +; /******************************************************************/ +; /* aq1.pro Last modification: Fri Jan 14 19:30:51 1994 */ +; /* Becker's implementation of AQ in MeTTa */ +; /******************************************************************/ +; ; ; Copyright (c) 1985 Jeffrey M. Becker ; +; /******************************************************************/ +; /* reimpl. by : Thomas Hoppe */ +; /* Mommsenstr. 50 */ +; /* D-10629 Berlin */ +; /* F.R.G. */ +; /* E-Mail: hoppet@cs.tu-berlin.de */ +; /* 1986 */ +; /* */ +; /* reference : AQ-PROLOG: A MeTTa Implementation of an */ +; /* Attribute-Based Learning System, Becker, J.M., */ +; /* Reports of the Intelligent Systems Group, */ +; /* Department of Computer Science, University of */ +; /* Illinois at Urbana-Champaign, Report Number */ +; /* ISG 85-1, January 1985 */ +; /* */ +; /* Learning from Observation: Conceptual Clustering*/ +; /* Michalski, R.S., Stepp, R.E., in: Machine */ +; /* Learning, Michalski, R.S., Carbonell, J.G., */ +; /* Mitchell, T.M. (eds.), Tioga Publishing */ +; /* Company, Palo Alto, 1983. */ +; /* */ +; /* Inductive Learning, Michalski, R.S., in: Machine*/ +; /* Learning, Michalski, R.S., Carbonell, J.G., */ +; /* Mitchell, T.M. (eds.), Tioga Publishing */ +; /* Company, Palo Alto, 1983. */ +; /* */ +; /* Update : The clause parent contained a typing error. */ +; /* Now its correct. Thanks to Werner Emde. */ +; /* */ +; /* TH: Made some minor modification */ +; /* */ +; /******************************************************************/ +; /* Because the program as a size about 22k, this version is */ +; /* nearly undocumented, only the top-level procedures and some */ +; /* very special changes against the report are documented. */ +; /* For a detailed documentation consult the report. */ +; /* */ +; /* In general the following changes are implemented: */ +; /* */ +; /* - The top-level Routines are modified slightly. */ +; /* - Ambique named predicates are renamed. */ +; /* - Some special UNSW-PROLOG predicates are removed. */ +; /* - Dependant on the 'bagof' predicate some cut's were necessary*/ +; /* - Some ambiguity concerning atom comparision was removed. */ +; /* - The unused predicat 'pos_cover_or_events' was removed. */ +; /* */ +; /* In the whole programm a destinction between < and @<, > and @> */ +; /* etc. was introduced, which originates in DEC-10 PROLOG. */ +; /* The <,>,=< and >= rever to arithmetric comparisions whereas */ +; /* @<,@>,@=< and @>= rever to comparisions of atoms. Dependant on */ +; /* you're local PROLOG system you have eventually to introduce */ +; /* them. */ +; /******************************************************************/ + + + (= (data $FILENAME) + (clear) + (nl) + (write '===> loading ') + (write $FILENAME) + (nl) + (see $FILENAME) + (repeat) + (read $X) + (or + (, + (= $X end-of-file) + (seen) + (add-is-symbol &self + (dataset $FILENAME)) + (set-det)) + (, + (process $X) + (fail)))) +; /******************************************************************/ +; /* */ +; /* call : data (+FILENAME) */ +; /* */ +; /* arguments : FILENAME = dependent on you're local PROLOG */ +; /* */ +; /* side effects: Removes a previous loaded dataset */ +; /* */ +; /******************************************************************/ +; /* Reads a dataset from the filesystem. */ +; /******************************************************************/ + + + (= (process (domaintype $ATTR $D)) + ( (add-is-symbol &self (domaintype $ATTR $D)) (set-det))) -; - - (= - (process (valueset $ATTR $VALSET)) + (= (process (valueset $ATTR $VALSET)) ( (qsort $VALSET $VALS) - (add-symbol &self + (add-is-symbol &self (valueset $ATTR $VALS)) (set-det))) -; - - (= - (process (range $ATTR $LOW $HIGH)) - ( (add-symbol &self + (= (process (range $ATTR $LOW $HIGH)) + ( (add-is-symbol &self (range $ATTR $LOW $HIGH)) - (add-symbol &self + (add-is-symbol &self (subtyp $ATTR integer)) (set-det))) -; - - (= - (process (order $ATTR $ORD)) + (= (process (order $ATTR $ORD)) ( (length $ORD $HIGH) - (add-symbol &self + (add-is-symbol &self (order $ATTR $ORD)) - (add-symbol &self + (add-is-symbol &self (range $ATTR 1 $HIGH)) - (add-symbol &self + (add-is-symbol &self (subtyp $ATTR symbolic)) (set-det))) -; - - (= - (process (structure $ATTR $STRUC)) + (= (process (structure $ATTR $STRUC)) ( (explodestruc $ATTR $STRUC) - (add-symbol &self + (add-is-symbol &self (structure $ATTR $STRUC)) (set-det))) -; - - (= - (process (classes $CLIST)) - ( (storeclasses $CLIST) (set-det))) -; - - (= - (process (events $CLASS $EVENTLIST)) - ( (encodeevents $EVENTLIST $ENCODEDEVENTS) - (storeevents $CLASS $ENCODEDEVENTS) - (set-det))) -; - - (= - (process $X) - ( (write '===> Invalid Data: ') - (nl) - (write $X) - (set-det))) -; - + (= (process (classes $CLIST)) + (storeclasses $CLIST) + (set-det)) + (= (process (events $CLASS $EVENTLIST)) + (encodeevents $EVENTLIST $ENCODEDEVENTS) + (storeevents $CLASS $ENCODEDEVENTS) + (set-det)) + (= (process $X) + (write '===> Invalid Data: ') + (nl) + (write $X) + (set-det)) - (= - (storeclasses $CLIST) + (= (storeclasses $CLIST) ( (member $CLASSNAME $CLIST) - (add-symbol &self + (add-is-symbol &self (class $CLASSNAME)) (fail))) -; + (= (storeclasses $_) True) - (= - (storeclasses $_) True) -; - - - (= - (storeevents $CLASS $EVENTLIST) + (= (storeevents $CLASS $EVENTLIST) ( (member $EVENT $EVENTLIST) - (add-symbol &self + (add-is-symbol &self (event $CLASS $EVENT)) (fail))) -; - - (= - (storeevents $_ $_) True) -; - + (= (storeevents $_ $_) True) - (= - (clear) - ( (get-symbols &self + (= (clear) + ( (== (= - (dataset $X) true)) + (dataset $X) true) + (get-atoms &self)) (abolish domaintype 2) (abolish valueset 2) (abolish range 3) @@ -141,19 +171,22 @@ (write ' deleted.') (nl) (abolish dataset 1))) -; +; /******************************************************************/ +; /* */ +; /* call : clear */ +; /* */ +; /******************************************************************/ +; /* Erases the actual dataset. */ +; /******************************************************************/ + (= clear True) - (= clear True) -; - - - (= - (listdata) + (= (listdata) ( (nl) - (get-symbols &self + (== (= - (dataset $DATA_SET_NAME) true)) + (dataset $DATA_SET_NAME) true) + (get-atoms &self)) (write '===> Datenset ') (write $DATA_SET_NAME) (write :) @@ -162,15 +195,20 @@ (nl) (printevents) (set-det))) -; +; /******************************************************************/ +; /* */ +; /* call : listdata */ +; /* */ +; /******************************************************************/ +; /* Display's the actual dataset */ +; /******************************************************************/ - - (= - (printdomaininfo) - ( (get-symbols &self + (= (printdomaininfo) + ( (== (= - (domaintype $VAR $DTYPE) true)) + (domaintype $VAR $DTYPE) true) + (get-atoms &self)) (write '===> Variable ') (write $VAR) (write ' of type ') @@ -178,899 +216,612 @@ (write .) (nl) (fail))) -; - - (= printdomaininfo True) -; + (= printdomaininfo True) - - (= - (printevents) - ( (get-symbols &self + (= (printevents) + ( (== (= - (class $CLASS) true)) - (get-symbols &self + (class $CLASS) true) + (get-atoms &self)) + (== (= - (event $CLASS $EVENT) true)) + (event $CLASS $EVENT) true) + (get-atoms &self)) (printcomplex $EVENT) (write ::> ) (write $CLASS) (nl) (fail))) -; - - (= printevents True) -; - - - - (= - (start) - ( (nl) - (write '===> Maximal number of Stars in the next run ?') - (nl) - (read $MAX_STAR) - (nl) - (nl) - (repeat) - (write '===> Which mode in the next run ?') - (nl) - (nl) - (write ' ic: Intersecting Covers') - (nl) - (write ' dc: Disjoint Covers') - (nl) - (write ' vl: VL mode (sequential)') - (nl) - (read $MODE) - (nl) - (abolish cover 2) - (nl) - (makecovers $MODE $MAX_STAR) - (showcovers) - (nl) - (nl) - (nl) - (write '===> You wanna try a different mode (yes,no) ?') - (nl) - (read $RETRY) - (nl) - (== $RETRY no) - (write '===> OK') - (nl) - (set-det))) -; - - - - (= - (makecovers ic $MAX_STAR) - ( (get-symbols &self + (= printevents True) + + + (= (start) + (nl) + (write '===> Maximal number of Stars in the next run ?') + (nl) + (read $MAX_STAR) + (nl) + (nl) + (repeat) + (write '===> Which mode in the next run ?') + (nl) + (nl) + (write ' ic: Intersecting Covers') + (nl) + (write ' dc: Disjoint Covers') + (nl) + (write ' vl: VL mode (sequential)') + (nl) + (read $MODE) + (nl) + (abolish cover 2) + (nl) + (makecovers $MODE $MAX_STAR) + (showcovers) + (nl) + (nl) + (nl) + (write '===> You wanna try a different mode (yes,no) ?') + (nl) + (read $RETRY) + (nl) + (== $RETRY no) + (write '===> OK') + (nl) + (set-det)) +; /******************************************************************/ +; /* */ +; /* call : start */ +; /* */ +; /******************************************************************/ +; /* Start is the top-level loop of AQ-PROLOG. AQ can compute in */ +; /* three different modes ic: Intersecting Covers, dc: Disjoint */ +; /* Covers and vl: VL mode (a sequential one). */ +; /******************************************************************/ + + + (= (makecovers ic $MAX_STAR) + ( (== (= - (class $CLASS) true)) + (class $CLASS) true) + (get-atoms &self)) (posevents $CLASS $EPOS) (negevents $CLASS $ENEG) (aq $EPOS $ENEG $EPOS $EPOS $MAX_STAR (:: Nil) $COVER) (storecover $CLASS $COVER) (fail))) -; - - (= - (makecovers ic $_) + (= (makecovers ic $_) (set-det)) -; - - (= - (makecovers dc $MAX_STAR) - ( (get-symbols &self + (= (makecovers dc $MAX_STAR) + ( (== (= - (class $CLASS) true)) + (class $CLASS) true) + (get-atoms &self)) (posevents $CLASS $EPOS) (neg-cover-or-events $CLASS $ENEG) (aq $EPOS $ENEG $EPOS $EPOS $MAX_STAR (:: Nil) $COVER) (storecover $CLASS $COVER) (fail))) -; - - (= - (makecovers dc $_) + (= (makecovers dc $_) (set-det)) -; - - (= - (makecovers vl $MAX_STAR) - ( (get-symbols &self + (= (makecovers vl $MAX_STAR) + ( (== (= - (class $CLASS) true)) + (class $CLASS) true) + (get-atoms &self)) (posevents $CLASS $EPOS) (followingevents $CLASS $ENEG) (aq $EPOS $ENEG $EPOS $EPOS $MAX_STAR (:: Nil) $COVER) (storecover $CLASS $COVER) (fail))) -; - - (= - (makecovers vl $_) + (= (makecovers vl $_) (set-det)) -; - - (= - (makecovers $X $_) - ( (nl) - (write '===> ERROR - only the modes ic, dc or vl') - (write ' are valid !') - (nl) - (fail))) -; - + (= (makecovers $X $_) + (nl) + (write '===> ERROR - only the modes ic, dc or vl') + (write ' are valid !') + (nl) + (fail)) - (= - (storecover $CLASS $COVER) + (= (storecover $CLASS $COVER) ( (member $COMPLEX $COVER) - (add-symbol &self + (add-is-symbol &self (cover $CLASS $COMPLEX)) (fail))) -; - - (= - (storecover $_ $_) True) -; - - - - (= - (posevents $CLASS $EPOS) - ( (findset $EVENT - (get-symbols &self - (= - (event $CLASS $EVENT) true)) $EPOS) (set-det))) -; + (= (storecover $_ $_) True) + (= (posevents $CLASS $EPOS) + (findset $EVENT + (== + (= + (event $CLASS $EVENT) true) + (get-atoms &self)) $EPOS) + (set-det)) - (= - (negevents $CLASS $ENEG) - ( (findset $EVENT - (negevent $CLASS $EVENT) $ENEG) (set-det))) -; + (= (negevents $CLASS $ENEG) + (findset $EVENT + (negevent $CLASS $EVENT) $ENEG) + (set-det)) - (= - (negevent $CLASS $EVENT) - ( (get-symbols &self + (= (negevent $CLASS $EVENT) + ( (== (= - (event $NEG_CLASS $EVENT) true)) (not (= $NEG_CLASS $CLASS)))) -; - + (event $NEG_CLASS $EVENT) true) + (get-atoms &self)) (not (= $NEG_CLASS $CLASS)))) - (= - (cover-or-event $CLASS $COMP) - (get-symbols &self + (= (cover-or-event $CLASS $COMP) + (== (= - (cover $CLASS $COMP) true))) -; - - (= - (cover-or-event $CLASS $COMP) - (get-symbols &self + (cover $CLASS $COMP) true) + (get-atoms &self))) + (= (cover-or-event $CLASS $COMP) + (== (= - (event $CLASS $COMP) true))) -; - - - - (= - (neg-cover-or-events $CLASS $NEG_COMPS) - ( (findset $COMP - (negcomp $CLASS $COMP) $NEG_COMPS) (set-det))) -; - - + (event $CLASS $COMP) true) + (get-atoms &self))) - (= - (negcomp $CLASS $COMP) - ( (cover-or-event $NEG_CLASS $COMP) (not (= $NEG_CLASS $CLASS)))) -; - - - (= - (followingevents $CLASS $SEVENTS) - ( (bagof $CLASS_NAME - (get-symbols &self - (= - (class $CLASS_NAME) true)) $CLASSES) - (following $CLASS $CLASSES $FCLASSES) - (findset $EVENT - (followev $FCLASSES $EVENT) $SEVENTS) - (set-det))) -; - - - - (= - (followev $FCLASSES $EVENT) - ( (member $CLASS $FCLASSES) (get-symbols &self (= (event $CLASS $EVENT) true)))) -; - - - - (= - (aq $_ $_ Nil $_ $_ $_ Nil) + (= (neg-cover-or-events $CLASS $NEG_COMPS) + (findset $COMP + (negcomp $CLASS $COMP) $NEG_COMPS) (set-det)) -; - - (= - (aq $ELIST $FLIST $UN_COVERED Nil $MAX_STAR $BOUND $RESULT) - ( (write '===> Please wait a moment ...') - (nl) - (set-det) - (aq $ELIST $FLIST $UN_COVERED $UN_COVERED $MAX_STAR $BOUND $RESULT))) -; +; /******************************************************************/ +; /* Against the AQ-PROLOG document the cut in neg_cover_or_events */ +; /* is necessary to prevent backtracking, when the first clause of */ +; /* makecovers fails. */ +; /******************************************************************/ - (= - (aq $ELIST $FLIST $UN_COVERED $SEED_LIST $MAX_STAR $BOUND - (Cons $BEST $COVER)) - ( (set-det) - (first $SEED_LIST $SEED) - (star $SEED $FLIST $MAX_STAR - (:: $ELIST $UN_COVERED) $BOUND $STAR) - (lef $LEF) - (selectbest $STAR 1 $LEF - (:: $ELIST $UN_COVERED) - (:: $BEST_COMP)) - (coveredbycomplex $BEST_COMP $UN_COVERED $COVERED_EVENTS) - (trim $BEST_COMP $COVERED_EVENTS $BEST) - (knockout1 $BEST $UN_COVERED $NEW_UN_COVERED) - (knockout $STAR $SEED_LIST $NEW_SEED_LIST) - (aq $ELIST $FLIST $NEW_UN_COVERED $NEW_SEED_LIST $MAX_STAR $BOUND $COVER) - (set-det))) -; + (= (negcomp $CLASS $COMP) + (cover-or-event $NEG_CLASS $COMP) + (not (= $NEG_CLASS $CLASS))) - (= - (star $_ Nil $_ $_ $PSTAR $PSTAR) + (= (followingevents $CLASS $SEVENTS) + (bagof $CLASS_NAME + (== + (= + (class $CLASS_NAME) true) + (get-atoms &self)) $CLASSES) + (following $CLASS $CLASSES $FCLASSES) + (findset $EVENT + (followev $FCLASSES $EVENT) $SEVENTS) (set-det)) -; +; /******************************************************************/ +; /* Watch out, this is the only occurence of 'bagof' for a correct */ +; /* instantiation of CLASSES to an unmodified ordering see the */ +; /* discussion of 'bagof' below. */ +; /******************************************************************/ - (= - (star $E - (Cons $F $FTAIL) $MAX_STAR $LEF_ARGS $PSTAR $NEW_PSTAR) - ( (set-det) - (extendagainst $E $F $ESTAR) - (multiply $PSTAR $ESTAR $F $EP_STAR) - (absorb $EP_STAR $MAX_STAR $AP_STAR) - (lef $LEF) - (selectbest $AP_STAR $MAX_STAR $LEF $LEF_ARGS $REDUCED_STAR) - (star $E $FTAIL $MAX_STAR $LEF_ARGS $REDUCED_STAR $NEW_PSTAR))) -; - - - - (= - (multiply $COM_SET $PSTAR $NEG_EVENT $EP_STAR) - ( (findset $NEW_COMPS - (, - (member $COMP $COM_SET) - (dis-or-mult $COMP $PSTAR $NEG_EVENT $NEW_COMPS)) $EP_LIST) - (appendx $EP_LIST $EP_STAR) - (set-det))) -; - - - - (= - (dis-or-mult $COMP $_ $NEG $ERG) - ( (disjointcomps $COMP $NEG) - (= $ERG - (:: $COMP)) - (set-det))) -; - - (= - (dis-or-mult $COMP $PSTAR $_ $NEW) - ( (findset $A - (, - (member $P $PSTAR) - (product $COMP $P $A)) $NEW) (set-det))) -; + (= (followev $FCLASSES $EVENT) + ( (member $CLASS $FCLASSES) (== (= (event $CLASS $EVENT) true) (get-atoms &self)))) - (= - (absorb $STAR $MAX_STAR $ASTAR) - ( (length $STAR $N) - (> $N $MAX_STAR) - (set-det) - (absourbr $STAR Nil $STAR1) - (absourbr $STAR1 Nil $ASTAR))) -; + (= (aq $_ $_ Nil $_ $_ $_ Nil) + (set-det)) + (= (aq $ELIST $FLIST $UN_COVERED Nil $MAX_STAR $BOUND $RESULT) + (write '===> Please wait a moment ...') + (nl) + (set-det) + (aq $ELIST $FLIST $UN_COVERED $UN_COVERED $MAX_STAR $BOUND $RESULT)) + (= (aq $ELIST $FLIST $UN_COVERED $SEED_LIST $MAX_STAR $BOUND (Cons $BEST $COVER)) + (set-det) + (first $SEED_LIST $SEED) + (star $SEED $FLIST $MAX_STAR + (:: $ELIST $UN_COVERED) $BOUND $STAR) + (lef $LEF) + (selectbest $STAR 1 $LEF + (:: $ELIST $UN_COVERED) + (:: $BEST_COMP)) + (coveredbycomplex $BEST_COMP $UN_COVERED $COVERED_EVENTS) + (trim $BEST_COMP $COVERED_EVENTS $BEST) + (knockout1 $BEST $UN_COVERED $NEW_UN_COVERED) + (knockout $STAR $SEED_LIST $NEW_SEED_LIST) + (aq $ELIST $FLIST $NEW_UN_COVERED $NEW_SEED_LIST $MAX_STAR $BOUND $COVER) + (set-det)) - (= - (absorb $STAR $_ $STAR) True) -; + (= (star $_ Nil $_ $_ $PSTAR $PSTAR) + (set-det)) +; /******************************************************************/ +; /* I'am not sure if the last cut in aq is necessary, but it works */ +; /* correctly with it. */ +; /******************************************************************/ + (= (star $E (Cons $F $FTAIL) $MAX_STAR $LEF_ARGS $PSTAR $NEW_PSTAR) + (set-det) + (extendagainst $E $F $ESTAR) + (multiply $PSTAR $ESTAR $F $EP_STAR) + (absorb $EP_STAR $MAX_STAR $AP_STAR) + (lef $LEF) + (selectbest $AP_STAR $MAX_STAR $LEF $LEF_ARGS $REDUCED_STAR) + (star $E $FTAIL $MAX_STAR $LEF_ARGS $REDUCED_STAR $NEW_PSTAR)) + + + (= (multiply $COM_SET $PSTAR $NEG_EVENT $EP_STAR) + (findset $NEW_COMPS + (, + (member $COMP $COM_SET) + (dis-or-mult $COMP $PSTAR $NEG_EVENT $NEW_COMPS)) $EP_LIST) + (appendx $EP_LIST $EP_STAR) + (set-det)) - (= - (absourbr Nil $S $S) + (= (dis-or-mult $COMP $_ $NEG $ERG) + (disjointcomps $COMP $NEG) + (= $ERG + (:: $COMP)) + (set-det)) +; /******************************************************************/ +; /* DIS_OR_MULT was introduced, because in AQ-PROLOG the definition*/ +; /* of multiply is heavily dependant on UNSW-PROLOG. The definition*/ +; /* serves the purpose of a substitution for the '->' operator, */ +; /* which seems to be the IF-THEN-ELSE definition in UNSW-PROLOG. */ +; /******************************************************************/ + (= (dis-or-mult $COMP $PSTAR $_ $NEW) + (findset $A + (, + (member $P $PSTAR) + (product $COMP $P $A)) $NEW) (set-det)) -; - - (= - (absourbr - (Cons $C $S) $B $AR_STAR) - ( (set-det) - (knockout1 $C $S $RS) - (absourbr $RS - (Cons $C $B) $AR_STAR))) -; + (= (absorb $STAR $MAX_STAR $ASTAR) + (length $STAR $N) + (> $N $MAX_STAR) + (set-det) + (absourbr $STAR Nil $STAR1) + (absourbr $STAR1 Nil $ASTAR)) + (= (absorb $STAR $_ $STAR) True) - (= - (selectbest $PSTAR $MAX_SIZE $_ $_ $PSTAR) - ( (length $PSTAR $L) - (=< $L $MAX_SIZE) - (set-det))) -; - - (= - (selectbest $PSTAR $MAX_SIZE - (Cons $CT $CTX) $LEF_ARGS $REDUCED_STAR) - ( (set-det) - (reduce $PSTAR $CT $LEF_ARGS $RSTAR) - (selectbest $RSTAR $MAX_SIZE $CTX $LEF_ARGS $REDUCED_STAR))) -; - - (= - (selectbest $PSTAR $MAX_SIZE Nil $_ $RSTAR) - ( (firstn $PSTAR $MAX_SIZE $RSTAR) (set-det))) -; - - - - (= - (reduce $PSTAR - (:: $CRIT_FN $N $D) - (:: $EPLUS $UN_COV_EPLUS) $RSTAR) - ( (=.. $GET_CRIT_FN - (:: $CRIT_FN $COMP $EPLUS $UN_COV_EPLUS $V)) - (findset $VC - (, - (member $COMP $PSTAR) $GET_CRIT_FN - (= $VC - (:: $V $COMP))) $VLIST) - (minmax $VLIST $MIN $MAX) - (is $TOL - (+ $MIN - (/ - (* $N - (- $MAX $MIN)) $D))) - (findset $C - (, - (member - (:: $V $C) $VLIST) - (=< $V $TOL)) $RSTAR) - (set-det))) -; + (= (absourbr Nil $S $S) + (set-det)) + (= (absourbr (Cons $C $S) $B $AR_STAR) + (set-det) + (knockout1 $C $S $RS) + (absourbr $RS + (Cons $C $B) $AR_STAR)) - (= - (minmax - (Cons - (:: $X $_) - (Cons - (:: $Y $_) $R)) $MIN $MAX) - ( (=< $X $Y) - (set-det) - (lohi - (Cons $X - (Cons $Y $R)) $MIN $MAX))) -; + (= (selectbest $PSTAR $MAX_SIZE $_ $_ $PSTAR) + (length $PSTAR $L) + (=< $L $MAX_SIZE) + (set-det)) + (= (selectbest $PSTAR $MAX_SIZE (Cons $CT $CTX) $LEF_ARGS $REDUCED_STAR) + (set-det) + (reduce $PSTAR $CT $LEF_ARGS $RSTAR) + (selectbest $RSTAR $MAX_SIZE $CTX $LEF_ARGS $REDUCED_STAR)) + (= (selectbest $PSTAR $MAX_SIZE Nil $_ $RSTAR) + (firstn $PSTAR $MAX_SIZE $RSTAR) + (set-det)) - (= - (minmax - (Cons - (:: $X $_) - (Cons - (:: $Y $_) $R)) $MIN $MAX) - ( (set-det) (lohi (Cons $Y (Cons $X $R)) $MIN $MAX))) -; + (= (reduce $PSTAR (:: $CRIT_FN $N $D) (:: $EPLUS $UN_COV_EPLUS) $RSTAR) + (=.. $GET_CRIT_FN + (:: $CRIT_FN $COMP $EPLUS $UN_COV_EPLUS $V)) + (findset $VC + (, + (member $COMP $PSTAR) $GET_CRIT_FN + (= $VC + (:: $V $COMP))) $VLIST) + (minmax $VLIST $MIN $MAX) + (is $TOL + (+ $MIN + (/ + (* $N + (- $MAX $MIN)) $D))) + (findset $C + (, + (member + (:: $V $C) $VLIST) + (=< $V $TOL)) $RSTAR) + (set-det)) - (= + (= (minmax (Cons (:: $X $_) (Cons (:: $Y $_) $R)) $MIN $MAX) + (=< $X $Y) + (set-det) (lohi (Cons $X - (Cons $Y - (Cons - (:: $Z $_) $R))) $MIN $MAX) - ( (set-det) - (min - (:: $X $Z) $A) - (max - (:: $Y $Z) $B) - (lohi - (Cons $A - (Cons $B $R)) $MIN $MAX))) -; - - (= + (Cons $Y $R)) $MIN $MAX)) + (= (minmax (Cons (:: $X $_) (Cons (:: $Y $_) $R)) $MIN $MAX) + (set-det) (lohi - (:: $X $Y) $X $Y) - (set-det)) -; - - - - (= - (numbercovered $COMP $_ $EVENTS $N) - ( (coveredbycomplex $COMP $EVENTS $COVERED_E) - (length $COVERED_E $P) - (is $N - (- $P)) - (set-det))) -; - - - - (= - (numberofselectors $COMP $_ $_ $N) - ( (length $COMP $N) (set-det))) -; - - - - (= - (lef - ( (numbercovered 0 1) (numberofselectors 0 1))) True) -; + (Cons $Y + (Cons $X $R)) $MIN $MAX)) + (= (lohi (Cons $X (Cons $Y (Cons (:: $Z $_) $R))) $MIN $MAX) + (set-det) + (min + (:: $X $Z) $A) + (max + (:: $Y $Z) $B) + (lohi + (Cons $A + (Cons $B $R)) $MIN $MAX)) + (= (lohi (:: $X $Y) $X $Y) + (set-det)) - (= - (knockout $OUTER_COMPS $INNER_COMPS $UN_COV_COMPS) - ( (set-det) (findset $IN_COMP (call (, (member $IN_COMP $INNER_COMPS) (nonecover $OUTER_COMPS $IN_COMP))) $UN_COV_COMPS))) -; + (= (numbercovered $COMP $_ $EVENTS $N) + (coveredbycomplex $COMP $EVENTS $COVERED_E) + (length $COVERED_E $P) + (is $N + (- $P)) + (set-det)) - (= - (nonecover Nil $IN_COMP) + (= (numberofselectors $COMP $_ $_ $N) + (length $COMP $N) (set-det)) -; - (= - (nonecover - (Cons $COMP $CX) $IN_COMP) - ( (set-det) - (not (covers $COMP $IN_COMP)) - (nonecover $CX $IN_COMP))) -; + (= (lef ((numbercovered 0 1) (numberofselectors 0 1))) True) - (= - (knockout1 $OUTER_C $INNER_COMPS $UN_COV_COMPS) - ( (set-det) (findset $IN_C (call (, (member $IN_C $INNER_COMPS) (not (covers $OUTER_C $IN_C)))) $UN_COV_COMPS))) -; + (= (knockout $OUTER_COMPS $INNER_COMPS $UN_COV_COMPS) + (set-det) + (findset $IN_COMP + (call (, (member $IN_COMP $INNER_COMPS) (nonecover $OUTER_COMPS $IN_COMP))) $UN_COV_COMPS)) + (= (nonecover Nil $IN_COMP) + (set-det)) + (= (nonecover (Cons $COMP $CX) $IN_COMP) + (set-det) + (not (covers $COMP $IN_COMP)) + (nonecover $CX $IN_COMP)) - (= - (coveredbycomplex $COMPLEX $EVENTS $COVERED_E) - ( (findset $E - (, - (member $E $EVENTS) - (covers $COMPLEX $E)) $COVERED_E) (set-det))) -; + (= (knockout1 $OUTER_C $INNER_COMPS $UN_COV_COMPS) + (set-det) + (findset $IN_C + (call (, (member $IN_C $INNER_COMPS) (not (covers $OUTER_C $IN_C)))) $UN_COV_COMPS)) - (= - (newselector - (Cons - (= $A1 $V1) $T1) - (= $A1 $V2) - (Cons - (= $A1 $V2) $T1)) + (= (coveredbycomplex $COMPLEX $EVENTS $COVERED_E) + (findset $E + (, + (member $E $EVENTS) + (covers $COMPLEX $E)) $COVERED_E) (set-det)) -; - - (= - (newselector - (Cons - (= $A1 $V1) $T1) - (= $A2 $V2) - (Cons - (= $A1 $V1) $T3)) - ( (@< $A1 $A2) - (set-det) - (newselector $T1 - (= $A2 $V2) $T3))) -; - (= - (newselector - (Cons - (= $A1 $V1) $T1) - (= $A2 $V2) - (Cons - (= $A2 $V2) - (Cons - (= $A1 $V1) $T1))) - ( (@> $A1 $A2) (set-det))) -; - (= - (newselector Nil $SEL - (:: $SEL)) + (= (newselector (Cons (= $A1 $V1) $T1) (= $A1 $V2) (Cons (= $A1 $V2) $T1)) + (set-det)) + (= (newselector (Cons (= $A1 $V1) $T1) (= $A2 $V2) (Cons (= $A1 $V1) $T3)) + (@< $A1 $A2) + (set-det) + (newselector $T1 + (= $A2 $V2) $T3)) + (= (newselector (Cons (= $A1 $V1) $T1) (= $A2 $V2) (Cons (= $A2 $V2) (Cons (= $A1 $V1) $T1))) + (@> $A1 $A2) + (set-det)) + (= (newselector Nil $SEL (:: $SEL)) (set-det)) -; - - - (= - (covers - (Cons - (= $A $OUT_VAL) $OUT_C) - (Cons - (= $A $IN_VAL) $IN_C)) - ( (set-det) - (includes - (= $A $OUT_VAL) - (= $A $IN_VAL)) - (covers $OUT_C $IN_C))) -; - (= + (= (covers (Cons (= $A $OUT_VAL) $OUT_C) (Cons (= $A $IN_VAL) $IN_C)) + (set-det) + (includes + (= $A $OUT_VAL) + (= $A $IN_VAL)) + (covers $OUT_C $IN_C)) + (= (covers (Cons (= $A1 $OUT_V) $OUT_C) (Cons (= $A2 $IN_V) $IN_C)) + (set-det) + (@< $A2 $A1) (covers (Cons - (= $A1 $OUT_V) $OUT_C) - (Cons - (= $A2 $IN_V) $IN_C)) - ( (set-det) - (@< $A2 $A1) - (covers - (Cons - (= $A1 $OUT_V) $OUT_C) $IN_C))) -; - - (= - (covers Nil $_) + (= $A1 $OUT_V) $OUT_C) $IN_C)) + (= (covers Nil $_) (set-det)) -; - - (= - (includes - (= $ATTR $OUT_VALS) - (= $ATTR $IN_VALS)) - ( (get-symbols &self + (= (includes (= $ATTR $OUT_VALS) (= $ATTR $IN_VALS)) + ( (== (= - (domaintype $ATTR nominal) true)) + (domaintype $ATTR nominal) true) + (get-atoms &self)) (set-det) (subset $IN_VALS $OUT_VALS))) -; - - (= - (includes - (= $ATTR $OUT_VALS) - (= $ATTR $IN_VALS)) - ( (get-symbols &self + (= (includes (= $ATTR $OUT_VALS) (= $ATTR $IN_VALS)) + ( (== (= - (domaintype $ATTR linear) true)) + (domaintype $ATTR linear) true) + (get-atoms &self)) (set-det) (includeslin $OUT_VALS $IN_VALS))) -; - - (= - (includes - (= $ATTR $OUT_VALS) - (= $ATTR $IN_VALS)) - ( (get-symbols &self + (= (includes (= $ATTR $OUT_VALS) (= $ATTR $IN_VALS)) + ( (== (= - (domaintype $ATTR structured) true)) + (domaintype $ATTR structured) true) + (get-atoms &self)) (set-det) (supremum $ATTR $OUT_VALS $IN_VALS))) -; - - - (= - (disjointcomps - (Cons - (= $A $V1) $T1) - (Cons - (= $A $V2) $T2)) - ( (set-det) (disjointsel (= $A $V1) (= $A $V2)))) -; - - (= - (disjointcomps - (Cons $_ $T1) - (Cons $_ $T2)) - ( (set-det) (disjointcomps $T1 $T2))) -; + (= (disjointcomps (Cons (= $A $V1) $T1) (Cons (= $A $V2) $T2)) + (set-det) + (disjointsel + (= $A $V1) + (= $A $V2))) + (= (disjointcomps (Cons $_ $T1) (Cons $_ $T2)) + (set-det) + (disjointcomps $T1 $T2)) - (= - (disjointsel - (= $ATTR $VALS1) - (= $ATTR $VALS2)) - ( (get-symbols &self + (= (disjointsel (= $ATTR $VALS1) (= $ATTR $VALS2)) + ( (== (= - (domaintype $ATTR nominal) true)) + (domaintype $ATTR nominal) true) + (get-atoms &self)) (set-det) (disjoint $VALS1 $VALS2))) -; - - (= - (disjointsel - (= $ATTR $VALS1) - (= $ATTR $VALS2)) - ( (get-symbols &self + (= (disjointsel (= $ATTR $VALS1) (= $ATTR $VALS2)) + ( (== (= - (domaintype $ATTR linear) true)) + (domaintype $ATTR linear) true) + (get-atoms &self)) (set-det) (disjointlin $VALS1 $VALS2))) -; - - (= - (disjointsel - (= $ATTR $VALS1) - (= $ATTR $VALS2)) - ( (get-symbols &self + (= (disjointsel (= $ATTR $VALS1) (= $ATTR $VALS2)) + ( (== (= - (domaintype $ATTR structured) true)) + (domaintype $ATTR structured) true) + (get-atoms &self)) (set-det) (not (supremum $ATTR $VALS1 $VALS2)) (not (supremum $ATTR $VALS2 $VALS1)))) -; - - (= - (negate $COMPLEX $NEG_COMPS) - ( (findset $NEGC - (, - (member $SEL $COMPLEX) - (negatesel $SEL $NSEL) - (= $NEGC - (:: $NSEL))) $NEG_COMPS) (set-det))) -; - + (= (negate $COMPLEX $NEG_COMPS) + (findset $NEGC + (, + (member $SEL $COMPLEX) + (negatesel $SEL $NSEL) + (= $NEGC + (:: $NSEL))) $NEG_COMPS) + (set-det)) - (= - (negatesel - (= $ATTR $VALS) - (= $ATTR $NEG_VALS)) - ( (get-symbols &self + (= (negatesel (= $ATTR $VALS) (= $ATTR $NEG_VALS)) + ( (== (= - (domaintype $ATTR nominal) true)) + (domaintype $ATTR nominal) true) + (get-atoms &self)) (set-det) - (get-symbols &self + (== (= - (valueset $ATTR $ALL_VALS) true)) + (valueset $ATTR $ALL_VALS) true) + (get-atoms &self)) (difference $ALL_VALS $VALS $NEG_VALS) (not (= $NEG_VALS Nil)))) -; - - (= - (negatesel - (= $ATTR $VALS) - (= $ATTR $NEG_VALS)) - ( (get-symbols &self + (= (negatesel (= $ATTR $VALS) (= $ATTR $NEG_VALS)) + ( (== (= - (domaintype $ATTR linear) true)) + (domaintype $ATTR linear) true) + (get-atoms &self)) (set-det) (negatelin $ATTR $VALS $NEG_VALS) (not (= $NEG_VALS Nil)))) -; - - - - (= - (extendagainst - (Cons - (= $A $VP) $P) - (Cons - (= $A $VN) $N) - (Cons - (:: (= $A $VX)) $X)) - ( (extendref - (= $A $VP) - (= $A $VN) - (= $A $VX)) - (set-det) - (extendagainst $P $N $X))) -; - (= - (extendagainst - (Cons - (= $AP $VP) $P) - (Cons - (= $AN $VN) $N) $X) - ( (@< $AP $AN) - (set-det) - (extendagainst $P - (Cons - (= $AN $VN) $N) $X))) -; - (= + (= (extendagainst (Cons (= $A $VP) $P) (Cons (= $A $VN) $N) (Cons (:: (= $A $VX)) $X)) + (extendref + (= $A $VP) + (= $A $VN) + (= $A $VX)) + (set-det) + (extendagainst $P $N $X)) + (= (extendagainst (Cons (= $AP $VP) $P) (Cons (= $AN $VN) $N) $X) + (@< $AP $AN) + (set-det) + (extendagainst $P + (Cons + (= $AN $VN) $N) $X)) + (= (extendagainst (Cons (= $AP $VP) $P) (Cons (= $AN $VN) $N) $X) + (set-det) (extendagainst (Cons - (= $AP $VP) $P) - (Cons - (= $AN $VN) $N) $X) - ( (set-det) (extendagainst (Cons (= $AP $VP) $P) $N $X))) -; - - (= - (extendagainst Nil $_ Nil) + (= $AP $VP) $P) $N $X)) + (= (extendagainst Nil $_ Nil) (set-det)) -; - - (= - (extendagainst $_ Nil Nil) + (= (extendagainst $_ Nil Nil) (set-det)) -; - - (= - (extendref - (= $ATTR $POS_VALS) - (= $ATTR $NEG_VALS) - (= $ATTR $EXT_VALS)) - ( (get-symbols &self + (= (extendref (= $ATTR $POS_VALS) (= $ATTR $NEG_VALS) (= $ATTR $EXT_VALS)) + ( (== (= - (domaintype $ATTR nominal) true)) + (domaintype $ATTR nominal) true) + (get-atoms &self)) (set-det) (disjoint $POS_VALS $NEG_VALS) (negatesel (= $ATTR $NEG_VALS) (= $ATTR $EXT_VALS)))) -; - - (= - (extendref - (= $ATTR $POS_VALS) - (= $ATTR $NEG_VALS) - (= $ATTR $EXT_VALS)) - ( (get-symbols &self + (= (extendref (= $ATTR $POS_VALS) (= $ATTR $NEG_VALS) (= $ATTR $EXT_VALS)) + ( (== (= - (domaintype $ATTR linear) true)) + (domaintype $ATTR linear) true) + (get-atoms &self)) (set-det) (disjointlin $POS_VALS $NEG_VALS) (negatelin $ATTR $NEG_VALS $NN_VALS) (extendedlin $POS_VALS $NN_VALS $EXT_VALS))) -; - - (= - (extendref - (= $ATTR $POS_VAL) - (= $ATTR $NEG_VAL) - (= $ATTR $EXT_VAL)) - ( (get-symbols &self + (= (extendref (= $ATTR $POS_VAL) (= $ATTR $NEG_VAL) (= $ATTR $EXT_VAL)) + ( (== (= - (domaintype $ATTR structured) true)) + (domaintype $ATTR structured) true) + (get-atoms &self)) (set-det) (supremum $ATTR $EXT_VAL $POS_VAL) (not (supremum $ATTR $EXT_VAL $NEG_VAL)) (parent $ATTR $EXT_VAL $EXT_PARENT) (supremum $ATTR $EXT_PARENT $NEG_VAL))) -; - - (= - (refunion - (Cons $C1 - (Cons $C2 $T)) $REFU) - ( (set-det) - (refu $C1 $C2 $C3) - (refunion - (Cons $C3 $T) $REFU))) -; - - (= + (= (refunion (Cons $C1 (Cons $C2 $T)) $REFU) + (set-det) + (refu $C1 $C2 $C3) (refunion - (:: $COMP) $COMP) + (Cons $C3 $T) $REFU)) + (= (refunion (:: $COMP) $COMP) (set-det)) -; - - - - (= - (refu - (Cons - (= $A $V1) $C1) - (Cons - (= $A $V2) $C2) - (Cons - (= $A $VU) $CU)) - ( (selunion - (= $A $V1) - (= $A $V2) - (= $A $VU)) - (set-det) - (refu $C1 $C2 $CU))) -; - (= - (refu - (Cons - (= $A1 $V1) $C1) - (Cons - (= $A2 $V2) $C2) $U) - ( (@< $A1 $A2) - (set-det) - (refu $C1 - (Cons - (= $A2 $V2) $C2) $U))) -; - (= + (= (refu (Cons (= $A $V1) $C1) (Cons (= $A $V2) $C2) (Cons (= $A $VU) $CU)) + (selunion + (= $A $V1) + (= $A $V2) + (= $A $VU)) + (set-det) + (refu $C1 $C2 $CU)) + (= (refu (Cons (= $A1 $V1) $C1) (Cons (= $A2 $V2) $C2) $U) + (@< $A1 $A2) + (set-det) + (refu $C1 + (Cons + (= $A2 $V2) $C2) $U)) + (= (refu (Cons (= $A1 $V1) $C1) (Cons (= $A2 $V2) $C2) $U) + (set-det) (refu (Cons - (= $A1 $V1) $C1) - (Cons - (= $A2 $V2) $C2) $U) - ( (set-det) (refu (Cons (= $A1 $V1) $C1) $C2 $U))) -; - - (= - (refu Nil $_ Nil) + (= $A1 $V1) $C1) $C2 $U)) + (= (refu Nil $_ Nil) (set-det)) -; - - (= - (refu $_ Nil Nil) + (= (refu $_ Nil Nil) (set-det)) -; - - (= - (selunion - (= $ATTR $VALS1) - (= $ATTR $VALS2) - (= $ATTR $UVALS)) - ( (get-symbols &self + (= (selunion (= $ATTR $VALS1) (= $ATTR $VALS2) (= $ATTR $UVALS)) + ( (== (= - (domaintype $ATTR nominal) true)) + (domaintype $ATTR nominal) true) + (get-atoms &self)) (set-det) (union $VALS1 $VALS2 $UVALS) - (get-symbols &self + (== (= - (valueset $ATTR $ALL_VALS) true)) + (valueset $ATTR $ALL_VALS) true) + (get-atoms &self)) (not (equals $UVALS $ALL_VALS)))) -; - - (= - (selunion - (= $ATTR $VALS1) - (= $ATTR $VALS2) - (= $ATTR $UVALS)) - ( (get-symbols &self + (= (selunion (= $ATTR $VALS1) (= $ATTR $VALS2) (= $ATTR $UVALS)) + ( (== (= - (domaintype $ATTR linear) true)) + (domaintype $ATTR linear) true) + (get-atoms &self)) (set-det) (low $VALS1 $L1) (low $VALS2 $L2) @@ -1080,301 +831,175 @@ (highest $VALS2 $H2) (max (:: $H1 $H2) $HIGH) - (get-symbols &self + (== (= - (range $ATTR $MIN $MAX) true)) + (range $ATTR $MIN $MAX) true) + (get-atoms &self)) (not (= $LOW $MIN)) (not (== $HIGH $MAX)) (== $UVALS (:: (.. $LOW $HIGH))) (set-det))) -; - - (= - (selunion - (= $ATTR $VAL1) - (= $ATTR $VAL2) - (= $ATTR $UV_AL)) - ( (get-symbols &self + (= (selunion (= $ATTR $VAL1) (= $ATTR $VAL2) (= $ATTR $UV_AL)) + ( (== (= - (domaintype $ATTR structured) true)) + (domaintype $ATTR structured) true) + (get-atoms &self)) (supremum $ATTR $UV_AL $VAL1) (supremum $ATTR $UV_AL $VAL2))) -; - - (= - (product - (Cons - (= $A $V1) $T1) - (Cons - (= $A $V2) $T2) - (Cons - (= $A $V3) $T3)) - ( (set-det) - (selproduct - (= $A $V1) - (= $A $V2) - (= $A $V3)) - (set-det) - (product $T1 $T2 $T3))) -; - - (= + (= (product (Cons (= $A $V1) $T1) (Cons (= $A $V2) $T2) (Cons (= $A $V3) $T3)) + (set-det) + (selproduct + (= $A $V1) + (= $A $V2) + (= $A $V3)) + (set-det) + (product $T1 $T2 $T3)) + (= (product (Cons (= $A1 $V1) $T1) (Cons (= $A2 $V2) $T2) (Cons (= $A1 $V1) $T3)) + (@< $A1 $A2) + (set-det) (product (Cons - (= $A1 $V1) $T1) - (Cons - (= $A2 $V2) $T2) - (Cons - (= $A1 $V1) $T3)) - ( (@< $A1 $A2) - (set-det) - (product - (Cons - (= $A2 $V2) $T2) $T1 $T3))) -; - - (= + (= $A2 $V2) $T2) $T1 $T3)) + (= (product (Cons (= $A1 $V1) $T1) (Cons (= $A2 $V2) $T2) (Cons (= $A2 $V2) $T3)) + (set-det) (product (Cons - (= $A1 $V1) $T1) - (Cons - (= $A2 $V2) $T2) - (Cons - (= $A2 $V2) $T3)) - ( (set-det) (product (Cons (= $A1 $V1) $T1) $T2 $T3))) -; - - (= - (product $X Nil $X) + (= $A1 $V1) $T1) $T2 $T3)) + (= (product $X Nil $X) (set-det)) -; - - (= - (product Nil $X $X) + (= (product Nil $X $X) (set-det)) -; - - (= - (selproduct - (= $ATTR $VALS1) - (= $ATTR $VALS2) - (= $ATTR $PROD_VALS)) - ( (get-symbols &self + (= (selproduct (= $ATTR $VALS1) (= $ATTR $VALS2) (= $ATTR $PROD_VALS)) + ( (== (= - (domaintype $ATTR nominal) true)) + (domaintype $ATTR nominal) true) + (get-atoms &self)) (set-det) (intersection $VALS1 $VALS2 $PROD_VALS) (not (= $PROD_VALS Nil)))) -; - - (= - (selproduct - (= $ATTR $VALS1) - (= $ATTR $VALS2) - (= $ATTR $PROD_VALS)) - ( (get-symbols &self + (= (selproduct (= $ATTR $VALS1) (= $ATTR $VALS2) (= $ATTR $PROD_VALS)) + ( (== (= - (domaintype $ATTR linear) true)) + (domaintype $ATTR linear) true) + (get-atoms &self)) (set-det) (productlin $VALS1 $VALS2 $PROD_VALS) (not (= $PROD_VALS Nil)))) -; - - (= - (selproduct - (= $ATTR $VALS1) - (= $ATTR $VALS2) - (= $ATTR $VALS1)) - ( (get-symbols &self + (= (selproduct (= $ATTR $VALS1) (= $ATTR $VALS2) (= $ATTR $VALS1)) + ( (== (= - (domaintype $ATTR structured) true)) + (domaintype $ATTR structured) true) + (get-atoms &self)) (supremum $ATTR $VALS2 $VALS1) (set-det))) -; - - (= - (selproduct - (= $ATTR $VALS1) - (= $ATTR $VALS2) - (= $ATTR $VALS2)) - ( (get-symbols &self + (= (selproduct (= $ATTR $VALS1) (= $ATTR $VALS2) (= $ATTR $VALS2)) + ( (== (= - (domaintype $ATTR structured) true)) + (domaintype $ATTR structured) true) + (get-atoms &self)) (supremum $ATTR $VALS1 $VALS2) (set-det))) -; - - - - (= - (trim $COMP $COVERED_EVENTS $TRIMMED_COMP) - ( (set-det) - (refunion $COVERED_EVENTS $REFU) - (trimcomp $COMP $REFU $TRIMMED_COMP))) -; + (= (trim $COMP $COVERED_EVENTS $TRIMMED_COMP) + (set-det) + (refunion $COVERED_EVENTS $REFU) + (trimcomp $COMP $REFU $TRIMMED_COMP)) - (= - (trimcomp - (Cons - (= $A $V1) $C1) - (Cons - (= $A $VU) $CU) - (Cons - (= $A $VT) $CT)) - ( (set-det) - (selproduct - (= $A $V1) - (= $A $VU) - (= $A $VT)) - (trimcomp $C1 $CU $CT))) -; - - (= - (trimcomp - (Cons - (= $A1 $V1) $C1) - (Cons - (= $A2 $VU) $CU) $CT) - ( (@< $A2 $A1) - (set-det) - (trimcomp - (Cons - (= $A1 $V1) $C1) $CU $CT))) -; - (= + (= (trimcomp (Cons (= $A $V1) $C1) (Cons (= $A $VU) $CU) (Cons (= $A $VT) $CT)) + (set-det) + (selproduct + (= $A $V1) + (= $A $VU) + (= $A $VT)) + (trimcomp $C1 $CU $CT)) + (= (trimcomp (Cons (= $A1 $V1) $C1) (Cons (= $A2 $VU) $CU) $CT) + (@< $A2 $A1) + (set-det) (trimcomp (Cons - (= $A1 $V1) $C1) + (= $A1 $V1) $C1) $CU $CT)) + (= (trimcomp (Cons (= $A1 $V1) $C1) (Cons (= $A2 $VU) $CU) (Cons (= $A1 $V1) $CT)) + (set-det) + (trimcomp $C1 (Cons - (= $A2 $VU) $CU) - (Cons - (= $A1 $V1) $CT)) - ( (set-det) (trimcomp $C1 (Cons (= $A2 $VU) $CU) $CT))) -; - - (= - (trimcomp $X Nil $X) + (= $A2 $VU) $CU) $CT)) + (= (trimcomp $X Nil $X) (set-det)) -; - - (= - (trimcomp Nil $_ Nil) + (= (trimcomp Nil $_ Nil) (set-det)) -; - - (= - (encodeevents Nil Nil) + (= (encodeevents Nil Nil) (set-det)) -; - - (= - (encodeevents - (Cons $E $REST) - (Cons $EE $ENCODE_REST)) - ( (set-det) - (encodeevent $E Nil $EE) - (encodeevents $REST $ENCODE_REST))) -; + (= (encodeevents (Cons $E $REST) (Cons $EE $ENCODE_REST)) + (set-det) + (encodeevent $E Nil $EE) + (encodeevents $REST $ENCODE_REST)) - - (= - (encodeevent Nil $EVENT $EVENT) + (= (encodeevent Nil $EVENT $EVENT) (set-det)) -; - - (= - (encodeevent - (Cons $SEL $E) $PARTIAL_EV $NEW_PARTIAL_EV) - ( (set-det) - (encodesel $SEL $ENCODED_SEL) - (newselector $PARTIAL_EV $ENCODED_SEL $PPEV) - (encodeevent $E $PPEV $NEW_PARTIAL_EV))) -; - + (= (encodeevent (Cons $SEL $E) $PARTIAL_EV $NEW_PARTIAL_EV) + (set-det) + (encodesel $SEL $ENCODED_SEL) + (newselector $PARTIAL_EV $ENCODED_SEL $PPEV) + (encodeevent $E $PPEV $NEW_PARTIAL_EV)) - (= - (encodesel - (:: (= $ATTR $VAL)) - (= $ATTR - (:: $VAL))) - ( (get-symbols &self + (= (encodesel (:: (= $ATTR $VAL)) (= $ATTR (:: $VAL))) + ( (== (= - (domaintype $ATTR nominal) true)) (set-det))) -; - - (= - (encodesel - (:: (= $ATTR $VAL)) - (= $ATTR - (:: (.. $VAL $VAL)))) - ( (get-symbols &self + (domaintype $ATTR nominal) true) + (get-atoms &self)) (set-det))) + (= (encodesel (:: (= $ATTR $VAL)) (= $ATTR (:: (.. $VAL $VAL)))) + ( (== (= - (domaintype $ATTR linear) true)) - (get-symbols &self + (domaintype $ATTR linear) true) + (get-atoms &self)) + (== (= - (subtyp $ATTR integer) true)) + (subtyp $ATTR integer) true) + (get-atoms &self)) (set-det))) -; - - (= - (encodesel - (:: (= $ATTR $SYM)) - (= $ATTR - (:: (.. $ORD $ORD)))) - ( (get-symbols &self + (= (encodesel (:: (= $ATTR $SYM)) (= $ATTR (:: (.. $ORD $ORD)))) + ( (== (= - (domaintype $ATTR linear) true)) - (get-symbols &self + (domaintype $ATTR linear) true) + (get-atoms &self)) + (== (= - (subtyp $ATTR symbolic) true)) + (subtyp $ATTR symbolic) true) + (get-atoms &self)) (set-det) (ord $ATTR $SYM $ORD))) -; - - (= - (encodesel - (:: (= $ATTR $VAL)) - (= $ATTR $VAL)) - ( (get-symbols &self + (= (encodesel (:: (= $ATTR $VAL)) (= $ATTR $VAL)) + ( (== (= - (domaintype $ATTR structured) true)) (set-det))) -; - - (= - (encodesel $S $_) - ( (write '===> ERROR - unknown selector type: ') (write $S))) -; + (domaintype $ATTR structured) true) + (get-atoms &self)) (set-det))) + (= (encodesel $S $_) + (write '===> ERROR - unknown selector type: ') + (write $S)) - - (= - (showcovers) - ( (get-symbols &self + (= (showcovers) + ( (== (= - (class $CLASS) true)) + (class $CLASS) true) + (get-atoms &self)) (showcover $CLASS) (fail))) -; - - (= showcovers True) -; + (= showcovers True) - - (= - (showcover $CLASS) + (= (showcover $CLASS) ( (nl) (nl) (write '===> Cover of class ') @@ -1382,984 +1007,595 @@ (write :) (set-det) (nl) - (get-symbols &self + (== (= - (cover $CLASS $COVER) true)) + (cover $CLASS $COVER) true) + (get-atoms &self)) (printcomplex $COVER) (nl) (fail))) -; - - (= - (showcover $_) True) -; - - + (= (showcover $_) True) - (= - (printcomplex $COMPLEX) - ( (member $SELECTOR $COMPLEX) - (printselector $SELECTOR) - (fail))) -; - (= - (printcomplex $_) + (= (printcomplex $COMPLEX) + (member $SELECTOR $COMPLEX) + (printselector $SELECTOR) + (fail)) + (= (printcomplex $_) (set-det)) -; - - (= - (printselector (= $ATTR $VALS)) - ( (get-symbols &self + (= (printselector (= $ATTR $VALS)) + ( (== (= - (domaintype $ATTR nominal) true)) + (domaintype $ATTR nominal) true) + (get-atoms &self)) (set-det) (write [) (write $ATTR) (write = ) (prinlist $VALS) (write ]))) -; - - (= - (printselector (= $ATTR $VALS)) - ( (get-symbols &self + (= (printselector (= $ATTR $VALS)) + ( (== (= - (domaintype $ATTR linear) true)) - (get-symbols &self + (domaintype $ATTR linear) true) + (get-atoms &self)) + (== (= - (subtyp $ATTR integer) true)) + (subtyp $ATTR integer) true) + (get-atoms &self)) (set-det) (write [) (write $ATTR) (write = ) (prinlin $VALS) (write ]))) -; - - (= - (printselector (= $ATTR $VALS)) - ( (get-symbols &self + (= (printselector (= $ATTR $VALS)) + ( (== (= - (domaintype $ATTR linear) true)) - (get-symbols &self + (domaintype $ATTR linear) true) + (get-atoms &self)) + (== (= - (subtyp $ATTR symbolic) true)) + (subtyp $ATTR symbolic) true) + (get-atoms &self)) (set-det) (write [) (write $ATTR) (write = ) (prinsym $ATTR $VALS) (write ]))) -; - - (= - (printselector (= $ATTR $VAL)) - ( (get-symbols &self + (= (printselector (= $ATTR $VAL)) + ( (== (= - (domaintype $ATTR structured) true)) + (domaintype $ATTR structured) true) + (get-atoms &self)) (set-det) (write [) (write $ATTR) (write = ) (write $VAL) (write ]))) -; - - (= - (intersection - (Cons $A $B) - (Cons $A $C) - (Cons $A $X)) - ( (set-det) (intersection $B $C $X))) -; - - (= + (= (intersection (Cons $A $B) (Cons $A $C) (Cons $A $X)) + (set-det) + (intersection $B $C $X)) + (= (intersection (Cons $A $B) (Cons $C $D) $X) + (@< $A $C) + (set-det) (intersection - (Cons $A $B) - (Cons $C $D) $X) - ( (@< $A $C) - (set-det) - (intersection - (Cons $C $D) $B $X))) -; - - (= + (Cons $C $D) $B $X)) + (= (intersection (Cons $A $B) (Cons $C $D) $X) + (set-det) (intersection - (Cons $A $B) - (Cons $C $D) $X) - ( (set-det) (intersection (Cons $A $B) $D $X))) -; - - (= - (intersection $Y Nil Nil) + (Cons $A $B) $D $X)) + (= (intersection $Y Nil Nil) (set-det)) -; - - (= - (intersection Nil $Y Nil) + (= (intersection Nil $Y Nil) (set-det)) -; - - (= - (difference - (Cons $A $B) - (Cons $A $C) $X) - ( (set-det) (difference $B $C $X))) -; - - (= - (difference - (Cons $A $B) - (Cons $C $D) - (Cons $A $X)) - ( (@< $A $C) - (set-det) - (difference $B - (Cons $C $D) $X))) -; - - (= + (= (difference (Cons $A $B) (Cons $A $C) $X) + (set-det) + (difference $B $C $X)) + (= (difference (Cons $A $B) (Cons $C $D) (Cons $A $X)) + (@< $A $C) + (set-det) + (difference $B + (Cons $C $D) $X)) + (= (difference (Cons $A $B) (Cons $C $D) (Cons $C $X)) + (set-det) (difference - (Cons $A $B) - (Cons $C $D) - (Cons $C $X)) - ( (set-det) (difference (Cons $A $B) $D $X))) -; - - (= - (difference $Y Nil $Y) + (Cons $A $B) $D $X)) + (= (difference $Y Nil $Y) (set-det)) -; - - (= - (difference Nil $Y Nil) + (= (difference Nil $Y Nil) (set-det)) -; - - (= + (= (union (Cons $A $B) (Cons $A $C) (Cons $A $X)) + (set-det) + (union $B $C $X)) + (= (union (Cons $A $B) (Cons $C $D) (Cons $A $X)) + (@< $A $C) + (set-det) (union - (Cons $A $B) - (Cons $A $C) - (Cons $A $X)) - ( (set-det) (union $B $C $X))) -; - - (= + (Cons $C $D) $B $X)) + (= (union (Cons $A $B) (Cons $C $D) (Cons $C $X)) + (set-det) (union - (Cons $A $B) - (Cons $C $D) - (Cons $A $X)) - ( (@< $A $C) - (set-det) - (union - (Cons $C $D) $B $X))) -; - - (= - (union - (Cons $A $B) - (Cons $C $D) - (Cons $C $X)) - ( (set-det) (union (Cons $A $B) $D $X))) -; - - (= - (union $Y Nil $Y) + (Cons $A $B) $D $X)) + (= (union $Y Nil $Y) (set-det)) -; - - (= - (union Nil $Y $Y) + (= (union Nil $Y $Y) (set-det)) -; - - (= + (= (disjoint (Cons $A $B) (Cons $C $D)) + (@< $A $C) + (set-det) (disjoint - (Cons $A $B) - (Cons $C $D)) - ( (@< $A $C) - (set-det) - (disjoint - (Cons $C $D) $B))) -; - - (= + (Cons $C $D) $B)) + (= (disjoint (Cons $A $B) (Cons $C $D)) + (@< $C $A) + (set-det) (disjoint - (Cons $A $B) - (Cons $C $D)) - ( (@< $C $A) - (set-det) - (disjoint - (Cons $A $B) $D))) -; - - (= - (disjoint $_ Nil) + (Cons $A $B) $D)) + (= (disjoint $_ Nil) (set-det)) -; - - (= - (disjoint Nil $_) + (= (disjoint Nil $_) (set-det)) -; - - - (= - (subset - (Cons $A $B) - (Cons $A $C)) - ( (set-det) (subset $B $C))) -; - (= + (= (subset (Cons $A $B) (Cons $A $C)) + (set-det) + (subset $B $C)) + (= (subset (Cons $A $B) (Cons $C $D)) + (@> $A $C) + (set-det) (subset - (Cons $A $B) - (Cons $C $D)) - ( (@> $A $C) - (set-det) - (subset - (Cons $A $B) $D))) -; - - (= - (subset Nil $_) + (Cons $A $B) $D)) + (= (subset Nil $_) (set-det)) -; - - - - (= - (equals $X $Y) - ( (= $X $Y) (set-det))) -; + (= (equals $X $Y) + (= $X $Y) + (set-det)) - (= - (cardinality $X $N) - ( (set-det) (length $X $N))) -; + (= (cardinality $X $N) + (set-det) + (length $X $N)) - (= - (ord $ATTR $SYM $N) - ( (get-symbols &self + (= (ord $ATTR $SYM $N) + ( (== (= - (order $ATTR $L) true)) + (order $ATTR $L) true) + (get-atoms &self)) (at $SYM $L $N 1) (set-det))) -; - - (= - (at $SYM - (Cons $SYM $X) $N $N) True) -; - - (= - (at $SYM - (Cons $_ $X) $N $I) - ( (is $J - (+ $I 1)) - (at $SYM $X $N $J) - (set-det))) -; - - (= - (at $_ $_ $_ $_) + (= (at $SYM (Cons $SYM $X) $N $N) True) + (= (at $SYM (Cons $_ $X) $N $I) + (is $J + (+ $I 1)) + (at $SYM $X $N $J) + (set-det)) + (= (at $_ $_ $_ $_) (write '===> ERROR - symbol undeclared')) -; - - (= - (low - (Cons - (.. $L $H) $_) $L) True) -; + (= (low (Cons (.. $L $H) $_) $L) True) + (= (highest ((.. $L $H)) $H) True) + (= (highest (Cons (.. $L $H) $X) $HIGH) + (set-det) + (highest $X $HIGH)) - (= - (highest - ( (.. $L $H)) $H) True) -; - (= - (highest + (= (includeslin $_ ()) True) + (= (includeslin (Cons (.. $LO $HO) $XO) (Cons (.. $LI $HI) $XI)) + (@< $HO $LI) + (set-det) + (includeslin $XO (Cons - (.. $L $H) $X) $HIGH) - ( (set-det) (highest $X $HIGH))) -; - - - - (= - (includeslin $_ ()) True) -; - - (= + (.. $LI $HI) $XI))) + (= (includeslin (Cons (.. $LO $HO) $XO) (Cons (.. $LI $HI) $XI)) + (set-det) + (@=< $LO $LI) + (@>= $HO $HI) (includeslin (Cons - (.. $LO $HO) $XO) - (Cons - (.. $LI $HI) $XI)) - ( (@< $HO $LI) - (set-det) - (includeslin $XO - (Cons - (.. $LI $HI) $XI)))) -; + (.. $LO $HO) $XO) $XI)) - (= - (includeslin - (Cons - (.. $LO $HO) $XO) - (Cons - (.. $LI $HI) $XI)) - ( (set-det) - (@=< $LO $LI) - (@>= $HO $HI) - (includeslin - (Cons - (.. $LO $HO) $XO) $XI))) -; - - - (= - (disjointlin Nil $_) + (= (disjointlin Nil $_) (set-det)) -; - - (= - (disjointlin $_ Nil) + (= (disjointlin $_ Nil) (set-det)) -; - - (= - (disjointlin - (Cons - (.. $L1 $H1) $X1) - (Cons - (.. $L2 $H2) $X2)) - ( (@< $H1 $L2) - (set-det) - (disjointlin $X1 - (Cons - (.. $L2 $H2) $X2)))) -; - - (= - (disjointlin + (= (disjointlin (Cons (.. $L1 $H1) $X1) (Cons (.. $L2 $H2) $X2)) + (@< $H1 $L2) + (set-det) + (disjointlin $X1 (Cons - (.. $L1 $H1) $X1) + (.. $L2 $H2) $X2))) + (= (disjointlin (Cons (.. $L1 $H1) $X1) (Cons (.. $L2 $H2) $X2)) + (@< $H2 $L1) + (set-det) + (disjointlin $X2 (Cons - (.. $L2 $H2) $X2)) - ( (@< $H2 $L1) - (set-det) - (disjointlin $X2 - (Cons - (.. $L1 $H1) $X1)))) -; - + (.. $L1 $H1) $X1))) - (= - (negatelin $ATTR + (= (negatelin $ATTR (Cons (.. $LP $HP) $XP) $N) + (set-det) + (neglinlow $ATTR $LP $LOW) + (neglinmid (Cons - (.. $LP $HP) $XP) $N) - ( (set-det) - (neglinlow $ATTR $LP $LOW) - (neglinmid - (Cons - (.. $LP $HP) $XP) $HI $MID) - (neglinhi $ATTR $HI $HIGH) - (appendx - (:: $LOW $MID $HIGH) $N))) -; + (.. $LP $HP) $XP) $HI $MID) + (neglinhi $ATTR $HI $HIGH) + (appendx + (:: $LOW $MID $HIGH) $N)) - - (= - (neglinlow $ATTR $LP Nil) - ( (get-symbols &self + (= (neglinlow $ATTR $LP Nil) + ( (== (= - (range $ATTR $LP $_) true)) (set-det))) -; - - (= - (neglinlow $ATTR $LP - (:: (.. $LOW $H))) + (range $ATTR $LP $_) true) + (get-atoms &self)) (set-det))) + (= (neglinlow $ATTR $LP (:: (.. $LOW $H))) ( (set-det) - (get-symbols &self + (== (= - (range $ATTR $LOW $_) true)) + (range $ATTR $LOW $_) true) + (get-atoms &self)) (is $H (- $LP 1)))) -; - - (= - (neglinmid - (:: (.. $L $H)) $H Nil) + (= (neglinmid (:: (.. $L $H)) $H Nil) (set-det)) -; - - (= - (neglinmid - (Cons - (.. $L1 $H1) - (Cons - (.. $L2 $H2) $X)) $HI - (:: - (.. $L $H) $N)) - ( (> $L2 - (+ $H1 1)) - (set-det) - (is $L - (+ $H1 1)) - (is $H - (- $L2 1)) - (neglinmid - (Cons - (.. $L2 $H2) $X) $HI $N))) -; - - (= + (= (neglinmid (Cons (.. $L1 $H1) (Cons (.. $L2 $H2) $X)) $HI (:: (.. $L $H) $N)) + (> $L2 + (+ $H1 1)) + (set-det) + (is $L + (+ $H1 1)) + (is $H + (- $L2 1)) (neglinmid (Cons - (.. $L1 $H1) - (Cons - (.. $L2 $H2) $X)) $HI $N) - ( (set-det) (neglinmid $X $HI $N))) -; - + (.. $L2 $H2) $X) $HI $N)) + (= (neglinmid (Cons (.. $L1 $H1) (Cons (.. $L2 $H2) $X)) $HI $N) + (set-det) + (neglinmid $X $HI $N)) - (= - (neglinhi $ATTR $HI Nil) - ( (get-symbols &self + (= (neglinhi $ATTR $HI Nil) + ( (== (= - (range $ATTR $_ $HI) true)) (set-det))) -; - - (= - (neglinhi $ATTR $HI - (:: (.. $L $HIGH))) + (range $ATTR $_ $HI) true) + (get-atoms &self)) (set-det))) + (= (neglinhi $ATTR $HI (:: (.. $L $HIGH))) ( (set-det) - (get-symbols &self + (== (= - (range $ATTR $_ $HIGH) true)) + (range $ATTR $_ $HIGH) true) + (get-atoms &self)) (is $L (+ $HI 1)))) -; - - (= - (extendedlin $_ Nil Nil) + (= (extendedlin $_ Nil Nil) (set-det)) -; - - (= - (extendedlin Nil $_ Nil) + (= (extendedlin Nil $_ Nil) (set-det)) -; - - (= - (extendedlin - (Cons - (.. $LP $HP) $XP) - (Cons - (.. $LN $HN) $XN) $XVALS) - ( (@< $HN $LP) - (set-det) - (extendedlin - (Cons - (.. $LP $HP) $XP) $XN $XVALS))) -; - - (= - (extendedlin - (Cons - (.. $LP $HP) $XP) - (Cons - (.. $LN $HN) $XN) $XVALS) - ( (@< $HP $LN) - (set-det) - (extendedlin $XP - (Cons - (.. $LN $HN) $XN) $XVALS))) -; - - (= + (= (extendedlin (Cons (.. $LP $HP) $XP) (Cons (.. $LN $HN) $XN) $XVALS) + (@< $HN $LP) + (set-det) (extendedlin (Cons - (.. $LP $HP) $XP) - (Cons - (.. $LN $HN) $XN) + (.. $LP $HP) $XP) $XN $XVALS)) + (= (extendedlin (Cons (.. $LP $HP) $XP) (Cons (.. $LN $HN) $XN) $XVALS) + (@< $HP $LN) + (set-det) + (extendedlin $XP (Cons - (.. $LN $HN) $XVALS)) - ( (set-det) - (@=< $LN $LP) - (@>= $HN $HP) - (extendedlin $XP $XN $XVALS))) -; - + (.. $LN $HN) $XN) $XVALS)) + (= (extendedlin (Cons (.. $LP $HP) $XP) (Cons (.. $LN $HN) $XN) (Cons (.. $LN $HN) $XVALS)) + (set-det) + (@=< $LN $LP) + (@>= $HN $HP) + (extendedlin $XP $XN $XVALS)) - (= - (productlin Nil $_ Nil) + (= (productlin Nil $_ Nil) (set-det)) -; - - (= - (productlin $_ Nil Nil) + (= (productlin $_ Nil Nil) + (set-det)) + (= (productlin (Cons (.. $L1 $H1) $X1) (Cons (.. $L2 $H2) $X2) $P) + (@< $H1 $L2) + (set-det) + (productlin $X1 + (Cons + (.. $L2 $H2) $X2) $P)) + (= (productlin (Cons (.. $L1 $H1) $X1) (Cons (.. $L2 $H2) $X2) $P) + (@< $H2 $L1) + (set-det) + (productlin $X2 + (Cons + (.. $L1 $H1) $X1) $P)) + (= (productlin (Cons (.. $L1 $H1) $X1) (Cons (.. $L2 $H2) $X2) (Cons (.. $L $H) $P)) + (set-det) + (max + (:: $L1 $L2) $L) + (min + (:: $H1 $H2) $H) + (productlin $X1 $X2 $P)) + + + (= (prinlin (:: $A)) + (set-det) + (prinseg $A)) + (= (prinlin (:: $A $B)) + (set-det) + (prinseg $A) + (write ' v ') + (prinlin $B)) + (= (prinlin Nil) + (set-det) + (write '===> ERROR - null RHS in linear selector')) + + + (= (prinseg (.. $L $H)) + (= $L $H) + (write $L) + (set-det)) + (= (prinseg $A) + (write $A) (set-det)) -; - - (= - (productlin - (Cons - (.. $L1 $H1) $X1) - (Cons - (.. $L2 $H2) $X2) $P) - ( (@< $H1 $L2) - (set-det) - (productlin $X1 - (Cons - (.. $L2 $H2) $X2) $P))) -; - - (= - (productlin - (Cons - (.. $L1 $H1) $X1) - (Cons - (.. $L2 $H2) $X2) $P) - ( (@< $H2 $L1) - (set-det) - (productlin $X2 - (Cons - (.. $L1 $H1) $X1) $P))) -; - - (= - (productlin - (Cons - (.. $L1 $H1) $X1) - (Cons - (.. $L2 $H2) $X2) - (Cons - (.. $L $H) $P)) - ( (set-det) - (max - (:: $L1 $L2) $L) - (min - (:: $H1 $H2) $H) - (productlin $X1 $X2 $P))) -; - - - - (= - (prinlin (:: $A)) - ( (set-det) (prinseg $A))) -; - - (= - (prinlin (:: $A $B)) - ( (set-det) - (prinseg $A) - (write ' v ') - (prinlin $B))) -; - - (= - (prinlin Nil) - ( (set-det) (write '===> ERROR - null RHS in linear selector'))) -; - - - - (= - (prinseg (.. $L $H)) - ( (= $L $H) - (write $L) - (set-det))) -; - - (= - (prinseg $A) - ( (write $A) (set-det))) -; - - - - (= - (prinsym $ATTR - (:: $A)) - ( (set-det) (prinsymseg $ATTR $A))) -; - - (= - (prinsym $ATTR - (Cons $A $B)) - ( (set-det) - (prinsymseg $ATTR $A) - (write ,) - (prinsym $ATTR $B))) -; - (= - (prinsym $_ Nil) - ( (set-det) (write '===> ERROR - null RHS in linear selector'))) -; + (= (prinsym $ATTR (:: $A)) + (set-det) + (prinsymseg $ATTR $A)) + (= (prinsym $ATTR (Cons $A $B)) + (set-det) + (prinsymseg $ATTR $A) + (write ,) + (prinsym $ATTR $B)) + (= (prinsym $_ Nil) + (set-det) + (write '===> ERROR - null RHS in linear selector')) - (= - (prinsymseg $ATTR - (.. $L $H)) - ( (= $L $H) - (ord $ATTR $SYM $L) - (write $SYM) - (set-det))) -; - - (= - (prinsymseg $ATTR - (.. $L $H)) - ( (ord $ATTR $SYML $L) - (ord $ATTR $SYMH $H) - (write (.. $SYML $SYMH)) - (set-det))) -; - + (= (prinsymseg $ATTR (.. $L $H)) + (= $L $H) + (ord $ATTR $SYM $L) + (write $SYM) + (set-det)) + (= (prinsymseg $ATTR (.. $L $H)) + (ord $ATTR $SYML $L) + (ord $ATTR $SYMH $H) + (write (.. $SYML $SYMH)) + (set-det)) - (= - (supremum $ATTR $HI_NODE $LO_NODE) - ( (get-symbols &self + (= (supremum $ATTR $HI_NODE $LO_NODE) + ( (== (= - (ancest $ATTR $LO_NODE $ALIST) true)) (member $HI_NODE $ALIST))) -; - - (= - (supremum $ATTR $X $X) True) -; - - - - (= - (parent $ATTR $NODE $PARENT) - (get-symbols &self + (ancest $ATTR $LO_NODE $ALIST) true) + (get-atoms &self)) (member $HI_NODE $ALIST))) +; /******************************************************************/ +; /* In AQ-PROLOG the procedure 'predecessor' is called 'ancestor'. */ +; /* Because in some (I think the most) PROLOG dialects a build-in */ +; /* predicate 'ancestor' exists, I preferred to rename it. */ +; /******************************************************************/ + (= (supremum $ATTR $X $X) True) + + + (= (parent $ATTR $NODE $PARENT) + (== (= (ancest $ATTR $NODE - (Cons $PARENT $_)) true))) -; - + (Cons $PARENT $_)) true) + (get-atoms &self))) - (= - (explodestruc $ATTR $STRUCTUR_SPEC) + (= (explodestruc $ATTR $STRUCTUR_SPEC) ( (allnodes $STRUCTUR_SPEC $NODE_LIST) (member $NODE $NODE_LIST) (predecessorlist $NODE $STRUCTUR_SPEC $ALIST) - (add-symbol &self + (add-is-symbol &self (ancest $ATTR $NODE $ALIST)) (fail))) -; + (= (explodestruc $_ $_) True) - (= - (explodestruc $_ $_) True) -; - - - (= - (allnodes Nil Nil) + (= (allnodes Nil Nil) (set-det)) -; - - (= - (allnodes - (Cons - (parent $SIBS $P) $X) $NODE_LIST) - ( (set-det) - (qsort $SIBS $L1) - (union $L1 - (:: $P) $L2) - (allnodes $X $L3) - (union $L2 $L3 $NODE_LIST))) -; - - - - (= - (predecessorlist $NODE $STRUCTUR_SPEC - (Cons $P $X)) - ( (father $NODE $STRUCTUR_SPEC $P) - (set-det) - (predecessorlist $P $STRUCTUR_SPEC $X))) -; - - (= - (predecessorlist $_ $_ Nil) + (= (allnodes (Cons (parent $SIBS $P) $X) $NODE_LIST) + (set-det) + (qsort $SIBS $L1) + (union $L1 + (:: $P) $L2) + (allnodes $X $L3) + (union $L2 $L3 $NODE_LIST)) + + + (= (predecessorlist $NODE $STRUCTUR_SPEC (Cons $P $X)) + (father $NODE $STRUCTUR_SPEC $P) + (set-det) + (predecessorlist $P $STRUCTUR_SPEC $X)) +; /******************************************************************/ +; /* In AQ-PROLOG the procedure 'predecessorlist' is called */ +; /* 'ancestorlist' Because I wanna be a little bit consistend in */ +; /* the naming of predicates and 'ancestor' was already renamed */ +; /* I preferred to rename this predicate too. */ +; /******************************************************************/ + (= (predecessorlist $_ $_ Nil) (set-det)) -; - - - - (= - (father $NODE - (Cons - (parent $SIBS $P) $X) $P) - ( (member $NODE $SIBS) (set-det))) -; - - (= - (father $NODE - (Cons $_ $X) $P) - ( (father $NODE $X $P) (set-det))) -; - - (= - (first - (Cons $A $B) $A) + (= (father $NODE (Cons (parent $SIBS $P) $X) $P) + (member $NODE $SIBS) (set-det)) -; - - - - (= - (appendx $X $Y) - ( (findset $A - (, - (member $B $X) - (member $A $B)) $Y) (set-det))) -; - - - - (= - (firstn $_ 0 Nil) + (= (father $NODE (Cons $_ $X) $P) + (father $NODE $X $P) (set-det)) -; - (= - (firstn - (Cons $A $B) $N - (Cons $A $C)) - ( (set-det) - (is $M - (- $N 1)) - (firstn $B $M $C))) -; - (= - (firstn Nil $_ Nil) + (= (first (Cons $A $B) $A) (set-det)) -; - - (= - (following $X - (Cons $X $AFTER_X) $AFTER_X) + (= (appendx $X $Y) + (findset $A + (, + (member $B $X) + (member $A $B)) $Y) (set-det)) -; - (= - (following $X - (Cons $_ $LIST) $AFTER_X) - ( (set-det) (following $X $LIST $AFTER_X))) -; - (= - (following $X Nil Nil) + (= (firstn $_ 0 Nil) (set-det)) -; - - - - (= - (qsort $L0 $L) - ( (qsort $L0 $L Nil) (set-det))) -; - - - (= - (qsort - (Cons $X $L) $R $R0) - ( (partition $L $X $L0 $L1) - (qsort $L1 $R1 $R0) - (qsort $L0 $R - (Cons $X $R1)))) -; - - (= - (qsort Nil $R $R) + (= (firstn (Cons $A $B) $N (Cons $A $C)) + (set-det) + (is $M + (- $N 1)) + (firstn $B $M $C)) + (= (firstn Nil $_ Nil) (set-det)) -; - - (= - (partition - (Cons $X $L) $Y - (Cons $X $L0) $L1) - ( (@=< $X $Y) - (set-det) - (partition $L $Y $L0 $L1))) -; - - (= - (partition - (Cons $X $L) $Y $L0 - (Cons $X $L1)) - ( (set-det) (partition $L $Y $L0 $L1))) -; - - (= - (partition () $_ () ()) True) -; - - - - (= - (remove $X Nil Nil) + (= (following $X (Cons $X $AFTER_X) $AFTER_X) + (set-det)) + (= (following $X (Cons $_ $LIST) $AFTER_X) + (set-det) + (following $X $LIST $AFTER_X)) + (= (following $X Nil Nil) (set-det)) -; - (= - (remove $X - (Cons $X $B) $C) - ( (set-det) (remove $X $B $C))) -; - (= - (remove $X - (Cons $A $B) - (Cons $A $C)) - ( (set-det) (remove $X $B $C))) -; + (= (qsort $L0 $L) + (qsort $L0 $L Nil) + (set-det)) + (= (qsort (Cons $X $L) $R $R0) + (partition $L $X $L0 $L1) + (qsort $L1 $R1 $R0) + (qsort $L0 $R + (Cons $X $R1))) + (= (qsort Nil $R $R) + (set-det)) - (= - (prinlist (:: $A)) - ( (write $A) (set-det))) -; + (= (partition (Cons $X $L) $Y (Cons $X $L0) $L1) + (@=< $X $Y) + (set-det) + (partition $L $Y $L0 $L1)) + (= (partition (Cons $X $L) $Y $L0 (Cons $X $L1)) + (set-det) + (partition $L $Y $L0 $L1)) + (= (partition () $_ () ()) True) - (= - (prinlist (Cons $A $B)) - ( (set-det) - (write $A) - (write ' v ') - (prinlist $B))) -; - (= - (prinlist Nil) - ( (write '===> Nothing to print') (set-det))) -; + (= (remove $X Nil Nil) + (set-det)) + (= (remove $X (Cons $X $B) $C) + (set-det) + (remove $X $B $C)) + (= (remove $X (Cons $A $B) (Cons $A $C)) + (set-det) + (remove $X $B $C)) + (= (prinlist (:: $A)) + (write $A) + (set-det)) + (= (prinlist (Cons $A $B)) + (set-det) + (write $A) + (write ' v ') + (prinlist $B)) + (= (prinlist Nil) + (write '===> Nothing to print') + (set-det)) - (= - (min - (Cons $X - (Cons $Y $T)) $Z) - ( (@=< $X $Y) - (set-det) - (min - (Cons $X $T) $Z))) -; - (= + (= (min (Cons $X (Cons $Y $T)) $Z) + (@=< $X $Y) + (set-det) (min - (Cons $X - (Cons $Y $T)) $Z) - ( (set-det) (min (Cons $Y $T) $Z))) -; - - (= + (Cons $X $T) $Z)) + (= (min (Cons $X (Cons $Y $T)) $Z) + (set-det) (min - (:: $X) $X) + (Cons $Y $T) $Z)) + (= (min (:: $X) $X) (set-det)) -; - - (= + (= (max (Cons $X (Cons $Y $T)) $Z) + (@>= $X $Y) + (set-det) (max - (Cons $X - (Cons $Y $T)) $Z) - ( (@>= $X $Y) - (set-det) - (max - (Cons $X $T) $Z))) -; - - (= + (Cons $X $T) $Z)) + (= (max (Cons $X (Cons $Y $T)) $Z) + (set-det) (max - (Cons $X - (Cons $Y $T)) $Z) - ( (set-det) (max (Cons $Y $T) $Z))) -; - - (= - (max - (:: $X) $X) + (Cons $Y $T) $Z)) + (= (max (:: $X) $X) (set-det)) -; - - (= - (findset $X $G $L) - ( (findall $X $G $ZWERG) (sort $ZWERG $L))) -; - - - - (= - (help) - ( (nl) - (nl) - (write '===> AQ-PROLOG') - (nl) - (write '===> Load data with command: data(fn)') - (nl) - (write '===> Show data with command: listdata') - (nl) - (write '===> Start AQ with command: start') - (nl) - (nl))) -; - + (= (findset $X $G $L) + (findall $X $G $ZWERG) + (sort $ZWERG $L)) + + + (= (help) + (nl) + (nl) + (write '===> AQ-PROLOG') + (nl) + (write '===> Load data with command: data(fn)') + (nl) + (write '===> Show data with command: listdata') + (nl) + (write '===> Start AQ with command: start') + (nl) + (nl)) +; /******************************************************************/ +; /* This is adopted from the Clocksin/Mellish definition of */ +; /* 'bagof', if you're local PROLOG system does not know 'findall' */ +; /* you should use this definition. AQ is ensured to work correctly*/ +; /* with this definition. In the case that your local MeTTa */ +; /* dialect has 'findall' as built-in and AQ will give no result, */ +; /* it is likely that the problem depends on the 'findall' */ +; /* definition. You should rename the 'findalls' of AQ and try it */ +; /* again. */ +; /******************************************************************/ +; /* findall(X,G,_) :- */ +; /* asserta(yk_found(mark)), call(G), */ +; /* asserta(yk_found(X)), fail . */ +; /* findall(_,_,L) :- */ +; /* yk_collect_found(L) . */ +; /* */ +; /* yk_collect_found([X|L]) :- */ +; /* yk_getnext(X), yk_collect_found(L) . */ +; /* yk_collect_found(nil) . */ +; /* */ +; /* yk_getnext(X) :- */ +; /* retract(yk_found(X)), !, not (X == mark) . */ +; /******************************************************************/ !(help *) -; - diff --git a/aq1/aq1_1.metta b/aq1/aq1_1.metta index ff4b65d..6ef7565 100644 --- a/aq1/aq1_1.metta +++ b/aq1/aq1_1.metta @@ -1,63 +1,21 @@ +; (convert_to_metta_file aq1_1 $_340696 aq1/aq1_1.pl aq1/aq1_1.metta) - (= - (domaintype color nominal) True) -; + (= (domaintype color nominal) True) + (= (valueset color (red green blue)) True) - (= - (valueset color - (red green blue)) True) -; + (= (domaintype temp linear) True) + (= (order temp (cold warm hot)) True) - (= - (domaintype temp linear) True) -; + (= (domaintype shape nominal) True) + (= (valueset shape (square hexagon octagon)) True) - (= - (order temp - (cold warm hot)) True) -; - - - (= - (domaintype shape nominal) True) -; - - - (= - (valueset shape - (square hexagon octagon)) True) -; - - - (= - (classes - (past present future)) True) -; - - - (= - (events past - ( ( ( (= color red)) - ( (= temp warm)) - ( (= shape square))) (((= color green)) ((= temp cold)) ((= shape hexagon))))) True) -; - - (= - (events present - ( ( ( (= color blue)) - ( (= temp warm)) - ( (= shape square))) (((= color red)) ((= temp hot)) ((= shape hexagon))))) True) -; - - (= - (events future - ( ( ( (= color green)) - ( (= temp warm)) - ( (= shape hexagon))) (((= color blue)) ((= temp hot)) ((= shape octagon))))) True) -; + (= (classes (past present future)) True) + (= (events past ((((= color red)) ((= temp warm)) ((= shape square))) (((= color green)) ((= temp cold)) ((= shape hexagon))))) True) + (= (events present ((((= color blue)) ((= temp warm)) ((= shape square))) (((= color red)) ((= temp hot)) ((= shape hexagon))))) True) + (= (events future ((((= color green)) ((= temp warm)) ((= shape hexagon))) (((= color blue)) ((= temp hot)) ((= shape octagon))))) True) diff --git a/aq1/aq1_2.metta b/aq1/aq1_2.metta index 9a45b92..1ac2124 100644 --- a/aq1/aq1_2.metta +++ b/aq1/aq1_2.metta @@ -1,81 +1,21 @@ +; (convert_to_metta_file aq1_2 $_393658 aq1/aq1_2.pl aq1/aq1_2.metta) - (= - (domaintype color nominal) True) -; + (= (domaintype color nominal) True) + (= (valueset color (red green blue)) True) - (= - (valueset color - (red green blue)) True) -; + (= (domaintype temp linear) True) + (= (order temp (cold warm hot)) True) - (= - (domaintype temp linear) True) -; + (= (domaintype shape nominal) True) + (= (valueset shape (square hexagon octagon)) True) - (= - (order temp - (cold warm hot)) True) -; - - - (= - (domaintype shape nominal) True) -; - - - (= - (valueset shape - (square hexagon octagon)) True) -; - - - (= - (classes - (past present future)) True) -; - - - (= - (events past - ( ( ( (= color red)) - ( (= shape square)) - ( (= temp warm))) - ( ( (= color red)) - ( (= shape hexagon)) - ( (= temp hot))) - ( ( (= color green)) - ( (= shape hexagon)) - ( (= temp cold))))) True) -; - - (= - (events present - ( ( ( (= color blue)) - ( (= shape square)) - ( (= temp warm))) - ( ( (= color red)) - ( (= shape hexagon)) - ( (= temp hot))) - ( ( (= color red)) - ( (= shape hexagon)) - ( (= temp hot))))) True) -; - - (= - (events future - ( ( ( (= color green)) - ( (= shape hexagon)) - ( (= temp warm))) - ( ( (= color red)) - ( (= shape hexagon)) - ( (= temp hot))) - ( ( (= color blue)) - ( (= shape octagon)) - ( (= temp hot))))) True) -; + (= (classes (past present future)) True) + (= (events past ((((= color red)) ((= shape square)) ((= temp warm))) (((= color red)) ((= shape hexagon)) ((= temp hot))) (((= color green)) ((= shape hexagon)) ((= temp cold))))) True) + (= (events present ((((= color blue)) ((= shape square)) ((= temp warm))) (((= color red)) ((= shape hexagon)) ((= temp hot))) (((= color red)) ((= shape hexagon)) ((= temp hot))))) True) + (= (events future ((((= color green)) ((= shape hexagon)) ((= temp warm))) (((= color red)) ((= shape hexagon)) ((= temp hot))) (((= color blue)) ((= shape octagon)) ((= temp hot))))) True) diff --git a/arch1/arch1.metta b/arch1/arch1.metta index 79e8116..7a7e2ee 100644 --- a/arch1/arch1.metta +++ b/arch1/arch1.metta @@ -1,1308 +1,1447 @@ - - (= - (process-stored-inputs $ConceptName) - ( (or - (remove-symbol &self - (concept $ConceptName $_)) True) - (set-det) - (process-stored-inputs-body $ConceptName))) -; - - - - (= - (process-stored-inputs-body $ConceptName) - ( (msgs (:: nl 'Processing stored inputs for ' $ConceptName ...)) - (input $ID $Type $ConceptName $Input) - (msgs (:: nl 'Input ' $ID : $Type nl $Input)) - (process-example $Type $ConceptName $Input) - (concept $ConceptName $Concept) - (concept-template $Concept $Template) - (concept-constraints $Concept $Constraints) - (msgs (:: nl 'New Concept Definition is:' nl '--- Template:' nl $Template nl '--- Constraints:' nl $Constraints nl)) - (fail))) -; - - (= - (process-stored-inputs-body $_) +; (convert_to_metta_file arch1 $_448468 arch1/arch1.pl arch1/arch1.metta) + + (= (process-stored-inputs $ConceptName) + (or + (remove-is-symbol &self + (concept $ConceptName $_)) True) + (set-det) + (process-stored-inputs-body $ConceptName)) +; /******************************************************************/ +; /* ARCH1.PRO Last Modification: Fri Jan 14 19:19:54 1994 */ +; /* Winston's incremental learning procedure. */ +; /******************************************************************/ +; ; ; Copyright (c) 1988 Stefan Wrobel ; ; This program is free software; you can redistribute it and/or ; modify it under the terms of the GNU General Public License ; Version 1 as published by the Free Software Foundation. ; ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; ; You should have received a copy of the GNU General Public ; Licensealong with this program; if not, write to the Free ; SoftwareFoundation, Inc., 675 Mass Ave, Cambridge, MA 02139, ; USA. ; +; /******************************************************************/ +; /* impl. by : Stefan Wrobel */ +; /* F3.XPS */ +; /* Gesellschaft fuer Mathematik und */ +; /* Datenverarbeitung */ +; /* Schloss Birlinghoven */ +; /* Postfach 1240 */ +; /* 5205 St.Augustin 1 */ +; /* F.R.G. */ +; /* E-Mail: wrobel@gmdzi.gmd.de */ +; /* 1988 */ +; /* */ +; /* reference : ES2ML Tutorial Exercise */ +; /* Concept Learning and Concept Formation */ +; /* Stefan Wrobel */ +; /* */ +; /* chapter 11 */ +; /* Artificial Intelligence */ +; /* Winston */ +; /* second edition */ +; /* Addison-Wesley, 1984 */ +; /* */ +; /* call : process_stored_inputs(arch) */ +; /* */ +; /******************************************************************/ +; ; TH Sat May 29 23:25:18 1993 - made some minor modifications +; /******************************************************************/ +; /* */ +; /* call : process_stored_inputs(+ConceptName) */ +; /* */ +; /* arguments : ConceptName = Name of example class */ +; /* */ +; /* side effects: retracts the previous concept, if there was one */ +; /* */ +; /******************************************************************/ +; /* Retracts the previous concept, if there was one and processes */ +; /* the example class. */ +; /******************************************************************/ + + + (= (process-stored-inputs-body $ConceptName) + (msgs (:: nl 'Processing stored inputs for ' $ConceptName ...)) + (input $ID $Type $ConceptName $Input) + (msgs (:: nl 'Input ' $ID : $Type nl $Input)) + (process-example $Type $ConceptName $Input) + (concept $ConceptName $Concept) + (concept-template $Concept $Template) + (concept-constraints $Concept $Constraints) + (msgs (:: nl 'New Concept Definition is:' nl '--- Template:' nl $Template nl '--- Constraints:' nl $Constraints nl)) + (fail)) + (= (process-stored-inputs-body $_) (msgs (:: nl 'No more inputs. Done.'))) -; - - (= - (process-example example $ConceptName $Example) - ( (remove-symbol &self + (= (process-example example $ConceptName $Example) + ( (remove-is-symbol &self (concept $ConceptName $Definition)) (set-det) (generalize $Example $Definition $NewDefinition) - (add-symbol &self + (add-is-symbol &self (concept $ConceptName $NewDefinition)) (set-det))) -; - - (= - (process-example example $ConceptName $Example) +; /******************************************************************/ +; /* */ +; /* call : process_example(+Type,+ConceptName,+Example) */ +; /* */ +; /* arguments : Type = Classification */ +; /* ConceptName = Name of example class */ +; /* Example = Structural Description */ +; /* */ +; /* side effects: assertion of concept definition in database */ +; /* modified concept definition in database */ +; /* */ +; /******************************************************************/ +; /* Processes a new input example (representation: see */ +; /* arch_1.MeTTa) and adapts the existing concept definition by */ +; /* using specialize (if Type is near_miss) or generalize (if Type */ +; /* is example). */ +; /*****************************************************************/ +; /* process it */ + (= (process-example example $ConceptName $Example) ( (set-det) (initial-generalization $Example $InitialDefinition) - (add-symbol &self + (add-is-symbol &self (concept $ConceptName $InitialDefinition)))) -; - - (= - (process-example near-miss $ConceptName $Example) - ( (remove-symbol &self +; /* no concept yet - this is the initial input. Perform */ +; /* special initial generalization on it */ + (= (process-example near-miss $ConceptName $Example) + ( (remove-is-symbol &self (concept $ConceptName $Definition)) (set-det) (specialize $Example $Definition $NewDefinition) - (add-symbol &self + (add-is-symbol &self (concept $ConceptName $NewDefinition)) (set-det))) -; - - (= - (process-example near-miss $ConceptName $_) - ( (set-det) (msgs (:: nl 'Cannot process a (near) miss as the first example of ' $ConceptName . nl 'Please begin with a (prototypical) example instead.')))) -; - - - - (= - (specialize $Example $OldConcept $OldConcept) - ( (is-member $Example $OldConcept no) - (set-det) - (msgs (:: nl 'Already excluded.')))) -; - - (= - (specialize $Example $OldConcept $NewConcept) - ( (match $OldConcept $Example Nil $BL $PL $ML $AL) - (find-important-differences-p specialize $PL $ML $AL $DifferenceDescriptions) - (specialize-concept-definition $DifferenceDescriptions $BL $OldConcept $NewConcept) - (set-det))) -; - - (= - (specialize $_ $Definition $Definition) +; /* process it */ + (= (process-example near-miss $ConceptName $_) + (set-det) + (msgs (:: nl 'Cannot process a (near) miss as the first example of ' $ConceptName . nl 'Please begin with a (prototypical) example instead.'))) +; /* oops - we got a near miss as a first example. Reject it. */ + + + (= (specialize $Example $OldConcept $OldConcept) + (is-member $Example $OldConcept no) + (set-det) + (msgs (:: nl 'Already excluded.'))) +; /******************************************************************/ +; /* */ +; /* call : specialize(+Example,+Definition,-NewDefinition) */ +; /* */ +; /* arguments : Example = Structural Description */ +; /* Definition = Current Concept Definition */ +; /* NewDefinition = New Concept Definition */ +; /* */ +; /******************************************************************/ +; /* Example is a near miss with respect to Definition (see */ +; /* arch_1.MeTTa for representations). This procedure tries to */ +; /* specialize the concept definition such that Example is */ +; /* excluded. This is done by strengthening the necessary */ +; /* conditions of Definition (adding must/must_not links in */ +; /* Winston's terminology). Note that this Winston-style */ +; /* specialization procedure needs a difference between the */ +; /* existing sufficient conditions and the example; if we */ +; /* ever overgeneralize (i.e., a near miss exactly matches */ +; /* the sufficient conditions), this procedure doesn't know */ +; /* how to recover. */ +; /******************************************************************/ +; /* match failed, i.e., this example is already excluded */ +; /* by the existing definition */ + (= (specialize $Example $OldConcept $NewConcept) + (match $OldConcept $Example Nil $BL $PL $ML $AL) + (find-important-differences-p specialize $PL $ML $AL $DifferenceDescriptions) + (specialize-concept-definition $DifferenceDescriptions $BL $OldConcept $NewConcept) + (set-det)) +; /* try to find the most important differences between the Example */ +; /* and the definition */ +; /* check if we're happy with this match */ +; /* o.k., we found some interesting differences */ + (= (specialize $_ $Definition $Definition) (msgs (:: nl 'Specialize failed. Ignoring example.'))) -; - - (= - (generalize $Example $OldConcept $OldConcept) - ( (is-member $Example $OldConcept yes) - (set-det) - (msgs (:: nl 'Already included.')))) -; - - (= - (generalize $Example $OldConcept $NewConcept) - ( (match $OldConcept $Example Nil $_ $PL $ML $AL) - (find-important-differences-p generalize $PL $ML $AL $DifferenceDescriptions) - (generalize-concept-definition $DifferenceDescriptions $OldConcept $NewConcept))) -; - - (= - (generalize $_ $Concept $Concept) + (= (generalize $Example $OldConcept $OldConcept) + (is-member $Example $OldConcept yes) + (set-det) + (msgs (:: nl 'Already included.'))) +; /******************************************************************/ +; /* */ +; /* call : generalize(+Example,+Definition,-NewDefinition) */ +; /* */ +; /* arguments : Example = Structural Description */ +; /* Definition = Current Concept Definition */ +; /* NewDefinition = New Concept Definition */ +; /* */ +; /******************************************************************/ +; /* Example is a positive example with respect to Definition (see */ +; /* arch_1.MeTTa for representations). This procedure tries to */ +; /* generalize the concept definition such that Example is */ +; /* included. This is done by weakening the sufficient conditions */ +; /* of Definition. */ +; /******************************************************************/ +; /* this example is already included by the existing definition */ + (= (generalize $Example $OldConcept $NewConcept) + (match $OldConcept $Example Nil $_ $PL $ML $AL) + (find-important-differences-p generalize $PL $ML $AL $DifferenceDescriptions) + (generalize-concept-definition $DifferenceDescriptions $OldConcept $NewConcept)) +; /* try to find the most important differences between the Example */ +; /* and the definition */ +; /* check if we're happy with this match */ +; /* o.k., we found some interesting differences */ + (= (generalize $_ $Concept $Concept) (msgs (:: nl 'Generalize failed. Ignoring example.'))) -; - - - - - (= - (find-important-differences-p generalize $PL $ML $_ $DD) - ( (mark-as partial $PL $DD1) - (mark-as missing $ML $DD2) - (append $DD1 $DD2 $DD))) -; - (= - (find-important-differences-p specialize $_ Nil $AL $DD) - ( (not (= $AL Nil)) - (set-det) - (mark-as addition $AL $DD))) -; - (= - (find-important-differences-p specialize $_ $ML $_ $DD) - ( (not (= $ML Nil)) - (set-det) - (mark-as missing $ML $DD))) -; - (= - (find-important-differences-p specialize $PL $_ $_ $DD) + (= (find-important-differences-p generalize $PL $ML $_ $DD) + (mark-as partial $PL $DD1) + (mark-as missing $ML $DD2) + (append $DD1 $DD2 $DD)) +; /**********************************************************************/ +; /* */ +; /* call : find_important_differences_p(Operation, */ +; /* +PartialList, */ +; /* +AdditionList, */ +; /* +MissingList, */ +; /* -DifferenceDescription)*/ +; /* */ +; /**********************************************************************/ +; /* Inspect the differences in PartialList, AdditionList, and */ +; /* MissingList, and decide which ones to use as the basis for */ +; /* concept modification. Operation is either "specialize" or */ +; /* "generalize". DifferenceDescriptions is the list of such */ +; /* differences, with a descriptor indicating their type: */ +; /* */ +; /* - partial_match([DefinitionConstraint,ExampleFact]) */ +; /* - addition(ExampleFact) */ +; /* - missing(DefinitionConstraint) */ +; /* */ +; /**********************************************************************/ +; /* For generalization, additional facts in the example are */ +; /* not interesting. Return partial matches and missing constraints. */ +; /**********************************************************************/ + (= (find-important-differences-p specialize $_ Nil $AL $DD) + (not (= $AL Nil)) + (set-det) + (mark-as addition $AL $DD)) +; /***********************************************************************/ +; /* For specialization, both missing constraints and additional facts */ +; /* are interesting. If there are both, prefer the missing constraint. */ +; /***********************************************************************/ +; /* differences_acceptable_p(AL), */ + (= (find-important-differences-p specialize $_ $ML $_ $DD) + (not (= $ML Nil)) + (set-det) + (mark-as missing $ML $DD)) +; /* differences_acceptable_p(ML), */ + (= (find-important-differences-p specialize $PL $_ $_ $DD) (mark-as partial $PL $DD)) -; - - - - (= - (differences-acceptable-p $Diffs) - ( (length $Diffs 1) (set-det))) -; - (= - (differences-acceptable-p $Diffs) - ( (same-functor-p $Diffs $_) (set-det))) -; - - - (= - (same-functor-p Nil $_) + (= (differences-acceptable-p $Diffs) + (length $Diffs 1) (set-det)) -; - - (= - (same-functor-p - (:: $LastDifference) $Functor) - ( (set-det) (=.. $LastDifference (Cons $Functor $_)))) -; - - (= - (same-functor-p - (Cons $First $Rest) $Functor) - ( (same-functor-p $Rest $Functor) (=.. $First (Cons $Functor $_)))) -; - - - - (= - (mark-as $_ Nil Nil) +; /* a single difference is always fine */ + (= (differences-acceptable-p $Diffs) + (same-functor-p $Diffs $_) (set-det)) -; - - (= - (mark-as $Mark - (Cons $First $Rest) - (Cons $FirstMarked $RestMarked)) - ( (=.. $FirstMarked - (:: $Mark $First)) (mark-as $Mark $Rest $RestMarked))) -; - - - - (= - (concept_p - (concept $_ $_ $_)) True) -; - - - (= - (concept_name - (concept $Name $_ $_) $Name) True) -; - +; /* more than one must have the same functor to be acceptable */ - (= - (concept_template - (concept $_ $Template $_) $Template) True) -; - - - (= - (concept_constraints - (concept $_ $_ $Constraints) $Constraints) True) -; - - - - (= - (alter_concept_constraints - (concept $N $T $_) $C - (concept $N $T $C)) True) -; - - - (= - (alter_concept_template - (concept $N $_ $C) $T - (concept $N $T $C)) True) -; - - - - (= - (concept-equal-p - (concept $Name $Template1 $Constraints1) - (concept $Name $Template2 $Constraints2)) - ( (set-equal-p $Template1 $Template2) (set-equal-p $Constraints1 $Constraints2))) -; - - - - (= - (print-concept $Concept) - ( (concept-name $Concept $Name) - (or - (= $Name -) True) - (concept-template $Concept $Template) - (concept-constraints $Concept $Constraints) - (msgs (:: nl 'Concept ' $Name : nl 'Template: ' $Template nl 'Constraints: ' $Constraints)) - (set-det))) -; - - - - (= - (print-concepts $Concepts) - ( (member $Concept $Concepts) - (print-concept $Concept) - (fail))) -; - - (= - (print_concepts $_) True) -; - - - - (= - (is-member $Example $Concept $Decision) - ( (match $Concept $Example Nil $_ $PL $ML $_) - (set-det) - (or - (, - (= $ML Nil) - (= $PL Nil) - (set-det) - (= $Decision yes)) - (= $Decision possible)))) -; - - (= - (is_member $_ $_ no) True) -; + (= (same-functor-p Nil $_) + (set-det)) + (= (same-functor-p (:: $LastDifference) $Functor) + (set-det) + (=.. $LastDifference + (Cons $Functor $_))) + (= (same-functor-p (Cons $First $Rest) $Functor) + (same-functor-p $Rest $Functor) + (=.. $First + (Cons $Functor $_))) - (= - (match $Concept $Ex $OldBL $NewBL $PL $ML $AL) + (= (mark-as $_ Nil Nil) + (set-det)) + (= (mark-as $Mark (Cons $First $Rest) (Cons $FirstMarked $RestMarked)) + (=.. $FirstMarked + (:: $Mark $First)) + (mark-as $Mark $Rest $RestMarked)) + + + (= (concept_p (concept $_ $_ $_)) True) +; /***********************************************************************/ +; /* The evolving concept definition is represented by two lists of facts*/ +; /* (which may contain symbolic vars "var(...)"). The first list is the */ +; /* "template", a structural description of the concept that is matched */ +; /* one-to-one to the example, i.e., each part of the template */ +; /* "consumes" one part of the example when matched. The second list */ +; /* contains the "constraints", which are logical conditions on concept */ +; /* members that do not "consume" example parts when they get matched. */ +; /* Negated facts go in the constraint slot. Within the template, */ +; /* necessary parts can be marked as necessary by enclosing them with */ +; /* "must(...)"; constraints are always interpreted as necessary. */ +; /***********************************************************************/ +; /* A concept is represented as: */ +; /* */ +; /* concept(NAME,TEMPLATE_LIST,CONSTRAINT_LIST) */ +; /* */ +; /* e.g., concept(arch, */ +; /* [part(var(o1)),part(var(o2)),part(var(o3)), */ +; /* isa(var(o1),brick), isa(var(o2),brick), */ +; /* isa(var(o3),brick), left_of(var(o2),var(o1)), */ +; /* must(supports(var(o1),var(o3))), */ +; /* must(supports(var(o2),var(o3)))], */ +; /* [not(touches(var(o1),var(o2)))]). */ +; /***********************************************************************/ +; /* The following predicates give access to the parts of a concept: */ +; /***********************************************************************/ + + (= (concept_name (concept $Name $_ $_) $Name) True) + + (= (concept_template (concept $_ $Template $_) $Template) True) + + (= (concept_constraints (concept $_ $_ $Constraints) $Constraints) True) + + + (= (alter_concept_constraints (concept $N $T $_) $C (concept $N $T $C)) True) +; /***********************************************************************/ +; /* The following predicates alternate parts of a concept: */ +; /***********************************************************************/ + + (= (alter_concept_template (concept $N $_ $C) $T (concept $N $T $C)) True) + + + (= (concept-equal-p (concept $Name $Template1 $Constraints1) (concept $Name $Template2 $Constraints2)) + (set-equal-p $Template1 $Template2) + (set-equal-p $Constraints1 $Constraints2)) +; /***********************************************************************/ +; /* Two concepts are equal if both have the same name and the sets of */ +; /* their templates and constraints are equal. This predicate will not */ +; /* notice isomorphic concepts with different variable names. */ +; /***********************************************************************/ + + + (= (print-concept $Concept) + (concept-name $Concept $Name) + (or + (= $Name -) True) + (concept-template $Concept $Template) + (concept-constraints $Concept $Constraints) + (msgs (:: nl 'Concept ' $Name : nl 'Template: ' $Template nl 'Constraints: ' $Constraints)) + (set-det)) +; /* make sure Name is bound to something reasonable */ + + + (= (print-concepts $Concepts) + (member $Concept $Concepts) + (print-concept $Concept) + (fail)) + (= (print_concepts $_) True) + + + (= (is-member $Example $Concept $Decision) + (match $Concept $Example Nil $_ $PL $ML $_) + (set-det) + (or + (, + (= $ML Nil) + (= $PL Nil) + (set-det) + (= $Decision yes)) + (= $Decision possible))) +; /******************************************************************/ +; /* */ +; /* call : is_member(+Example,+Concept,-Decision) */ +; /* */ +; /* arguments : Example = Structural Description */ +; /* Concept = Current Concept Definition */ +; /* Decision = Truth Value */ +; /* */ +; /******************************************************************/ +; /* Classifies Example according to Concept. Three cases are */ +; /* possible: */ +; /* */ +; /* (a) Example meets the sufficient conditions of the current */ +; /* Concept Definition, so it must be a member of the */ +; /* concept (Decision = yes) */ +; /* (b) Example does not meet the necessary conditions, so it */ +; /* cannot be a member (Decision = no) */ +; /* (c) Example meets the necessary conditions, but not the */ +; /* sufficient conditions (Decision = possible) */ +; /* */ +; /******************************************************************/ +; /* match succeeds only if necessary conditions */ +; /* (incl. constraints) are met */ +; /* check if all non-necessary conditions were */ +; /* matched also */ + (= (is_member $_ $_ no) True) + + + (= (match $Concept $Ex $OldBL $NewBL $PL $ML $AL) (match $Concept $Ex $OldBL $NewBL $PL $ML $AL t)) -; - - - (= - (match $Concept $Ex $OldBL $NewBL $PL $ML $AL $CheckNecessaryP) - ( (concept-template $Concept $Templ) - (concept-constraints $Concept $Constraints) - (unambiguous-match $Templ $Ex $OldBL $RestTempl1 $RestEx1 $BL1) - (perfect-match $RestTempl1 $RestEx1 $BL1 $RestTempl2 $RestEx2 $BL2 $CheckNecessaryP) - (not (unsatisfied-constraint-p $Constraints $Ex $BL2)) - (partial-match $RestTempl2 $RestEx2 $BL2 $NewBL $PL $ML $AL))) -; - - - - (= - (unambiguous-match $Templ $Ex $OldBL $Templ $Ex $OldBL) - ( (or - (= $Templ Nil) - (= $Ex Nil)) (set-det))) -; - - (= - (unambiguous-match $Templ $Ex $OldBL $RestTempl $RestEx $NewBL) - ( (find-unambiguous-match-p $Templ $Ex $OldBL $RestTempl1 $RestEx1 $NewBL1) - (set-det) - (unambiguous-match $RestTempl1 $RestEx1 $NewBL1 $RestTempl $RestEx $NewBL))) -; - - (= - (unambiguous-match $Templ $Ex $OldBL $Templ $Ex $OldBL) +; /********************************************************************/ +; /* Pattern Matcher */ +; /********************************************************************/ +; /* */ +; /* call : match(+Concept,+Example, */ +; /* +OldBindingList,-NewBindingList, */ +; /* -PartialMatchList,-MissingList, */ +; /* -AdditionList,CheckNecessaryConditions) */ +; /* */ +; /* arguments : Concept = Current Concept Definition */ +; /* Example = Structural Description */ +; /* OldBindingList = List of Current Bindings */ +; /* NewBindingList = List of New Bindings */ +; /* PartialMatchList = List of Partial Matched Pairs */ +; /* MissingList = List of Missing Example Facts */ +; /* AdditionList = List of Missing Concept Parts */ +; /* CheckNecessaryConditions = see descripton */ +; /* */ +; /* properties : The predicate is backtrackable and returns all */ +; /* equally good matches on backtracking. */ +; /* */ +; /********************************************************************/ +; /* Match Example with Concept Definition. Example and Concept are */ +; /* represented as in "arch_1.pro". Concept may contain facts with */ +; /* symbolic variables as arguments ("var()"), all other */ +; /* symbols are treated as constants. No guarantee if you call match */ +; /* with expressions that contain unbound (PROLOG-) variables. */ +; /* OldBindingList is the list of bindings (list of [var|value] */ +; /* pairs) to respect when performing the match. The constraints of */ +; /* Concept are handled properly (they do not "consume" parts in the */ +; /* example and may include negated facts). The match does not */ +; /* succeed unless all constraints are met. If CheckNecessary- */ +; /* Conditions is non-nil (or left out), match makes sure that no */ +; /* match leaves a necessary part of Definition unmatched (those */ +; /* marked with "must(...)"). If CheckNecessaryConditions is nil, */ +; /* that check is not made (useful if you want to generalize on */ +; /* necessary conditions, too). */ +; /* */ +; /* Match returns: */ +; /* */ +; /* - the NewBindingList with any additional bindings that were */ +; /* made (a superset of OldBindingList) */ +; /* - PartialMatchList, the list of pairs */ +; /* ([Constraint,ExampleFact]) that were partially matched */ +; /* - AdditionList, the list of facts present in the example */ +; /* without a counterpart in the definition */ +; /* - MissingList, the list of facts in the definition without a */ +; /* a counterpart in the example */ +; /* */ +; /********************************************************************/ + + (= (match $Concept $Ex $OldBL $NewBL $PL $ML $AL $CheckNecessaryP) + (concept-template $Concept $Templ) + (concept-constraints $Concept $Constraints) + (unambiguous-match $Templ $Ex $OldBL $RestTempl1 $RestEx1 $BL1) + (perfect-match $RestTempl1 $RestEx1 $BL1 $RestTempl2 $RestEx2 $BL2 $CheckNecessaryP) + (not (unsatisfied-constraint-p $Constraints $Ex $BL2)) + (partial-match $RestTempl2 $RestEx2 $BL2 $NewBL $PL $ML $AL)) +; /* try to match as many parts as possible unambiguously */ +; /* for the rest, try to match as many as possible perfectly */ +; /* check other constraints (negated conditions, etc.) */ +; /* ("Must" conditions are checked in perfect_match, */ +; /* to cut off false matches as early as possible) */ +; /* among whatever is still left, try to find as many partial */ +; /* matches as possible - whatever is left there is */ +; /* missing/additional */ + + + (= (unambiguous-match $Templ $Ex $OldBL $Templ $Ex $OldBL) + (or + (= $Templ Nil) + (= $Ex Nil)) (set-det)) -; - - - - (= - (find-unambiguous-match-p $Templ $Ex $OldBL $RestTempl $RestEx $NewBL) - ( (enumerate $Templ $Part $RestTempl) - (find-unambiguous-match-p1 $Part $Templ $Ex $OldBL $RestEx $NewBL) - (set-det))) -; - - - - (= - (find-unambiguous-match-p1 $Part $Template $Ex $OldBL $RestEx $NewBL) - ( (enumerate $Ex $ExamplePart $RestEx) - (perfect-match-p $Part $ExamplePart $OldBL $NewBL) - (not (non-unique-match-p $Part $ExamplePart $Template $Ex $OldBL)) - (set-det))) -; - - - - (= - (non-unique-match-p $Part $ExamplePart $Template $Example $BL) - ( (member $Part1 $Template) - (member $ExamplePart1 $Example) - (or - (, - (not (= $Part1 $Part)) - (= $ExamplePart1 $ExamplePart)) - (, - (not (= $ExamplePart1 $ExamplePart)) - (= $Part1 $Part))) - (perfect-match-p $Part1 $ExamplePart1 $BL $_) - (set-det))) -; - - - - (= - (perfect-match $Templ $Ex $OldBL $RestTempl $RestEx $NewBL $CheckNecessaryP) - ( (findbag - (:: $RestTempl1 $RestEx1 $NewBL1) - (, - (perfect-match1 $Templ $Ex $OldBL $RestTempl1 $RestEx1 $NewBL1) - (check-for-unmatched-necessary-constraints-p $RestTempl1 $CheckNecessaryP)) $PerfectMatches) - (remove-duplicates $PerfectMatches $PerfectMatches1 perfect-match-equal-p) - (list-sort $PerfectMatches1 $SortedPerfectMatches perfect-match-better-p) - (get-best $SortedPerfectMatches $BestMatches perfect-match-better-p) - (member - (:: $RestTempl $RestEx $NewBL) $BestMatches))) -; - - +; /********************************************************************/ +; /* unambiguous_match */ +; /********************************************************************/ +; /* if either Def or Ex are empty, we can't do anything */ + (= (unambiguous-match $Templ $Ex $OldBL $RestTempl $RestEx $NewBL) + (find-unambiguous-match-p $Templ $Ex $OldBL $RestTempl1 $RestEx1 $NewBL1) + (set-det) + (unambiguous-match $RestTempl1 $RestEx1 $NewBL1 $RestTempl $RestEx $NewBL)) + (= (unambiguous-match $Templ $Ex $OldBL $Templ $Ex $OldBL) + (set-det)) +; /* we couldn't find another unambiguous match - just return */ - (= - (perfect-match1 $Templ $Ex $OldBL $Templ $Ex $OldBL) - ( (or - (= $Templ Nil) - (= $Ex Nil)) (set-det))) -; - (= - (perfect-match1 $Templ $Ex $OldBL $Templ $Ex $OldBL) - ( (not (find-perfect-match-p $Templ $Ex $OldBL $_ $_ $_)) (set-det))) -; + (= (find-unambiguous-match-p $Templ $Ex $OldBL $RestTempl $RestEx $NewBL) + (enumerate $Templ $Part $RestTempl) + (find-unambiguous-match-p1 $Part $Templ $Ex $OldBL $RestEx $NewBL) + (set-det)) +; /* can we find an unambiguous match for FirstPart? */ +; /* yes, fine */ - (= - (perfect-match1 $Templ $Ex $OldBL $RestTempl $RestEx $NewBL) - ( (find-perfect-match-p $Templ $Ex $OldBL $RestTempl1 $RestEx1 $NewBL1) (perfect-match1 $RestTempl1 $RestEx1 $NewBL1 $RestTempl $RestEx $NewBL))) -; + (= (find-unambiguous-match-p1 $Part $Template $Ex $OldBL $RestEx $NewBL) + (enumerate $Ex $ExamplePart $RestEx) + (perfect-match-p $Part $ExamplePart $OldBL $NewBL) + (not (non-unique-match-p $Part $ExamplePart $Template $Ex $OldBL)) + (set-det)) +; /* they must at least match */ +; /* and do so uniquely */ +; /* fine */ + + + (= (non-unique-match-p $Part $ExamplePart $Template $Example $BL) + (member $Part1 $Template) + (member $ExamplePart1 $Example) + (or + (, + (not (= $Part1 $Part)) + (= $ExamplePart1 $ExamplePart)) + (, + (not (= $ExamplePart1 $ExamplePart)) + (= $Part1 $Part))) + (perfect-match-p $Part1 $ExamplePart1 $BL $_) + (set-det)) - (= - (find-perfect-match-p $Templ $Ex $OldBL $RestTempl $RestEx $NewBL) - ( (enumerate $Templ $Part $RestTempl) (find-perfect-match-p1 $Part $Ex $OldBL $RestEx $NewBL))) -; + (= (perfect-match $Templ $Ex $OldBL $RestTempl $RestEx $NewBL $CheckNecessaryP) + (findbag + (:: $RestTempl1 $RestEx1 $NewBL1) + (, + (perfect-match1 $Templ $Ex $OldBL $RestTempl1 $RestEx1 $NewBL1) + (check-for-unmatched-necessary-constraints-p $RestTempl1 $CheckNecessaryP)) $PerfectMatches) + (remove-duplicates $PerfectMatches $PerfectMatches1 perfect-match-equal-p) + (list-sort $PerfectMatches1 $SortedPerfectMatches perfect-match-better-p) + (get-best $SortedPerfectMatches $BestMatches perfect-match-better-p) + (member + (:: $RestTempl $RestEx $NewBL) $BestMatches)) +; /********************************************************************/ +; /* Finding perfect matches involves guessing. To avoid returning a */ +; /* bad match only because of a bad first guess, we need to look at */ +; /* all possible matches and return the best one (since by looking */ +; /* at the first N matches, we cannot always be sure there won't be */ +; /* a better one if we backtrack once more). */ +; /********************************************************************/ +; /* find all perfect matches */ +; /* get all matches with the top score */ +; /* return one of them (backtrackable) */ + + + (= (perfect-match1 $Templ $Ex $OldBL $Templ $Ex $OldBL) + (or + (= $Templ Nil) + (= $Ex Nil)) + (set-det)) +; /* if either Templ or Ex are empty, we can't do anything */ + (= (perfect-match1 $Templ $Ex $OldBL $Templ $Ex $OldBL) + (not (find-perfect-match-p $Templ $Ex $OldBL $_ $_ $_)) + (set-det)) +; /* we couldn't find another perfect match - just return */ + (= (perfect-match1 $Templ $Ex $OldBL $RestTempl $RestEx $NewBL) + (find-perfect-match-p $Templ $Ex $OldBL $RestTempl1 $RestEx1 $NewBL1) + (perfect-match1 $RestTempl1 $RestEx1 $NewBL1 $RestTempl $RestEx $NewBL)) + (= (find-perfect-match-p $Templ $Ex $OldBL $RestTempl $RestEx $NewBL) + (enumerate $Templ $Part $RestTempl) + (find-perfect-match-p1 $Part $Ex $OldBL $RestEx $NewBL)) +; /* can we find a perfect match for FirstPart? */ - (= - (find-perfect-match-p1 $Part $Ex $OldBL $RestEx $NewBL) - ( (enumerate $Ex $ExamplePart $RestEx) (perfect-match-p $Part $ExamplePart $OldBL $NewBL))) -; + (= (find-perfect-match-p1 $Part $Ex $OldBL $RestEx $NewBL) + (enumerate $Ex $ExamplePart $RestEx) + (perfect-match-p $Part $ExamplePart $OldBL $NewBL)) +; /* they must match */ - (= - (perfect-match-p - (must $Constraint) $Fact $OldBL $NewBL) + (= (perfect-match-p (must $Constraint) $Fact $OldBL $NewBL) (perfect-match-p $Constraint $Fact $OldBL $NewBL)) -; - - (= - (perfect-match-p $Constraint $Fact $OldBL $NewBL) - ( (=.. $Constraint - (Cons $Functor $Args1)) - (=.. $Fact - (Cons $Functor $Args2)) - (count-differences-p $Args1 $Args2 $OldBL $NewBL 0))) -; - - (= - (perfect-match-p $Constraint $Fact $OldBL $NewBL) - ( (infer $Fact $FactDerivation) (perfect-match-p $Constraint $FactDerivation $OldBL $NewBL))) -; - - - - - (= - (perfect-match-better-p - (:: $RestTempl1 $RestEx1 $BL1) - (:: $RestTempl2 $RestEx2 $BL2)) - ( (length $RestTempl1 $L1) - (length $RestTempl2 $L2) - (< $L1 $L2))) -; - - - - (= - (perfect-match-equal-p - (:: $RestTempl1 $RestEx1 $BL1) - (:: $RestTempl2 $RestEx2 $BL2)) - ( (set-equal-p $RestTempl1 $RestTempl2) - (set-equal-p $RestEx1 $RestEx2) - (set-equal-p $BL1 $BL2))) -; - - - - (= - (unsatisfied-constraint-p $Constraints $Ex $BL) - ( (member $Constraint $Constraints) - (member $Fact $Ex) - (or - (= $Constraint - (not $BaseConstraint)) - (= $BaseConstraint $Constraint)) - (perfect-match-p $BaseConstraint $Fact $BL $_) - (set-det))) -; - +; /********************************************************************/ +; /* */ +; /* call : perfect_match_p(+Constraint,+Fact,+OldBL,-NewBL) */ +; /* */ +; /* arguments : Constraint = Current Concept Definition */ +; /* Fact = Structural Description */ +; /* OldBL = OldBindingList */ +; /* NewBL = NewBindingList */ +; /* */ +; /********************************************************************/ +; /* Succeed if Constraint and Fact match perfectly, returning the new*/ +; /* binding list, or fail otherwise. */ +; /* Second possibility: we are able to use a theorem that uses the */ +; /* existing example fact to derive a fact that matches. See */ +; /* arch_1.pro for some sample inferences. */ +; /********************************************************************/ + (= (perfect-match-p $Constraint $Fact $OldBL $NewBL) + (=.. $Constraint + (Cons $Functor $Args1)) + (=.. $Fact + (Cons $Functor $Args2)) + (count-differences-p $Args1 $Args2 $OldBL $NewBL 0)) + (= (perfect-match-p $Constraint $Fact $OldBL $NewBL) + (infer $Fact $FactDerivation) + (perfect-match-p $Constraint $FactDerivation $OldBL $NewBL)) + + + + (= (perfect-match-better-p (:: $RestTempl1 $RestEx1 $BL1) (:: $RestTempl2 $RestEx2 $BL2)) + (length $RestTempl1 $L1) + (length $RestTempl2 $L2) + (< $L1 $L2)) +; /********************************************************************/ +; /* Decides if one perfect match is better than another by a simple */ +; /* measure: more parts of the template matched */ +; /********************************************************************/ + + + (= (perfect-match-equal-p (:: $RestTempl1 $RestEx1 $BL1) (:: $RestTempl2 $RestEx2 $BL2)) + (set-equal-p $RestTempl1 $RestTempl2) + (set-equal-p $RestEx1 $RestEx2) + (set-equal-p $BL1 $BL2)) +; /********************************************************************/ +; /* True if two perfect matches are equal */ +; /********************************************************************/ + + + (= (unsatisfied-constraint-p $Constraints $Ex $BL) + (member $Constraint $Constraints) + (member $Fact $Ex) + (or + (= $Constraint + (not $BaseConstraint)) + (= $BaseConstraint $Constraint)) + (perfect-match-p $BaseConstraint $Fact $BL $_) + (set-det)) +; /********************************************************************/ +; /* unsatisfied_constraint_p */ +; /********************************************************************/ - (= - (check-for-unmatched-necessary-constraints-p $_ nil) + (= (check-for-unmatched-necessary-constraints-p $_ nil) (set-det)) -; - - (= - (check-for-unmatched-necessary-constraints-p $Templ $_) + (= (check-for-unmatched-necessary-constraints-p $Templ $_) (not (member (must $_) $Templ))) -; - - - - (= - (partial-match $Templ $Ex $OldBL $NewBL $PL $RestTempl $RestEx) - ( (findbag - (:: $PL1 $RestTempl1 $RestEx1 $NewBL1) - (partial-match1 $Templ $Ex $OldBL $PL1 $RestTempl1 $RestEx1 $NewBL1) $PartialMatches) - (remove-duplicates $PartialMatches $PartialMatches1 partial-match-equal-p) - (list-sort $PartialMatches1 $SortedPartialMatches partial-match-better-p) - (get-best $SortedPartialMatches $BestMatches partial-match-better-p) - (member - (:: $PL $RestTempl $RestEx $NewBL) $BestMatches))) -; - - - - (= - (partial-match1 $Templ $Ex $OldBL Nil $Templ $Ex $OldBL) - ( (or - (= $Templ Nil) - (= $Ex Nil)) (set-det))) -; - (= - (partial-match1 $Templ $Ex $OldBL Nil $Templ $Ex $OldBL) - ( (not (find-partial-match-p $Templ $Ex $OldBL $_ $_ $_ $_)) (set-det))) -; - - (= - (partial-match1 $Templ $Ex $OldBL - (Cons $PartialMatch $RestPL) $RestTempl $RestEx $NewBL) - ( (find-partial-match-p $Templ $Ex $OldBL $PartialMatch $RestTempl1 $RestEx1 $NewBL1) - (set-det) - (partial-match1 $RestTempl1 $RestEx1 $NewBL1 $RestPL $RestTempl $RestEx $NewBL))) -; - - - - (= - (find-partial-match-p $Templ $Ex $OldBL $PartialMatch $RestTempl $RestEx $NewBL) - ( (enumerate $Templ $Part $RestTempl) - (find-partial-match-p1 $Part $Ex $OldBL $MatchingFact $RestEx $NewBL) - (= $PartialMatch - (:: $Part $MatchingFact)))) -; - - - - (= - (find-partial-match-p1 $Part $Ex $OldBL $ExamplePart $RestEx $NewBL) - ( (enumerate $Ex $ExamplePart $RestEx) (partial-match-p $Part $ExamplePart $OldBL $NewBL))) -; - - - - (= - (partial-match-p - (must $Constraint) $Fact $OldBL $NewBL) - ( (set-det) (partial-match-p $Constraint $Fact $OldBL $NewBL))) -; - - (= - (partial-match-p $Constraint $Fact $OldBL $NewBL) - ( (=.. $Constraint - (Cons $Functor $Args1)) - (=.. $Fact - (Cons $Functor $Args2)) - (count-differences-p $Args1 $Args2 $OldBL $NewBL 1))) -; - - (= - (partial-match-p $Constraint $Fact $OldBL $NewBL) - ( (infer $Fact $FactDerivation) (partial-match-p $Constraint $FactDerivation $OldBL $NewBL))) -; - - - - - (= - (partial-match-better-p - (:: $PL1 $RestTempl1 $RestEx1 $BL1) - (:: $PL2 $RestTempl2 $RestEx2 $BL2)) - ( (length $RestTempl1 $L1) - (length $RestTempl2 $L2) - (< $L1 $L2))) -; - - - - (= - (partial-match-equal-p - (:: $PL1 $RestTempl1 $RestEx1 $BL1) - (:: $PL2 $RestTempl2 $RestEx2 $BL2)) - ( (set-equal-p $PL1 $PL2) - (set-equal-p $RestTempl1 $RestTempl2) - (set-equal-p $RestEx1 $RestEx2) - (set-equal-p $BL1 $BL2))) -; - - - - (= - (count-differences-p Nil Nil $BL $BL 0) + (= (partial-match $Templ $Ex $OldBL $NewBL $PL $RestTempl $RestEx) + (findbag + (:: $PL1 $RestTempl1 $RestEx1 $NewBL1) + (partial-match1 $Templ $Ex $OldBL $PL1 $RestTempl1 $RestEx1 $NewBL1) $PartialMatches) + (remove-duplicates $PartialMatches $PartialMatches1 partial-match-equal-p) + (list-sort $PartialMatches1 $SortedPartialMatches partial-match-better-p) + (get-best $SortedPartialMatches $BestMatches partial-match-better-p) + (member + (:: $PL $RestTempl $RestEx $NewBL) $BestMatches)) +; /********************************************************************/ +; /* */ +; /* call : partial_match(!Template,!Example, */ +; /* !OldBindingList,?NewBindingList, */ +; /* ?PartialMatchList,?MissingList, */ +; /* ?AdditionList) */ +; /* */ +; /* arguments : Template = Current Template */ +; /* Example = Structural Description */ +; /* OldBindingList = List of Current Bindings */ +; /* NewBindingList = List of New Bindings */ +; /* PartialMatchList = List of Partial Matched Pairs */ +; /* MissingList = List of Missing Example Facts */ +; /* AdditionList = List of Missing Concept Parts */ +; /* */ +; /********************************************************************/ +; /* Finding partial matches involves guessing. To avoid returning a */ +; /* bad match only because of a bad first guess, we need to look at */ +; /* all possible matches and return the best one (since by looking at*/ +; /* the first N matches, we cannot always be sure there won't be a */ +; /* better one if we backtrack once more). Anything that can't be */ +; /* matched partially is returned as missing (left-over template */ +; /* parts) or additional (left-over example parts). */ +; /********************************************************************/ +; /* find all partial matches */ +; /* get all matches with the top score */ +; /* return one of them (backtrackable) */ + + + + (= (partial-match1 $Templ $Ex $OldBL Nil $Templ $Ex $OldBL) + (or + (= $Templ Nil) + (= $Ex Nil)) (set-det)) -; - - (= - (count-differences-p - (Cons $First1 $Rest1) - (Cons $First2 $Rest2) $OldBL $NewBL $RestN) - ( (atom-match-p $First1 $First2 $OldBL $BL) - (set-det) - (count-differences-p $Rest1 $Rest2 $BL $NewBL $RestN))) -; - - (= - (count-differences-p - (Cons $First1 $Rest1) - (Cons $First2 $Rest2) $OldBL $NewBL $N) - ( (set-det) - (not (= $First1 (var $_))) - (not (= $First2 (var $_))) - (count-differences-p $Rest1 $Rest2 $OldBL $NewBL $RestN) - (is $N - (+ $RestN 1)))) -; - - - - (= - (atom-match-p $O1 $O2 $OldBL $NewBL) - ( (atom-match-p1 $O1 $O2 $OldBL $NewBL) (unique-binding-p $NewBL))) -; - - - - (= - (atom-match-p1 - (var $VarName1) - (var $VarName2) $OldBL $NewBL) - ( (set-det) - (get-binding $VarName1 $OldBL $BL $Binding1) - (get-binding $VarName2 $BL $NewBL $Binding2) - (= $Binding1 $Binding2))) -; - - (= - (atom-match-p1 $Const - (var $VarName) $OldBL $NewBL) - ( (set-det) (get-binding $VarName $OldBL $NewBL $Const))) -; - - (= - (atom-match-p1 - (var $VarName) $Const $OldBL $NewBL) - ( (set-det) (get-binding $VarName $OldBL $NewBL $Const))) -; - - (= - (symbol_match_p1 $Const $Const $BL $BL) True) -; - - - - (= - (get-binding $Key Nil - (:: (Cons $Key $Value)) $Value) +; /* if either Templ or Ex are empty, we can't do anything */ + (= (partial-match1 $Templ $Ex $OldBL Nil $Templ $Ex $OldBL) + (not (find-partial-match-p $Templ $Ex $OldBL $_ $_ $_ $_)) (set-det)) -; - - (= - (get-binding $Key $BL $BL $Value1) - ( (= $BL - (Cons - (Cons $Key $Value2) $_)) - (set-det) - (= $Value1 $Value2))) -; - - (= - (get-binding $Key - (Cons $FirstBinding $RestBL) - (Cons $FirstBinding $NewRestBL) $Value) - ( (set-det) (get-binding $Key $RestBL $NewRestBL $Value))) -; - - - - - (= - (get_variable_p $Value +; /* we couldn't find another partial match - just return */ + (= (partial-match1 $Templ $Ex $OldBL (Cons $PartialMatch $RestPL) $RestTempl $RestEx $NewBL) + (find-partial-match-p $Templ $Ex $OldBL $PartialMatch $RestTempl1 $RestEx1 $NewBL1) + (set-det) + (partial-match1 $RestTempl1 $RestEx1 $NewBL1 $RestPL $RestTempl $RestEx $NewBL)) + + + (= (find-partial-match-p $Templ $Ex $OldBL $PartialMatch $RestTempl $RestEx $NewBL) + (enumerate $Templ $Part $RestTempl) + (find-partial-match-p1 $Part $Ex $OldBL $MatchingFact $RestEx $NewBL) + (= $PartialMatch + (:: $Part $MatchingFact))) +; /* can we find a partial match for Part? */ +; /* yes, fine */ + + + (= (find-partial-match-p1 $Part $Ex $OldBL $ExamplePart $RestEx $NewBL) + (enumerate $Ex $ExamplePart $RestEx) + (partial-match-p $Part $ExamplePart $OldBL $NewBL)) +; /* they must match */ + + + (= (partial-match-p (must $Constraint) $Fact $OldBL $NewBL) + (set-det) + (partial-match-p $Constraint $Fact $OldBL $NewBL)) +; /********************************************************************/ +; /* */ +; /* call : partial_match_p(+Constraint,+Fact,+OldBL,-NewBL) */ +; /* */ +; /* arguments : Constraint = */ +; /* Fact = */ +; /* OldBL = List of Current Bindings */ +; /* NewBL = List of New Bindings */ +; /* */ +; /********************************************************************/ +; /* Succeed if Constraint and Fact match partially, returning the new*/ +; /* binding list, or fail otherwise. */ +; /* Second possibility: we are able to use a theorem that uses the */ +; /* existing example fact to derive a fact that matches. See */ +; /* arch_1.pro for some sample inferences. */ +; /********************************************************************/ + (= (partial-match-p $Constraint $Fact $OldBL $NewBL) + (=.. $Constraint + (Cons $Functor $Args1)) + (=.. $Fact + (Cons $Functor $Args2)) + (count-differences-p $Args1 $Args2 $OldBL $NewBL 1)) + (= (partial-match-p $Constraint $Fact $OldBL $NewBL) + (infer $Fact $FactDerivation) + (partial-match-p $Constraint $FactDerivation $OldBL $NewBL)) + + + + (= (partial-match-better-p (:: $PL1 $RestTempl1 $RestEx1 $BL1) (:: $PL2 $RestTempl2 $RestEx2 $BL2)) + (length $RestTempl1 $L1) + (length $RestTempl2 $L2) + (< $L1 $L2)) +; /********************************************************************/ +; /* Decides if one partial match is better than another by a simple */ +; /* measure: more parts of the template matched */ +; /********************************************************************/ + + + (= (partial-match-equal-p (:: $PL1 $RestTempl1 $RestEx1 $BL1) (:: $PL2 $RestTempl2 $RestEx2 $BL2)) + (set-equal-p $PL1 $PL2) + (set-equal-p $RestTempl1 $RestTempl2) + (set-equal-p $RestEx1 $RestEx2) + (set-equal-p $BL1 $BL2)) + + + (= (count-differences-p Nil Nil $BL $BL 0) + (set-det)) +; /********************************************************************/ +; /* */ +; /* call : count_differences_p(+List1,+List2,+OldBL,-NewBL, */ +; /* -NoOfDifferences) */ +; /* */ +; /* arguments : List1 = */ +; /* List2 = */ +; /* OldBL = List of Current Bindings */ +; /* NewBL = List of New Bindings */ +; /* NoOfDifferences = Number of Differences */ +; /* */ +; /********************************************************************/ +; /* NoOfDifferences is the number of positions in which list1 and */ +; /* list2 differ, returning new binding list. Fails if the two lists */ +; /* don't have the same length. */ +; /********************************************************************/ + (= (count-differences-p (Cons $First1 $Rest1) (Cons $First2 $Rest2) $OldBL $NewBL $RestN) + (atom-match-p $First1 $First2 $OldBL $BL) + (set-det) + (count-differences-p $Rest1 $Rest2 $BL $NewBL $RestN)) +; /* those two matched - compute differences for tail of list */ + (= (count-differences-p (Cons $First1 $Rest1) (Cons $First2 $Rest2) $OldBL $NewBL $N) + (set-det) + (not (= $First1 (var $_))) + (not (= $First2 (var $_))) + (count-differences-p $Rest1 $Rest2 $OldBL $NewBL $RestN) + (is $N + (+ $RestN 1))) +; /* oops - they didn't match, increase count (but only if */ +; /* both were constants), there can't be partial matches */ +; /* with incorrectly bound vars) */ + + + (= (atom-match-p $O1 $O2 $OldBL $NewBL) + (atom-match-p1 $O1 $O2 $OldBL $NewBL) + (unique-binding-p $NewBL)) +; /********************************************************************/ +; /* */ +; /* call : atom_match_p(+Object1,+Object2,BindingList) */ +; /* */ +; /* arguments : Object1 = */ +; /* Object2 = */ +; /* BindingList = List of Current Bindings */ +; /********************************************************************/ +; /* Succeeds iff Object1 and Object2 can be unified using the */ +; /* bindings in BindingList. Variables are marked "var(varname)" */ +; /* (i.e., they are not MeTTa variables). Handles atoms and */ +; /* variables only. Note: we require bindings to be unique, i.e. */ +; /* invertible mappings from vars to values. atom_match_p checks for */ +; /* that after performing a match. */ +; /********************************************************************/ + + + (= (atom-match-p1 (var $VarName1) (var $VarName2) $OldBL $NewBL) + (set-det) + (get-binding $VarName1 $OldBL $BL $Binding1) + (get-binding $VarName2 $BL $NewBL $Binding2) + (= $Binding1 $Binding2)) +; /* matching two variables - give them a MeTTa variable */ +; /* as binding, so when one of them gets matched later on, */ +; /* that binding is propagated */ + (= (atom-match-p1 $Const (var $VarName) $OldBL $NewBL) + (set-det) + (get-binding $VarName $OldBL $NewBL $Const)) +; /* we require bindings to be unique (one part in object A */ +; /* can match only one part in object B */ + (= (atom-match-p1 (var $VarName) $Const $OldBL $NewBL) + (set-det) + (get-binding $VarName $OldBL $NewBL $Const)) + (= (symbol_match_p1 $Const $Const $BL $BL) True) + + + (= (get-binding $Key Nil (:: (Cons $Key $Value)) $Value) + (set-det)) +; /********************************************************************/ +; /* */ +; /* call : get_binding(+Key,+BindingList,-Value) */ +; /* */ +; /* arguments : Key = */ +; /* BindingList = List of Current Bindings */ +; /* Value = */ +; /* */ +; /********************************************************************/ +; /* Value is the binding for Key in BindingList (first occurence). If*/ +; /* key is not bound in BindingList, a PROLOG variable is returned */ +; /* as Value. If the binding list is empty, Key doesn't have a value*/ +; /* yet, add it (as an unbound variable) */ +; /********************************************************************/ + (= (get-binding $Key $BL $BL $Value1) + (= $BL (Cons - (Cons $Variable $Value) $_) $Variable) True) -; - - (= - (get-variable-p $Value - (Cons $_ $RestBL) $Variable) + (Cons $Key $Value2) $_)) + (set-det) + (= $Value1 $Value2)) +; /* this split is necessary for cases where Value1 is */ +; /* bound by the caller */ + (= (get-binding $Key (Cons $FirstBinding $RestBL) (Cons $FirstBinding $NewRestBL) $Value) + (set-det) + (get-binding $Key $RestBL $NewRestBL $Value)) + + + + (= (get_variable_p $Value (Cons (Cons $Variable $Value) $_) $Variable) True) +; /********************************************************************/ +; /* */ +; /* call : get_variable_p(+Value,+BindingList,-Variable) */ +; /* */ +; /* arguments : Value = */ +; /* BindingList = List of Current Bindings */ +; /* Variable = */ +; /* */ +; /********************************************************************/ +; /* The "reverse" of get_binding: given a value, returns the first */ +; /* Variable bound to that value in BindingList (backtracking returns*/ +; /* second, etc.). Fails if there is none. */ +; /********************************************************************/ + (= (get-variable-p $Value (Cons $_ $RestBL) $Variable) (get-variable-p $Value $RestBL $Variable)) -; - - - - - (= - (unique_binding_p ()) True) -; - - (= - (unique-binding-p (Cons $FirstBinding $RestBindings)) - ( (unique-binding-p $RestBindings) - (= $FirstBinding - (Cons $_ $Value)) - (not (get-variable-p $Value $RestBindings $_)))) -; - - - - (= - (initial-generalization $Example $InitialConcept) - ( (variabilize-part-facts $Example $VarPartFacts $BL $RestFacts) - (variabilize-facts $RestFacts $BL $VarRestFacts) - (append $VarPartFacts $VarRestFacts $Template) - (concept-template $InitialConcept $Template) - (concept-constraints $InitialConcept Nil) - (set-det))) -; - (= - (variabilize-part-facts Nil Nil Nil Nil) + (= (unique_binding_p ()) True) +; /********************************************************************/ +; /* */ +; /* call : unique_binding_p(BindingList) */ +; /* */ +; /* arguments : BindingList = List of Current Bindings */ +; /* */ +; /********************************************************************/ +; /* Suceeds if no binding value occurs more than once */ +; /********************************************************************/ + (= (unique-binding-p (Cons $FirstBinding $RestBindings)) + (unique-binding-p $RestBindings) + (= $FirstBinding + (Cons $_ $Value)) + (not (get-variable-p $Value $RestBindings $_))) + + + (= (initial-generalization $Example $InitialConcept) + (variabilize-part-facts $Example $VarPartFacts $BL $RestFacts) + (variabilize-facts $RestFacts $BL $VarRestFacts) + (append $VarPartFacts $VarRestFacts $Template) + (concept-template $InitialConcept $Template) + (concept-constraints $InitialConcept Nil) (set-det)) -; - - (= - (variabilize-part-facts - (Cons - (part $PartName) $Rest) $VarPartFacts $BL $RestFacts) - ( (set-det) - (= $VarPartFacts - (Cons - (part (var $PartName)) $VarRestParts)) - (= $BL - (Cons - (Cons $PartName $PartName) $RestBL)) - (variabilize-part-facts $Rest $VarRestParts $RestBL $RestFacts))) -; - - (= - (variabilize-part-facts - (Cons $First $Rest) $VarRestParts $RestBL - (Cons $First $RestFacts)) - ( (set-det) (variabilize-part-facts $Rest $VarRestParts $RestBL $RestFacts))) -; - - - - (= - (variabilize-facts Nil $_ Nil) +; /********************************************************************/ +; /* */ +; /* call : initial_generalization(+Example, */ +; /* -InitialDefinition) */ +; /* */ +; /* arguments : Example = Structural Description */ +; /* InitialDefinition = Generalized Definition */ +; /* */ +; /********************************************************************/ +; /* Winston interprets all nodes as variables, except those found */ +; /* in special positions (eg., second argument of an isa link). In */ +; /* our representation, this means we have to mark the constants */ +; /* found in the first example as variables. We use a different */ +; /* heuristic: all parts (introduced with the "part" predicate) are */ +; /* interpreted as variables. The result constitutes the initial */ +; /* sufficient conditions, the necessary conditions are still empty, */ +; /* as we haven't seen counterexamples yet. */ +; /********************************************************************/ +; /* now variabilize the other facts, marking only the */ +; /* part names as variable */ + + + (= (variabilize-part-facts Nil Nil Nil Nil) (set-det)) -; - - (= - (variabilize-facts - (Cons $First $Rest) $BL - (Cons $VarFirst $VarRest)) - ( (set-det) - (variabilize-fact $First $BL $VarFirst) - (variabilize-facts $Rest $BL $VarRest))) -; - - - - (= - (specialize-concept-definition Nil $_ $C $C) - (set-det)) -; - - (= - (specialize-concept-definition + (= (variabilize-part-facts (Cons (part $PartName) $Rest) $VarPartFacts $BL $RestFacts) + (set-det) + (= $VarPartFacts (Cons - (addition $ExampleFact) $RestDD) $BL $OldConcept $NewConcept) - ( (set-det) - (variabilize-fact $ExampleFact $BL $NewNecessaryConstraint) - (specialize-concept-definition $RestDD $BL $OldConcept $Concept) - (concept-constraints $Concept $Constraints) - (list-add-if-necessary - (not $NewNecessaryConstraint) $Constraints $NewConstraints) - (alter-concept-constraints $Concept $NewConstraints $NewConcept))) -; - - - (= - (specialize-concept-definition + (part (var $PartName)) $VarRestParts)) + (= $BL (Cons - (missing $Part) $RestDD) $BL $OldConcept $NewConcept) - ( (set-det) - (specialize-concept-definition $RestDD $BL $OldConcept $Concept) - (concept-template $Concept $Template) - (list-remove $Part $Template $Template1) - (= $NewTemplate - (Cons - (must $Part) $Template1)) - (alter-concept-template $Concept $NewTemplate $NewConcept))) -; - - - (= - (specialize-concept-definition - (Cons - (partial (:: $Part $_)) $RestDD) $BL $OldConcept $NewConcept) - ( (set-det) - (specialize-concept-definition $RestDD $BL $OldConcept $Concept) - (concept-template $Concept $Template) - (list-remove $Part $Template $Template1) - (= $NewTemplate - (Cons - (must $Part) $Template1)) - (alter-concept-template $Concept $NewTemplate $NewConcept))) -; - + (Cons $PartName $PartName) $RestBL)) + (variabilize-part-facts $Rest $VarRestParts $RestBL $RestFacts)) + (= (variabilize-part-facts (Cons $First $Rest) $VarRestParts $RestBL (Cons $First $RestFacts)) + (set-det) + (variabilize-part-facts $Rest $VarRestParts $RestBL $RestFacts)) - (= - (variabilize-fact $Fact $BL $VarFact) - ( (=.. $Fact - (Cons $Functor $Args)) - (variabilize-list $Args $BL $VarArgs) - (=.. $VarFact - (Cons $Functor $VarArgs)))) -; - - - - (= - (variabilize-list Nil $_ Nil) + (= (variabilize-facts Nil $_ Nil) (set-det)) -; - - (= - (variabilize-list - (Cons $FirstArg $RestArgs) $BL - (Cons - (var $VarFirstArg) $VarRestArgs)) - ( (get-variable-p $FirstArg $BL $VarFirstArg) - (set-det) - (variabilize-list $RestArgs $BL $VarRestArgs))) -; - - (= - (variabilize-list - (Cons $FirstArg $RestArgs) $BL - (Cons $FirstArg $VarRestArgs)) - ( (set-det) (variabilize-list $RestArgs $BL $VarRestArgs))) -; - + (= (variabilize-facts (Cons $First $Rest) $BL (Cons $VarFirst $VarRest)) + (set-det) + (variabilize-fact $First $BL $VarFirst) + (variabilize-facts $Rest $BL $VarRest)) - (= - (generalize-concept-definition Nil $C $C) + (= (specialize-concept-definition Nil $_ $C $C) (set-det)) -; - - (= - (generalize-concept-definition +; /********************************************************************/ +; /* */ +; /* call : specialize_concept_definition( */ +; /* +DifferenceDescriptions, */ +; /* +BindingList,+OldConcept, */ +; /* -NewConcept) */ +; /* */ +; /* arguments : DifferenceDescriptions = Difference Description */ +; /* BindingList = List of Current Bindings */ +; /* OldConcept = Current Concept Def. */ +; /* NewConcept = New Concept Definition */ +; /* */ +; /********************************************************************/ +; /* Specialize the supplied concept definition by adding constraints */ +; /* to its necessary conditions. Based on Winston's require-link */ +; /* and forbid-link heuristics. */ +; /********************************************************************/ + (= (specialize-concept-definition (Cons (addition $ExampleFact) $RestDD) $BL $OldConcept $NewConcept) + (set-det) + (variabilize-fact $ExampleFact $BL $NewNecessaryConstraint) + (specialize-concept-definition $RestDD $BL $OldConcept $Concept) + (concept-constraints $Concept $Constraints) + (list-add-if-necessary + (not $NewNecessaryConstraint) $Constraints $NewConstraints) + (alter-concept-constraints $Concept $NewConstraints $NewConcept)) +; /* an additional fact was found in the example - use */ +; /* forbid-link heuristic */ +; /* treat rest of differences */ +; /* add negative constraint to constraints slot */ + + (= (specialize-concept-definition (Cons (missing $Part) $RestDD) $BL $OldConcept $NewConcept) + (set-det) + (specialize-concept-definition $RestDD $BL $OldConcept $Concept) + (concept-template $Concept $Template) + (list-remove $Part $Template $Template1) + (= $NewTemplate (Cons - (partial (:: $Constraint $ExampleFact)) $RestDD) $OldConcept $NewConcept) - ( (set-det) - (generalize-arg $Constraint $ExampleFact $NewConstraint) - (generalize-concept-definition $RestDD $OldConcept $RestConcept) - (concept-template $RestConcept $Template) - (list-remove $Constraint $Template $Template1) - (= $NewTemplate - (Cons $NewConstraint $Template1)) - (alter-concept-template $RestConcept $NewTemplate $NewConcept))) -; - - - (= - (generalize-concept-definition + (must $Part) $Template1)) + (alter-concept-template $Concept $NewTemplate $NewConcept)) +; /* a constraint was missing from the example - use require-link */ +; /* heuristic */ +; /* treat rest of differences */ +; /* replace Part by must(Part) */ + + (= (specialize-concept-definition (Cons (partial (:: $Part $_)) $RestDD) $BL $OldConcept $NewConcept) + (set-det) + (specialize-concept-definition $RestDD $BL $OldConcept $Concept) + (concept-template $Concept $Template) + (list-remove $Part $Template $Template1) + (= $NewTemplate (Cons - (missing $Constraint) $RestDD) $OldConcept $NewConcept) - ( (set-det) - (generalize-concept-definition $RestDD $OldConcept $RestConcept) - (concept-template $RestConcept $Template) - (list-remove $Constraint $Template $NewTemplate) - (alter-concept-template $RestConcept $NewTemplate $NewConcept))) -; + (must $Part) $Template1)) + (alter-concept-template $Concept $NewTemplate $NewConcept)) +; /* a partial match - treat like missing constraint */ +; /* replace Part by must(Part) */ + + + (= (variabilize-fact $Fact $BL $VarFact) + (=.. $Fact + (Cons $Functor $Args)) + (variabilize-list $Args $BL $VarArgs) + (=.. $VarFact + (Cons $Functor $VarArgs))) +; /********************************************************************/ +; /* */ +; /* call : variabilize_fact(+Fact,+BindingList,-VarFact) */ +; /* */ +; /* arguments : Fact = */ +; /* BindingList = List of Current Bindings */ +; /* VarFact = */ +; /* */ +; /********************************************************************/ +; /* Replaces each argument in Fact by the first variable in */ +; /* BindingList which has that argument as its binding; if there is */ +; /* none, the argumnet is left as it is. */ +; /********************************************************************/ + + + (= (variabilize-list Nil $_ Nil) + (set-det)) + (= (variabilize-list (Cons $FirstArg $RestArgs) $BL (Cons (var $VarFirstArg) $VarRestArgs)) + (get-variable-p $FirstArg $BL $VarFirstArg) + (set-det) + (variabilize-list $RestArgs $BL $VarRestArgs)) + (= (variabilize-list (Cons $FirstArg $RestArgs) $BL (Cons $FirstArg $VarRestArgs)) + (set-det) + (variabilize-list $RestArgs $BL $VarRestArgs)) - (= - (generalize-concept-definition - (Cons $_ $RestDD) $OldSC $RestSC) + (= (generalize-concept-definition Nil $C $C) + (set-det)) +; /********************************************************************/ +; /* */ +; /* call : generalize_concept_definition( */ +; /* +DifferenceDescriptions, */ +; /* +OldConcept,-NewConcept) */ +; /* */ +; /* arguments : DifferenceDescriptions = Difference Description */ +; /* OldConcept = Current Concept Defi. */ +; /* NewConcept = New Concept Definition */ +; /* */ +; /********************************************************************/ +; /* Generalize the supplied concept definition by weakening and/or */ +; /* removing constraints from its sufficient conditions NOTE: if you */ +; /* pass differences involving necessary conditions ("must"), */ +; /* generalization may result in the concept covering negative */ +; /* examples again. */ +; /********************************************************************/ + (= (generalize-concept-definition (Cons (partial (:: $Constraint $ExampleFact)) $RestDD) $OldConcept $NewConcept) + (set-det) + (generalize-arg $Constraint $ExampleFact $NewConstraint) + (generalize-concept-definition $RestDD $OldConcept $RestConcept) + (concept-template $RestConcept $Template) + (list-remove $Constraint $Template $Template1) + (= $NewTemplate + (Cons $NewConstraint $Template1)) + (alter-concept-template $RestConcept $NewTemplate $NewConcept)) +; /* a partial match was found, i.e., one arg in Constraint and */ +; /* Factis different. If there is common parent in the ako */ +; /* hierarchy for both, use the parent in the new constraint. */ +; /* If there isn't, use a new variable */ +; /* treat rest of differences */ + + (= (generalize-concept-definition (Cons (missing $Constraint) $RestDD) $OldConcept $NewConcept) + (set-det) + (generalize-concept-definition $RestDD $OldConcept $RestConcept) + (concept-template $RestConcept $Template) + (list-remove $Constraint $Template $NewTemplate) + (alter-concept-template $RestConcept $NewTemplate $NewConcept)) +; /* a constraint was missing from the example - use */ +; /* drop-link heuristic */ + + (= (generalize-concept-definition (Cons $_ $RestDD) $OldSC $RestSC) (generalize-concept-definition $RestDD $OldSC $RestSC)) -; - - +; /* this must be an additional example fact - don't know */ +; /* what to do with them, so ignore and treat rest of */ +; /* differences */ - (= - (generalize-arg - (must $Constraint) $ExampleFact - (must $NewConstraint)) - ( (set-det) (generalize-arg $Constraint $ExampleFact $NewConstraint))) -; + (= (generalize-arg (must $Constraint) $ExampleFact (must $NewConstraint)) + (set-det) + (generalize-arg $Constraint $ExampleFact $NewConstraint)) - (= - (generalize-arg $Constraint $ExampleFact $NewConstraint) - ( (=.. $Constraint - (Cons $Functor $Args1)) - (=.. $ExampleFact - (Cons $Functor $Args2)) - (generalize-arg1 $Args1 $Args2 $NewArgs1) - (=.. $NewConstraint - (Cons $Functor $NewArgs1)))) -; + (= (generalize-arg $Constraint $ExampleFact $NewConstraint) + (=.. $Constraint + (Cons $Functor $Args1)) + (=.. $ExampleFact + (Cons $Functor $Args2)) + (generalize-arg1 $Args1 $Args2 $NewArgs1) + (=.. $NewConstraint + (Cons $Functor $NewArgs1))) - - (= - (generalize-arg1 Nil Nil Nil) + (= (generalize-arg1 Nil Nil Nil) (set-det)) -; - - (= - (generalize-arg1 - (Cons $Arg1 $Rest1) - (Cons $Arg2 $Rest2) - (Cons $Arg1 $GenRest)) - ( (or - (= $Arg1 $Arg2) - (= $Arg1 - (var $_))) - (set-det) - (generalize-arg1 $Rest1 $Rest2 $GenRest))) -; - - (= - (generalize-arg1 - (Cons $Arg1 $Rest1) - (Cons $Arg2 $_) - (Cons $GenArg $Rest1)) - ( (set-det) (find-or-create-common-ancestor $Arg1 $Arg2 $GenArg))) -; - - - - (= - (find-or-create-common-ancestor $Class1 $Class2 $Ancestor) - ( (ancestors $Class1 $Ancestors1) - (ancestors $Class2 $Ancestors2) - (smallest-ancestor-p $Ancestors1 $Ancestors2 $Ancestor) - (set-det))) -; - - (= - (find-or-create-common-ancestor $Class1 $Class2 $Ancestor) + (= (generalize-arg1 (Cons $Arg1 $Rest1) (Cons $Arg2 $Rest2) (Cons $Arg1 $GenRest)) + (or + (= $Arg1 $Arg2) + (= $Arg1 + (var $_))) + (set-det) + (generalize-arg1 $Rest1 $Rest2 $GenRest)) + (= (generalize-arg1 (Cons $Arg1 $Rest1) (Cons $Arg2 $_) (Cons $GenArg $Rest1)) + (set-det) + (find-or-create-common-ancestor $Arg1 $Arg2 $GenArg)) +; /* o.k., this is it - can we generalize them? */ + + + (= (find-or-create-common-ancestor $Class1 $Class2 $Ancestor) + (ancestors $Class1 $Ancestors1) + (ancestors $Class2 $Ancestors2) + (smallest-ancestor-p $Ancestors1 $Ancestors2 $Ancestor) + (set-det)) + (= (find-or-create-common-ancestor $Class1 $Class2 $Ancestor) ( (set-det) (concat $Class1 $Class2 $Ancestor) - (add-symbol &self + (add-is-symbol &self (ako $Class1 $Ancestor)) - (add-symbol &self + (add-is-symbol &self (ako $Class2 $Ancestor)))) -; +; /* create a new name */ +; /* and record its relation to existing classes */ - - (= - (ancestors $Class $Ancestors) + (= (ancestors $Class $Ancestors) (ancestors1 (:: $Class) Nil $Ancestors)) -; - - (= - (ancestors1 Nil $Ancestors $Ancestors) + (= (ancestors1 Nil $Ancestors $Ancestors) (set-det)) -; - - (= - (ancestors1 - (Cons $First $Rest) $Ancestors $ExtendedAncestors) - ( (direct-ancestors $First $FirstAncestors) - (not (= $FirstAncestors Nil)) - (set-det) - (append $FirstAncestors $Rest $NewClassList) - (union $Ancestors $FirstAncestors $NewAncestorList) - (ancestors1 $NewClassList $NewAncestorList $ExtendedAncestors))) -; - - (= - (ancestors1 - (Cons $First $Rest) $Ancestors $ExtendedAncestors) - ( (set-det) - (union - (:: $First) $Ancestors $NewAncestors) - (ancestors1 $Rest $NewAncestors $ExtendedAncestors))) -; - - - - (= - (direct-ancestors $Class $Ancestors) - ( (set-det) (findbag $Ancestor (ako $Class $Ancestor) $Ancestors))) -; - + (= (ancestors1 (Cons $First $Rest) $Ancestors $ExtendedAncestors) + (direct-ancestors $First $FirstAncestors) + (not (= $FirstAncestors Nil)) + (set-det) + (append $FirstAncestors $Rest $NewClassList) + (union $Ancestors $FirstAncestors $NewAncestorList) + (ancestors1 $NewClassList $NewAncestorList $ExtendedAncestors)) + (= (ancestors1 (Cons $First $Rest) $Ancestors $ExtendedAncestors) + (set-det) + (union + (:: $First) $Ancestors $NewAncestors) + (ancestors1 $Rest $NewAncestors $ExtendedAncestors)) +; /* no ancestors */ - (= - (smallest-ancestor-p - (Cons $First $_) $Ancestors2 $First) - ( (member $First $Ancestors2) (set-det))) -; + (= (direct-ancestors $Class $Ancestors) + (set-det) + (findbag $Ancestor + (ako $Class $Ancestor) $Ancestors)) - (= - (smallest-ancestor-p - (Cons $_ $Rest) $Ancestors2 $Ancestor) - ( (set-det) (smallest-ancestor-p $Rest $Ancestors2 $Ancestor))) -; + (= (smallest-ancestor-p (Cons $First $_) $Ancestors2 $First) + (member $First $Ancestors2) + (set-det)) + (= (smallest-ancestor-p (Cons $_ $Rest) $Ancestors2 $Ancestor) + (set-det) + (smallest-ancestor-p $Rest $Ancestors2 $Ancestor)) - (= - (list-remove $_ Nil Nil) + (= (list-remove $_ Nil Nil) (set-det)) -; - - (= - (list-remove $Target - (Cons $Target $Rest) $RestRemoved) - ( (set-det) (list-remove $Target $Rest $RestRemoved))) -; - - (= - (list-remove $Target - (Cons $First $Rest) - (Cons $First $RestRemoved)) +; /********************************************************************/ +; /* */ +; /* call : list_remove(+Target,+List,-Rest) */ +; /* */ +; /* arguments : Target = */ +; /* List = */ +; /* Rest = List without Target */ +; /* */ +; /********************************************************************/ +; /* Remove all elements of List that unify with Target, return the */ +; /* Rest. */ +; /********************************************************************/ + (= (list-remove $Target (Cons $Target $Rest) $RestRemoved) + (set-det) + (list-remove $Target $Rest $RestRemoved)) + (= (list-remove $Target (Cons $First $Rest) (Cons $First $RestRemoved)) (list-remove $Target $Rest $RestRemoved)) -; - - (= - (msgs Nil) + (= (msgs Nil) + (set-det)) +; /********************************************************************/ +; /* */ +; /* call : msgs(+List) */ +; /* */ +; /* arguments : List = of Elements which should be displayed on */ +; /* current output device */ +; /* */ +; /********************************************************************/ +; /* Display the Elements of the List on the current output device. */ +; /* The following constants are handled in a special way: */ +; /* */ +; /* nl - forces a single linefeed */ +; /* nl(X) - forces the number of linefeeds given by X */ +; /* sp - forces a single space */ +; /* nl(X) - forces the number of spaces given by X */ +; /* pf(X,Y) - uses print function X to display Y */ +; /* */ +; /* Every other element is outputed in the normal "print"-way. */ +; /********************************************************************/ + (= (msgs (Cons $First $Rest)) + (msg $First) + (msgs $Rest) (set-det)) -; - - (= - (msgs (Cons $First $Rest)) - ( (msg $First) - (msgs $Rest) - (set-det))) -; - - - - (= - (msg nl) - ( (set-det) (nl))) -; - - (= - (msg (nl $N)) - ( (set-det) (repeat $N nl))) -; - - (= - (msg sp) - ( (set-det) (write ' '))) -; - - (= - (msg (sp $N)) - ( (set-det) (repeat $N (write ' ')))) -; - - (= - (msg (pf $PF $Object)) - ( (set-det) - (=.. $Call - (:: $PF $Object)) - (call $Call))) -; - - (= - (msg $Object) - ( (write $Object) (set-det))) -; + (= (msg nl) + (set-det) + (nl)) + (= (msg (nl $N)) + (set-det) + (repeat $N nl)) + (= (msg sp) + (set-det) + (write ' ')) + (= (msg (sp $N)) + (set-det) + (repeat $N + (write ' '))) + (= (msg (pf $PF $Object)) + (set-det) + (=.. $Call + (:: $PF $Object)) + (call $Call)) + (= (msg $Object) + (write $Object) + (set-det)) - (= - (repeat $N $_) - ( (< $N 1) (set-det))) -; - (= - (repeat $N $Call) + (= (repeat $N $_) + (< $N 1) + (set-det)) +; /********************************************************************/ +; /* */ +; /* call : repeat(+Number,+Call) */ +; /* */ +; /* arguments : Number = Number of times */ +; /* Call = Procedure call */ +; /* */ +; /********************************************************************/ +; /* Repeats Call Number times. */ +; /********************************************************************/ + (= (repeat $N $Call) ($Call (is $N1 (- $N 1)) (repeat $N1 $Call) (set-det))) -; - - (= - (set-equal-p Nil Nil) + (= (set-equal-p Nil Nil) (set-det)) -; - - (= - (set-equal-p - (Cons $First $Rest) $Set2) - ( (enumerate $Set2 $First $Rest2) - (set-det) - (set-equal-p $Rest $Rest2))) -; + (= (set-equal-p (Cons $First $Rest) $Set2) + (enumerate $Set2 $First $Rest2) + (set-det) + (set-equal-p $Rest $Rest2)) - - (= - (remove-duplicates Nil Nil $_) + (= (remove-duplicates Nil Nil $_) (set-det)) -; - - (= - (remove-duplicates - (Cons $First $Rest) $Result $EqualP) - ( (remove-duplicates $Rest $RestResult $EqualP) (remove-duplicates-result $First $RestResult $Result $EqualP))) -; - - - - (= - (remove-duplicates-result $First $RestResult $RestResult $EqualP) - ( (member $First $RestResult $EqualP) (set-det))) -; - - (= - (remove_duplicates_result $First $RestResult - (Cons $First $RestResult) $_) True) -; - - - - (= - (list_sort () () $_) True) -; - - (= - (list-sort - (Cons $X $L) $M $O) - ( (list-sort $L $N $O) (list-sort1 $X $N $M $O))) -; - - - - (= - (list-sort1 $X - (Cons $A $L) - (Cons $A $M) $O) - ( (=.. $P - (:: $O $A $X)) - (call $P) - (set-det) - (list-sort1 $X $L $M $O))) -; - - (= - (list_sort1 $X $L - (Cons $X $L) $_) True) -; - - - - (= - (get_best () () $_) True) -; - - (= - (get_best - ($Single) - ($Single) $_) True) -; - - (= - (get-best - (Cons $First - (Cons $Second $_)) - (:: $First) $ComparisonP) - ( (=.. $Call - (:: $ComparisonP $First $Second)) - (call $Call) - (set-det))) -; - - (= +; /********************************************************************/ +; /* remove_duplicates */ +; /********************************************************************/ +; /* with an additional EqualP */ +; /********************************************************************/ + (= (remove-duplicates (Cons $First $Rest) $Result $EqualP) + (remove-duplicates $Rest $RestResult $EqualP) + (remove-duplicates-result $First $RestResult $Result $EqualP)) + + + (= (remove-duplicates-result $First $RestResult $RestResult $EqualP) + (member $First $RestResult $EqualP) + (set-det)) + (= (remove_duplicates_result $First $RestResult (Cons $First $RestResult) $_) True) + + + (= (list_sort () () $_) True) +; /********************************************************************/ +; /* */ +; /* call : list_sort(+List,-SortedList,+ComparisonPredicate) */ +; /* */ +; /* arguments : List = */ +; /* SortedList = */ +; /* ComparisonPredicateDifference = */ +; /* */ +; /********************************************************************/ +; /* An insertion sort ! */ +; /* SortedList has the same members as List and is sorted according */ +; /* to ComparisonPredicate (a before b if ComparisonPredicate(a,b)). */ +; /********************************************************************/ + (= (list-sort (Cons $X $L) $M $O) + (list-sort $L $N $O) + (list-sort1 $X $N $M $O)) + + + (= (list-sort1 $X (Cons $A $L) (Cons $A $M) $O) + (=.. $P + (:: $O $A $X)) + (call $P) + (set-det) + (list-sort1 $X $L $M $O)) + (= (list_sort1 $X $L (Cons $X $L) $_) True) + + + (= (get_best () () $_) True) +; /********************************************************************/ +; /* */ +; /* call : get_best(+SortedList,-Best,+OrderP) */ +; /* */ +; /* arguments : SortedList = */ +; /* Best = */ +; /* OrderP = */ +; /* */ +; /********************************************************************/ +; /* get_best returns the elements with the top score in SortedList */ +; /* (which must be sorted according to OrderP). */ +; /********************************************************************/ + (= (get_best ($Single) ($Single) $_) True) + (= (get-best (Cons $First (Cons $Second $_)) (:: $First) $ComparisonP) + (=.. $Call + (:: $ComparisonP $First $Second)) + (call $Call) + (set-det)) +; /* the next match is worse - we've found all the best matches */ + (= (get-best (Cons $First (Cons $Second $Rest)) (Cons $First $RestBest) $ComparisonP) + (set-det) (get-best - (Cons $First - (Cons $Second $Rest)) - (Cons $First $RestBest) $ComparisonP) - ( (set-det) (get-best (Cons $Second $Rest) $RestBest $ComparisonP))) -; - - - - (= - (enumerate - (Cons $Head $Tail) $Head $Tail) True) -; - - (= - (enumerate - (Cons $Head $Tail) $NextHead - (Cons $Head $NextRest)) + (Cons $Second $Rest) $RestBest $ComparisonP)) +; /* keep looking */ + + + (= (enumerate (Cons $Head $Tail) $Head $Tail) True) +; /********************************************************************/ +; /* */ +; /* call : enumerate(!List,?Head,?Rest) */ +; /* */ +; /* arguments : List = */ +; /* Head = */ +; /* Rest = */ +; /* */ +; /********************************************************************/ +; /* Enumerates heads of List on backtracking, Rest is always List */ +; /* with current Head removed. */ +; /********************************************************************/ + (= (enumerate (Cons $Head $Tail) $NextHead (Cons $Head $NextRest)) (enumerate $Tail $NextHead $NextRest)) -; - - (= - (list-add-if-necessary $NewElement $List $List) - ( (member $NewElement $List) (set-det))) -; - - (= - (list-add-if-necessary $NewElement $List $NewList) - ( (= $NewList - (Cons $NewElement $List)) (set-det))) -; - - - - (= - (concat $S1 $S2 $S3) - ( (nonvar $S1) - (nonvar $S2) - (name $S1 $L1) - (name $S2 $L2) - (append $L1 $L2 $L3) - (name $S3 $L3) - (set-det))) -; - - - (= - (concat $S1 $S2 $S3) - ( (nonvar $S1) - (nonvar $S3) - (name $S1 $L1) - (name $S3 $L3) - (append $L1 $L2 $L3) - (name $S2 $L2) - (set-det))) -; + (= (list-add-if-necessary $NewElement $List $List) + (member $NewElement $List) + (set-det)) +; /********************************************************************/ +; /* */ +; /* call : list_add_if_necessary(+NewElement,+List,-NewList) */ +; /* */ +; /* arguments : NewElementList = */ +; /* List = */ +; /* NewList = */ +; /* */ +; /********************************************************************/ +; /* Adds NewElement to List if it is not already there; result is */ +; /* NewList */ +; /********************************************************************/ + (= (list-add-if-necessary $NewElement $List $NewList) + (= $NewList + (Cons $NewElement $List)) + (set-det)) - (= - (concat $S1 $S2 $S3) - ( (nonvar $S2) - (nonvar $S3) - (name $S2 $L2) - (name $S3 $L3) - (append $L1 $L2 $L3) - (name $S1 $L1) - (set-det))) -; + (= (concat $S1 $S2 $S3) + (nonvar $S1) + (nonvar $S2) + (name $S1 $L1) + (name $S2 $L2) + (append $L1 $L2 $L3) + (name $S3 $L3) + (set-det)) +; /********************************************************************/ +; /* */ +; /* call : concat(Atom1,Atom2,Atom3) */ +; /* */ +; /* arguments : Atom1 = */ +; /* Atom2 = */ +; /* Atom3 = */ +; /* */ +; /********************************************************************/ +; /* Concatenates Atom1 and Atom2 to Atom3, or splits Atom3 in two */ +; /* ways if Atom1 is instantiated than the rest of Atom3 is returned */ +; /* in Atom2 or if Atom2 is instantiated than the Atom1 becomes the */ +; /* prefix of Atom3 without Atom1. Two arguments must be instantiated*/ +; /* otherwise the predicate fails. */ +; /********************************************************************/ + + (= (concat $S1 $S2 $S3) + (nonvar $S1) + (nonvar $S3) + (name $S1 $L1) + (name $S3 $L3) + (append $L1 $L2 $L3) + (name $S2 $L2) + (set-det)) + (= (concat $S1 $S2 $S3) + (nonvar $S2) + (nonvar $S3) + (name $S2 $L2) + (name $S3 $L3) + (append $L1 $L2 $L3) + (name $S1 $L1) + (set-det)) - (= - (member $_ $List $_) - ( (var $List) - (set-det) - (is $List Nil) - (fail))) -; - - (= - (member $E - (Cons $First $_) $EqualP) - ( (=.. $Call - (:: $EqualP $E $First)) (call $Call))) -; - - (= - (member $E - (Cons $_ $R) $EqualP) + (= (member $_ $List $_) + (var $List) + (set-det) + (is $List Nil) + (fail)) +; /********************************************************************/ +; /* */ +; /* call : member(Element,List,EqualP) */ +; /* */ +; /* arguments : Element = */ +; /* List = */ +; /* EqualP = */ +; /* */ +; /********************************************************************/ +; /* The common member predicate extend by an additional EqualP to be */ +; /* used for membership test. */ +; /********************************************************************/ + (= (member $E (Cons $First $_) $EqualP) + (=.. $Call + (:: $EqualP $E $First)) + (call $Call)) + (= (member $E (Cons $_ $R) $EqualP) (member $E $R $EqualP)) -; - !(dynamic (/ found 1)) -; - - (= - (findbag $X $G $_) - ( (add-symbol &self + (= (findbag $X $G $_) + ( (add-is-symbol &self (found mark)) (call $G) - (add-symbol &self + (add-is-symbol &self (found $X)) - (fail))) -; - - (= - (findbag $_ $_ $L) - (collect-found Nil $L)) -; - + (fail))) + (= (findbag $_ $_ $L) + (collect-found Nil $L)) - (= - (collect-found $L $L1) - ( (getnext $X) (collect-found (Cons $X $L) $L1))) -; - - (= - (collect_found $L $L) True) -; - + (= (collect-found $L $L1) + (getnext $X) + (collect-found + (Cons $X $L) $L1)) + (= (collect_found $L $L) True) ; (error ; (syntax_error operator_expected) @@ -1310,38 +1449,21 @@ - (= - (union () $X $X) True) -; - - (= - (union - (Cons $X $R) $Y $Z) - ( (member $X $Y) - (set-det) - (union $R $Y $Z))) -; - - (= - (union - (Cons $X $R) $Y - (Cons $X $Z)) + (= (union () $X $X) True) + (= (union (Cons $X $R) $Y $Z) + (member $X $Y) + (set-det) + (union $R $Y $Z)) + (= (union (Cons $X $R) $Y (Cons $X $Z)) (union $R $Y $Z)) -; - - - (= - (help) - ( (write 'Load data set with command: [Filename].') - (nl) - (write 'Start arch1 with command: process-stored-inputs(ConceptName).') - (nl))) -; + (= (help) + (write 'Load data set with command: [Filename].') + (nl) + (write 'Start arch1 with command: process-stored-inputs(ConceptName).') + (nl)) !(help *) -; - diff --git a/arch1/arch1_1.metta b/arch1/arch1_1.metta index bbf75ee..171f4bb 100644 --- a/arch1/arch1_1.metta +++ b/arch1/arch1_1.metta @@ -1,93 +1,34 @@ - - (= - (input 1 example arch - ( (part part1) - (part part2) - (part part3) - (isa part1 brick) - (isa part2 brick) - (isa part3 brick) - (left_of part2 part1) - (supports part1 part3) - (supports part2 part3))) True) -; - - (= - (input 2 near_miss arch - ( (part part1) - (isa part2 brick) - (part part2) - (left_of part2 part1) - (part part3) - (isa part1 brick) - (isa part3 brick))) True) -; - - (= - (input 3 near_miss arch - ( (part part1) - (part part2) - (part part3) - (isa part1 brick) - (isa part2 brick) - (isa part3 brick) - (left_of part2 part1) - (touches part1 part2) - (supports part1 part3) - (supports part2 part3))) True) -; - - (= - (input 4 example arch - ( (part part1) - (part part2) - (part part3) - (isa part1 brick) - (isa part2 brick) - (isa part3 wedge) - (left_of part2 part1) - (supports part1 part3) - (supports part2 part3))) True) -; - - (= - (input 5 near_miss arch - ( (part part1) - (part part2) - (part part3) - (isa part1 brick) - (isa part2 brick) - (isa part3 cylinder) - (left_of part2 part1) - (supports part1 part3) - (supports part2 part3))) True) -; - +; (convert_to_metta_file arch1_1 $_339820 arch1/arch1_1.pl arch1/arch1_1.metta) + + (= (input 1 example arch ((part part1) (part part2) (part part3) (isa part1 brick) (isa part2 brick) (isa part3 brick) (left_of part2 part1) (supports part1 part3) (supports part2 part3))) True) +; /********************************************************************/ +; /* Each example is represented by a set of MeTTa facts. The arch */ +; /* examples in Winston's book come out as follows: */ +; /********************************************************************/ + (= (input 2 near_miss arch ((part part1) (isa part2 brick) (part part2) (left_of part2 part1) (part part3) (isa part1 brick) (isa part3 brick))) True) + (= (input 3 near_miss arch ((part part1) (part part2) (part part3) (isa part1 brick) (isa part2 brick) (isa part3 brick) (left_of part2 part1) (touches part1 part2) (supports part1 part3) (supports part2 part3))) True) + (= (input 4 example arch ((part part1) (part part2) (part part3) (isa part1 brick) (isa part2 brick) (isa part3 wedge) (left_of part2 part1) (supports part1 part3) (supports part2 part3))) True) + (= (input 5 near_miss arch ((part part1) (part part2) (part part3) (isa part1 brick) (isa part2 brick) (isa part3 cylinder) (left_of part2 part1) (supports part1 part3) (supports part2 part3))) True) - (= - (infer - (touch $O1 $O2) - (touch $O2 $O1)) True) -; - - - (= - (infer - (isa $Object $Type1) - (isa $Object $Type2)) - ( (set-det) (ako $Type1 $Type2))) -; - - - - (= - (ako brick parallel_epiphed) True) -; - - (= - (ako wedge parallel_epiphed) True) -; - + (= (infer (touch $O1 $O2) (touch $O2 $O1)) True) +; /********************************************************************/ +; /* background knowledge */ +; /********************************************************************/ +; /* infer - used during matching to try to infer facts that might */ +; /* match. */ +; /* Careful - match doesn't check for cycles in the inference chain. */ +; /********************************************************************/ + + (= (infer (isa $Object $Type1) (isa $Object $Type2)) + (set-det) + (ako $Type1 $Type2)) + + + (= (ako brick parallel_epiphed) True) +; /********************************************************************/ +; /* ako - represent taxonomies */ +; /********************************************************************/ + (= (ako wedge parallel_epiphed) True) diff --git a/arch2/arch2.metta b/arch2/arch2.metta index f9e9758..53bc18f 100644 --- a/arch2/arch2.metta +++ b/arch2/arch2.metta @@ -1,229 +1,298 @@ - - (= - (learn $Concept) - ( (findbag $X - (example $X) $L) (learn $L $Concept))) -; - - - (= - (learn - (Cons $FirstExample $Examples) $ConceptDesc) - ( (initialize $FirstExample $InitialHypothesis) (process-examples $InitialHypothesis $Examples $ConceptDesc))) -; - +; (convert_to_metta_file arch2 $_405988 arch2/arch2.pl arch2/arch2.metta) + + (= (learn $Concept) + (findbag $X + (example $X) $L) + (learn $L $Concept)) +; /******************************************************************/ +; /* ARCH2.PRO Last Modification: Fri Jan 14 19:21:09 1994 */ +; /* Winston's incremental learning procedure. */ +; /******************************************************************/ +; ; ; Copyright (c) 1990 Ivan Bratko ; +; /******************************************************************/ +; /* reimpl. by : Thomas Hoppe */ +; /* Mommsenstr. 50 */ +; /* D-10629 Berlin */ +; /* F.R.G. */ +; /* E-Mail: hoppet@cs.tu-berlin.de */ +; /* 1990 */ +; /* */ +; /* reference : Chapter 18, */ +; /* Ivan Bratko */ +; /* MeTTa */ +; /* 2nd extend edition */ +; /* Addison-Wesley, 1990 */ +; /* */ +; /* call : learn(-Concept) */ +; /* */ +; /* argument : Concept = learned concept description */ +; /* */ +; /******************************************************************/ +; /* This is a strong restricted version of Winston's incremental */ +; /* learning procedure for structural descriptions. */ +; /* The following restrictions are known: */ +; /* - The first example must be positive. */ +; /* - The implementation can handle only up to six objects. */ +; /* - The list containing missing or extra descriptors of a concept*/ +; /* can contain only 3 descriptors. */ +; /* */ +; /* The representation used: */ +; /* Object = object(ListOfParts,ListOfRelations) */ +; /* Concept = concept(ListOfParts,MustRels,Rels,MustNotRels) */ +; /* Positive example = + Object */ +; /* Negative example = - Object */ +; /* */ +; /* Parts in an objects are denoted by MeTTa variables, in a */ +; /* description they are denoted by constants (i.e. part1, ...) */ +; /* */ +; /* learn induces a structural concept description from a list of */ +; /* examples. */ +; /******************************************************************/ +; ; TH Sat May 29 23:41:21 1993 - made some minor modifications + + (= (learn (Cons $FirstExample $Examples) $ConceptDesc) + (initialize $FirstExample $InitialHypothesis) + (process-examples $InitialHypothesis $Examples $ConceptDesc)) - (= - (initialize - (+ (object $Parts $Rels)) - (concept $Parts Nil $Rels Nil)) + (= (initialize (+ (object $Parts $Rels)) (concept $Parts Nil $Rels Nil)) (namevars $Parts (:: part1 part2 part3 part4 part5 part6))) -; - +; ; Turn variables in a description into constants. Atmost the concept ; can contain 6 objects. - (= - (namevars $List $NameList) + (= (namevars $List $NameList) (append $List $_ $NameList)) -; - - - - (= - (process_examples $ConceptDesc () $ConceptDesc) True) -; - - (= - (process-examples $CurDesc - (Cons $Example $Examples) $FinDesc) - ( (object-type $Example $Object $Type) - (match $Object $CurDesc $Difference) - (update $Type $Difference $CurDesc $NewDesc) - (process-examples $NewDesc $Examples $FinDesc))) -; - +; /******************************************************************/ +; /* */ +; /* call : namevars(+VarList,+NameList) */ +; /* */ +; /* argument : VarList = list of variables */ +; /* NameList = list of constants */ +; /* */ +; /******************************************************************/ +; /* namevars instantiates the variables in VarList with the */ +; /* constants in NameList. */ +; /******************************************************************/ + + + (= (process_examples $ConceptDesc () $ConceptDesc) True) + (= (process-examples $CurDesc (Cons $Example $Examples) $FinDesc) + (object-type $Example $Object $Type) + (match $Object $CurDesc $Difference) + (update $Type $Difference $CurDesc $NewDesc) + (process-examples $NewDesc $Examples $FinDesc)) - (= - (object_type - (+ $Object) $Object positive) True) -; - - (= - (object_type - (- $Object) $Object negative) True) -; - - - - (= - (match - (object $OParts $ORels) - (concept $CParts $Musts $Rels $MustNots) - (+ $Missing $Extras)) - ( (list-diff $ORels $Musts - (+ Nil $RestRels)) - (short-lists (+ $Missing $Extras)) - (list-diff $OParts $CParts - (+ Nil Nil)) - (list-diff $RestRels $Rels - (+ $Missing $Extras)) - (list-diff $Extras $MustNots - (+ $MustNots $_)))) -; - + (= (object_type (+ $Object) $Object positive) True) + (= (object_type (- $Object) $Object negative) True) + + + (= (match (object $OParts $ORels) (concept $CParts $Musts $Rels $MustNots) (+ $Missing $Extras)) + (list-diff $ORels $Musts + (+ Nil $RestRels)) + (short-lists (+ $Missing $Extras)) + (list-diff $OParts $CParts + (+ Nil Nil)) + (list-diff $RestRels $Rels + (+ $Missing $Extras)) + (list-diff $Extras $MustNots + (+ $MustNots $_))) +; /******************************************************************/ +; /* */ +; /* call : match(+ObjectDesc,+ConceptDesc,-Difference) */ +; /* */ +; /* argument : ObjectDesc = description of an example */ +; /* ConceptDesc = current concept description */ +; /* Difference = term of the form: Missing + Extra */ +; /* */ +; /******************************************************************/ +; /* match matches the description of an example against the current*/ +; /* concept description and determines two lists of Missing and */ +; /* Extra descriptors. These are returned and form the basis for */ +; /* updates of the current concept description. */ +; /* Matching proceeds in the following order, first all: */ +; /* - must matches are performed, then */ +; /* - a difference template is generated */ +; /* - parts of the object and concept descriptions are matched */ +; /* - other relations are matched and */ +; /* - it is checked whether all MustNots are missing. */ +; /* On backtracking a different template is tried. */ +; /******************************************************************/ - (= - (list_diff $List () - (+ () $List)) True) -; - - (= - (list-diff $List1 - (Cons $X $List2) - (+ $Miss $Extras)) - ( (delete $List1 $List11 $X $Miss11 $Miss) (list-diff $List11 $List2 (+ $Miss11 $Extras)))) -; - + (= (list_diff $List () (+ () $List)) True) +; /******************************************************************/ +; /* */ +; /* call : list_diff(+List1,+List2,-ListDiffs) */ +; /* */ +; /* argument : List1 = list of descriptors */ +; /* List2 = list of descriptors */ +; /* ListDiffs = List2\List1 + List1\List2 */ +; /* */ +; /******************************************************************/ + (= (list-diff $List1 (Cons $X $List2) (+ $Miss $Extras)) + (delete $List1 $List11 $X $Miss11 $Miss) + (list-diff $List11 $List2 + (+ $Miss11 $Extras))) - (= - (delete () () $X $Dels - (Cons $X $Dels)) True) -; - - (= - (delete - (Cons $Y $L) $L $X $Dels $Dels) - ( (== $X $Y) (set-det))) -; - - (= - (delete - (Cons $Y $L) $L $X $Dels $Dels) + (= (delete () () $X $Dels (Cons $X $Dels)) True) +; /******************************************************************/ +; /* */ +; /* call : delete(+List1,+List2,+Descriptor,-List3,-List4) */ +; /* */ +; /* argument : List1 = list of descriptors */ +; /* List2 = list of descriptors possibly without */ +; /* Descriptor */ +; /* Descriptor= Descriptor which should be deleted */ +; /* List3 = list of descriptors with Descriptor */ +; /* deleted */ +; /* List4 = list of descriptors possibly with */ +; /* Descriptor */ +; /* */ +; /******************************************************************/ +; /* If Descriptor is deleted from List1 then List4 = List1, */ +; /* if not the List2 = List1 and List4 = [Descriptor|List3]. */ +; /* (If Descriptor is not deleted then it is missing in List.) */ +; /******************************************************************/ + (= (delete (Cons $Y $L) $L $X $Dels $Dels) + (== $X $Y) + (set-det)) + (= (delete (Cons $Y $L) $L $X $Dels $Dels) (= $X $Y)) -; - - (= - (delete - (Cons $Y $L) - (Cons $Y $L1) $X $Dels $Dels1) + (= (delete (Cons $Y $L) (Cons $Y $L1) $X $Dels $Dels1) (delete $L $L1 $X $Dels $Dels1)) -; - - (= - (short-lists (+ $L1 $L2)) - ( (append $L $_ - (:: $_ $_ $_)) (append $L1 $L2 $L))) -; - - - - (= - (update negative - (+ $_ - ($ExtraRelation)) - (concept $Parts $Musts $Rels $MustNots) - (concept $Parts $Musts $Rels - (Cons $ExtraRelation $MustNots))) True) -; - - (= + (= (short-lists (+ $L1 $L2)) + (append $L $_ + (:: $_ $_ $_)) + (append $L1 $L2 $L)) +; /******************************************************************/ +; /* */ +; /* call : short_lists(List1 + List2) */ +; /* */ +; /* argument : List1 = list of descriptors */ +; /* List2 = list of descriptors */ +; /* */ +; /******************************************************************/ +; /* short_lists generates difference templates of the form: */ +; /* List1 + List2; short lists are generated first to force finding*/ +; /* good (in the sense of short) matches, before more complex */ +; /* are tried. Templates are generated in the order: */ +; /* [] + [], [] + [_], [_] + [], [] + [_,_], [_] + [_] .... */ +; /* Each list can contain atmost 3 elements. */ +; /******************************************************************/ + + + (= (update negative (+ $_ ($ExtraRelation)) (concept $Parts $Musts $Rels $MustNots) (concept $Parts $Musts $Rels (Cons $ExtraRelation $MustNots))) True) +; /******************************************************************/ +; /* */ +; /* call : update(+TypeOfExample,+Difference,+CurrentDesc, */ +; /* -NewDesc) */ +; /* */ +; /* argument : TypeOfExample = classification of the example */ +; /* Difference = determined difference */ +; /* CurrentDesc = current concept description */ +; /* NewDesc = modified concept description */ +; /* */ +; /******************************************************************/ +; /* updates modifies the current concept description in */ +; /* correspondance to the determined difference. */ +; /* The clauses make the following: */ +; /* Clause 1: Forbid-relation rule: an extra relation in a negative*/ +; /* example must be forbidden in */ +; /* the concept description. */ +; /* Clause 2: Require-relation rule: missing relations in a */ +; /* negative example must be */ +; /* required in the concept */ +; /* description. */ +; /* Clause 3: One missing and one extra relation in a negative */ +; /* Can be handled separatly. */ +; /* Clause 4: Climb-taxonomy rule: generalize an isa-relation by */ +; /* climbing a-kind-of taxonomy. */ +; /* The ako-taxonomy represents the */ +; /* background knowledge of the */ +; /* system. */ +; /******************************************************************/ + (= (update negative (+ $Missing $_) (concept $Parts $Musts $Rels $MustNots) (concept $Parts $NewMusts $NewRels $MustNots)) + (= $Missing + (Cons $_ $_)) + (append $Missing $Musts $NewMusts) + (list-diff $Rels $Missing + (+ $_ $NewRels))) + (= (update negative (+ (:: $MissR) (:: $ExtraR)) $CurDesc $NewDesc) (update negative - (+ $Missing $_) - (concept $Parts $Musts $Rels $MustNots) - (concept $Parts $NewMusts $NewRels $MustNots)) - ( (= $Missing - (Cons $_ $_)) - (append $Missing $Musts $NewMusts) - (list-diff $Rels $Missing - (+ $_ $NewRels)))) -; - - (= + (+ Nil + (:: $ExtraR)) $CurDesc $InterDesc) (update negative (+ - (:: $MissR) - (:: $ExtraR)) $CurDesc $NewDesc) - ( (update negative - (+ Nil - (:: $ExtraR)) $CurDesc $InterDesc) (update negative (+ (:: $MissR) Nil) $InterDesc $FinDesc))) -; - - (= - (update positive - (+ - (:: (isa $Object $Class1)) - (:: (isa $Object $Class2))) - (concept $Parts $Musts $Rels $MustNots) - (concept $Parts $Musts $NewRels $MustNots)) - ( (climb $Class1 $Class) - (climb $Class2 $Class) - (set-det) - (replace - (isa $Object $Class1) $Rels - (isa $Object $Class) $NewRels))) -; - + (:: $MissR) Nil) $InterDesc $FinDesc)) + (= (update positive (+ (:: (isa $Object $Class1)) (:: (isa $Object $Class2))) (concept $Parts $Musts $Rels $MustNots) (concept $Parts $Musts $NewRels $MustNots)) + (climb $Class1 $Class) + (climb $Class2 $Class) + (set-det) + (replace + (isa $Object $Class1) $Rels + (isa $Object $Class) $NewRels)) - (= - (replace $Item $List $NewItem - (Cons $NewItem $List1)) + (= (replace $Item $List $NewItem (Cons $NewItem $List1)) (delete $List $List1 $Item $_ $_)) -; - +; /******************************************************************/ +; /* */ +; /* call : replace(+Item,+List,+NewItem,-NewList) */ +; /* */ +; /* argument : Item = descriptor */ +; /* List = list of descriptors */ +; /* NewItem = replacement descriptor */ +; /* NewList = replaced list of descriptors */ +; /* */ +; /******************************************************************/ +; /* replace removes Item from List and adds Newitem producing */ +; /* NewList. */ +; /******************************************************************/ - (= - (climb $Class $Class) True) -; - - (= - (climb $Class $SuperClass) - ( (get-symbols &self + (= (climb $Class $Class) True) +; /******************************************************************/ +; /* */ +; /* call : climb(+Class1,-Class2) */ +; /* */ +; /* argument : Class1 = Subclass */ +; /* Class2 = Superclass */ +; /* */ +; /******************************************************************/ +; /* climb climbs in a-kind-of taxonomy from Class1 to superclass */ +; /* Class2. */ +; /******************************************************************/ + (= (climb $Class $SuperClass) + ( (== (= - (ako $Class1 $Class) true)) (climb $Class1 $SuperClass))) -; - + (ako $Class1 $Class) true) + (get-atoms &self)) (climb $Class1 $SuperClass))) !(dynamic (/ found 1)) -; - - (= - (findbag $X $G $_) - ( (add-symbol &self + (= (findbag $X $G $_) + ( (add-is-symbol &self (found mark)) (call $G) - (add-symbol &self + (add-is-symbol &self (found $X)) - (fail))) -; - - (= - (findbag $_ $_ $L) - (collect-found Nil $L)) -; - + (fail))) + (= (findbag $_ $_ $L) + (collect-found Nil $L)) - (= - (collect-found $L $L1) - ( (getnext $X) (collect-found (Cons $X $L) $L1))) -; - - (= - (collect_found $L $L) True) -; - + (= (collect-found $L $L1) + (getnext $X) + (collect-found + (Cons $X $L) $L1)) + (= (collect_found $L $L) True) ; (error ; (syntax_error operator_expected) @@ -231,17 +300,12 @@ - (= - (help) - ( (write 'Load data set with command: [Filename].') - (nl) - (write 'Start arch2 with command: learn(X).') - (nl))) -; - + (= (help) + (write 'Load data set with command: [Filename].') + (nl) + (write 'Start arch2 with command: learn(X).') + (nl)) !(help *) -; - diff --git a/arch2/arch2_1.metta b/arch2/arch2_1.metta index e5d7262..9a4fb8d 100644 --- a/arch2/arch2_1.metta +++ b/arch2/arch2_1.metta @@ -1,96 +1,21 @@ - - (= - (example - (+ - (object - ($A $B $C) - ( (support $A $C) - (support $B $C) - (isa $A rectangle) - (isa $B rectangle) - (isa $C rectangle))))) True) -; - - (= - (example - (- - (object - ($A $B $C) - ( (support $A $C) - (support $B $C) - (touch $A $B) - (isa $A rectangle) - (isa $B rectangle) - (isa $C rectangle))))) True) -; - - (= - (example - (- - (object - ($A $B $C) - ( (isa $A rectangle) - (isa $B rectangle) - (isa $C rectangle))))) True) -; - - (= - (example - (+ - (object - ($A $B $C) - ( (support $A $C) - (support $B $C) - (isa $A rectangle) - (isa $B rectangle) - (isa $C triangle))))) True) -; - - - - - (= - (ako figure polygone) True) -; - - (= - (ako figure circle) True) -; - - (= - (ako polygon convex_poly) True) -; - - (= - (ako polygon concave_poly) True) -; - - (= - (ako convex_poly stable_poly) True) -; - - (= - (ako convex_poly unstable_poly) True) -; - - (= - (ako stable_poly triangle) True) -; - - (= - (ako stable_poly rectangle) True) -; - - (= - (ako stable_poly trapezium) True) -; - - (= - (ako unstable_poly unstable_triangle) True) -; - - (= - (ako unstable_poly hexagon) True) -; - +; (convert_to_metta_file arch2_1 $_207516 arch2/arch2_1.pl arch2/arch2_1.metta) + + (= (example (+ (object ($A $B $C) ((support $A $C) (support $B $C) (isa $A rectangle) (isa $B rectangle) (isa $C rectangle))))) True) + (= (example (- (object ($A $B $C) ((support $A $C) (support $B $C) (touch $A $B) (isa $A rectangle) (isa $B rectangle) (isa $C rectangle))))) True) + (= (example (- (object ($A $B $C) ((isa $A rectangle) (isa $B rectangle) (isa $C rectangle))))) True) + (= (example (+ (object ($A $B $C) ((support $A $C) (support $B $C) (isa $A rectangle) (isa $B rectangle) (isa $C triangle))))) True) + + + + (= (ako figure polygone) True) + (= (ako figure circle) True) + (= (ako polygon convex_poly) True) + (= (ako polygon concave_poly) True) + (= (ako convex_poly stable_poly) True) + (= (ako convex_poly unstable_poly) True) + (= (ako stable_poly triangle) True) + (= (ako stable_poly rectangle) True) + (= (ako stable_poly trapezium) True) + (= (ako unstable_poly unstable_triangle) True) + (= (ako unstable_poly hexagon) True) diff --git a/attdsc/attdsc.metta b/attdsc/attdsc.metta index 96f1536..0543742 100644 --- a/attdsc/attdsc.metta +++ b/attdsc/attdsc.metta @@ -1,15 +1,53 @@ +; (convert_to_metta_file attdsc $_265692 attdsc/attdsc.pl attdsc/attdsc.metta) !(op 300 xfx <==) -; - +; /******************************************************************/ +; /* ATTDSC.PRO Last Modification: Fri Jan 14 19:22:05 1994 */ +; /* Bratko's simple algorithm for attributional descriptions. */ +; /******************************************************************/ +; ; ; Copyright (c) 1990 Ivan Bratko ; +; /******************************************************************/ +; /* reimpl. by : Thomas Hoppe */ +; /* Mommsenstr. 50 */ +; /* D-10629 Berlin */ +; /* F.R.G. */ +; /* E-Mail: hoppet@cs.tu-berlin.de */ +; /* 1991 */ +; /* */ +; /* reference : Chapter 18, */ +; /* Ivan Bratko */ +; /* MeTTa */ +; /* 2nd extend edition */ +; /* Addison-Wesley, 1990 */ +; /* */ +; /* call : learn(+ClassName) */ +; /* */ +; /* argument : ClassName = name of the class, whose descrip- */ +; /* tion should be learned */ +; /* */ +; /******************************************************************/ +; /* The representation used: */ +; /* Attribute = attributes(AttributeName,ListOfPossibleValues) */ +; /* Example = example(ClassName,ListOfAttributeValues) */ +; /* AttributeValues = Attribute = Value */ +; /* */ +; /* learn induces class descriptions of the form: */ +; /* */ +; /* Class <== ListOfAttributeValues */ +; /* */ +; /* with the meaning: An object is an Class, if it fulfills the */ +; /* class description given by ListOfAttributeValues. */ +; /* */ +; /******************************************************************/ +; ; TH Sat May 29 23:45:01 1993 - Made some minor modifications !(dynamic (/ <== 2)) -; - +; /******************************************************************/ +; /* Some M-, C- and YAP-MeTTa dependent declarations. */ +; /******************************************************************/ - (= - (learn $Class) + (= (learn $Class) ( (bagof (example $ClassX $Obj) (example $ClassX $Obj) $Examples) @@ -19,62 +57,80 @@ (write <==) (nl) (writelist $Description) - (add-symbol &self + (add-is-symbol &self (<== $Class $Description)))) -; - - - (= - (learn $Examples $Class Nil) +; /******************************************************************/ +; /* */ +; /* call : learn(+Class) */ +; /* */ +; /* arguments : Class = class name to be learned */ +; /* */ +; /* side effects: asserts classification rules in the database */ +; /* */ +; /******************************************************************/ +; /* 'learn' collects all examples into a list, constructs and out- */ +; /* puts a description for Class, and asserts the corresponding */ +; /* rule about Class. */ +; /******************************************************************/ + + (= (learn $Examples $Class Nil) (not (member (example $Class $_) $Examples))) -; - - (= - (learn $Examples $Class - (Cons $Conj $Conjs)) - ( (learn-conj $Examples $Class $Conj) - (remove $Examples $Conj $RestExamples) - (learn $RestExamples $Class $Conjs))) -; - +; /******************************************************************/ +; /* */ +; /* call : learn(+Examples,+Class,-Description) */ +; /* */ +; /* arguments : Examples = list of all available examples */ +; /* Class = class name to be learned */ +; /* Description = induced concept description */ +; /* */ +; /******************************************************************/ +; /* Description covers exactly the positive examples of Class in */ +; /* list Examples. If no examples exist for Class, an empty De- */ +; /* scription is returned. After a conjunction was learned the */ +; /* examples matching the conjunction are removed from Examples */ +; /* and for remaining RestExamples a further conjunct is learned. */ +; /******************************************************************/ + (= (learn $Examples $Class (Cons $Conj $Conjs)) + (learn-conj $Examples $Class $Conj) + (remove $Examples $Conj $RestExamples) + (learn $RestExamples $Class $Conjs)) - (= - (learn-conj $Examples $Class Nil) - ( (not (, (member (example $ClassX $_) $Examples) (not (== $ClassX $Class)))) (set-det))) -; - - (= - (learn-conj $Examples $Class - (Cons $Cond $Conds)) - ( (choose-cond $Examples $Class $Cond) - (filter $Examples - (:: $Cond) $Examples1) - (learn-conj $Examples1 $Class $Conds))) -; - + (= (learn-conj $Examples $Class Nil) + (not (, (member (example $ClassX $_) $Examples) (not (== $ClassX $Class)))) + (set-det)) +; /******************************************************************/ +; /* */ +; /* call : learn_conj(+Examples,+Class,-Conj) */ +; /* */ +; /* arguments : Examples = list of all available examples */ +; /* Class = class name to be learned */ +; /* Conj = list of attribute/value pairs */ +; /* */ +; /******************************************************************/ +; /* Conj is a list of attribute/value pairs are satisfied by some */ +; /* examples of class Class and no other classes. If there is no */ +; /* other Example of a different class covered, the empty Conj is */ +; /* returned. Otherwise, we choose the best attribute/value pair */ +; /* according to the evaluation criterion used in 'score' and */ +; /* filter out all examples, that cover this attribute/value pair. */ +; /******************************************************************/ + (= (learn-conj $Examples $Class (Cons $Cond $Conds)) + (choose-cond $Examples $Class $Cond) + (filter $Examples + (:: $Cond) $Examples1) + (learn-conj $Examples1 $Class $Conds)) - (= - (choose-cond $Examples $Class $AttVal) - ( (findall - (/ $AV $Score) - (score $Examples $Class $AV $Score) $AVs) (best $AVs $AttVal))) -; - + (= (choose-cond $Examples $Class $AttVal) + (findall + (/ $AV $Score) + (score $Examples $Class $AV $Score) $AVs) + (best $AVs $AttVal)) - (= - (best - ( (/ $AttVal $_)) $AttVal) True) -; - - (= - (best - (Cons - (/ $AV0 $S0) - (Cons - (/ $AV1 $S1) $AVSlist)) $AttVal) + (= (best ((/ $AttVal $_)) $AttVal) True) + (= (best (Cons (/ $AV0 $S0) (Cons (/ $AV1 $S1) $AVSlist)) $AttVal) (or (, (> $S1 $S0) @@ -85,132 +141,144 @@ (best (Cons (/ $AV0 $S0) $AVSlist) $AttVal))) -; - - (= - (score $Examples $Class $AttVal $Score) - ( (candidate $Examples $Class $AttVal) - (filter $Examples - (:: $AttVal) $Examples1) - (length $Examples1 $N1) - (count-pos $Examples1 $Class $NPos1) - (> $NPos1 0) - (is $Score - (- - (* 2 $NPos1) $N1)))) -; - + (= (score $Examples $Class $AttVal $Score) + (candidate $Examples $Class $AttVal) + (filter $Examples + (:: $AttVal) $Examples1) + (length $Examples1 $N1) + (count-pos $Examples1 $Class $NPos1) + (> $NPos1 0) + (is $Score + (- + (* 2 $NPos1) $N1))) +; /******************************************************************/ +; /* */ +; /* call : score(+Examples,+Class,-AttVal,-Score) */ +; /* */ +; /* arguments : Examples = list of all available examples */ +; /* Class = class name to be learned */ +; /* AttVal = chosen attribute/value pair */ +; /* Score = value of AttVal */ +; /* */ +; /******************************************************************/ +; /* 'score' determines an suitable attribute/value pair, determines*/ +; /* how many examples are covered and computes a value for the */ +; /* chosen attribute/value pair. */ +; /* Remark: In the current implementation at least one example has */ +; /* to be covered. Thus, in some cases it can happen, that rules */ +; /* are generated, which cover exactly one example. Hence, we do */ +; /* not benefite from learning. This can be changed by requiring */ +; /* that at least two examples should be covered. */ +; /******************************************************************/ - (= - (candidate $Examples $Class - (= $Att $Val)) - ( (get-symbols &self + (= (candidate $Examples $Class (= $Att $Val)) + ( (== (= - (attribute $Att $Values) true)) + (attribute $Att $Values) true) + (get-atoms &self)) (member $Val $Values) (suitable (= $Att $Val) $Examples $Class))) -; - - (= - (suitable $AttVal $Examples $Class) - ( (member - (example $ClassX $ObjX) $Examples) - (not (== $ClassX $Class)) - (not (satisfy $ObjX (:: $AttVal))) - (set-det))) -; - + (= (suitable $AttVal $Examples $Class) + (member + (example $ClassX $ObjX) $Examples) + (not (== $ClassX $Class)) + (not (satisfy $ObjX (:: $AttVal))) + (set-det)) +; ; atleast one neg. example must not match AttVal - (= - (count_pos () $_ 0) True) -; - - (= - (count-pos - (Cons - (example $ClassX $_) $Examples) $Class $N) - ( (count-pos $Examples $Class $N1) (or (, (= $ClassX $Class) (set-det) (is $N (+ $N1 1))) (= $N $N1)))) -; - + (= (count_pos () $_ 0) True) +; /******************************************************************/ +; /* */ +; /* call : count_pos(+Examples,+Class,-N) */ +; /* */ +; /* arguments : Examples = list of all available examples */ +; /* Class = class name to be learned */ +; /* N = number of covered examples */ +; /* */ +; /******************************************************************/ +; /* N is the number of positive examples of Class */ +; /******************************************************************/ + (= (count-pos (Cons (example $ClassX $_) $Examples) $Class $N) + (count-pos $Examples $Class $N1) + (or + (, + (= $ClassX $Class) + (set-det) + (is $N + (+ $N1 1))) + (= $N $N1))) - (= - (filter $Examples $Cond $Examples1) + (= (filter $Examples $Cond $Examples1) (findall (example $Class $Obj) (, (member (example $Class $Obj) $Examples) (satisfy $Obj $Cond)) $Examples1)) -; - +; /******************************************************************/ +; /* */ +; /* call : filter(+Examples,+Cond,-Examples1) */ +; /* */ +; /* arguments : Examples = list of all available examples */ +; /* Cond = attribute/value pair */ +; /* Examples1 = list of examples with attr/val */ +; /* */ +; /******************************************************************/ +; /* Examples1 contains elements of Examples that satisfy Condition */ +; /******************************************************************/ - (= - (remove () $_ ()) True) -; - - (= - (remove - (Cons - (example $Class $Obj) $Es) $Conj $Es1) - ( (satisfy $Obj $Conj) - (set-det) - (remove $Es $Conj $Es1))) -; - - (= - (remove - (Cons $E $Es) $Conj - (Cons $E $Es1)) + (= (remove () $_ ()) True) +; /******************************************************************/ +; /* */ +; /* call : remove(+Examples,+Conj,-RestExamples) */ +; /* */ +; /* arguments : Examples = list of all available examples */ +; /* Conj = list of attribute/value pair */ +; /* RestExamples = list of examples not matching */ +; /* Conj */ +; /* */ +; /******************************************************************/ +; /* removing from Examples those examples that match Conj gives */ +; /* RestExamples . */ +; /******************************************************************/ + (= (remove (Cons (example $Class $Obj) $Es) $Conj $Es1) + (satisfy $Obj $Conj) + (set-det) + (remove $Es $Conj $Es1)) + (= (remove (Cons $E $Es) $Conj (Cons $E $Es1)) (remove $Es $Conj $Es1)) -; - - (= - (satisfy $Object $Conj) + (= (satisfy $Object $Conj) (not (, (member (= $Att $Val) $Conj) (member (= $Att $ValX) $Object) (not (== $ValX $Val))))) -; - - (= - (match $Object $Description) - ( (member $Conj $Description) (satisfy $Object $Conj))) -; - + (= (match $Object $Description) + (member $Conj $Description) + (satisfy $Object $Conj)) - (= - (writelist ()) True) -; - - (= - (writelist (Cons $X $L)) - ( (tab 2) - (write $X) - (nl) - (writelist $L))) -; + (= (writelist ()) True) + (= (writelist (Cons $X $L)) + (tab 2) + (write $X) + (nl) + (writelist $L)) - - (= - (help) - ( (write 'Load data set and start learning with command: [Filename].') (nl))) -; - + (= (help) + (write 'Load data set and start learning with command: [Filename].') + (nl)) !(help *) -; - diff --git a/attdsc/attdsc_1.metta b/attdsc/attdsc_1.metta index 99e35bf..8823778 100644 --- a/attdsc/attdsc_1.metta +++ b/attdsc/attdsc_1.metta @@ -1,120 +1,25 @@ - - (= - (attribute size - (small large)) True) -; - - (= - (attribute shape - (long compact other)) True) -; - - (= - (attribute holes - (none 1 2 3 many)) True) -; - - - - (= - (example nut - ( (= size small) - (= shape compact) - (= holes 1))) True) -; - - (= - (example screw - ( (= size small) - (= shape long) - (= holes none))) True) -; - - (= - (example key - ( (= size small) - (= shape long) - (= holes 1))) True) -; - - (= - (example nut - ( (= size small) - (= shape compact) - (= holes 1))) True) -; - - (= - (example key - ( (= size large) - (= shape long) - (= holes 1))) True) -; - - (= - (example screw - ( (= size small) - (= shape compact) - (= holes none))) True) -; - - (= - (example nut - ( (= size small) - (= shape compact) - (= holes 1))) True) -; - - (= - (example pen - ( (= size large) - (= shape long) - (= holes none))) True) -; - - (= - (example scissors - ( (= size large) - (= shape long) - (= holes 2))) True) -; - - (= - (example pen - ( (= size large) - (= shape long) - (= holes none))) True) -; - - (= - (example scissors - ( (= size large) - (= shape other) - (= holes 2))) True) -; - - (= - (example key - ( (= size small) - (= shape other) - (= holes 2))) True) -; - - - - (= - (?- - (learn nut)) True) -; - - (= - (?- - (learn key)) True) -; - - (= - (?- - (learn scissors)) True) -; - +; (convert_to_metta_file attdsc_1 $_448868 attdsc/attdsc_1.pl attdsc/attdsc_1.metta) + + (= (attribute size (small large)) True) + (= (attribute shape (long compact other)) True) + (= (attribute holes (none 1 2 3 many)) True) + + + (= (example nut ((= size small) (= shape compact) (= holes 1))) True) + (= (example screw ((= size small) (= shape long) (= holes none))) True) + (= (example key ((= size small) (= shape long) (= holes 1))) True) + (= (example nut ((= size small) (= shape compact) (= holes 1))) True) + (= (example key ((= size large) (= shape long) (= holes 1))) True) + (= (example screw ((= size small) (= shape compact) (= holes none))) True) + (= (example nut ((= size small) (= shape compact) (= holes 1))) True) + (= (example pen ((= size large) (= shape long) (= holes none))) True) + (= (example scissors ((= size large) (= shape long) (= holes 2))) True) + (= (example pen ((= size large) (= shape long) (= holes none))) True) + (= (example scissors ((= size large) (= shape other) (= holes 2))) True) + (= (example key ((= size small) (= shape other) (= holes 2))) True) + + + (= (?- (learn nut)) True) + (= (?- (learn key)) True) + (= (?- (learn scissors)) True) diff --git a/cobweb/cobweb.metta b/cobweb/cobweb.metta index b52d8e2..72db867 100644 --- a/cobweb/cobweb.metta +++ b/cobweb/cobweb.metta @@ -1,657 +1,711 @@ +; (convert_to_metta_file cobweb $_11954 cobweb/cobweb.pl cobweb/cobweb.metta) !(dynamic (/ root 2)) -; - +; /******************************************************************/ +; /* cobweb.pro Last modification: Fri Jan 14 19:32:01 1994 */ +; /* Gennari's incremental concept formation algorithm */ +; /******************************************************************/ +; ; ; Copyright (c) 1989 Joerg-Uwe Kietz ; ; This program is free software; you can redistribute it and/or ; modify it under the terms of the GNU General Public License ; Version 1 as published by the Free Software Foundation. ; ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; ; You should have received a copy of the GNU General Public ; Licensealong with this program; if not, write to the Free ; SoftwareFoundation, Inc., 675 Mass Ave, Cambridge, MA 02139, ; USA. ; +; /******************************************************************/ +; /* impl. by : Joerg-Uwe Kietz */ +; /* F3-XPS */ +; /* Gesellschaft fuer Mathematik und Datenver- */ +; /* arbeitung */ +; /* Schloss Birlinghoven */ +; /* 5201 St. Augustin 1 */ +; /* E-Mail: kietz@gmdzi.gmd.de */ +; /* 1989 */ +; /* */ +; /* reference : Gennari, J.H., Langley, P., Fisher, D. */ +; /* Models of Incremental Concept Formation */ +; /* Artifical Intelligence, Vol 40, pp. 11-61, */ +; /* 1989 */ +; /* */ +; /* correction : There is a bracket around the subtraction of */ +; /* the two double sums missing in formula (3) on */ +; /* p. 35. */ +; /* In the case of Split-Node is the best, the call */ +; /* cobweb(N,I) leads to double incorporation of I */ +; /* into Node N. */ +; /* */ +; /* call : learn */ +; /* */ +; /* parameter : acuity/1 asserted in the dynamic DB allows to */ +; /* vary the acuity parameter (default is 0). It */ +; /* should be a real between 0 and 1. */ +; /* */ +; /* side effects: assertz and retracts clauses, hence not very */ +; /* efficient. Even less efficient, if MeTTa */ +; /* dialect does not support first arg indexing. */ +; /* If a more efficient implementation (avoiding */ +; /* assert/retract) is needed, try to contact Kietz */ +; /* directly. */ +; /* */ +; /* restrictions: MeTTa-dialect must allow real arithmetic. */ +; /* */ +; /******************************************************************/ +; ; TH: Sat May 29 16:19:01 1993 prettyfied output ; corrected bug in cobweb_3.pl ; Sat Jan 8 11:33:49 1994 removed incompatible predicate ; Fri Jan 14 17:31:36 1994 avoidance of rounding errors ; better handling of 'acuity' +; /******************************************************************/ +; /* SWI-, YAP-, C- and M-MeTTa specific declaration of dynamical */ +; /* clauses. */ +; /******************************************************************/ !(dynamic (/ root 4)) -; - !(dynamic (/ node 3)) -; - !(dynamic (/ d-sub 2)) -; - !(dynamic (/ gensym-counter 2)) -; - !(dynamic (/ prediction-counter 2)) -; - !(dynamic (/ features 1)) -; - !(dynamic (/ case 1)) -; - !(dynamic (/ acuity 1)) -; - - - (= - (learn) - ( (initialize) - (get-case $X) - (cobweb $X) - (nl) - (nl) - (show-classes) - (fail))) -; - - (= learn True) -; + (= (learn) + (initialize) + (get-case $X) + (cobweb $X) + (nl) + (nl) + (show-classes) + (fail)) +; /******************************************************************/ +; /* QUINTUS MeTTa specific import of predicates `sqrt' and `abs' */ +; /******************************************************************/ +; ;:- use_module(library(math),[sqrt/2,abs/2]). +; /******************************************************************/ +; /* */ +; /* call : learn */ +; /* */ +; /* side effects: assertz and retracts clauses */ +; /* */ +; /* restrictions: MeTTa-dialect must allow real arithmetric. */ +; /* */ +; /******************************************************************/ +; /* With the predicate 'learn' the cobweb algorithm is called in */ +; /* batch mode. In this mode the data have to be present at call- */ +; /* time in the internal database. They have to follow the format */ +; /* shown in the example file. Because, cobweb is an incremental */ +; /* concept formation system it retrieves first a datum from the */ +; /* database (in MeTTa's processing order) and integrates it in a */ +; /* growing concept tree. Before the learning process starts the */ +; /* internal concept tree data structure is initialized. The */ +; /* concept tree is asserted and modified at runtime. */ +; /******************************************************************/ + (= learn True) - (= - (initialize) - ( (abolish node 3) - (abolish d-sub 2) - (abolish root 2) - (abolish root 4) - (abolish prediction-counter 2) - (abolish gensym-counter 2) - (set-det))) -; - - - - (= - (learn-more) - ( (get-case $X) - (cobweb $X) - (fail))) -; - - (= learn_more True) -; - - - - (= - (nmember $E - (Cons $E $L) 1) True) -; + (= (initialize) + (abolish node 3) + (abolish d-sub 2) + (abolish root 2) + (abolish root 4) + (abolish prediction-counter 2) + (abolish gensym-counter 2) + (set-det)) - (= - (nmember $E - (Cons $_ $R) $P1) - ( (nmember $E $R $P) (is $P1 (+ $P 1)))) -; + (= (learn-more) + (get-case $X) + (cobweb $X) + (fail)) +; /******************************************************************/ +; /* */ +; /* call : learn_more */ +; /* */ +; /* side effects: assertz and retracts clauses */ +; /* */ +; /******************************************************************/ +; /* With the predicate 'learn_more' the cobweb algorithm is called */ +; /* in batch mode. In this mode the data have to be present at */ +; /* call-time in the internal database. They have to follow the */ +; /* format shown in the example file. Because, cobweb is an */ +; /* incremental concept formation system it retrieves first a */ +; /* datum from the database (in MeTTa's processing order) and */ +; /* integrates it in a growing concept tree. The data structure of */ +; /* the internal concept tree data structure is not initialized, */ +; /* thus allowing to process large datasets in smaller parts. The */ +; /* concept tree is asserted and modified at runtime. The user has */ +; /* to take care that the dataset is erased after each batch run, */ +; /* to avoid that data are processed twice. */ +; /******************************************************************/ + (= learn_more True) + + + (= (nmember $E (Cons $E $L) 1) True) +; /******************************************************************/ +; /* QUINTUS MeTTa specific import of predicates `nth1' and */ +; /* `nmember'. `nth1' for getting the nth-element of a list and */ +; /* `nmember' for getting a member as well as its position. */ +; /******************************************************************/ +; ; :- use_module(library(lists),[nth1/3,nmember/3]). + (= (nmember $E (Cons $_ $R) $P1) + (nmember $E $R $P) + (is $P1 + (+ $P 1))) - (= - (nth1 1 - (Cons $X $_) $X) True) -; - - (= - (nth1 $P1 - (Cons $_ $R) $X) - ( (> $P1 1) - (is $P - (- $P1 1)) - (nth1 $P $R $X))) -; + (= (nth1 1 (Cons $X $_) $X) True) + (= (nth1 $P1 (Cons $_ $R) $X) + (> $P1 1) + (is $P + (- $P1 1)) + (nth1 $P $R $X)) + + + (= (get-case $CaseID) + (case (Cons $CaseID $_)) + (nl) + (nl) + (write ' Processing case ') + (write $CaseID) + (write ...)) +; /******************************************************************/ +; /* */ +; /* call : get_case(+Case) */ +; /* */ +; /* arguments : Case = unique case identificator */ +; /* */ +; /******************************************************************/ +; /* This is a new version of get_case/1 called by COBWEB. This */ +; /* version is independent from the data set. Using this version */ +; /* one can change the data-set (i.e consult a different data file)*/ +; /* without changing the access operations (especially the number */ +; /* of arguments) */ +; /******************************************************************/ + + + (= (get-case-feature $CaseId $Type (:: $Feature $Val)) + (case (Cons $CaseId $CaseDescription)) + (features $FeatureDescription) + (nmember + (:: $Type $Feature) $FeatureDescription $Pos) + (nth1 $Pos $CaseDescription $Val)) +; /******************************************************************/ +; /* */ +; /* call : get_case_features(+Case,+Type,-AttVall) */ +; /* */ +; /* arguments : Case = unique case identificator */ +; /* Type = type description of value */ +; /* AttVal = Attribute-Value Pair */ +; /* */ +; /******************************************************************/ +; /* This is a new version of get_case_features/3 called by COBWEB. */ +; /* This version is independent from the data set. Using this */ +; /* version one can change the data-set (i.e consult a different */ +; /* case file) without changing the access operations (especially */ +; /* the number of arguments) */ +; /******************************************************************/ +; ; backtrack through all feature description and +; ; get corresponding feature value - - (= - (get-case $CaseID) - ( (case (Cons $CaseID $_)) - (nl) - (nl) - (write ' Processing case ') - (write $CaseID) - (write ...))) -; - - - - (= - (get-case-feature $CaseId $Type - (:: $Feature $Val)) - ( (case (Cons $CaseId $CaseDescription)) - (features $FeatureDescription) - (nmember - (:: $Type $Feature) $FeatureDescription $Pos) - (nth1 $Pos $CaseDescription $Val))) -; - - - - (= - (cobweb $Case) - ( (not (get-node $_)) - (init-node) - (node $Root root 1 1) - (new-node-from-case $Case $Root) - (assert-node $Root) - (msgs (:: nl ' Root initialized with case: ' $Root)) - (set-det))) -; - - (= - (cobweb $Case) - ( (node $OldRoot root 1 1) - (remove-node $OldRoot) - (set-det) - (copy-node-to-new-node $OldRoot $New) - (node $New $_ 1 1) - (assert-node $New) - (msgs (:: nl ' Root node: ' $OldRoot ' used as new terminal node: ' $New)) - (assert-d-sub $OldRoot $New) - (new-node-from-case $Case $New2) - (node $New2 $_ 1 1) - (assert-node $New2) - (msgs (:: nl ' Case ' $Case ' becomes new terminal ' $New2)) - (assert-d-sub $OldRoot $New2) - (incorporate-case-into-node $Case $OldRoot) - (node $NewRoot root 2 $_) - (assert-node $NewRoot) - (msgs (:: nl ' Root changed to: ' $NewRoot)) - (set-det))) -; - - (= - (cobweb $Case) - ( (node-name $OldRoot root) - (remove-node $OldRoot) - (set-det) - (incorporate-case-into-node $Case $OldRoot) - (node-objects $OldRoot $Objects) - (is $NewObjects - (+ $Objects 1)) - (node $NewRoot root $NewObjects $_) - (assert-node $NewRoot) - (msgs (:: nl ' Root changed to: ' $NewRoot)) - (cobweb $NewRoot $Case) - (set-det))) -; - - - (= - (cobweb none $_) True) -; - - (= - (cobweb $Parent $Case) - ( (best-child $Parent $Case $Best $IBest $Next $DoneRest $RestPred $PartSize $IncPrediction) - (set-det) - (new-child $Parent $Case $Best $Next $RestPred $PartSize $New $NewPrediction) - (set-det) - (merge-child $Parent $Case $Best $Next $RestPred $PartSize $Merge $MergePrediction) - (set-det) - (split-child $Parent $Case $Best $IBest $Next $DoneRest $RestPred $PartSize $SplitPrediction) - (set-det) - (max-of - (:: $IncPrediction $NewPrediction $MergePrediction $SplitPrediction) $BestPrediction) - (set-det) + (= (cobweb $Case) + (not (get-node $_)) + (init-node) + (node $Root root 1 1) + (new-node-from-case $Case $Root) + (assert-node $Root) + (msgs (:: nl ' Root initialized with case: ' $Root)) + (set-det)) +; /******************************************************************/ +; /* */ +; /* call : cobweb(+Case) */ +; /* */ +; /* arguments : Case = unique case identificator */ +; /* */ +; /* side effects: assertz and retracts clauses */ +; /* */ +; /******************************************************************/ +; /* cobweb processes a case always completely. The case identifi- */ +; /* cator is used as pointer to the case. Every case must have a */ +; /* unique case identificator, accessible over the predicate */ +; /* get_case(Case). The three cases of asserting a case as initial */ +; /* root node, as new terminal node in the tree, or integrating */ +; /* the case into a node and processing the subtree's are handled. */ +; /******************************************************************/ +; ; if the tree is empty +; ; generate root from Case + (= (cobweb $Case) + (node $OldRoot root 1 1) + (remove-node $OldRoot) + (set-det) + (copy-node-to-new-node $OldRoot $New) + (node $New $_ 1 1) + (assert-node $New) + (msgs (:: nl ' Root node: ' $OldRoot ' used as new terminal node: ' $New)) + (assert-d-sub $OldRoot $New) + (new-node-from-case $Case $New2) + (node $New2 $_ 1 1) + (assert-node $New2) + (msgs (:: nl ' Case ' $Case ' becomes new terminal ' $New2)) + (assert-d-sub $OldRoot $New2) + (incorporate-case-into-node $Case $OldRoot) + (node $NewRoot root 2 $_) + (assert-node $NewRoot) + (msgs (:: nl ' Root changed to: ' $NewRoot)) + (set-det)) +; ; if root is terminal: +; ; first, make a copy of root +; ; second, make a node of Case +; ; third, incorporate Case into root + (= (cobweb $Case) + (node-name $OldRoot root) + (remove-node $OldRoot) + (set-det) + (incorporate-case-into-node $Case $OldRoot) + (node-objects $OldRoot $Objects) + (is $NewObjects + (+ $Objects 1)) + (node $NewRoot root $NewObjects $_) + (assert-node $NewRoot) + (msgs (:: nl ' Root changed to: ' $NewRoot)) + (cobweb $NewRoot $Case) + (set-det)) +; ; if root is not terminal: +; ; first, incorporate Case into root +; ; second, compute new subtree + + (= (cobweb none $_) True) + (= (cobweb $Parent $Case) + (best-child $Parent $Case $Best $IBest $Next $DoneRest $RestPred $PartSize $IncPrediction) + (set-det) + (new-child $Parent $Case $Best $Next $RestPred $PartSize $New $NewPrediction) + (set-det) + (merge-child $Parent $Case $Best $Next $RestPred $PartSize $Merge $MergePrediction) + (set-det) + (split-child $Parent $Case $Best $IBest $Next $DoneRest $RestPred $PartSize $SplitPrediction) + (set-det) + (max-of + (:: $IncPrediction $NewPrediction $MergePrediction $SplitPrediction) $BestPrediction) + (set-det) + (or + (, + (= $BestPrediction $IncPrediction) + (do-incorp $IBest $Best $Merge $New $Case $NewParent)) (or (, - (= $BestPrediction $IncPrediction) - (do-incorp $IBest $Best $Merge $New $Case $NewParent)) + (= $BestPrediction $SplitPrediction) + (do-split $Best $IBest $New $Merge $Parent $NewParent)) (or (, - (= $BestPrediction $SplitPrediction) - (do-split $Best $IBest $New $Merge $Parent $NewParent)) - (or - (, - (= $BestPrediction $MergePrediction) - (do-merge $Best $Next $Merge $Parent $IBest $New $NewParent)) - (, - (= $BestPrediction $NewPrediction) - (do-new $Parent $New $IBest $Merge $NewParent))))) - (set-det) - (cobweb $NewParent $Case))) -; - - - - (= - (do-incorp $IBest $Best $Merge $New $Case $NewParent) - ( (msgs (:: nl ' Incorporating case ' $Case ' into node: ' $IBest)) - (move-subs $Best $IBest) - (delete-node $Merge) - (delete-node $New) - (if - (terminal-node $Best) - (, - (ins-node $IBest $Best Nil) - (msgs (:: nl ' using old node: ' $Best ' as terminal node.')) - (new-node-from-case $Case $New2) - (node $New2 $_ 1 1) - (assert-node $New2) - (msgs (:: nl ' New terminal node: ' $New2)) - (ins-node $IBest $New2 Nil) - (= $NewParent none)) - (, - (delete-node $Best) - (= $NewParent $IBest))))) -; - - - - (= - (do-split $Best $IBest $New $Merge $Parent $Parent) - ( (msgs (:: nl ' Case splits node: ' $Best)) - (delete-node $Best) - (delete-node $IBest) - (delete-node $New) - (delete-node $Merge))) -; - - - - (= - (do-merge $Best $Next $Merge $Parent $IBest $New $Merge) - ( (msgs (:: nl ' Case merges nodes: ' $Best ' and ' $Next nl ' into ' $Merge)) - (ins-node $Parent $Merge - (:: $Best $Next)) - (delete-node $IBest) - (delete-node $New))) -; - - - - (= - (do-new $Parent $New $IBest $Merge none) - ( (ins-node $Parent $New Nil) - (msgs (:: nl ' New terminal node: ' $New)) - (delete-node $IBest) - (delete-node $Merge))) -; - - - - (= - (best-child $Parent $Case $Best $IBest $Next $DoneRest $RestPred $PartSize $IncPrediction) - ( (findall $Child - (get-d-sub $Parent $Child) - (Cons $C1 - (Cons $C2 $DoRest))) - (length - (Cons $C1 - (Cons $C2 $DoRest)) $PartSize) - (copy-and-inc $C1 $Case $IC1) - (copy-and-inc $C2 $Case $IC2) - (compare-partitions $C1 $IC1 $C2 $IC2 $DoRest Nil $Parent $First $IFirst $Second $ISecond $FirstRestP) - (set-det) - (best-childs $Parent $Case $DoRest Nil $First $IFirst $Second $ISecond $FirstRestP $Best $IBest $Next $DoneRest $RestPred) - (sum-score - (:: $IBest) - (:: $Next) $Parent $RestPred $IncScore) - (node-prediction $Parent $NormPrediction) - (is $IncPrediction - (/ - (- $IncScore $NormPrediction) $PartSize)))) -; - - - - (= - (best-childs $_ $_ Nil $DoneRest $Best $IBest $Next $INext $RestP $Best $IBest $Next $DoneRest $RestP) - ( (delete-node $INext) (set-det))) -; - - (= - (best-childs $Parent $Case - (Cons $Try $DoRest) $DoneRest $First $IFirst $Second $ISecond $FirstRestP $Best $IBest $Next $NewDoneRest $RestP) - ( (copy-and-inc $Try $Case $ITry) (if (compare-partitions $Second $ISecond $Try $ITry $DoRest (Cons $First $DoneRest) $Parent $Second $ISecond $Try $ITry $_) (, (delete-node $ITry) (best-childs $Parent $Case $DoRest (Cons $Try $DoneRest) $First $IFirst $Second $ISecond $FirstRestP $Best $IBest $Next $NewDoneRest $RestP)) (, (delete-node $ISecond) (compare-partitions $First $IFirst $Try $ITry $DoRest (Cons $Second $DoneRest) $Parent $NFirst $NIFirst $NSecond $NISecond $NFirstRestP) (set-det) (best-childs $Parent $Case $DoRest (Cons $Second $DoneRest) $NFirst $NIFirst $NSecond $NISecond $NFirstRestP $Best $IBest $Next $NewDoneRest $RestP))))) -; - - - - (= - (new-child $Parent $Case $Best $Next $RestPred $PartSize $New $NewPrediction) - ( (new-node-from-case $Case $New) - (node $New $_ 1 1) - (assert-node $New) - (sum-score - (:: $New) - (:: $Best $Next) $Parent $RestPred $NewPredictionSum) - (node-prediction $Parent $NormPrediction) - (is $NewPrediction - (/ - (- $NewPredictionSum $NormPrediction) - (+ $PartSize 1))) - (set-det))) -; - - + (= $BestPrediction $MergePrediction) + (do-merge $Best $Next $Merge $Parent $IBest $New $NewParent)) + (, + (= $BestPrediction $NewPrediction) + (do-new $Parent $New $IBest $Merge $NewParent))))) + (set-det) + (cobweb $NewParent $Case)) +; ; Correction of the reference: In the case of Split-Node is the best, +; ; The call cobweb(N,I) leads to double incorporating I into Node N. + + + (= (do-incorp $IBest $Best $Merge $New $Case $NewParent) + (msgs (:: nl ' Incorporating case ' $Case ' into node: ' $IBest)) + (move-subs $Best $IBest) + (delete-node $Merge) + (delete-node $New) + (if + (terminal-node $Best) + (, + (ins-node $IBest $Best Nil) + (msgs (:: nl ' using old node: ' $Best ' as terminal node.')) + (new-node-from-case $Case $New2) + (node $New2 $_ 1 1) + (assert-node $New2) + (msgs (:: nl ' New terminal node: ' $New2)) + (ins-node $IBest $New2 Nil) + (= $NewParent none)) + (, + (delete-node $Best) + (= $NewParent $IBest)))) +; ; if Best is a terminal node we have the case from the paper, +; ; where N is terminal before incorporating the new case. +; ; first: make Best to an subnode of IBest +; ; second: generate a new terminal node from Case +; ; and make it to an subnode of IBest, too +; ; than all is done, because Best and NewNode2 are terminal. + + + (= (do-split $Best $IBest $New $Merge $Parent $Parent) + (msgs (:: nl ' Case splits node: ' $Best)) + (delete-node $Best) + (delete-node $IBest) + (delete-node $New) + (delete-node $Merge)) +; ; The next call also copies the d_subs from Best to Parent + + + (= (do-merge $Best $Next $Merge $Parent $IBest $New $Merge) + (msgs (:: nl ' Case merges nodes: ' $Best ' and ' $Next nl ' into ' $Merge)) + (ins-node $Parent $Merge + (:: $Best $Next)) + (delete-node $IBest) + (delete-node $New)) +; ; Possible optimization: +; ; We could remember that Best is the best_child for +; ; incorporate and Next is the second best, RestP = 0, ..., +; ; i.e. we already know what best_child will produce in the +; ; next recursion. + + + (= (do-new $Parent $New $IBest $Merge none) + (ins-node $Parent $New Nil) + (msgs (:: nl ' New terminal node: ' $New)) + (delete-node $IBest) + (delete-node $Merge)) +; ; all is done, because New is terminal. + + + (= (best-child $Parent $Case $Best $IBest $Next $DoneRest $RestPred $PartSize $IncPrediction) + (findall $Child + (get-d-sub $Parent $Child) + (Cons $C1 + (Cons $C2 $DoRest))) + (length + (Cons $C1 + (Cons $C2 $DoRest)) $PartSize) + (copy-and-inc $C1 $Case $IC1) + (copy-and-inc $C2 $Case $IC2) + (compare-partitions $C1 $IC1 $C2 $IC2 $DoRest Nil $Parent $First $IFirst $Second $ISecond $FirstRestP) + (set-det) + (best-childs $Parent $Case $DoRest Nil $First $IFirst $Second $ISecond $FirstRestP $Best $IBest $Next $DoneRest $RestPred) + (sum-score + (:: $IBest) + (:: $Next) $Parent $RestPred $IncScore) + (node-prediction $Parent $NormPrediction) + (is $IncPrediction + (/ + (- $IncScore $NormPrediction) $PartSize))) - (= - (merge-child $Parent $Case $Best $Next $RestPred 2 $Merge -10000) - ( (new-node $Merge) - (assert-node $Merge) - (set-det))) -; - - (= - (merge-child $Parent $Case $Best $Next $RestPred $PartSize $Merge $MergePrediction) - ( (copy-node-to-new-node $Best $Merge) - (merge-node-into-node $Next $Merge) - (incorporate-case-into-node $Case $Merge) - (node-objects $Best $BestO) - (node-objects $Next $NextO) - (is $MergeObjects - (+ - (+ $BestO $NextO) 1)) - (node-objects $Merge $MergeObjects) - (compute-prediction $Merge) - (assert-node $Merge) - (sum-score - (:: $Merge) Nil $Parent $RestPred $MergePredictionSum) - (node-prediction $Parent $NormPrediction) - (is $MergePrediction - (/ - (- $MergePredictionSum $NormPrediction) - (- $PartSize 1))) - (set-det))) -; + (= (best-childs $_ $_ Nil $DoneRest $Best $IBest $Next $INext $RestP $Best $IBest $Next $DoneRest $RestP) + (delete-node $INext) + (set-det)) + (= (best-childs $Parent $Case (Cons $Try $DoRest) $DoneRest $First $IFirst $Second $ISecond $FirstRestP $Best $IBest $Next $NewDoneRest $RestP) + (copy-and-inc $Try $Case $ITry) + (if + (compare-partitions $Second $ISecond $Try $ITry $DoRest + (Cons $First $DoneRest) $Parent $Second $ISecond $Try $ITry $_) + (, + (delete-node $ITry) + (best-childs $Parent $Case $DoRest + (Cons $Try $DoneRest) $First $IFirst $Second $ISecond $FirstRestP $Best $IBest $Next $NewDoneRest $RestP)) + (, + (delete-node $ISecond) + (compare-partitions $First $IFirst $Try $ITry $DoRest + (Cons $Second $DoneRest) $Parent $NFirst $NIFirst $NSecond $NISecond $NFirstRestP) + (set-det) + (best-childs $Parent $Case $DoRest + (Cons $Second $DoneRest) $NFirst $NIFirst $NSecond $NISecond $NFirstRestP $Best $IBest $Next $NewDoneRest $RestP)))) +; ; Try is weaker than our Second, +; ; Delete ITry from memory +; ; put Try to done, use the old Results +; ; Try is stronger than our Second, +; ; Delete ISecond from memory, put Second to done +; ; compare Try with First, use the new Results + + + (= (new-child $Parent $Case $Best $Next $RestPred $PartSize $New $NewPrediction) + (new-node-from-case $Case $New) + (node $New $_ 1 1) + (assert-node $New) + (sum-score + (:: $New) + (:: $Best $Next) $Parent $RestPred $NewPredictionSum) + (node-prediction $Parent $NormPrediction) + (is $NewPrediction + (/ + (- $NewPredictionSum $NormPrediction) + (+ $PartSize 1))) + (set-det)) +; ; Prediction from New is equal to 1 + (= (merge-child $Parent $Case $Best $Next $RestPred 2 $Merge -10000) + (new-node $Merge) + (assert-node $Merge) + (set-det)) + (= (merge-child $Parent $Case $Best $Next $RestPred $PartSize $Merge $MergePrediction) + (copy-node-to-new-node $Best $Merge) + (merge-node-into-node $Next $Merge) + (incorporate-case-into-node $Case $Merge) + (node-objects $Best $BestO) + (node-objects $Next $NextO) + (is $MergeObjects + (+ + (+ $BestO $NextO) 1)) + (node-objects $Merge $MergeObjects) + (compute-prediction $Merge) + (assert-node $Merge) + (sum-score + (:: $Merge) Nil $Parent $RestPred $MergePredictionSum) + (node-prediction $Parent $NormPrediction) + (is $MergePrediction + (/ + (- $MergePredictionSum $NormPrediction) + (- $PartSize 1))) + (set-det)) +; ; first, copy BestNode Attributes to MergeNode +; ; second, merge NextNode Attributes into MergeNode +; ; third, incorporate Case into MergeNode +; ; compute the rest of MergeNode +; ; completed W.E. - (= - (split-child $Parent $Case $Best $IBest $Next $DoneRest $RestPred $PartSize -10000) - ( (terminal-node $Best) (set-det))) -; - (= - (split-child $Parent $Case $Best $IBest $Next $DoneRest $RestPred $PartSize $SplitPrediction) - ( (findall $Child - (get-d-sub $Best $Child) - (Cons $C1 $DoRest)) - (length - (Cons $C1 $DoRest) $CPartSize) - (copy-and-inc $C1 $Case $IC1) - (copy-and-inc $Next $Case $INext) - (compare-partitions $C1 $IC1 $Next $INext $DoRest $DoneRest $Parent $First $IFirst $Second $ISecond $FirstRestP) - (set-det) - (best-childs $Parent $Case $DoRest $DoneRest $First $IFirst $Second $ISecond $FirstRestP $CBest $CIBest $CNext $_ $RPred) - (sum-score - (:: $CIBest) - (:: $CNext) $Parent $RPred $SplitPredictionSum) - (node-prediction $Parent $NormPrediction) - (is $SplitPrediction - (/ - (- $SplitPredictionSum $NormPrediction) - (- - (+ $PartSize $CPartSize) 1))) - (delete-node $CIBest) - (set-det))) -; + (= (split-child $Parent $Case $Best $IBest $Next $DoneRest $RestPred $PartSize -10000) + (terminal-node $Best) + (set-det)) +; ; we cannot split Best if it is terminal + (= (split-child $Parent $Case $Best $IBest $Next $DoneRest $RestPred $PartSize $SplitPrediction) + (findall $Child + (get-d-sub $Best $Child) + (Cons $C1 $DoRest)) + (length + (Cons $C1 $DoRest) $CPartSize) + (copy-and-inc $C1 $Case $IC1) + (copy-and-inc $Next $Case $INext) + (compare-partitions $C1 $IC1 $Next $INext $DoRest $DoneRest $Parent $First $IFirst $Second $ISecond $FirstRestP) + (set-det) + (best-childs $Parent $Case $DoRest $DoneRest $First $IFirst $Second $ISecond $FirstRestP $CBest $CIBest $CNext $_ $RPred) + (sum-score + (:: $CIBest) + (:: $CNext) $Parent $RPred $SplitPredictionSum) + (node-prediction $Parent $NormPrediction) + (is $SplitPrediction + (/ + (- $SplitPredictionSum $NormPrediction) + (- + (+ $PartSize $CPartSize) 1))) + (delete-node $CIBest) + (set-det)) +; ; best_child of the partition resulting from split +; ; (i.e. best of: Parent-Childs union Best-Childs without Best) - (= - (compare-partitions $C1 $IC1 $C2 $IC2 $DoRest $DoneRest $Parent $First $IFirst $Second $ISecond $RestP) - ( (sum-score $DoRest $DoneRest $Parent 0 $RestP) - (sum-score - (:: $C1) - (:: $IC2) $Parent $RestP $IC2_Score) - (sum-score - (:: $IC1) - (:: $C2) $Parent $RestP $IC1_Score) - (det-if-then-else - (> $IC2_Score $IC1_Score) - (, - (= $First $C2) - (= $IFirst $IC2) - (= $Second $C1) - (= $ISecond $IC1)) - (, - (= $First $C1) - (= $IFirst $IC1) - (= $Second $C2) - (= $ISecond $IC2))) - (set-det))) -; - - - - (= - (copy-and-inc $Node $Case $INode) - ( (new-node $INode) - (set-det) - (copy-node-to-new-node $Node $INode) - (incorporate-case-into-node $Case $INode) - (node-objects $Node $Objects) - (is $IObjects - (+ $Objects 1)) - (node-objects $INode $IObjects) - (compute-prediction $INode) - (assert-node $INode) - (set-det))) -; - - - - (= - (merge-node-into-node $Node $MergeNode) - ( (or - (, - (get-node-nominal-attr $Node $Attr $ValuesCounter) - (if - (, - (remove-node-nominal-attr $MergeNode $Attr $MergeValuesCounter) - (sum-value-counter $ValuesCounter $MergeValuesCounter $NewValuesCounter) - (assert-node-nominal-attr $MergeNode $Attr $NewValuesCounter)) fail)) True) - (or - (, - (get-node-numeric-attr $Node $Attr $N $SumXiPow2 $SumXi) - (if - (, - (remove-node-numeric-attr $MergeNode $Attr $MergeN $MergeSumXiPow2 $MergeSumXi) - (is $NewN - (+ $N $MergeN)) - (is $NewSumXiPow2 - (+ $SumXiPow2 $MergeSumXiPow2)) - (is $NewSumXi - (+ $SumXi $MergeSumXi)) - (assert-node-numeric-attr $MergeNode $Attr $NewN $NewSumXiPow2 $NewSumXi)) fail)) True) - (set-det))) -; - - + (= (compare-partitions $C1 $IC1 $C2 $IC2 $DoRest $DoneRest $Parent $First $IFirst $Second $ISecond $RestP) + (sum-score $DoRest $DoneRest $Parent 0 $RestP) + (sum-score + (:: $C1) + (:: $IC2) $Parent $RestP $IC2_Score) + (sum-score + (:: $IC1) + (:: $C2) $Parent $RestP $IC1_Score) + (det-if-then-else + (> $IC2_Score $IC1_Score) + (, + (= $First $C2) + (= $IFirst $IC2) + (= $Second $C1) + (= $ISecond $IC1)) + (, + (= $First $C1) + (= $IFirst $IC1) + (= $Second $C2) + (= $ISecond $IC2))) + (set-det)) +; /******************************************************************/ +; /* compare_partitions */ +; /******************************************************************/ + + + (= (copy-and-inc $Node $Case $INode) + (new-node $INode) + (set-det) + (copy-node-to-new-node $Node $INode) + (incorporate-case-into-node $Case $INode) + (node-objects $Node $Objects) + (is $IObjects + (+ $Objects 1)) + (node-objects $INode $IObjects) + (compute-prediction $INode) + (assert-node $INode) + (set-det)) +; /******************************************************************/ +; /* basic node operations */ +; /******************************************************************/ +; ; first, copy all Node Attributes to INode +; ; second, incorporate Case into INode - (= - (new-node-from-case $Case $Node) - ( (new-node $Node) - (or - (, - (get-case-feature $Case nominal - (:: $Attr $Val)) - (if - (assert-node-nominal-attr $Node $Attr - (:: (- $Val 1))) fail)) True) - (or - (, - (get-case-feature $Case numeric - (:: $Attr $Val)) - (if - (, - (is $SumXiPow2 - (* $Val $Val)) - (assert-node-numeric-attr $Node $Attr 1 $SumXiPow2 $Val)) fail)) True) - (set-det))) -; + (= (merge-node-into-node $Node $MergeNode) + (or + (, + (get-node-nominal-attr $Node $Attr $ValuesCounter) + (if + (, + (remove-node-nominal-attr $MergeNode $Attr $MergeValuesCounter) + (sum-value-counter $ValuesCounter $MergeValuesCounter $NewValuesCounter) + (assert-node-nominal-attr $MergeNode $Attr $NewValuesCounter)) fail)) True) + (or + (, + (get-node-numeric-attr $Node $Attr $N $SumXiPow2 $SumXi) + (if + (, + (remove-node-numeric-attr $MergeNode $Attr $MergeN $MergeSumXiPow2 $MergeSumXi) + (is $NewN + (+ $N $MergeN)) + (is $NewSumXiPow2 + (+ $SumXiPow2 $MergeSumXiPow2)) + (is $NewSumXi + (+ $SumXi $MergeSumXi)) + (assert-node-numeric-attr $MergeNode $Attr $NewN $NewSumXiPow2 $NewSumXi)) fail)) True) + (set-det)) +; /******************************************************************/ +; /* basic node attribute operations */ +; /******************************************************************/ - (= - (copy-node-to-new-node $Node $NewNode) - ( (new-node $NewNode) - (or - (, - (get-node-nominal-attr $Node $Attr $ValuesCounter) - (if - (assert-node-nominal-attr $NewNode $Attr $ValuesCounter) fail)) True) - (or - (, - (get-node-numeric-attr $Node $Attr $N $SumXiPow2 $SumXi) - (if - (assert-node-numeric-attr $NewNode $Attr $N $SumXiPow2 $SumXi) fail)) True) - (set-det))) -; + (= (new-node-from-case $Case $Node) + (new-node $Node) + (or + (, + (get-case-feature $Case nominal + (:: $Attr $Val)) + (if + (assert-node-nominal-attr $Node $Attr + (:: (- $Val 1))) fail)) True) + (or + (, + (get-case-feature $Case numeric + (:: $Attr $Val)) + (if + (, + (is $SumXiPow2 + (* $Val $Val)) + (assert-node-numeric-attr $Node $Attr 1 $SumXiPow2 $Val)) fail)) True) + (set-det)) + (= (copy-node-to-new-node $Node $NewNode) + (new-node $NewNode) + (or + (, + (get-node-nominal-attr $Node $Attr $ValuesCounter) + (if + (assert-node-nominal-attr $NewNode $Attr $ValuesCounter) fail)) True) + (or + (, + (get-node-numeric-attr $Node $Attr $N $SumXiPow2 $SumXi) + (if + (assert-node-numeric-attr $NewNode $Attr $N $SumXiPow2 $SumXi) fail)) True) + (set-det)) - (= - (incorporate-case-into-node $Case $Node) - ( (or - (, - (get-case-feature $Case nominal - (:: $Attr $Val)) - (if - (, - (remove-node-nominal-attr $Node $Attr $ValuesCounter) - (sum-value-counter $ValuesCounter - (:: (- $Val 1)) $NewValuesCounter) - (assert-node-nominal-attr $Node $Attr $NewValuesCounter)) fail)) True) - (or - (, - (get-case-feature $Case numeric - (:: $Attr $Val)) - (if - (, - (remove-node-numeric-attr $Node $Attr $N $SumXiPow2 $SumXi) - (is $NewN - (+ $N 1)) - (is $NewSumXiPow2 - (+ $SumXiPow2 - (* $Val $Val))) - (is $NewSumXi - (+ $SumXi $Val)) - (assert-node-numeric-attr $Node $Attr $NewN $NewSumXiPow2 $NewSumXi)) fail)) True) - (set-det))) -; + (= (incorporate-case-into-node $Case $Node) + (or + (, + (get-case-feature $Case nominal + (:: $Attr $Val)) + (if + (, + (remove-node-nominal-attr $Node $Attr $ValuesCounter) + (sum-value-counter $ValuesCounter + (:: (- $Val 1)) $NewValuesCounter) + (assert-node-nominal-attr $Node $Attr $NewValuesCounter)) fail)) True) + (or + (, + (get-case-feature $Case numeric + (:: $Attr $Val)) + (if + (, + (remove-node-numeric-attr $Node $Attr $N $SumXiPow2 $SumXi) + (is $NewN + (+ $N 1)) + (is $NewSumXiPow2 + (+ $SumXiPow2 + (* $Val $Val))) + (is $NewSumXi + (+ $SumXi $Val)) + (assert-node-numeric-attr $Node $Attr $NewN $NewSumXiPow2 $NewSumXi)) fail)) True) + (set-det)) - (= - (sum-value-counter $ValuesCounter Nil $ValuesCounter) + (= (sum-value-counter $ValuesCounter Nil $ValuesCounter) (set-det)) -; - - (= - (sum_value_counter () $ValuesCounter $ValuesCounter) True) -; - - (= - (sum-value-counter +; /******************************************************************/ +; /* sum_value_counter(+ValuesCounter,+ValuesCounter,-ValuesCounter)*/ +; /******************************************************************/ + (= (sum_value_counter () $ValuesCounter $ValuesCounter) True) + (= (sum-value-counter (Cons (- $Val $C1) $R1) (Cons (- $Val $C2) $R2) (Cons (- $Val $SumC) $Rest)) + (is $SumC + (+ $C1 $C2)) + (set-det) + (sum-value-counter $R1 $R2 $Rest)) + (= (sum-value-counter (Cons (- $Val1 $C1) $R1) (Cons (- $Val2 $C2) $R2) (Cons (- $Val1 $C1) $Rest)) + (@< $Val1 $Val2) + (set-det) + (sum-value-counter $R1 (Cons - (- $Val $C1) $R1) - (Cons - (- $Val $C2) $R2) - (Cons - (- $Val $SumC) $Rest)) - ( (is $SumC - (+ $C1 $C2)) - (set-det) - (sum-value-counter $R1 $R2 $Rest))) -; - - (= + (- $Val2 $C2) $R2) $Rest)) + (= (sum-value-counter (Cons (- $Val1 $C1) $R1) (Cons (- $Val2 $C2) $R2) (Cons (- $Val2 $C2) $Rest)) + (@< $Val2 $Val1) + (set-det) (sum-value-counter (Cons - (- $Val1 $C1) $R1) - (Cons - (- $Val2 $C2) $R2) - (Cons - (- $Val1 $C1) $Rest)) - ( (@< $Val1 $Val2) - (set-det) - (sum-value-counter $R1 - (Cons - (- $Val2 $C2) $R2) $Rest))) -; - - (= - (sum-value-counter - (Cons - (- $Val1 $C1) $R1) - (Cons - (- $Val2 $C2) $R2) - (Cons - (- $Val2 $C2) $Rest)) - ( (@< $Val2 $Val1) - (set-det) - (sum-value-counter - (Cons - (- $Val1 $C1) $R1) $R2 $Rest))) -; - - - - (= - (sum_score () () $_ $Score $Score) True) -; - - (= - (sum-score Nil - (Cons $Node $Rest) $NormNode $Score $Sum_Score) - ( (node $Node $_ $Objects $Prediction) - (node-objects $NormNode $NormObjects) - (is $ZScore - (+ - (/ - (* $Objects $Prediction) $NormObjects) $Score)) - (set-det) - (sum-score Nil $Rest $NormNode $ZScore $Sum_Score))) -; - - (= - (sum-score - (Cons $Node $Rest) $ToDo $NormNode $Score $Sum_Score) - ( (node $Node $_ $Objects $Prediction) - (node-objects $NormNode $NormObjects) - (is $ZScore - (+ - (/ - (* $Objects $Prediction) $NormObjects) $Score)) - (set-det) - (sum-score $Rest $ToDo $NormNode $ZScore $Sum_Score))) -; - + (- $Val1 $C1) $R1) $R2 $Rest)) + + + (= (sum_score () () $_ $Score $Score) True) +; /******************************************************************/ +; /* sum_score(+NodeList,+NodeList,+NormNode,+BaseScore,-FinalScore)*/ +; /******************************************************************/ +; ;; This follows Fisher 1987 in the ML Journal but this seems to be ;; wrong ;sum_score([],[],_,Score,Score). ;sum_score([],[Node|Rest],NormNode,Score,Sum_Score):- ; node(Node,_,Objects,Prediction), ; node(NormNode,_,NormObjects,NormPrediction), ; ZScore is ((Objects / NormObjects) * (Prediction - NormPrediction)) ; + Score, ; !, ; sum_score([],Rest,NormNode,ZScore,Sum_Score). ;sum_score([Node|Rest],ToDo,NormNode,Score,Sum_Score):- ; node(Node,_,Objects,Prediction), ; node(NormNode,_,NormObjects,NormPrediction), ; ZScore is ((Objects / NormObjects) * (Prediction - NormPrediction)) ; + Score, ; !, ; sum_score(Rest,ToDo,NormNode,ZScore,Sum_Score). +; ;; According to Gennari, et. al. 1989 and the COBWEB/3 implementation ; ;sum_score([],[],_,Score,Score). ;sum_score([],[Node|Rest],NormNode,Score,Sum_Score) :- ; node(Node,_,Objects,Prediction), ; node_objects(NormNode,NormObjects), ; ZScore is ((Objects / NormObjects) * Prediction) ; + Score, ; !, ; sum_score([],Rest,NormNode,ZScore,Sum_Score). ;sum_score([Node|Rest],ToDo,NormNode,Score,Sum_Score) :- ; node(Node,_,Objects,Prediction), ; node_objects(NormNode,NormObjects), ; ZScore is ((Objects / NormObjects) * Prediction) ; + Score, ; !, ; sum_score(Rest,ToDo,NormNode,ZScore,Sum_Score). +; ; According to Kietz 93 this implementation avoids rounding errors ; in certain MeTTa dialects. ; ; The first clause realizes a normalization, which seems to be ; integrated already in certain callers of this routine. If you like ; to use it, it needs to replace the following clause. Except for ; smaller caller code size, there seems to be no other advantage of ; using the commented clause. Anyway I include its code, if someone ; likes to clean up the callers. Note, that such a modification might ; conflict compare_partitions/12 ! ; ; sum_score([],[],NormNode,Score,NormScore):- ; node_prediction(NormNode,NormPrediction), ; NormScore = Score - NormPrediction, ; !. + (= (sum-score Nil (Cons $Node $Rest) $NormNode $Score $Sum_Score) + (node $Node $_ $Objects $Prediction) + (node-objects $NormNode $NormObjects) + (is $ZScore + (+ + (/ + (* $Objects $Prediction) $NormObjects) $Score)) + (set-det) + (sum-score Nil $Rest $NormNode $ZScore $Sum_Score)) + (= (sum-score (Cons $Node $Rest) $ToDo $NormNode $Score $Sum_Score) + (node $Node $_ $Objects $Prediction) + (node-objects $NormNode $NormObjects) + (is $ZScore + (+ + (/ + (* $Objects $Prediction) $NormObjects) $Score)) + (set-det) + (sum-score $Rest $ToDo $NormNode $ZScore $Sum_Score)) - (= - (compute-prediction $Node) + (= (compute-prediction $Node) ( (node-objects $Node $Objects) - (add-symbol &self + (add-is-symbol &self (prediction_counter 0 0)) (get-node-nominal-attr $Node $_ $ValuesCounter) (if - (remove-symbol &self + (remove-is-symbol &self (prediction_counter $Sum $Count)) True) (is $NCount (+ $Count 1)) - (add-symbol &self + (add-is-symbol &self (prediction_counter $Sum $NCount)) (member (- $_ $C) $ValuesCounter) (if - (remove-symbol &self + (remove-is-symbol &self (prediction_counter $NNSum $NCount)) True) (is $NSum (+ $NNSum (/ (* $C $C) (* $Objects $Objects)))) - (add-symbol &self + (add-is-symbol &self (prediction_counter $NSum $NCount)) (fail))) -; - - (= - (compute-prediction $Node) +; /******************************************************************/ +; /* compute the prediction of Node */ +; /******************************************************************/ +; ;compute_prediction(Node) :- ; node_objects(Node,Objects), ; asserta(prediction_counter(0,0)), ; get_node_nominal_attr(Node,_,ValuesCounter), ; if(retract(prediction_counter(Sum,Count)),true), ; NCount is Count + 1, ; asserta(prediction_counter(Sum,NCount)), ; member(_-C,ValuesCounter), ; if(retract(prediction_counter(NNSum,NCount)),true), ; NSum is NNSum + ((C / Objects) * (C / Objects)), ; asserta(prediction_counter(NSum,NCount)), ; fail. ;compute_prediction(Node) :- ; get_node_numeric_attr(Node,_,N,SumXiPow2,SumXi), ; if(retract(prediction_counter(Sum,Count)),true), ; NCount is Count + 1, ; DeviationPow2 is (SumXiPow2/N) - ((SumXi*SumXi)/(N*N)), ; abs(DeviationPow2,PosDeviationPow2), ; sqrt(PosDeviationPow2,Deviation), ; ; Deviation of one Instance is 0, so we use a minimum deviation of 1 ; ; Here 'acuity' is hardcoded ! ; max_of([Deviation,1],ScoreDeviation), ; NSum is Sum + 1/ScoreDeviation, ; asserta(prediction_counter(NSum,NCount)), ; fail. ;compute_prediction(Node) :- ; ; Normalize the Prediction against the Number of Attributes ; retract(prediction_counter(Prediction,Count)), ; NormPrediction is Prediction / Count, ; node_prediction(Node,NormPrediction), ; !. +; ; According to Kietz 93 this implementation avoids rounding errors ; in certain MeTTa dialects, and allows a better treatment of the ; 'acuity'. + (= (compute-prediction $Node) ( (get-node-numeric-attr $Node $_ $N $SumXiPow2 $SumXi) (if - (remove-symbol &self + (remove-is-symbol &self (prediction_counter $Sum $Count)) True) (is $NCount (+ $Count 1)) @@ -674,367 +728,288 @@ (is $NSum (+ $Sum (/ $Const $ScoreDeviation))) - (add-symbol &self + (add-is-symbol &self (prediction_counter $NSum $NCount)) (fail))) -; - - (= - (compute-prediction $Node) - ( (remove-symbol &self +; ; Deviation of one Instance is 0, so we use a minimum deviation of 1 +; ; Here 'acuity' isn't longer hardcoded, instead an value is retieved +; ; from the database. A minimal acuity Const is used to ensure that +; ; Const/ScoreDeviation is in the interval [0,1]! + (= (compute-prediction $Node) + ( (remove-is-symbol &self (prediction_counter $Prediction $Count)) (is $NormPrediction (/ $Prediction $Count)) (node-prediction $Node $Prediction) (set-det))) -; - +; ; Normalize the Prediction against the Number of Attributes - (= - (get-acuity $Accuity) - ( (get-symbols &self + (= (get-acuity $Accuity) + ( (== (= - (acuity $Accuity) true)) (set-det))) -; - - (= - (get_acuity 0) True) -; - - - - (= - (init-node) - ( (abolish root 2) - (abolish root 4) - (or - (remove-symbol &self - (gensym_counter node_ $_)) True) - (or - (remove-all-symbols &self - (node root $_ $_)) True) - (or - (remove-all-symbols &self - (d_sub root $_)) True) - (or - (remove-all-symbols &self - (d_sub $_ root)) True) - (set-det))) -; - - - - (= - (new-node (node $Node $_ $_)) + (acuity $Accuity) true) + (get-atoms &self)) (set-det))) + (= (get_acuity 0) True) + + + (= (init-node) + (abolish root 2) + (abolish root 4) + (or + (remove-is-symbol &self + (gensym_counter node_ $_)) True) + (or + (remove-all-atoms &self + (node root $_ $_)) True) + (or + (remove-all-atoms &self + (d_sub root $_)) True) + (or + (remove-all-atoms &self + (d_sub $_ root)) True) + (set-det)) +; /******************************************************************/ +; /* Internal Data Structures are: */ +; /* */ +; /* node(Node,Objects) with */ +; /* Node = Atom and Objects = Integer */ +; /* node(Attribute,[Val-Count|...]) with */ +; /* Attribute = Atom, Val = Atom and Count = Integer */ +; /* d_sub(Parent,Child) with */ +; /* Parent = Atom and Child = Atom */ +; /******************************************************************/ + + + (= (new-node (node $Node $_ $_)) (nonvar $Node)) -; - ; -; - +; QUINTUS-MeTTa specific initialization ; -; - +; new_node(node(Node,_,_)):- ; -; - +; var(Node), ; -; - +; gensym(node_,Node), ; -; - +; abolish(Node,2), ; -; - +; abolish(Node,4), ; -; - +; (retractall(node(Node,_,_));true), ; -; - +; (retractall(d_sub(Node,_));true), ; -; - +; (retractall(d_sub(_,Node));true), ; -; - +; !. ; -; - +; SWI- YAP-, C- and M-MeTTa specific initialization with declaration ; -; - - (= - (new-node (node $Node $_ $_)) - ( (var $Node) - (gensym node- $Node) - (dynamic (/ $Node 2)) - (dynamic (/ $Node 4)) - (abolish $Node 2) - (abolish $Node 4) - (or - (remove-all-symbols &self - (node $Node $_ $_)) True) - (or - (remove-all-symbols &self - (d_sub $Node $_)) True) - (or - (remove-all-symbols &self - (d_sub $_ $Node)) True) - (set-det))) -; - +; of dynamical clauses. + (= (new-node (node $Node $_ $_)) + (var $Node) + (gensym node- $Node) + (dynamic (/ $Node 2)) + (dynamic (/ $Node 4)) + (abolish $Node 2) + (abolish $Node 4) + (or + (remove-all-atoms &self + (node $Node $_ $_)) True) + (or + (remove-all-atoms &self + (d_sub $Node $_)) True) + (or + (remove-all-atoms &self + (d_sub $_ $Node)) True) + (set-det)) - (= - (delete-node $Node) - ( (remove-node $Node) - (node-name $Node $NodeName) - (abolish $NodeName 2) - (abolish $NodeName 4) - (or - (, - (remove-d-sub $Parent $Node) - (remove-d-sub $Node $Child) - (assert-d-sub $Parent $Child) - (fail)) True) - (set-det))) -; - + (= (delete-node $Node) + (remove-node $Node) + (node-name $Node $NodeName) + (abolish $NodeName 2) + (abolish $NodeName 4) + (or + (, + (remove-d-sub $Parent $Node) + (remove-d-sub $Node $Child) + (assert-d-sub $Parent $Child) + (fail)) True) + (set-det)) +; ; This asumes that there is mostly one ParentNode - (= - (terminal-node $Node) + (= (terminal-node $Node) (node-objects $Node 1)) -; - - (= - (move-subs $Source $Dest) - ( (remove-d-sub $Source $Child) - (assert-d-sub $Dest $Child) - (fail))) -; - - (= - (move-subs $Source $Dest) - ( (remove-d-sub $Parent $Source) - (assert-d-sub $Parent $Dest) - (set-det))) -; - - - - (= - (ins-node $Parent $New Nil) - ( (assert-d-sub $Parent $New) (set-det))) -; - - (= - (ins-node $Parent $New - (Cons $Child $Rest)) - ( (or - (remove-d-sub $Parent $Child) True) - (assert-d-sub $New $Child) - (set-det) - (ins-node $Parent $New $Rest))) -; - + (= (move-subs $Source $Dest) + (remove-d-sub $Source $Child) + (assert-d-sub $Dest $Child) + (fail)) + (= (move-subs $Source $Dest) + (remove-d-sub $Parent $Source) + (assert-d-sub $Parent $Dest) + (set-det)) - (= - (node-name - (node $Name $_ $_) $Name) - ( (nonvar $Name) (set-det))) -; + (= (ins-node $Parent $New Nil) + (assert-d-sub $Parent $New) + (set-det)) + (= (ins-node $Parent $New (Cons $Child $Rest)) + (or + (remove-d-sub $Parent $Child) True) + (assert-d-sub $New $Child) + (set-det) + (ins-node $Parent $New $Rest)) + (= (node-name (node $Name $_ $_) $Name) + (nonvar $Name) + (set-det)) +; /******************************************************************/ +; /* node(Node:Atom,Objects:Integer,Prediction:Real) */ +; /******************************************************************/ - (= - (node-objects - (node $Name $Objects $_) $Objects) - ( (nonvar $Name) - (if - (var $Objects) - (get-node (node $Name $Objects $_)) True) - (set-det))) -; + (= (node-objects (node $Name $Objects $_) $Objects) + (nonvar $Name) + (if + (var $Objects) + (get-node (node $Name $Objects $_)) True) + (set-det)) - (= - (node-prediction - (node $Name $Objects $Pred) $Pred) - ( (nonvar $Name) - (or - (, - (var $Pred) - (get-node (node $Name $Objects $Pred))) True) - (if + (= (node-prediction (node $Name $Objects $Pred) $Pred) + (nonvar $Name) + (or + (, (var $Pred) - (compute-prediction (node $Name $Objects $Pred)) True) - (set-det))) -; - + (get-node (node $Name $Objects $Pred))) True) + (if + (var $Pred) + (compute-prediction (node $Name $Objects $Pred)) True) + (set-det)) - (= - (node - (node $Name $Objects $Pred) $Name $Objects $Pred) - ( (nonvar $Name) - (if - (var $Objects) - (get-node (node $Name $Objects $_)) True) - (or - (, - (var $Pred) - (get-node (node $Name $Objects $Pred))) True) - (if + (= (node (node $Name $Objects $Pred) $Name $Objects $Pred) + (nonvar $Name) + (if + (var $Objects) + (get-node (node $Name $Objects $_)) True) + (or + (, (var $Pred) - (compute-prediction (node $Name $Objects $Pred)) True) - (set-det))) -; - + (get-node (node $Name $Objects $Pred))) True) + (if + (var $Pred) + (compute-prediction (node $Name $Objects $Pred)) True) + (set-det)) - (= - (get-node (node $Node $Objects $Pred)) - (get-symbols &self + (= (get-node (node $Node $Objects $Pred)) + (== (= - (node $Node $Objects $Pred) true))) -; - + (node $Node $Objects $Pred) true) + (get-atoms &self))) - (= - (assert-node (node $Node $Objects $Pred)) - ( (nonvar $Node) (add-symbol &self (node $Node $Objects $Pred)))) -; + (= (assert-node (node $Node $Objects $Pred)) + ( (nonvar $Node) (add-is-symbol &self (node $Node $Objects $Pred)))) - - (= - (remove-node (node $Node $Objects $Pred)) - (remove-symbol &self + (= (remove-node (node $Node $Objects $Pred)) + (remove-is-symbol &self (node $Node $Objects $Pred))) -; - - (= - (get-node-nominal-attr - (node $Node $_ $_) $Attr $ValuesCounter) - ( (nonvar $Node) - (nonvar $Attr) - (=.. $Call - (:: $Node $Attr $ValuesCounter)) - (or - (get-symbols &self - (= $Call true)) - (if - (var $ValuesCounter) - (= $ValuesCounter Nil))) - (set-det))) -; - - (= - (get-node-nominal-attr - (node $Node $_ $_) $Attr $ValuesCounter) + (= (get-node-nominal-attr (node $Node $_ $_) $Attr $ValuesCounter) + (nonvar $Node) + (nonvar $Attr) + (=.. $Call + (:: $Node $Attr $ValuesCounter)) + (or + (== + (= $Call true) + (get-atoms &self)) + (if + (var $ValuesCounter) + (= $ValuesCounter Nil))) + (set-det)) +; /******************************************************************/ +; /* node(Attr:Atom,[Val:Atom-Count:Integer|...]) */ +; /******************************************************************/ + (= (get-node-nominal-attr (node $Node $_ $_) $Attr $ValuesCounter) ( (nonvar $Node) (var $Attr) (=.. $Call (:: $Node $Attr $ValuesCounter)) - (get-symbols &self - (= $Call true)))) -; - + (== + (= $Call true) + (get-atoms &self)))) - (= - (assert_node_nominal_attr $_ $_ ()) True) -; - - (= - (assert-node-nominal-attr - (node $Node $_ $_) $Attr $ValuesCounter) + (= (assert_node_nominal_attr $_ $_ ()) True) + (= (assert-node-nominal-attr (node $Node $_ $_) $Attr $ValuesCounter) ( (nonvar $Node) (nonvar $Attr) (nonvar $ValuesCounter) (=.. $Call (:: $Node $Attr $ValuesCounter)) - (add-symbol &self $Call))) -; - - + (add-is-symbol &self $Call))) - (= - (remove-node-nominal-attr - (node $Node $_ $_) $Attr $ValuesCounter) - ( (nonvar $Node) - (nonvar $Attr) - (=.. $Call - (:: $Node $Attr $ValuesCounter)) - (or - (remove-symbol &self $Call) - (if - (var $ValuesCounter) - (= $ValuesCounter Nil))) - (set-det))) -; - (= - (remove-node-nominal-attr - (node $Node $_ $_) $Attr $ValuesCounter) + (= (remove-node-nominal-attr (node $Node $_ $_) $Attr $ValuesCounter) + (nonvar $Node) + (nonvar $Attr) + (=.. $Call + (:: $Node $Attr $ValuesCounter)) + (or + (remove-is-symbol &self $Call) + (if + (var $ValuesCounter) + (= $ValuesCounter Nil))) + (set-det)) + (= (remove-node-nominal-attr (node $Node $_ $_) $Attr $ValuesCounter) ( (nonvar $Node) (=.. $Call (:: $Node $Attr $ValuesCounter)) - (remove-symbol &self $Call))) -; - - - - (= - (get-node-numeric-attr - (node $Node $_ $_) $Attr $N $SumXiPow2 $SumXi) - ( (nonvar $Node) - (nonvar $Attr) - (=.. $Call - (:: $Node $Attr $N $SumXiPow2 $SumXi)) - (or - (get-symbols &self - (= $Call true)) - (if - (var $N) - (, - (= $N 0) - (= $SumXiPow2 0) - (= $SumXi 0)))) - (set-det))) -; - - (= - (get-node-numeric-attr - (node $Node $_ $_) $Attr $N $SumXiPow2 $SumXi) + (remove-is-symbol &self $Call))) + + + (= (get-node-numeric-attr (node $Node $_ $_) $Attr $N $SumXiPow2 $SumXi) + (nonvar $Node) + (nonvar $Attr) + (=.. $Call + (:: $Node $Attr $N $SumXiPow2 $SumXi)) + (or + (== + (= $Call true) + (get-atoms &self)) + (if + (var $N) + (, + (= $N 0) + (= $SumXiPow2 0) + (= $SumXi 0)))) + (set-det)) +; /******************************************************************/ +; /* node(Attr:Atom,N:Integer,SumXiPow2:Integer,SumXi:Integer) */ +; /******************************************************************/ + (= (get-node-numeric-attr (node $Node $_ $_) $Attr $N $SumXiPow2 $SumXi) ( (nonvar $Node) (var $Attr) (=.. $Call (:: $Node $Attr $N $SumXiPow2 $SumXi)) - (get-symbols &self - (= $Call true)))) -; - + (== + (= $Call true) + (get-atoms &self)))) - (= - (assert_node_numeric_attr $_ $_ 0 $_ $_) True) -; - - (= - (assert-node-numeric-attr - (node $Node $_ $_) $Attr $N $SumXiPow2 $SumXi) + (= (assert_node_numeric_attr $_ $_ 0 $_ $_) True) + (= (assert-node-numeric-attr (node $Node $_ $_) $Attr $N $SumXiPow2 $SumXi) ( (nonvar $Node) (nonvar $Attr) (nonvar $N) @@ -1042,579 +1017,410 @@ (nonvar $SumXi) (=.. $Call (:: $Node $Attr $N $SumXiPow2 $SumXi)) - (add-symbol &self $Call))) -; - - + (add-is-symbol &self $Call))) - (= - (remove-node-numeric-attr - (node $Node $_ $_) $Attr $N $SumXiPow2 $SumXi) - ( (nonvar $Node) - (nonvar $Attr) - (=.. $Call - (:: $Node $Attr $N $SumXiPow2 $SumXi)) - (or - (remove-symbol &self $Call) - (if - (var $N) - (, - (= $N 0) - (= $SumXiPow2 0) - (= $SumXi 0)))) - (set-det))) -; - (= - (remove-node-numeric-attr - (node $Node $_ $_) $Attr $N $SumXiPow2 $SumXi) + (= (remove-node-numeric-attr (node $Node $_ $_) $Attr $N $SumXiPow2 $SumXi) + (nonvar $Node) + (nonvar $Attr) + (=.. $Call + (:: $Node $Attr $N $SumXiPow2 $SumXi)) + (or + (remove-is-symbol &self $Call) + (if + (var $N) + (, + (= $N 0) + (= $SumXiPow2 0) + (= $SumXi 0)))) + (set-det)) + (= (remove-node-numeric-attr (node $Node $_ $_) $Attr $N $SumXiPow2 $SumXi) ( (nonvar $Node) (=.. $Call (:: $Node $Attr $N $SumXiPow2 $SumXi)) - (remove-symbol &self $Call))) -; - + (remove-is-symbol &self $Call))) - (= - (get-d-sub - (node $SuperNode $_ $_) - (node $SubNode $_ $_)) - (get-symbols &self + (= (get-d-sub (node $SuperNode $_ $_) (node $SubNode $_ $_)) + (== (= - (d_sub $SuperNode $SubNode) true))) -; - + (d_sub $SuperNode $SubNode) true) + (get-atoms &self))) +; /******************************************************************/ +; /* d_sub(SuperNode:Atom,SubNode:Atom) */ +; /******************************************************************/ - (= - (assert-d-sub - (node $SuperNode $_ $_) - (node $SubNode $_ $_)) - (add-symbol &self + (= (assert-d-sub (node $SuperNode $_ $_) (node $SubNode $_ $_)) + (add-is-symbol &self (d_sub $SuperNode $SubNode))) -; - - (= - (remove-d-sub - (node $SuperNode $_ $_) - (node $SubNode $_ $_)) - (remove-symbol &self + (= (remove-d-sub (node $SuperNode $_ $_) (node $SubNode $_ $_)) + (remove-is-symbol &self (d_sub $SuperNode $SubNode))) -; - - - - (= - (max-of - (Cons $F $R) $Max) - ( (max-of $R $F $Max) (set-det))) -; - - (= - (max_of () $Max $Max) True) -; - (= - (max-of - (Cons $F $R) $Best $Max) - ( (=< $F $Best) - (set-det) - (max-of $R $Best $Max))) -; - (= - (max-of - (Cons $F $R) $_ $Max) + (= (max-of (Cons $F $R) $Max) + (max-of $R $F $Max) + (set-det)) +; /******************************************************************/ +; /* Miscealenous definitions */ +; /******************************************************************/ + (= (max_of () $Max $Max) True) + (= (max-of (Cons $F $R) $Best $Max) + (=< $F $Best) + (set-det) + (max-of $R $Best $Max)) + (= (max-of (Cons $F $R) $_ $Max) (max-of $R $F $Max)) -; - - (= - (msgs Nil) + (= (msgs Nil) (set-det)) -; - - (= - (msgs (Cons $First $Rest)) - ( (msg $First) (msgs $Rest))) -; - - - - (= - (msg (node $ID $Obj $Pred)) - ( (set-det) - (write $ID) - (write (obj=) - (write $Obj) - (write ',pred=') - (write $Pred) - (write )))) -; - - (= - (msg $Var) - ( (var $Var) - (set-det) - (write $Var))) -; - - (= - (msg nl) - ( (set-det) (nl))) -; - - (= - (msg (nl $N)) - ( (set-det) (msg-repeat $N nl))) -; - - (= - (msg sp) - ( (set-det) (write ' '))) -; - - (= - (msg (sp $N)) - ( (set-det) (msg-repeat $N (outterm ' ')))) -; - - (= - (msg (q- $O)) - ( (set-det) (write $O))) -; - - (= - (msg $X) - ( (set-det) (write $X))) -; - + (= (msgs (Cons $First $Rest)) + (msg $First) + (msgs $Rest)) + + + (= (msg (node $ID $Obj $Pred)) + (set-det) + (write $ID) + (write (obj=) + (write $Obj) + (write ',pred=') + (write $Pred) + (write ))) + (= (msg $Var) + (var $Var) + (set-det) + (write $Var)) + (= (msg nl) + (set-det) + (nl)) + (= (msg (nl $N)) + (set-det) + (msg-repeat $N nl)) + (= (msg sp) + (set-det) + (write ' ')) + (= (msg (sp $N)) + (set-det) + (msg-repeat $N + (outterm ' '))) + (= (msg (q- $O)) + (set-det) + (write $O)) + (= (msg $X) + (set-det) + (write $X)) ; -; - - - (= - (msg-repeat $N $_) - ( (< $N 1) (set-det))) -; +; msg_repeat Call N times. - (= - (msg-repeat $N $Call) + (= (msg-repeat $N $_) + (< $N 1) + (set-det)) + (= (msg-repeat $N $Call) ($Call (is $N1 (- $N 1)) (msg-repeat $N1 $Call))) -; - - - (= - (save-kb $FN) - ( (concat $FN .pl $Y) - (tell $Y) - (print-kb) - (told) - (set-det))) -; + (= (save-kb $FN) + (concat $FN .pl $Y) + (tell $Y) + (print-kb) + (told) + (set-det)) - (= - (load-kb $FN) - ( (clear-kb) - (concat $FN .pl $Y) - (consult $Y) - (set-det))) -; - + (= (load-kb $FN) + (clear-kb) + (concat $FN .pl $Y) + (consult $Y) + (set-det)) - (= - (print-kb) + (= (print-kb) ( (if (= $Call (d-sub $SuperNode $SubNode)) True) - (get-symbols &self - (= $Call true)) + (== + (= $Call true) + (get-atoms &self)) (if (, (writeq $Call) (write .) (nl)) fail))) -; - - (= - (print-kb) - ( (get-node $Node) (if (, (writeq $Node) (write .) (nl)) fail))) -; - - (= - (print-kb) + (= (print-kb) + (get-node $Node) + (if + (, + (writeq $Node) + (write .) + (nl)) fail)) + (= (print-kb) ( (get-node $Node) (if (, (node-name $Node $Name) (=.. $Call (:: $Name $Attr $ValuesCounter))) True) - (get-symbols &self - (= $Call true)) + (== + (= $Call true) + (get-atoms &self)) (if (, (writeq $Call) (write .) (nl)) fail))) -; - - (= - (print-kb) + (= (print-kb) ( (get-node $Node) (if (, (node-name $Node $Name) (=.. $Call (:: $Name $Attr $N $SumXiPow2 $SumXi))) True) - (get-symbols &self - (= $Call true)) + (== + (= $Call true) + (get-atoms &self)) (if (, (writeq $Call) (write .) (nl)) fail))) -; - - (= print_kb True) -; + (= print_kb True) - - (= - (clear-kb) - ( (get-node $Node) (if (, (node-name $Node $Name) (abolish $Name 2) (abolish $Name 4)) fail))) -; - - (= - (clear-kb) + (= (clear-kb) + (get-node $Node) + (if + (, + (node-name $Node $Name) + (abolish $Name 2) + (abolish $Name 4)) fail)) + (= (clear-kb) ( (abolish node 3) (abolish d-sub 2) (or - (remove-symbol &self + (remove-is-symbol &self (gensym_counter node_ $_)) True) - (add-symbol &self + (add-is-symbol &self (gensym_counter node_ 0)) (set-det))) -; - - - - (= - (show) - ( (collect-tree root $Tree all) - (display-tree $Tree) - (set-det))) -; - - (= - (show-classes) - ( (collect-tree root $Tree classes) - (display-tree $Tree) - (set-det))) -; + (= (show) + (collect-tree root $Tree all) + (display-tree $Tree) + (set-det)) + (= (show-classes) + (collect-tree root $Tree classes) + (display-tree $Tree) + (set-det)) - (= - (collect_tree () () $_) True) -; - (= - (collect-tree - (Cons $Node $Nodes) - (Cons $SubTree $SubTrees) $Type) - ( (collect-tree $Node $SubTree $Type) - (set-det) - (collect-tree $Nodes $SubTrees $Type))) -; - - (= - (collect-tree - (Cons $_ $Nodes) $SubTrees classes) - ( (set-det) (collect-tree $Nodes $SubTrees classes))) -; - - (= - (collect-tree $Node - (:: $Node $Obj $SubTrees) $Type) - ( (get-symbols &self + (= (collect_tree () () $_) True) + (= (collect-tree (Cons $Node $Nodes) (Cons $SubTree $SubTrees) $Type) + (collect-tree $Node $SubTree $Type) + (set-det) + (collect-tree $Nodes $SubTrees $Type)) + (= (collect-tree (Cons $_ $Nodes) $SubTrees classes) + (set-det) + (collect-tree $Nodes $SubTrees classes)) +; ; Terminals are ignored here + (= (collect-tree $Node (:: $Node $Obj $SubTrees) $Type) + ( (== (= - (node $Node $Obj $_) true)) + (node $Node $Obj $_) true) + (get-atoms &self)) (or (setof $Sub - (get-symbols &self + (== (= - (d_sub $Node $Sub) true)) $Subs) + (d_sub $Node $Sub) true) + (get-atoms &self)) $Subs) (, (= $Type all) (= $Subs Nil))) (set-det) (collect-tree $Subs $SubTrees $Type))) -; - - - - (= - (display-tree (:: $Node $Obj $SubTrees)) - ( (write 'Number of cases processed: ') - (write $Obj) - (nl) - (write $Node) - (name $Node $String) - (length $String $Offset) - (display-tree $SubTrees $Offset))) -; - - - (= - (display-tree - (:: $Node) $Offset) - ( (set-det) (display-tree-node $Node $Offset))) -; - - (= - (display-tree - (Cons $Node $Subtrees) $Offset) - ( (set-det) - (display-tree-node $Node $Offset) - (tab $Offset) - (display-tree $Subtrees $Offset))) -; - - - - (= - (display-tree-node - (:: $Node $Obj Nil) $Offset) - ( (set-det) - (write <-- ) - (write $Node) - (write = ) - (write $Obj) - (nl))) -; - - (= - (display-tree-node - (:: $Node $Obj $Subtree) $Offset) - ( (write <-- ) - (write $Node) - (write = ) - (write $Obj) - (name $Node $String1) - (length $String1 $SLength) - (name $Obj $String2) - (length $String2 $NLength) - (is $NewOffset - (+ - (+ - (+ - (+ $Offset 5) $SLength) 3) $NLength)) - (display-tree $Subtree $NewOffset))) -; - - - - (= - (show-node $Node) - ( (collect-attribute-values $Node $Nominal $Numeric) (display-node $Node $Nominal $Numeric))) -; - - - - (= - (collect-attribute-values $Node $NominalAttValueList $NumericAttValueList) - ( (=.. $NominalAttValues - (:: $Node $NominalAtt $NominalVals)) - (=.. $NumericAttValues - (:: $Node $NumericAtt $Number $X $Y)) - (findall $NominalAttValues - (call $NominalAttValues) $NominalAttValueList) - (findall $NumericAttValues - (call $NumericAttValues) $NumericAttValueList))) -; - - (= - (if $Cond $Then) - ( (call $Cond) - (set-det) - (call $Then))) -; - - (= - (if $_ $_) True) -; - - - (= - (if $Cond $Then $Else) - ( (call $Cond) - (set-det) - (calltrue $Then))) -; - - (= - (if $_ $_ $Else) + (= (display-tree (:: $Node $Obj $SubTrees)) + (write 'Number of cases processed: ') + (write $Obj) + (nl) + (write $Node) + (name $Node $String) + (length $String $Offset) + (display-tree $SubTrees $Offset)) + + (= (display-tree (:: $Node) $Offset) + (set-det) + (display-tree-node $Node $Offset)) + (= (display-tree (Cons $Node $Subtrees) $Offset) + (set-det) + (display-tree-node $Node $Offset) + (tab $Offset) + (display-tree $Subtrees $Offset)) + + + (= (display-tree-node (:: $Node $Obj Nil) $Offset) + (set-det) + (write <-- ) + (write $Node) + (write = ) + (write $Obj) + (nl)) + (= (display-tree-node (:: $Node $Obj $Subtree) $Offset) + (write <-- ) + (write $Node) + (write = ) + (write $Obj) + (name $Node $String1) + (length $String1 $SLength) + (name $Obj $String2) + (length $String2 $NLength) + (is $NewOffset + (+ + (+ + (+ + (+ $Offset 5) $SLength) 3) $NLength)) + (display-tree $Subtree $NewOffset)) + + + (= (show-node $Node) + (collect-attribute-values $Node $Nominal $Numeric) + (display-node $Node $Nominal $Numeric)) + + + (= (collect-attribute-values $Node $NominalAttValueList $NumericAttValueList) + (=.. $NominalAttValues + (:: $Node $NominalAtt $NominalVals)) + (=.. $NumericAttValues + (:: $Node $NumericAtt $Number $X $Y)) + (findall $NominalAttValues + (call $NominalAttValues) $NominalAttValueList) + (findall $NumericAttValues + (call $NumericAttValues) $NumericAttValueList)) + + + (= (if $Cond $Then) + (call $Cond) + (set-det) + (call $Then)) +; /******************************************************************/ +; /* utility predicates */ +; /******************************************************************/ + (= (if $_ $_) True) + + (= (if $Cond $Then $Else) + (call $Cond) + (set-det) + (calltrue $Then)) + (= (if $_ $_ $Else) (calltrue $Else)) -; - - (= - (calltrue $Call) - ( (call $Call) (set-det))) -; - - (= - (calltrue $_) True) -; - + (= (calltrue $Call) + (call $Call) + (set-det)) + (= (calltrue $_) True) - (= - (count $VAR $X) - ( (remove-symbol &self + (= (count $VAR $X) + ( (remove-is-symbol &self (gensym_counter $VAR $N)) (is $X (+ $N 1)) - (add-symbol &self + (add-is-symbol &self (gensym_counter $VAR $X)) (set-det))) -; - - (= - (count $VAR 1) - (add-symbol &self + (= (count $VAR 1) + (add-is-symbol &self (gensym_counter $VAR 1))) -; - - (= - (gensym $SYM) + (= (gensym $SYM) (gensym $SYM g)) -; - - (= - (gensym $N $Sym) - ( (count $N $X) - (name $N $S1) - (name $X $S2) - (append $S1 $S2 $S3) - (name $Sym $S3))) -; - - - - (= - (remove-all-symbols &self $HEAD) - ( (var $HEAD) - (set-det) - (fail))) -; - - (= - (remove-all-symbols &self - (:- $HEAD $BODY)) - ( (var $BODY) - (set-det) - (or - (, - (remove-symbol &self - (:- $HEAD true)) - (fail)) True) - (or - (, - (remove-symbol &self - (:- $HEAD $_)) - (fail)) True))) -; - - (= - (remove-all-symbols &self - (:- $HEAD true)) - ( (remove-symbol &self + (= (gensym $N $Sym) + (count $N $X) + (name $N $S1) + (name $X $S2) + (append $S1 $S2 $S3) + (name $Sym $S3)) + + + (= (remove-all-atoms &self $HEAD) + (var $HEAD) + (set-det) + (fail)) + (= (remove-all-atoms &self (:- $HEAD $BODY)) + (var $BODY) + (set-det) + (or + (, + (remove-is-symbol &self + (:- $HEAD true)) + (fail)) True) + (or + (, + (remove-is-symbol &self + (:- $HEAD $_)) + (fail)) True)) + (= (remove-all-atoms &self (:- $HEAD true)) + ( (remove-is-symbol &self (:- $HEAD true)) (fail))) -; - - (= - (remove-all-symbols &self - (:- $HEAD $BODY)) - ( (remove-symbol &self + (= (remove-all-atoms &self (:- $HEAD $BODY)) + ( (remove-is-symbol &self (:- $HEAD $BODY)) (fail))) -; - - (= - (retractall $_) True) -; - - + (= (retractall $_) True) - (= - (abs $X $Y) - ( (< $X 0) - (is $Y - (* $X -1)) - (set-det))) -; - - (= - (abs $X $X) True) -; + (= (abs $X $Y) + (< $X 0) + (is $Y + (* $X -1)) + (set-det)) +; /******************************************************************/ +; /* YAP-MeTTa specific declaration. */ +; /******************************************************************/ + (= (abs $X $X) True) - (= - (sqrt $X $Y) + (= (sqrt $X $Y) (is $Y (sqrt $X))) -; - - - - (= - (help) - ( (write ' Load data set : load-kb(Filename).') - (nl) - (write ' Process single file : learn.') - (nl) - (write ' Process multiple files : learn-more.') - (nl) - (write ' Show hierarchy (classes & cases) : show.') - (nl) - (write ' Show hierarchy (classes only) : show-classes.') - (nl) - (write ' Show node (not yet impl.) : show-node(NodeID).') - (nl) - (write ' Print result (cryptical) : print-kb.') - (nl) - (write ' Store result : save-kb(Filename).') - (nl) - (write ' Forget result : clear-kb.') - (nl))) -; + (= (help) + (write ' Load data set : load-kb(Filename).') + (nl) + (write ' Process single file : learn.') + (nl) + (write ' Process multiple files : learn-more.') + (nl) + (write ' Show hierarchy (classes & cases) : show.') + (nl) + (write ' Show hierarchy (classes only) : show-classes.') + (nl) + (write ' Show node (not yet impl.) : show-node(NodeID).') + (nl) + (write ' Print result (cryptical) : print-kb.') + (nl) + (write ' Store result : save-kb(Filename).') + (nl) + (write ' Forget result : clear-kb.') + (nl)) - !(help *) -; + !(help *) diff --git a/cobweb/cobweb_1.metta b/cobweb/cobweb_1.metta index 2ae729a..49aa58e 100644 --- a/cobweb/cobweb_1.metta +++ b/cobweb/cobweb_1.metta @@ -1,53 +1,31 @@ +; (convert_to_metta_file cobweb_1 $_178754 cobweb/cobweb_1.pl cobweb/cobweb_1.metta) - (= - (features - ( (numeric minPrice) - (nominal tv) - (nominal bar))) True) -; - ; -; - + (= (features ((numeric minPrice) (nominal tv) (nominal bar))) True) +; /********************************************************************/ +; /* cobweb_1.pro Last modification: Sun 2 Feb 1992 12:47:23 */ +; /********************************************************************/ +; /********************************************************************/ +; /* Data set describing a set of fictitious hotels (price per room, */ +; /* furnishings). The learning result should be a grouping into cheap*/ +; /* and luxury hotels. */ +; /********************************************************************/ +; ; Description of the features as a list of (type and name) +; ; minimum price per room +; ; room with TV? ; +; room with bar? ; -; - +; Description of the cases ; -; - +; (first element: case-id (will not be used in clustering), ; -; - +; rest: feature values in accordance to the description of features above) - (= - (case - (sheraton 250.0 y y)) True) -; - - (= - (case - (ritz 223.0 y y)) True) -; - - (= - (case - (kempinski 224.0 y y)) True) -; - - (= - (case - (sonja 40.0 n y)) True) -; - - (= - (case - (ostermann 35 n n)) True) -; - - (= - (case - (zur_gruenen_wiese 50 y n)) True) -; - + (= (case (sheraton 250.0 y y)) True) + (= (case (ritz 223.0 y y)) True) + (= (case (kempinski 224.0 y y)) True) + (= (case (sonja 40.0 n y)) True) + (= (case (ostermann 35 n n)) True) + (= (case (zur_gruenen_wiese 50 y n)) True) diff --git a/cobweb/cobweb_2.metta b/cobweb/cobweb_2.metta index 99d98e0..98a7f30 100644 --- a/cobweb/cobweb_2.metta +++ b/cobweb/cobweb_2.metta @@ -1,51 +1,29 @@ +; (convert_to_metta_file cobweb_2 $_240114 cobweb/cobweb_2.pl cobweb/cobweb_2.metta) - (= - (features - ( (numeric ht) - (numeric wid) - (numeric txt))) True) -; - + (= (features ((numeric ht) (numeric wid) (numeric txt))) True) +; /********************************************************************/ +; /* cobweb_2.pro Last modification: Sun 2 Feb 1992 12:47:41 */ +; /********************************************************************/ +; /********************************************************************/ +; /* COBWEB example data-set: Rectangle descriptions */ +; /* Source: from J. Gennari, P. Langley, D. Fisher: */ +; /* 'Models of Incremental Concept Formation', */ +; /* AI 40, 1989, page 41, Fig. 6-10 */ +; /********************************************************************/ +; ; Description of the features as a list of (type and name) ; -; - +; Description of the cases ; -; - +; (first element: case-id (will not be used in clustering), ; -; - +; rest: feature values in accordance to the description of features above) - (= - (case - (firstInstance 14.0 7.0 8.0)) True) -; - - (= - (case - (secondInstance 12.0 7.0 20.0)) True) -; - - (= - (case - (thirdInstance 25.0 15.0 24.0)) True) -; - - (= - (case - (fourthInstance 28.0 13.0 19.0)) True) -; - - (= - (case - (fifthInstance 41.0 36.0 30.0)) True) -; - - (= - (case - (sixthInstance 12.0 6.0 7.0)) True) -; - + (= (case (firstInstance 14.0 7.0 8.0)) True) + (= (case (secondInstance 12.0 7.0 20.0)) True) + (= (case (thirdInstance 25.0 15.0 24.0)) True) + (= (case (fourthInstance 28.0 13.0 19.0)) True) + (= (case (fifthInstance 41.0 36.0 30.0)) True) + (= (case (sixthInstance 12.0 6.0 7.0)) True) diff --git a/cobweb/cobweb_3.metta b/cobweb/cobweb_3.metta index a663ca3..dfe11ea 100644 --- a/cobweb/cobweb_3.metta +++ b/cobweb/cobweb_3.metta @@ -1,48 +1,29 @@ +; (convert_to_metta_file cobweb_3 $_300858 cobweb/cobweb_3.pl cobweb/cobweb_3.metta) - (= - (features - ( (nominal bodycover) - (nominal heartchamber) - (nominal bodytemp) - (nominal fertilization))) True) -; - + (= (features ((nominal bodycover) (nominal heartchamber) (nominal bodytemp) (nominal fertilization))) True) +; /********************************************************************/ +; /* cobweb_3.pro Last modification: Sat 29 May 1992 15:37:04 */ +; /********************************************************************/ +; /********************************************************************/ +; /* COBWEB example data-set: Animal descriptions */ +; /* From D. Fisher: 'Knowledge Acquisition Via Incremental */ +; /* Conceptual Clustering', */ +; /* Machine Learning 2, 1991, page 142, Table 1 */ +; /********************************************************************/ +; ; Description of the features (type and name) ; -; - +; Description of the cases ; -; - +; (first element: case-id (will not be used in clustering), ; -; - +; rest: feature values in accordance to the description of features above) - (= - (case - (reptile cornified_skin imperfect_four unregulated internal)) True) -; - - (= - (case - (bird feathers four regulated internal)) True) -; - - (= - (case - (amphipian moist_skin three unregulated external)) True) -; - - (= - (case - (fish scales two unregulated external)) True) -; - - (= - (case - (mammal hair four regulated internal)) True) -; - + (= (case (reptile cornified_skin imperfect_four unregulated internal)) True) + (= (case (bird feathers four regulated internal)) True) + (= (case (amphipian moist_skin three unregulated external)) True) + (= (case (fish scales two unregulated external)) True) + (= (case (mammal hair four regulated internal)) True) diff --git a/cobweb/cobweb_4.metta b/cobweb/cobweb_4.metta index 52c66ea..e8503df 100644 --- a/cobweb/cobweb_4.metta +++ b/cobweb/cobweb_4.metta @@ -1,42 +1,28 @@ +; (convert_to_metta_file cobweb_4 $_361122 cobweb/cobweb_4.pl cobweb/cobweb_4.metta) - (= - (features - ( (nominal tails) - (nominal color) - (nominal nuclei))) True) -; - + (= (features ((nominal tails) (nominal color) (nominal nuclei))) True) +; /********************************************************************/ +; /* cobweb_4.pro Last modification: Sun 2 Feb 1992 12:46:30 */ +; /********************************************************************/ +; /********************************************************************/ +; /* COBWEB example data-set: Cell descriptions */ +; /* Source: from J. Gennari, P. Langley, D. Fisher: */ +; /* 'Models of Incremental Concept Formation', */ +; /* Artificial Intelligence 40, 1989, page 30, Fig. 3 */ +; /********************************************************************/ +; ; Description of the features as a list of (type and name) ; -; - +; Description of the cases ; -; - +; (first element: case-id (will not be used in clustering), ; -; - +; rest: feature values in accordance to the description of features above) - (= - (case - (cell1 one light one)) True) -; - - (= - (case - (cell2 two dark two)) True) -; - - (= - (case - (cell3 two light two)) True) -; - - (= - (case - (cell4 one dark three)) True) -; - + (= (case (cell1 one light one)) True) + (= (case (cell2 two dark two)) True) + (= (case (cell3 two light two)) True) + (= (case (cell4 one dark three)) True) diff --git a/discr/discr.metta b/discr/discr.metta index d97e494..7cbad30 100644 --- a/discr/discr.metta +++ b/discr/discr.metta @@ -1,223 +1,294 @@ +; (convert_to_metta_file discr $_420542 discr/discr.pl discr/discr.metta) !(dynamic (/ :: 2)) -; - +; /******************************************************************/ +; /* DISCR.PL Last Modification: Fri Jan 14 19:22:58 1994 */ +; /* Brazdil's generation of discriminants from derivation trees */ +; /******************************************************************/ +; ; ; Copyright (c) 1989 Thomas Hoppe ; ; This program is free software; you can redistribute it and/or ; modify it under the terms of the GNU General Public License ; Version 1 as published by the Free Software Foundation. ; ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; ; You should have received a copy of the GNU General Public ; Licensealong with this program; if not, write to the Free ; SoftwareFoundation, Inc., 675 Mass Ave, Cambridge, MA 02139, ; USA. ; +; /******************************************************************/ +; /* impl. by : Thomas Hoppe */ +; /* Mommsenstr. 50 */ +; /* D-10629 Berlin */ +; /* F.R.G. */ +; /* E-Mail: hoppet@cs.tu-berlin.de */ +; /* 1989 */ +; /* */ +; /* reference : problem 93 */ +; /* chapter 9 */ +; /* PROLOG by example */ +; /* Helder Coelho, Jose' C. Cotta */ +; /* Berlin, Heidelberg, New York */ +; /* Springer-Verlag, 1988 */ +; /* */ +; /* call : ex1, ex2 */ +; /* */ +; /******************************************************************/ +; /* One of the common errors in learning is over generalisation: */ +; /* a given term Q is applicable in certain contexts instead of */ +; /* failing. The purpose of the following programm is to correct */ +; /* this. This can be done by computation of a discriminant, which */ +; /* can be used to backup from an overgeneralisation. For this */ +; /* purpose we need two kind of contexts: */ +; /* */ +; /* - an application context (app) in which the proof of Q */ +; /* should suceed, and */ +; /* - a rejection context (rej) in which the proof should fail. */ +; /* */ +; /* All clauses determining what Q is (this can be viewed as the */ +; /* background knowledge) and how it is related to the contexts */ +; /* (app and rej) (this can be viewed as the user-given examples) */ +; /* should also be given. The expression generated which is */ +; /* applicable in the application context (app) only is referred */ +; /* to as discriminant, and the process of generating the */ +; /* discriminat (obviously) as discrimination. */ +; /******************************************************************/ +; /* The programm assumes that clauses are represented in the */ +; /* following way: */ +; /* */ +; /* cn :: HEAD <- PRED1 & PRED2 & ..... PREDN */ +; /* */ +; /* where cn is a unique name for every single clause, <- denotes */ +; /* implication and & denotes conjunction. PREDN can be a PROLOG */ +; /* build-in predicate, which is evaluated in the normal fasion. */ +; /* See discr_1.pro and discr_2.pro. Sorry I haven't yet some nice */ +; /* examples. */ +; /******************************************************************/ +; ; TH Sat May 29 23:58:27 1993 - made some minor modifications +; /******************************************************************/ +; /* SWI-, YAP-, C- and M-MeTTa specific declaration of dynamical */ +; /* clauses. */ +; /******************************************************************/ !(op 150 yfx ::) -; - !(op 145 xfx <-) -; - !(op 140 xfy &) -; - !(op 135 xfx :=) -; - - (= - (derivation - (<- $P $C) $TYP) + (= (derivation (<- $P $C) $TYP) ( (name a1 $NAME) (add-context $NAME $C) (generate-goal-ids $P $ID1 1 $I1) (expand-derivation $P $P2 $ID1 $ID2 (:: $I1 $ID1) (:: $I2 $DERIVATION)) - (add-symbol &self + (add-is-symbol &self (:: $TYP $DERIVATION)) (write (:: $TYP $DERIVATION)) (nl) (fail))) -; - - (= - (derivation $_ $_) - ( (name a1 - (:: $N1 $N2)) (del-context (:: $N1 $_)))) -; - - - - (= - (add-context - (:: $N1 $N2) - (& $P1 $P2)) +; /******************************************************************/ +; /* */ +; /* call : derivation(+EXPRESSION,+TYP) */ +; /* */ +; /* arguments : EXPRESSION = Expression of the form P <- C */ +; /* TYPE = context type */ +; /* */ +; /* side effects: Asserting derivation trees in the database */ +; /* */ +; /******************************************************************/ +; /* The generation of all possible derivation trees of an */ +; /* EXPRESSION of the form P <- C, whose truth/falsity should be */ +; /* established, is done with this predicate. TYPE is the context */ +; /* type (app or rej). */ +; /******************************************************************/ + (= (derivation $_ $_) + (name a1 + (:: $N1 $N2)) + (del-context (:: $N1 $_))) + + + (= (add-context (:: $N1 $N2) (& $P1 $P2)) ( (set-det) (name $C (:: $N1 $N2)) - (add-symbol &self + (add-is-symbol &self (:: $C (<- $P1 true))) (is $N3 (+ $N2 1)) (add-context (:: $N1 $N3) $P2))) -; - - (= - (add-context - (:: $N1 $N2) $P1) +; /******************************************************************/ +; /* */ +; /* call : add_context(+CLAUSENAME,+EXPRESSION) */ +; /* */ +; /* arguments : CLAUSENAME = List of charaters */ +; /* EXPRESSION = Conjunction of Facts */ +; /* */ +; /* side effects: Asserting contexts in the database */ +; /* */ +; /******************************************************************/ +; /* The assertion of contexts is done with this predicate. CLAUSE- */ +; /* NAME is a list of characters of length 2, and EXPRESSION a */ +; /* conjunction of Facts. */ +; /******************************************************************/ + (= (add-context (:: $N1 $N2) $P1) ( (name $C - (:: $N1 $N2)) (add-symbol &self (:: $C (<- $P1 true))))) -; - + (:: $N1 $N2)) (add-is-symbol &self (:: $C (<- $P1 true))))) - (= - (del-context (:: $N1 $N2)) + (= (del-context (:: $N1 $N2)) ( (:: $C (<- $P1 True)) (name $C (:: $N1 $_)) - (remove-symbol &self + (remove-is-symbol &self (:: $C (<- $P1 true))) (fail))) -; - - (= - (del_context $_) True) -; - - - - (= - (generate-goal-ids - (& $P1 $P2) - (& $I1 $I2) $I1 $I4) - ( (set-det) - (is $I3 - (+ $I1 1)) - (generate-goal-ids $P2 $I2 $I3 $I4))) -; - - (= - (generate-goal-ids $P1 $I1 $I1 $I4) +; /******************************************************************/ +; /* */ +; /* call : del_context(+CLAUSENAME) */ +; /* */ +; /* arguments : CLAUSENAME = List of charaters */ +; /* */ +; /* side effects: Retracting contexts from the database */ +; /* */ +; /******************************************************************/ +; /* The deletion of contexts is done with this predicate. CLAUSE- */ +; /* NAME is a list of characters of length 2. */ +; /******************************************************************/ + (= (del_context $_) True) + + + (= (generate-goal-ids (& $P1 $P2) (& $I1 $I2) $I1 $I4) + (set-det) + (is $I3 + (+ $I1 1)) + (generate-goal-ids $P2 $I2 $I3 $I4)) +; /******************************************************************/ +; /* */ +; /* call : generate_goal_ids(+GOALCONJUNCTION, */ +; /* -IDCONJUNCTION, */ +; /* +ID1, */ +; /* -ID2) */ +; /* */ +; /* arguments : GOALCONJUNCTION = actual conjunction of goals */ +; /* IDCONJUNCTION = conjunction of goal ids */ +; /* ID1 = last used id */ +; /* ID2 = updated last used id */ +; /* */ +; /******************************************************************/ +; /* Given a conjunction of goals this predicate generates goal */ +; /* identifiers (integers) using the information of the last used */ +; /* id and returning the last new identifier. */ +; /******************************************************************/ + (= (generate-goal-ids $P1 $I1 $I1 $I4) (is $I4 (+ $I1 1))) -; - - (= - (expand-derivation True True $ID1 $ID1 $D1 $D1) + (= (expand-derivation True True $ID1 $ID1 $D1 $D1) (set-det)) -; - - (= - (expand-derivation - (& True $P3) $P3 - (& $ID1 $ID3) $ID3 $D1 $D1) +; /******************************************************************/ +; /* */ +; /* call : expand_derivation(+GOALCONJUNCTION1, */ +; /* -GOALCONJUNCTION2, */ +; /* +IDCONJUNCTION1, */ +; /* -IDCONJUNCTION2, */ +; /* +DERIVATION1, */ +; /* -DERIVATION2) */ +; /* */ +; /* arguments : GOALCONJUNCTION1 = actual conjunction of goals */ +; /* GOALCONJUNCTION2 = reduced conjunction of goals */ +; /* IDCONJUNCTION1 = actual goal id conjunction */ +; /* IDCONJUNCTION2 = reduced goal id conjunction */ +; /* DERIVATION1 = actual derivation tree */ +; /* DERIVATION2 = expanded derivation tree */ +; /* */ +; /******************************************************************/ +; /* Given a conjunction of goals (GOALCONJUNCTION1), a conjunction */ +; /* of the corresponding goal ids (IDCONJUNCTION1) and a previous */ +; /* derivation (DERIVATION1) this predicate generates the expanded */ +; /* derivation tree (DERIVATION2) while solving (in a backward- */ +; /* chaining manner) a goal of GOALCONJUNCTION1. It returns the */ +; /* still unsolved goals in GOALCONJUNCTION2 and their */ +; /* corresponding goal ids in IDCONJUNCTION2. Notice, this is a */ +; /* kind of PROLOG meta-interpreter, which collect the derivation */ +; /* tree. Derivation tree's in the sense of this programm are */ +; /* ordered, ::-connected lists. */ +; /******************************************************************/ + (= (expand-derivation (& True $P3) $P3 (& $ID1 $ID3) $ID3 $D1 $D1) (set-det)) -; - - (= - (expand-derivation - (& $P1 $P3) $P5 - (& $ID1 $ID3) $ID5 $D1 $D3) - ( (expand-derivation- $P1 $P2 $ID1 $ID2 $D1 $D2) - (join-goals - (& $P2 $P3) $P4 - (& $ID2 $ID3) $ID4) - (expand-derivation $P4 $P5 $ID4 $ID5 $D2 $D3))) -; - -; (error -; (syntax_error operator_expected) -; (file discr/discr.pl 201 8 11767)) + (= (expand-derivation (& $P1 $P3) $P5 (& $ID1 $ID3) $ID5 $D1 $D3) + (expand-derivation- $P1 $P2 $ID1 $ID2 $D1 $D2) + (join-goals + (& $P2 $P3) $P4 + (& $ID2 $ID3) $ID4) + (expand-derivation $P4 $P5 $ID4 $ID5 $D2 $D3)) +; (error +; (syntax_error operator_expected) +; (file discr/discr.pl 201 8 11767)) - (= - (expand-derivation- $P1 $P2 $ID1 $ID2 - (:: $I1 $D1) - (:: $I2 $D2)) - ( (:: $C - (<- $P1 $P2)) - (generate-goal-ids $P2 $ID2 $I1 $I2) - (= $D2 - (:: - (:: $D1 $C) - (<- $ID1 $ID2))))) -; - + (= (expand-derivation- $P1 $P2 $ID1 $ID2 (:: $I1 $D1) (:: $I2 $D2)) + (:: $C + (<- $P1 $P2)) + (generate-goal-ids $P2 $ID2 $I1 $I2) + (= $D2 + (:: + (:: $D1 $C) + (<- $ID1 $ID2)))) - (= - (join-goals - (& $P1 - (& $P2 $P3)) - (& $P1 $P5) - (& $ID1 - (& $ID3 $ID3)) - (& $ID1 $ID5)) - ( (set-det) (join-goals (& $P2 $P3) $P5 (& $ID2 $ID3) $ID5))) -; - - (= + (= (join-goals (& $P1 (& $P2 $P3)) (& $P1 $P5) (& $ID1 (& $ID3 $ID3)) (& $ID1 $ID5)) + (set-det) (join-goals - (& True $P3) $P3 - (& $ID1 $ID3) $ID3) + (& $P2 $P3) $P5 + (& $ID2 $ID3) $ID5)) +; /******************************************************************/ +; /* */ +; /* call : join_goals(+GOALCONJUNCTION1,-GOALCONJUNCTION2, */ +; /* +IDCONJUNCTION1,-IDCONJUNCTION2) */ +; /* */ +; /* arguments : GOALCONJUNCTION1 = actual conjunction of goals */ +; /* GOALCONJUNCTION2 = joined conjunction of goals */ +; /* IDCONJUNCTION1 = actual goal id conjunction */ +; /* IDCONJUNCTION2 = joined goal id conjunction */ +; /* */ +; /******************************************************************/ +; /* The joining of goals is done by this predicate. */ +; /******************************************************************/ + (= (join-goals (& True $P3) $P3 (& $ID1 $ID3) $ID3) (set-det)) -; + (= (join_goals $P1 $P1 $ID1 $ID1) True) - (= - (join_goals $P1 $P1 $ID1 $ID1) True) -; +; (error +; (syntax_error operator_expected) +; (file discr/discr.pl 248 8 14466)) -; (error -; (syntax_error operator_expected) -; (file discr/discr.pl 248 8 14466)) + (= (spec $T1 $T2) + (ground $T2 1 $_) + (= $T1 $T2)) - (= - (spec $T1 $T2) - ( (ground $T2 1 $_) (= $T1 $T2))) -; - - - - (= - (ground - (skolem-function $N1) $N1 $N2) - ( (set-det) (is $N2 (+ $N1 1)))) -; - - (= - (ground $T $N1 $N2) - ( (=.. $T - (Cons $_ $TS)) - (== $TS Nil) - (set-det))) -; - - (= - (ground $T $N1 $N2) - ( (=.. $T - (Cons $_ $TS)) (grounds $TS $N1 $N2))) -; - - - - (= - (grounds - (Cons $T $TS) $N1 $N3) - ( (ground $T $N1 $N2) (grounds $TS $N1 $N2))) -; + (= (ground (skolem-function $N1) $N1 $N2) + (set-det) + (is $N2 + (+ $N1 1))) + (= (ground $T $N1 $N2) + (=.. $T + (Cons $_ $TS)) + (== $TS Nil) + (set-det)) + (= (ground $T $N1 $N2) + (=.. $T + (Cons $_ $TS)) + (grounds $TS $N1 $N2)) - (= - (grounds () $N1 $N1) True) -; + (= (grounds (Cons $T $TS) $N1 $N3) + (ground $T $N1 $N2) + (grounds $TS $N1 $N2)) + (= (grounds () $N1 $N1) True) - (= - (generate-discriminants $P $PA $PR) + (= (generate-discriminants $P $PA $PR) ( (generate-goal-ids $P $ID 1 $_) (determine-discriminant (:: @@ -226,139 +297,119 @@ (:: (:: (:: $PA $IA) $PR) $IR)) - (add-symbol &self + (add-is-symbol &self (:: disc $PA)) (write (:: disc $PA)) (nl) (fail))) -; - - (= - (generate_discriminants $_ $_ $_) True) -; - - -; (error -; (syntax_error operator_expected) -; (file discr/discr.pl 293 8 16547)) - - - (= - (determine-discriminant +; /******************************************************************/ +; /* */ +; /* call : generate_discriminants(+EXPRESSION, */ +; /* -DISCRIMINANT1, */ +; /* -DISCRIMINANT2) */ +; /* */ +; /* arguments : EXPRESSION = Expression to be specialized */ +; /* DISCRIMINANT1 = */ +; /* DISCRIMINANT2 = */ +; /* */ +; /* side effects: Asserting discriminants in the database */ +; /* */ +; /******************************************************************/ +; /* Generates all possible discriminants an asserts them in the */ +; /* database. More than one discriminant can be generated, if more */ +; /* the EXPRESSION is computable from more than one derivations. */ +; /* See discr_2.pro for an example. All discriminants generated */ +; /* should be specific enough so that they would fail in all */ +; /* rejection contexts. As we can see from discr_2.pro this is not */ +; /* the case for the second discriminant !. */ +; /******************************************************************/ + (= (generate_discriminants $_ $_ $_) True) + +; (error +; (syntax_error operator_expected) +; (file discr/discr.pl 293 8 16547)) + + + (= (determine-discriminant (:: (:: (:: (& True $PA3) (& $_ $IA3)) (& True $PR3)) (& $_ $IR3)) $P3) + (set-det) + (= $P3 (:: (:: - (:: - (& True $PA3) - (& $_ $IA3)) - (& True $PR3)) - (& $_ $IR3)) $P3) - ( (set-det) (= $P3 (:: (:: (:: $PA3 $IA3) $PR3) $IR3)))) -; - - (= + (:: $PA3 $IA3) $PR3) $IR3))) + (= (determine-discriminant (:: (:: (:: (& $PA1 $PA3) (& $IA1 $IA3)) (& $PR1 $PR3)) (& $IR1 $IR3)) $P3) (determine-discriminant (:: (:: - (:: - (& $PA1 $PA3) - (& $IA1 $IA3)) - (& $PR1 $PR3)) - (& $IR1 $IR3)) $P3) - ( (determine-discriminant - (:: - (:: - (:: $PA1 $IA1) $PR1) $IR1) + (:: $PA1 $IA1) $PR1) $IR1) + (:: (:: - (:: - (:: $PA2 $IA2) $PR2) $IR2)) - (join-goals - (& $PA2 $PA3) $PA5 - (& $IA2 $IA3) $IA5) - (join-goals - (& $PR2 $PR3) $PR5 - (& $IR2 $IR3) $IR5) - (= $P3 + (:: $PA2 $IA2) $PR2) $IR2)) + (join-goals + (& $PA2 $PA3) $PA5 + (& $IA2 $IA3) $IA5) + (join-goals + (& $PR2 $PR3) $PR5 + (& $IR2 $IR3) $IR5) + (= $P3 + (:: (:: - (:: - (:: $PA5 $IA5) $PR5) $IR5)))) -; - - (= + (:: $PA5 $IA5) $PR5) $IR5))) + (= (determine-discriminant (:: (:: (:: (& $PA1 $PA3) (& $IA1 $IA3)) (& $PR1 $PR3)) (& $IR1 $IR3)) $P3) (determine-discriminant (:: (:: - (:: - (& $PA1 $PA3) - (& $IA1 $IA3)) - (& $PR1 $PR3)) - (& $IR1 $IR3)) $P3) - ( (determine-discriminant + (:: $PA3 $IA3) $PR3) $IR3) + (:: (:: - (:: - (:: $PA3 $IA3) $PR3) $IR3) + (:: $PA4 $IA4) $PR4) $IR4)) + (= $P3 + (:: (:: (:: - (:: $PA4 $IA4) $PR4) $IR4)) (= $P3 (:: (:: (:: (& $PA1 $PA4) (& $IA1 $IA4)) (& $PR1 $PR4)) (& $IR1 $PR4))))) -; + (& $PA1 $PA4) + (& $IA1 $IA4)) + (& $PR1 $PR4)) + (& $IR1 $PR4)))) +; (error +; (syntax_error operator_expected) +; (file discr/discr.pl 305 8 17158)) -; (error -; (syntax_error operator_expected) -; (file discr/discr.pl 305 8 17158)) - - (= - (determine-discriminant- $P1 $P3) - ( (= $P1 + (= (determine-discriminant- $P1 $P3) + (= $P1 + (:: (:: - (:: - (:: $PA1 $IA1) $PR1) $IR1)) + (:: $PA1 $IA1) $PR1) $IR1)) + (:: $CA + (<- $PA1 $PA2)) + (:: app $DA) + (in-derivation-p (:: $CA - (<- $PA1 $PA2)) - (:: app $DA) - (in-derivation-p - (:: $CA - (<- $IA1 $IA2)) $DA) + (<- $IA1 $IA2)) $DA) + (:: $CR + (<- $PR1 $PR2)) + (:: rej $DR) + (in-derivation-p (:: $CR - (<- $PR1 $PR2)) - (:: rej $DR) - (in-derivation-p - (:: $CR - (<- $IR1 $IR2)) $DR) - (= $P3 + (<- $IR1 $IR2)) $DR) + (= $P3 + (:: (:: - (:: - (:: $PA2 $IA2) $PR2) $IR2)))) -; - + (:: $PA2 $IA2) $PR2) $IR2))) - (= - (in-derivation-p - (:: $X $C) - (:: - (:: $DER $X) $C)) + (= (in-derivation-p (:: $X $C) (:: (:: $DER $X) $C)) (set-det)) -; - - (= - (in-derivation-p - (:: $X $C) - (:: $DER $_)) + (= (in-derivation-p (:: $X $C) (:: $DER $_)) (in-derivation-p (:: $X $C) $DER)) -; - - (= - (help) - ( (write 'Load data set with command: [Filename].') (nl))) -; - + (= (help) + (write 'Load data set with command: [Filename].') + (nl)) !(help *) -; - diff --git a/discr/discr_1.metta b/discr/discr_1.metta index aa01a9a..0439436 100644 --- a/discr/discr_1.metta +++ b/discr/discr_1.metta @@ -1,43 +1,35 @@ +; (convert_to_metta_file discr_1 $_60876 discr/discr_1.pl discr/discr_1.metta) - (= - (ex1) - ( (exc1) - (derivation - (<- q - (& u v)) app) - (derivation - (<- q - (& w v)) rej) - (generate-discriminants q $_ $_))) -; + (= (ex1) + (exc1) + (derivation + (<- q + (& u v)) app) + (derivation + (<- q + (& w v)) rej) + (generate-discriminants q $_ $_)) - - (= - (exc1) + (= (exc1) ( (abolish :: 2) - (add-symbol &self + (add-is-symbol &self (:: c1 (<- q (& s r)))) - (add-symbol &self + (add-is-symbol &self (:: c2 (<- s t))) - (add-symbol &self + (add-is-symbol &self (:: c3 (<- s w))) - (add-symbol &self + (add-is-symbol &self (:: c4 (<- t u))) - (add-symbol &self + (add-is-symbol &self (:: c5 (<- r v))))) -; - - - (= - (?- ex1) True) -; + (= (?- ex1) True) diff --git a/discr/discr_2.metta b/discr/discr_2.metta index 1086070..5f43151 100644 --- a/discr/discr_2.metta +++ b/discr/discr_2.metta @@ -1,29 +1,26 @@ +; (convert_to_metta_file discr_2 $_115544 discr/discr_2.pl discr/discr_2.metta) - (= - (ex2) - ( (exc2) - (derivation - (<- - (term (:: t1 t2)) - (& - (const t1) - (const t2))) app) - (derivation - (<- - (term (:: t1 t2)) - (& - (termv t1) - (termc t2))) rej) - (generate-discriminants - (term (:: t1 t2)) $_ $_))) -; + (= (ex2) + (exc2) + (derivation + (<- + (term (:: t1 t2)) + (& + (const t1) + (const t2))) app) + (derivation + (<- + (term (:: t1 t2)) + (& + (termv t1) + (termc t2))) rej) + (generate-discriminants + (term (:: t1 t2)) $_ $_)) - - (= - (exc2) + (= (exc2) ( (abolish :: 2) - (add-symbol &self + (add-is-symbol &self (:: c1 (<- (term $X) @@ -33,17 +30,17 @@ (& (term $X1) (term $X2)))))) - (add-symbol &self + (add-is-symbol &self (:: c2 (<- (term $X) (termc $X)))) - (add-symbol &self + (add-is-symbol &self (:: c3 (<- (term $X) (termv $X)))) - (add-symbol &self + (add-is-symbol &self (:: c4 (<- (termc $X) @@ -53,12 +50,12 @@ (& (termc $X1) (termc $X2)))))) - (add-symbol &self + (add-is-symbol &self (:: c5 (<- (termc $X) (const $X)))) - (add-symbol &self + (add-is-symbol &self (:: c6 (<- (termv $X) @@ -66,7 +63,7 @@ (:= (:: $X1 $X2) $X) (termv $X1))))) - (add-symbol &self + (add-is-symbol &self (:: c7 (<- (termv $X) @@ -74,23 +71,18 @@ (:= (:: $X1 $X2) $X) (termv $X2))))) - (add-symbol &self + (add-is-symbol &self (:: c8 (<- (termv $X) (var $X)))) - (add-symbol &self + (add-is-symbol &self (:- (:: c9 (<- (:= $X1 $X2) true)) (:= $X1 $X2))))) -; - - - (= - (?- ex2) True) -; + (= (?- ex2) True) diff --git a/ebg/ebg.metta b/ebg/ebg.metta index 429a5fe..23989e4 100644 --- a/ebg/ebg.metta +++ b/ebg/ebg.metta @@ -1,237 +1,348 @@ - - (= - (prove-1 (, $HEAD $REST)) - ( (set-det) - (prove-1 $HEAD) - (prove-1 $REST))) -; - - (= - (prove-1 $FACT) - (get-symbols &self - (= $FACT true))) -; - - (= - (prove-1 $GOAL) - ( (get-symbols &self - (= $GOAL $PREMISSES)) (prove-1 $PREMISSES))) -; - - (= - (prove-1 $GOAL) +; (convert_to_metta_file ebg $_176472 ebg/ebg.pl ebg/ebg.metta) + + (= (prove-1 (, $HEAD $REST)) + (set-det) + (prove-1 $HEAD) + (prove-1 $REST)) +; /******************************************************************/ +; /* EBG.PRO Last Modification: Fri Jan 14 19:23:23 1994 */ +; /* Different meta-interpreters for Mitchell's explanation-based */ +; /* generalisation and partial evaluation */ +; /******************************************************************/ +; ; ; Copyright (c) 1988 Thomas Hoppe ; ; This program is free software; you can redistribute it and/or ; modify it under the terms of the GNU General Public License ; Version 1 as published by the Free Software Foundation. ; ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; ; You should have received a copy of the GNU General Public ; Licensealong with this program; if not, write to the Free ; Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, ; USA. ; +; /******************************************************************/ +; /* impl. by : Thomas Hoppe */ +; /* Mommsenstr. 50 */ +; /* D-10629 Berlin */ +; /* F.R.G. */ +; /* E-Mail: hoppet@cs.tu-berlin.de */ +; /* 1988 */ +; /* */ +; /* reference : Explanation-Based Generalisation as Resolution */ +; /* Theorem Proving, Smadar T. Kedar-Cabelli, L. */ +; /* Thorne McCharty, Proceedings of the Fourth */ +; /* International Workshop on Machine Learning, */ +; /* Irvine, Morgan Kaufmann Publishers, California, */ +; /* 1987 */ +; /* */ +; /* Explanation-Based Generalisation = Partial */ +; /* Evaluation, van Harmelen, F., Bundy, A., */ +; /* Research Note, AI 36, 1988. */ +; /* */ +; /******************************************************************/ +; ; TH Sun May 30 00:06:23 1993 - made some minor modifications +; /* This is YAP-MeTTa specific */ +; ; :- do_not_compile_expressions. +; /******************************************************************/ +; /* */ +; /* call : prove_1 (+GOAL) */ +; /* */ +; /* arguments : GOAL = instantiated goal for a proof */ +; /* */ +; /* properties : backtrackable */ +; /* */ +; /******************************************************************/ +; /* prove_1 implements a PROLOG meta-interpreter, which succeds if */ +; /* GOAL is deducible from a PROLOG program. */ +; /* In opposite to the literature the last clause is necessary to */ +; /* handle PROLOG built-in predicates corret. */ +; /******************************************************************/ + (= (prove-1 $FACT) + (== + (= $FACT true) + (get-atoms &self))) + (= (prove-1 $GOAL) + ( (== + (= $GOAL $PREMISSES) + (get-atoms &self)) (prove-1 $PREMISSES))) + (= (prove-1 $GOAL) (call $GOAL)) -; - - - - (= - (prove-2 - (, $HEAD $REST) $PROOF) - ( (set-det) - (prove-2 $HEAD $HEAD_PROOF) - (prove-2 $REST $REST_PROOF) - (append $HEAD_PROOF $REST_PROOF $PROOF))) -; - - (= - (prove-2 $FACT - (:: $FACT)) - (get-symbols &self - (= $FACT true))) -; - - (= - (prove-2 $GOAL $PROOF) - ( (get-symbols &self - (= $GOAL $PREMISSES)) + + + (= (prove-2 (, $HEAD $REST) $PROOF) + (set-det) + (prove-2 $HEAD $HEAD_PROOF) + (prove-2 $REST $REST_PROOF) + (append $HEAD_PROOF $REST_PROOF $PROOF)) +; /******************************************************************/ +; /* */ +; /* call : prove_2 (+GOAL,-PROOF) */ +; /* */ +; /* arguments : GOAL = instantiated goal for a proof */ +; /* PROOF = proof tree for GOAL */ +; /* */ +; /* properties : backtrackable */ +; /* */ +; /******************************************************************/ +; /* prove_2 is the extention of prove_1 to deliver the PROOF for */ +; /* the GOAL, if GOAL is deducible from a PROLOG program. */ +; /* In opposite to the literature the last clause is necessary to */ +; /* handle PROLOG built-in predicates corret. */ +; /* On backtracking it gives the next possible prove. */ +; /******************************************************************/ + (= (prove-2 $FACT (:: $FACT)) + (== + (= $FACT true) + (get-atoms &self))) + (= (prove-2 $GOAL $PROOF) + ( (== + (= $GOAL $PREMISSES) + (get-atoms &self)) (not (== $PREMISSES True)) (prove-2 $PREMISSES $PREM_PROOF) (append (:: $GOAL) (:: $PREM_PROOF) $PROOF))) -; - - (= - (prove-2 $GOAL - (:: $GOAL)) + (= (prove-2 $GOAL (:: $GOAL)) (call $GOAL)) -; - - (= - (prove-3 - (, $HEAD $REST) $PROOF) - ( (set-det) - (prove-3 $HEAD $HEAD_PROOF) - (prove-3 $REST $REST_PROOF) - (append $HEAD_PROOF $REST_PROOF $PROOF))) -; - -; (error -; (syntax_error operator_expected) -; (file ebg/ebg.pl 124 8 6850)) - - (= - (prove-3 $GOAL $PROOF) - ( (get-symbols &self - (= $GOAL $PREMISSES)) + (= (prove-3 (, $HEAD $REST) $PROOF) + (set-det) + (prove-3 $HEAD $HEAD_PROOF) + (prove-3 $REST $REST_PROOF) + (append $HEAD_PROOF $REST_PROOF $PROOF)) +; /******************************************************************/ +; /* */ +; /* call : prove_3 (+GOAL,-PROOF) */ +; /* */ +; /* arguments : GOAL = instantiated goal for a proof */ +; /* PROOF = proof tree for GOAL */ +; /* */ +; /* properties : backtrackable */ +; /* */ +; /******************************************************************/ +; /* prove_3 is an extention of prove_2 to deliver generalized */ +; /* PROOFS for the GOAL, if GOAL is deducible from a pure PROLOG */ +; /* program. */ +; /* The call 'not (not clause(FACT,true))' is a special PROLOG */ +; /* trick, which succeds if 'clause(FACT,true)' holds, without */ +; /* instanciating GOAL. */ +; /* A sublist of length 1 in the PROOF denotes a fact, which has */ +; /* to be instanciated to fulfill the proof. */ +; /* The first element of a list is the subtree goal. */ +; /* On backtracking it gives the next possible prove path. */ +; /******************************************************************/ +; (error +; (syntax_error operator_expected) +; (file ebg/ebg.pl 124 8 6850)) + + (= (prove-3 $GOAL $PROOF) + ( (== + (= $GOAL $PREMISSES) + (get-atoms &self)) (not (== $PREMISSES True)) (prove-3 $PREMISSES $PREM_PROOF) (append (:: $GOAL) (:: $PREM_PROOF) $PROOF))) -; - - (= - (prove_3 $GOAL - ($GOAL)) True) -; - - - - (= - (prove-4 - (or $HEAD $REST) $PROOF) - ( (set-det) (or (prove-4 $HEAD $PROOF) (prove-4 $REST $PROOF)))) -; - - (= - (prove-4 - (, $HEAD $REST) $PROOF) - ( (set-det) - (prove-4 $HEAD $HEAD_PROOF) - (prove-4 $REST $REST_PROOF) - (append $HEAD_PROOF $REST_PROOF $PROOF))) -; - -; (error -; (syntax_error operator_expected) -; (file ebg/ebg.pl 155 8 8557)) + (= (prove_3 $GOAL ($GOAL)) True) + + + (= (prove-4 (or $HEAD $REST) $PROOF) + (set-det) + (or + (prove-4 $HEAD $PROOF) + (prove-4 $REST $PROOF))) +; /******************************************************************/ +; /* */ +; /* call : prove_4 (+GOAL,-FACTS) */ +; /* */ +; /* arguments : GOAL = uninstantiated goal for a proof */ +; /* FACTS = List of FACTS which must hold for a */ +; /* proof of GOAL */ +; /* */ +; /* properties : backtrackable */ +; /* */ +; /******************************************************************/ +; /* prove_4 is an extention of prove_3 to delivers the generalized */ +; /* FACTS that must be true for a proof of GOAL, if GOAL is */ +; /* deducible from a pure PROLOG program. */ +; /* With this predicat a partial evaluation of the theory according*/ +; /* to the GOAL is possible */ +; /* On backtracking it gives the next partial evaluation. */ +; /******************************************************************/ + (= (prove-4 (, $HEAD $REST) $PROOF) + (set-det) + (prove-4 $HEAD $HEAD_PROOF) + (prove-4 $REST $REST_PROOF) + (append $HEAD_PROOF $REST_PROOF $PROOF)) +; (error +; (syntax_error operator_expected) +; (file ebg/ebg.pl 155 8 8557)) -; (error -; (syntax_error operator_expected) -; (file ebg/ebg.pl 157 8 8632)) - - (= - (prove_4 $GOAL - ($GOAL)) True) -; - - - - (= - (prove-5 - (, $HEAD $REST) - (Cons $PROOF_HEAD $PROOF_REST) $LIST) - ( (set-det) - (prove-5 $HEAD $PROOF_HEAD $PROOF_LIST1) - (prove-5 $REST $PROOF_REST $PROOF_LIST2) - (append $PROOF_LIST1 $PROOF_LIST2 $LIST))) -; - -; (error -; (syntax_error operator_expected) -; (file ebg/ebg.pl 187 8 10387)) - - (= - (prove-5 $GOAL - (:: $GOAL $PROOF) $LIST) - ( (get-symbols &self - (= $GOAL $PREMISSES)) +; (error +; (syntax_error operator_expected) +; (file ebg/ebg.pl 157 8 8632)) + + (= (prove_4 $GOAL ($GOAL)) True) + + + (= (prove-5 (, $HEAD $REST) (Cons $PROOF_HEAD $PROOF_REST) $LIST) + (set-det) + (prove-5 $HEAD $PROOF_HEAD $PROOF_LIST1) + (prove-5 $REST $PROOF_REST $PROOF_LIST2) + (append $PROOF_LIST1 $PROOF_LIST2 $LIST)) +; /******************************************************************/ +; /* */ +; /* call : prove_5 (+GOAL,-PROOF,-FACTS) */ +; /* */ +; /* arguments : GOAL = uninstantiated goal for a proof */ +; /* PROOF = proof tree for GOAL */ +; /* FACTS = List of FACTS which must hold for a */ +; /* proof of GOAL */ +; /* */ +; /* properties : backtrackable */ +; /* */ +; /******************************************************************/ +; /* prove_5 is a combination of prove_3 and prove_4 to delivers the*/ +; /* generalized FACTS that must be true for a proof of GOAL and the*/ +; /* proof path, if GOAL is deducible from a pure PROLOG program. */ +; /* So one can get the information which predicates must be */ +; /* instantiated to a particular prove path. */ +; /* On backtracking it gives the next possible prove path and the */ +; /* predicats that must be instanciated. */ +; /******************************************************************/ +; (error +; (syntax_error operator_expected) +; (file ebg/ebg.pl 187 8 10387)) + + (= (prove-5 $GOAL (:: $GOAL $PROOF) $LIST) + ( (== + (= $GOAL $PREMISSES) + (get-atoms &self)) (not (== $PREMISSES True)) (prove-5 $PREMISSES $PROOF $LIST))) -; - - (= - (prove_5 $GOAL - ($GOAL) - ($GOAL)) True) -; - - - - (= - (prove-6 - (, $HEAD $REST) - (, $GEN_HEAD $GEN_REST) $LIST) - ( (set-det) - (prove-6 $HEAD $GEN_HEAD $LIST1) - (prove-6 $REST $GEN_REST $LIST2) - (append $LIST1 $LIST2 $LIST))) -; - - (= - (prove-6 $GOAL $GEN_GOAL - (:: $GEN_GOAL)) - ( (operational $GOAL) (set-det))) -; - -; (error -; (syntax_error operator_expected) -; (file ebg/ebg.pl 218 8 12142)) - - - - (= - (listify - ($H) $H) True) -; - - (= - (listify - (Cons $H $R) - (, $H $S)) + (= (prove_5 $GOAL ($GOAL) ($GOAL)) True) + + + (= (prove-6 (, $HEAD $REST) (, $GEN_HEAD $GEN_REST) $LIST) + (set-det) + (prove-6 $HEAD $GEN_HEAD $LIST1) + (prove-6 $REST $GEN_REST $LIST2) + (append $LIST1 $LIST2 $LIST)) +; /******************************************************************/ +; /* */ +; /* call : prove_6 (+GOAL1,+GOAL2,-FACTS) */ +; /* */ +; /* arguments : GOAL1 = instantiated goal for a paticular proof */ +; /* GOAL2 = generalized goal */ +; /* FACTS = List of FACTS which must hold for a */ +; /* proof of GOAL */ +; /* */ +; /* properties : backtrackable */ +; /* */ +; /******************************************************************/ +; /* prove_6 is an extention of prove_4 to handle the operationality*/ +; /* criterion mentioned by Mitchell/Keller/Kedar-Cabelli (1986). */ +; /* It delivers the generalized FACTS that must be true for a */ +; /* paticular proof of GOAL1, if GOAL1 is deducible from a PROLOG */ +; /* program. */ +; /* On backtracking it gives the next possible prove path. */ +; /******************************************************************/ + (= (prove-6 $GOAL $GEN_GOAL (:: $GEN_GOAL)) + (operational $GOAL) + (set-det)) +; (error +; (syntax_error operator_expected) +; (file ebg/ebg.pl 218 8 12142)) + + + + (= (listify ($H) $H) True) +; /******************************************************************/ +; /* */ +; /* call : listify (LIST,PREMISSES) */ +; /* */ +; /* arguments : LIST = normal PROLOG list */ +; /* PREMISSES = normal PROLOG and-concatenated */ +; /* premisse_list */ +; /* */ +; /* properties : backtrackable, symmetric */ +; /* */ +; /******************************************************************/ +; /* listify builds a PROLOG and-cocatenated premisse list out of */ +; /* every normal list, respecively vice versa. */ +; /* One predicat must be instantiated. */ +; /******************************************************************/ + (= (listify (Cons $H $R) (, $H $S)) (listify $R $S)) -; - - (= - (copy $TERM1 $TERM2) - ( (add-symbol &self + (= (copy $TERM1 $TERM2) + ( (add-is-symbol &self (internal $TERM1)) - (remove-symbol &self + (remove-is-symbol &self (internal $TERM2)) (set-det))) -; - - - - (= - (operational $A) - (get-symbols &self - (= $A true))) -; - -; (error -; (syntax_error operator_expected) -; (file ebg/ebg.pl 277 8 15501)) - - - - (= - (ebg $GOAL $RULE) - ( (functor $GOAL $F $N) - (functor $COPY $F $N) - (call $GOAL) - (prove-6 $GOAL $COPY $ZWERG1) - (listify $ZWERG1 $ZWERG2) - (= $RULE - (= $COPY $ZWERG2)))) -; - - - - (= - (help) - ( (write 'Load example theories and start EBG with command: [Filename].') (nl))) -; - +; /******************************************************************/ +; /* */ +; /* call : copy (+TERM1,-TERM2) */ +; /* */ +; /* arguments : TERM1 = normal PROLOG term */ +; /* TERM2 = normal PROLOG term */ +; /* */ +; /******************************************************************/ +; /* copy makes copy's of every PROLOG-Term, with the special */ +; /* database trick to ensure that new variables are generated in */ +; /* the output term. */ +; /******************************************************************/ +; ; inst(TERM1,TERM2), + + + (= (operational $A) + (== + (= $A true) + (get-atoms &self))) +; /******************************************************************/ +; /* */ +; /* call : operational (+TERM) */ +; /* */ +; /* arguments : TERM = normal PROLOG term */ +; /* */ +; /******************************************************************/ +; /* operational is an predicat for the decision of operaionality */ +; /* in EBL-based algorithms. It's definition must be changed */ +; /* depending on the operationality criterion's of a particular */ +; /* implementation. */ +; /* The first clause ensures that normal PROLOG facts are */ +; /* operational. */ +; /* The second clause is a check for built-in predicats which are */ +; /* not defined, but can be evaluated. */ +; /******************************************************************/ +; (error +; (syntax_error operator_expected) +; (file ebg/ebg.pl 277 8 15501)) + + + + (= (ebg $GOAL $RULE) + (functor $GOAL $F $N) + (functor $COPY $F $N) + (call $GOAL) + (prove-6 $GOAL $COPY $ZWERG1) + (listify $ZWERG1 $ZWERG2) + (= $RULE + (= $COPY $ZWERG2))) +; /******************************************************************/ +; /* */ +; /* call : ebg (GOAL,RULE) */ +; /* */ +; /* arguments : GOAL = a goal which is to be proven */ +; /* RULE = a generalized rule for the proof */ +; /* */ +; /******************************************************************/ +; /* ebg is a predicate which first proves a goal to find a */ +; /* solution, and afterwards it takes the solution and generates a */ +; /* rule out of the proof tree. The solution is returned as a */ +; /* generalisation for the prove tree. */ +; /******************************************************************/ + + + (= (help) + (write 'Load example theories and start EBG with command: [Filename].') + (nl)) !(help *) -; - diff --git a/ebg/ebg_1.metta b/ebg/ebg_1.metta index c6d2487..96f844b 100644 --- a/ebg/ebg_1.metta +++ b/ebg/ebg_1.metta @@ -1,56 +1,27 @@ +; (convert_to_metta_file ebg_1 $_448136 ebg/ebg_1.pl ebg/ebg_1.metta) - (= - (depressed john) True) -; + (= (depressed john) True) + (= (buy john gun1) True) - (= - (buy john gun1) True) -; + (= (gun gun1) True) - (= - (gun gun1) True) -; + (= (kill $A $B) + (hate $A $B) + (possess $A $C) + (weapon $C)) - - - (= - (kill $A $B) - ( (hate $A $B) - (possess $A $C) - (weapon $C))) -; - - - (= - (hate $W $W) + (= (hate $W $W) (depressed $W)) -; - - (= - (possess $U $V) + (= (possess $U $V) (buy $U $V)) -; - - (= - (weapon $Z) + (= (weapon $Z) (gun $Z)) -; - - - (= - (?- - (; - (, - (ebg - (kill john john) $L) - (, - (write $L) fail)) true)) True) -; + (= (?- (; (, (ebg (kill john john) $L) (, (write $L) fail)) true)) True) diff --git a/ebg/ebg_2.metta b/ebg/ebg_2.metta index e6fd1d4..362aeb3 100644 --- a/ebg/ebg_2.metta +++ b/ebg/ebg_2.metta @@ -1,92 +1,42 @@ +; (convert_to_metta_file ebg_2 $_501270 ebg/ebg_2.pl ebg/ebg_2.metta) - (= - (on o1 o2) True) -; + (= (on o1 o2) True) + (= (isa o1 box) True) + (= (isa o2 endtable) True) - (= - (isa o1 box) True) -; + (= (color o1 red) True) + (= (color o2 blue) True) - (= - (isa o2 endtable) True) -; + (= (volume o1 1) True) + (= (density o1 2) True) - (= - (color o1 red) True) -; + (= (isa o3 box) True) - (= - (color o2 blue) True) -; + (= (volume o3 6) True) + (= (density o3 2) True) - (= - (volume o1 1) True) -; - - (= - (density o1 2) True) -; - - - (= - (isa o3 box) True) -; - - - (= - (volume o3 6) True) -; - - - (= - (density o3 2) True) -; - - - - (= - (save-to-stack $X $Y) + (= (save-to-stack $X $Y) (lighter $X $Y)) -; - - - (= - (weight $O $W) - ( (volume $O $V) - (density $O $D) - (is $W - (* $V $D)))) -; + (= (weight $O $W) + (volume $O $V) + (density $O $D) + (is $W + (* $V $D))) - (= - (lighter $O1 $O2) - ( (weight $O1 $W1) - (weight $O2 $W2) - (< $W1 $W2))) -; + (= (lighter $O1 $O2) + (weight $O1 $W1) + (weight $O2 $W2) + (< $W1 $W2)) - - (= - (weight $O 5) + (= (weight $O 5) (isa $O endtable)) -; - - - (= - (?- - (; - (, - (ebg - (save_to_stack o1 o2) $L) - (, - (write $L) fail)) true)) True) -; + (= (?- (; (, (ebg (save_to_stack o1 o2) $L) (, (write $L) fail)) true)) True) diff --git a/foil/foil.metta b/foil/foil.metta index 81dbbda..e692718 100644 --- a/foil/foil.metta +++ b/foil/foil.metta @@ -1,127 +1,86 @@ +; (convert_to_metta_file foil $_46614 foil/foil.pl foil/foil.metta) !(ensure-loaded (library occurs)) -; - - !(ensure-loaded (library basics)) -; - - !(ensure-loaded (library lists)) -; - - !(ensure-loaded (library between)) -; - - !(ensure-loaded (library math)) -; - +; /*************************************************************************** FILE: FOIL.PL PROGRAMMER: John Zelle DATE: 2/10/92 DESCRIPTION: A MeTTa implementation of the FOIL (First Order Inductive Learning) algorithm for learning relational concept definitions. For backgound on the algorithm, see : Quinlan, J. R., "Learning Logical Definitions from Relations," in Machine Learning, 5, 1990. The version presented here is somewhat simplified in that it uses a much weaker test to constrain recursive predicates (a recursive call must contain vars not found in the head of of a clause, and may not introduce any unbound vars), and it does not incorporate encoding length restrictions to handle noisy data. There is also no post-processing of clauses to simplify learned definitions, although this would be relatively easy to add. This is a very simple implementation which recomputes tuple sets "on the fly". Don't expect it to run like the wind. LANGUAGE: Quintus MeTTa v. 3.1 MODIFIED: 3/30/92 (JMZ) Added determinate literals. See article: Quinlan, J. R., "Determinate Literals in Inductive Logic Programming," in Proceedings of the Eighth International Workshop in Machine Learning, 1991 INPUT FORM: The background knowledge for predicate induction is represented as "existential" predicates asserted in the module, foil_input. By existential is is meant that the definitions there must be fully constructive to avoid instantiation errors when running FOIL. EXAMPLE: Definition of "list" from Quinlan's paper. This is an example input file. After consulting this definition of the module foil_input, the definition of list can be learned by invoking: foil(list(_)). ---------------------------------------------------------------------- ;Background and tuples for learning definition of list. ; This heading should be on every file used to provide ; test data for FOIL :- module(foil_input, [foil_predicates/1, foil_use_negations/1, foil_det_lit_bound/1]). foil_predicates([ list/1, null/1, components/3 ]). foil_use_negations(false). ; Don't use negations of foil_predicates foil_det_lit_bound(0). ; Don't add any determinate literals ; In general, this is a depth limit on ; the search for determinate literals ; Definitions of background predicates null([]). components([a], a, []). components([b, [a], d], b, [[a], d]). components([[a],d], [a], [d]). components([d], d, []). components([e|f], e, f). list([]). list([a]). list([b, [a], d]). list([[a], d]). list([d]). --------------------------------------------------------------------------- ***************************************************************************/ + !(ensure-loaded (library basics)) + !(ensure-loaded (library lists)) + !(ensure-loaded (library between)) + !(ensure-loaded (library math)) !(use-module (library ordsets) - (:: (/ ord-add-element 3))) -; - + (:: (/ ord-add-element 3))) ; -; - +; Run foil to attempt finding a definition for Goal and then print ; -; +; out the resulting clauses. e. g. foil(list(_)). - - (= - (foil $Goal) - ( (foil $Goal $Clauses) - (format "~n~nFOUND DEFINITION:~n~n" Nil) - (portray-clauses $Clauses))) -; - + (= (foil $Goal) + (foil $Goal $Clauses) + (format "~n~nFOUND DEFINITION:~n~n" Nil) + (portray-clauses $Clauses)) ; -; +; Pretty print a list of clauses. - - (= - (portray-clauses Nil) - (nl)) -; - - (= - (portray-clauses (Cons $H $T)) - ( (portray-clause $H) (portray-clauses $T))) -; - + (= (portray-clauses Nil) + (nl)) + (= (portray-clauses (Cons $H $T)) + (portray-clause $H) + (portray-clauses $T)) ; -; +; run foil and print running time stats. - - (= - (foil-time $Goal) - ( (statistics runtime - (Cons $T0 $_)) - (foil $Goal) - (statistics runtime - (Cons $T1 $_)) - (is $T - (- $T1 $T0)) - (format "~nRun Time = ~3d sec.~n" - (:: $T)))) -; - + (= (foil-time $Goal) + (statistics runtime + (Cons $T0 $_)) + (foil $Goal) + (statistics runtime + (Cons $T1 $_)) + (is $T + (- $T1 $T0)) + (format "~nRun Time = ~3d sec.~n" + (:: $T))) ; -; - +; Find the positive examples of Goal and construct a set of negative ; -; - +; examples using a closed world hypothesis. - (= - (get-examples $Goal $Pos $Neg) - ( (findall $Goal - (with_self - (foil-input *) $Goal) $Pos) (create-negatives $Pos $Neg))) -; - + (= (get-examples $Goal $Pos $Neg) + (findall $Goal + (with_self + (foil-input *) $Goal) $Pos) + (create-negatives $Pos $Neg)) ; -; - +; Clauses is the set of clauses defining Goal found by FOIL. Negative examples ; -; - +; are provided by a closed world assumption. - (= - (foil $Goal $Clauses) - ( (get-examples $Goal $Positives $Negatives) (foil-loop $Positives $Goal $Negatives Nil $Clauses))) -; - + (= (foil $Goal $Clauses) + (get-examples $Goal $Positives $Negatives) + (foil-loop $Positives $Goal $Negatives Nil $Clauses)) ; -; - - (= - (foil $Goal $Negatives $Clauses) - ( (findall $Goal - (with_self - (foil-input *) $Goal) $Positives) (foil-loop $Positives $Goal $Negatives Nil $Clauses))) -; - +; FOIL provided explicit negative examples. + (= (foil $Goal $Negatives $Clauses) + (findall $Goal + (with_self + (foil-input *) $Goal) $Positives) + (foil-loop $Positives $Goal $Negatives Nil $Clauses)) ; -; - +; Each iteration constructs a clause. Pos is positive examples left to ; -; - +; be covered, Goal is the concept being defined, Neg is a list of the ; -; - +; negative examples and Clauses0 is the list of clauses found in previous ; -; - +; iterations. - (= - (foil-loop $Pos $Goal $Neg $Clauses0 $Clauses) + (= (foil-loop $Pos $Goal $Neg $Clauses0 $Clauses) (det-if-then-else (= $Pos Nil) (= $Clauses $Clauses0) @@ -129,24 +88,19 @@ (format "~nUncovered positives adding a clause~n~w~n" (:: $Pos)) (extend-clause-loop $Neg $Pos - (= $Goal True) $Clause) + (= $Goal True) $Clause) (format "~n~nClause Found: ~n" Nil) (portray-clause $Clause) (uncovered-examples $Clause $Pos $Pos1) (foil-loop $Pos1 $Goal $Neg - (Cons $Clause $Clauses0) $Clauses)))) -; - + (Cons $Clause $Clauses0) $Clauses)))) ; -; - +; Add antecendents to Clause0 until it covers no negatives. Or no more info ; -; +; gain is achieved. - - (= - (extend-clause-loop $Nxs0 $Pxs0 $Clause0 $Clause) + (= (extend-clause-loop $Nxs0 $Pxs0 $Clause0 $Clause) (det-if-then-else (= $Nxs0 Nil) (= $Clause $Clause0) @@ -183,126 +137,93 @@ (, (covered-examples $Clause1 $Pxs0 $Pxs1) (covered-examples $Clause1 $Nxs0 $Nxs1) - (extend-clause-loop $Nxs1 $Pxs1 $Clause1 $Clause)))))) -; - + (extend-clause-loop $Nxs1 $Pxs1 $Clause1 $Clause)))))) ; -; - +; Find the clause which is an extension of Clause by a single literal and ; -; - +; provides maximum info gain over the original clause. - (= - (best_next_clause () $_ $_ $_ $_ $_ $Clause $Clause) True) -; - - (= - (best-next-clause - (Cons $L $Ls) $Nxs $Pxs $Clause $Info $Gain0 $Best0 $Best) - ( (add-literal $L $Clause $Best1) - (compute-gain $Nxs $Pxs $Info $Best1 $Gain1) + (= (best_next_clause () $_ $_ $_ $_ $_ $Clause $Clause) True) + (= (best-next-clause (Cons $L $Ls) $Nxs $Pxs $Clause $Info $Gain0 $Best0 $Best) + (add-literal $L $Clause $Best1) + (compute-gain $Nxs $Pxs $Info $Best1 $Gain1) + (det-if-then-else + (> $Gain1 $Gain0) + (best-next-clause $Ls $Nxs $Pxs $Clause $Info $Gain1 $Best1 $Best) (det-if-then-else - (> $Gain1 $Gain0) - (best-next-clause $Ls $Nxs $Pxs $Clause $Info $Gain1 $Best1 $Best) - (det-if-then-else - (=:= $Gain1 $Gain0) - (, - (choose-tie-clause $Best0 $Best1 $Best2) - (best-next-clause $Ls $Nxs $Pxs $Clause $Info $Gain0 $Best2 $Best)) - (best-next-clause $Ls $Nxs $Pxs $Clause $Info $Gain0 $Best0 $Best))))) -; - + (=:= $Gain1 $Gain0) + (, + (choose-tie-clause $Best0 $Best1 $Best2) + (best-next-clause $Ls $Nxs $Pxs $Clause $Info $Gain0 $Best2 $Best)) + (best-next-clause $Ls $Nxs $Pxs $Clause $Info $Gain0 $Best0 $Best)))) +; ; format("~w ~4f~n", [L, Gain1]), - (= - (choose-tie-clause - (= $A1 $B1) - (= $A2 $B2) $C) - ( (variables-in $B1 $V1) - (length $V1 $N1) - (variables-in $B2 $V2) - (length $V2 $N2) - (det-if-then-else - (< $N2 $N1) - (= $C - (= $A2 $B2)) - (= $C - (= $A1 $B1))))) -; - + (= (choose-tie-clause (= $A1 $B1) (= $A2 $B2) $C) + (variables-in $B1 $V1) + (length $V1 $N1) + (variables-in $B2 $V2) + (length $V2 $N2) + (det-if-then-else + (< $N2 $N1) + (= $C + (= $A2 $B2)) + (= $C + (= $A1 $B1)))) ; -; - +; For a set of positive and negative examples Pxs and Nxs, compute the ; -; - +; information gain of Clause over a clause which produces a split having ; -; - +; Info, as it's "information value" on these examples. - (= - (compute-gain $Nxs $Pxs $Info $Clause $Gain) - ( (covered-examples $Clause $Pxs $Retained) - (length $Retained $R) - (det-if-then-else - (=:= $R 0) - (= $Gain 0) - (, - (info-value $Clause $Pxs $Nxs $Info1) - (is $Gain - (* $R - (- $Info $Info1))))))) -; - + (= (compute-gain $Nxs $Pxs $Info $Clause $Gain) + (covered-examples $Clause $Pxs $Retained) + (length $Retained $R) + (det-if-then-else + (=:= $R 0) + (= $Gain 0) + (, + (info-value $Clause $Pxs $Nxs $Info1) + (is $Gain + (* $R + (- $Info $Info1)))))) ; -; - +; Compute the information matric for the set of positive and negative ; -; +; tuples which result from applying Clause to the examples Pxs and NXs - - (= - (info-value $Clause $Pxs $Nxs $Value) - ( (tuples $Clause $Pxs $Ptuples) - (length $Ptuples $P) - (det-if-then-else - (=:= $P 0) - (= $Value 0) - (, - (tuples $Clause $Nxs $Ntuples) - (length $Ntuples $N) - (is $Temp - (/ $P - (+ $P $N))) - (log $Temp $Temp1) - (is $Value - (* $Temp1 -1.442695)))))) -; - + (= (info-value $Clause $Pxs $Nxs $Value) + (tuples $Clause $Pxs $Ptuples) + (length $Ptuples $P) + (det-if-then-else + (=:= $P 0) + (= $Value 0) + (, + (tuples $Clause $Nxs $Ntuples) + (length $Ntuples $N) + (is $Temp + (/ $P + (+ $P $N))) + (log $Temp $Temp1) + (is $Value + (* $Temp1 -1.442695))))) ; -; - +; Add a literal to the right end of a clause - (= - (add-literal $L - (= $A $B) - (= $A $B1)) + (= (add-literal $L (= $A $B) (= $A $B1)) (det-if-then-else (= $B True) (= $B1 $L) (= $B1 - (, $B $L)))) -; - + (, $B $L)))) - (= - (add-literals $Ls $Clause0 $Clause) + (= (add-literals $Ls $Clause0 $Clause) (det-if-then-else (= $Ls Nil) (= $Clause $Clause0) @@ -310,44 +231,30 @@ (= $Ls (Cons $L $Ls1)) (add-literal $L $Clause0 $Clause1) - (add-literals $Ls1 $Clause1 $Clause)))) -; - + (add-literals $Ls1 $Clause1 $Clause)))) ; -; +; Construct a list representing the set of variables in Term. - - (= - (variables-in $A $Vs) + (= (variables-in $A $Vs) (variables-in $A Nil $Vs)) -; - +; /* Changed from setof definition to correctly handle dterminate literals code with clauses containing \+ */ - (= - (variables-in $A $V0 $V) - ( (var $A) - (set-det) - (ord-add-element $V0 $A $V))) -; - - (= - (variables-in $A $V0 $V) - ( (ground $A) - (set-det) - (= $V $V0))) -; - - (= - (variables-in $Term $V0 $V) - ( (functor $Term $_ $N) (variables-in-args $N $Term $V0 $V))) -; - - - - (= - (variables-in-args $N $Term $V0 $V) + (= (variables-in $A $V0 $V) + (var $A) + (set-det) + (ord-add-element $V0 $A $V)) + (= (variables-in $A $V0 $V) + (ground $A) + (set-det) + (= $V $V0)) + (= (variables-in $Term $V0 $V) + (functor $Term $_ $N) + (variables-in-args $N $Term $V0 $V)) + + + (= (variables-in-args $N $Term $V0 $V) (det-if-then-else (=:= $N 0) (= $V $V0) @@ -356,112 +263,75 @@ (variables-in $Arg $V0 $V1) (is $N1 (- $N 1)) - (variables-in-args $N1 $Term $V1 $V)))) -; - + (variables-in-args $N1 $Term $V1 $V)))) ; -; - +; Given a clause and a list of examples, construct the list of tuples ; -; - +; for the clause. A tuple is the binding of values to variables such ; -; - +; that the clause can be used to prove the example. - (= - (tuples - (= $A $B) $Xs $Tuples) - ( (variables-in - (= $A $B) $Vars) - (variables-in $A $HeadVars) - (length $HeadVars $N1) - (length $Vars $N2) - (det-if-then-else - (=:= $N1 $N2) - (findall $Vars - (, - (member $A $Xs) - (not (not (with_self (foil-input *) $B)))) $Tuples) - (findall $Vars - (, - (member $A $Xs) - (with_self - (foil-input *) $B)) $Tuples)))) -; - + (= (tuples (= $A $B) $Xs $Tuples) + (variables-in + (= $A $B) $Vars) + (variables-in $A $HeadVars) + (length $HeadVars $N1) + (length $Vars $N2) + (det-if-then-else + (=:= $N1 $N2) + (findall $Vars + (, + (member $A $Xs) + (not (not (with_self (foil-input *) $B)))) $Tuples) + (findall $Vars + (, + (member $A $Xs) + (with_self + (foil-input *) $B)) $Tuples))) +; ; shortcut - only need 1 proof if no new variables. ; -; - +; Xs1 are the examples from Xs that can be proved with the clause - (= - (covered-examples - (= $A $B) $Xs $Xs1) + (= (covered-examples (= $A $B) $Xs $Xs1) (findall $A (, (member $A $Xs) - (not (not (with_self (foil-input *) $B)))) $Xs1)) -; - + (not (not (with_self (foil-input *) $B)))) $Xs1)) ; -; - +; Xs1 are the examples from Xs that cannot be proved with the clause. - (= - (uncovered-examples - (= $A $B) $Xs $Xs1) + (= (uncovered-examples (= $A $B) $Xs $Xs1) (findall $A (, (member $A $Xs) - (not (with_self (foil-input *) $B))) $Xs1)) -; - + (not (with_self (foil-input *) $B))) $Xs1)) ; -; - +; --------------------------------------------------------------------------- ; -; - +; Ugly code to generate possible literals - (= - (generate-possible-extensions - (= $A $B) $Extensions) - ( (variables-in - (= $A $B) $OldVars) (bagof $L (candidate-literal $A $OldVars $L) $Extensions))) -; - + (= (generate-possible-extensions (= $A $B) $Extensions) + (variables-in + (= $A $B) $OldVars) + (bagof $L + (candidate-literal $A $OldVars $L) $Extensions)) - (= - (possible_unification () () ()) True) -; - - (= - (possible-unification - (Cons $H $T) - (Cons $H $Result) - (Cons $H $Vars)) - (possible-unification $T $Result $Vars)) -; - - (= - (possible-unification - (Cons $H $T) - (Cons $H $T1) $Vs) - ( (possible-unification $T $T1 $Vs) - (member $V $Vs) - (= $H $V))) -; - + (= (possible_unification () () ()) True) + (= (possible-unification (Cons $H $T) (Cons $H $Result) (Cons $H $Vars)) + (possible-unification $T $Result $Vars)) + (= (possible-unification (Cons $H $T) (Cons $H $T1) $Vs) + (possible-unification $T $T1 $Vs) + (member $V $Vs) + (= $H $V)) - (= - (list-of-n-from $Elements $N $List0 $List) + (= (list-of-n-from $Elements $N $List0 $List) (det-if-then-else (is $N 0) (= $List $List0) @@ -470,32 +340,20 @@ (- $N 1)) (member $E $Elements) (list-of-n-from $Elements $N1 - (Cons $E $List0) $List)))) -; - + (Cons $E $List0) $List)))) - (= - (possible_new_vars true $_ ()) True) -; - - (= - (possible-new-vars False $N $L) - (length $L $N)) -; - - (= - (possible-new-vars False $N $L) - ( (> $N 0) - (is $N1 - (- $N 1)) - (possible-new-vars False $N1 $L))) -; - + (= (possible_new_vars true $_ ()) True) + (= (possible-new-vars False $N $L) + (length $L $N)) + (= (possible-new-vars False $N $L) + (> $N 0) + (is $N1 + (- $N 1)) + (possible-new-vars False $N1 $L)) - (= - (bind-vars $Lit $Vars $Index) + (= (bind-vars $Lit $Vars $Index) (det-if-then-else (= $Vars Nil) True (, @@ -504,74 +362,57 @@ (arg $Index $Lit $H) (is $Index1 (+ $Index 1)) - (bind-vars $Lit $T $Index1)))) -; - + (bind-vars $Lit $T $Index1)))) - (= - (recursion-check $G $Pred $Arity $Flag) + (= (recursion-check $G $Pred $Arity $Flag) (det-if-then-else (functor $G $Pred $Arity) (= $Flag True) - (= $Flag False))) -; - - - - (= - (candidate-literal $Goal $OldVars $Lit) - ( (foil-predicates $Preds) - (member - (/ $Pred $Arity) $Preds) - (functor $L $Pred $Arity) - (recursion-check $Goal $Pred $Arity $RecursionFlag) - (is $MaxNewVars - (- $Arity 1)) - (possible-new-vars $RecursionFlag $MaxNewVars $NewVars) - (length $NewVars $NewVarPositions) - (is $OldVarPositions - (- $Arity $NewVarPositions)) - (list-of-n-from $OldVars $OldVarPositions Nil $OldVarSeq) - (recursion-safe $RecursionFlag $Goal $OldVarSeq) - (possible-unification $NewVars $NewVarSeq $_) - (subseq $VarSeq $OldVarSeq $NewVarSeq) - (bind-vars $L $VarSeq 1) - (or - (= $Lit $L) - (, - (foil-use-negations True) - (= $Lit - (not $L)))))) -; - + (= $Flag False))) + + + (= (candidate-literal $Goal $OldVars $Lit) + (foil-predicates $Preds) + (member + (/ $Pred $Arity) $Preds) + (functor $L $Pred $Arity) + (recursion-check $Goal $Pred $Arity $RecursionFlag) + (is $MaxNewVars + (- $Arity 1)) + (possible-new-vars $RecursionFlag $MaxNewVars $NewVars) + (length $NewVars $NewVarPositions) + (is $OldVarPositions + (- $Arity $NewVarPositions)) + (list-of-n-from $OldVars $OldVarPositions Nil $OldVarSeq) + (recursion-safe $RecursionFlag $Goal $OldVarSeq) + (possible-unification $NewVars $NewVarSeq $_) + (subseq $VarSeq $OldVarSeq $NewVarSeq) + (bind-vars $L $VarSeq 1) + (or + (= $Lit $L) + (, + (foil-use-negations True) + (= $Lit + (not $L))))) - (= - (recursion-safe $RecursionFlag $Goal $OldVarSeq) + (= (recursion-safe $RecursionFlag $Goal $OldVarSeq) (det-if-then-else (= $RecursionFlag True) - (not (, (numbervars $Goal 0 $_) (ground $OldVarSeq))) True)) -; - + (not (, (numbervars $Goal 0 $_) (ground $OldVarSeq))) True)) ; -; - +; --------------------------------------------------------------------------- ; -; - +; Closed World Assumption - (= - (create-universe $Universe) + (= (create-universe $Universe) (setof $Term - (term-of-ext-def $Term) $Universe)) -; - + (term-of-ext-def $Term) $Universe)) - (= - (term-of-ext-def $Term) + (= (term-of-ext-def $Term) ( (foil-predicates $PredSpecs) (member (/ $Pred $Arity) $PredSpecs) @@ -579,27 +420,20 @@ (with_self (foil-input *) $Goal) (between 1 $Arity $ArgPos) - (arg $ArgPos $Goal $Term))) -; - + (arg $ArgPos $Goal $Term))) - (= - (create-negatives - (Cons $P $Ps) $Negatives) - ( (functor $P $F $N) - (functor $Template $F $N) - (create-universe $Universe) - (setof $Template - (, - (arguments-are-members $Template $N $Universe) - (not (member $Template (Cons $P $Ps)))) $Negatives))) -; - + (= (create-negatives (Cons $P $Ps) $Negatives) + (functor $P $F $N) + (functor $Template $F $N) + (create-universe $Universe) + (setof $Template + (, + (arguments-are-members $Template $N $Universe) + (not (member $Template (Cons $P $Ps)))) $Negatives)) - (= - (arguments-are-members $Term $N $Universe) + (= (arguments-are-members $Term $N $Universe) (det-if-then-else (> $N 0) (, @@ -607,142 +441,96 @@ (member $Arg $Universe) (is $N1 (- $N 1)) - (arguments-are-members $Term $N1 $Universe)) True)) -; - + (arguments-are-members $Term $N1 $Universe)) True)) ; -; - +; --------------------------------------------------------------------------- ; -; - +; Determinate Literals - (= - (determinate $L $Vars $PTuples $NTuples) - ( (binds-new-var $L $Vars) - (determ-cover $PTuples $L $Vars) - (determ-partial-cover $NTuples $L $Vars))) -; - + (= (determinate $L $Vars $PTuples $NTuples) + (binds-new-var $L $Vars) + (determ-cover $PTuples $L $Vars) + (determ-partial-cover $NTuples $L $Vars)) +; /* determinate(+Lit, +Vars, +PTuples, +NTuples) -- holds if Lit is a determinate literal wrt the bindings for Vars as represented in PTuples and NTuples. */ - (= - (binds-new-var - (not $_) $_) - ( (set-det) (fail))) -; - - (= - (binds-new-var $L $Vars) - ( (variables-in $L $LVars) - (member $V $LVars) - (not (contains-var $V $Vars)) - (set-det))) -; - + (= (binds-new-var (not $_) $_) + (set-det) + (fail)) + (= (binds-new-var $L $Vars) + (variables-in $L $LVars) + (member $V $LVars) + (not (contains-var $V $Vars)) + (set-det)) - (= - (determ_cover () $_ $_) True) -; - - (= - (determ-cover - (Cons $T $Ts) $Lit $Vars) - ( (findall $Lit - (, - (= $Vars $T) - (with_self - (foil-input *) $Lit)) - (:: $_)) (determ-cover $Ts $Lit $Vars))) -; - + (= (determ_cover () $_ $_) True) + (= (determ-cover (Cons $T $Ts) $Lit $Vars) + (findall $Lit + (, + (= $Vars $T) + (with_self + (foil-input *) $Lit)) + (:: $_)) + (determ-cover $Ts $Lit $Vars)) - (= - (determ_partial_cover () $_ $_) True) -; - - (= - (determ-partial-cover - (Cons $T $Ts) $Lit $Vars) - ( (findall $Lit - (, - (= $Vars $T) - (with_self - (foil-input *) $Lit)) $Xs) - (or - (= $Xs Nil) - (= $Xs - (:: $_))) - (determ-partial-cover $Ts $Lit $Vars))) -; - + (= (determ_partial_cover () $_ $_) True) + (= (determ-partial-cover (Cons $T $Ts) $Lit $Vars) + (findall $Lit + (, + (= $Vars $T) + (with_self + (foil-input *) $Lit)) $Xs) + (or + (= $Xs Nil) + (= $Xs + (:: $_))) + (determ-partial-cover $Ts $Lit $Vars)) - (= - (determinate-literals1 $Cands $Body $Vars $PTuples $NTuples $DLits) + (= (determinate-literals1 $Cands $Body $Vars $PTuples $NTuples $DLits) (bagof $X (, (member $X $Cands) (determinate $X $Vars $PTuples $NTuples) - (not (, (numbervars $Vars 0 $_) (ante-memberchk $X $Body)))) $DLits)) -; - + (not (, (numbervars $Vars 0 $_) (ante-memberchk $X $Body)))) $DLits)) - (= - (determinate-literals $Cands $Clause $Pxs $Nxs $DLits) - ( (variables-in $Clause $Vars) - (tuples $Clause $Pxs $PTuples) - (tuples $Clause $Nxs $NTuples) - (= $Clause - (= $_ $Body)) - (determinate-literals1 $Cands $Body $Vars $PTuples $NTuples $DLits))) -; - + (= (determinate-literals $Cands $Clause $Pxs $Nxs $DLits) + (variables-in $Clause $Vars) + (tuples $Clause $Pxs $PTuples) + (tuples $Clause $Nxs $NTuples) + (= $Clause + (= $_ $Body)) + (determinate-literals1 $Cands $Body $Vars $PTuples $NTuples $DLits)) - (= - (bounded-determinate-literals 0 $_ $_ $_ $_ Nil) - (set-det)) -; - - (= - (bounded-determinate-literals $Bound $Cands - (= $A $B) $Pxs $Nxs $DLits) - ( (determinate-literals $Cands - (= $A $B) $Pxs $Nxs $DLits0) (reachable-antes $Bound $A $DLits0 $DLits))) -; - + (= (bounded-determinate-literals 0 $_ $_ $_ $_ Nil) + (set-det)) + (= (bounded-determinate-literals $Bound $Cands (= $A $B) $Pxs $Nxs $DLits) + (determinate-literals $Cands + (= $A $B) $Pxs $Nxs $DLits0) + (reachable-antes $Bound $A $DLits0 $DLits)) - (= - (ante-memberchk $A $A) - (set-det)) -; - - (= - (ante-memberchk $A - (, $B $C)) + (= (ante-memberchk $A $A) + (set-det)) + (= (ante-memberchk $A (, $B $C)) (det-if-then-else (ante-memberchk $A $B) True - (ante-memberchk $A $C))) -; - + (ante-memberchk $A $C))) - (= - (reachable-antes $Bound $H $Cands $Antes) - ( (variables-in $H $Vs) (expand-by-var-chain $Bound $Cands $Vs Nil $Antes))) -; - + (= (reachable-antes $Bound $H $Cands $Antes) + (variables-in $H $Vs) + (expand-by-var-chain $Bound $Cands $Vs Nil $Antes)) +; /* reachable_antes(+Bound, +H, +Cands, -Antes) -- Antes is the list of literals from Cands which can be "connected" to H by some chain of variables of length <= Bound. */ - (= - (expand-by-var-chain $Bound $Cands $Vars $As0 $As) + (= (expand-by-var-chain $Bound $Cands $Vars $As0 $As) (det-if-then-else (=:= $Bound 0) (= $As $As0) @@ -756,32 +544,24 @@ (variables-in $As1 $Vars1) (is $Bound1 (- $Bound 1)) - (expand-by-var-chain $Bound1 $Havenots $Vars1 $As1 $As)))))) -; - + (expand-by-var-chain $Bound1 $Havenots $Vars1 $As1 $As)))))) - (= - (partition_on_vars () $_ () ()) True) -; - - (= - (partition-on-vars - (Cons $C $Cs) $Vars $Hs $Hnots) - ( (det-if-then-else - (, - (member $V $Vars) - (contains-var $V $C)) - (, - (= $Hs - (Cons $C $Hs1)) - (= $Hnots $Hnots1)) - (, - (= $Hs $Hs1) - (= $Hnots - (Cons $C $Hnots1)))) (partition-on-vars $Cs $Vars $Hs1 $Hnots1))) -; - + (= (partition_on_vars () $_ () ()) True) + (= (partition-on-vars (Cons $C $Cs) $Vars $Hs $Hnots) + (det-if-then-else + (, + (member $V $Vars) + (contains-var $V $C)) + (, + (= $Hs + (Cons $C $Hs1)) + (= $Hnots $Hnots1)) + (, + (= $Hs $Hs1) + (= $Hnots + (Cons $C $Hnots1)))) + (partition-on-vars $Cs $Vars $Hs1 $Hnots1)) diff --git a/idt/idt1.metta b/idt/idt1.metta index 18a3da7..86d7c5b 100644 --- a/idt/idt1.metta +++ b/idt/idt1.metta @@ -1,430 +1,362 @@ +; (convert_to_metta_file idt1 $_348688 idt/idt1.pl idt/idt1.metta) !(dynamic (/ node 3)) -; - +; /******************************************************************/ +; /* IDT.PRO Last modification: Wed Feb 9 14:20:27 1994 */ +; /* Torgos ID3-like system based on the gain-ratio measure */ +; /******************************************************************/ +; ; ; Copyright (c) 1989 Luis Torgo ; ; This program is free software; you can redistribute it and/or ; modify it under the terms of the GNU General Public License ; Version 1 as published by the Free Software Foundation. ; ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; ; You should have received a copy of the GNU General Public ; License along with this program; if not, write to the Free ; Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, ; USA. ; +; /******************************************************************/ +; /* impl. by : Luis Torgo, Laboratorio Inteligencia Artificial */ +; /* e Ciencas de Computacao, */ +; /* Universidade do Porto, */ +; /* Rua Campo Alegre 823, */ +; /* 4100 Porto, */ +; /* Portugal */ +; /* 1989 */ +; /* */ +; /* Thomas Hoppe */ +; /* Mommsenstr. 50 */ +; /* D-10629 Berlin */ +; /* F.R.G. */ +; /* E-Mail: hoppet@cs.tu-berlin.de */ +; /* 1990 */ +; /* */ +; /* reference : Learning Efficient Classification Procedures */ +; /* and Their Application to Chess End Games, */ +; /* Quinlan, J. R., in: Machine Learning, */ +; /* Michalski, R.S., Carbonell, J.G., Mitchell, T.M.*/ +; /* (eds.), Tioga Publishing Company, Palo Alto, */ +; /* 1983. */ +; /* */ +; /* Induction of Decision Trees, J. Ross Quinlan */ +; /* Machine Learning 1(1), 81-106, 1986 */ +; /* */ +; /* call : idt */ +; /* */ +; /******************************************************************/ +; ; TH: Sat May 29 16:41:25 1993 - made some minor changes ; Mon Feb 7 22:12:43 1994 - for portability with Sicstus input ; files are no longer consulted. ; Wed Feb 9 13:42:44 1994 - log computations are modified for ; compatibility with Quintus-MeTTa ; - Zero-division bug in common ; calculations removed +; /******************************************************************/ +; /* SWI-, YAP-, C- and M-MeTTa specific declaration of dynamical */ +; /* clauses. */ +; /******************************************************************/ !(dynamic (/ decision-tree 1)) -; - !(dynamic (/ example 3)) -; - !(dynamic (/ attributes 1)) -; - !(dynamic (/ classes 1)) -; - !(dynamic (/ current-node 1)) -; - -; (error -; (syntax_error operator_expected) -; (file idt/idt1.pl 69 17 3862)) +; (error +; (syntax_error operator_expected) +; (file idt/idt1.pl 69 17 3862)) !(dynamic (/ found 1)) -; - ; -; - +; Comment this out if you use Quintus MeTTa - (= - (log $X $Y) + (= (log $X $Y) (is $Y (log $X))) -; - - - - (= - (idt) - ( (repeat) - (nl) - (write 'Which file to use ? ') - (read $FileName) - (nl) - (initialize-kb) - (readfile $FileName) - (build-decision-tree) - (show-decision-tree) - (nl) - (write 'Quit (y/n) ? ') - (read y))) -; - - - - (= - (initialize-kb) - ( (abolish node 3) - (abolish decision-tree 1) - (abolish example 3) - (abolish attributes 1) - (abolish classes 1) - (abolish current-node 1) - (set-det))) -; + (= (idt) + (repeat) + (nl) + (write 'Which file to use ? ') + (read $FileName) + (nl) + (initialize-kb) + (readfile $FileName) + (build-decision-tree) + (show-decision-tree) + (nl) + (write 'Quit (y/n) ? ') + (read y)) +; /******************************************************************/ +; /* Quintus-MeTTa specific declaration. */ +; /******************************************************************/ +; ; :- ensure_loaded(library(math)). ; :- ensure_loaded(library(basics)). +; /******************************************************************/ +; /* */ +; /* call : idt */ +; /* */ +; /* side effects: assertz and retracts clauses */ +; /* */ +; /******************************************************************/ +; /* idt reads a filename from the terminal, initializes the know- */ +; /* base, consults the correponding file builds a decision tree */ +; /* and displays the tree. */ +; /* The program assertz the following predicates, which must be */ +; /* declared as dynamic in some MeTTa dialects: */ +; /* node/3, decision_tree/1, example/3, attributes/1, classes/1, */ +; /* current_node/1 and table/3. */ +; /******************************************************************/ + + + (= (initialize-kb) + (abolish node 3) + (abolish decision-tree 1) + (abolish example 3) + (abolish attributes 1) + (abolish classes 1) + (abolish current-node 1) + (set-det)) - (= - (readfile $FileName) - ( (concat $FileName .pl $File) - (see $File) - (repeat) - (read $Term) - (det-if-then-else - (= $Term end-of-file) - (, - (set-det) - (seen)) - (, - (add-symbol &self $Term) - (fail))))) -; + (= (readfile $FileName) + (concat $FileName .pl $File) + (see $File) + (repeat) + (read $Term) + (det-if-then-else + (= $Term end-of-file) + (, + (set-det) + (seen)) + (, + (add-is-symbol &self $Term) + (fail)))) - (= - (build-decision-tree) + (= (build-decision-tree) ( (generate-node-id $_) - (get-symbols &self + (== (= - (attributes $Attributes) true)) + (attributes $Attributes) true) + (get-atoms &self)) (findbag $Ex - (get-symbols &self + (== (= - (example $Ex $_ $_) true)) $Exs) + (example $Ex $_ $_) true) + (get-atoms &self)) $Exs) (idt $Exs $Attributes $Node) - (add-symbol &self + (add-is-symbol &self (decision_tree $Node)) (set-det))) -; - - (= - (generate-node-id $Y) - ( (get-symbols &self + (= (generate-node-id $Y) + ( (== (= - (current_node $X) true)) + (current_node $X) true) + (get-atoms &self)) (set-det) - (remove-symbol &self + (remove-is-symbol &self (current_node $X)) (is $Y (+ $X 1)) - (add-symbol &self + (add-is-symbol &self (current_node $Y)))) -; - - (= - (generate-node-id 0) - (add-symbol &self + (= (generate-node-id 0) + (add-is-symbol &self (current_node 0))) -; - - (= - (idt () $_ ()) True) -; - - (= - (idt $Exs $_ - (:: (leaf $Class))) + (= (idt () $_ ()) True) +; /******************************************************************/ +; /* */ +; /* call : idt(+Examples,+Attributes,-Class) */ +; /* */ +; /* arguments : Examples = List of Examples */ +; /* Attributes = List of Attributes */ +; /* Class = Node ID of Class or leaf(Class) */ +; /* */ +; /******************************************************************/ +; /* IDT determines an attribute-value pair which best splits the */ +; /* examples according to the information-theoretical 'gain-ration'*/ +; /* measure. The attribute-value pair is deleted from the set of */ +; /* all attribute-value pairs and the process of generating a sub- */ +; /* decision tree is called recursively with the according to the */ +; /* attribute-value pair splitted examples. The recursion */ +; /* terminates either if there is no more example to process or if */ +; /* all examples belong to the same class. In the last case */ +; /* leaf(Class) is returned insteed of the SubtreeIDs. */ +; /* In the end for every generated subtree an ID is generated and */ +; /* the tree structure is asserted in the database. */ +; /******************************************************************/ + (= (idt $Exs $_ (:: (leaf $Class))) (termination-criterion $Exs $Class)) -; - - (= - (idt $Exs $Attributes $ID) + (= (idt $Exs $Attributes $ID) ( (get-best-attribute $Attributes $Exs $BestAttribute) (split-values $BestAttribute $Exs $DividedValues) (delete $BestAttribute $Attributes $NewAttributes) (generate-subtrees $DividedValues $NewAttributes $SubtreeIDs) (generate-node-id $ID) - (add-symbol &self + (add-is-symbol &self (node $ID $BestAttribute $SubtreeIDs)))) -; - - (= - (termination-criterion - (Cons $Ex $Exs) $Class) - ( (get-symbols &self + (= (termination-criterion (Cons $Ex $Exs) $Class) + ( (== (= - (example $Ex $Class $_) true)) + (example $Ex $Class $_) true) + (get-atoms &self)) (set-det) (all-in-same-class $Exs $Class))) -; - - - (= - (all_in_same_class () $_) True) -; - (= - (all-in-same-class - (Cons $Ex $Exs) $C) - ( (get-symbols &self + (= (all_in_same_class () $_) True) + (= (all-in-same-class (Cons $Ex $Exs) $C) + ( (== (= - (example $Ex $C $_) true)) + (example $Ex $C $_) true) + (get-atoms &self)) (set-det) (all-in-same-class $Exs $C))) -; + (= (get-best-attribute $Attributes $Exs $BestAttribute) + (construct-contingency-table $Attributes $Exs) + (common-calculations $MC $N) + (calculate-parameter-classification $Attributes $MC $N $Values) + (get-best $Attributes $Values $BestAttribute)) - (= - (get-best-attribute $Attributes $Exs $BestAttribute) - ( (construct-contingency-table $Attributes $Exs) - (common-calculations $MC $N) - (calculate-parameter-classification $Attributes $MC $N $Values) - (get-best $Attributes $Values $BestAttribute))) -; - - - (= - (construct-contingency-table $Attributes $Exs) - ( (get-symbols &self + (= (construct-contingency-table $Attributes $Exs) + ( (== (= - (classes $Lc) true)) + (classes $Lc) true) + (get-atoms &self)) (length $Lc $NroColTab) (abolish table 3) (create-list-of-zeros $NroColTab $List) (initialize-contingency-tables $Attributes $List) (construct-contingency-tables $Attributes $Exs))) -; - - (= - (initialize_contingency_tables () $_) True) -; - - (= - (initialize-contingency-tables - (Cons $A $As) $List) - ( (add-symbol &self + (= (initialize_contingency_tables () $_) True) + (= (initialize-contingency-tables (Cons $A $As) $List) + ( (add-is-symbol &self (table $A () $List)) (initialize-contingency-tables $As $List))) -; - - - - (= - (create_list_of_zeros 0 ()) True) -; - - (= - (create-list-of-zeros $N - (Cons 0 $R)) - ( (> $N 0) - (is $N1 - (- $N 1)) - (create-list-of-zeros $N1 $R))) -; - - (= - (construct_contingency_tables () $_) True) -; - - (= - (construct-contingency-tables - (Cons $Attribute $Attributes) $ExampleList) - ( (contingency-table $Attribute $ExampleList) - (set-det) - (construct-contingency-tables $Attributes $ExampleList))) -; - + (= (create_list_of_zeros 0 ()) True) + (= (create-list-of-zeros $N (Cons 0 $R)) + (> $N 0) + (is $N1 + (- $N 1)) + (create-list-of-zeros $N1 $R)) - (= - (contingency_table $_ ()) True) -; + (= (construct_contingency_tables () $_) True) + (= (construct-contingency-tables (Cons $Attribute $Attributes) $ExampleList) + (contingency-table $Attribute $ExampleList) + (set-det) + (construct-contingency-tables $Attributes $ExampleList)) - (= - (contingency-table $Attribute - (Cons $Ex $Exs)) - ( (value $Attribute $Ex $V) - (position-of-class $Ex $Pc) - (update-table $Attribute $V $Pc) - (set-det) - (contingency-table $Attribute $Exs))) -; + (= (contingency_table $_ ()) True) + (= (contingency-table $Attribute (Cons $Ex $Exs)) + (value $Attribute $Ex $V) + (position-of-class $Ex $Pc) + (update-table $Attribute $V $Pc) + (set-det) + (contingency-table $Attribute $Exs)) - (= - (value $A - (Cons - (= $A $V) $_) $V) + (= (value $A (Cons (= $A $V) $_) $V) (set-det)) -; - - (= - (value $A - (Cons $_ $Sels) $V) + (= (value $A (Cons $_ $Sels) $V) (value $A $Sels $V)) -; - - (= - (value $A $No $V) - ( (get-symbols &self + (= (value $A $No $V) + ( (== (= - (example $No $_ $Ex) true)) (value $A $Ex $V))) -; + (example $No $_ $Ex) true) + (get-atoms &self)) (value $A $Ex $V))) - - (= - (position-of-class $Ex $Pc) - ( (get-symbols &self + (= (position-of-class $Ex $Pc) + ( (== (= - (example $Ex $C $_) true)) - (get-symbols &self + (example $Ex $C $_) true) + (get-atoms &self)) + (== (= - (classes $Classes) true)) + (classes $Classes) true) + (get-atoms &self)) (position $C $Classes $Pc))) -; - - (= - (position $X $L $P) + (= (position $X $L $P) (position $X 1 $L $P)) -; - - (= - (position $X $P - (Cons $X $_) $P) True) -; + (= (position $X $P (Cons $X $_) $P) True) + (= (position $X $N (Cons $_ $R) $P) + (is $N1 + (+ $N 1)) + (position $X $N1 $R $P)) - (= - (position $X $N - (Cons $_ $R) $P) - ( (is $N1 - (+ $N 1)) (position $X $N1 $R $P))) -; - - - (= - (update-table $Attribute $V $Pc) - ( (remove-symbol &self + (= (update-table $Attribute $V $Pc) + ( (remove-is-symbol &self (table $Attribute $TabLines $TotClass)) (modify-table $TabLines $V $Pc $NewLines) (increment-position-list 1 $Pc $TotClass $NewTotal) - (add-symbol &self + (add-is-symbol &self (table $Attribute $NewLines $NewTotal)))) -; - - (= - (modify-table Nil $V $Pc - (:: (, $V $Values 1))) - ( (get-symbols &self + (= (modify-table Nil $V $Pc (:: (, $V $Values 1))) + ( (== (= - (classes $Classes) true)) + (classes $Classes) true) + (get-atoms &self)) (length $Classes $NoOfColums) (create-list-of-zeros $NoOfColums $L) (increment-position-list 1 $Pc $L $Values))) -; - - (= - (modify-table - (Cons - (, $V $Nums $Tot) $Rest) $V $Pc - (Cons - (, $V $NewNums $NewTot) $Rest)) - ( (is $NewTot - (+ $Tot 1)) (increment-position-list 1 $Pc $Nums $NewNums))) -; - - (= - (modify-table - (Cons $X $Rest1) $V $Pc - (Cons $X $Rest2)) + (= (modify-table (Cons (, $V $Nums $Tot) $Rest) $V $Pc (Cons (, $V $NewNums $NewTot) $Rest)) + (is $NewTot + (+ $Tot 1)) + (increment-position-list 1 $Pc $Nums $NewNums)) + (= (modify-table (Cons $X $Rest1) $V $Pc (Cons $X $Rest2)) (modify-table $Rest1 $V $Pc $Rest2)) -; - - (= - (increment-position-list $N $N - (Cons $X $R) - (Cons $Y $R)) + (= (increment-position-list $N $N (Cons $X $R) (Cons $Y $R)) (is $Y (+ $X 1))) -; - - (= - (increment-position-list $N1 $N - (Cons $X $R1) - (Cons $X $R2)) - ( (is $N2 - (+ $N1 1)) (increment-position-list $N2 $N $R1 $R2))) -; - + (= (increment-position-list $N1 $N (Cons $X $R1) (Cons $X $R2)) + (is $N2 + (+ $N1 1)) + (increment-position-list $N2 $N $R1 $R2)) - (= - (common-calculations $MC $N) - ( (get-symbols &self + (= (common-calculations $MC $N) + ( (== (= - (table $_ $_ $Xjs) true)) (common-calculations $Xjs 0 0 $MC $N))) -; - - - (= - (common-calculations Nil $TotalSum $N $MC $N) - ( (log $N $NLog) (is $MC (* (/ -1 $N) (- $TotalSum (* $N $NLog)))))) -; - - (= - (common-calculations - (:: 0) $S $N $S $N) + (table $_ $_ $Xjs) true) + (get-atoms &self)) (common-calculations $Xjs 0 0 $MC $N))) + + (= (common-calculations Nil $TotalSum $N $MC $N) + (log $N $NLog) + (is $MC + (* + (/ -1 $N) + (- $TotalSum + (* $N $NLog))))) + (= (common-calculations (:: 0) $S $N $S $N) (set-det)) -; + (= (common-calculations (Cons $Xj $Xjs) $Ac1 $Ac2 $MC $N) + (log $Xj $XjLog) + (is $NAc1 + (+ $Ac1 + (* $Xj $XjLog))) + (is $NAc2 + (+ $Ac2 $Xj)) + (common-calculations $Xjs $NAc1 $NAc2 $MC $N)) - (= - (common-calculations - (Cons $Xj $Xjs) $Ac1 $Ac2 $MC $N) - ( (log $Xj $XjLog) - (is $NAc1 - (+ $Ac1 - (* $Xj $XjLog))) - (is $NAc2 - (+ $Ac2 $Xj)) - (common-calculations $Xjs $NAc1 $NAc2 $MC $N))) -; + (= (calculate_parameter_classification () $_ $_ ()) True) + (= (calculate-parameter-classification (Cons $A $As) $MC $N (Cons $V $Vs)) + (gain-ratio $A $MC $N $V) + (calculate-parameter-classification $As $MC $N $Vs)) - (= - (calculate_parameter_classification () $_ $_ ()) True) -; - - (= - (calculate-parameter-classification - (Cons $A $As) $MC $N - (Cons $V $Vs)) - ( (gain-ratio $A $MC $N $V) (calculate-parameter-classification $As $MC $N $Vs))) -; - - - - (= - (gain-ratio $A $MC $N $GR) - ( (get-symbols &self + (= (gain-ratio $A $MC $N $GR) + ( (== (= - (table $A $Lines $_) true)) + (table $A $Lines $_) true) + (get-atoms &self)) (calculate-factors-B-and-IV $Lines $N 0 0 $B $IV) (is $IM (- $MC $B)) @@ -433,332 +365,215 @@ (is $GR (/ $IM $IV)) (= $GR 1)))) -; - - - - (= - (calculate-factors-B-and-IV Nil $N $Sum1 $Sum2 $B $IV) - ( (log $N $NLog) - (is $B - (* - (/ -1 $N) - (- $Sum1 $Sum2))) - (is $IV - (* - (/ -1 $N) - (- $Sum2 - (* $N $NLog)))))) -; - - (= - (calculate-factors-B-and-IV - (Cons - (, $_ $L $TotL) $Rest) $N $Ac1 $Ac2 $B $IV) - ( (sum-of-lines $L 0 $SL) - (log $TotL $TotLog) - (is $NAc1 - (+ $Ac1 $SL)) - (is $NAc2 - (+ $Ac2 - (* $TotL $TotLog))) - (calculate-factors-B-and-IV $Rest $N $NAc1 $NAc2 $B $IV))) -; - - - - (= - (sum_of_lines () $X $X) True) -; - - (= - (sum-of-lines - (Cons 0 $Ns) $Ac $Tot) - (sum-of-lines $Ns $Ac $Tot)) -; - (= - (sum-of-lines - (Cons $N $Ns) $Ac $Tot) - ( (log $N $NLog) - (is $Nac - (+ $Ac - (* $N $NLog))) - (sum-of-lines $Ns $Nac $Tot))) -; + (= (calculate-factors-B-and-IV Nil $N $Sum1 $Sum2 $B $IV) + (log $N $NLog) + (is $B + (* + (/ -1 $N) + (- $Sum1 $Sum2))) + (is $IV + (* + (/ -1 $N) + (- $Sum2 + (* $N $NLog))))) + (= (calculate-factors-B-and-IV (Cons (, $_ $L $TotL) $Rest) $N $Ac1 $Ac2 $B $IV) + (sum-of-lines $L 0 $SL) + (log $TotL $TotLog) + (is $NAc1 + (+ $Ac1 $SL)) + (is $NAc2 + (+ $Ac2 + (* $TotL $TotLog))) + (calculate-factors-B-and-IV $Rest $N $NAc1 $NAc2 $B $IV)) + + + (= (sum_of_lines () $X $X) True) + (= (sum-of-lines (Cons 0 $Ns) $Ac $Tot) + (sum-of-lines $Ns $Ac $Tot)) + (= (sum-of-lines (Cons $N $Ns) $Ac $Tot) + (log $N $NLog) + (is $Nac + (+ $Ac + (* $N $NLog))) + (sum-of-lines $Ns $Nac $Tot)) - (= - (get-best - (Cons $A $As) - (Cons $V $Vs) $Result) + (= (get-best (Cons $A $As) (Cons $V $Vs) $Result) (best-value $As $Vs (, $A $V) $Result)) -; - - (= - (best_value () () - (, $A $_) $A) True) -; - - (= - (best-value - (Cons $A $As) - (Cons $V $Vs) - (, $_ $TV) $Result) - ( (> $V $TV) (best-value $As $Vs (, $A $V) $Result))) -; - - (= - (best-value - (Cons $_ $As) - (Cons $_ $Vs) - (, $TA $TV) $Result) + (= (best_value () () (, $A $_) $A) True) + (= (best-value (Cons $A $As) (Cons $V $Vs) (, $_ $TV) $Result) + (> $V $TV) + (best-value $As $Vs + (, $A $V) $Result)) + (= (best-value (Cons $_ $As) (Cons $_ $Vs) (, $TA $TV) $Result) (best-value $As $Vs (, $TA $TV) $Result)) -; - - (= - (split-values $Attribute $Exs $Result) - ( (get-values $Attribute $Exs $Values) (split-examples $Attribute $Values $Exs $Result))) -; + (= (split-values $Attribute $Exs $Result) + (get-values $Attribute $Exs $Values) + (split-examples $Attribute $Values $Exs $Result)) - - (= - (get-values $Attribute $Exs $Vals) - ( (findbag $V - (, - (member $Ex $Exs) - (value $Attribute $Ex $V)) $Vs) (remove-duplicates $Vs $Vals))) -; - - - - (= - (split_examples $_ - ($V) $Exs - ( (, $V $Exs))) True) -; - - (= - (split-examples $A - (Cons $V $Vs) $Exs - (Cons - (, $V $VExs) $Rest)) - ( (findbag $Ex - (, - (member $Ex $Exs) - (value $A $Ex $V)) $VExs) - (difference $VExs $Exs $RestEx) - (split-examples $A $Vs $RestEx $Rest))) -; - + (= (get-values $Attribute $Exs $Vals) + (findbag $V + (, + (member $Ex $Exs) + (value $Attribute $Ex $V)) $Vs) + (remove-duplicates $Vs $Vals)) - (= - (generate_subtrees () $_ ()) True) -; + (= (split_examples $_ ($V) $Exs ((, $V $Exs))) True) + (= (split-examples $A (Cons $V $Vs) $Exs (Cons (, $V $VExs) $Rest)) + (findbag $Ex + (, + (member $Ex $Exs) + (value $A $Ex $V)) $VExs) + (difference $VExs $Exs $RestEx) + (split-examples $A $Vs $RestEx $Rest)) - (= - (generate-subtrees - (Cons - (, $Value $Exs) $Rest1) $Attributes - (Cons - (, $Value $Id) $Rest2)) - ( (idt $Exs $Attributes $Id) - (set-det) - (generate-subtrees $Rest1 $Attributes $Rest2))) -; + (= (generate_subtrees () $_ ()) True) + (= (generate-subtrees (Cons (, $Value $Exs) $Rest1) $Attributes (Cons (, $Value $Id) $Rest2)) + (idt $Exs $Attributes $Id) + (set-det) + (generate-subtrees $Rest1 $Attributes $Rest2)) - (= - (show-decision-tree) + (= (show-decision-tree) ( (nl) - (get-symbols &self + (== (= - (decision_tree $Node) true)) + (decision_tree $Node) true) + (get-atoms &self)) (show-subtree $Node 0) (set-det))) -; - - - - (= - (show-subtree $NodeNo $Indent) - ( (get-symbols &self +; /******************************************************************/ +; /* */ +; /* call : show_decision_tree */ +; /* */ +; /******************************************************************/ +; /* A simple pretty-print procedure for displaying decision trees. */ +; /* In steed of this procedure, we can also generate rules from the*/ +; /* decision tree by traversing every path in the tree until a */ +; /* leaf node was reached and collecting the attribute-value pairs */ +; /* of that path. Then the leaf node forms the head of a Horn- */ +; /* formula and the set of attribute-value pairs of the path forms */ +; /* the body of the clause. */ +; /******************************************************************/ + + + (= (show-subtree $NodeNo $Indent) + ( (== (= - (node $NodeNo $Attribute $SubtreeList) true)) (show-subtrees $SubtreeList $Attribute $Indent))) -; - + (node $NodeNo $Attribute $SubtreeList) true) + (get-atoms &self)) (show-subtrees $SubtreeList $Attribute $Indent))) - (= - (show-subtrees Nil $_ $_) + (= (show-subtrees Nil $_ $_) (nl)) -; - - (= - (show-subtrees - (Cons - (, $Value - (leaf $X)) $Brothers) $Attribute $Indent) - ( (write (= $Attribute $Value)) - (write ' ') - (write ==> ) - (write (= class $X)) - (nl) - (space $Indent) - (show-subtrees $Brothers $Attribute $Indent))) -; - - (= - (show-subtrees - (Cons - (, $Value $NodeNo) $Brothers) $Attribute $Indent) - ( (name $Attribute $List1) - (length $List1 $N1) - (name $Value $List2) - (length $List2 $N2) - (write (= $Attribute $Value)) - (write ' and ') - (is $Offset + (= (show-subtrees (Cons (, $Value (leaf $X)) $Brothers) $Attribute $Indent) + (write (= $Attribute $Value)) + (write ' ') + (write ==> ) + (write (= class $X)) + (nl) + (space $Indent) + (show-subtrees $Brothers $Attribute $Indent)) + (= (show-subtrees (Cons (, $Value $NodeNo) $Brothers) $Attribute $Indent) + (name $Attribute $List1) + (length $List1 $N1) + (name $Value $List2) + (length $List2 $N2) + (write (= $Attribute $Value)) + (write ' and ') + (is $Offset + (+ (+ (+ - (+ - (+ $Indent $N1) 3) $N2) 5)) - (show-subtree $NodeNo $Offset) - (space $Indent) - (show-subtrees $Brothers $Attribute $Indent))) -; - - - - (= - (space 0) True) -; - - (= - (space $N) - ( (> $N 0) - (write ' ') - (is $N1 - (- $N 1)) - (space $N1))) -; - - - - (= - (remove_duplicates () ()) True) -; - - (= - (remove-duplicates - (Cons $X $Xs) $Ys) - ( (member $X $Xs) (remove-duplicates $Xs $Ys))) -; - - (= - (remove-duplicates - (Cons $X $Xs) - (Cons $X $Ys)) + (+ $Indent $N1) 3) $N2) 5)) + (show-subtree $NodeNo $Offset) + (space $Indent) + (show-subtrees $Brothers $Attribute $Indent)) + + + (= (space 0) True) +; /******************************************************************/ +; /* Utility predicates */ +; /******************************************************************/ + (= (space $N) + (> $N 0) + (write ' ') + (is $N1 + (- $N 1)) + (space $N1)) + + + (= (remove_duplicates () ()) True) + (= (remove-duplicates (Cons $X $Xs) $Ys) + (member $X $Xs) + (remove-duplicates $Xs $Ys)) + (= (remove-duplicates (Cons $X $Xs) (Cons $X $Ys)) (remove-duplicates $Xs $Ys)) -; - ; -; - +; length([],0). ; -; - +; length([L|Ls],N) :- ; -; - +; length(Ls,N1), ; -; - - +; N is N1 + 1. - (= - (delete $X - (Cons $X $Xs) $Xs) True) -; - (= - (delete $X - (Cons $Y $Ys) - (Cons $Y $Zs)) + (= (delete $X (Cons $X $Xs) $Xs) True) + (= (delete $X (Cons $Y $Ys) (Cons $Y $Zs)) (delete $X $Ys $Zs)) -; - - (= - (difference $L1 $L2 $L3) + (= (difference $L1 $L2 $L3) (findbag $N (, (member $N $L2) (not (member $N $L1))) $L3)) -; - - (= - (findbag $X $G $_) - ( (add-symbol &self + (= (findbag $X $G $_) + ( (add-is-symbol &self (found mark)) (call $G) - (add-symbol &self + (add-is-symbol &self (found $X)) - (fail))) -; - - (= - (findbag $_ $_ $L) - (collect-found Nil $L)) -; - + (fail))) + (= (findbag $_ $_ $L) + (collect-found Nil $L)) - (= - (collect-found $L $L1) - ( (getnext $X) (collect-found (Cons $X $L) $L1))) -; - - (= - (collect_found $L $L) True) -; - + (= (collect-found $L $L1) + (getnext $X) + (collect-found + (Cons $X $L) $L1)) + (= (collect_found $L $L) True) - (= - (getnext $X) - ( (remove-symbol &self + (= (getnext $X) + ( (remove-is-symbol &self (found $X)) (set-det) - (not (== $X mark)))) -; - - + (not (== $X mark)))) - (= - (help) - ( (write 'Start IDT with command: idt.') (nl))) -; + (= (help) + (write 'Start IDT with command: idt.') + (nl)) !(help *) -; - diff --git a/idt/idt1_1.metta b/idt/idt1_1.metta index bf8fabc..b70442c 100644 --- a/idt/idt1_1.metta +++ b/idt/idt1_1.metta @@ -1,64 +1,15 @@ +; (convert_to_metta_file idt1_1 $_245168 idt/idt1_1.pl idt/idt1_1.metta) - (= - (classes - (x y)) True) -; + (= (classes (x y)) True) + (= (attributes (a b c)) True) - (= - (attributes - (a b c)) True) -; - - - (= - (example 1 x - ( (= a 1) - (= b 1) - (= c 1))) True) -; - - (= - (example 2 y - ( (= a 1) - (= b 2) - (= c 2))) True) -; - - (= - (example 3 y - ( (= a 2) - (= b 3) - (= c 2))) True) -; - - (= - (example 4 x - ( (= a 2) - (= b 3) - (= c 1))) True) -; - - (= - (example 5 y - ( (= a 1) - (= b 2) - (= c 2))) True) -; - - (= - (example 6 x - ( (= a 1) - (= b 1) - (= c 2))) True) -; - - (= - (example 7 x - ( (= a 1) - (= b 1) - (= c 1))) True) -; - + (= (example 1 x ((= a 1) (= b 1) (= c 1))) True) + (= (example 2 y ((= a 1) (= b 2) (= c 2))) True) + (= (example 3 y ((= a 2) (= b 3) (= c 2))) True) + (= (example 4 x ((= a 2) (= b 3) (= c 1))) True) + (= (example 5 y ((= a 1) (= b 2) (= c 2))) True) + (= (example 6 x ((= a 1) (= b 1) (= c 2))) True) + (= (example 7 x ((= a 1) (= b 1) (= c 1))) True) diff --git a/idt/idt1_2.metta b/idt/idt1_2.metta index 835068b..2a1721b 100644 --- a/idt/idt1_2.metta +++ b/idt/idt1_2.metta @@ -1,79 +1,16 @@ +; (convert_to_metta_file idt1_2 $_298570 idt/idt1_2.pl idt/idt1_2.metta) - (= - (classes - (accept reject)) True) -; + (= (classes (accept reject)) True) + (= (attributes (account cash employed credits)) True) - (= - (attributes - (account cash employed credits)) True) -; - - - (= - (example 1 accept - ( (= account bank) - (= cash 700) - (= employed yes) - (= credits 200))) True) -; - - (= - (example 2 reject - ( (= account bank) - (= cash 300) - (= employed yes) - (= credits 600))) True) -; - - (= - (example 3 reject - ( (= account none) - (= cash 0) - (= employed yes) - (= credits 400))) True) -; - - (= - (example 4 accept - ( (= account others) - (= cash 1200) - (= employed yes) - (= credits 600))) True) -; - - (= - (example 5 reject - ( (= account others) - (= cash 800) - (= employed yes) - (= credits 600))) True) -; - - (= - (example 6 accept - ( (= account others) - (= cash 1600) - (= employed yes) - (= credits 200))) True) -; - - (= - (example 7 accept - ( (= account bank) - (= cash 3000) - (= employed no) - (= credits 300))) True) -; - - (= - (example 8 reject - ( (= account none) - (= cash 0) - (= employed no) - (= credits 200))) True) -; - + (= (example 1 accept ((= account bank) (= cash 700) (= employed yes) (= credits 200))) True) + (= (example 2 reject ((= account bank) (= cash 300) (= employed yes) (= credits 600))) True) + (= (example 3 reject ((= account none) (= cash 0) (= employed yes) (= credits 400))) True) + (= (example 4 accept ((= account others) (= cash 1200) (= employed yes) (= credits 600))) True) + (= (example 5 reject ((= account others) (= cash 800) (= employed yes) (= credits 600))) True) + (= (example 6 accept ((= account others) (= cash 1600) (= employed yes) (= credits 200))) True) + (= (example 7 accept ((= account bank) (= cash 3000) (= employed no) (= credits 300))) True) + (= (example 8 reject ((= account none) (= cash 0) (= employed no) (= credits 200))) True) diff --git a/idt/idt1_3.metta b/idt/idt1_3.metta index 13bbd06..c045a7e 100644 --- a/idt/idt1_3.metta +++ b/idt/idt1_3.metta @@ -1,98 +1,19 @@ - - (= - (classes - (accept reject)) True) -; - - - (= - (attributes - (account cash employed)) True) -; - - - (= - (example 1 accept - ( (= account bank) - (= employed yes) - (= cash 300))) True) -; - - (= - (example 2 accept - ( (= account bank) - (= employed yes) - (= cash 300))) True) -; - - (= - (example 3 reject - ( (= account bank) - (= employed no) - (= cash 300))) True) -; - - (= - (example 4 accept - ( (= account bank) - (= employed no) - (= cash 4000))) True) -; - - (= - (example 5 accept - ( (= account none) - (= employed yes) - (= cash 4000))) True) -; - - (= - (example 6 reject - ( (= account none) - (= employed yes) - (= cash 300))) True) -; - - (= - (example 7 reject - ( (= account none) - (= employed no) - (= cash 300))) True) -; - - (= - (example 8 reject - ( (= account none) - (= employed no) - (= cash 4000))) True) -; - - (= - (example 9 reject - ( (= account none) - (= employed no) - (= cash 4000))) True) -; - - (= - (example 10 reject - ( (= account others) - (= employed no) - (= cash 300))) True) -; - - (= - (example 11 accept - ( (= account others) - (= employed no) - (= cash 4000))) True) -; - - (= - (example 12 reject - ( (= account others) - (= employed no) - (= cash 300))) True) -; - +; (convert_to_metta_file idt1_3 $_353972 idt/idt1_3.pl idt/idt1_3.metta) + + (= (classes (accept reject)) True) + + (= (attributes (account cash employed)) True) + + (= (example 1 accept ((= account bank) (= employed yes) (= cash 300))) True) + (= (example 2 accept ((= account bank) (= employed yes) (= cash 300))) True) + (= (example 3 reject ((= account bank) (= employed no) (= cash 300))) True) + (= (example 4 accept ((= account bank) (= employed no) (= cash 4000))) True) + (= (example 5 accept ((= account none) (= employed yes) (= cash 4000))) True) + (= (example 6 reject ((= account none) (= employed yes) (= cash 300))) True) + (= (example 7 reject ((= account none) (= employed no) (= cash 300))) True) + (= (example 8 reject ((= account none) (= employed no) (= cash 4000))) True) + (= (example 9 reject ((= account none) (= employed no) (= cash 4000))) True) + (= (example 10 reject ((= account others) (= employed no) (= cash 300))) True) + (= (example 11 accept ((= account others) (= employed no) (= cash 4000))) True) + (= (example 12 reject ((= account others) (= employed no) (= cash 300))) True) diff --git a/idt/idt1_4.metta b/idt/idt1_4.metta index adcaebc..731a717 100644 --- a/idt/idt1_4.metta +++ b/idt/idt1_4.metta @@ -1,98 +1,19 @@ - - (= - (classes - (accept reject ask)) True) -; - - - (= - (attributes - (account cash employed)) True) -; - - - (= - (example 1 accept - ( (= account bank) - (= employed yes) - (= cash 300))) True) -; - - (= - (example 2 accept - ( (= account bank) - (= employed yes) - (= cash 300))) True) -; - - (= - (example 3 accept - ( (= account bank) - (= employed no) - (= cash 300))) True) -; - - (= - (example 4 accept - ( (= account bank) - (= employed no) - (= cash 4000))) True) -; - - (= - (example 5 accept - ( (= account none) - (= employed yes) - (= cash 4000))) True) -; - - (= - (example 6 reject - ( (= account none) - (= employed yes) - (= cash 300))) True) -; - - (= - (example 7 reject - ( (= account none) - (= employed no) - (= cash 300))) True) -; - - (= - (example 8 reject - ( (= account none) - (= employed no) - (= cash 4000))) True) -; - - (= - (example 9 reject - ( (= account none) - (= employed no) - (= cash 4000))) True) -; - - (= - (example 10 ask - ( (= account others) - (= employed no) - (= cash 300))) True) -; - - (= - (example 11 ask - ( (= account others) - (= employed no) - (= cash 4000))) True) -; - - (= - (example 12 ask - ( (= account others) - (= employed no) - (= cash 300))) True) -; - +; (convert_to_metta_file idt1_4 $_411730 idt/idt1_4.pl idt/idt1_4.metta) + + (= (classes (accept reject ask)) True) + + (= (attributes (account cash employed)) True) + + (= (example 1 accept ((= account bank) (= employed yes) (= cash 300))) True) + (= (example 2 accept ((= account bank) (= employed yes) (= cash 300))) True) + (= (example 3 accept ((= account bank) (= employed no) (= cash 300))) True) + (= (example 4 accept ((= account bank) (= employed no) (= cash 4000))) True) + (= (example 5 accept ((= account none) (= employed yes) (= cash 4000))) True) + (= (example 6 reject ((= account none) (= employed yes) (= cash 300))) True) + (= (example 7 reject ((= account none) (= employed no) (= cash 300))) True) + (= (example 8 reject ((= account none) (= employed no) (= cash 4000))) True) + (= (example 9 reject ((= account none) (= employed no) (= cash 4000))) True) + (= (example 10 ask ((= account others) (= employed no) (= cash 300))) True) + (= (example 11 ask ((= account others) (= employed no) (= cash 4000))) True) + (= (example 12 ask ((= account others) (= employed no) (= cash 300))) True) diff --git a/idt/idt1_5.metta b/idt/idt1_5.metta index 3457108..1857c68 100644 --- a/idt/idt1_5.metta +++ b/idt/idt1_5.metta @@ -1,94 +1,17 @@ - - (= - (classes - (yes no)) True) -; - - - (= - (attributes - (season weather temp work)) True) -; - - - (= - (example 1 yes - ( (= season spring) - (= weather sunny) - (= temp warm) - (= work few))) True) -; - - (= - (example 2 yes - ( (= season summer) - (= weather cloudy) - (= temp hot) - (= work few))) True) -; - - (= - (example 3 no - ( (= season summer) - (= weather rain) - (= temp cold) - (= work few))) True) -; - - (= - (example 4 yes - ( (= season winter) - (= weather cloudy) - (= temp cold) - (= work plenty))) True) -; - - (= - (example 5 no - ( (= season winter) - (= weather cloudy) - (= temp cold) - (= work few))) True) -; - - (= - (example 6 yes - ( (= season autumn) - (= weather sunny) - (= temp hot) - (= work plenty))) True) -; - - (= - (example 7 yes - ( (= season winter) - (= weather sunny) - (= temp warm) - (= work few))) True) -; - - (= - (example 8 no - ( (= season autumn) - (= weather cloudy) - (= temp warm) - (= work few))) True) -; - - (= - (example 9 no - ( (= season summer) - (= weather cloudy) - (= temp hot) - (= work plenty))) True) -; - - (= - (example 10 no - ( (= season winter) - (= weather cloudy) - (= temp hot) - (= work few))) True) -; - +; (convert_to_metta_file idt1_5 $_469528 idt/idt1_5.pl idt/idt1_5.metta) + + (= (classes (yes no)) True) + + (= (attributes (season weather temp work)) True) + + (= (example 1 yes ((= season spring) (= weather sunny) (= temp warm) (= work few))) True) + (= (example 2 yes ((= season summer) (= weather cloudy) (= temp hot) (= work few))) True) + (= (example 3 no ((= season summer) (= weather rain) (= temp cold) (= work few))) True) + (= (example 4 yes ((= season winter) (= weather cloudy) (= temp cold) (= work plenty))) True) + (= (example 5 no ((= season winter) (= weather cloudy) (= temp cold) (= work few))) True) + (= (example 6 yes ((= season autumn) (= weather sunny) (= temp hot) (= work plenty))) True) + (= (example 7 yes ((= season winter) (= weather sunny) (= temp warm) (= work few))) True) + (= (example 8 no ((= season autumn) (= weather cloudy) (= temp warm) (= work few))) True) + (= (example 9 no ((= season summer) (= weather cloudy) (= temp hot) (= work plenty))) True) + (= (example 10 no ((= season winter) (= weather cloudy) (= temp hot) (= work few))) True) diff --git a/idt/idt1_6.metta b/idt/idt1_6.metta index 451c690..dc7bc4e 100644 --- a/idt/idt1_6.metta +++ b/idt/idt1_6.metta @@ -1,127 +1,22 @@ - - (= - (classes - (n p)) True) -; - - - (= - (attributes - (outlook temperature humidity windy)) True) -; - - - (= - (example 1 n - ( (= outlook sunny) - (= temperature hot) - (= humidity high) - (= windy false))) True) -; - - (= - (example 2 n - ( (= outlook sunny) - (= temperature hot) - (= humidity high) - (= windy true))) True) -; - - (= - (example 3 p - ( (= outlook overcast) - (= temperature hot) - (= humidity high) - (= windy false))) True) -; - - (= - (example 4 p - ( (= outlook rain) - (= temperature mild) - (= humidity high) - (= windy false))) True) -; - - (= - (example 5 p - ( (= outlook rain) - (= temperature cool) - (= humidity normal) - (= windy false))) True) -; - - (= - (example 6 n - ( (= outlook rain) - (= temperature cool) - (= humidity normal) - (= windy true))) True) -; - - (= - (example 7 p - ( (= outlook overcast) - (= temperature cool) - (= humidity normal) - (= windy true))) True) -; - - (= - (example 8 n - ( (= outlook sunny) - (= temperature mild) - (= humidity high) - (= windy false))) True) -; - - (= - (example 9 p - ( (= outlook sunny) - (= temperature cool) - (= humidity normal) - (= windy false))) True) -; - - (= - (example 10 p - ( (= outlook rain) - (= temperature mild) - (= humidity normal) - (= windy false))) True) -; - - (= - (example 11 p - ( (= outlook sunny) - (= temperature mild) - (= humidity normal) - (= windy true))) True) -; - - (= - (example 12 p - ( (= outlook overcast) - (= temperature mild) - (= humidity high) - (= windy true))) True) -; - - (= - (example 13 p - ( (= outlook overcast) - (= temperature hot) - (= humidity normal) - (= windy false))) True) -; - - (= - (example 14 n - ( (= outlook rain) - (= temperature mild) - (= humidity high) - (= windy true))) True) -; - +; (convert_to_metta_file idt1_6 $_18768 idt/idt1_6.pl idt/idt1_6.metta) + + (= (classes (n p)) True) + + (= (attributes (outlook temperature humidity windy)) True) + + (= (example 1 n ((= outlook sunny) (= temperature hot) (= humidity high) (= windy false))) True) + (= (example 2 n ((= outlook sunny) (= temperature hot) (= humidity high) (= windy true))) True) + (= (example 3 p ((= outlook overcast) (= temperature hot) (= humidity high) (= windy false))) True) + (= (example 4 p ((= outlook rain) (= temperature mild) (= humidity high) (= windy false))) True) + (= (example 5 p ((= outlook rain) (= temperature cool) (= humidity normal) (= windy false))) True) + (= (example 6 n ((= outlook rain) (= temperature cool) (= humidity normal) (= windy true))) True) + (= (example 7 p ((= outlook overcast) (= temperature cool) (= humidity normal) (= windy true))) True) + (= (example 8 n ((= outlook sunny) (= temperature mild) (= humidity high) (= windy false))) True) + (= (example 9 p ((= outlook sunny) (= temperature cool) (= humidity normal) (= windy false))) True) + (= (example 10 p ((= outlook rain) (= temperature mild) (= humidity normal) (= windy false))) True) + (= (example 11 p ((= outlook sunny) (= temperature mild) (= humidity normal) (= windy true))) True) + (= (example 12 p ((= outlook overcast) (= temperature mild) (= humidity high) (= windy true))) True) + (= (example 13 p ((= outlook overcast) (= temperature hot) (= humidity normal) (= windy false))) True) + (= (example 14 n ((= outlook rain) (= temperature mild) (= humidity high) (= windy true))) True) diff --git a/index/char.metta b/index/char.metta index d9d1bd2..2d01b36 100644 --- a/index/char.metta +++ b/index/char.metta @@ -1,53 +1,45 @@ +; (convert_to_metta_file char $_80026 index/char.pl index/char.metta) - (= - (char $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) - ( (char1 $InICs $PosIn $NegIn Nil $TmpICs $PosOut $NegOut) (cleanup $TmpICs Nil $OutICs))) -; + (= (char $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) + (char1 $InICs $PosIn $NegIn Nil $TmpICs $PosOut $NegOut) + (cleanup $TmpICs Nil $OutICs)) +; /* characterisation */ - - (= - (char1 () $P $N $Out $Out $P $N) True) -; - - (= - (char1 - (Cons $IC $ICs) $P0 $N0 $Acc $Out $P $N) - ( (write-debug (:: 'evaluating ' $IC)) - (evaluate $P0 $N0 $IC $Tuples $P1 $N1 $Answer) + (= (char1 () $P $N $Out $Out $P $N) True) + (= (char1 (Cons $IC $ICs) $P0 $N0 $Acc $Out $P $N) + (write-debug (:: 'evaluating ' $IC)) + (evaluate $P0 $N0 $IC $Tuples $P1 $N1 $Answer) + (det-if-then-else + (= $Answer refine) + (, + (refinements $IC $Tuples $Spec) + (append $ICs $Spec $NewICs) + (= $NewAcc $Acc)) (det-if-then-else - (= $Answer refine) + (= $Answer keep) (, - (refinements $IC $Tuples $Spec) - (append $ICs $Spec $NewICs) - (= $NewAcc $Acc)) + (= $NewICs $ICs) + (= $NewAcc + (Cons $IC $Acc))) (det-if-then-else - (= $Answer keep) + (= $Answer + (ignore $E)) (, (= $NewICs $ICs) - (= $NewAcc - (Cons $IC $Acc))) - (det-if-then-else + (= $NewAcc $Acc)) + (det-if-then (= $Answer - (ignore $E)) + (keep $E)) (, (= $NewICs $ICs) - (= $NewAcc $Acc)) - (det-if-then - (= $Answer - (keep $E)) - (, - (= $NewICs $ICs) - (insert-ic $Acc $IC $E $NewAcc)))))) - (write-debug (:: ' result: ' $Answer)) - (set-det) - (char1 $NewICs $P1 $N1 $NewAcc $Out $P $N))) -; - + (insert-ic $Acc $IC $E $NewAcc)))))) + (write-debug (:: ' result: ' $Answer)) + (set-det) + (char1 $NewICs $P1 $N1 $NewAcc $Out $P $N)) - (= - (evaluate $P0 $N0 $IC $Tuples $P $N $Answer) + (= (evaluate $P0 $N0 $IC $Tuples $P $N $Answer) (det-if-then-else (evaluate1 $P0 $IC $Answer) (, @@ -76,202 +68,112 @@ (, (queries $P0 $N0 $T $P1 $N1) (evaluate $P1 $N1 $IC $Tuples $P $N $Answer))))))))) -; - - +; ; write_debug(['contr...']), - (= - (contr $P $N $IC $Tuples $Answer) - ( (horn $IC $HornIC) (incons $HornIC $P $N $Tuples $Answer))) -; + (= (contr $P $N $IC $Tuples $Answer) + (horn $IC $HornIC) + (incons $HornIC $P $N $Tuples $Answer)) - (= - (queries $P $N () $P $N) True) -; + (= (queries $P $N () $P $N) True) + (= (queries $P $N (Cons $T $Ts) $P1 $N1) + (query $P $N $T $P2 $N2) + (queries $P2 $N2 $Ts $P1 $N1)) - (= - (queries $P $N - (Cons $T $Ts) $P1 $N1) - ( (query $P $N $T $P2 $N2) (queries $P2 $N2 $Ts $P1 $N1))) -; +; (error +; (syntax_error operator_expected) +; (file index/char.pl 41 4 1180)) +; (error +; (syntax_error operator_expected) +; (file index/char.pl 43 4 1267)) -; (error -; (syntax_error operator_expected) -; (file index/char.pl 41 4 1180)) -; (error -; (syntax_error operator_expected) -; (file index/char.pl 43 4 1267)) + (= (query $P $N (- $T) $P (Cons $T $N)) + (switched-on cwa) + (write (- $T)) + (nl)) + (= (query $P $N (+ $T) $P $N) True) - (= - (query $P $N - (- $T) $P - (Cons $T $N)) - ( (switched-on cwa) - (write (- $T)) - (nl))) -; - - (= - (query $P $N - (+ $T) $P $N) True) -; - - - - (= - (cleanup - (Cons $X $In) $Acc $Out) - ( (member $IC $In) - (subsumed $X $IC) - (set-det) - (cleanup $In $Acc $Out))) -; - - (= - (cleanup - (Cons $X $In) $Acc $Out) - ( (member $IC $Acc) - (subsumed $X $IC) - (set-det) - (cleanup $In $Acc $Out))) -; - - (= - (cleanup - (Cons $X $In) $Acc $Out) + (= (cleanup (Cons $X $In) $Acc $Out) + (member $IC $In) + (subsumed $X $IC) + (set-det) + (cleanup $In $Acc $Out)) + (= (cleanup (Cons $X $In) $Acc $Out) + (member $IC $Acc) + (subsumed $X $IC) + (set-det) + (cleanup $In $Acc $Out)) + (= (cleanup (Cons $X $In) $Acc $Out) (cleanup $In (Cons $X $Acc) $Out)) -; - - (= - (cleanup () $Out $Out) True) -; - - - - (= - (incons - (= $Head $Body) $P $N $Tuples $Answer) - ( (satisfied $Body $P $N $TuplesB) - (falsified $Head $P $N $TuplesH) - (set-det) - (= $Answer yes) - (append $TuplesB $TuplesH $Tuples))) -; - - (= - (incons - (= $Head $Body) $P $N $Tuples $Answer) - ( (satisfied $Body $P $N $TuplesB) - (unsatisfied $Head $P $N $TuplesH) - (set-det) - (= $Answer possibly) - (append $TuplesB $TuplesH $Tuples))) -; - - (= - (incons - (= $Head $Body) $P $N Nil $Answer) + (= (cleanup () $Out $Out) True) + + + (= (incons (= $Head $Body) $P $N $Tuples $Answer) + (satisfied $Body $P $N $TuplesB) + (falsified $Head $P $N $TuplesH) + (set-det) + (= $Answer yes) + (append $TuplesB $TuplesH $Tuples)) + (= (incons (= $Head $Body) $P $N $Tuples $Answer) + (satisfied $Body $P $N $TuplesB) + (unsatisfied $Head $P $N $TuplesH) + (set-det) + (= $Answer possibly) + (append $TuplesB $TuplesH $Tuples)) + (= (incons (= $Head $Body) $P $N Nil $Answer) (= $Answer no)) -; - - (= - (satisfied - (, $A $B) $P $N $Tuples) - ( (satisfied $A $P $N $TuplesA) - (satisfied $B $P $N $TuplesB) - (append $TuplesA $TuplesB $Tuples))) -; - - (= - (satisfied - (or $A $B) $P $N $Tuples) + (= (satisfied (, $A $B) $P $N $Tuples) + (satisfied $A $P $N $TuplesA) + (satisfied $B $P $N $TuplesB) + (append $TuplesA $TuplesB $Tuples)) + (= (satisfied (or $A $B) $P $N $Tuples) (or (satisfied $A $P $N $Tuples) (satisfied $B $P $N $Tuples))) -; - - (= - (satisfied $A $P $N - (:: (+ $A))) + (= (satisfied $A $P $N (:: (+ $A))) (member $A $P)) -; - - (= - (satisfied - (= $A $A) $P $N ()) True) -; - ; -; - - (= - (satisfied $A $P $N Nil) - ( (proc $Rel $Proc) (exec-proc $A $Proc))) -; + (= (satisfied (= $A $A) $P $N ()) True) ; +; fds only + (= (satisfied $A $P $N Nil) + (proc $Rel $Proc) + (exec-proc $A $Proc)) - - (= - (exec-proc $Goal - (, $P1 $P2)) + (= (exec-proc $Goal (, $P1 $P2)) (or (exec-proc $Goal $P1) (exec-proc $Goal $P2))) -; - - (= - (exec-proc $Goal - (= $Goal $Body)) + (= (exec-proc $Goal (= $Goal $Body)) (call $Body)) -; - - (= - (falsified - (, $A $B) $P $N $Tuples) + (= (falsified (, $A $B) $P $N $Tuples) (or (, (set-det) (falsified $A $P $N $Tuples)) (falsified $B $P $N $Tuples))) -; - - (= - (falsified $A $P $N - (:: (- $A))) + (= (falsified $A $P $N (:: (- $A))) (member $A $N)) -; - - (= - (falsified - (= $A $B) $P $N Nil) + (= (falsified (= $A $B) $P $N Nil) (\= $A $B)) -; - +; ; fds only - (= - (unsatisfied - (, $A $B) $P $N $Tuples) + (= (unsatisfied (, $A $B) $P $N $Tuples) (or (, (set-det) (unsatisfied $A $P $N $Tuples)) (unsatisfied $B $P $N $Tuples))) -; - - (= - (unsatisfied $A $P $N - (:: (- $A))) - ( (not (satisfied $A $P $N $_)) (not (falsified $A $P $N $_)))) -; - + (= (unsatisfied $A $P $N (:: (- $A))) + (not (satisfied $A $P $N $_)) + (not (falsified $A $P $N $_))) diff --git a/index/commands.metta b/index/commands.metta index 3d070be..4f367e5 100644 --- a/index/commands.metta +++ b/index/commands.metta @@ -1,728 +1,440 @@ +; (convert_to_metta_file commands $_424050 index/commands.pl index/commands.metta) - (= - (keyword1 save ' save in Prolog database') True) -; + (= (keyword1 save ' save in Prolog database') True) +; /* commands */ + (= (keyword1 get ' get from Prolog database') True) + (= (keyword1 show ' show current') True) + (= (keyword1 count ' count current') True) + (= (keyword1 del ' delete') True) + (= (keyword1 add ' add new') True) + (= (keyword1 init ' initialise constraints') True) + (= (keyword1 find ' find constraints') True) + (= (keyword1 check ' check validity') True) + (= (keyword1 decomp ' decompose relation') True) + (= (keyword1 comp ' compose relations') True) + (= (keyword1 switch ' switch on or off') True) + (= (keyword1 set ' set level') True) + (= (keyword1 help ' get help') True) - (= - (keyword1 get ' get from Prolog database') True) -; - (= - (keyword1 show ' show current') True) -; + (= (keyword2 pos ' positive tuples') True) + (= (keyword2 neg ' negative tuples') True) + (= (keyword2 ics ' integrity constraints') True) + (= (keyword2 calc ' calculated relations') True) - (= - (keyword1 count ' count current') True) -; - (= - (keyword1 del ' delete') True) -; + (= (switch cwa ' Closed-World Assumption') True) + (= (switch horn ' display in Horn form') True) + (= (switch eval ' evaluate constraints') True) + (= (switch debug ' show debugging information') True) - (= - (keyword1 add ' add new') True) -; - - (= - (keyword1 init ' initialise constraints') True) -; - - (= - (keyword1 find ' find constraints') True) -; - - (= - (keyword1 check ' check validity') True) -; - - (= - (keyword1 decomp ' decompose relation') True) -; - - (= - (keyword1 comp ' compose relations') True) -; - - (= - (keyword1 switch ' switch on or off') True) -; - - (= - (keyword1 set ' set level') True) -; - - (= - (keyword1 help ' get help') True) -; - - - - (= - (keyword2 pos ' positive tuples') True) -; - - (= - (keyword2 neg ' negative tuples') True) -; - - (= - (keyword2 ics ' integrity constraints') True) -; - - (= - (keyword2 calc ' calculated relations') True) -; - - - - (= - (switch cwa ' Closed-World Assumption') True) -; - - (= - (switch horn ' display in Horn form') True) -; - - (= - (switch eval ' evaluate constraints') True) -; - - (= - (switch debug ' show debugging information') True) -; - - - - (= - (level conf ' confirmation level of constraint') True) -; - - (= - (level acc ' accuracy of constraint') True) -; - - (= - (level split ' splitting level of constraint') True) -; + (= (level conf ' confirmation level of constraint') True) + (= (level acc ' accuracy of constraint') True) + (= (level split ' splitting level of constraint') True) !(forall (^ $T (keyword1 $W $T)) (op 1200 fx $W)) -; - !(forall (^ $T (keyword2 $W $T)) (op 1100 fx $W)) -; - !(forall (^ $T (level $W $T)) (op 1100 fx $W)) -; - - - (= - (commands $InICs $PosIn $NegIn) - ( (prompt-read '' $Command) - (do-command $Command $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) - (set-det) - (commands $OutICs $PosOut $NegOut))) -; - (= - (commands $InICs $PosIn $NegIn) - ( (write no) - (nl) - (set-det) - (commands $InICs $PosIn $NegIn))) -; - - - - (= - (do-command - (save $X) $ICs $Pos $Neg $ICs $Pos $Neg) - ( (set-det) (save-command $X $ICs $Pos $Neg))) -; - - (= - (do-command - (get $X) $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) - ( (set-det) (get-command $X $InICs $PosIn $NegIn $OutICs $PosOut $NegOut))) -; - - (= - (do-command - (show $X) $ICs $Pos $Neg $ICs $Pos $Neg) - ( (set-det) (show-command $X $ICs $Pos $Neg))) -; - - (= - (do-command - (count $X) $ICs $Pos $Neg $ICs $Pos $Neg) - ( (set-det) (count-command $X $ICs $Pos $Neg))) -; - - (= - (do-command - (del $X) $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) - ( (set-det) (del-command $X $InICs $PosIn $NegIn $OutICs $PosOut $NegOut))) -; - - (= - (do-command - (add $X) $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) - ( (set-det) (add-command $X $InICs $PosIn $NegIn $OutICs $PosOut $NegOut))) -; - - (= - (do-command - (init $X) $InICs $Pos $Neg $OutICs $Pos $Neg) - ( (set-det) (init-command $X $InICs $OutICs))) -; - - (= - (do-command - (find $X) $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) - ( (set-det) (find-command $X $InICs $PosIn $NegIn $OutICs $PosOut $NegOut))) -; - - (= - (do-command - (check $X) $ICs $Pos $Neg $ICs $Pos $Neg) - ( (set-det) (check-command $X $ICs $Pos $Neg))) -; - - (= - (do-command - (decomp $IC) $InICs $PosIn $Neg $OutICs $PosOut $Neg) - ( (set-det) (decompose $IC $PosIn $PosOut $InICs $OutICs))) -; - - (= - (do-command - (comp $Rule) $ICs $PosIn $Neg $ICs $PosOut $Neg) - ( (set-det) - (exec-rule $Rule $PosIn $PosNew) - (append $PosIn $PosNew $PosOut))) -; - - (= - (do-command - (switch $X) $ICs $Pos $Neg $ICs $Pos $Neg) - ( (set-det) (switch $X))) -; - - (= - (do-command - (set $X) $ICs $Pos $Neg $ICs $Pos $Neg) - ( (set-det) (set $X))) -; - - (= - (do-command - (help $Topic) $ICs $Pos $Neg $ICs $Pos $Neg) - ( (set-det) (help-command $Topic))) -; - - (= - (do-command $Command $ICs $Pos $Neg $ICs $Pos $Neg) + (= (commands $InICs $PosIn $NegIn) + (prompt-read '' $Command) + (do-command $Command $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) + (set-det) + (commands $OutICs $PosOut $NegOut)) + (= (commands $InICs $PosIn $NegIn) + (write no) + (nl) + (set-det) + (commands $InICs $PosIn $NegIn)) + + + (= (do-command (save $X) $ICs $Pos $Neg $ICs $Pos $Neg) + (set-det) + (save-command $X $ICs $Pos $Neg)) + (= (do-command (get $X) $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) + (set-det) + (get-command $X $InICs $PosIn $NegIn $OutICs $PosOut $NegOut)) + (= (do-command (show $X) $ICs $Pos $Neg $ICs $Pos $Neg) + (set-det) + (show-command $X $ICs $Pos $Neg)) + (= (do-command (count $X) $ICs $Pos $Neg $ICs $Pos $Neg) + (set-det) + (count-command $X $ICs $Pos $Neg)) + (= (do-command (del $X) $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) + (set-det) + (del-command $X $InICs $PosIn $NegIn $OutICs $PosOut $NegOut)) + (= (do-command (add $X) $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) + (set-det) + (add-command $X $InICs $PosIn $NegIn $OutICs $PosOut $NegOut)) + (= (do-command (init $X) $InICs $Pos $Neg $OutICs $Pos $Neg) + (set-det) + (init-command $X $InICs $OutICs)) + (= (do-command (find $X) $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) + (set-det) + (find-command $X $InICs $PosIn $NegIn $OutICs $PosOut $NegOut)) + (= (do-command (check $X) $ICs $Pos $Neg $ICs $Pos $Neg) + (set-det) + (check-command $X $ICs $Pos $Neg)) + (= (do-command (decomp $IC) $InICs $PosIn $Neg $OutICs $PosOut $Neg) + (set-det) + (decompose $IC $PosIn $PosOut $InICs $OutICs)) + (= (do-command (comp $Rule) $ICs $PosIn $Neg $ICs $PosOut $Neg) + (set-det) + (exec-rule $Rule $PosIn $PosNew) + (append $PosIn $PosNew $PosOut)) + (= (do-command (switch $X) $ICs $Pos $Neg $ICs $Pos $Neg) + (set-det) + (switch $X)) + (= (do-command (set $X) $ICs $Pos $Neg $ICs $Pos $Neg) + (set-det) + (set $X)) + (= (do-command (help $Topic) $ICs $Pos $Neg $ICs $Pos $Neg) + (set-det) + (help-command $Topic)) + (= (do-command $Command $ICs $Pos $Neg $ICs $Pos $Neg) (call $Command)) -; - - (= - (do-command $Command $ICs $Pos $Neg $ICs $Pos $Neg) + (= (do-command $Command $ICs $Pos $Neg $ICs $Pos $Neg) (write ?)) -; - - (= - (save-command - (pos $Rel) $ICs $Pos $Neg) + (= (save-command (pos $Rel) $ICs $Pos $Neg) (save-pos $Rel $Pos)) -; - - (= - (save-command - (neg $Rel) $ICs $Pos $Neg) + (= (save-command (neg $Rel) $ICs $Pos $Neg) (save-neg $Rel $Neg)) -; - - (= - (save-command - (ics $T) $ICs $Pos $Neg) + (= (save-command (ics $T) $ICs $Pos $Neg) (save-ics $T $ICs)) -; - - - - (= - (get-command - (pos $Rel) $ICs $PosIn $Neg $ICs $PosOut $Neg) - ( (get-pos $Rel $Pos) (append $PosIn $Pos $PosOut))) -; - - (= - (get-command - (neg $Rel) $ICs $Pos $NegIn $ICs $Pos $NegOut) - ( (get-neg $Rel $Neg) (append $NegIn $Neg $NegOut))) -; - - (= - (get-command - (ics $T) $InICs $Pos $Neg $OutICs $Pos $Neg) - ( (get-ics $T $ICs) (append $InICs $ICs $OutICs))) -; - - - - (= - (show-command all $ICs $Pos $Neg) - ( (set-det) - (show-list 'positive tuples' $Pos) - (show-list 'negative tuples' $Neg) - (show-list 'integrity constraints' $ICs))) -; - - (= - (show-command rel $ICs $Pos $Neg) - ( (set-det) - (bagof0 $R - (^ $A - (rel $R $A)) $Rels) - (show-list relations $Rels))) -; - - (= - (show-command $Other $ICs $Pos $Neg) - ( (get-list $Other $ICs $Pos $Neg $List $Text) - (set-det) - (show-list $Text $List))) -; - (= - (show-command $Wrong $ICs $Pos $Neg) + + (= (get-command (pos $Rel) $ICs $PosIn $Neg $ICs $PosOut $Neg) + (get-pos $Rel $Pos) + (append $PosIn $Pos $PosOut)) + (= (get-command (neg $Rel) $ICs $Pos $NegIn $ICs $Pos $NegOut) + (get-neg $Rel $Neg) + (append $NegIn $Neg $NegOut)) + (= (get-command (ics $T) $InICs $Pos $Neg $OutICs $Pos $Neg) + (get-ics $T $ICs) + (append $InICs $ICs $OutICs)) + + + (= (show-command all $ICs $Pos $Neg) + (set-det) + (show-list 'positive tuples' $Pos) + (show-list 'negative tuples' $Neg) + (show-list 'integrity constraints' $ICs)) + (= (show-command rel $ICs $Pos $Neg) + (set-det) + (bagof0 $R + (^ $A + (rel $R $A)) $Rels) + (show-list relations $Rels)) + (= (show-command $Other $ICs $Pos $Neg) + (get-list $Other $ICs $Pos $Neg $List $Text) + (set-det) + (show-list $Text $List)) + (= (show-command $Wrong $ICs $Pos $Neg) (show-list choices (:: 'show all' 'show rel' 'show pos all' 'show pos Rel' 'show neg all' 'show neg Rel' 'show ics all' 'show ics Rel'))) -; - - - - (= - (count-command $Filter $ICs $Pos $Neg) - ( (get-list $Filter $ICs $Pos $Neg $List $Text) - (length $List $N) - (write-list (:: 'There are ' $N ' ' $Text .)) - (nl))) -; + (= (count-command $Filter $ICs $Pos $Neg) + (get-list $Filter $ICs $Pos $Neg $List $Text) + (length $List $N) + (write-list (:: 'There are ' $N ' ' $Text .)) + (nl)) - (= - (del_command all $ICs $Pos $Neg () () ()) True) -; - (= - (del-command - (ics $F) $InICs $Pos $Neg $OutICs $Pos $Neg) + (= (del_command all $ICs $Pos $Neg () () ()) True) + (= (del-command (ics $F) $InICs $Pos $Neg $OutICs $Pos $Neg) (filter $InICs $F $Deleted $OutICs)) -; - - (= - (del-command - (pos $Rel) $ICs $PosIn $Neg $ICs $PosOut $Neg) + (= (del-command (pos $Rel) $ICs $PosIn $Neg $ICs $PosOut $Neg) (filter $PosIn $Rel $Deleted $PosOut)) -; - - (= - (del-command - (neg $Rel) $ICs $Pos $NegIn $ICs $Pos $NegOut) + (= (del-command (neg $Rel) $ICs $Pos $NegIn $ICs $Pos $NegOut) (filter $NegIn $Rel $Deleted $NegOut)) -; - - (= - (del-command - (rel $R) $ICs $PosIn $NegIn $ICs $PosOut $NegOut) - ( (remove-symbol &self + (= (del-command (rel $R) $ICs $PosIn $NegIn $ICs $PosOut $NegOut) + ( (remove-is-symbol &self (rel $R $AList)) (filter $PosIn $Rel $_ $PosOut) (filter $NegIn $Rel $_ $NegOut))) -; - - (= - (del-command - (calc $Rel) $InICs $Pos $Neg $OutICs $Pos $Neg) - ( (remove-all-symbols &self + (= (del-command (calc $Rel) $InICs $Pos $Neg $OutICs $Pos $Neg) + ( (remove-all-atoms &self (proc $Rel $Proc)) (remove (proc $Rel) $InICs $OutICs))) -; - - (= - (add-command - (ics $DisplayIC) $ICs $Pos $Neg - (Cons $IC $ICs) $Pos $Neg) + (= (add-command (ics $DisplayIC) $ICs $Pos $Neg (Cons $IC $ICs) $Pos $Neg) (display $IC $DisplayIC)) -; - - (= - (add_command - (pos $Tuple) $ICs $Pos $Neg $ICs - (Cons $Tuple $Pos) $Neg) True) -; - - (= - (add_command - (neg $Tuple) $ICs $Pos $Neg $ICs $Pos - (Cons $Tuple $Neg)) True) -; - - (= - (add-command - (rel $R $AList) $ICs $Pos $Neg $ICs $Pos $Neg) + (= (add_command (pos $Tuple) $ICs $Pos $Neg $ICs (Cons $Tuple $Pos) $Neg) True) + (= (add_command (neg $Tuple) $ICs $Pos $Neg $ICs $Pos (Cons $Tuple $Neg)) True) + (= (add-command (rel $R $AList) $ICs $Pos $Neg $ICs $Pos $Neg) (new-rel $R $AList)) -; - - (= - (add-command - (calc $Rel) $InICs $PosIn $Neg - (Cons - (proc $Rel) $OutICs) $PosOut $Neg) - ( (ask-proc $Rel) - (filter $PosIn $Rel $RelTuples $_) - (setof0 $T - (, - (member $T $RelTuples) - (satisfied $T Nil Nil Nil)) $SatTuples) - (listdiff $PosIn $SatTuples $PosOut) - (remove - (proc $Rel) $InICs $OutICs))) -; - + (= (add-command (calc $Rel) $InICs $PosIn $Neg (Cons (proc $Rel) $OutICs) $PosOut $Neg) + (ask-proc $Rel) + (filter $PosIn $Rel $RelTuples $_) + (setof0 $T + (, + (member $T $RelTuples) + (satisfied $T Nil Nil Nil)) $SatTuples) + (listdiff $PosIn $SatTuples $PosOut) + (remove + (proc $Rel) $InICs $OutICs)) - (= - (init-command - (ics $Rel) $InICs $OutICs) - ( (init-ICs $Rel $ICs) (append $InICs $ICs $OutICs))) -; - + (= (init-command (ics $Rel) $InICs $OutICs) + (init-ICs $Rel $ICs) + (append $InICs $ICs $OutICs)) - (= - (find-command ics $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) + (= (find-command ics $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) (char $InICs $PosIn $NegIn $OutICs $PosOut $NegOut)) -; - - - - (= - (check-command - (ics $DisplayIC) $ICs $Pos $Neg) - ( (display $IC $DisplayIC) (check-ics $IC $Pos $Neg))) -; - - (= - (check-command - (pos $Tuple) $ICs $Pos $Neg) - ( (set-det) (forall (member $IC $ICs) (check-ics $IC (Cons $Tuple $Pos) $Neg)))) -; - - - - (= - (help-command commands) - ( (set-det) - (bagof0 - (with_self $W $T) - (keyword1 $W $T) $L) - (show-list Commands $L))) -; - - (= - (help-command filters) - ( (set-det) - (bagof0 - (with_self $W $T) - (keyword2 $W $T) $L) - (show-list Filters $L))) -; - - (= - (help-command switches) - ( (set-det) - (bagof0 - (with_self $W $T) - (switch $W $T) $L) - (show-list Switches $L))) -; - - (= - (help-command levels) - ( (set-det) - (bagof0 - (with_self $W $T) - (level $W $T) $L) - (show-list Levels $L))) -; - - (= - (help-command $_) - ( (help-command commands) - (help-command filters) - (help-command switches) - (help-command levels))) -; - - - - (= - (get-list - (pos $Filter) $ICs $Pos $Neg $List 'positive tuples') - (filter $Pos $Filter $List)) -; - - (= - (get-list - (neg $Filter) $ICs $Pos $Neg $List 'negative tuples') - (filter $Neg $Filter $List)) -; - - (= - (get-list - (ics $Filter) $ICs $Pos $Neg $List 'integrity constraints') - ( (filter $ICs $Filter $Tmp) (compress $Tmp $List))) -; - - - - (= - (filter $In $F $Out) - ( (template $F $Template) (setof0 $Template (member $Template $In) $Out))) -; - - - (= - (filter $In $F $Out $Rest) - ( (filter $In $F $Out) (listdiff $In $Out $Rest))) -; - - (= - (new-rel $R $Attrs) - ( (rel $R $Attrs) (set-det))) -; - - (= - (new-rel $R $Attrs) - ( (rel $R $A) - (set-det) - (write 'Error: relation name already in use') - (nl) - (fail))) -; - - (= - (new-rel $R $Attrs) - (add-symbol &self + (= (check-command (ics $DisplayIC) $ICs $Pos $Neg) + (display $IC $DisplayIC) + (check-ics $IC $Pos $Neg)) + (= (check-command (pos $Tuple) $ICs $Pos $Neg) + (set-det) + (forall + (member $IC $ICs) + (check-ics $IC + (Cons $Tuple $Pos) $Neg))) + + + (= (help-command commands) + (set-det) + (bagof0 + (with_self $W $T) + (keyword1 $W $T) $L) + (show-list Commands $L)) + (= (help-command filters) + (set-det) + (bagof0 + (with_self $W $T) + (keyword2 $W $T) $L) + (show-list Filters $L)) + (= (help-command switches) + (set-det) + (bagof0 + (with_self $W $T) + (switch $W $T) $L) + (show-list Switches $L)) + (= (help-command levels) + (set-det) + (bagof0 + (with_self $W $T) + (level $W $T) $L) + (show-list Levels $L)) + (= (help-command $_) + (help-command commands) + (help-command filters) + (help-command switches) + (help-command levels)) + + + (= (get-list (pos $Filter) $ICs $Pos $Neg $List 'positive tuples') + (filter $Pos $Filter $List)) + (= (get-list (neg $Filter) $ICs $Pos $Neg $List 'negative tuples') + (filter $Neg $Filter $List)) + (= (get-list (ics $Filter) $ICs $Pos $Neg $List 'integrity constraints') + (filter $ICs $Filter $Tmp) + (compress $Tmp $List)) + + + (= (filter $In $F $Out) + (template $F $Template) + (setof0 $Template + (member $Template $In) $Out)) + + (= (filter $In $F $Out $Rest) + (filter $In $F $Out) + (listdiff $In $Out $Rest)) + + + (= (new-rel $R $Attrs) + (rel $R $Attrs) + (set-det)) + (= (new-rel $R $Attrs) + (rel $R $A) + (set-det) + (write 'Error: relation name already in use') + (nl) + (fail)) + (= (new-rel $R $Attrs) + (add-is-symbol &self (rel $R $Attrs))) -; - - (= - (ask-proc $Rel) + (= (ask-proc $Rel) ( (prompt-read clause $Clause) - (add-symbol &self + (add-is-symbol &self (proc $Rel $Clause)) (set-det) (ask-proc $Rel))) -; - - (= - (ask_proc $Rel) True) -; - - - - (= - (get-pos $Rel $Pos) - ( (template $Rel $Tuple) (bagof0 $Tuple (pos-tuple $Tuple) $Pos))) -; - + (= (ask_proc $Rel) True) - (= - (get-neg $Rel $Neg) - ( (template $Rel $Tuple) (bagof0 $Tuple (neg-tuple $Tuple) $Neg))) -; + (= (get-pos $Rel $Pos) + (template $Rel $Tuple) + (bagof0 $Tuple + (pos-tuple $Tuple) $Pos)) + (= (get-neg $Rel $Neg) + (template $Rel $Tuple) + (bagof0 $Tuple + (neg-tuple $Tuple) $Neg)) - (= - (get-ics $T $ICs) - ( (template $T $Templ) (bagof0 $Templ (constraint $Templ) $ICs))) -; + (= (get-ics $T $ICs) + (template $T $Templ) + (bagof0 $Templ + (constraint $Templ) $ICs)) - (= - (save-pos $Rel $Pos) - ( (template $Rel $T) (forall (member $T $Pos) (myassert (pos-tuple $T))))) -; + (= (save-pos $Rel $Pos) + (template $Rel $T) + (forall + (member $T $Pos) + (myassert (pos-tuple $T)))) + (= (save-neg $Rel $Neg) + (template $Rel $T) + (forall + (member $T $Neg) + (myassert (neg-tuple $T)))) - (= - (save-neg $Rel $Neg) - ( (template $Rel $T) (forall (member $T $Neg) (myassert (neg-tuple $T))))) -; + (= (save-ics $T $ICs) + (template $T $Templ) + (forall + (member $Templ $ICs) + (myassert (constraint $Templ)))) - (= - (save-ics $T $ICs) - ( (template $T $Templ) (forall (member $Templ $ICs) (myassert (constraint $Templ))))) -; - - - - (= - (check-ics $IC $Pos $Neg) - ( (display $IC $DisplayIC) - (evaluate $Pos $Neg $IC $Tuples $PosOut $NegOut $Answer) - (write $DisplayIC) + (= (check-ics $IC $Pos $Neg) + (display $IC $DisplayIC) + (evaluate $Pos $Neg $IC $Tuples $PosOut $NegOut $Answer) + (write $DisplayIC) + (det-if-then-else + (= $Answer refine) + (show-list ' is contradicted by' $Tuples) (det-if-then-else - (= $Answer refine) - (show-list ' is contradicted by' $Tuples) + (= $Answer keep) + (, + (write ' is satisfied') + (nl)) (det-if-then-else - (= $Answer keep) + (= $Answer + (keep $E)) (, - (write ' is satisfied') + (write-list (:: ' looks promising: ' $E)) (nl)) - (det-if-then-else + (det-if-then (= $Answer - (keep $E)) + (ignore $E)) (, - (write-list (:: ' looks promising: ' $E)) - (nl)) - (det-if-then - (= $Answer - (ignore $E)) - (, - (write-list (:: ' has low confirmation: ' $E)) - (nl)))))))) -; - + (write-list (:: ' has low confirmation: ' $E)) + (nl))))))) - (= - (switch $X) + (= (switch $X) ( (switch $X $T) - (remove-symbol &self + (remove-is-symbol &self (switched_on $X)) (set-det) (write-list (:: $X ' is now off.')) (nl))) -; - - (= - (switch $X) + (= (switch $X) ( (switch $X $T) (set-det) - (add-symbol &self + (add-is-symbol &self (switched_on $X)) (write-list (:: $X ' is now on.')) (nl))) -; - ; (error ; (syntax_error operator_expected) ; (file index/commands.pl 251 28 7757)) - (= - (set $X) - ( (=.. $X - (Cons $Level $Rest)) - (level $Level $T) - (set-det) - (det-if-then-else - (= $Rest - (:: $Value)) - (, - (or - (, - (remove-symbol &self - (level_set $Level $V)) - (set-det)) True) - (add-symbol &self - (level_set $Level $Value))) - (det-if-then - (= $Rest Nil) + (= (set $X) + (=.. $X + (Cons $Level $Rest)) + (level $Level $T) + (set-det) + (det-if-then-else + (= $Rest + (:: $Value)) + (, + (or (, - (get-level $Level $L) - (write (= $Level $L)) - (nl)))))) -; - - (= - (set $_) - ( (setof0 - (= $L $V) - (^ $T - (, - (level $L $T) - (get-level $L $V))) $L) (show-list levels $L))) -; - - - - (= - (get-level $Level $Value) - ( (level $Level $T) (or (, (level-set $Level $Value) (set-det)) (= $Value 0)))) -; - - - - (= - (compare $X) - ( (=.. $X - (:: $Level $Value)) - (get-level $Level $L) + (remove-is-symbol &self + (level_set $Level $V)) + (set-det)) True) + (add-is-symbol &self + (level_set $Level $Value))) + (det-if-then + (= $Rest Nil) + (, + (get-level $Level $L) + (write (= $Level $L)) + (nl))))) + (= (set $_) + (setof0 + (= $L $V) + (^ $T + (, + (level $L $T) + (get-level $L $V))) $L) + (show-list levels $L)) + + + (= (get-level $Level $Value) + (level $Level $T) + (or + (, + (level-set $Level $Value) + (set-det)) + (= $Value 0))) + + + (= (compare $X) + (=.. $X + (:: $Level $Value)) + (get-level $Level $L) + (det-if-then-else + (= $L + (+ $V)) + (>= $Value $V) (det-if-then-else (= $L - (+ $V)) - (>= $Value $V) + (- $V)) + (=< $Value $V) (det-if-then-else (= $L - (- $V)) - (=< $Value $V) - (det-if-then-else - (= $L - (/ $V $A)) + (/ $V $A)) + (, + (is $Upper + (+ $V $A)) + (=< $Value $Upper) + (is $Lower + (- $V $A)) + (>= $Value $Lower)) + (det-if-then otherwise (, - (is $Upper - (+ $V $A)) - (=< $Value $Upper) - (is $Lower - (- $V $A)) - (>= $Value $Lower)) - (det-if-then otherwise - (, - (write-list (:: 'Wrong level: ' (= $Level $L))) - (nl) - (break)))))))) -; - + (write-list (:: 'Wrong level: ' (= $Level $L))) + (nl) + (break))))))) diff --git a/index/decomp.metta b/index/decomp.metta index 0f897b3..1e62c58 100644 --- a/index/decomp.metta +++ b/index/decomp.metta @@ -1,279 +1,198 @@ - - (= - (decompose $DisplayIC $PosIn $PosOut $InICs $OutICs) - ( (display $IC $DisplayIC) - (contr $PosIn Nil $IC $Tuples $Answer) - (det-if-then-else - (= $Answer no) - (split $IC $PosIn $PosOut $InICs $OutICs) - (det-if-then otherwise - (divide $PosIn $IC $PosOut $InICs $OutICs))))) -; - - - - (= - (split $Dep $PosIn $PosOut $ICs - (Cons $Join $ICs)) - ( (dep $Dep $Type $Rel $From $To) (split1 $Rel $From $To $PosIn $PosOut $Join))) -; - - - - (= - (split1 $Rel $From $To $PosIn $PosOut - (join $Rel $R1 $R2)) - ( (append $From $To $In1) - (new-name $In1 $Out1 $R1) - (rel $Rel $AttrList) - (listdiff $AttrList $To $In2) - (new-name $In2 $Out2 $R2) - (splits $Rel $R1 $R2 $Out1 $Out2 $PosIn $PosTmp) - (remove-dups $PosTmp $PosOut))) -; - - - - (= - (splits $Rel $R1 $R2 $AList1 $AList2 () ()) True) -; - - (= - (splits $Rel $R1 $R2 $AList1 $AList2 - (Cons $T $Ts) - (Cons $T1 - (Cons $T2 $Rest))) - ( (values $Rel $AList1 $ValueList1 $T) - (set-det) - (=.. $T1 - (Cons $R1 $ValueList1)) - (values $Rel $AList2 $ValueList2 $T) - (=.. $T2 - (Cons $R2 $ValueList2)) - (splits $Rel $R1 $R2 $AList1 $AList2 $Ts $Rest))) -; - - (= - (splits $Rel $R1 $R2 $AList1 $AList2 - (Cons $T $Ts) - (Cons $T $Rest)) +; (convert_to_metta_file decomp $_297580 index/decomp.pl index/decomp.metta) + + (= (decompose $DisplayIC $PosIn $PosOut $InICs $OutICs) + (display $IC $DisplayIC) + (contr $PosIn Nil $IC $Tuples $Answer) + (det-if-then-else + (= $Answer no) + (split $IC $PosIn $PosOut $InICs $OutICs) + (det-if-then otherwise + (divide $PosIn $IC $PosOut $InICs $OutICs)))) +; /* text of window: decomp */ + + + (= (split $Dep $PosIn $PosOut $ICs (Cons $Join $ICs)) + (dep $Dep $Type $Rel $From $To) + (split1 $Rel $From $To $PosIn $PosOut $Join)) + + + (= (split1 $Rel $From $To $PosIn $PosOut (join $Rel $R1 $R2)) + (append $From $To $In1) + (new-name $In1 $Out1 $R1) + (rel $Rel $AttrList) + (listdiff $AttrList $To $In2) + (new-name $In2 $Out2 $R2) + (splits $Rel $R1 $R2 $Out1 $Out2 $PosIn $PosTmp) + (remove-dups $PosTmp $PosOut)) + + + (= (splits $Rel $R1 $R2 $AList1 $AList2 () ()) True) + (= (splits $Rel $R1 $R2 $AList1 $AList2 (Cons $T $Ts) (Cons $T1 (Cons $T2 $Rest))) + (values $Rel $AList1 $ValueList1 $T) + (set-det) + (=.. $T1 + (Cons $R1 $ValueList1)) + (values $Rel $AList2 $ValueList2 $T) + (=.. $T2 + (Cons $R2 $ValueList2)) (splits $Rel $R1 $R2 $AList1 $AList2 $Ts $Rest)) -; - + (= (splits $Rel $R1 $R2 $AList1 $AList2 (Cons $T $Ts) (Cons $T $Rest)) + (splits $Rel $R1 $R2 $AList1 $AList2 $Ts $Rest)) +; ; T not in Rel - (= - (new-name $AListIn $AListOut $R) - ( (show-list attributes $AListIn) - (prompt-read 'relation name' $Answer) + (= (new-name $AListIn $AListOut $R) + (show-list attributes $AListIn) + (prompt-read 'relation name' $Answer) + (det-if-then-else + (= $Answer -) + (, + (concat-atom $AListIn $R) + (= $AListOut $AListIn)) (det-if-then-else - (= $Answer -) + (= $Answer +) (, - (concat-atom $AListIn $R) - (= $AListOut $AListIn)) - (det-if-then-else - (= $Answer +) - (, - (prompt-read 'rel(Name,AttrList)' - (rel $R $AListOut)) - (permutation $AListOut $AListIn)) - (det-if-then otherwise - (, - (= $R $Answer) - (= $AListOut $AListIn))))) - (new-rel $R $AListOut))) -; - - - - (= - (exec-rule $DisplayRule $PosIn $PosOut) - ( (display $Rule $DisplayRule) - (horn $Rule - (= $Tuple $Body)) - (setof0 $Tuple - (^ $Ts - (satisfied $Body $PosIn Nil $Ts)) $PosOut))) -; - - - - (= - (divide $PosIn $Dep $PosOut $InICs - (Cons - (plus $Rel $Names) $OutICs)) - ( (dep $Dep $Type $Rel $From $To) - (filter $PosIn $Rel $PosFiltered $Rest) - (splitsort $PosFiltered $Dep $SplitPos) - (joinsort $SplitPos $Dep $NotContr $Contr) - (find-division $Rel $NotContr $Contr $Numbers $NewPos1) - (new-preds $Rel $NewPos1 Nil $PosTmp1 Nil $Names) - (append $PosTmp1 $Rest $PosTmp2) - (decomp-again $Names $Dep $PosTmp2 $PosOut $InICs $OutICs))) -; - - - - (= - (decomp_again () $Dep $Pos $Pos $ICs $ICs) True) -; - - (= - (decomp-again - (Cons $Name $Names) $Dep $PosIn $PosOut $InICs $OutICs) - ( (det-if-then-else - (yesno (:: 'Decompose ' $Name ? )) - (, - (dep $Dep $Type $R $From $To) - (dep $NewDep $Type $Name $From $To) - (display $NewDep $DDep) - (decompose $DDep $PosIn $PosTmp $InICs $TmpICs)) + (prompt-read 'rel(Name,AttrList)' + (rel $R $AListOut)) + (permutation $AListOut $AListIn)) (det-if-then otherwise (, - (= $PosTmp $PosIn) - (= $TmpICs $InICs)))) (decomp-again $Names $Dep $PosTmp $PosOut $TmpICs $OutICs))) -; - - - - (= - (divides () $Dep () ()) True) -; + (= $R $Answer) + (= $AListOut $AListIn))))) + (new-rel $R $AListOut)) + + + (= (exec-rule $DisplayRule $PosIn $PosOut) + (display $Rule $DisplayRule) + (horn $Rule + (= $Tuple $Body)) + (setof0 $Tuple + (^ $Ts + (satisfied $Body $PosIn Nil $Ts)) $PosOut)) + + + (= (divide $PosIn $Dep $PosOut $InICs (Cons (plus $Rel $Names) $OutICs)) + (dep $Dep $Type $Rel $From $To) + (filter $PosIn $Rel $PosFiltered $Rest) + (splitsort $PosFiltered $Dep $SplitPos) + (joinsort $SplitPos $Dep $NotContr $Contr) + (find-division $Rel $NotContr $Contr $Numbers $NewPos1) + (new-preds $Rel $NewPos1 Nil $PosTmp1 Nil $Names) + (append $PosTmp1 $Rest $PosTmp2) + (decomp-again $Names $Dep $PosTmp2 $PosOut $InICs $OutICs)) +; ; divides(SplitPos,Dep,NewPos,Numbers), + + + (= (decomp_again () $Dep $Pos $Pos $ICs $ICs) True) + (= (decomp-again (Cons $Name $Names) $Dep $PosIn $PosOut $InICs $OutICs) + (det-if-then-else + (yesno (:: 'Decompose ' $Name ? )) + (, + (dep $Dep $Type $R $From $To) + (dep $NewDep $Type $Name $From $To) + (display $NewDep $DDep) + (decompose $DDep $PosIn $PosTmp $InICs $TmpICs)) + (det-if-then otherwise + (, + (= $PosTmp $PosIn) + (= $TmpICs $InICs)))) + (decomp-again $Names $Dep $PosTmp $PosOut $TmpICs $OutICs)) - (= - (divides - (Cons $H $T) $Dep - (Cons $NewH $NewT) - (Cons $NsH $NsT)) - ( (length $H $LH) - (divide1 $H $LH $_ Nil 0 $_ $Dep $NewH $NsH) - (set-det) - (divides $T $Dep $NewT $NsT))) -; + (= (divides () $Dep () ()) True) + (= (divides (Cons $H $T) $Dep (Cons $NewH $NewT) (Cons $NsH $NsT)) + (length $H $LH) + (divide1 $H $LH $_ Nil 0 $_ $Dep $NewH $NsH) + (set-det) + (divides $T $Dep $NewT $NsT)) - (= - (divide1 $Pos1 $Pos2 $IC $PosOut) + (= (divide1 $Pos1 $Pos2 $IC $PosOut) (divide1 $Pos1 0 $_ $Pos2 0 $_ $IC $PosOut $_)) -; - - (= - (divide1 Nil $K $K Nil $L $L $IC Nil Nil) + (= (divide1 Nil $K $K Nil $L $L $IC Nil Nil) (set-det)) -; - - (= - (divide1 $Pos1 $K0 $K $Pos2 $L0 $L $IC $PosOut $M) - ( (contr $Pos1 Nil $IC $Tuples $Answer) - (det-if-then-else - (or - (= $Answer yes) - (= $Answer possibly)) - (, - (= $Tuples + (= (divide1 $Pos1 $K0 $K $Pos2 $L0 $L $IC $PosOut $M) + (contr $Pos1 Nil $IC $Tuples $Answer) + (det-if-then-else + (or + (= $Answer yes) + (= $Answer possibly)) + (, + (= $Tuples + (Cons + (+ $T1) (Cons - (+ $T1) - (Cons - (+ $T2) $N))) - (remove $T2 $Pos1 $NewPos1) - (is $K1 - (- $K0 1)) - (= $NewPos2 - (Cons $T2 $Pos2)) - (is $L1 - (+ $L0 1)) - (= $PosOut $NewPosOut) - (= $M $NewM)) - (det-if-then - (= $Answer no) - (, - (= $NewPos1 $Pos2) - (= $K1 $L0) - (= $NewPos2 Nil) - (= $L1 0) - (= $PosOut - (Cons $Pos1 $NewPosOut)) - (= $M - (Cons $K0 $NewM))))) - (set-det) - (divide1 $NewPos1 $K1 $K $NewPos2 $L1 $L $IC $NewPosOut $NewM))) -; - - - - (= - (find-division $Rel $NotContr $Contr $Numbers $NewPos) - ( (det-if-then-else - (= $NotContr Nil) - (= $NewPos $Contr) - (det-if-then otherwise - (= $NewPos - (Cons - (:: $NotContr) $Contr)))) - (show-lists $Rel - (:: segment part) $NewPos) - (yesno (:: 'Proceed? ')))) -; - - - - (= - (new_preds $Rel () $New $New $Names $Names) True) -; - - (= - (new-preds $Rel - (Cons $H $T) $New0 $New $Names0 $Names) - ( (new-preds1 $Rel $H $New0 $New1 $Names0 $Names1) (new-preds $Rel $T $New1 $New $Names1 $Names))) -; - - - - (= - (new_preds1 $Rel () $New $New $Names $Names) True) -; - - (= - (new-preds1 $Rel - (Cons $R $Rs) $New0 $New $Names0 $Names) - ( (show-list $Rel 'partial relation' $R) - (prompt-read 'relation name' $N) - (rel $Rel $Attrs) - (new-rel $N $Attrs) - (new-relation $Rel $R $N $NewR) - (append $New0 $NewR $New1) - (add-if $N $Names0 $Names1) - (new-preds1 $Rel $Rs $New1 $New $Names1 $Names))) -; - - - - (= - (new-relation $Rel $R $N $NewR) + (+ $T2) $N))) + (remove $T2 $Pos1 $NewPos1) + (is $K1 + (- $K0 1)) + (= $NewPos2 + (Cons $T2 $Pos2)) + (is $L1 + (+ $L0 1)) + (= $PosOut $NewPosOut) + (= $M $NewM)) + (det-if-then + (= $Answer no) + (, + (= $NewPos1 $Pos2) + (= $K1 $L0) + (= $NewPos2 Nil) + (= $L1 0) + (= $PosOut + (Cons $Pos1 $NewPosOut)) + (= $M + (Cons $K0 $NewM))))) + (set-det) + (divide1 $NewPos1 $K1 $K $NewPos2 $L1 $L $IC $NewPosOut $NewM)) + + + (= (find-division $Rel $NotContr $Contr $Numbers $NewPos) + (det-if-then-else + (= $NotContr Nil) + (= $NewPos $Contr) + (det-if-then otherwise + (= $NewPos + (Cons + (:: $NotContr) $Contr)))) + (show-lists $Rel + (:: segment part) $NewPos) + (yesno (:: 'Proceed? '))) + + + (= (new_preds $Rel () $New $New $Names $Names) True) + (= (new-preds $Rel (Cons $H $T) $New0 $New $Names0 $Names) + (new-preds1 $Rel $H $New0 $New1 $Names0 $Names1) + (new-preds $Rel $T $New1 $New $Names1 $Names)) + + + (= (new_preds1 $Rel () $New $New $Names $Names) True) + (= (new-preds1 $Rel (Cons $R $Rs) $New0 $New $Names0 $Names) + (show-list $Rel 'partial relation' $R) + (prompt-read 'relation name' $N) + (rel $Rel $Attrs) + (new-rel $N $Attrs) + (new-relation $Rel $R $N $NewR) + (append $New0 $NewR $New1) + (add-if $N $Names0 $Names1) + (new-preds1 $Rel $Rs $New1 $New $Names1 $Names)) + + + (= (new-relation $Rel $R $N $NewR) (bagof0 $NewT (^ $T (, (member $T $R) (new-tuple $Rel $T $N $NewT))) $NewR)) -; - - - - (= - (new-tuple $Rel $T $N $NewT) - ( (=.. $T - (Cons $Rel $Args)) - (set-det) - (=.. $NewT - (Cons $N $Args)))) -; - (= - (new_tuple $Rel $T $N $T) True) -; - ; -; + (= (new-tuple $Rel $T $N $NewT) + (=.. $T + (Cons $Rel $Args)) + (set-det) + (=.. $NewT + (Cons $N $Args))) + (= (new_tuple $Rel $T $N $T) True) ; +; tuple from other relation diff --git a/index/eval.metta b/index/eval.metta index cf469aa..3ee4216 100644 --- a/index/eval.metta +++ b/index/eval.metta @@ -1,93 +1,74 @@ - - (= - (evaluate1 $P $IC $Answer) - ( (switched-on eval) - (dep $IC $Type $Rel $From $To) - (filter $P $Rel $P1 $Rest) - (splitsort $P1 $IC $SplitP $NumbersC) - (calc-conf $NumbersC $Conf) - (det-if-then-else - (compare (conf $Conf)) - (, - (divides $SplitP $IC $NewP $NumbersA) - (calc-acc $NumbersA $Acc) - (det-if-then-else - (compare (acc $Acc)) - (= $Answer - (keep (acc $Acc))) - (det-if-then - (compare (split $Acc)) - (= $Answer - (keep (split $Acc)))))) - (det-if-then otherwise +; (convert_to_metta_file eval $_459408 index/eval.pl index/eval.metta) + + (= (evaluate1 $P $IC $Answer) + (switched-on eval) + (dep $IC $Type $Rel $From $To) + (filter $P $Rel $P1 $Rest) + (splitsort $P1 $IC $SplitP $NumbersC) + (calc-conf $NumbersC $Conf) + (det-if-then-else + (compare (conf $Conf)) + (, + (divides $SplitP $IC $NewP $NumbersA) + (calc-acc $NumbersA $Acc) + (det-if-then-else + (compare (acc $Acc)) (= $Answer - (ignore (conf $Conf))))))) -; - + (keep (acc $Acc))) + (det-if-then + (compare (split $Acc)) + (= $Answer + (keep (split $Acc)))))) + (det-if-then otherwise + (= $Answer + (ignore (conf $Conf)))))) +; ; write_debug(['splitsort...']), +; ; write_debug(['divides...']), - (= - (calc-conf - (, $NDivs $NTuples) $Confirmation) + (= (calc-conf (, $NDivs $NTuples) $Confirmation) (is $Confirmation (/ $NTuples $NDivs))) -; - - - - (= - (calc-acc $Numbers $Accuracy) - ( (calc-acc1 $Numbers 0 $NTuples 0 $NLarge 0 $MaxNP) (is $Accuracy (- 1 (/ (* (- $MaxNP 1) (- $NTuples $NLarge)) $NTuples))))) -; - - - - (= - (calc_acc1 () $NT $NT $NL $NL $MaxNP $MaxNP) True) -; - - (= - (calc-acc1 - (Cons $D $Ds) $NT0 $NT $NL0 $NL $MaxNP0 $MaxNP) - ( (eval2 $D 0 $Sum 0 $Largest 0 $NParts) - (is $NT1 - (+ $NT0 $Sum)) - (is $NL1 - (+ $NL0 $Largest)) - (det-if-then-else - (> $NParts $MaxNP0) - (= $MaxNP1 $NParts) - (det-if-then otherwise - (= $MaxNP1 $MaxNP0))) - (calc-acc1 $Ds $NT1 $NT $NL1 $NL $MaxNP1 $MaxNP))) -; - - - - (= - (eval2 () $S $S $L $L $M $M) True) -; - - (= - (eval2 - (Cons $N $Ns) $S0 $S $L0 $L $M0 $M) - ( (is $S1 - (+ $S0 $N)) - (det-if-then-else - (> $N $L0) - (= $L1 $N) - (det-if-then otherwise - (= $L1 $L0))) - (is $M1 - (+ $M0 1)) - (eval2 $Ns $S1 $S $L1 $L $M1 $M))) -; - - - (= - (insert_ic $L $IC $E - (Cons $IC $L)) True) -; + (= (calc-acc $Numbers $Accuracy) + (calc-acc1 $Numbers 0 $NTuples 0 $NLarge 0 $MaxNP) + (is $Accuracy + (- 1 + (/ + (* + (- $MaxNP 1) + (- $NTuples $NLarge)) $NTuples)))) + + + (= (calc_acc1 () $NT $NT $NL $NL $MaxNP $MaxNP) True) + (= (calc-acc1 (Cons $D $Ds) $NT0 $NT $NL0 $NL $MaxNP0 $MaxNP) + (eval2 $D 0 $Sum 0 $Largest 0 $NParts) + (is $NT1 + (+ $NT0 $Sum)) + (is $NL1 + (+ $NL0 $Largest)) + (det-if-then-else + (> $NParts $MaxNP0) + (= $MaxNP1 $NParts) + (det-if-then otherwise + (= $MaxNP1 $MaxNP0))) + (calc-acc1 $Ds $NT1 $NT $NL1 $NL $MaxNP1 $MaxNP)) + + + (= (eval2 () $S $S $L $L $M $M) True) + (= (eval2 (Cons $N $Ns) $S0 $S $L0 $L $M0 $M) + (is $S1 + (+ $S0 $N)) + (det-if-then-else + (> $N $L0) + (= $L1 $N) + (det-if-then otherwise + (= $L1 $L0))) + (is $M1 + (+ $M0 1)) + (eval2 $Ns $S1 $S $L1 $L $M1 $M)) + + + (= (insert_ic $L $IC $E (Cons $IC $L)) True) diff --git a/index/hooks.metta b/index/hooks.metta index bb41cad..7e15a08 100644 --- a/index/hooks.metta +++ b/index/hooks.metta @@ -1,365 +1,200 @@ +; (convert_to_metta_file hooks $_42036 index/hooks.pl index/hooks.metta) !(op 900 xfx :) -; - !(op 800 xfx -->) -; - !(op 800 xfx ->->) -; - !(op 800 xfx ><) -; - !(op 800 xfx <) -; - - - - (= - (init-ICs $Rel $ICs) - ( (rel $Rel $AList) - (choose-list 'Which dependencies' $AList $AttrList) - (bagof0 - (mvd $Rel Nil - (:: $A)) - (member $A $AttrList) $IC1) - (bagof0 - (fd $Rel Nil - (:: $A)) - (member $A $AttrList) $IC2) - (append $IC1 $IC2 $ICs))) -; - - - - (= - (horn - (fd $Rel $FromList - (:: $To)) - (= - (= $A1 $A2) - ($Tuple1 $Tuple2))) - ( (values $Rel $FromList $ValueList $Tuple1) - (values $Rel $FromList $ValueList $Tuple2) - (value $Rel $To $A1 $Tuple1) - (value $Rel $To $A2 $Tuple2))) -; - - (= - (horn - (mvd $Rel $FromList $ToList) - (= $Tuple1 - ($Tuple2 $Tuple3))) - ( (rel $Rel $AttrList) - (listdiff $AttrList $FromList $List) - (listdiff $List $ToList $RestList) - (values $Rel $FromList $FromValues $Tuple1) - (values $Rel $FromList $FromValues $Tuple2) - (values $Rel $FromList $FromValues $Tuple3) - (values $Rel $ToList $ToValues $Tuple1) - (values $Rel $ToList $ToValues $Tuple2) - (values $Rel $RestList $RestValues $Tuple1) - (values $Rel $RestList $RestValues $Tuple3))) -; - - (= - (horn - (join $Rel $R1 $R2) - (= $Tuple1 - ($Tuple2 $Tuple3))) - ( (rel $R1 $R1Attrs) - (rel $R2 $R2Attrs) - (values $Rel $R1Attrs $R1Values $Tuple1) - (values $Rel $R2Attrs $R2Values $Tuple1) - (values $R1 $R1Attrs $R1Values $Tuple2) - (values $R2 $R2Attrs $R2Values $Tuple3))) -; - - (= - (horn - (plus $Rel $List) - (= $Tuple $Body)) - ( (rel $Rel $RelAttrs) - (values $Rel $RelAttrs $Values $Tuple) - (make-body $List $Values $Body))) -; - - (= - (horn - (proc $Rel) $Proc) - (proc $Rel $Proc)) -; - ; -; - - (= - (make-body - (:: $R) $Values $L) - ( (set-det) - (rel $R $Attrs) - (values $R $Attrs $Values $L))) -; - - (= - (make-body - (Cons $R $Rs) $Values - (or $L $Ls)) - ( (rel $R $Attrs) - (values $R $Attrs $Values $L) - (make-body $Rs $Values $Ls))) -; - - - - (= - (refinements - (fd $Rel $From + (= (init-ICs $Rel $ICs) + (rel $Rel $AList) + (choose-list 'Which dependencies' $AList $AttrList) + (bagof0 + (mvd $Rel Nil + (:: $A)) + (member $A $AttrList) $IC1) + (bagof0 + (fd $Rel Nil + (:: $A)) + (member $A $AttrList) $IC2) + (append $IC1 $IC2 $ICs)) +; /* initialisation */ + + + (= (horn (fd $Rel $FromList (:: $To)) (= (= $A1 $A2) + ($Tuple1 $Tuple2))) + (values $Rel $FromList $ValueList $Tuple1) + (values $Rel $FromList $ValueList $Tuple2) + (value $Rel $To $A1 $Tuple1) + (value $Rel $To $A2 $Tuple2)) +; /* translation to Horn form */ + (= (horn (mvd $Rel $FromList $ToList) (= $Tuple1 + ($Tuple2 $Tuple3))) + (rel $Rel $AttrList) + (listdiff $AttrList $FromList $List) + (listdiff $List $ToList $RestList) + (values $Rel $FromList $FromValues $Tuple1) + (values $Rel $FromList $FromValues $Tuple2) + (values $Rel $FromList $FromValues $Tuple3) + (values $Rel $ToList $ToValues $Tuple1) + (values $Rel $ToList $ToValues $Tuple2) + (values $Rel $RestList $RestValues $Tuple1) + (values $Rel $RestList $RestValues $Tuple3)) + (= (horn (join $Rel $R1 $R2) (= $Tuple1 + ($Tuple2 $Tuple3))) + (rel $R1 $R1Attrs) + (rel $R2 $R2Attrs) + (values $Rel $R1Attrs $R1Values $Tuple1) + (values $Rel $R2Attrs $R2Values $Tuple1) + (values $R1 $R1Attrs $R1Values $Tuple2) + (values $R2 $R2Attrs $R2Values $Tuple3)) + (= (horn (plus $Rel $List) (= $Tuple $Body)) + (rel $Rel $RelAttrs) + (values $Rel $RelAttrs $Values $Tuple) + (make-body $List $Values $Body)) + (= (horn (proc $Rel) $Proc) + (proc $Rel $Proc)) ; +; works only for one-clause procs + + + (= (make-body (:: $R) $Values $L) + (set-det) + (rel $R $Attrs) + (values $R $Attrs $Values $L)) + (= (make-body (Cons $R $Rs) $Values (or $L $Ls)) + (rel $R $Attrs) + (values $R $Attrs $Values $L) + (make-body $Rs $Values $Ls)) + + + (= (refinements (fd $Rel $From (:: $To)) (:: (+ $T1) (+ $T2)) $ICs) + (set-det) + (diff $T1 $T2 $Diff) + (bagof0 + (fd $Rel + (Cons $Attr $From) (:: $To)) - (:: - (+ $T1) - (+ $T2)) $ICs) - ( (set-det) - (diff $T1 $T2 $Diff) - (bagof0 - (fd $Rel - (Cons $Attr $From) - (:: $To)) - (fd-spec $To $Diff $Attr) $ICs))) -; - - (= - (refinements - (mvd $Rel $From $To) - (:: - (+ $T1) - (+ $T2) - (- $T3)) $ICs) - ( (set-det) - (diff $T1 $T3 $D13) - (diff $T2 $T3 $D23) - (bagof0 - (mvd $Rel - (Cons $Attr $From) $ST) - (mvd-spec $Rel $From $To $D13 $D23 $Attr $ST) $ICs))) -; - - (= - (refinements $IC $Tuples $ICs) - ( (display $IC $DisplayIC) - (write $DisplayIC) - (show-list ' is contradicted by' $Tuples) - (ic-spec $IC $ICs))) -; - - - - (= - (fd-spec $To $Diff $Attr) - ( (member $Attr $Diff) (\= $Attr $To))) -; - - - - (= - (mvd-spec $Rel $From $To $Diff $_ $Attr $ST) - ( (member $Attr $Diff) - (remove $Attr $To $ST) - (\= $ST Nil) - (compl - (mvd $Rel - (Cons $Attr $From) $ST) - (mvd $Rel - (Cons $Attr $From) $SCT)) - (\= $SCT Nil))) -; - - (= - (mvd-spec $Rel $From $To $_ $Diff $Attr $ST) - ( (member $Attr $Diff) - (remove $Attr $To $ST) - (\= $ST Nil) - (compl - (mvd $Rel - (Cons $Attr $From) $ST) - (mvd $Rel - (Cons $Attr $From) $SCT)) - (\= $SCT Nil))) -; - - - - (= - (ic-spec $IC - (Cons $R $Rs)) - ( (prompt-read refinement $DR) - (set-det) - (display $R $DR) - (ic-spec $IC $Rs))) -; + (fd-spec $To $Diff $Attr) $ICs)) +; /* refinements on the meta-level */ + (= (refinements (mvd $Rel $From $To) (:: (+ $T1) (+ $T2) (- $T3)) $ICs) + (set-det) + (diff $T1 $T3 $D13) + (diff $T2 $T3 $D23) + (bagof0 + (mvd $Rel + (Cons $Attr $From) $ST) + (mvd-spec $Rel $From $To $D13 $D23 $Attr $ST) $ICs)) + (= (refinements $IC $Tuples $ICs) + (display $IC $DisplayIC) + (write $DisplayIC) + (show-list ' is contradicted by' $Tuples) + (ic-spec $IC $ICs)) + + + (= (fd-spec $To $Diff $Attr) + (member $Attr $Diff) + (\= $Attr $To)) + + + (= (mvd-spec $Rel $From $To $Diff $_ $Attr $ST) + (member $Attr $Diff) + (remove $Attr $To $ST) + (\= $ST Nil) + (compl + (mvd $Rel + (Cons $Attr $From) $ST) + (mvd $Rel + (Cons $Attr $From) $SCT)) + (\= $SCT Nil)) + (= (mvd-spec $Rel $From $To $_ $Diff $Attr $ST) + (member $Attr $Diff) + (remove $Attr $To $ST) + (\= $ST Nil) + (compl + (mvd $Rel + (Cons $Attr $From) $ST) + (mvd $Rel + (Cons $Attr $From) $SCT)) + (\= $SCT Nil)) - (= - (ic_spec $IC ()) True) -; + (= (ic-spec $IC (Cons $R $Rs)) + (prompt-read refinement $DR) + (set-det) + (display $R $DR) + (ic-spec $IC $Rs)) + (= (ic_spec $IC ()) True) - (= - (subsumed - (fd $Rel $From1 $To) - (fd $Rel $From2 $To)) + (= (subsumed (fd $Rel $From1 $To) (fd $Rel $From2 $To)) (subset $From2 $From1)) -; - - (= - (subsumed - (mvd $Rel $From1 $To) - (mvd $Rel $From2 $To)) - ( (set-det) (subset $From2 $From1))) -; - - (= - (subsumed - (mvd $Rel $From1 $To1) - (mvd $Rel $From2 $To2)) - ( (subset $From2 $From1) (compl (mvd $Rel $From1 $To1) (mvd $Rel $From1 $To2)))) -; - - - - (= +; /* subsumption test */ + (= (subsumed (mvd $Rel $From1 $To) (mvd $Rel $From2 $To)) + (set-det) + (subset $From2 $From1)) + (= (subsumed (mvd $Rel $From1 $To1) (mvd $Rel $From2 $To2)) + (subset $From2 $From1) (compl - (mvd $Rel $From $To) - (mvd $Rel $From $CTo)) - ( (rel $Rel $AttrList) - (listdiff $AttrList $From $AL1) - (listdiff $AL1 $To $CTo))) -; - - - - (= - (compress $In $Out) - ( (select - (fd $Rel $From $To1) $In $In1) - (select - (fd $Rel $From $To2) $In1 $In2) - (set-det) - (append $To1 $To2 $To) - (compress - (Cons - (fd $Rel $From $To) $In2) $Out))) -; + (mvd $Rel $From1 $To1) + (mvd $Rel $From1 $To2))) - (= - (compress $ICs $ICs) True) -; + (= (compl (mvd $Rel $From $To) (mvd $Rel $From $CTo)) + (rel $Rel $AttrList) + (listdiff $AttrList $From $AL1) + (listdiff $AL1 $To $CTo)) - (= - (dep - (fd $Rel $From $To) fd $Rel $From $To) True) -; + (= (compress $In $Out) + (select + (fd $Rel $From $To1) $In $In1) + (select + (fd $Rel $From $To2) $In1 $In2) + (set-det) + (append $To1 $To2 $To) + (compress + (Cons + (fd $Rel $From $To) $In2) $Out)) +; /* compression */ + (= (compress $ICs $ICs) True) - (= - (dep - (mvd $Rel $From $To) mvd $Rel $From $To) True) -; + (= (dep (fd $Rel $From $To) fd $Rel $From $To) True) +; /* dependencies only */ + (= (dep (mvd $Rel $From $To) mvd $Rel $From $To) True) - (= - (display - (fd $Rel $From $To) - (with_self $Rel - (--> $From $To))) + (= (display (fd $Rel $From $To) (with_self $Rel (--> $From $To))) (set-det)) -; - - (= - (display - (mvd $Rel $From $To) - (with_self $Rel - (->-> $From $To))) +; /* display form */ + (= (display (mvd $Rel $From $To) (with_self $Rel (->-> $From $To))) (set-det)) -; - - (= - (display - (join $Rel $R1 $R2) - (>< - (= $Rel $R1) $R2)) + (= (display (join $Rel $R1 $R2) (>< (= $Rel $R1) $R2)) (set-det)) -; - - (= - (display - (plus $Rel $List) - (= $Rel $List)) + (= (display (plus $Rel $List) (= $Rel $List)) (set-det)) -; - - (= - (display - (proc $Rel) - (with_self - (calculated *) $Rel)) + (= (display (proc $Rel) (with_self (calculated *) $Rel)) (set-det)) -; + (= (display $X $X) True) - (= - (display $X $X) True) -; - - - (= - (template all $X) + (= (template all $X) (set-det)) -; - - (= - (template fd - (fd $Rel $From $To)) +; /* templates */ + (= (template fd (fd $Rel $From $To)) (set-det)) -; - - (= - (template mvd - (mvd $Rel $From $To)) + (= (template mvd (mvd $Rel $From $To)) (set-det)) -; - - (= - (template join - (join $Rel $R1 $R2)) + (= (template join (join $Rel $R1 $R2)) (set-det)) -; - - (= - (template plus - (plus $Rel $List)) + (= (template plus (plus $Rel $List)) (set-det)) -; - - (= - (template proc - (proc $Rel)) + (= (template proc (proc $Rel)) (set-det)) -; - - (= - (template $R $Tuple) - ( (rel $R $A) - (set-det) - (values $R $A $V $Tuple))) -; - - (= - (template $X $X) True) -; - + (= (template $R $Tuple) + (rel $R $A) + (set-det) + (values $R $A $V $Tuple)) + (= (template $X $X) True) diff --git a/index/index.metta b/index/index.metta index db47de4..db246db 100644 --- a/index/index.metta +++ b/index/index.metta @@ -1,157 +1,78 @@ +; (convert_to_metta_file index $_209758 index/index.pl index/index.metta) !(unknown $_ fail) -; - !(no-style-check all) -; - !(compile (library basics)) -; - !(compile (library lists)) -; - !(compile (library sets)) -; - !(compile (library not)) -; - ; -; - +; :-compile(library(strings)). !(dynamic (/ switched-on 1)) -; - !(dynamic (/ level-set 2)) -; - - - - (= - (switched_on cwa) True) -; - - (= - (switched_on eval) True) -; - - (= - (switched_on debug) True) -; - - (= - (level_set acc - (+ 0.8)) True) -; + (= (switched_on cwa) True) + (= (switched_on eval) True) + (= (switched_on debug) True) - (= - (level_set conf - (+ 2)) True) -; - (= - (level_set split - (/ 0.5 0.1)) True) -; + (= (level_set acc (+ 0.8)) True) + (= (level_set conf (+ 2)) True) + (= (level_set split (/ 0.5 0.1)) True) - - (= - (run) + (= (run) (commands Nil Nil Nil)) -; - - - +; /* modules */ +; /* :-compile(utils),compile(char),compile(eval),compile(hooks), compile(object),compile(sort),compile(decomp). :-compile(inter),compile(commands). */ - (= - (listdiff $L () $L) True) -; - (= - (listdiff $L - (Cons $H $T) $V) - ( (remove $H $L $L1) (listdiff $L1 $T $V))) -; + (= (listdiff $L () $L) True) +; /* utilities */ + (= (listdiff $L (Cons $H $T) $V) + (remove $H $L $L1) + (listdiff $L1 $T $V)) - (= - (remove $_ () ()) True) -; - - (= - (remove $H - (Cons $H $T) $L) + (= (remove $_ () ()) True) + (= (remove $H (Cons $H $T) $L) (remove $H $T $L)) -; - - (= - (remove $X - (Cons $H $T) - (Cons $H $L)) - ( (remove $X $T $L) (\= $X $H))) -; - + (= (remove $X (Cons $H $T) (Cons $H $L)) + (remove $X $T $L) + (\= $X $H)) - (= - (select-two - (Cons $H $T) $H $Y) + (= (select-two (Cons $H $T) $H $Y) (member $Y $T)) -; - - (= - (select-two - (Cons $H $T) $X $Y) + (= (select-two (Cons $H $T) $X $Y) (select-two $T $X $Y)) -; - - - - (= - (forall $Goal $Condition) - ( (bagof0 $Condition $Goal $List) (forall1 $List))) -; - - - (= - (forall1 ()) True) -; - (= - (forall1 (Cons $H $T)) - ( (call $H) (forall1 $T))) -; + (= (forall $Goal $Condition) + (bagof0 $Condition $Goal $List) + (forall1 $List)) + (= (forall1 ()) True) + (= (forall1 (Cons $H $T)) + (call $H) + (forall1 $T)) - (= - (bagof0 $T $G $L) - ( (bagof $T $G $L) (set-det))) -; - (= - (bagof0 $T $G ()) True) -; - - - - (= - (setof0 $T $G $L) - ( (setof $T $G $L) (set-det))) -; + (= (bagof0 $T $G $L) + (bagof $T $G $L) + (set-det)) + (= (bagof0 $T $G ()) True) - (= - (setof0 $T $G ()) True) -; + (= (setof0 $T $G $L) + (setof $T $G $L) + (set-det)) + (= (setof0 $T $G ()) True) ; (error ; (syntax_error operator_expected) @@ -159,93 +80,64 @@ - (= - (add-if $X $Ys $Ys) - ( (member $X $Ys) (set-det))) -; - - (= - (add_if $X $Ys - (Cons $X $Ys)) True) -; - + (= (add-if $X $Ys $Ys) + (member $X $Ys) + (set-det)) + (= (add_if $X $Ys (Cons $X $Ys)) True) - (= - (flatten $Xs $Ys) + (= (flatten $Xs $Ys) (flatten-dl $Xs Nil $Ys)) -; - - (= - (flatten-dl Nil $Ys $Ys) + (= (flatten-dl Nil $Ys $Ys) (set-det)) -; - - (= - (flatten-dl - (Cons $X $Xs) $Ys0 $Ys) - ( (set-det) - (flatten-dl $Xs $Ys0 $Ys1) - (flatten-dl $X $Ys1 $Ys))) -; - - (= - (flatten_dl $X $Xs - (Cons $X $Xs)) True) -; - - - (= - (char $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) - ( (char1 $InICs $PosIn $NegIn Nil $TmpICs $PosOut $NegOut) (cleanup $TmpICs Nil $OutICs))) -; - - - - (= - (char1 () $P $N $Out $Out $P $N) True) -; - - (= - (char1 - (Cons $IC $ICs) $P0 $N0 $Acc $Out $P $N) - ( (write-debug (:: 'evaluating ' $IC)) - (evaluate $P0 $N0 $IC $Tuples $P1 $N1 $Answer) + (= (flatten-dl (Cons $X $Xs) $Ys0 $Ys) + (set-det) + (flatten-dl $Xs $Ys0 $Ys1) + (flatten-dl $X $Ys1 $Ys)) + (= (flatten_dl $X $Xs (Cons $X $Xs)) True) + + (= (char $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) + (char1 $InICs $PosIn $NegIn Nil $TmpICs $PosOut $NegOut) + (cleanup $TmpICs Nil $OutICs)) +; /* characterisation */ + + + (= (char1 () $P $N $Out $Out $P $N) True) + (= (char1 (Cons $IC $ICs) $P0 $N0 $Acc $Out $P $N) + (write-debug (:: 'evaluating ' $IC)) + (evaluate $P0 $N0 $IC $Tuples $P1 $N1 $Answer) + (det-if-then-else + (= $Answer refine) + (, + (refinements $IC $Tuples $Spec) + (append $ICs $Spec $NewICs) + (= $NewAcc $Acc)) (det-if-then-else - (= $Answer refine) + (= $Answer keep) (, - (refinements $IC $Tuples $Spec) - (append $ICs $Spec $NewICs) - (= $NewAcc $Acc)) + (= $NewICs $ICs) + (= $NewAcc + (Cons $IC $Acc))) (det-if-then-else - (= $Answer keep) + (= $Answer + (ignore $E)) (, (= $NewICs $ICs) - (= $NewAcc - (Cons $IC $Acc))) - (det-if-then-else + (= $NewAcc $Acc)) + (det-if-then (= $Answer - (ignore $E)) + (keep $E)) (, (= $NewICs $ICs) - (= $NewAcc $Acc)) - (det-if-then - (= $Answer - (keep $E)) - (, - (= $NewICs $ICs) - (insert-ic $Acc $IC $E $NewAcc)))))) - (write-debug (:: ' result: ' $Answer)) - (set-det) - (char1 $NewICs $P1 $N1 $NewAcc $Out $P $N))) -; - + (insert-ic $Acc $IC $E $NewAcc)))))) + (write-debug (:: ' result: ' $Answer)) + (set-det) + (char1 $NewICs $P1 $N1 $NewAcc $Out $P $N)) - (= - (evaluate $P0 $N0 $IC $Tuples $P $N $Answer) + (= (evaluate $P0 $N0 $IC $Tuples $P $N $Answer) (det-if-then-else (evaluate1 $P0 $IC $Answer) (, @@ -274,27 +166,18 @@ (, (queries $P0 $N0 $T $P1 $N1) (evaluate $P1 $N1 $IC $Tuples $P $N $Answer))))))))) -; +; ; write_debug(['contr...']), + (= (contr $P $N $IC $Tuples $Answer) + (horn $IC $HornIC) + (incons $HornIC $P $N $Tuples $Answer)) - (= - (contr $P $N $IC $Tuples $Answer) - ( (horn $IC $HornIC) (incons $HornIC $P $N $Tuples $Answer))) -; - - - - (= - (queries $P $N () $P $N) True) -; - - (= - (queries $P $N - (Cons $T $Ts) $P1 $N1) - ( (query $P $N $T $P2 $N2) (queries $P2 $N2 $Ts $P1 $N1))) -; + (= (queries $P $N () $P $N) True) + (= (queries $P $N (Cons $T $Ts) $P1 $N1) + (query $P $N $T $P2 $N2) + (queries $P2 $N2 $Ts $P1 $N1)) ; (error ; (syntax_error operator_expected) @@ -305,1248 +188,762 @@ ; (file index/index.pl 124 4 2590)) - (= - (query $P $N - (- $T) $P - (Cons $T $N)) - ( (switched-on cwa) - (write (- $T)) - (nl))) -; - - (= - (query $P $N - (+ $T) $P $N) True) -; - - - - (= - (cleanup - (Cons $X $In) $Acc $Out) - ( (member $IC $In) - (subsumed $X $IC) - (set-det) - (cleanup $In $Acc $Out))) -; - - (= - (cleanup - (Cons $X $In) $Acc $Out) - ( (member $IC $Acc) - (subsumed $X $IC) - (set-det) - (cleanup $In $Acc $Out))) -; - - (= - (cleanup - (Cons $X $In) $Acc $Out) + (= (query $P $N (- $T) $P (Cons $T $N)) + (switched-on cwa) + (write (- $T)) + (nl)) + (= (query $P $N (+ $T) $P $N) True) + + + (= (cleanup (Cons $X $In) $Acc $Out) + (member $IC $In) + (subsumed $X $IC) + (set-det) + (cleanup $In $Acc $Out)) + (= (cleanup (Cons $X $In) $Acc $Out) + (member $IC $Acc) + (subsumed $X $IC) + (set-det) + (cleanup $In $Acc $Out)) + (= (cleanup (Cons $X $In) $Acc $Out) (cleanup $In (Cons $X $Acc) $Out)) -; - - (= - (cleanup () $Out $Out) True) -; - - - - (= - (incons - (= $Head $Body) $P $N $Tuples $Answer) - ( (satisfied $Body $P $N $TuplesB) - (falsified $Head $P $N $TuplesH) - (set-det) - (= $Answer yes) - (append $TuplesB $TuplesH $Tuples))) -; - - (= - (incons - (= $Head $Body) $P $N $Tuples $Answer) - ( (satisfied $Body $P $N $TuplesB) - (unsatisfied $Head $P $N $TuplesH) - (set-det) - (= $Answer possibly) - (append $TuplesB $TuplesH $Tuples))) -; - - (= - (incons - (= $Head $Body) $P $N Nil $Answer) + (= (cleanup () $Out $Out) True) + + + (= (incons (= $Head $Body) $P $N $Tuples $Answer) + (satisfied $Body $P $N $TuplesB) + (falsified $Head $P $N $TuplesH) + (set-det) + (= $Answer yes) + (append $TuplesB $TuplesH $Tuples)) + (= (incons (= $Head $Body) $P $N $Tuples $Answer) + (satisfied $Body $P $N $TuplesB) + (unsatisfied $Head $P $N $TuplesH) + (set-det) + (= $Answer possibly) + (append $TuplesB $TuplesH $Tuples)) + (= (incons (= $Head $Body) $P $N Nil $Answer) (= $Answer no)) -; - - (= - (satisfied - (, $A $B) $P $N $Tuples) - ( (satisfied $A $P $N $TuplesA) - (satisfied $B $P $N $TuplesB) - (append $TuplesA $TuplesB $Tuples))) -; - - (= - (satisfied - (or $A $B) $P $N $Tuples) + (= (satisfied (, $A $B) $P $N $Tuples) + (satisfied $A $P $N $TuplesA) + (satisfied $B $P $N $TuplesB) + (append $TuplesA $TuplesB $Tuples)) + (= (satisfied (or $A $B) $P $N $Tuples) (or (satisfied $A $P $N $Tuples) (satisfied $B $P $N $Tuples))) -; - - (= - (satisfied $A $P $N - (:: (+ $A))) + (= (satisfied $A $P $N (:: (+ $A))) (member $A $P)) -; - - (= - (satisfied - (= $A $A) $P $N ()) True) -; - ; -; - - (= - (satisfied $A $P $N Nil) - ( (proc $Rel $Proc) (exec-proc $A $Proc))) -; - + (= (satisfied (= $A $A) $P $N ()) True) ; +; fds only + (= (satisfied $A $P $N Nil) + (proc $Rel $Proc) + (exec-proc $A $Proc)) - (= - (exec-proc $Goal - (, $P1 $P2)) + (= (exec-proc $Goal (, $P1 $P2)) (or (exec-proc $Goal $P1) (exec-proc $Goal $P2))) -; - - (= - (exec-proc $Goal - (= $Goal $Body)) + (= (exec-proc $Goal (= $Goal $Body)) (call $Body)) -; - - (= - (falsified - (, $A $B) $P $N $Tuples) + (= (falsified (, $A $B) $P $N $Tuples) (or (, (set-det) (falsified $A $P $N $Tuples)) (falsified $B $P $N $Tuples))) -; - - (= - (falsified $A $P $N - (:: (- $A))) + (= (falsified $A $P $N (:: (- $A))) (member $A $N)) -; - - (= - (falsified - (= $A $B) $P $N Nil) + (= (falsified (= $A $B) $P $N Nil) (\= $A $B)) -; +; ; fds only - - (= - (unsatisfied - (, $A $B) $P $N $Tuples) + (= (unsatisfied (, $A $B) $P $N $Tuples) (or (, (set-det) (unsatisfied $A $P $N $Tuples)) (unsatisfied $B $P $N $Tuples))) -; - - (= - (unsatisfied $A $P $N - (:: (- $A))) - ( (not (satisfied $A $P $N $_)) (not (falsified $A $P $N $_)))) -; - - - (= - (evaluate1 $P $IC $Answer) - ( (switched-on eval) - (dep $IC $Type $Rel $From $To) - (filter $P $Rel $P1 $Rest) - (splitsort $P1 $IC $SplitP $NumbersC) - (calc-conf $NumbersC $Conf) - (det-if-then-else - (compare (conf $Conf)) - (, - (divides $SplitP $IC $NewP $NumbersA) - (calc-acc $NumbersA $Acc) - (det-if-then-else - (compare (acc $Acc)) - (= $Answer - (keep (acc $Acc))) - (det-if-then - (compare (split $Acc)) - (= $Answer - (keep (split $Acc)))))) - (det-if-then otherwise + (= (unsatisfied $A $P $N (:: (- $A))) + (not (satisfied $A $P $N $_)) + (not (falsified $A $P $N $_))) + + (= (evaluate1 $P $IC $Answer) + (switched-on eval) + (dep $IC $Type $Rel $From $To) + (filter $P $Rel $P1 $Rest) + (splitsort $P1 $IC $SplitP $NumbersC) + (calc-conf $NumbersC $Conf) + (det-if-then-else + (compare (conf $Conf)) + (, + (divides $SplitP $IC $NewP $NumbersA) + (calc-acc $NumbersA $Acc) + (det-if-then-else + (compare (acc $Acc)) (= $Answer - (ignore (conf $Conf))))))) -; - + (keep (acc $Acc))) + (det-if-then + (compare (split $Acc)) + (= $Answer + (keep (split $Acc)))))) + (det-if-then otherwise + (= $Answer + (ignore (conf $Conf)))))) +; ; write_debug(['splitsort...']), +; ; write_debug(['divides...']), - (= - (calc-conf - (, $NDivs $NTuples) $Confirmation) + (= (calc-conf (, $NDivs $NTuples) $Confirmation) (is $Confirmation (/ $NTuples $NDivs))) -; - - (= - (calc-acc $Numbers $Accuracy) - ( (calc-acc1 $Numbers 0 $NTuples 0 $NLarge 0 $MaxNP) (is $Accuracy (- 1 (/ (* (- $MaxNP 1) (- $NTuples $NLarge)) $NTuples))))) -; + (= (calc-acc $Numbers $Accuracy) + (calc-acc1 $Numbers 0 $NTuples 0 $NLarge 0 $MaxNP) + (is $Accuracy + (- 1 + (/ + (* + (- $MaxNP 1) + (- $NTuples $NLarge)) $NTuples)))) - - (= - (calc_acc1 () $NT $NT $NL $NL $MaxNP $MaxNP) True) -; - - (= - (calc-acc1 - (Cons $D $Ds) $NT0 $NT $NL0 $NL $MaxNP0 $MaxNP) - ( (eval2 $D 0 $Sum 0 $Largest 0 $NParts) - (is $NT1 - (+ $NT0 $Sum)) - (is $NL1 - (+ $NL0 $Largest)) - (det-if-then-else - (> $NParts $MaxNP0) - (= $MaxNP1 $NParts) - (det-if-then otherwise - (= $MaxNP1 $MaxNP0))) - (calc-acc1 $Ds $NT1 $NT $NL1 $NL $MaxNP1 $MaxNP))) -; - - - - (= - (eval2 () $S $S $L $L $M $M) True) -; - - (= - (eval2 - (Cons $N $Ns) $S0 $S $L0 $L $M0 $M) - ( (is $S1 - (+ $S0 $N)) - (det-if-then-else - (> $N $L0) - (= $L1 $N) - (det-if-then otherwise - (= $L1 $L0))) - (is $M1 - (+ $M0 1)) - (eval2 $Ns $S1 $S $L1 $L $M1 $M))) -; + (= (calc_acc1 () $NT $NT $NL $NL $MaxNP $MaxNP) True) + (= (calc-acc1 (Cons $D $Ds) $NT0 $NT $NL0 $NL $MaxNP0 $MaxNP) + (eval2 $D 0 $Sum 0 $Largest 0 $NParts) + (is $NT1 + (+ $NT0 $Sum)) + (is $NL1 + (+ $NL0 $Largest)) + (det-if-then-else + (> $NParts $MaxNP0) + (= $MaxNP1 $NParts) + (det-if-then otherwise + (= $MaxNP1 $MaxNP0))) + (calc-acc1 $Ds $NT1 $NT $NL1 $NL $MaxNP1 $MaxNP)) + (= (eval2 () $S $S $L $L $M $M) True) + (= (eval2 (Cons $N $Ns) $S0 $S $L0 $L $M0 $M) + (is $S1 + (+ $S0 $N)) + (det-if-then-else + (> $N $L0) + (= $L1 $N) + (det-if-then otherwise + (= $L1 $L0))) + (is $M1 + (+ $M0 1)) + (eval2 $Ns $S1 $S $L1 $L $M1 $M)) - (= - (insert_ic $L $IC $E - (Cons $IC $L)) True) -; + (= (insert_ic $L $IC $E (Cons $IC $L)) True) !(op 900 xfx :) -; - !(op 800 xfx -->) -; - !(op 800 xfx ->->) -; - !(op 800 xfx ><) -; - !(op 800 xfx <) -; - - - - (= - (init-ICs $Rel $ICs) - ( (rel $Rel $AList) - (choose-list 'Which dependencies' $AList $AttrList) - (bagof0 - (mvd $Rel Nil - (:: $A)) - (member $A $AttrList) $IC1) - (bagof0 - (fd $Rel Nil - (:: $A)) - (member $A $AttrList) $IC2) - (append $IC1 $IC2 $ICs))) -; - - (= - (horn - (fd $Rel $FromList + (= (init-ICs $Rel $ICs) + (rel $Rel $AList) + (choose-list 'Which dependencies' $AList $AttrList) + (bagof0 + (mvd $Rel Nil + (:: $A)) + (member $A $AttrList) $IC1) + (bagof0 + (fd $Rel Nil + (:: $A)) + (member $A $AttrList) $IC2) + (append $IC1 $IC2 $ICs)) +; /* initialisation */ + + + (= (horn (fd $Rel $FromList (:: $To)) (= (= $A1 $A2) + ($Tuple1 $Tuple2))) + (values $Rel $FromList $ValueList $Tuple1) + (values $Rel $FromList $ValueList $Tuple2) + (value $Rel $To $A1 $Tuple1) + (value $Rel $To $A2 $Tuple2)) +; /* translation to Horn form */ + (= (horn (mvd $Rel $FromList $ToList) (= $Tuple1 + ($Tuple2 $Tuple3))) + (rel $Rel $AttrList) + (listdiff $AttrList $FromList $List) + (listdiff $List $ToList $RestList) + (values $Rel $FromList $FromValues $Tuple1) + (values $Rel $FromList $FromValues $Tuple2) + (values $Rel $FromList $FromValues $Tuple3) + (values $Rel $ToList $ToValues $Tuple1) + (values $Rel $ToList $ToValues $Tuple2) + (values $Rel $RestList $RestValues $Tuple1) + (values $Rel $RestList $RestValues $Tuple3)) + (= (horn (join $Rel $R1 $R2) (= $Tuple1 + ($Tuple2 $Tuple3))) + (rel $R1 $R1Attrs) + (rel $R2 $R2Attrs) + (values $Rel $R1Attrs $R1Values $Tuple1) + (values $Rel $R2Attrs $R2Values $Tuple1) + (values $R1 $R1Attrs $R1Values $Tuple2) + (values $R2 $R2Attrs $R2Values $Tuple3)) + (= (horn (plus $Rel $List) (= $Tuple $Body)) + (rel $Rel $RelAttrs) + (values $Rel $RelAttrs $Values $Tuple) + (make-body $List $Values $Body)) + (= (horn (proc $Rel) $Proc) + (proc $Rel $Proc)) ; +; works only for one-clause procs + + + (= (make-body (:: $R) $Values $L) + (set-det) + (rel $R $Attrs) + (values $R $Attrs $Values $L)) + (= (make-body (Cons $R $Rs) $Values (or $L $Ls)) + (rel $R $Attrs) + (values $R $Attrs $Values $L) + (make-body $Rs $Values $Ls)) + + + (= (refinements (fd $Rel $From (:: $To)) (:: (+ $T1) (+ $T2)) $ICs) + (set-det) + (diff $T1 $T2 $Diff) + (bagof0 + (fd $Rel + (Cons $Attr $From) (:: $To)) - (= - (= $A1 $A2) - ($Tuple1 $Tuple2))) - ( (values $Rel $FromList $ValueList $Tuple1) - (values $Rel $FromList $ValueList $Tuple2) - (value $Rel $To $A1 $Tuple1) - (value $Rel $To $A2 $Tuple2))) -; - - (= - (horn - (mvd $Rel $FromList $ToList) - (= $Tuple1 - ($Tuple2 $Tuple3))) - ( (rel $Rel $AttrList) - (listdiff $AttrList $FromList $List) - (listdiff $List $ToList $RestList) - (values $Rel $FromList $FromValues $Tuple1) - (values $Rel $FromList $FromValues $Tuple2) - (values $Rel $FromList $FromValues $Tuple3) - (values $Rel $ToList $ToValues $Tuple1) - (values $Rel $ToList $ToValues $Tuple2) - (values $Rel $RestList $RestValues $Tuple1) - (values $Rel $RestList $RestValues $Tuple3))) -; - - (= - (horn - (join $Rel $R1 $R2) - (= $Tuple1 - ($Tuple2 $Tuple3))) - ( (rel $R1 $R1Attrs) - (rel $R2 $R2Attrs) - (values $Rel $R1Attrs $R1Values $Tuple1) - (values $Rel $R2Attrs $R2Values $Tuple1) - (values $R1 $R1Attrs $R1Values $Tuple2) - (values $R2 $R2Attrs $R2Values $Tuple3))) -; - - (= - (horn - (plus $Rel $List) - (= $Tuple $Body)) - ( (rel $Rel $RelAttrs) - (values $Rel $RelAttrs $Values $Tuple) - (make-body $List $Values $Body))) -; - - (= - (horn - (proc $Rel) $Proc) - (proc $Rel $Proc)) -; - ; -; - - - - (= - (make-body - (:: $R) $Values $L) - ( (set-det) - (rel $R $Attrs) - (values $R $Attrs $Values $L))) -; - - (= - (make-body - (Cons $R $Rs) $Values - (or $L $Ls)) - ( (rel $R $Attrs) - (values $R $Attrs $Values $L) - (make-body $Rs $Values $Ls))) -; - - - - (= - (refinements - (fd $Rel $From - (:: $To)) - (:: - (+ $T1) - (+ $T2)) $ICs) - ( (set-det) - (diff $T1 $T2 $Diff) - (bagof0 - (fd $Rel - (Cons $Attr $From) - (:: $To)) - (fd-spec $To $Diff $Attr) $ICs))) -; - - (= - (refinements - (mvd $Rel $From $To) - (:: - (+ $T1) - (+ $T2) - (- $T3)) $ICs) - ( (set-det) - (diff $T1 $T3 $D13) - (diff $T2 $T3 $D23) - (bagof0 - (mvd $Rel - (Cons $Attr $From) $ST) - (mvd-spec $Rel $From $To $D13 $D23 $Attr $ST) $ICs))) -; - - (= - (refinements $IC $Tuples $ICs) - ( (display $IC $DisplayIC) - (write $DisplayIC) - (show-list ' is contradicted by' $Tuples) - (ic-spec $IC $ICs))) -; - - - - (= - (fd-spec $To $Diff $Attr) - ( (member $Attr $Diff) (\= $Attr $To))) -; - - - - (= - (mvd-spec $Rel $From $To $Diff $_ $Attr $ST) - ( (member $Attr $Diff) - (remove $Attr $To $ST) - (\= $ST Nil) - (compl - (mvd $Rel - (Cons $Attr $From) $ST) - (mvd $Rel - (Cons $Attr $From) $SCT)) - (\= $SCT Nil))) -; - - (= - (mvd-spec $Rel $From $To $_ $Diff $Attr $ST) - ( (member $Attr $Diff) - (remove $Attr $To $ST) - (\= $ST Nil) - (compl - (mvd $Rel - (Cons $Attr $From) $ST) - (mvd $Rel - (Cons $Attr $From) $SCT)) - (\= $SCT Nil))) -; - - - - (= - (ic-spec $IC - (Cons $R $Rs)) - ( (prompt-read refinement $DR) - (set-det) - (display $R $DR) - (ic-spec $IC $Rs))) -; + (fd-spec $To $Diff $Attr) $ICs)) +; /* refinements on the meta-level */ + (= (refinements (mvd $Rel $From $To) (:: (+ $T1) (+ $T2) (- $T3)) $ICs) + (set-det) + (diff $T1 $T3 $D13) + (diff $T2 $T3 $D23) + (bagof0 + (mvd $Rel + (Cons $Attr $From) $ST) + (mvd-spec $Rel $From $To $D13 $D23 $Attr $ST) $ICs)) + (= (refinements $IC $Tuples $ICs) + (display $IC $DisplayIC) + (write $DisplayIC) + (show-list ' is contradicted by' $Tuples) + (ic-spec $IC $ICs)) + + + (= (fd-spec $To $Diff $Attr) + (member $Attr $Diff) + (\= $Attr $To)) + + + (= (mvd-spec $Rel $From $To $Diff $_ $Attr $ST) + (member $Attr $Diff) + (remove $Attr $To $ST) + (\= $ST Nil) + (compl + (mvd $Rel + (Cons $Attr $From) $ST) + (mvd $Rel + (Cons $Attr $From) $SCT)) + (\= $SCT Nil)) + (= (mvd-spec $Rel $From $To $_ $Diff $Attr $ST) + (member $Attr $Diff) + (remove $Attr $To $ST) + (\= $ST Nil) + (compl + (mvd $Rel + (Cons $Attr $From) $ST) + (mvd $Rel + (Cons $Attr $From) $SCT)) + (\= $SCT Nil)) - (= - (ic_spec $IC ()) True) -; + (= (ic-spec $IC (Cons $R $Rs)) + (prompt-read refinement $DR) + (set-det) + (display $R $DR) + (ic-spec $IC $Rs)) + (= (ic_spec $IC ()) True) - (= - (subsumed - (fd $Rel $From1 $To) - (fd $Rel $From2 $To)) + (= (subsumed (fd $Rel $From1 $To) (fd $Rel $From2 $To)) (subset $From2 $From1)) -; - - (= - (subsumed - (mvd $Rel $From1 $To) - (mvd $Rel $From2 $To)) - ( (set-det) (subset $From2 $From1))) -; - - (= - (subsumed - (mvd $Rel $From1 $To1) - (mvd $Rel $From2 $To2)) - ( (subset $From2 $From1) (compl (mvd $Rel $From1 $To1) (mvd $Rel $From1 $To2)))) -; - - - - (= +; /* subsumption test */ + (= (subsumed (mvd $Rel $From1 $To) (mvd $Rel $From2 $To)) + (set-det) + (subset $From2 $From1)) + (= (subsumed (mvd $Rel $From1 $To1) (mvd $Rel $From2 $To2)) + (subset $From2 $From1) (compl - (mvd $Rel $From $To) - (mvd $Rel $From $CTo)) - ( (rel $Rel $AttrList) - (listdiff $AttrList $From $AL1) - (listdiff $AL1 $To $CTo))) -; - - - - (= - (compress $In $Out) - ( (select - (fd $Rel $From $To1) $In $In1) - (select - (fd $Rel $From $To2) $In1 $In2) - (set-det) - (append $To1 $To2 $To) - (compress - (Cons - (fd $Rel $From $To) $In2) $Out))) -; + (mvd $Rel $From1 $To1) + (mvd $Rel $From1 $To2))) - (= - (compress $ICs $ICs) True) -; + (= (compl (mvd $Rel $From $To) (mvd $Rel $From $CTo)) + (rel $Rel $AttrList) + (listdiff $AttrList $From $AL1) + (listdiff $AL1 $To $CTo)) - (= - (dep - (fd $Rel $From $To) fd $Rel $From $To) True) -; + (= (compress $In $Out) + (select + (fd $Rel $From $To1) $In $In1) + (select + (fd $Rel $From $To2) $In1 $In2) + (set-det) + (append $To1 $To2 $To) + (compress + (Cons + (fd $Rel $From $To) $In2) $Out)) +; /* compression */ + (= (compress $ICs $ICs) True) - (= - (dep - (mvd $Rel $From $To) mvd $Rel $From $To) True) -; + (= (dep (fd $Rel $From $To) fd $Rel $From $To) True) +; /* dependencies only */ + (= (dep (mvd $Rel $From $To) mvd $Rel $From $To) True) - (= - (display - (fd $Rel $From $To) - (with_self $Rel - (--> $From $To))) + (= (display (fd $Rel $From $To) (with_self $Rel (--> $From $To))) (set-det)) -; - - (= - (display - (mvd $Rel $From $To) - (with_self $Rel - (->-> $From $To))) +; /* display form */ + (= (display (mvd $Rel $From $To) (with_self $Rel (->-> $From $To))) (set-det)) -; - - (= - (display - (join $Rel $R1 $R2) - (>< - (= $Rel $R1) $R2)) + (= (display (join $Rel $R1 $R2) (>< (= $Rel $R1) $R2)) (set-det)) -; - - (= - (display - (plus $Rel $List) - (= $Rel $List)) + (= (display (plus $Rel $List) (= $Rel $List)) (set-det)) -; - - (= - (display - (proc $Rel) - (with_self - (calculated *) $Rel)) + (= (display (proc $Rel) (with_self (calculated *) $Rel)) (set-det)) -; - - (= - (display $X $X) True) -; + (= (display $X $X) True) - - (= - (template all $X) + (= (template all $X) (set-det)) -; - - (= - (template fd - (fd $Rel $From $To)) +; /* templates */ + (= (template fd (fd $Rel $From $To)) (set-det)) -; - - (= - (template mvd - (mvd $Rel $From $To)) + (= (template mvd (mvd $Rel $From $To)) (set-det)) -; - - (= - (template join - (join $Rel $R1 $R2)) + (= (template join (join $Rel $R1 $R2)) (set-det)) -; - - (= - (template plus - (plus $Rel $List)) + (= (template plus (plus $Rel $List)) (set-det)) -; - - (= - (template proc - (proc $Rel)) + (= (template proc (proc $Rel)) (set-det)) -; - - (= - (template $R $Tuple) - ( (rel $R $A) - (set-det) - (values $R $A $V $Tuple))) -; - - (= - (template $X $X) True) -; - + (= (template $R $Tuple) + (rel $R $A) + (set-det) + (values $R $A $V $Tuple)) + (= (template $X $X) True) - (= - (diff $Tuple1 $Tuple2 $Diff) + (= (diff $Tuple1 $Tuple2 $Diff) (diff $Tuple1 $Tuple2 $Rel $Equal $Diff)) -; - - - (= - (diff $Tuple1 $Tuple2 $Rel $Equal $Diff) - ( (=.. $Tuple1 - (Cons $Rel $Values1)) - (=.. $Tuple2 - (Cons $Rel $Values2)) - (rel $Rel $AttrList) - (diff1 $Values1 $Values2 $AttrList $Equal $Diff))) -; - - - - (= - (diff1 () () () () ()) True) -; - ; -; - - (= - (diff1 - (Cons $V $Values1) - (Cons $V $Values2) - (Cons $A $AttrList) - (Cons $A $Equal) $Diff) +; /* object level <--> meta level */ +; ; old diff + + (= (diff $Tuple1 $Tuple2 $Rel $Equal $Diff) + (=.. $Tuple1 + (Cons $Rel $Values1)) + (=.. $Tuple2 + (Cons $Rel $Values2)) + (rel $Rel $AttrList) (diff1 $Values1 $Values2 $AttrList $Equal $Diff)) -; +; ; new diff (24-2-93) - (= - (diff1 - (Cons $V1 $Values1) - (Cons $V2 $Values2) - (Cons $A $AttrList) $Equal - (Cons $A $Diff)) - ( (\= $V1 $V2) (diff1 $Values1 $Values2 $AttrList $Equal $Diff))) -; - - - - (= - (values $_ () () $_) True) -; - - (= - (values $Rel - (Cons $Attr $AttrList) - (Cons $Value $ValueList) $Tuple) - ( (value $Rel $Attr $Value $Tuple) (values $Rel $AttrList $ValueList $Tuple))) -; + (= (diff1 () () () () ()) True) ; +; new diff1 (24-2-93) + (= (diff1 (Cons $V $Values1) (Cons $V $Values2) (Cons $A $AttrList) (Cons $A $Equal) $Diff) + (diff1 $Values1 $Values2 $AttrList $Equal $Diff)) + (= (diff1 (Cons $V1 $Values1) (Cons $V2 $Values2) (Cons $A $AttrList) $Equal (Cons $A $Diff)) + (\= $V1 $V2) + (diff1 $Values1 $Values2 $AttrList $Equal $Diff)) - (= - (value $Rel $Attr $Value $Tuple) - ( (rel $Rel $AttrList) - (al2vl $Attr $AttrList $Value $ValueList) - (=.. $Tuple - (Cons $Rel $ValueList)))) -; + (= (values $_ () () $_) True) + (= (values $Rel (Cons $Attr $AttrList) (Cons $Value $ValueList) $Tuple) + (value $Rel $Attr $Value $Tuple) + (values $Rel $AttrList $ValueList $Tuple)) + (= (value $Rel $Attr $Value $Tuple) + (rel $Rel $AttrList) + (al2vl $Attr $AttrList $Value $ValueList) + (=.. $Tuple + (Cons $Rel $ValueList))) - (= - (al2vl $_ () $_ ()) True) -; - (= - (al2vl $Attr - (Cons $Attr $AttrList) $Value - (Cons $Value $ValueList)) + (= (al2vl $_ () $_ ()) True) + (= (al2vl $Attr (Cons $Attr $AttrList) $Value (Cons $Value $ValueList)) + (al2vl $Attr $AttrList $Value $ValueList)) + (= (al2vl $Attr (Cons $A $AttrList) $Value (Cons $V $ValueList)) + (or + (\= $Attr $A) + (\= $Value $V)) (al2vl $Attr $AttrList $Value $ValueList)) -; - - (= - (al2vl $Attr - (Cons $A $AttrList) $Value - (Cons $V $ValueList)) - ( (or - (\= $Attr $A) - (\= $Value $V)) (al2vl $Attr $AttrList $Value $ValueList))) -; - - - (= - (my-sort $Rel $SortAttrs $Tuples $Sorted) - ( (rel $Rel $Attrs) - (listdiff $Attrs $SortAttrs $RestAttrs) - (append $SortAttrs $RestAttrs $NewAttrs) - (reorder $Tuples $NewAttrs $NewTuples) - (setof0 $T - (member $T $NewTuples) $TmpSorted) - (reorder $TmpSorted $Attrs $Sorted))) -; - - - (= - (reorder () $Attrs ()) True) -; + (= (my-sort $Rel $SortAttrs $Tuples $Sorted) + (rel $Rel $Attrs) + (listdiff $Attrs $SortAttrs $RestAttrs) + (append $SortAttrs $RestAttrs $NewAttrs) + (reorder $Tuples $NewAttrs $NewTuples) + (setof0 $T + (member $T $NewTuples) $TmpSorted) + (reorder $TmpSorted $Attrs $Sorted)) +; /* text of window: sort */ +; ; quick & dirty - (= - (reorder - (Cons $T $Ts) $Attrs - (Cons $NewT $NewTs)) - ( (values $Rel $Attrs $Values $T) - (=.. $NewT - (Cons $Rel $Values)) - (reorder $Ts $Attrs $NewTs))) -; + (= (reorder () $Attrs ()) True) + (= (reorder (Cons $T $Ts) $Attrs (Cons $NewT $NewTs)) + (values $Rel $Attrs $Values $T) + (=.. $NewT + (Cons $Rel $Values)) + (reorder $Ts $Attrs $NewTs)) - (= - (splitsort $Ts $Dep $SortedTs) + (= (splitsort $Ts $Dep $SortedTs) (splitsort $Ts $Dep $SortedTs 0 $N 0 $M)) -; - - (= - (splitsort $Ts $Dep $SortedTs - (, $N $M)) + (= (splitsort $Ts $Dep $SortedTs (, $N $M)) (splitsort $Ts $Dep $SortedTs 0 $N 0 $M)) -; - - (= - (splitsort () $Dep () $N $N $M $M) True) -; - - (= - (splitsort - (Cons $Tuple $Tuples) $Dep - (Cons $Equals $SortedUnEquals) $N0 $N $M0 $M) - ( (partition $Tuples $Tuple $Dep $Equals $UnEquals $M0 $M1) - (is $N1 - (+ $N0 1)) - (set-det) - (splitsort $UnEquals $Dep $SortedUnEquals $N1 $N $M1 $M))) -; + (= (splitsort () $Dep () $N $N $M $M) True) + (= (splitsort (Cons $Tuple $Tuples) $Dep (Cons $Equals $SortedUnEquals) $N0 $N $M0 $M) + (partition $Tuples $Tuple $Dep $Equals $UnEquals $M0 $M1) + (is $N1 + (+ $N0 1)) + (set-det) + (splitsort $UnEquals $Dep $SortedUnEquals $N1 $N $M1 $M)) - - (= - (partition Nil $Tuple $Dep - (:: $Tuple) Nil $M0 $M) + (= (partition Nil $Tuple $Dep (:: $Tuple) Nil $M0 $M) (is $M (+ $M0 1))) -; - - (= - (partition - (Cons $T $Ts) $Tuple $Dep $Es $UnEs $M0 $M) - ( (horn $Dep - (= $Head - ($Tuple $Tuple2))) - (det-if-then-else - (= $Tuple2 $T) + (= (partition (Cons $T $Ts) $Tuple $Dep $Es $UnEs $M0 $M) + (horn $Dep + (= $Head + ($Tuple $Tuple2))) + (det-if-then-else + (= $Tuple2 $T) + (, + (= $Es + (Cons $T $Es1)) + (= $UnEs $UnEs1) + (is $M1 + (+ $M0 1))) + (det-if-then otherwise (, - (= $Es - (Cons $T $Es1)) - (= $UnEs $UnEs1) - (is $M1 - (+ $M0 1))) - (det-if-then otherwise - (, - (= $Es $Es1) - (= $UnEs - (Cons $T $UnEs1)) - (= $M1 $M0)))) - (set-det) - (partition $Ts $Tuple $Dep $Es1 $UnEs1 $M1 $M))) -; - + (= $Es $Es1) + (= $UnEs + (Cons $T $UnEs1)) + (= $M1 $M0)))) + (set-det) + (partition $Ts $Tuple $Dep $Es1 $UnEs1 $M1 $M)) - (= - (joinsort $Parts $Dep $NotContr $Contr) + (= (joinsort $Parts $Dep $NotContr $Contr) (joinsort $Parts $Dep Nil $NotContr Nil $Contr)) -; - - (= - (joinsort () $Dep $NotContr $NotContr $Contr $Contr) True) -; - - (= - (joinsort - (Cons $Part $Parts) $Dep $NC0 $NC $C0 $C) - ( (contr $Part Nil $Dep $Tuples $Answer) - (det-if-then-else - (= $Answer no) + (= (joinsort () $Dep $NotContr $NotContr $Contr $Contr) True) + (= (joinsort (Cons $Part $Parts) $Dep $NC0 $NC $C0 $C) + (contr $Part Nil $Dep $Tuples $Answer) + (det-if-then-else + (= $Answer no) + (, + (append $NC0 $Part $NC1) + (= $C1 $C0)) + (det-if-then otherwise (, - (append $NC0 $Part $NC1) - (= $C1 $C0)) - (det-if-then otherwise - (, - (= $NC1 $NC0) - (divide1 $Part Nil $Dep $DPart) - (= $C1 - (Cons $DPart $C0))))) - (set-det) - (joinsort $Parts $Dep $NC1 $NC $C1 $C))) -; - - - (= - (decompose $DisplayIC $PosIn $PosOut $InICs $OutICs) - ( (display $IC $DisplayIC) - (contr $PosIn Nil $IC $Tuples $Answer) - (det-if-then-else - (= $Answer no) - (split $IC $PosIn $PosOut $InICs $OutICs) - (det-if-then otherwise - (divide $PosIn $IC $PosOut $InICs $OutICs))))) -; - - - - (= - (split $Dep $PosIn $PosOut $ICs - (Cons $Join $ICs)) - ( (dep $Dep $Type $Rel $From $To) (split1 $Rel $From $To $PosIn $PosOut $Join))) -; - - - - (= - (split1 $Rel $From $To $PosIn $PosOut - (join $Rel $R1 $R2)) - ( (append $From $To $In1) - (new-name $In1 $Out1 $R1) - (rel $Rel $AttrList) - (listdiff $AttrList $To $In2) - (new-name $In2 $Out2 $R2) - (splits $Rel $R1 $R2 $Out1 $Out2 $PosIn $PosTmp) - (remove-dups $PosTmp $PosOut))) -; - - - - (= - (splits $Rel $R1 $R2 $AList1 $AList2 () ()) True) -; - - (= - (splits $Rel $R1 $R2 $AList1 $AList2 - (Cons $T $Ts) - (Cons $T1 - (Cons $T2 $Rest))) - ( (values $Rel $AList1 $ValueList1 $T) - (set-det) - (=.. $T1 - (Cons $R1 $ValueList1)) - (values $Rel $AList2 $ValueList2 $T) - (=.. $T2 - (Cons $R2 $ValueList2)) - (splits $Rel $R1 $R2 $AList1 $AList2 $Ts $Rest))) -; - - (= - (splits $Rel $R1 $R2 $AList1 $AList2 - (Cons $T $Ts) - (Cons $T $Rest)) + (= $NC1 $NC0) + (divide1 $Part Nil $Dep $DPart) + (= $C1 + (Cons $DPart $C0))))) + (set-det) + (joinsort $Parts $Dep $NC1 $NC $C1 $C)) + + (= (decompose $DisplayIC $PosIn $PosOut $InICs $OutICs) + (display $IC $DisplayIC) + (contr $PosIn Nil $IC $Tuples $Answer) + (det-if-then-else + (= $Answer no) + (split $IC $PosIn $PosOut $InICs $OutICs) + (det-if-then otherwise + (divide $PosIn $IC $PosOut $InICs $OutICs)))) +; /* text of window: decomp */ + + + (= (split $Dep $PosIn $PosOut $ICs (Cons $Join $ICs)) + (dep $Dep $Type $Rel $From $To) + (split1 $Rel $From $To $PosIn $PosOut $Join)) + + + (= (split1 $Rel $From $To $PosIn $PosOut (join $Rel $R1 $R2)) + (append $From $To $In1) + (new-name $In1 $Out1 $R1) + (rel $Rel $AttrList) + (listdiff $AttrList $To $In2) + (new-name $In2 $Out2 $R2) + (splits $Rel $R1 $R2 $Out1 $Out2 $PosIn $PosTmp) + (remove-dups $PosTmp $PosOut)) + + + (= (splits $Rel $R1 $R2 $AList1 $AList2 () ()) True) + (= (splits $Rel $R1 $R2 $AList1 $AList2 (Cons $T $Ts) (Cons $T1 (Cons $T2 $Rest))) + (values $Rel $AList1 $ValueList1 $T) + (set-det) + (=.. $T1 + (Cons $R1 $ValueList1)) + (values $Rel $AList2 $ValueList2 $T) + (=.. $T2 + (Cons $R2 $ValueList2)) (splits $Rel $R1 $R2 $AList1 $AList2 $Ts $Rest)) -; - + (= (splits $Rel $R1 $R2 $AList1 $AList2 (Cons $T $Ts) (Cons $T $Rest)) + (splits $Rel $R1 $R2 $AList1 $AList2 $Ts $Rest)) +; ; T not in Rel - (= - (new-name $AListIn $AListOut $R) - ( (show-list attributes $AListIn) - (prompt-read 'relation name' $Answer) + (= (new-name $AListIn $AListOut $R) + (show-list attributes $AListIn) + (prompt-read 'relation name' $Answer) + (det-if-then-else + (= $Answer -) + (, + (concat-atom $AListIn $R) + (= $AListOut $AListIn)) (det-if-then-else - (= $Answer -) + (= $Answer +) (, - (concat-atom $AListIn $R) - (= $AListOut $AListIn)) - (det-if-then-else - (= $Answer +) - (, - (prompt-read 'rel(Name,AttrList)' - (rel $R $AListOut)) - (permutation $AListOut $AListIn)) - (det-if-then otherwise - (, - (= $R $Answer) - (= $AListOut $AListIn))))) - (new-rel $R $AListOut))) -; - - - - (= - (exec-rule $DisplayRule $PosIn $PosOut) - ( (display $Rule $DisplayRule) - (horn $Rule - (= $Tuple $Body)) - (setof0 $Tuple - (^ $Ts - (satisfied $Body $PosIn Nil $Ts)) $PosOut))) -; - - - - (= - (divide $PosIn $Dep $PosOut $InICs - (Cons - (plus $Rel $Names) $OutICs)) - ( (dep $Dep $Type $Rel $From $To) - (filter $PosIn $Rel $PosFiltered $Rest) - (splitsort $PosFiltered $Dep $SplitPos) - (joinsort $SplitPos $Dep $NotContr $Contr) - (find-division $Rel $NotContr $Contr $Numbers $NewPos1) - (new-preds $Rel $NewPos1 Nil $PosTmp1 Nil $Names) - (append $PosTmp1 $Rest $PosTmp2) - (decomp-again $Names $Dep $PosTmp2 $PosOut $InICs $OutICs))) -; - - - - (= - (decomp_again () $Dep $Pos $Pos $ICs $ICs) True) -; - - (= - (decomp-again - (Cons $Name $Names) $Dep $PosIn $PosOut $InICs $OutICs) - ( (det-if-then-else - (yesno (:: 'Decompose ' $Name ? )) - (, - (dep $Dep $Type $R $From $To) - (dep $NewDep $Type $Name $From $To) - (display $NewDep $DDep) - (decompose $DDep $PosIn $PosTmp $InICs $TmpICs)) + (prompt-read 'rel(Name,AttrList)' + (rel $R $AListOut)) + (permutation $AListOut $AListIn)) (det-if-then otherwise (, - (= $PosTmp $PosIn) - (= $TmpICs $InICs)))) (decomp-again $Names $Dep $PosTmp $PosOut $TmpICs $OutICs))) -; - - - - (= - (divides () $Dep () ()) True) -; + (= $R $Answer) + (= $AListOut $AListIn))))) + (new-rel $R $AListOut)) + + + (= (exec-rule $DisplayRule $PosIn $PosOut) + (display $Rule $DisplayRule) + (horn $Rule + (= $Tuple $Body)) + (setof0 $Tuple + (^ $Ts + (satisfied $Body $PosIn Nil $Ts)) $PosOut)) + + + (= (divide $PosIn $Dep $PosOut $InICs (Cons (plus $Rel $Names) $OutICs)) + (dep $Dep $Type $Rel $From $To) + (filter $PosIn $Rel $PosFiltered $Rest) + (splitsort $PosFiltered $Dep $SplitPos) + (joinsort $SplitPos $Dep $NotContr $Contr) + (find-division $Rel $NotContr $Contr $Numbers $NewPos1) + (new-preds $Rel $NewPos1 Nil $PosTmp1 Nil $Names) + (append $PosTmp1 $Rest $PosTmp2) + (decomp-again $Names $Dep $PosTmp2 $PosOut $InICs $OutICs)) +; ; divides(SplitPos,Dep,NewPos,Numbers), + + + (= (decomp_again () $Dep $Pos $Pos $ICs $ICs) True) + (= (decomp-again (Cons $Name $Names) $Dep $PosIn $PosOut $InICs $OutICs) + (det-if-then-else + (yesno (:: 'Decompose ' $Name ? )) + (, + (dep $Dep $Type $R $From $To) + (dep $NewDep $Type $Name $From $To) + (display $NewDep $DDep) + (decompose $DDep $PosIn $PosTmp $InICs $TmpICs)) + (det-if-then otherwise + (, + (= $PosTmp $PosIn) + (= $TmpICs $InICs)))) + (decomp-again $Names $Dep $PosTmp $PosOut $TmpICs $OutICs)) - (= - (divides - (Cons $H $T) $Dep - (Cons $NewH $NewT) - (Cons $NsH $NsT)) - ( (length $H $LH) - (divide1 $H $LH $_ Nil 0 $_ $Dep $NewH $NsH) - (set-det) - (divides $T $Dep $NewT $NsT))) -; + (= (divides () $Dep () ()) True) + (= (divides (Cons $H $T) $Dep (Cons $NewH $NewT) (Cons $NsH $NsT)) + (length $H $LH) + (divide1 $H $LH $_ Nil 0 $_ $Dep $NewH $NsH) + (set-det) + (divides $T $Dep $NewT $NsT)) - (= - (divide1 $Pos1 $Pos2 $IC $PosOut) + (= (divide1 $Pos1 $Pos2 $IC $PosOut) (divide1 $Pos1 0 $_ $Pos2 0 $_ $IC $PosOut $_)) -; - - (= - (divide1 Nil $K $K Nil $L $L $IC Nil Nil) + (= (divide1 Nil $K $K Nil $L $L $IC Nil Nil) (set-det)) -; - - (= - (divide1 $Pos1 $K0 $K $Pos2 $L0 $L $IC $PosOut $M) - ( (contr $Pos1 Nil $IC $Tuples $Answer) - (det-if-then-else - (or - (= $Answer yes) - (= $Answer possibly)) - (, - (= $Tuples - (Cons - (+ $T1) - (Cons - (+ $T2) $N))) - (remove $T2 $Pos1 $NewPos1) - (is $K1 - (- $K0 1)) - (= $NewPos2 - (Cons $T2 $Pos2)) - (is $L1 - (+ $L0 1)) - (= $PosOut $NewPosOut) - (= $M $NewM)) - (det-if-then - (= $Answer no) - (, - (= $NewPos1 $Pos2) - (= $K1 $L0) - (= $NewPos2 Nil) - (= $L1 0) - (= $PosOut - (Cons $Pos1 $NewPosOut)) - (= $M - (Cons $K0 $NewM))))) - (set-det) - (divide1 $NewPos1 $K1 $K $NewPos2 $L1 $L $IC $NewPosOut $NewM))) -; - - - - (= - (find-division $Rel $NotContr $Contr $Numbers $NewPos) - ( (det-if-then-else - (= $NotContr Nil) - (= $NewPos $Contr) - (det-if-then otherwise - (= $NewPos + (= (divide1 $Pos1 $K0 $K $Pos2 $L0 $L $IC $PosOut $M) + (contr $Pos1 Nil $IC $Tuples $Answer) + (det-if-then-else + (or + (= $Answer yes) + (= $Answer possibly)) + (, + (= $Tuples + (Cons + (+ $T1) (Cons - (:: $NotContr) $Contr)))) - (show-lists $Rel - (:: segment part) $NewPos) - (yesno (:: 'Proceed? ')))) -; - - - - (= - (new_preds $Rel () $New $New $Names $Names) True) -; - - (= - (new-preds $Rel - (Cons $H $T) $New0 $New $Names0 $Names) - ( (new-preds1 $Rel $H $New0 $New1 $Names0 $Names1) (new-preds $Rel $T $New1 $New $Names1 $Names))) -; - + (+ $T2) $N))) + (remove $T2 $Pos1 $NewPos1) + (is $K1 + (- $K0 1)) + (= $NewPos2 + (Cons $T2 $Pos2)) + (is $L1 + (+ $L0 1)) + (= $PosOut $NewPosOut) + (= $M $NewM)) + (det-if-then + (= $Answer no) + (, + (= $NewPos1 $Pos2) + (= $K1 $L0) + (= $NewPos2 Nil) + (= $L1 0) + (= $PosOut + (Cons $Pos1 $NewPosOut)) + (= $M + (Cons $K0 $NewM))))) + (set-det) + (divide1 $NewPos1 $K1 $K $NewPos2 $L1 $L $IC $NewPosOut $NewM)) + + + (= (find-division $Rel $NotContr $Contr $Numbers $NewPos) + (det-if-then-else + (= $NotContr Nil) + (= $NewPos $Contr) + (det-if-then otherwise + (= $NewPos + (Cons + (:: $NotContr) $Contr)))) + (show-lists $Rel + (:: segment part) $NewPos) + (yesno (:: 'Proceed? '))) - (= - (new_preds1 $Rel () $New $New $Names $Names) True) -; + (= (new_preds $Rel () $New $New $Names $Names) True) + (= (new-preds $Rel (Cons $H $T) $New0 $New $Names0 $Names) + (new-preds1 $Rel $H $New0 $New1 $Names0 $Names1) + (new-preds $Rel $T $New1 $New $Names1 $Names)) - (= - (new-preds1 $Rel - (Cons $R $Rs) $New0 $New $Names0 $Names) - ( (show-list $Rel 'partial relation' $R) - (prompt-read 'relation name' $N) - (rel $Rel $Attrs) - (new-rel $N $Attrs) - (new-relation $Rel $R $N $NewR) - (append $New0 $NewR $New1) - (add-if $N $Names0 $Names1) - (new-preds1 $Rel $Rs $New1 $New $Names1 $Names))) -; + (= (new_preds1 $Rel () $New $New $Names $Names) True) + (= (new-preds1 $Rel (Cons $R $Rs) $New0 $New $Names0 $Names) + (show-list $Rel 'partial relation' $R) + (prompt-read 'relation name' $N) + (rel $Rel $Attrs) + (new-rel $N $Attrs) + (new-relation $Rel $R $N $NewR) + (append $New0 $NewR $New1) + (add-if $N $Names0 $Names1) + (new-preds1 $Rel $Rs $New1 $New $Names1 $Names)) - (= - (new-relation $Rel $R $N $NewR) + (= (new-relation $Rel $R $N $NewR) (bagof0 $NewT (^ $T (, (member $T $R) (new-tuple $Rel $T $N $NewT))) $NewR)) -; - - - - (= - (new-tuple $Rel $T $N $NewT) - ( (=.. $T - (Cons $Rel $Args)) - (set-det) - (=.. $NewT - (Cons $N $Args)))) -; - (= - (new_tuple $Rel $T $N $T) True) -; - ; -; + (= (new-tuple $Rel $T $N $NewT) + (=.. $T + (Cons $Rel $Args)) + (set-det) + (=.. $NewT + (Cons $N $Args))) + (= (new_tuple $Rel $T $N $T) True) ; +; tuple from other relation - (= - (show-lists $Filter $Texts $Lists) + (= (show-lists $Filter $Texts $Lists) (show-lists $Filter $Texts 1 Nil $Lists)) -; +; /* interaction */ - - (= - (show_lists $Filter $Words $N $Text ()) True) -; - - (= - (show-lists $Filter Nil $N $Text - (Cons $H $T)) + (= (show_lists $Filter $Words $N $Text ()) True) + (= (show-lists $Filter Nil $N $Text (Cons $H $T)) (show-list $Filter $Text (Cons $H $T))) -; - - (= + (= (show-lists $Filter (Cons $Word $Words) 1 $Text (:: $H)) + (set-det) + (show-lists $Filter $Words 1 $Text $H)) + (= (show-lists $Filter (Cons $Word $Words) $N $Text (Cons $H $T)) + (append $Text + (:: $Word $N --- ) $NewText) + (show-lists $Filter $Words 1 $NewText $H) + (is $N1 + (+ $N 1)) (show-lists $Filter - (Cons $Word $Words) 1 $Text - (:: $H)) - ( (set-det) (show-lists $Filter $Words 1 $Text $H))) -; - - (= - (show-lists $Filter - (Cons $Word $Words) $N $Text - (Cons $H $T)) - ( (append $Text - (:: $Word $N --- ) $NewText) - (show-lists $Filter $Words 1 $NewText $H) - (is $N1 - (+ $N 1)) - (show-lists $Filter - (Cons $Word $Words) $N1 $Text $T))) -; - - + (Cons $Word $Words) $N1 $Text $T)) - (= - (show-list $Filter $Text $List) - ( (filter $List $Filter $Filtered) (show-list $Text $Filtered))) -; - - - (= - (show-list $Text Nil) - ( (set-det) - (write-list (:: 'There are no ' $Text .)) - (nl))) -; - - (= - (show-list $Text $List) - ( (write-list (:: $Text :)) - (display-list $List $List1) - (show-items $List1) - (nl))) -; + (= (show-list $Filter $Text $List) + (filter $List $Filter $Filtered) + (show-list $Text $Filtered)) + (= (show-list $Text Nil) + (set-det) + (write-list (:: 'There are no ' $Text .)) + (nl)) + (= (show-list $Text $List) + (write-list (:: $Text :)) + (display-list $List $List1) + (show-items $List1) + (nl)) - (= - (choose-list $Text $List $Sel) - ( (display-list $List $List1) - (choose-items 1 $List1) - (write-list (:: $Text ? )) - (read $Ns) - (det-if-then-else - (nths $List $Ns Nil $Sel) True - (det-if-then otherwise - (, - (write 'Wrong number! Try again.') - (nl) - (choose-list $Text $List $Sel)))))) -; + (= (choose-list $Text $List $Sel) + (display-list $List $List1) + (choose-items 1 $List1) + (write-list (:: $Text ? )) + (read $Ns) + (det-if-then-else + (nths $List $Ns Nil $Sel) True + (det-if-then otherwise + (, + (write 'Wrong number! Try again.') + (nl) + (choose-list $Text $List $Sel))))) - (= - (nths $List all Nil $List) + (= (nths $List all Nil $List) (set-det)) -; - - (= - (nths $In - (- $A $A) $Tmp $Out) - ( (set-det) (nths $In $A $Tmp $Out))) -; - - (= + (= (nths $In (- $A $A) $Tmp $Out) + (set-det) + (nths $In $A $Tmp $Out)) + (= (nths $In (- $A $B) $Tmp $Out) + (set-det) + (< $A $B) + (is $A1 + (+ $A 1)) + (nths $In $A $Tmp $Tmp1) (nths $In - (- $A $B) $Tmp $Out) - ( (set-det) - (< $A $B) - (is $A1 - (+ $A 1)) - (nths $In $A $Tmp $Tmp1) - (nths $In - (- $A1 $B) $Tmp1 $Out))) -; - - (= - (nths $In - (, $N $Ns) $Tmp $Out) - ( (set-det) - (nths $In $N $Tmp $Tmp1) - (nths $In $Ns $Tmp1 $Out))) -; - + (- $A1 $B) $Tmp1 $Out)) + (= (nths $In (, $N $Ns) $Tmp $Out) + (set-det) + (nths $In $N $Tmp $Tmp1) + (nths $In $Ns $Tmp1 $Out)) ; -; - +; nths([],1,Tmp,[X|Tmp]):-!, ; -; - - (= - (nths - (Cons $X $R) 1 $Tmp - (Cons $X $Tmp)) +; write('Which one? '),read(X). + (= (nths (Cons $X $R) 1 $Tmp (Cons $X $Tmp)) (set-det)) -; - - (= - (nths - (Cons $X $R) $N $Tmp $Out) - ( (is $N1 - (- $N 1)) (nths $R $N1 $Tmp $Out))) -; - + (= (nths (Cons $X $R) $N $Tmp $Out) + (is $N1 + (- $N 1)) + (nths $R $N1 $Tmp $Out)) ; (error ; (syntax_error operator_expected) @@ -1558,846 +955,518 @@ - (= - (choose-items $N Nil) + (= (choose-items $N Nil) (nl)) -; - - (= - (choose-items $N - (Cons $H $T)) - ( (nl) - (write-list (:: $N . $H)) - (is $N1 - (+ $N 1)) - (choose-items $N1 $T))) -; - - - - (= - (display_list () ()) True) -; - - (= - (display-list - (Cons $H $T) - (Cons $DH $DT)) - ( (det-if-then-else - (switched-on horn) - (displayhorn $H $DH) - (det-if-then otherwise - (display $H $DH))) (display-list $T $DT))) -; +; ; nl,write_list([' ',N,'. Other...']), + (= (choose-items $N (Cons $H $T)) + (nl) + (write-list (:: $N . $H)) + (is $N1 + (+ $N 1)) + (choose-items $N1 $T)) - - (= - (displayhorn $X $HX) - ( (horn $X $HX) (set-det))) -; - - (= - (displayhorn $X $X) True) -; + (= (display_list () ()) True) + (= (display-list (Cons $H $T) (Cons $DH $DT)) + (det-if-then-else + (switched-on horn) + (displayhorn $H $DH) + (det-if-then otherwise + (display $H $DH))) + (display-list $T $DT)) + (= (displayhorn $X $HX) + (horn $X $HX) + (set-det)) + (= (displayhorn $X $X) True) - (= - (prompt-read $Question $Answer) - ( (write-list (:: $Question ? )) - (read $Answer) - (det-if-then-else - (= $Answer stop) fail - (det-if-then otherwise True)))) -; + (= (prompt-read $Question $Answer) + (write-list (:: $Question ? )) + (read $Answer) + (det-if-then-else + (= $Answer stop) fail + (det-if-then otherwise True))) - (= - (yesno $Question) - ( (write-list $Question) - (read $Answer) + (= (yesno $Question) + (write-list $Question) + (read $Answer) + (det-if-then-else + (= $Answer yes) True (det-if-then-else - (= $Answer yes) True - (det-if-then-else - (= $Answer no) fail - (det-if-then otherwise - (, - (call $Answer) - (yesno $Question))))))) -; - + (= $Answer no) fail + (det-if-then otherwise + (, + (call $Answer) + (yesno $Question)))))) ; (error ; (syntax_error operator_expected) ; (file index/index.pl 647 4 17368)) - (= - (write-debug $Message) - ( (switched-on debug) - (write | ) - (write-list $Message) - (nl))) -; - - - - (= - (write-list $List) - ( (flatten $List $FList) (write-list1 $FList))) -; - + (= (write-debug $Message) + (switched-on debug) + (write | ) + (write-list $Message) + (nl)) - (= - (write_list1 ()) True) -; + (= (write-list $List) + (flatten $List $FList) + (write-list1 $FList)) - (= - (write-list1 (Cons $H $T)) - ( (write $H) (write-list1 $T))) -; + (= (write_list1 ()) True) + (= (write-list1 (Cons $H $T)) + (write $H) + (write-list1 $T)) - (= - (quit) + (= (quit) (abort)) -; - - - (= - (keyword1 save ' save in Prolog database') True) -; - (= - (keyword1 get ' get from Prolog database') True) -; + (= (keyword1 save ' save in Prolog database') True) +; /* commands */ + (= (keyword1 get ' get from Prolog database') True) + (= (keyword1 show ' show current') True) + (= (keyword1 count ' count current') True) + (= (keyword1 del ' delete') True) + (= (keyword1 add ' add new') True) + (= (keyword1 init ' initialise constraints') True) + (= (keyword1 find ' find constraints') True) + (= (keyword1 check ' check validity') True) + (= (keyword1 decomp ' decompose relation') True) + (= (keyword1 comp ' compose relations') True) + (= (keyword1 switch ' switch on or off') True) + (= (keyword1 set ' set level') True) + (= (keyword1 help ' get help') True) - (= - (keyword1 show ' show current') True) -; - (= - (keyword1 count ' count current') True) -; + (= (keyword2 pos ' positive tuples') True) + (= (keyword2 neg ' negative tuples') True) + (= (keyword2 ics ' integrity constraints') True) + (= (keyword2 calc ' calculated relations') True) - (= - (keyword1 del ' delete') True) -; - (= - (keyword1 add ' add new') True) -; + (= (switch cwa ' Closed-World Assumption') True) + (= (switch horn ' display in Horn form') True) + (= (switch eval ' evaluate constraints') True) + (= (switch debug ' show debugging information') True) - (= - (keyword1 init ' initialise constraints') True) -; - - (= - (keyword1 find ' find constraints') True) -; - - (= - (keyword1 check ' check validity') True) -; - - (= - (keyword1 decomp ' decompose relation') True) -; - - (= - (keyword1 comp ' compose relations') True) -; - - (= - (keyword1 switch ' switch on or off') True) -; - - (= - (keyword1 set ' set level') True) -; - - (= - (keyword1 help ' get help') True) -; - - - - (= - (keyword2 pos ' positive tuples') True) -; - - (= - (keyword2 neg ' negative tuples') True) -; - - (= - (keyword2 ics ' integrity constraints') True) -; - - (= - (keyword2 calc ' calculated relations') True) -; - - - - (= - (switch cwa ' Closed-World Assumption') True) -; - - (= - (switch horn ' display in Horn form') True) -; - - (= - (switch eval ' evaluate constraints') True) -; - - (= - (switch debug ' show debugging information') True) -; - - - - (= - (level conf ' confirmation level of constraint') True) -; - - (= - (level acc ' accuracy of constraint') True) -; - - (= - (level split ' splitting level of constraint') True) -; + (= (level conf ' confirmation level of constraint') True) + (= (level acc ' accuracy of constraint') True) + (= (level split ' splitting level of constraint') True) !(forall (^ $T (keyword1 $W $T)) (op 1200 fx $W)) -; - !(forall (^ $T (keyword2 $W $T)) (op 1100 fx $W)) -; - !(forall (^ $T (level $W $T)) (op 1100 fx $W)) -; - - (= - (commands $InICs $PosIn $NegIn) - ( (prompt-read '' $Command) - (do-command $Command $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) - (set-det) - (commands $OutICs $PosOut $NegOut))) -; - - (= - (commands $InICs $PosIn $NegIn) - ( (write no) - (nl) - (set-det) - (commands $InICs $PosIn $NegIn))) -; - - - - (= - (do-command - (save $X) $ICs $Pos $Neg $ICs $Pos $Neg) - ( (set-det) (save-command $X $ICs $Pos $Neg))) -; - - (= - (do-command - (get $X) $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) - ( (set-det) (get-command $X $InICs $PosIn $NegIn $OutICs $PosOut $NegOut))) -; - - (= - (do-command - (show $X) $ICs $Pos $Neg $ICs $Pos $Neg) - ( (set-det) (show-command $X $ICs $Pos $Neg))) -; - - (= - (do-command - (count $X) $ICs $Pos $Neg $ICs $Pos $Neg) - ( (set-det) (count-command $X $ICs $Pos $Neg))) -; - - (= - (do-command - (del $X) $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) - ( (set-det) (del-command $X $InICs $PosIn $NegIn $OutICs $PosOut $NegOut))) -; - - (= - (do-command - (add $X) $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) - ( (set-det) (add-command $X $InICs $PosIn $NegIn $OutICs $PosOut $NegOut))) -; - - (= - (do-command - (init $X) $InICs $Pos $Neg $OutICs $Pos $Neg) - ( (set-det) (init-command $X $InICs $OutICs))) -; - - (= - (do-command - (find $X) $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) - ( (set-det) (find-command $X $InICs $PosIn $NegIn $OutICs $PosOut $NegOut))) -; - - (= - (do-command - (check $X) $ICs $Pos $Neg $ICs $Pos $Neg) - ( (set-det) (check-command $X $ICs $Pos $Neg))) -; - - (= - (do-command - (decomp $IC) $InICs $PosIn $Neg $OutICs $PosOut $Neg) - ( (set-det) (decompose $IC $PosIn $PosOut $InICs $OutICs))) -; - - (= - (do-command - (comp $Rule) $ICs $PosIn $Neg $ICs $PosOut $Neg) - ( (set-det) - (exec-rule $Rule $PosIn $PosNew) - (append $PosIn $PosNew $PosOut))) -; - - (= - (do-command - (switch $X) $ICs $Pos $Neg $ICs $Pos $Neg) - ( (set-det) (switch $X))) -; - - (= - (do-command - (set $X) $ICs $Pos $Neg $ICs $Pos $Neg) - ( (set-det) (set $X))) -; - - (= - (do-command - (help $Topic) $ICs $Pos $Neg $ICs $Pos $Neg) - ( (set-det) (help-command $Topic))) -; - - (= - (do-command $Command $ICs $Pos $Neg $ICs $Pos $Neg) + (= (commands $InICs $PosIn $NegIn) + (prompt-read '' $Command) + (do-command $Command $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) + (set-det) + (commands $OutICs $PosOut $NegOut)) + (= (commands $InICs $PosIn $NegIn) + (write no) + (nl) + (set-det) + (commands $InICs $PosIn $NegIn)) + + + (= (do-command (save $X) $ICs $Pos $Neg $ICs $Pos $Neg) + (set-det) + (save-command $X $ICs $Pos $Neg)) + (= (do-command (get $X) $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) + (set-det) + (get-command $X $InICs $PosIn $NegIn $OutICs $PosOut $NegOut)) + (= (do-command (show $X) $ICs $Pos $Neg $ICs $Pos $Neg) + (set-det) + (show-command $X $ICs $Pos $Neg)) + (= (do-command (count $X) $ICs $Pos $Neg $ICs $Pos $Neg) + (set-det) + (count-command $X $ICs $Pos $Neg)) + (= (do-command (del $X) $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) + (set-det) + (del-command $X $InICs $PosIn $NegIn $OutICs $PosOut $NegOut)) + (= (do-command (add $X) $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) + (set-det) + (add-command $X $InICs $PosIn $NegIn $OutICs $PosOut $NegOut)) + (= (do-command (init $X) $InICs $Pos $Neg $OutICs $Pos $Neg) + (set-det) + (init-command $X $InICs $OutICs)) + (= (do-command (find $X) $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) + (set-det) + (find-command $X $InICs $PosIn $NegIn $OutICs $PosOut $NegOut)) + (= (do-command (check $X) $ICs $Pos $Neg $ICs $Pos $Neg) + (set-det) + (check-command $X $ICs $Pos $Neg)) + (= (do-command (decomp $IC) $InICs $PosIn $Neg $OutICs $PosOut $Neg) + (set-det) + (decompose $IC $PosIn $PosOut $InICs $OutICs)) + (= (do-command (comp $Rule) $ICs $PosIn $Neg $ICs $PosOut $Neg) + (set-det) + (exec-rule $Rule $PosIn $PosNew) + (append $PosIn $PosNew $PosOut)) + (= (do-command (switch $X) $ICs $Pos $Neg $ICs $Pos $Neg) + (set-det) + (switch $X)) + (= (do-command (set $X) $ICs $Pos $Neg $ICs $Pos $Neg) + (set-det) + (set $X)) + (= (do-command (help $Topic) $ICs $Pos $Neg $ICs $Pos $Neg) + (set-det) + (help-command $Topic)) + (= (do-command $Command $ICs $Pos $Neg $ICs $Pos $Neg) (call $Command)) -; - - (= - (do-command $Command $ICs $Pos $Neg $ICs $Pos $Neg) + (= (do-command $Command $ICs $Pos $Neg $ICs $Pos $Neg) (write ?)) -; - - (= - (save-command - (pos $Rel) $ICs $Pos $Neg) + (= (save-command (pos $Rel) $ICs $Pos $Neg) (save-pos $Rel $Pos)) -; - - (= - (save-command - (neg $Rel) $ICs $Pos $Neg) + (= (save-command (neg $Rel) $ICs $Pos $Neg) (save-neg $Rel $Neg)) -; - - (= - (save-command - (ics $T) $ICs $Pos $Neg) + (= (save-command (ics $T) $ICs $Pos $Neg) (save-ics $T $ICs)) -; - - - - (= - (get-command - (pos $Rel) $ICs $PosIn $Neg $ICs $PosOut $Neg) - ( (get-pos $Rel $Pos) (append $PosIn $Pos $PosOut))) -; - - (= - (get-command - (neg $Rel) $ICs $Pos $NegIn $ICs $Pos $NegOut) - ( (get-neg $Rel $Neg) (append $NegIn $Neg $NegOut))) -; - - (= - (get-command - (ics $T) $InICs $Pos $Neg $OutICs $Pos $Neg) - ( (get-ics $T $ICs) (append $InICs $ICs $OutICs))) -; - - - - (= - (show-command all $ICs $Pos $Neg) - ( (set-det) - (show-list 'positive tuples' $Pos) - (show-list 'negative tuples' $Neg) - (show-list 'integrity constraints' $ICs))) -; - - (= - (show-command rel $ICs $Pos $Neg) - ( (set-det) - (bagof0 $R - (^ $A - (rel $R $A)) $Rels) - (show-list relations $Rels))) -; - - (= - (show-command $Other $ICs $Pos $Neg) - ( (get-list $Other $ICs $Pos $Neg $List $Text) - (set-det) - (show-list $Text $List))) -; - (= - (show-command $Wrong $ICs $Pos $Neg) + + (= (get-command (pos $Rel) $ICs $PosIn $Neg $ICs $PosOut $Neg) + (get-pos $Rel $Pos) + (append $PosIn $Pos $PosOut)) + (= (get-command (neg $Rel) $ICs $Pos $NegIn $ICs $Pos $NegOut) + (get-neg $Rel $Neg) + (append $NegIn $Neg $NegOut)) + (= (get-command (ics $T) $InICs $Pos $Neg $OutICs $Pos $Neg) + (get-ics $T $ICs) + (append $InICs $ICs $OutICs)) + + + (= (show-command all $ICs $Pos $Neg) + (set-det) + (show-list 'positive tuples' $Pos) + (show-list 'negative tuples' $Neg) + (show-list 'integrity constraints' $ICs)) + (= (show-command rel $ICs $Pos $Neg) + (set-det) + (bagof0 $R + (^ $A + (rel $R $A)) $Rels) + (show-list relations $Rels)) + (= (show-command $Other $ICs $Pos $Neg) + (get-list $Other $ICs $Pos $Neg $List $Text) + (set-det) + (show-list $Text $List)) + (= (show-command $Wrong $ICs $Pos $Neg) (show-list choices (:: 'show all' 'show rel' 'show pos all' 'show pos Rel' 'show neg all' 'show neg Rel' 'show ics all' 'show ics Rel'))) -; - - - - (= - (count-command $Filter $ICs $Pos $Neg) - ( (get-list $Filter $ICs $Pos $Neg $List $Text) - (length $List $N) - (write-list (:: 'There are ' $N ' ' $Text .)) - (nl))) -; + (= (count-command $Filter $ICs $Pos $Neg) + (get-list $Filter $ICs $Pos $Neg $List $Text) + (length $List $N) + (write-list (:: 'There are ' $N ' ' $Text .)) + (nl)) - (= - (del_command all $ICs $Pos $Neg () () ()) True) -; - (= - (del-command - (ics $F) $InICs $Pos $Neg $OutICs $Pos $Neg) + (= (del_command all $ICs $Pos $Neg () () ()) True) + (= (del-command (ics $F) $InICs $Pos $Neg $OutICs $Pos $Neg) (filter $InICs $F $Deleted $OutICs)) -; - - (= - (del-command - (pos $Rel) $ICs $PosIn $Neg $ICs $PosOut $Neg) + (= (del-command (pos $Rel) $ICs $PosIn $Neg $ICs $PosOut $Neg) (filter $PosIn $Rel $Deleted $PosOut)) -; - - (= - (del-command - (neg $Rel) $ICs $Pos $NegIn $ICs $Pos $NegOut) + (= (del-command (neg $Rel) $ICs $Pos $NegIn $ICs $Pos $NegOut) (filter $NegIn $Rel $Deleted $NegOut)) -; - - (= - (del-command - (rel $R) $ICs $PosIn $NegIn $ICs $PosOut $NegOut) - ( (remove-symbol &self + (= (del-command (rel $R) $ICs $PosIn $NegIn $ICs $PosOut $NegOut) + ( (remove-is-symbol &self (rel $R $AList)) (filter $PosIn $Rel $_ $PosOut) (filter $NegIn $Rel $_ $NegOut))) -; - - (= - (del-command - (calc $Rel) $InICs $Pos $Neg $OutICs $Pos $Neg) - ( (remove-all-symbols &self + (= (del-command (calc $Rel) $InICs $Pos $Neg $OutICs $Pos $Neg) + ( (remove-all-atoms &self (proc $Rel $Proc)) (remove (proc $Rel) $InICs $OutICs))) -; - - (= - (add-command - (ics $DisplayIC) $ICs $Pos $Neg - (Cons $IC $ICs) $Pos $Neg) + (= (add-command (ics $DisplayIC) $ICs $Pos $Neg (Cons $IC $ICs) $Pos $Neg) (display $IC $DisplayIC)) -; - - (= - (add_command - (pos $Tuple) $ICs $Pos $Neg $ICs - (Cons $Tuple $Pos) $Neg) True) -; - - (= - (add_command - (neg $Tuple) $ICs $Pos $Neg $ICs $Pos - (Cons $Tuple $Neg)) True) -; - - (= - (add-command - (rel $R $AList) $ICs $Pos $Neg $ICs $Pos $Neg) + (= (add_command (pos $Tuple) $ICs $Pos $Neg $ICs (Cons $Tuple $Pos) $Neg) True) + (= (add_command (neg $Tuple) $ICs $Pos $Neg $ICs $Pos (Cons $Tuple $Neg)) True) + (= (add-command (rel $R $AList) $ICs $Pos $Neg $ICs $Pos $Neg) (new-rel $R $AList)) -; - - (= - (add-command - (calc $Rel) $InICs $PosIn $Neg - (Cons - (proc $Rel) $OutICs) $PosOut $Neg) - ( (ask-proc $Rel) - (filter $PosIn $Rel $RelTuples $_) - (setof0 $T - (, - (member $T $RelTuples) - (satisfied $T Nil Nil Nil)) $SatTuples) - (listdiff $PosIn $SatTuples $PosOut) - (remove - (proc $Rel) $InICs $OutICs))) -; - + (= (add-command (calc $Rel) $InICs $PosIn $Neg (Cons (proc $Rel) $OutICs) $PosOut $Neg) + (ask-proc $Rel) + (filter $PosIn $Rel $RelTuples $_) + (setof0 $T + (, + (member $T $RelTuples) + (satisfied $T Nil Nil Nil)) $SatTuples) + (listdiff $PosIn $SatTuples $PosOut) + (remove + (proc $Rel) $InICs $OutICs)) - (= - (init-command - (ics $Rel) $InICs $OutICs) - ( (init-ICs $Rel $ICs) (append $InICs $ICs $OutICs))) -; - + (= (init-command (ics $Rel) $InICs $OutICs) + (init-ICs $Rel $ICs) + (append $InICs $ICs $OutICs)) - (= - (find-command ics $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) + (= (find-command ics $InICs $PosIn $NegIn $OutICs $PosOut $NegOut) (char $InICs $PosIn $NegIn $OutICs $PosOut $NegOut)) -; - - - - (= - (check-command - (ics $DisplayIC) $ICs $Pos $Neg) - ( (display $IC $DisplayIC) (check-ics $IC $Pos $Neg))) -; - - (= - (check-command - (pos $Tuple) $ICs $Pos $Neg) - ( (set-det) (forall (member $IC $ICs) (check-ics $IC (Cons $Tuple $Pos) $Neg)))) -; - - - - (= - (help-command commands) - ( (set-det) - (bagof0 - (with_self $W $T) - (keyword1 $W $T) $L) - (show-list Commands $L))) -; - - (= - (help-command filters) - ( (set-det) - (bagof0 - (with_self $W $T) - (keyword2 $W $T) $L) - (show-list Filters $L))) -; - - (= - (help-command switches) - ( (set-det) - (bagof0 - (with_self $W $T) - (switch $W $T) $L) - (show-list Switches $L))) -; - - (= - (help-command levels) - ( (set-det) - (bagof0 - (with_self $W $T) - (level $W $T) $L) - (show-list Levels $L))) -; - - (= - (help-command $_) - ( (help-command commands) - (help-command filters) - (help-command switches) - (help-command levels))) -; - - - - (= - (get-list - (pos $Filter) $ICs $Pos $Neg $List 'positive tuples') - (filter $Pos $Filter $List)) -; - - (= - (get-list - (neg $Filter) $ICs $Pos $Neg $List 'negative tuples') - (filter $Neg $Filter $List)) -; - - (= - (get-list - (ics $Filter) $ICs $Pos $Neg $List 'integrity constraints') - ( (filter $ICs $Filter $Tmp) (compress $Tmp $List))) -; + (= (check-command (ics $DisplayIC) $ICs $Pos $Neg) + (display $IC $DisplayIC) + (check-ics $IC $Pos $Neg)) + (= (check-command (pos $Tuple) $ICs $Pos $Neg) + (set-det) + (forall + (member $IC $ICs) + (check-ics $IC + (Cons $Tuple $Pos) $Neg))) + + + (= (help-command commands) + (set-det) + (bagof0 + (with_self $W $T) + (keyword1 $W $T) $L) + (show-list Commands $L)) + (= (help-command filters) + (set-det) + (bagof0 + (with_self $W $T) + (keyword2 $W $T) $L) + (show-list Filters $L)) + (= (help-command switches) + (set-det) + (bagof0 + (with_self $W $T) + (switch $W $T) $L) + (show-list Switches $L)) + (= (help-command levels) + (set-det) + (bagof0 + (with_self $W $T) + (level $W $T) $L) + (show-list Levels $L)) + (= (help-command $_) + (help-command commands) + (help-command filters) + (help-command switches) + (help-command levels)) + + + (= (get-list (pos $Filter) $ICs $Pos $Neg $List 'positive tuples') + (filter $Pos $Filter $List)) + (= (get-list (neg $Filter) $ICs $Pos $Neg $List 'negative tuples') + (filter $Neg $Filter $List)) + (= (get-list (ics $Filter) $ICs $Pos $Neg $List 'integrity constraints') + (filter $ICs $Filter $Tmp) + (compress $Tmp $List)) - (= - (filter $In $F $Out) - ( (template $F $Template) (setof0 $Template (member $Template $In) $Out))) -; - - - (= - (filter $In $F $Out $Rest) - ( (filter $In $F $Out) (listdiff $In $Out $Rest))) -; + (= (filter $In $F $Out) + (template $F $Template) + (setof0 $Template + (member $Template $In) $Out)) + (= (filter $In $F $Out $Rest) + (filter $In $F $Out) + (listdiff $In $Out $Rest)) - (= - (new-rel $R $Attrs) - ( (rel $R $Attrs) (set-det))) -; - (= - (new-rel $R $Attrs) - ( (rel $R $A) - (set-det) - (write 'Error: relation name already in use') - (nl) - (fail))) -; - - (= - (new-rel $R $Attrs) - (add-symbol &self + (= (new-rel $R $Attrs) + (rel $R $Attrs) + (set-det)) + (= (new-rel $R $Attrs) + (rel $R $A) + (set-det) + (write 'Error: relation name already in use') + (nl) + (fail)) + (= (new-rel $R $Attrs) + (add-is-symbol &self (rel $R $Attrs))) -; - - (= - (ask-proc $Rel) + (= (ask-proc $Rel) ( (prompt-read clause $Clause) - (add-symbol &self + (add-is-symbol &self (proc $Rel $Clause)) (set-det) (ask-proc $Rel))) -; - - (= - (ask_proc $Rel) True) -; - + (= (ask_proc $Rel) True) - (= - (get-pos $Rel $Pos) - ( (template $Rel $Tuple) (bagof0 $Tuple (pos-tuple $Tuple) $Pos))) -; + (= (get-pos $Rel $Pos) + (template $Rel $Tuple) + (bagof0 $Tuple + (pos-tuple $Tuple) $Pos)) + (= (get-neg $Rel $Neg) + (template $Rel $Tuple) + (bagof0 $Tuple + (neg-tuple $Tuple) $Neg)) - (= - (get-neg $Rel $Neg) - ( (template $Rel $Tuple) (bagof0 $Tuple (neg-tuple $Tuple) $Neg))) -; + (= (get-ics $T $ICs) + (template $T $Templ) + (bagof0 $Templ + (constraint $Templ) $ICs)) - (= - (get-ics $T $ICs) - ( (template $T $Templ) (bagof0 $Templ (constraint $Templ) $ICs))) -; + (= (save-pos $Rel $Pos) + (template $Rel $T) + (forall + (member $T $Pos) + (myassert (pos-tuple $T)))) + (= (save-neg $Rel $Neg) + (template $Rel $T) + (forall + (member $T $Neg) + (myassert (neg-tuple $T)))) - (= - (save-pos $Rel $Pos) - ( (template $Rel $T) (forall (member $T $Pos) (myassert (pos-tuple $T))))) -; + (= (save-ics $T $ICs) + (template $T $Templ) + (forall + (member $Templ $ICs) + (myassert (constraint $Templ)))) - (= - (save-neg $Rel $Neg) - ( (template $Rel $T) (forall (member $T $Neg) (myassert (neg-tuple $T))))) -; - - - - (= - (save-ics $T $ICs) - ( (template $T $Templ) (forall (member $Templ $ICs) (myassert (constraint $Templ))))) -; - - - - (= - (check-ics $IC $Pos $Neg) - ( (display $IC $DisplayIC) - (evaluate $Pos $Neg $IC $Tuples $PosOut $NegOut $Answer) - (write $DisplayIC) + (= (check-ics $IC $Pos $Neg) + (display $IC $DisplayIC) + (evaluate $Pos $Neg $IC $Tuples $PosOut $NegOut $Answer) + (write $DisplayIC) + (det-if-then-else + (= $Answer refine) + (show-list ' is contradicted by' $Tuples) (det-if-then-else - (= $Answer refine) - (show-list ' is contradicted by' $Tuples) + (= $Answer keep) + (, + (write ' is satisfied') + (nl)) (det-if-then-else - (= $Answer keep) + (= $Answer + (keep $E)) (, - (write ' is satisfied') + (write-list (:: ' looks promising: ' $E)) (nl)) - (det-if-then-else + (det-if-then (= $Answer - (keep $E)) + (ignore $E)) (, - (write-list (:: ' looks promising: ' $E)) - (nl)) - (det-if-then - (= $Answer - (ignore $E)) - (, - (write-list (:: ' has low confirmation: ' $E)) - (nl)))))))) -; - + (write-list (:: ' has low confirmation: ' $E)) + (nl))))))) - (= - (switch $X) + (= (switch $X) ( (switch $X $T) - (remove-symbol &self + (remove-is-symbol &self (switched_on $X)) (set-det) (write-list (:: $X ' is now off.')) (nl))) -; - - (= - (switch $X) + (= (switch $X) ( (switch $X $T) (set-det) - (add-symbol &self + (add-is-symbol &self (switched_on $X)) (write-list (:: $X ' is now on.')) (nl))) -; - ; (error ; (syntax_error operator_expected) ; (file index/index.pl 912 28 25372)) - (= - (set $X) - ( (=.. $X - (Cons $Level $Rest)) - (level $Level $T) - (set-det) - (det-if-then-else - (= $Rest - (:: $Value)) - (, - (or - (, - (remove-symbol &self - (level_set $Level $V)) - (set-det)) True) - (add-symbol &self - (level_set $Level $Value))) - (det-if-then - (= $Rest Nil) - (, - (get-level $Level $L) - (write (= $Level $L)) - (nl)))))) -; - - (= - (set $_) - ( (setof0 - (= $L $V) - (^ $T + (= (set $X) + (=.. $X + (Cons $Level $Rest)) + (level $Level $T) + (set-det) + (det-if-then-else + (= $Rest + (:: $Value)) + (, + (or (, - (level $L $T) - (get-level $L $V))) $L) (show-list levels $L))) -; - - + (remove-is-symbol &self + (level_set $Level $V)) + (set-det)) True) + (add-is-symbol &self + (level_set $Level $Value))) + (det-if-then + (= $Rest Nil) + (, + (get-level $Level $L) + (write (= $Level $L)) + (nl))))) + (= (set $_) + (setof0 + (= $L $V) + (^ $T + (, + (level $L $T) + (get-level $L $V))) $L) + (show-list levels $L)) - (= - (get-level $Level $Value) - ( (level $Level $T) (or (, (level-set $Level $Value) (set-det)) (= $Value 0)))) -; + (= (get-level $Level $Value) + (level $Level $T) + (or + (, + (level-set $Level $Value) + (set-det)) + (= $Value 0))) - (= - (compare $X) - ( (=.. $X - (:: $Level $Value)) - (get-level $Level $L) + (= (compare $X) + (=.. $X + (:: $Level $Value)) + (get-level $Level $L) + (det-if-then-else + (= $L + (+ $V)) + (>= $Value $V) (det-if-then-else (= $L - (+ $V)) - (>= $Value $V) + (- $V)) + (=< $Value $V) (det-if-then-else (= $L - (- $V)) - (=< $Value $V) - (det-if-then-else - (= $L - (/ $V $A)) + (/ $V $A)) + (, + (is $Upper + (+ $V $A)) + (=< $Value $Upper) + (is $Lower + (- $V $A)) + (>= $Value $Lower)) + (det-if-then otherwise (, - (is $Upper - (+ $V $A)) - (=< $Value $Upper) - (is $Lower - (- $V $A)) - (>= $Value $Lower)) - (det-if-then otherwise - (, - (write-list (:: 'Wrong level: ' (= $Level $L))) - (nl) - (break)))))))) -; - + (write-list (:: 'Wrong level: ' (= $Level $L))) + (nl) + (break))))))) !(run *) -; - diff --git a/index/inter.metta b/index/inter.metta index 5d14144..ba16968 100644 --- a/index/inter.metta +++ b/index/inter.metta @@ -1,252 +1,163 @@ +; (convert_to_metta_file inter $_245304 index/inter.pl index/inter.metta) - (= - (show-lists $Filter $Texts $Lists) + (= (show-lists $Filter $Texts $Lists) (show-lists $Filter $Texts 1 Nil $Lists)) -; +; /* interaction */ - - (= - (show_lists $Filter $Words $N $Text ()) True) -; - - (= - (show-lists $Filter Nil $N $Text - (Cons $H $T)) + (= (show_lists $Filter $Words $N $Text ()) True) + (= (show-lists $Filter Nil $N $Text (Cons $H $T)) (show-list $Filter $Text (Cons $H $T))) -; - - (= + (= (show-lists $Filter (Cons $Word $Words) 1 $Text (:: $H)) + (set-det) + (show-lists $Filter $Words 1 $Text $H)) + (= (show-lists $Filter (Cons $Word $Words) $N $Text (Cons $H $T)) + (append $Text + (:: $Word $N --- ) $NewText) + (show-lists $Filter $Words 1 $NewText $H) + (is $N1 + (+ $N 1)) (show-lists $Filter - (Cons $Word $Words) 1 $Text - (:: $H)) - ( (set-det) (show-lists $Filter $Words 1 $Text $H))) -; + (Cons $Word $Words) $N1 $Text $T)) - (= - (show-lists $Filter - (Cons $Word $Words) $N $Text - (Cons $H $T)) - ( (append $Text - (:: $Word $N --- ) $NewText) - (show-lists $Filter $Words 1 $NewText $H) - (is $N1 - (+ $N 1)) - (show-lists $Filter - (Cons $Word $Words) $N1 $Text $T))) -; - - - - (= - (show-list $Filter $Text $List) - ( (filter $List $Filter $Filtered) (show-list $Text $Filtered))) -; - - - (= - (show-list $Text Nil) - ( (set-det) - (write-list (:: 'There are no ' $Text .)) - (nl))) -; - - (= - (show-list $Text $List) - ( (write-list (:: $Text :)) - (display-list $List $List1) - (show-items $List1) - (nl))) -; - - - - (= - (choose-list $Text $List $Sel) - ( (display-list $List $List1) - (choose-items 1 $List1) - (write-list (:: $Text ? )) - (read $Ns) - (det-if-then-else - (nths $List $Ns Nil $Sel) True - (det-if-then otherwise - (, - (write 'Wrong number! Try again.') - (nl) - (choose-list $Text $List $Sel)))))) -; + (= (show-list $Filter $Text $List) + (filter $List $Filter $Filtered) + (show-list $Text $Filtered)) + (= (show-list $Text Nil) + (set-det) + (write-list (:: 'There are no ' $Text .)) + (nl)) + (= (show-list $Text $List) + (write-list (:: $Text :)) + (display-list $List $List1) + (show-items $List1) + (nl)) - (= - (nths $List all Nil $List) - (set-det)) -; - (= - (nths $In - (- $A $A) $Tmp $Out) - ( (set-det) (nths $In $A $Tmp $Out))) -; + (= (choose-list $Text $List $Sel) + (display-list $List $List1) + (choose-items 1 $List1) + (write-list (:: $Text ? )) + (read $Ns) + (det-if-then-else + (nths $List $Ns Nil $Sel) True + (det-if-then otherwise + (, + (write 'Wrong number! Try again.') + (nl) + (choose-list $Text $List $Sel))))) - (= - (nths $In - (- $A $B) $Tmp $Out) - ( (set-det) - (< $A $B) - (is $A1 - (+ $A 1)) - (nths $In $A $Tmp $Tmp1) - (nths $In - (- $A1 $B) $Tmp1 $Out))) -; - - (= - (nths $In - (, $N $Ns) $Tmp $Out) - ( (set-det) - (nths $In $N $Tmp $Tmp1) - (nths $In $Ns $Tmp1 $Out))) -; + (= (nths $List all Nil $List) + (set-det)) + (= (nths $In (- $A $A) $Tmp $Out) + (set-det) + (nths $In $A $Tmp $Out)) + (= (nths $In (- $A $B) $Tmp $Out) + (set-det) + (< $A $B) + (is $A1 + (+ $A 1)) + (nths $In $A $Tmp $Tmp1) + (nths $In + (- $A1 $B) $Tmp1 $Out)) + (= (nths $In (, $N $Ns) $Tmp $Out) + (set-det) + (nths $In $N $Tmp $Tmp1) + (nths $In $Ns $Tmp1 $Out)) ; -; - +; nths([],1,Tmp,[X|Tmp]):-!, ; -; - - (= - (nths - (Cons $X $R) 1 $Tmp - (Cons $X $Tmp)) +; write('Which one? '),read(X). + (= (nths (Cons $X $R) 1 $Tmp (Cons $X $Tmp)) (set-det)) -; - - (= - (nths - (Cons $X $R) $N $Tmp $Out) - ( (is $N1 - (- $N 1)) (nths $R $N1 $Tmp $Out))) -; - + (= (nths (Cons $X $R) $N $Tmp $Out) + (is $N1 + (- $N 1)) + (nths $R $N1 $Tmp $Out)) -; (error -; (syntax_error operator_expected) -; (file index/inter.pl 56 6 1401)) +; (error +; (syntax_error operator_expected) +; (file index/inter.pl 56 6 1401)) -; (error -; (syntax_error operator_expected) -; (file index/inter.pl 60 6 1499)) +; (error +; (syntax_error operator_expected) +; (file index/inter.pl 60 6 1499)) - (= - (choose-items $N Nil) + (= (choose-items $N Nil) (nl)) -; - - (= - (choose-items $N - (Cons $H $T)) - ( (nl) - (write-list (:: $N . $H)) - (is $N1 - (+ $N 1)) - (choose-items $N1 $T))) -; - - - - (= - (display_list () ()) True) -; - - (= - (display-list - (Cons $H $T) - (Cons $DH $DT)) - ( (det-if-then-else - (switched-on horn) - (displayhorn $H $DH) - (det-if-then otherwise - (display $H $DH))) (display-list $T $DT))) -; - - - - (= - (displayhorn $X $HX) - ( (horn $X $HX) (set-det))) -; - - (= - (displayhorn $X $X) True) -; - - +; ; nl,write_list([' ',N,'. Other...']), + (= (choose-items $N (Cons $H $T)) + (nl) + (write-list (:: $N . $H)) + (is $N1 + (+ $N 1)) + (choose-items $N1 $T)) + + + (= (display_list () ()) True) + (= (display-list (Cons $H $T) (Cons $DH $DT)) + (det-if-then-else + (switched-on horn) + (displayhorn $H $DH) + (det-if-then otherwise + (display $H $DH))) + (display-list $T $DT)) + + + (= (displayhorn $X $HX) + (horn $X $HX) + (set-det)) + (= (displayhorn $X $X) True) - (= - (prompt-read $Question $Answer) - ( (write-list (:: $Question ? )) - (read $Answer) - (det-if-then-else - (= $Answer stop) fail - (det-if-then otherwise True)))) -; + (= (prompt-read $Question $Answer) + (write-list (:: $Question ? )) + (read $Answer) + (det-if-then-else + (= $Answer stop) fail + (det-if-then otherwise True))) - (= - (yesno $Question) - ( (write-list $Question) - (read $Answer) + (= (yesno $Question) + (write-list $Question) + (read $Answer) + (det-if-then-else + (= $Answer yes) True (det-if-then-else - (= $Answer yes) True - (det-if-then-else - (= $Answer no) fail - (det-if-then otherwise - (, - (call $Answer) - (yesno $Question))))))) -; - + (= $Answer no) fail + (det-if-then otherwise + (, + (call $Answer) + (yesno $Question)))))) ; (error ; (syntax_error operator_expected) ; (file index/inter.pl 96 4 2236)) - (= - (write-debug $Message) - ( (switched-on debug) - (write | ) - (write-list $Message) - (nl))) -; - - - - (= - (write-list $List) - ( (flatten $List $FList) (write-list1 $FList))) -; - + (= (write-debug $Message) + (switched-on debug) + (write | ) + (write-list $Message) + (nl)) - (= - (write_list1 ()) True) -; + (= (write-list $List) + (flatten $List $FList) + (write-list1 $FList)) - (= - (write-list1 (Cons $H $T)) - ( (write $H) (write-list1 $T))) -; + (= (write_list1 ()) True) + (= (write-list1 (Cons $H $T)) + (write $H) + (write-list1 $T)) - (= - (quit) + (= (quit) (abort)) -; - diff --git a/index/main.metta b/index/main.metta index c4ddfc5..62a7fb6 100644 --- a/index/main.metta +++ b/index/main.metta @@ -1,64 +1,27 @@ +; (convert_to_metta_file main $_154800 index/main.pl index/main.metta) !(unknown $_ fail) -; - !(no-style-check all) -; - !(compile (library basics)) -; - !(compile (library lists)) -; - !(compile (library sets)) -; - !(compile (library not)) -; - ; -; - +; :-compile(library(strings)). !(dynamic (/ switched-on 1)) -; - !(dynamic (/ level-set 2)) -; - - - (= - (switched_on cwa) True) -; - (= - (switched_on eval) True) -; + (= (switched_on cwa) True) + (= (switched_on eval) True) + (= (switched_on debug) True) - (= - (switched_on debug) True) -; - - - - (= - (level_set acc - (+ 0.8)) True) -; - - (= - (level_set conf - (+ 2)) True) -; - - (= - (level_set split - (/ 0.5 0.1)) True) -; + (= (level_set acc (+ 0.8)) True) + (= (level_set conf (+ 2)) True) + (= (level_set split (/ 0.5 0.1)) True) !((compile utils) @@ -68,21 +31,13 @@ (compile object) (compile sort) (compile decomp)) -; - +; /* modules */ !((compile inter) (compile commands)) -; - - (= - (run) + (= (run) (commands Nil Nil Nil)) -; - !(run *) -; - diff --git a/index/object.metta b/index/object.metta index 1f83426..e00c53e 100644 --- a/index/object.metta +++ b/index/object.metta @@ -1,89 +1,48 @@ +; (convert_to_metta_file object $_215068 index/object.pl index/object.metta) - (= - (diff $Tuple1 $Tuple2 $Diff) + (= (diff $Tuple1 $Tuple2 $Diff) (diff $Tuple1 $Tuple2 $Rel $Equal $Diff)) -; - - - (= - (diff $Tuple1 $Tuple2 $Rel $Equal $Diff) - ( (=.. $Tuple1 - (Cons $Rel $Values1)) - (=.. $Tuple2 - (Cons $Rel $Values2)) - (rel $Rel $AttrList) - (diff1 $Values1 $Values2 $AttrList $Equal $Diff))) -; - - - - (= - (diff1 () () () () ()) True) -; - ; -; - - (= - (diff1 - (Cons $V $Values1) - (Cons $V $Values2) - (Cons $A $AttrList) - (Cons $A $Equal) $Diff) +; /* object level <--> meta level */ +; ; old diff + + (= (diff $Tuple1 $Tuple2 $Rel $Equal $Diff) + (=.. $Tuple1 + (Cons $Rel $Values1)) + (=.. $Tuple2 + (Cons $Rel $Values2)) + (rel $Rel $AttrList) (diff1 $Values1 $Values2 $AttrList $Equal $Diff)) -; - - (= - (diff1 - (Cons $V1 $Values1) - (Cons $V2 $Values2) - (Cons $A $AttrList) $Equal - (Cons $A $Diff)) - ( (\= $V1 $V2) (diff1 $Values1 $Values2 $AttrList $Equal $Diff))) -; - +; ; new diff (24-2-93) - (= - (values $_ () () $_) True) -; - - (= - (values $Rel - (Cons $Attr $AttrList) - (Cons $Value $ValueList) $Tuple) - ( (value $Rel $Attr $Value $Tuple) (values $Rel $AttrList $ValueList $Tuple))) -; - + (= (diff1 () () () () ()) True) ; +; new diff1 (24-2-93) + (= (diff1 (Cons $V $Values1) (Cons $V $Values2) (Cons $A $AttrList) (Cons $A $Equal) $Diff) + (diff1 $Values1 $Values2 $AttrList $Equal $Diff)) + (= (diff1 (Cons $V1 $Values1) (Cons $V2 $Values2) (Cons $A $AttrList) $Equal (Cons $A $Diff)) + (\= $V1 $V2) + (diff1 $Values1 $Values2 $AttrList $Equal $Diff)) - (= - (value $Rel $Attr $Value $Tuple) - ( (rel $Rel $AttrList) - (al2vl $Attr $AttrList $Value $ValueList) - (=.. $Tuple - (Cons $Rel $ValueList)))) -; + (= (values $_ () () $_) True) + (= (values $Rel (Cons $Attr $AttrList) (Cons $Value $ValueList) $Tuple) + (value $Rel $Attr $Value $Tuple) + (values $Rel $AttrList $ValueList $Tuple)) + (= (value $Rel $Attr $Value $Tuple) + (rel $Rel $AttrList) + (al2vl $Attr $AttrList $Value $ValueList) + (=.. $Tuple + (Cons $Rel $ValueList))) - (= - (al2vl $_ () $_ ()) True) -; - (= - (al2vl $Attr - (Cons $Attr $AttrList) $Value - (Cons $Value $ValueList)) + (= (al2vl $_ () $_ ()) True) + (= (al2vl $Attr (Cons $Attr $AttrList) $Value (Cons $Value $ValueList)) + (al2vl $Attr $AttrList $Value $ValueList)) + (= (al2vl $Attr (Cons $A $AttrList) $Value (Cons $V $ValueList)) + (or + (\= $Attr $A) + (\= $Value $V)) (al2vl $Attr $AttrList $Value $ValueList)) -; - - (= - (al2vl $Attr - (Cons $A $AttrList) $Value - (Cons $V $ValueList)) - ( (or - (\= $Attr $A) - (\= $Value $V)) (al2vl $Attr $AttrList $Value $ValueList))) -; - diff --git a/index/sort.metta b/index/sort.metta index fe4724b..f06d449 100644 --- a/index/sort.metta +++ b/index/sort.metta @@ -1,123 +1,82 @@ +; (convert_to_metta_file sort $_292974 index/sort.pl index/sort.metta) - (= - (my-sort $Rel $SortAttrs $Tuples $Sorted) - ( (rel $Rel $Attrs) - (listdiff $Attrs $SortAttrs $RestAttrs) - (append $SortAttrs $RestAttrs $NewAttrs) - (reorder $Tuples $NewAttrs $NewTuples) - (setof0 $T - (member $T $NewTuples) $TmpSorted) - (reorder $TmpSorted $Attrs $Sorted))) -; + (= (my-sort $Rel $SortAttrs $Tuples $Sorted) + (rel $Rel $Attrs) + (listdiff $Attrs $SortAttrs $RestAttrs) + (append $SortAttrs $RestAttrs $NewAttrs) + (reorder $Tuples $NewAttrs $NewTuples) + (setof0 $T + (member $T $NewTuples) $TmpSorted) + (reorder $TmpSorted $Attrs $Sorted)) +; /* text of window: sort */ +; ; quick & dirty + (= (reorder () $Attrs ()) True) + (= (reorder (Cons $T $Ts) $Attrs (Cons $NewT $NewTs)) + (values $Rel $Attrs $Values $T) + (=.. $NewT + (Cons $Rel $Values)) + (reorder $Ts $Attrs $NewTs)) - (= - (reorder () $Attrs ()) True) -; - (= - (reorder - (Cons $T $Ts) $Attrs - (Cons $NewT $NewTs)) - ( (values $Rel $Attrs $Values $T) - (=.. $NewT - (Cons $Rel $Values)) - (reorder $Ts $Attrs $NewTs))) -; - - - - (= - (splitsort $Ts $Dep $SortedTs) + (= (splitsort $Ts $Dep $SortedTs) (splitsort $Ts $Dep $SortedTs 0 $N 0 $M)) -; - - (= - (splitsort $Ts $Dep $SortedTs - (, $N $M)) + (= (splitsort $Ts $Dep $SortedTs (, $N $M)) (splitsort $Ts $Dep $SortedTs 0 $N 0 $M)) -; - - - (= - (splitsort () $Dep () $N $N $M $M) True) -; - (= - (splitsort - (Cons $Tuple $Tuples) $Dep - (Cons $Equals $SortedUnEquals) $N0 $N $M0 $M) - ( (partition $Tuples $Tuple $Dep $Equals $UnEquals $M0 $M1) - (is $N1 - (+ $N0 1)) - (set-det) - (splitsort $UnEquals $Dep $SortedUnEquals $N1 $N $M1 $M))) -; + (= (splitsort () $Dep () $N $N $M $M) True) + (= (splitsort (Cons $Tuple $Tuples) $Dep (Cons $Equals $SortedUnEquals) $N0 $N $M0 $M) + (partition $Tuples $Tuple $Dep $Equals $UnEquals $M0 $M1) + (is $N1 + (+ $N0 1)) + (set-det) + (splitsort $UnEquals $Dep $SortedUnEquals $N1 $N $M1 $M)) - - (= - (partition Nil $Tuple $Dep - (:: $Tuple) Nil $M0 $M) + (= (partition Nil $Tuple $Dep (:: $Tuple) Nil $M0 $M) (is $M (+ $M0 1))) -; - - (= - (partition - (Cons $T $Ts) $Tuple $Dep $Es $UnEs $M0 $M) - ( (horn $Dep - (= $Head - ($Tuple $Tuple2))) - (det-if-then-else - (= $Tuple2 $T) + (= (partition (Cons $T $Ts) $Tuple $Dep $Es $UnEs $M0 $M) + (horn $Dep + (= $Head + ($Tuple $Tuple2))) + (det-if-then-else + (= $Tuple2 $T) + (, + (= $Es + (Cons $T $Es1)) + (= $UnEs $UnEs1) + (is $M1 + (+ $M0 1))) + (det-if-then otherwise (, - (= $Es - (Cons $T $Es1)) - (= $UnEs $UnEs1) - (is $M1 - (+ $M0 1))) - (det-if-then otherwise - (, - (= $Es $Es1) - (= $UnEs - (Cons $T $UnEs1)) - (= $M1 $M0)))) - (set-det) - (partition $Ts $Tuple $Dep $Es1 $UnEs1 $M1 $M))) -; - + (= $Es $Es1) + (= $UnEs + (Cons $T $UnEs1)) + (= $M1 $M0)))) + (set-det) + (partition $Ts $Tuple $Dep $Es1 $UnEs1 $M1 $M)) - (= - (joinsort $Parts $Dep $NotContr $Contr) + (= (joinsort $Parts $Dep $NotContr $Contr) (joinsort $Parts $Dep Nil $NotContr Nil $Contr)) -; - - (= - (joinsort () $Dep $NotContr $NotContr $Contr $Contr) True) -; - - (= - (joinsort - (Cons $Part $Parts) $Dep $NC0 $NC $C0 $C) - ( (contr $Part Nil $Dep $Tuples $Answer) - (det-if-then-else - (= $Answer no) + (= (joinsort () $Dep $NotContr $NotContr $Contr $Contr) True) + (= (joinsort (Cons $Part $Parts) $Dep $NC0 $NC $C0 $C) + (contr $Part Nil $Dep $Tuples $Answer) + (det-if-then-else + (= $Answer no) + (, + (append $NC0 $Part $NC1) + (= $C1 $C0)) + (det-if-then otherwise (, - (append $NC0 $Part $NC1) - (= $C1 $C0)) - (det-if-then otherwise - (, - (= $NC1 $NC0) - (divide1 $Part Nil $Dep $DPart) - (= $C1 - (Cons $DPart $C0))))) - (set-det) - (joinsort $Parts $Dep $NC1 $NC $C1 $C))) -; - + (= $NC1 $NC0) + (divide1 $Part Nil $Dep $DPart) + (= $C1 + (Cons $DPart $C0))))) + (set-det) + (joinsort $Parts $Dep $NC1 $NC $C1 $C)) diff --git a/index/train.metta b/index/train.metta index ccbbe2d..fa05324 100644 --- a/index/train.metta +++ b/index/train.metta @@ -1,193 +1,103 @@ +; (convert_to_metta_file train $_386202 index/train.pl index/train.metta) !(dynamic (/ rel 2)) -; - !(dynamic (/ pos-tuple 1)) -; - !(dynamic (/ neg-tuple 1)) -; - - (= - (rel train - (direction hour minutes stop1)) True) -; - + (= (rel train (direction hour minutes stop1)) True) ; -; - +; pos_tuple(train(utrecht,8,8,den-bosch)). ; -; - +; pos_tuple(train(tilburg,8,10,tilburg)). ; -; - +; pos_tuple(train(maastricht,8,10,weert)). ; -; - +; pos_tuple(train(utrecht,8,13,eindhoven-bkln)). ; -; - +; pos_tuple(train(tilburg,8,17,eindhoven-bkln)). ; -; - +; pos_tuple(train(utrecht,8,25,den-bosch)). ; -; - +; pos_tuple(train(utrecht,8,31,utrecht)). ; -; - +; pos_tuple(train(utrecht,8,43,eindhoven-bkln)). ; -; - +; pos_tuple(train(tilburg,8,47,eindhoven-bkln)). ; -; - +; pos_tuple(train(utrecht,9,8,den-bosch)). ; -; - +; pos_tuple(train(tilburg,9,10,tilburg)). ; -; - +; pos_tuple(train(maastricht,9,10,weert)). ; -; - +; pos_tuple(train(utrecht,9,13,eindhoven-bkln)). ; -; - +; pos_tuple(train(tilburg,9,17,eindhoven-bkln)). ; -; - +; pos_tuple(train(utrecht,9,25,den-bosch)). ; -; - +; pos_tuple(train(utrecht,9,43,eindhoven-bkln)). ; -; +; pos_tuple(train(tilburg,9,47,eindhoven-bkln)). - - (= - (pos-tuple (train $Direction $Hour $Minutes $Stop1)) + (= (pos-tuple (train $Direction $Hour $Minutes $Stop1)) (normaltrain $Direction $Hour $Minutes $Stop1)) -; - - (= - (pos-tuple (train $Direction $Hour $Minutes $Stop1)) + (= (pos-tuple (train $Direction $Hour $Minutes $Stop1)) (specialtrain $Direction $Hour $Minutes $Stop1)) -; + (= (normaltrain $Direction $Hour $Minutes $Stop1) + (hour $Hour) + (fasttrain $Direction $Minutes $Stop1)) + (= (normaltrain $Direction $Hour $Minutes $Stop1) + (hour $Hour) + (slowtrain $Direction $Minutes $Stop1)) - (= - (normaltrain $Direction $Hour $Minutes $Stop1) - ( (hour $Hour) (fasttrain $Direction $Minutes $Stop1))) -; - (= - (normaltrain $Direction $Hour $Minutes $Stop1) - ( (hour $Hour) (slowtrain $Direction $Minutes $Stop1))) -; + (= (fasttrain $Direction $Minutes $Stop1) + (fasttrain $Direction $Minutes) + (fasttrain-stop1 $Direction $Stop1)) + (= (slowtrain $Direction $Minutes $Stop1) + (slowtrain $Direction $Minutes) + (slowtrain-stop1 $Direction $Stop1)) + (= (slowtrain $Direction $Minutes $Stop1) + (slowtrain $Direction $Minutes1) + (is $Minutes + (+ $Minutes1 30)) + (slowtrain-stop1 $Direction $Stop1)) - (= - (fasttrain $Direction $Minutes $Stop1) - ( (fasttrain $Direction $Minutes) (fasttrain-stop1 $Direction $Stop1))) -; + (= (fasttrain utrecht 8) True) + (= (fasttrain tilburg 10) True) + (= (fasttrain maastricht 10) True) + (= (fasttrain utrecht 25) True) - (= - (slowtrain $Direction $Minutes $Stop1) - ( (slowtrain $Direction $Minutes) (slowtrain-stop1 $Direction $Stop1))) -; + (= (fasttrain_stop1 utrecht (- den bosch)) True) + (= (fasttrain_stop1 tilburg tilburg) True) + (= (fasttrain_stop1 maastricht weert) True) - (= - (slowtrain $Direction $Minutes $Stop1) - ( (slowtrain $Direction $Minutes1) - (is $Minutes - (+ $Minutes1 30)) - (slowtrain-stop1 $Direction $Stop1))) -; + (= (slowtrain utrecht 13) True) + (= (slowtrain tilburg 17) True) - (= - (fasttrain utrecht 8) True) -; + (= (slowtrain_stop1 utrecht (- eindhoven bkln)) True) + (= (slowtrain_stop1 tilburg (- eindhoven bkln)) True) - (= - (fasttrain tilburg 10) True) -; - (= - (fasttrain maastricht 10) True) -; + (= (specialtrain utrecht 8 31 utrecht) True) - (= - (fasttrain utrecht 25) True) -; - - - - (= - (fasttrain_stop1 utrecht - (- den bosch)) True) -; - - (= - (fasttrain_stop1 tilburg tilburg) True) -; - - (= - (fasttrain_stop1 maastricht weert) True) -; - - - - (= - (slowtrain utrecht 13) True) -; - - (= - (slowtrain tilburg 17) True) -; - - - - (= - (slowtrain_stop1 utrecht - (- eindhoven bkln)) True) -; - - (= - (slowtrain_stop1 tilburg - (- eindhoven bkln)) True) -; - - - - (= - (specialtrain utrecht 8 31 utrecht) True) -; - - - - (= - (hour 8) True) -; - - (= - (hour 9) True) -; + (= (hour 8) True) + (= (hour 9) True) ; -; - +; hour(10). ; -; - +; hour(11). diff --git a/index/utils.metta b/index/utils.metta index 3511cad..fd5cdc3 100644 --- a/index/utils.metta +++ b/index/utils.metta @@ -1,129 +1,69 @@ +; (convert_to_metta_file utils $_467354 index/utils.pl index/utils.metta) - (= - (listdiff $L () $L) True) -; + (= (listdiff $L () $L) True) +; /* utilities */ + (= (listdiff $L (Cons $H $T) $V) + (remove $H $L $L1) + (listdiff $L1 $T $V)) - (= - (listdiff $L - (Cons $H $T) $V) - ( (remove $H $L $L1) (listdiff $L1 $T $V))) -; - - - (= - (remove $_ () ()) True) -; - - (= - (remove $H - (Cons $H $T) $L) + (= (remove $_ () ()) True) + (= (remove $H (Cons $H $T) $L) (remove $H $T $L)) -; + (= (remove $X (Cons $H $T) (Cons $H $L)) + (remove $X $T $L) + (\= $X $H)) - (= - (remove $X - (Cons $H $T) - (Cons $H $L)) - ( (remove $X $T $L) (\= $X $H))) -; - - - (= - (select-two - (Cons $H $T) $H $Y) + (= (select-two (Cons $H $T) $H $Y) (member $Y $T)) -; - - (= - (select-two - (Cons $H $T) $X $Y) + (= (select-two (Cons $H $T) $X $Y) (select-two $T $X $Y)) -; - - - - (= - (forall $Goal $Condition) - ( (bagof0 $Condition $Goal $List) (forall1 $List))) -; - - - - (= - (forall1 ()) True) -; - (= - (forall1 (Cons $H $T)) - ( (call $H) (forall1 $T))) -; + (= (forall $Goal $Condition) + (bagof0 $Condition $Goal $List) + (forall1 $List)) - (= - (bagof0 $T $G $L) - ( (bagof $T $G $L) (set-det))) -; + (= (forall1 ()) True) + (= (forall1 (Cons $H $T)) + (call $H) + (forall1 $T)) - (= - (bagof0 $T $G ()) True) -; - - - - (= - (setof0 $T $G $L) - ( (setof $T $G $L) (set-det))) -; - - (= - (setof0 $T $G ()) True) -; + (= (bagof0 $T $G $L) + (bagof $T $G $L) + (set-det)) + (= (bagof0 $T $G ()) True) -; (error -; (syntax_error operator_expected) -; (file index/utils.pl 37 4 521)) + (= (setof0 $T $G $L) + (setof $T $G $L) + (set-det)) + (= (setof0 $T $G ()) True) +; (error +; (syntax_error operator_expected) +; (file index/utils.pl 37 4 521)) - (= - (add-if $X $Ys $Ys) - ( (member $X $Ys) (set-det))) -; - (= - (add_if $X $Ys - (Cons $X $Ys)) True) -; + (= (add-if $X $Ys $Ys) + (member $X $Ys) + (set-det)) + (= (add_if $X $Ys (Cons $X $Ys)) True) - (= - (flatten $Xs $Ys) + (= (flatten $Xs $Ys) (flatten-dl $Xs Nil $Ys)) -; - - (= - (flatten-dl Nil $Ys $Ys) + (= (flatten-dl Nil $Ys $Ys) (set-det)) -; - - (= - (flatten-dl - (Cons $X $Xs) $Ys0 $Ys) - ( (set-det) - (flatten-dl $Xs $Ys0 $Ys1) - (flatten-dl $X $Ys1 $Ys))) -; - - (= - (flatten_dl $X $Xs - (Cons $X $Xs)) True) -; - + (= (flatten-dl (Cons $X $Xs) $Ys0 $Ys) + (set-det) + (flatten-dl $Xs $Ys0 $Ys1) + (flatten-dl $X $Ys1 $Ys)) + (= (flatten_dl $X $Xs (Cons $X $Xs)) True) diff --git a/invers/invers.metta b/invers/invers.metta index cf3f784..920e90a 100644 --- a/invers/invers.metta +++ b/invers/invers.metta @@ -1,356 +1,333 @@ +; (convert_to_metta_file invers $_141654 invers/invers.pl invers/invers.metta) !(dynamic (/ flat 1)) -; - +; /******************************************************************/ +; /* INVERS.PL Last Modification: Fri Jan 14 19:24:41 1994 */ +; /* Two versions of the two main operators for inverse resolution. */ +; /******************************************************************/ +; ; ; Copyright (c) 1989,1990 Thomas Hoppe ; ; This program is free software; you can redistribute it and/or ; modify it under the terms of the GNU General Public License ; Version 1 as published by the Free Software Foundation. ; ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; ; You should have received a copy of the GNU General Public ; License along with this program; if not, write to the Free ; Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, ; USA. ; +; /******************************************************************/ +; /* impl. by : Thomas Hoppe */ +; /* Mommsenstr. 50 */ +; /* D-10629 Berlin */ +; /* F.R.G. */ +; /* E-Mail: hoppet@cs.tu-berlin.de */ +; /* 1989/90 */ +; /* */ +; /* reference : Muggleton, S., Buntine, W., Machine Invention */ +; /* of First-order Predicates by Inverting Resolu- */ +; /* tion, Proceedings of the International Workshop */ +; /* on Machine Learning, Ann Arbor, Morgan Kaufmann */ +; /* 1988. */ +; /* */ +; /* Rouveirol, C., Puget, J.-F., A Simple Solution */ +; /* For Inverting Resolution, in: K. Morik, Procee- */ +; /* dings of the 4th European Working Session on */ +; /* Machine Learning, Montpellier, Pitman Publishing*/ +; /* 1989. */ +; /* */ +; /* call : see invers_1.pro */ +; /* */ +; /* of First-order Predicates by Inverting Resolu- */ +; /* tion, Proceedings of the International Workshop */ +; /* on Machine Learning, Ann Arbor, Morgan Kaufmann */ +; /* 1988. */ +; /* */ +; /* Rouveirol, C., Puget, J.-F., A Simple Solution */ +; /* For Inverting Resolution, in: K. Morik, Procee- */ +; /* dings of the 4th European Working Session on */ +; /* Machine Learning, Montpellier, Pitman Publishing*/ +; /* 1989. */ +; /* */ +; /* call : see invers_1.pro */ +; /* */ +; /******************************************************************/ +; /* This file contains two versions for the main operators of */ +; /* inverse resolution, absorption and intra-construction, as */ +; /* they are described by Stephen Muggleton and Wray Buntine. */ +; /* */ +; /* The versions numbered 1 are working on definite Horn-clauses */ +; /* without function symbols. The versions numbered 2 are working */ +; /* on definite Horn-clauses with function symbols. The basic */ +; /* difference is made up by the predicates 'flatten' and */ +; /* 'unflatten', and is described in Rouveirol & Puget. */ +; /* */ +; /* The main predicates 'absorption1', 'absorption2', 'intra- */ +; /* construction1' and 'intra-construction2' use some predicates */ +; /* importet from the library entry 'logic', which should be */ +; /* consulted befor runing the examples. */ +; /* */ +; /* Instead of using a generalisation algorithm based on the */ +; /* 'dropping condition rule' as described by Rouveirol & Puget */ +; /* I have developed a 'fast' generalisation routine, which in the*/ +; /* end gives the same results as 'dropping condition'. Its nice */ +; /* advantage is that it delivers the first generalisation in */ +; /* linear time, although this is an exponential problem. Of */ +; /* course in general, exponentiallity cannot be avoided. */ +; /* But through delaying it, we can save some time in easy cases. */ +; /******************************************************************/ +; ; TH Tue Feb 23 12:38:06 1993 ; - added missing definition of element_v ; - introduced dynamic/2 (below) for making system dependency ; more obvious ; TH Fri Mar 5 11:40:21 1993 ; - removed some findall/3 calls, since it's not built-in in ; C-MeTTa, introduced instead findbag, which is bagof with ; reversed list order ; - numbervars is not built-in in C-MeTTa, thus I included ; instvars, although the output is now ugly, it works ; TH Sun May 30 14:20:37 1993 ; - made some minor modifications +; /******************************************************************/ +; /* Some SWI-, C-, M- and YAP-MeTTa dependent declarations. */ +; /******************************************************************/ !(dynamic (/ internal 1)) -; - ; -; - +; Dependent on your MeTTa dialect (whether it requires dynamic ; -; - +; declarations or not, you may need to substitute the Body of the ; -; - +; following clause with `true'. - (= - (dynamic $N $A) + (= (dynamic $N $A) (dynamic (/ $N $A))) -; - +; ; true. ; -; - +; C-MeTTa doesn't know numbervars (quite strange, isn't it?) ; -; - +; Thus it needs to be emulated (see comment at the end) ! ; -; - +; numbervars(T,Min,Max) :- ; -; - +; instvars(T,Min,Max). ; -; - +; SWI-MeTTa nows only of numbervars/4, but that's no problem with ; -; - +; the following clause - (= - (numbervars $T $Min $Max) + (= (numbervars $T $Min $Max) (numbervars $T %VAR $Min $Max)) -; - !(:: (logic *)) -; - - (= - (absorption1 $Clause $Resolvent $InducedClause) - ( (split $Clause $ClauseHead $ClauseBody) - (split $Resolvent $ResolventHead $ResolventBody) - (step-1 $ClauseBody $ResolventBody $RestClauseBody $Subst_2) - (subst - (:: $ClauseHead) $Subst_2 - (:: $NewClauseHead)) - (step-2 $NewClauseHead $RestClauseBody $IntermediaryBody) - (join $ResolventHead $IntermediaryBody $IntermediaryClause) - (copy $IntermediaryClause $InducedClause))) -; - + (= (absorption1 $Clause $Resolvent $InducedClause) + (split $Clause $ClauseHead $ClauseBody) + (split $Resolvent $ResolventHead $ResolventBody) + (step-1 $ClauseBody $ResolventBody $RestClauseBody $Subst_2) + (subst + (:: $ClauseHead) $Subst_2 + (:: $NewClauseHead)) + (step-2 $NewClauseHead $RestClauseBody $IntermediaryBody) + (join $ResolventHead $IntermediaryBody $IntermediaryClause) + (copy $IntermediaryClause $InducedClause)) +; /******************************************************************/ +; /* */ +; /* call : absorption1(+Clause,+Resolvent,-InducedClause) */ +; /* */ +; /* arguments : Clause = definite clause */ +; /* Resolvent = definite clause */ +; /* InducedClause = induced definite clause */ +; /* */ +; /******************************************************************/ +; /* works on definite clauses without function-symbols */ +; /******************************************************************/ - (= - (split - (= $Head True) $Head Nil) + (= (split (= $Head True) $Head Nil) (set-det)) -; - - (= - (split - (= $Head $Body) $Head $BodyList) - ( (split $Body $_ $BodyList) (set-det))) -; - - (= - (split - (, $Prem $Prems) $_ - (Cons $Prem $RestPrems)) - ( (split $Prems $_ $RestPrems) (set-det))) -; + (= (split (= $Head $Body) $Head $BodyList) + (split $Body $_ $BodyList) + (set-det)) + (= (split (, $Prem $Prems) $_ (Cons $Prem $RestPrems)) + (split $Prems $_ $RestPrems) + (set-det)) + (= (split $Prem $_ ($Prem)) True) - (= - (split $Prem $_ - ($Prem)) True) -; + (= (join $Head $PremList (= $Head $Prems)) + (join $PremList $Prems)) + (= (join (:: $Prem) $Prem) + (set-det)) + (= (join (Cons $Prem $Prems) (, $Prem $RestPrems)) + (join $Prems $RestPrems)) - (= - (join $Head $PremList - (= $Head $Prems)) - (join $PremList $Prems)) -; + (= (step-1 $ClauseBody $ResolventBody $ResolventRest $Subst) + (choose-common-parts $ResolventBody $ClauseBody $Beta1 $Beta2) + (not (not (subset $Beta1 $ClauseBody))) + (substitution $ClauseBody $Beta1 $Subst) + (subtract-v $Beta1 $ResolventBody $ResolventRest)) - (= - (join - (:: $Prem) $Prem) - (set-det)) -; - (= - (join - (Cons $Prem $Prems) - (, $Prem $RestPrems)) - (join $Prems $RestPrems)) -; - - - - (= - (step-1 $ClauseBody $ResolventBody $ResolventRest $Subst) - ( (choose-common-parts $ResolventBody $ClauseBody $Beta1 $Beta2) - (not (not (subset $Beta1 $ClauseBody))) - (substitution $ClauseBody $Beta1 $Subst) - (subtract-v $Beta1 $ResolventBody $ResolventRest))) -; - - - - (= - (choose-common-parts $List1 $List2 $Sublist1 $Sublist2) - ( (findbag $MGT - (, - (member $Pred $List1) - (functor $Pred $N $A) - (functor $MGT $N $A)) $MGTS1) - (findbag $MGT - (, - (member $Pred $List2) - (functor $Pred $N $A) - (functor $MGT $N $A)) $MGTS2) - (set-det) - (dropping-condition-intersection $MGTS1 $MGTS2 $MGTS) - (copy $MGTS $Sublist1) - (copy $MGTS $Sublist2) - (subset $Sublist1 $List1) - (subset $Sublist2 $List2))) -; - - - - (= - (dropping_condition_intersection () $_ ()) True) -; - - (= - (dropping-condition-intersection - (Cons $X $R) $Y - (Cons $X $Z)) - ( (member $X1 $Y) - (not (not (= $X $X1))) - (set-det) - (dropping-condition-delete $X $Y $Y1) - (dropping-condition-intersection $R $Y1 $Z))) -; - - (= - (dropping-condition-intersection - (Cons $X $R) $Y $Z) + (= (choose-common-parts $List1 $List2 $Sublist1 $Sublist2) + (findbag $MGT + (, + (member $Pred $List1) + (functor $Pred $N $A) + (functor $MGT $N $A)) $MGTS1) + (findbag $MGT + (, + (member $Pred $List2) + (functor $Pred $N $A) + (functor $MGT $N $A)) $MGTS2) + (set-det) + (dropping-condition-intersection $MGTS1 $MGTS2 $MGTS) + (copy $MGTS $Sublist1) + (copy $MGTS $Sublist2) + (subset $Sublist1 $List1) + (subset $Sublist2 $List2)) +; /********************************************************************/ +; /* Determination of the most special subsets of two non-ground */ +; /* predicate sets, on backtracking it delivers the next more general*/ +; /* subsets. The nice property, of this routine is, that the first */ +; /* common_subpart is found in linear time, although the determina- */ +; /* tion of all common_subparts needs exponential time. */ +; /********************************************************************/ + + + (= (dropping_condition_intersection () $_ ()) True) + (= (dropping-condition-intersection (Cons $X $R) $Y (Cons $X $Z)) + (member $X1 $Y) + (not (not (= $X $X1))) + (set-det) + (dropping-condition-delete $X $Y $Y1) + (dropping-condition-intersection $R $Y1 $Z)) + (= (dropping-condition-intersection (Cons $X $R) $Y $Z) (dropping-condition-intersection $R $Y $Z)) -; - - (= - (dropping-condition-delete $X - (Cons $Y $Ys) $Ys) - ( (not (not (= $X $Y))) (set-det))) -; - - (= - (dropping-condition-delete $X - (Cons $Y $Ys) - (Cons $Y $Zs)) - (dropping-condition-delete $X $Ys $Zs)) -; - + (= (dropping-condition-delete $X (Cons $Y $Ys) $Ys) + (not (not (= $X $Y))) + (set-det)) + (= (dropping-condition-delete $X (Cons $Y $Ys) (Cons $Y $Zs)) + (dropping-condition-delete $X $Ys $Zs)) - (= - (step-2 $ClauseHead $RestClauseBody $IntermediaryBody) + (= (step-2 $ClauseHead $RestClauseBody $IntermediaryBody) (union-v (:: $ClauseHead) $RestClauseBody $IntermediaryBody)) -; - +; ; Union_v helps us to avoid some redundant premisses - (= - (absorption2 $Clause $Resolvent $InducedClause) - ( (flatten $Clause $ClauseHead $ClauseBody) - (flatten $Resolvent $ResolventHead $ResolventBody) - (step-1 $ClauseBody $ResolventBody $RestClauseBody $Subst_2) - (subst - (:: $ClauseHead) $Subst_2 - (:: $NewClauseHead)) - (step-2 $NewClauseHead $RestClauseBody $IntermediaryBody) - (unflatten - (:: $ResolventHead) $IntermediaryBody $IntermediaryClause) - (copy $IntermediaryClause $InducedClause))) -; - - - - (= - (flatten - (= $Conclusion $Conjunction) $NewConclusion $NewPremisses) - ( (flatten $Conclusion - (:: $NewConclusion) $FunctionPrems1 $Dictionary) - (flatten $Conjunction $Prems $FunctionPrems2 $Dictionary) - (union-v $FunctionPrems1 $FunctionPrems2 $FunctionPrems) - (union-v $FunctionPrems $Prems $NewPremisses) - (set-det))) -; - - - (= - (flatten - (, $Prem $Prems) $NewPremisses $FunctionPrems $Dictionary) - ( (flatten $Prem $NewPrem $FunctionPrems1 $Dictionary) - (flatten $Prems $NewPrems $FunctionPrems2 $Dictionary) - (union-v $NewPrem $NewPrems $NewPremisses) - (union-v $FunctionPrems1 $FunctionPrems2 $FunctionPrems) - (set-det))) -; - - - (= - (flatten () () () $_) True) -; - - (= - (flatten - (Cons $Const $Terms) - (Cons $Var $NewVars) $ResultPrems $Dictionary) - ( (atomic $Const) - (lookup $Const $Dictionary $Var) - (conc $Const -p $NewName) - (flat-assertion $NewName $Const) - (=.. $Pred - (:: $NewName $Var)) - (flatten $Terms $NewVars $NewPrems $Dictionary) - (set-det) - (union-v - (:: $Pred) $NewPrems $ResultPrems))) -; - - (= - (flatten - (Cons $Term $Terms) - (Cons $Term $NewVars) $NewPrems $Dictionary) - ( (var $Term) - (set-det) - (flatten $Terms $NewVars $NewPrems $Dictionary))) -; - - (= - (flatten - (Cons $Term $Terms) - (Cons $NewVar $NewVars) $NewPrems $Dictionary) - ( (=.. $Term - (Cons $N $Args)) - (conc $N -p $NN) - (flatten $Args $NewTerms $Prems $Dictionary) - (append $NewTerms - (:: $NewVar) $NewArgs) - (=.. $NewTerm - (Cons $NN $NewArgs)) - (flat-assertion $NN $NewTerms $N $NewTerms) - (flatten $Terms $NewVars $NP $Dictionary) - (set-det) - (union-v - (:: $NewTerm) $NP $ERG) - (union-v $Prems $ERG $NewPrems))) -; - - - (= - (flatten True Nil Nil $_) + (= (absorption2 $Clause $Resolvent $InducedClause) + (flatten $Clause $ClauseHead $ClauseBody) + (flatten $Resolvent $ResolventHead $ResolventBody) + (step-1 $ClauseBody $ResolventBody $RestClauseBody $Subst_2) + (subst + (:: $ClauseHead) $Subst_2 + (:: $NewClauseHead)) + (step-2 $NewClauseHead $RestClauseBody $IntermediaryBody) + (unflatten + (:: $ResolventHead) $IntermediaryBody $IntermediaryClause) + (copy $IntermediaryClause $InducedClause)) +; /******************************************************************/ +; /* */ +; /* call : absorption2(+Clause,+Resolvent,-InducedClause) */ +; /* */ +; /* arguments : Clause = definite clause */ +; /* Resolvent = definite clause */ +; /* InducedClause = induced definite clause */ +; /* */ +; /******************************************************************/ +; /* works on definite clauses with function-symbols */ +; /******************************************************************/ + + + (= (flatten (= $Conclusion $Conjunction) $NewConclusion $NewPremisses) + (flatten $Conclusion + (:: $NewConclusion) $FunctionPrems1 $Dictionary) + (flatten $Conjunction $Prems $FunctionPrems2 $Dictionary) + (union-v $FunctionPrems1 $FunctionPrems2 $FunctionPrems) + (union-v $FunctionPrems $Prems $NewPremisses) (set-det)) -; - - (= - (flatten False Nil Nil $_) +; /********************************************************************/ +; /* Representation change procedures for inverse resolution. */ +; /* The basic idea behind these procedures is to re-represent n-ary */ +; /* function symbols by n+1-ary predicate symbols, where the */ +; /* additional argument delivers the value of the function. A */ +; /* discussion of this can be found in Rouveirol & Puget's paper. */ +; /********************************************************************/ + + (= (flatten (, $Prem $Prems) $NewPremisses $FunctionPrems $Dictionary) + (flatten $Prem $NewPrem $FunctionPrems1 $Dictionary) + (flatten $Prems $NewPrems $FunctionPrems2 $Dictionary) + (union-v $NewPrem $NewPrems $NewPremisses) + (union-v $FunctionPrems1 $FunctionPrems2 $FunctionPrems) (set-det)) -; - - (= - (flatten - (not $Pred) - (:: (not $NewPred)) $NewPrems $Dictionary) - ( (set-det) (flatten $Pred (:: $NewPred) $NewPrems $Dictionary))) -; - (= - (flatten $Pred - (:: $Pred) Nil $Dictionary) - ( (atomic $Pred) (set-det))) -; + (= (flatten () () () $_) True) + (= (flatten (Cons $Const $Terms) (Cons $Var $NewVars) $ResultPrems $Dictionary) + (atomic $Const) + (lookup $Const $Dictionary $Var) + (conc $Const -p $NewName) + (flat-assertion $NewName $Const) + (=.. $Pred + (:: $NewName $Var)) + (flatten $Terms $NewVars $NewPrems $Dictionary) + (set-det) + (union-v + (:: $Pred) $NewPrems $ResultPrems)) + (= (flatten (Cons $Term $Terms) (Cons $Term $NewVars) $NewPrems $Dictionary) + (var $Term) + (set-det) + (flatten $Terms $NewVars $NewPrems $Dictionary)) + (= (flatten (Cons $Term $Terms) (Cons $NewVar $NewVars) $NewPrems $Dictionary) + (=.. $Term + (Cons $N $Args)) + (conc $N -p $NN) + (flatten $Args $NewTerms $Prems $Dictionary) + (append $NewTerms + (:: $NewVar) $NewArgs) + (=.. $NewTerm + (Cons $NN $NewArgs)) + (flat-assertion $NN $NewTerms $N $NewTerms) + (flatten $Terms $NewVars $NP $Dictionary) + (set-det) + (union-v + (:: $NewTerm) $NP $ERG) + (union-v $Prems $ERG $NewPrems)) - (= + (= (flatten True Nil Nil $_) + (set-det)) + (= (flatten False Nil Nil $_) + (set-det)) + (= (flatten (not $Pred) (:: (not $NewPred)) $NewPrems $Dictionary) + (set-det) (flatten $Pred - (:: $NewPred) $NewPrems $Dictionary) - ( (set-det) - (=.. $Pred - (Cons $N $Args)) - (flatten $Args $NewArgs $NewPrems $Dictionary) - (=.. $NewPred - (Cons $N $NewArgs)))) -; - + (:: $NewPred) $NewPrems $Dictionary)) + (= (flatten $Pred (:: $Pred) Nil $Dictionary) + (atomic $Pred) + (set-det)) + (= (flatten $Pred (:: $NewPred) $NewPrems $Dictionary) + (set-det) + (=.. $Pred + (Cons $N $Args)) + (flatten $Args $NewArgs $NewPrems $Dictionary) + (=.. $NewPred + (Cons $N $NewArgs))) - (= - (flat-assertion $Name $Term) + (= (flat-assertion $Name $Term) ( (=.. $NewRelation (:: $Name $Term)) (copy $NewRelation $NR) (skolemize (:: $NR) 0 $_) - (get-symbols &self + (== (= - (flat $NR) true)) - (get-symbols &self + (flat $NR) true) + (get-atoms &self)) + (== (= - (flat $NewRelation) true)) + (flat $NewRelation) true) + (get-atoms &self)) (set-det))) -; - - (= - (flat-assertion $Name $Term) + (= (flat-assertion $Name $Term) ( (=.. $NewRelation (:: $Name $Term)) - (add-symbol &self + (add-is-symbol &self (flat $NewRelation)) (set-det))) -; - - (= - (flat-assertion $Name1 $Args $Name2 $Terms) + (= (flat-assertion $Name1 $Args $Name2 $Terms) ( (=.. $OldTerm (Cons $Name2 $Terms)) (append $Args @@ -360,620 +337,476 @@ (copy $NewRelation $NR) (skolemize (:: $NR) 0 $_) - (get-symbols &self + (== (= - (flat $NR) true)) - (get-symbols &self + (flat $NR) true) + (get-atoms &self)) + (== (= - (flat $NewRelation) true)) + (flat $NewRelation) true) + (get-atoms &self)) (set-det))) -; - - (= - (flat-assertion $Name1 $Args $Name2 $Terms) + (= (flat-assertion $Name1 $Args $Name2 $Terms) ( (=.. $OldTerm (Cons $Name2 $Terms)) (append $Args (:: $OldTerm) $NewArgs) (=.. $NewRelation (Cons $Name1 $NewArgs)) - (add-symbol &self + (add-is-symbol &self (flat $NewRelation)))) -; - - (= - (unflatten - (:: $Head) $BodyList - (= $Head $Body)) - ( (unflatten $BodyList $Body) (set-det))) -; - + (= (unflatten (:: $Head) $BodyList (= $Head $Body)) + (unflatten $BodyList $Body) + (set-det)) - (= - (unflatten () true) True) -; - - (= - (unflatten - (:: $Prem) $Prem) - ( (functor $Prem $N $A) - (functor $P $N $A) - (not (get-symbols &self (= (flat $P) true))) - (set-det) - (not (get-symbols &self (= (flat $Prem) true))) - (set-det))) -; - - (= - (unflatten - (Cons $Prem $Prems) - (, $Prem $RestPrems)) - ( (functor $Prem $N $A) - (functor $P $N $A) - (not (get-symbols &self (= (flat $P) true))) - (set-det) - (not (get-symbols &self (= (flat $Prem) true))) - (unflatten $Prems $RestPrems) - (set-det))) -; - - (= - (unflatten - (Cons $Prem $Prems) $RestPrems) - ( (get-symbols &self + (= (unflatten () true) True) + (= (unflatten (:: $Prem) $Prem) + (functor $Prem $N $A) + (functor $P $N $A) + (not (== (= (flat $P) true) (get-atoms &self))) + (set-det) + (not (== (= (flat $Prem) true) (get-atoms &self))) + (set-det)) + (= (unflatten (Cons $Prem $Prems) (, $Prem $RestPrems)) + (functor $Prem $N $A) + (functor $P $N $A) + (not (== (= (flat $P) true) (get-atoms &self))) + (set-det) + (not (== (= (flat $Prem) true) (get-atoms &self))) + (unflatten $Prems $RestPrems) + (set-det)) + (= (unflatten (Cons $Prem $Prems) $RestPrems) + ( (== (= - (flat $Prem) true)) (unflatten $Prems $RestPrems))) -; - + (flat $Prem) true) + (get-atoms &self)) (unflatten $Prems $RestPrems))) - (= - (intra-construction1 $Resolvent1 $Resolvent2 $InducedRules) - ( (split $Resolvent1 $Resolvent1Head $Resolvent1Body) - (split $Resolvent2 $Resolvent2Head $Resolvent2Body) - (step-1 $Resolvent1Head $Resolvent1Body $Resolvent2Head $Resolvent2Body $ClauseHead $Alpha $Resolvent1BodyRest $Resolvent2BodyRest $Subst1 $Subst2) - (step-2 $ClauseHead $Alpha $Resolvent1BodyRest $Subst1 $Resolvent2BodyRest $Subst2 $Vars) - (step-3-1 $ClauseHead $Vars $Alpha $Resolvent1BodyRest $Subst1 $Resolvent2BodyRest $Subst2 $InducedRules))) -; - - - - (= - (step-1 $Resolvent1Head $Resolvent1Body $Resolvent2Head $Resolvent2Body - (:: $ClauseHead) $Alpha $Resolvent1BodyRest $Resolvent2BodyRest $Subst1 $Subst2) - ( (choose-common-parts $Resolvent1Body $Resolvent2Body $AlphaTheta1 $AlphaTheta2) - (length $AlphaTheta1 $X) - (length $AlphaTheta2 $X) - (> $X 0) - (subtract-v $AlphaTheta1 $Resolvent1Body $Resolvent1BodyRest) - (subtract-v $AlphaTheta2 $Resolvent2Body $Resolvent2BodyRest) - (lgg - (:: $Resolvent1Head $AlphaTheta1) - (:: $Resolvent2Head $AlphaTheta2) - (:: $ClauseHead $Alpha)) - (substitution - (:: $ClauseHead $Alpha) - (:: $Resolvent1Head $AlphaTheta1) $Subst1) - (substitution - (:: $ClauseHead $Alpha) - (:: $Resolvent2Head $AlphaTheta2) $Subst2))) -; - - - - (= - (step-2 $ClauseHead $Alpha $Resolvent1BodyRest $Subst1 $Resolvent2BodyRest $Subst2 $Vars) - ( (varlist $Resolvent1BodyRest $RBR1Vars) - (varlist $Resolvent2BodyRest $RBR2Vars) - (varlist $ClauseHead $CHVars) - (varlist $Alpha $AVars) - (inv-subst $RBR1 $Subst1 $RBR1Vars) - (inv-subst $RBR2 $Subst2 $RBR2Vars) - (or - (= $CHVars Nil) - (, - (intersection-v $CHVars $AVars $XI) - (not (== $XI Nil)))) - (union-v $CHVars $AVars $Xs) - (union-v $RBR1 $RBR2 $RBRU) - (intersection-v $RBRU $Xs $Vars) - (set-det))) -; - - - - (= - (step-3-1 - (:: $ClauseHead) $Vars $Alpha $Resolvent1BodyRest $Subst1 $Resolvent2BodyRest $Subst2 - (:: $R1 $R2 $R3)) - ( (gensym $Name P) - (=.. $X - (Cons $Name $Vars)) - (subst - (:: $X) $Subst1 - (:: $X1)) - (subst - (:: $X) $Subst2 - (:: $X2)) - (join $X1 $Resolvent1BodyRest $QR1) - (join $X2 $Resolvent2BodyRest $QR2) - (copy $QR1 $NQR1) - (copy $QR2 $NQR2) - (numbervars $NQR1 0 $_) - (numbervars $NQR2 0 $_) - (nl) - (write ' Predicate invention') - (nl) - (nl) - (tab 3) - (write $NQR1) - (nl) - (tab 3) - (write $NQR2) - (nl) - (nl) - (write ' Has this predicate a meaning (y/n)? ') - (read $Answer) - (nl) - (or - (, - (= $Answer n) - (set-det) - (fail)) - (, - (= $Answer y) - (set-det))) - (write ' How shall I name the predicate ? ') - (read $NewName) - (nl) - (=.. $NP - (Cons $NewName $Vars)) - (subst - (:: $NP) $Subst1 - (:: $NP1)) - (subst - (:: $NP) $Subst2 - (:: $NP2)) - (join $NP1 $Resolvent1BodyRest $R1) - (join $NP2 $Resolvent2BodyRest $R2) - (append - (:: $NP) $Alpha $ClauseBody) - (join $ClauseHead $ClauseBody $R3) - (set-det))) -; - - + (= (intra-construction1 $Resolvent1 $Resolvent2 $InducedRules) + (split $Resolvent1 $Resolvent1Head $Resolvent1Body) + (split $Resolvent2 $Resolvent2Head $Resolvent2Body) + (step-1 $Resolvent1Head $Resolvent1Body $Resolvent2Head $Resolvent2Body $ClauseHead $Alpha $Resolvent1BodyRest $Resolvent2BodyRest $Subst1 $Subst2) + (step-2 $ClauseHead $Alpha $Resolvent1BodyRest $Subst1 $Resolvent2BodyRest $Subst2 $Vars) + (step-3-1 $ClauseHead $Vars $Alpha $Resolvent1BodyRest $Subst1 $Resolvent2BodyRest $Subst2 $InducedRules)) +; /******************************************************************/ +; /* */ +; /* call : intra_construction1(+Resolvent1,+Resolvent2, */ +; /* -InducedRules) */ +; /* */ +; /* arguments : Resolvent1 = definite clause */ +; /* Resolvent2 = definite clause */ +; /* InducedRules = list of three induced definite */ +; /* clauses */ +; /* */ +; /******************************************************************/ +; /* works on definite clauses without function-symbols */ +; /******************************************************************/ + + + (= (step-1 $Resolvent1Head $Resolvent1Body $Resolvent2Head $Resolvent2Body (:: $ClauseHead) $Alpha $Resolvent1BodyRest $Resolvent2BodyRest $Subst1 $Subst2) + (choose-common-parts $Resolvent1Body $Resolvent2Body $AlphaTheta1 $AlphaTheta2) + (length $AlphaTheta1 $X) + (length $AlphaTheta2 $X) + (> $X 0) + (subtract-v $AlphaTheta1 $Resolvent1Body $Resolvent1BodyRest) + (subtract-v $AlphaTheta2 $Resolvent2Body $Resolvent2BodyRest) + (lgg + (:: $Resolvent1Head $AlphaTheta1) + (:: $Resolvent2Head $AlphaTheta2) + (:: $ClauseHead $Alpha)) + (substitution + (:: $ClauseHead $Alpha) + (:: $Resolvent1Head $AlphaTheta1) $Subst1) + (substitution + (:: $ClauseHead $Alpha) + (:: $Resolvent2Head $AlphaTheta2) $Subst2)) +; ; if AlphaTheta is empty we gain nothing, thus +; ; lgg doesn't take the order of literals into account, initially it was ; only designed for terms, that doesn't matter because choose_common_subpart ; ensures a common predicate order through copying the MGT and instantiating ; afterwards. +; ; At least we determine the substitutions theta 1 and theta 2 + + + (= (step-2 $ClauseHead $Alpha $Resolvent1BodyRest $Subst1 $Resolvent2BodyRest $Subst2 $Vars) + (varlist $Resolvent1BodyRest $RBR1Vars) + (varlist $Resolvent2BodyRest $RBR2Vars) + (varlist $ClauseHead $CHVars) + (varlist $Alpha $AVars) + (inv-subst $RBR1 $Subst1 $RBR1Vars) + (inv-subst $RBR2 $Subst2 $RBR2Vars) + (or + (= $CHVars Nil) + (, + (intersection-v $CHVars $AVars $XI) + (not (== $XI Nil)))) + (union-v $CHVars $AVars $Xs) + (union-v $RBR1 $RBR2 $RBRU) + (intersection-v $RBRU $Xs $Vars) + (set-det)) +; ; The head and the generalized body part must have (at least) ; a variable in common +; ; This is different as in the paper of Rouveirol/Puget. If we would ; use their method, we couldn't even obtain their results, but ; with this it works. This error was confirmed by Celine Rouveirol - (= - (intra-construction2 $Resolvent1 $Resolvent2 $InducedClauses) - ( (flatten $Resolvent1 $Resolvent1Head $Resolvent1Body) - (flatten $Resolvent2 $Resolvent2Head $Resolvent2Body) - (step-1 $Resolvent1Head $Resolvent1Body $Resolvent2Head $Resolvent2Body $ClauseHead $Alpha $Resolvent1BodyRest $Resolvent2BodyRest $Subst1 $Subst2) - (step-2 $ClauseHead $Alpha $Resolvent1BodyRest $Subst1 $Resolvent2BodyRest $Subst2 $Vars) - (step-3-2 $ClauseHead $Vars $Alpha $Resolvent1BodyRest $Subst1 $Resolvent2BodyRest $Subst2 $InducedClauses))) -; + (= (step-3-1 (:: $ClauseHead) $Vars $Alpha $Resolvent1BodyRest $Subst1 $Resolvent2BodyRest $Subst2 (:: $R1 $R2 $R3)) + (gensym $Name P) + (=.. $X + (Cons $Name $Vars)) + (subst + (:: $X) $Subst1 + (:: $X1)) + (subst + (:: $X) $Subst2 + (:: $X2)) + (join $X1 $Resolvent1BodyRest $QR1) + (join $X2 $Resolvent2BodyRest $QR2) + (copy $QR1 $NQR1) + (copy $QR2 $NQR2) + (numbervars $NQR1 0 $_) + (numbervars $NQR2 0 $_) + (nl) + (write ' Predicate invention') + (nl) + (nl) + (tab 3) + (write $NQR1) + (nl) + (tab 3) + (write $NQR2) + (nl) + (nl) + (write ' Has this predicate a meaning (y/n)? ') + (read $Answer) + (nl) + (or + (, + (= $Answer n) + (set-det) + (fail)) + (, + (= $Answer y) + (set-det))) + (write ' How shall I name the predicate ? ') + (read $NewName) + (nl) + (=.. $NP + (Cons $NewName $Vars)) + (subst + (:: $NP) $Subst1 + (:: $NP1)) + (subst + (:: $NP) $Subst2 + (:: $NP2)) + (join $NP1 $Resolvent1BodyRest $R1) + (join $NP2 $Resolvent2BodyRest $R2) + (append + (:: $NP) $Alpha $ClauseBody) + (join $ClauseHead $ClauseBody $R3) + (set-det)) - (= - (step-3-2 $ClauseHead $Vars $Alpha $Resolvent1BodyRest $Subst1 $Resolvent2BodyRest $Subst2 - (:: $R1 $R2 $R3)) - ( (gensym $Name P) - (=.. $X - (Cons $Name $Vars)) - (subst - (:: $X) $Subst1 $X1) - (subst - (:: $X) $Subst2 $X2) - (unflatten $X1 $Resolvent1BodyRest $QR1) - (unflatten $X2 $Resolvent2BodyRest $QR2) - (copy $QR1 $NQR1) - (copy $QR2 $NQR2) - (numbervars $NQR1 0 $_) - (numbervars $NQR2 0 $_) - (nl) - (write ' Predicate invention') - (nl) - (nl) - (tab 3) - (write $NQR1) - (nl) - (tab 3) - (write $NQR2) - (nl) - (nl) - (write ' Has this predicate a meaning (y/n)? ') - (read $Answer) - (nl) - (or - (, - (= $Answer n) - (set-det) - (fail)) - (, - (= $Answer y) - (set-det))) - (write ' How shall I name the predicate ? ') - (read $NewName) - (nl) - (=.. $NP - (Cons $NewName $Vars)) - (subst - (:: $NP) $Subst1 $NP1) - (subst - (:: $NP) $Subst2 $NP2) - (unflatten $NP1 $Resolvent1BodyRest $R1) - (unflatten $NP2 $Resolvent2BodyRest $R2) - (append - (:: $NP) $Alpha $ClauseBody) - (unflatten $ClauseHead $ClauseBody $R3) - (set-det))) -; - + (= (intra-construction2 $Resolvent1 $Resolvent2 $InducedClauses) + (flatten $Resolvent1 $Resolvent1Head $Resolvent1Body) + (flatten $Resolvent2 $Resolvent2Head $Resolvent2Body) + (step-1 $Resolvent1Head $Resolvent1Body $Resolvent2Head $Resolvent2Body $ClauseHead $Alpha $Resolvent1BodyRest $Resolvent2BodyRest $Subst1 $Subst2) + (step-2 $ClauseHead $Alpha $Resolvent1BodyRest $Subst1 $Resolvent2BodyRest $Subst2 $Vars) + (step-3-2 $ClauseHead $Vars $Alpha $Resolvent1BodyRest $Subst1 $Resolvent2BodyRest $Subst2 $InducedClauses)) +; /******************************************************************/ +; /* */ +; /* call : intra_construction2(+Resolvent1,+Resolvent2, */ +; /* -InducedRules) */ +; /* */ +; /* arguments : Resolvent1 = definite clause */ +; /* Resolvent2 = definite clause */ +; /* InducedRules = list of three induced definite */ +; /* clauses */ +; /* */ +; /******************************************************************/ +; /* works on definite clauses with function-symbols */ +; /******************************************************************/ - (= - (subst () $_ ()) True) -; - - (= + (= (step-3-2 $ClauseHead $Vars $Alpha $Resolvent1BodyRest $Subst1 $Resolvent2BodyRest $Subst2 (:: $R1 $R2 $R3)) + (gensym $Name P) + (=.. $X + (Cons $Name $Vars)) (subst - (Cons $X $Xs) $Subst - (Cons $Y $Ys)) - ( (member - (/ $U $V) $Subst) - (== $X $U) - (= $Y $V) - (subst $Xs $Subst $Ys) - (set-det))) -; - - (= + (:: $X) $Subst1 $X1) (subst - (Cons $Prem $Prems) $Subst - (Cons $NewPrem $NewPrems)) - ( (=.. $Prem - (Cons $F $Args)) - (subst $Args $Subst $NewArgs) - (=.. $NewPrem - (Cons $F $NewArgs)) - (subst $Prems $Subst $NewPrems) - (set-det))) -; - - (= + (:: $X) $Subst2 $X2) + (unflatten $X1 $Resolvent1BodyRest $QR1) + (unflatten $X2 $Resolvent2BodyRest $QR2) + (copy $QR1 $NQR1) + (copy $QR2 $NQR2) + (numbervars $NQR1 0 $_) + (numbervars $NQR2 0 $_) + (nl) + (write ' Predicate invention') + (nl) + (nl) + (tab 3) + (write $NQR1) + (nl) + (tab 3) + (write $NQR2) + (nl) + (nl) + (write ' Has this predicate a meaning (y/n)? ') + (read $Answer) + (nl) + (or + (, + (= $Answer n) + (set-det) + (fail)) + (, + (= $Answer y) + (set-det))) + (write ' How shall I name the predicate ? ') + (read $NewName) + (nl) + (=.. $NP + (Cons $NewName $Vars)) (subst - (Cons $X $Xs) $Subst - (Cons $X $Ys)) - (subst $Xs $Subst $Ys)) -; - - + (:: $NP) $Subst1 $NP1) + (subst + (:: $NP) $Subst2 $NP2) + (unflatten $NP1 $Resolvent1BodyRest $R1) + (unflatten $NP2 $Resolvent2BodyRest $R2) + (append + (:: $NP) $Alpha $ClauseBody) + (unflatten $ClauseHead $ClauseBody $R3) + (set-det)) + - (= - (inv_subst () $_ ()) True) -; + (= (subst () $_ ()) True) +; /********************************************************************/ +; /* Some predicates for substituting and for inverse substituting */ +; /* terms according to a given Subst. */ +; /********************************************************************/ + (= (subst (Cons $X $Xs) $Subst (Cons $Y $Ys)) + (member + (/ $U $V) $Subst) + (== $X $U) + (= $Y $V) + (subst $Xs $Subst $Ys) + (set-det)) + (= (subst (Cons $Prem $Prems) $Subst (Cons $NewPrem $NewPrems)) + (=.. $Prem + (Cons $F $Args)) + (subst $Args $Subst $NewArgs) + (=.. $NewPrem + (Cons $F $NewArgs)) + (subst $Prems $Subst $NewPrems) + (set-det)) + (= (subst (Cons $X $Xs) $Subst (Cons $X $Ys)) + (subst $Xs $Subst $Ys)) - (= - (inv-subst - (Cons $X $Xs) $Subst - (Cons $Y $Ys)) - ( (member - (/ $U $V) $Subst) - (== $Y $V) - (= $X $U) - (inv-subst $Xs $Subst $Ys) - (set-det))) -; - - (= - (inv-subst - (Cons $Prem $Prems) $Subst - (Cons $NewPrem $NewPrems)) - ( (=.. $NewPrem - (Cons $F $NewArgs)) - (inv-subst $Args $Subst $NewArgs) - (=.. $Prem - (Cons $F $Args)) - (inv-subst $Prems $Subst $NewPrems) - (set-det))) -; - (= - (inv-subst - (Cons $X $Xs) $Subst - (Cons $X $Ys)) + (= (inv_subst () $_ ()) True) + (= (inv-subst (Cons $X $Xs) $Subst (Cons $Y $Ys)) + (member + (/ $U $V) $Subst) + (== $Y $V) + (= $X $U) + (inv-subst $Xs $Subst $Ys) + (set-det)) + (= (inv-subst (Cons $Prem $Prems) $Subst (Cons $NewPrem $NewPrems)) + (=.. $NewPrem + (Cons $F $NewArgs)) + (inv-subst $Args $Subst $NewArgs) + (=.. $Prem + (Cons $F $Args)) + (inv-subst $Prems $Subst $NewPrems) + (set-det)) + (= (inv-subst (Cons $X $Xs) $Subst (Cons $X $Ys)) (inv-subst $Xs $Subst $Ys)) -; - - - (= - (union_v () $X $X) True) -; - (= - (union-v - (Cons $X $R) $Y $Z) - ( (member $U $Y) - (== $U $X) - (set-det) - (union-v $R $Y $Z))) -; - - (= - (union-v - (Cons $X $R) $Y - (Cons $X $Z)) + (= (union_v () $X $X) True) +; /******************************************************************/ +; /* Some set theoretical predicates, variables are not unified */ +; /******************************************************************/ + (= (union-v (Cons $X $R) $Y $Z) + (member $U $Y) + (== $U $X) + (set-det) + (union-v $R $Y $Z)) + (= (union-v (Cons $X $R) $Y (Cons $X $Z)) (union-v $R $Y $Z)) -; - - - - (= - (intersection_v () $_ ()) True) -; - (= - (intersection-v - (Cons $X $R) $Y - (Cons $X $Z)) - ( (member $U $Y) - (== $U $X) - (set-det) - (intersection-v $R $Y $Z))) -; - (= - (intersection-v - (Cons $X $R) $Y $Z) + (= (intersection_v () $_ ()) True) + (= (intersection-v (Cons $X $R) $Y (Cons $X $Z)) + (member $U $Y) + (== $U $X) + (set-det) + (intersection-v $R $Y $Z)) + (= (intersection-v (Cons $X $R) $Y $Z) (intersection-v $R $Y $Z)) -; - - - (= - (subset () ()) True) -; - (= - (subset - (Cons $X $Subset) - (Cons $X $List)) + (= (subset () ()) True) + (= (subset (Cons $X $Subset) (Cons $X $List)) (subset $Subset $List)) -; - - (= - (subset $Subset - (Cons $_ $List)) + (= (subset $Subset (Cons $_ $List)) (subset $Subset $List)) -; - - (= - (subtract-v - (Cons $X $Xs) $Ys $Zs) - ( (member $Y $Ys) - (== $X $Y) - (delete-v $X $Ys $Y1s) - (subtract-v $Xs $Y1s $Zs) - (set-det))) -; - - (= - (subtract-v - (Cons $X $Xs) $Ys $Zs) + (= (subtract-v (Cons $X $Xs) $Ys $Zs) + (member $Y $Ys) + (== $X $Y) + (delete-v $X $Ys $Y1s) + (subtract-v $Xs $Y1s $Zs) + (set-det)) + (= (subtract-v (Cons $X $Xs) $Ys $Zs) (subtract-v $Xs $Ys $Zs)) -; - - (= - (subtract_v () $Xs $Xs) True) -; - - + (= (subtract_v () $Xs $Xs) True) - (= - (delete-v $X - (Cons $Y $Ys) $Ys) - ( (== $X $Y) (set-det))) -; - (= - (delete-v $X - (Cons $Y $Ys) - (Cons $Y $Zs)) - (delete-v $X $Ys $Zs)) -; - + (= (delete-v $X (Cons $Y $Ys) $Ys) + (== $X $Y) + (set-det)) + (= (delete-v $X (Cons $Y $Ys) (Cons $Y $Zs)) + (delete-v $X $Ys $Zs)) - (= - (count $VAR $X) + (= (count $VAR $X) ( (dynamic $VAR 1) (=.. $P1 (:: $VAR $N)) - (remove-symbol &self $P1) + (remove-is-symbol &self $P1) (is $X (+ $N 1)) (=.. $P2 (:: $VAR $X)) - (add-symbol &self $P2) + (add-is-symbol &self $P2) (set-det))) -; - - (= - (count $VAR 1) +; /******************************************************************/ +; /* Creation of unique identifiers */ +; /******************************************************************/ + (= (count $VAR 1) ( (dynamic $VAR 1) (=.. $P (:: $VAR 1)) - (add-symbol &self $P))) -; - + (add-is-symbol &self $P))) - (= - (gensym $SYM $N) - ( (count $N $X) (conc $N $X $SYM))) -; + (= (gensym $SYM $N) + (count $N $X) + (conc $N $X $SYM)) - - (= - (copy $A $B) + (= (copy $A $B) (or (, - (add-symbol &self + (add-is-symbol &self (internal $A)) - (remove-symbol &self + (remove-is-symbol &self (internal $B)) (set-det)) (, - (remove-symbol &self + (remove-is-symbol &self (internal $_)) (fail)))) -; - - - - (= - (lookup $Key - (d $Key $X $Left $Right) $Value) - ( (set-det) (= $X $Value))) -; - - (= - (lookup $Key - (d $Key1 $X $Left $Right) $Value) - ( (@< $Key $Key1) (lookup $Key $Left $Value))) -; - - (= - (lookup $Key - (d $Key1 $X $Left $Right) $Value) - ( (@> $Key $Key1) (lookup $Key $Right $Value))) -; - - - - (= - (conc $STR1 $STR2 $STR3) - ( (nonvar $STR1) - (nonvar $STR2) - (name $STR1 $S1) - (name $STR2 $S2) - (append $S1 $S2 $S3) - (name $STR3 $S3))) -; - - (= - (conc $STR1 $STR2 $STR3) - ( (nonvar $STR1) - (nonvar $STR3) - (name $STR1 $S1) - (name $STR3 $S3) - (append $S1 $S2 $S3) - (name $STR2 $S2))) -; - - (= - (conc $STR1 $STR2 $STR3) - ( (nonvar $STR2) - (nonvar $STR3) - (name $STR2 $S2) - (name $STR3 $S3) - (append $S1 $S2 $S3) - (name $STR1 $S1))) -; - - - - (= - (varlist $X $L) - ( (varlist $X Nil $L) (set-det))) -; - +; /******************************************************************/ +; /* Making a copy of the variables occuring in a MeTTa term */ +; /******************************************************************/ + + + (= (lookup $Key (d $Key $X $Left $Right) $Value) + (set-det) + (= $X $Value)) +; /******************************************************************/ +; /* Construction and retrieval of an dictionary */ +; /******************************************************************/ + (= (lookup $Key (d $Key1 $X $Left $Right) $Value) + (@< $Key $Key1) + (lookup $Key $Left $Value)) + (= (lookup $Key (d $Key1 $X $Left $Right) $Value) + (@> $Key $Key1) + (lookup $Key $Right $Value)) + + + (= (conc $STR1 $STR2 $STR3) + (nonvar $STR1) + (nonvar $STR2) + (name $STR1 $S1) + (name $STR2 $S2) + (append $S1 $S2 $S3) + (name $STR3 $S3)) +; /******************************************************************/ +; /* Concatenation of atoms */ +; /******************************************************************/ + (= (conc $STR1 $STR2 $STR3) + (nonvar $STR1) + (nonvar $STR3) + (name $STR1 $S1) + (name $STR3 $S3) + (append $S1 $S2 $S3) + (name $STR2 $S2)) + (= (conc $STR1 $STR2 $STR3) + (nonvar $STR2) + (nonvar $STR3) + (name $STR2 $S2) + (name $STR3 $S3) + (append $S1 $S2 $S3) + (name $STR1 $S1)) + + + (= (varlist $X $L) + (varlist $X Nil $L) + (set-det)) +; /******************************************************************/ +; /* Determination of the set of vars occuring in a MeTTa expression*/ +; /******************************************************************/ - (= - (varlist $T $L $LO) - ( (nonvar $T) - (=.. $T - (Cons $F $A)) - (set-det) - (varlist1 $A $L $LO))) -; - - (= - (varlist $X $L $L) - ( (var $X) - (element-v $X $L) - (set-det))) -; - - (= - (varlist $X $L - (Cons $X $L)) - ( (var $X) (set-det))) -; - - - - (= - (varlist1 - (Cons $T $A) $L $LO) - ( (varlist1 $A $L $L1) - (set-det) - (varlist $T $L1 $LO))) -; + (= (varlist $T $L $LO) + (nonvar $T) + (=.. $T + (Cons $F $A)) + (set-det) + (varlist1 $A $L $LO)) + (= (varlist $X $L $L) + (var $X) + (element-v $X $L) + (set-det)) + (= (varlist $X $L (Cons $X $L)) + (var $X) + (set-det)) - (= - (varlist1 () $L $L) True) -; + (= (varlist1 (Cons $T $A) $L $LO) + (varlist1 $A $L $L1) + (set-det) + (varlist $T $L1 $LO)) + (= (varlist1 () $L $L) True) - (= - (element-v $Element1 - (Cons $Element2 $Tail)) + (= (element-v $Element1 (Cons $Element2 $Tail)) (== $Element1 $Element2)) -; - - (= - (element-v $Element - (Cons $_ $Tail)) + (= (element-v $Element (Cons $_ $Tail)) (element-v $Element $Tail)) -; - - (= - (findbag $X $G $_) - ( (add-symbol &self + (= (findbag $X $G $_) + ( (add-is-symbol &self (yk_found mark)) (call $G) - (add-symbol &self + (add-is-symbol &self (yk_found $X)) (fail))) -; - - (= - (findbag $_ $_ $L) - (yk-collect-found Nil $L)) -; - +; /******************************************************************/ +; /* We cannot use bagof/3 since it reverses the output list order !*/ +; /******************************************************************/ + (= (findbag $_ $_ $L) + (yk-collect-found Nil $L)) - (= - (yk-collect-found $Acc $L) - ( (yk-getnext $X) (yk-collect-found (Cons $X $Acc) $L))) -; - - (= - (yk_collect_found $X $X) True) -; - + (= (yk-collect-found $Acc $L) + (yk-getnext $X) + (yk-collect-found + (Cons $X $Acc) $L)) + (= (yk_collect_found $X $X) True) ; (error ; (syntax_error operator_expected) @@ -981,31 +814,32 @@ - (= - (help) - ( (write 'Load example calls with command: [Filename].') - (nl) - (write 'Run example with command: test1(X).') - (nl) - (write 'Run example with command: test2(X).') - (nl) - (write 'Run example with command: test3(X).') - (nl) - (write 'Run example with command: test4(X).') - (nl) - (write 'Run example with command: test5(X).') - (nl) - (write 'Run example with command: test6(X).') - (nl) - (write 'Run example with command: test7(X).') - (nl) - (write 'Run example with command: test8(X).') - (nl))) -; - + (= (help) + (write 'Load example calls with command: [Filename].') + (nl) + (write 'Run example with command: test1(X).') + (nl) + (write 'Run example with command: test2(X).') + (nl) + (write 'Run example with command: test3(X).') + (nl) + (write 'Run example with command: test4(X).') + (nl) + (write 'Run example with command: test5(X).') + (nl) + (write 'Run example with command: test6(X).') + (nl) + (write 'Run example with command: test7(X).') + (nl) + (write 'Run example with command: test8(X).') + (nl)) +; /******************************************************************/ +; /* instvars instantiates variables by a '_'() structure. */ +; /* Unfortunately a pretty print will result in uglier terms in */ +; /* some MeTTa dialects */ +; /******************************************************************/ +; ; instvars(REXPR,MIN,MAX) :- ; REXPR =.. [_|ARGS], yap_instvar(ARGS,MIN,MAX), ! . ; ; yap_instvar([],N,N) . ; yap_instvar([FIRST|REST],N,N_OUT) :- ; var(FIRST), !, Y =.. ['_',N], FIRST = Y, ; N_PLUS_1 is N + 1, yap_instvar(REST,N_PLUS_1,N_OUT) . ; yap_instvar([FIRST|REST],N,N_OUT) :- ; skel(FIRST), !, FIRST =.. [_|SKEL_ARGS], ; yap_instvar(SKEL_ARGS,N,N_PLUS_M), ; yap_instvar(REST,N_PLUS_M,N_OUT) . ; yap_instvar([_|REST],N,N_OUT) :- ; yap_instvar(REST,N,N_OUT) . ; ; skel(Z) :- ; nonvar(Z), ; (list(Z), !, length(Z,N), N>0; ; Z =.. [_|LIST], length(LIST,N), N>0), ! . ; ; list([]). ; list([A|B]) :- list(B) . !(help *) -; - diff --git a/invers/invers_1.metta b/invers/invers_1.metta index 510434d..a96a052 100644 --- a/invers/invers_1.metta +++ b/invers/invers_1.metta @@ -1,201 +1,155 @@ - - (= - (test1) - ( (split - (= - (< $A - (succ (succ $A))) - (< $B - (succ $B))) $Head $BodyList) (join $Head $BodyList $Rule))) -; - +; (convert_to_metta_file invers_1 $_200618 invers/invers_1.pl invers/invers_1.metta) + + (= (test1) + (split + (= (< $A (succ (succ $A))) + (< $B + (succ $B))) $Head $BodyList) + (join $Head $BodyList $Rule)) +; /******************************************************************/ +; /* testcalls for different implementation levels */ +; /******************************************************************/ - (= - (test2) - ( (flatten - (= - (< $B - (succ $B)) True) $K $L) (flatten (= (< $A (succ (succ $A))) True) $U $V))) -; - - - - (= - (test1 $Q) - ( (= $X - (= - (mother $A $B) - ( (sex $A female) (parent $A $B)))) - (write 'Clause: ') - (write $X) - (nl) - (= $Y - (= - (grandfather $D $F) - ( (father $D $E) - (sex $E female) - (parent $E $F)))) - (write 'Resolvent: ') - (write $Y) - (nl) - (absorption1 $X $Y $Q))) -; - - - - (= - (test2 $Q) - ( (= $X - (= - (< $B $C) - (succ $B $C))) - (write 'Clause: ') - (write $X) - (nl) - (= $Y - (= - (< $A $D) - ( (succ $A $E) (succ $E $D)))) - (write 'Resolvent: ') - (write $Y) - (nl) - (absorption1 $X $Y $Q))) -; - - - - (= - (test3 $Q) - ( (= $X - (= - (mother $A $B) - ( (sex $A female) (daugther $B $A)))) - (write 'Clause: ') - (write $X) - (nl) - (= $Y - (= - (grandfather a c) - ( (father a m) - (sex m female) - (daugther c m)))) - (write 'Resolvent: ') - (write $Y) - (nl) - (absorption2 $X $Y $Q))) -; - - - - (= - (test4 $Q) - ( (= $X - (= - (< $B - (succ $B)) True)) - (write 'Clause: ') - (write $X) - (nl) - (= $Y - (= - (< $A - (succ - (succ $A))) True)) - (write 'Resolvent: ') - (write $Y) - (nl) - (absorption2 $X $Y $Q))) -; - - - - (= - (test5 $Q) - ( (= $X - (= - (grandfather $D $E) - ( (father $D $F) (mother $F $E)))) - (write 'Resolvent: ') - (write $X) - (nl) - (= $Y - (= - (grandfather $A $B) - ( (father $A $C) (father $C $B)))) - (write 'Resolvent: ') - (write $Y) - (nl) - (intra-construction1 $X $Y $Q))) -; - - - - (= - (test6 $Q) - ( (= $X - (= - (grandfather $D $E) - ( (father $D $F) (mother $F $E)))) - (write 'Resolvent: ') - (write $X) - (nl) - (= $Y - (= - (grandfather $A $B) - ( (father $A $C) (father $C $B)))) - (write 'Resolvent: ') - (write $Y) - (nl) - (intra-construction2 $X $Y $Q))) -; - - - - (= - (test7 $Q) - ( (= $X - (= - (min $D - (Cons - (succ $D) $E)) - (min $D $E))) - (write 'Resolvent: ') - (write $X) - (nl) - (= $Y - (= - (min $F - (Cons - (succ (succ $F)) $G)) - (min $F $G))) - (write 'Resolvent: ') - (write $Y) - (nl) - (intra-construction2 $X $Y $Q))) -; - - - - (= - (test8 $Q) - ( (= $X - (= - (< $B - (succ $B)) True)) - (write 'Resolvent: ') - (write $X) - (nl) - (= $Y - (= - (< $A - (succ - (succ $A))) True)) - (write 'Resolvent: ') - (write $Y) - (nl) - (intra-construction2 $X $Y $Q))) -; - + (= (test2) + (flatten + (= (< $B (succ $B)) True) $K $L) + (flatten + (= (< $A (succ (succ $A))) True) $U $V)) + + + (= (test1 $Q) + (= $X + (= (mother $A $B) + (sex $A female) + (parent $A $B))) + (write 'Clause: ') + (write $X) + (nl) + (= $Y + (= (grandfather $D $F) + (father $D $E) + (sex $E female) + (parent $E $F))) + (write 'Resolvent: ') + (write $Y) + (nl) + (absorption1 $X $Y $Q)) + + + (= (test2 $Q) + (= $X + (= (< $B $C) + (succ $B $C))) + (write 'Clause: ') + (write $X) + (nl) + (= $Y + (= (< $A $D) + (succ $A $E) + (succ $E $D))) + (write 'Resolvent: ') + (write $Y) + (nl) + (absorption1 $X $Y $Q)) + + + (= (test3 $Q) + (= $X + (= (mother $A $B) + (sex $A female) + (daugther $B $A))) + (write 'Clause: ') + (write $X) + (nl) + (= $Y + (= (grandfather a c) + (father a m) + (sex m female) + (daugther c m))) + (write 'Resolvent: ') + (write $Y) + (nl) + (absorption2 $X $Y $Q)) + + + (= (test4 $Q) + (= $X + (= (< $B (succ $B)) True)) + (write 'Clause: ') + (write $X) + (nl) + (= $Y + (= (< $A (succ (succ $A))) True)) + (write 'Resolvent: ') + (write $Y) + (nl) + (absorption2 $X $Y $Q)) + + + (= (test5 $Q) + (= $X + (= (grandfather $D $E) + (father $D $F) + (mother $F $E))) + (write 'Resolvent: ') + (write $X) + (nl) + (= $Y + (= (grandfather $A $B) + (father $A $C) + (father $C $B))) + (write 'Resolvent: ') + (write $Y) + (nl) + (intra-construction1 $X $Y $Q)) + + + (= (test6 $Q) + (= $X + (= (grandfather $D $E) + (father $D $F) + (mother $F $E))) + (write 'Resolvent: ') + (write $X) + (nl) + (= $Y + (= (grandfather $A $B) + (father $A $C) + (father $C $B))) + (write 'Resolvent: ') + (write $Y) + (nl) + (intra-construction2 $X $Y $Q)) + + + (= (test7 $Q) + (= $X + (= (min $D (Cons (succ $D) $E)) + (min $D $E))) + (write 'Resolvent: ') + (write $X) + (nl) + (= $Y + (= (min $F (Cons (succ (succ $F)) $G)) + (min $F $G))) + (write 'Resolvent: ') + (write $Y) + (nl) + (intra-construction2 $X $Y $Q)) + + + (= (test8 $Q) + (= $X + (= (< $B (succ $B)) True)) + (write 'Resolvent: ') + (write $X) + (nl) + (= $Y + (= (< $A (succ (succ $A))) True)) + (write 'Resolvent: ') + (write $Y) + (nl) + (intra-construction2 $X $Y $Q)) diff --git a/invers/logic.metta b/invers/logic.metta index a95a5f1..c956168 100644 --- a/invers/logic.metta +++ b/invers/logic.metta @@ -1,248 +1,276 @@ +; (convert_to_metta_file logic $_313292 invers/logic.pl invers/logic.metta) - (= - (substitution $Term1 $Term2 $Sub_List) - ( (implies $Term1 $Term2) - (substitute - (:: $Term1) - (:: $Term2) $Subst1) - (sort $Subst1 $Subst2) - (remove-id $Subst2 $Sub_List) - (set-det))) -; - + (= (substitution $Term1 $Term2 $Sub_List) + (implies $Term1 $Term2) + (substitute + (:: $Term1) + (:: $Term2) $Subst1) + (sort $Subst1 $Subst2) + (remove-id $Subst2 $Sub_List) + (set-det)) +; /******************************************************************/ +; /* LOGIC.PRO Last Modification: Fri Jan 14 19:25:10 1994 */ +; /* Differerent logic procedures useful for learning: determination*/ +; /* of subsitutions, implies, Plotkin's least general generalisa- */ +; /* tion, Buntine's generalized subsumption. */ +; /******************************************************************/ +; ; ; Copyright (c) 1988 Stephen Muggleton ; ; This program is free software; you can redistribute it and/or ; modify it under the terms of the GNU General Public License ; Version 1 as published by the Free Software Foundation. ; ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; ; You should have received a copy of the GNU General Public ; License along with this program; if not, write to the Free ; Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, ; USA. ; +; /******************************************************************/ +; /* impl. by : Stephen Muggleton */ +; /* Turing Institute */ +; /* George House */ +; /* 36 North hanover Street */ +; /* Glasgow, G1 2AD */ +; /* U.K. */ +; /* E-Mail: steve@turing-institute.ac.uk */ +; /* 1988 */ +; /* */ +; /* reference : A note on inductive generalization */ +; /* Gordon Plotkin */ +; /* in: B. Meltzer, D. Michie (eds) */ +; /* Machine Intelligence 5 */ +; /* Elsevier North-Holland 1970 */ +; /* */ +; /* A further note on inductive generalization */ +; /* Gordon Plotkin */ +; /* in: B. Meltzer, D. Michie (eds) */ +; /* Machine Intelligence 6 */ +; /* Elsevier North-Holland 1971 */ +; /* */ +; /* Generalized Subsumption and Its Applications to */ +; /* Induction and Redundancy */ +; /* Wray Buntine */ +; /* Artificial Intelligence 36, 1988. */ +; /* */ +; /* ES2ML Tutorial Exercise */ +; /* Substitution matching and generalisation in */ +; /* MeTTa */ +; /* Stephen Muggleton */ +; /* */ +; /* call : see logic_1.pro */ +; /* */ +; /******************************************************************/ +; ; TH Sun May 30 15:12:41 1993 - made some minor modifications +; /******************************************************************/ +; /* */ +; /* call : subsitution (+Term1,+Term2,-Subst) */ +; /* */ +; /* arguments : Term1 = first-order logic Term, with variables */ +; /* Term2 = first-order logic Term, without */ +; /* variables */ +; /* Subst = List of minimal-sized substitutions */ +; /* */ +; /******************************************************************/ +; /* In PROLOG (and first-order logic), a term is recursively */ +; /* defined as being either a constant (in PROLOG a lower-case */ +; /* atom), a variable (in PROLOG a upper-case variable) or a */ +; /* function symbol (in PROLOG a relational expression of the form */ +; /* 'p(a,b, ..., X)') which takes a number of terms as arguments. */ +; /* Substitutions are unique mappings from variables to Terms, in */ +; /* the following denoted by S, and written out as sets of */ +; /* variable/term pairs, such as {A/b,B/f(X)}. When a substitution */ +; /* S is applied to a term t, each variable within t which is an */ +; /* element of the domain of S is replaced by the corresponding */ +; /* term within S. Thus, letting t = f(a,A) and S = {A/b,B/f(X)}, */ +; /* the term tS = f(a,b). */ +; /* The following predicate 'substitution', returns the minimal- */ +; /* sized substitution S such that t1 S = t2, when such a */ +; /* substitution exists, given two terms t1 and t2. */ +; /******************************************************************/ -; (error -; (syntax_error operator_expected) -; (file invers/logic.pl 95 8 5563)) +; (error +; (syntax_error operator_expected) +; (file invers/logic.pl 95 8 5563)) - (= - (skolemize () $N $N) True) -; - - (= - (skolemize - (Cons $Head $Tail) $N $M) - ( (= $Head - ($var $N)) - (skolemize $Tail - (s $N) $M) - (set-det))) -; - - (= - (skolemize - (Cons $Head $Tail) $N $M) - ( (=.. $Head - (Cons $F $Tail1)) - (skolemize $Tail1 $N $O) - (skolemize $Tail $O $M))) -; - + (= (skolemize () $N $N) True) + (= (skolemize (Cons $Head $Tail) $N $M) + (= $Head + ($var $N)) + (skolemize $Tail + (s $N) $M) + (set-det)) + (= (skolemize (Cons $Head $Tail) $N $M) + (=.. $Head + (Cons $F $Tail1)) + (skolemize $Tail1 $N $O) + (skolemize $Tail $O $M)) - (= - (substitute Nil Nil Nil) + (= (substitute Nil Nil Nil) + (set-det)) + (= (substitute (Cons $Head1 $Tail1) (Cons $Head2 $Tail2) (Cons (/ $Head1 $Head2) $Tail3)) + (var $Head1) + (substitute $Tail1 $Tail2 $Tail3) + (set-det)) + (= (substitute (Cons $Head1 $Tail1) (Cons $Head2 $Tail2) $Subst) + (=.. $Head1 + (Cons $F1 $Tail11)) + (=.. $Head2 + (Cons $F1 $Tail22)) + (substitute $Tail11 $Tail22 $Tail33) + (substitute $Tail1 $Tail2 $Tail4) + (append $Tail33 $Tail4 $Subst) (set-det)) -; - (= - (substitute - (Cons $Head1 $Tail1) - (Cons $Head2 $Tail2) - (Cons - (/ $Head1 $Head2) $Tail3)) - ( (var $Head1) - (substitute $Tail1 $Tail2 $Tail3) - (set-det))) -; - (= - (substitute - (Cons $Head1 $Tail1) - (Cons $Head2 $Tail2) $Subst) - ( (=.. $Head1 - (Cons $F1 $Tail11)) - (=.. $Head2 - (Cons $F1 $Tail22)) - (substitute $Tail11 $Tail22 $Tail33) - (substitute $Tail1 $Tail2 $Tail4) - (append $Tail33 $Tail4 $Subst) - (set-det))) -; - - - - (= - (remove-id Nil Nil) + (= (remove-id Nil Nil) (set-det)) -; - - (= - (remove-id - (:: $X) - (:: $X)) + (= (remove-id (:: $X) (:: $X)) (set-det)) -; - - (= - (remove-id - (Cons $A - (Cons $B $Tail)) $List) - ( (== $A $B) - (remove-id - (Cons $A $Tail) $List) - (set-det))) -; - - (= + (= (remove-id (Cons $A (Cons $B $Tail)) $List) + (== $A $B) (remove-id - (Cons $Head1 $Tail1) - (Cons $Head1 $Tail2)) - ( (remove-id $Tail1 $Tail2) (set-det))) -; - - - - (= - (lgg $Term1 $Term2 $Term3) - ( (lgg1 - (:: $Term1) - (:: $Term2) - (:: $Term3) Nil $Subst) (set-det))) -; - - + (Cons $A $Tail) $List) + (set-det)) + (= (remove-id (Cons $Head1 $Tail1) (Cons $Head1 $Tail2)) + (remove-id $Tail1 $Tail2) + (set-det)) - (= - (lgg1 () () () $Subst $Subst) True) -; - (= + (= (lgg $Term1 $Term2 $Term3) (lgg1 - (Cons $Head1 $Tail1) - (Cons $Head2 $Tail2) - (Cons $Head3 $Tail3) $Subst1 $Subst3) - ( (=.. $Head1 - (Cons $F $Tail11)) - (=.. $Head2 - (Cons $F $Tail22)) - (lgg1 $Tail11 $Tail22 $Tail33 $Subst1 $Subst2) - (=.. $Head3 - (Cons $F $Tail33)) - (lgg1 $Tail1 $Tail2 $Tail3 $Subst2 $Subst3) - (set-det))) -; - - (= - (lgg1 - (Cons $Head1 $Tail1) - (Cons $Head2 $Tail2) - (Cons $Head3 $Tail3) $Subst1 $Subst2) - ( (subst-member - (/ $Head3 - (, $Head1 $Head2)) $Subst1) - (lgg1 $Tail1 $Tail2 $Tail3 $Subst1 $Subst2) - (set-det))) -; - - (= - (lgg1 - (Cons $Head1 $Tail1) - (Cons $Head2 $Tail2) - (Cons $Head3 $Tail3) $Subst1 $Subst2) - ( (lgg1 $Tail1 $Tail2 $Tail3 - (Cons - (/ $Head3 - (, $Head1 $Head2)) $Subst1) $Subst2) (set-det))) -; - - + (:: $Term1) + (:: $Term2) + (:: $Term3) Nil $Subst) + (set-det)) +; /******************************************************************/ +; /* */ +; /* call : lgg (+Term1,+Term2,-Term3) */ +; /* */ +; /* arguments : Term1 = first-order logic Term */ +; /* Term2 = first-order logic Term */ +; /* Term3 = generalized first-order logic Term */ +; /* */ +; /******************************************************************/ +; /* We say that term t1 is a 'generalisation of (or subsumes)' t2 */ +; /* iff there exists a substitution S such that t1 S = t2. Also */ +; /* Term t is said to be a 'common generalisation' of terms u and */ +; /* v iff t is a generalisation of u and t is a generalisation of */ +; /* v. In paticular t is the 'least-general-generalisation (lgg)' */ +; /* of u and v iff t is a common generalisation of u and v, and */ +; /* every other common generalisation t' of u and v is also a */ +; /* generalisation of t. */ +; /******************************************************************/ + - (= + (= (lgg1 () () () $Subst $Subst) True) + (= (lgg1 (Cons $Head1 $Tail1) (Cons $Head2 $Tail2) (Cons $Head3 $Tail3) $Subst1 $Subst3) + (=.. $Head1 + (Cons $F $Tail11)) + (=.. $Head2 + (Cons $F $Tail22)) + (lgg1 $Tail11 $Tail22 $Tail33 $Subst1 $Subst2) + (=.. $Head3 + (Cons $F $Tail33)) + (lgg1 $Tail1 $Tail2 $Tail3 $Subst2 $Subst3) + (set-det)) + (= (lgg1 (Cons $Head1 $Tail1) (Cons $Head2 $Tail2) (Cons $Head3 $Tail3) $Subst1 $Subst2) (subst-member - (/ $A $B) + (/ $Head3 + (, $Head1 $Head2)) $Subst1) + (lgg1 $Tail1 $Tail2 $Tail3 $Subst1 $Subst2) + (set-det)) + (= (lgg1 (Cons $Head1 $Tail1) (Cons $Head2 $Tail2) (Cons $Head3 $Tail3) $Subst1 $Subst2) + (lgg1 $Tail1 $Tail2 $Tail3 (Cons - (/ $A $C) $_)) - ( (== $B $C) (set-det))) -; - - (= - (subst-member $A - (Cons $_ $B)) - ( (subst-member $A $B) (set-det))) -; + (/ $Head3 + (, $Head1 $Head2)) $Subst1) $Subst2) + (set-det)) + (= (subst-member (/ $A $B) (Cons (/ $A $C) $_)) + (== $B $C) + (set-det)) + (= (subst-member $A (Cons $_ $B)) + (subst-member $A $B) + (set-det)) - (= - (covers () $_) True) -; - (= + (= (covers () $_) True) +; /******************************************************************/ +; /* */ +; /* call : covers(+Goal,+ClauseList) */ +; /* */ +; /* arguments : Goal = An instance */ +; /* ClauseList = Clauses in a special PROLOG-syntax */ +; /* */ +; /******************************************************************/ +; /* An 'atomic formula' is defined as a predicate symbol which */ +; /* takes a number of terms as arguments (such as "mem(a,[b,a])"). */ +; /* A 'literal' is defined as being either an atomic formula or */ +; /* the negation of an atomic formula (such as "not mem(a,[b,c])". */ +; /* A 'clause' is a 'disjunction' of literals. Thus a clause */ +; /* (L1 \/ L2 \/ ... Ln) can be represented as a set */ +; /* {L1,L2, ... Ln} */ +; /* Given two clauses C and D we say that C is a 'generalisation */ +; /* (or subsumes)' D whenever there is a substitution S such that */ +; /* C S is a subset of or equal to D, w.r.t. a logic program P. */ +; /******************************************************************/ + (= (covers (Cons $H1 $T1) $P) + (member $C1 $P) + (copy $C1 + (= $H1 $B1)) + (covers-body $B1 $P) + (covers $T1 $P)) + + + (= (covers_body true $_) True) + (= (covers-body (, $H $B) $P) + (set-det) (covers - (Cons $H1 $T1) $P) - ( (member $C1 $P) - (copy $C1 - (= $H1 $B1)) - (covers-body $B1 $P) - (covers $T1 $P))) -; - - - - (= - (covers_body true $_) True) -; - - (= - (covers-body - (, $H $B) $P) - ( (set-det) - (covers - (:: $H) $P) - (covers-body $B $P))) -; - - (= - (covers-body $H $P) + (:: $H) $P) + (covers-body $B $P)) + (= (covers-body $H $P) (covers (:: $H) $P)) -; - - (= - (copy $A $B) + (= (copy $A $B) (or (, - (add-symbol &self + (add-is-symbol &self (yap_inst $A)) - (remove-symbol &self + (remove-is-symbol &self (yap_inst $B)) (set-det)) (, - (remove-symbol &self + (remove-is-symbol &self (yap_inst $_)) (fail)))) -; - - (= - (psubsumes $_ Nil) + (= (psubsumes $_ Nil) + (set-det)) +; /******************************************************************/ +; /* */ +; /* call : psubsumes(+PRG1,+PRG2) */ +; /* */ +; /* arguments : PRG1 = A clause set in a special PROLOG-syntax */ +; /* PRG2 = A clause set in a special PROLOG-syntax */ +; /* */ +; /******************************************************************/ +; /* MeTTa programs consist of a restricted form of clause called */ +; /* a 'Horn clause'. Horn clauses contains at most one positive (or*/ +; /* unnegated) literal. The positive literal is written as the */ +; /* 'head' of a MeTTa clause, while the 'body' of a MeTTa clause */ +; /* represents the set of negated literals. The 'goal' of a MeTTa */ +; /* program is simply a clause containing no positive literals. A */ +; /* MeTTa program should be viewed as a conjunction of clauses. */ +; /* This might be represented symbolically as: */ +; /* (C1 /\ C2 /\ ... Cn) or in set notation as */ +; /* {C1,C2,... Cn} */ +; /* Thus an entire MeTTa program can be viewed as a single logical*/ +; /* formula. The following is a simplified restatement of */ +; /* Herbrand's theorem: */ +; /* Given two formulae F1 and F2, F1 is more general than F2 */ +; /* iff for every substitution S, (F1 /\ not(F2)) S is false. */ +; /******************************************************************/ + (= (psubsumes $P (Cons $C $T)) + (bsubsumes $P $C) + (psubsumes $P $T) (set-det)) -; - - (= - (psubsumes $P - (Cons $C $T)) - ( (bsubsumes $P $C) - (psubsumes $P $T) - (set-det))) -; - ; (error ; (syntax_error operator_expected) @@ -250,73 +278,68 @@ - (= - (body-units True Nil) + (= (body-units True Nil) (set-det)) -; - - (= - (body-units - (, $Head1 $Tail1) - (Cons - (= $Head1 True) $Tail2)) - ( (body-units $Tail1 $Tail2) (set-det))) -; - - (= - (body_units $Head - ( (:- $Head true))) True) -; - - - - (= - (goal_units () ()) True) -; - - (= - (goal-units - (Cons $Head1 $Tail1) - (Cons - (= $Head1 True) $Tail2)) - ( (goal-units $Tail1 $Tail2) (set-det))) -; + (= (body-units (, $Head1 $Tail1) (Cons (= $Head1 True) $Tail2)) + (body-units $Tail1 $Tail2) + (set-det)) + (= (body_units $Head ((:- $Head true))) True) + (= (goal_units () ()) True) + (= (goal-units (Cons $Head1 $Tail1) (Cons (= $Head1 True) $Tail2)) + (goal-units $Tail1 $Tail2) + (set-det)) - (= - (p-subsumes $ClauseSet1 $Theory $ClauseSet2) - ( (append $ClauseSet1 $Theory $Program) (psubsumes $Program $ClauseSet2))) -; + (= (p-subsumes $ClauseSet1 $Theory $ClauseSet2) + (append $ClauseSet1 $Theory $Program) + (psubsumes $Program $ClauseSet2)) +; /******************************************************************/ +; /* */ +; /* call : p_subsumes(+ClauseSet1,+Theory,+ClauseSet2) */ +; /* */ +; /* arguments : ClauseSet1 = A set of clauses PROLOG-syntax */ +; /* ClauseSet2 = A set of clauses PROLOG-syntax */ +; /* Theory = A set of clauses PROLOG-syntax */ +; /* */ +; /******************************************************************/ +; /* This procedure implements the generalized subsumption between */ +; /* two clause sets, w.r.t. a background theory. */ +; /******************************************************************/ - (= - (p-equivalent $ClauseSet1 $Theory $ClauseSet2) - ( (append $ClauseSet1 $Theory $Program1) - (psubsumes $Program1 $ClauseSet2) - (append $ClauseSet2 $Theory $Program2) - (psubsumes $Program2 $ClauseSet1))) -; - + (= (p-equivalent $ClauseSet1 $Theory $ClauseSet2) + (append $ClauseSet1 $Theory $Program1) + (psubsumes $Program1 $ClauseSet2) + (append $ClauseSet2 $Theory $Program2) + (psubsumes $Program2 $ClauseSet1)) +; /******************************************************************/ +; /* */ +; /* call : p_subsumes(+ClauseSet1,+Theory,+ClauseSet2) */ +; /* */ +; /* arguments : ClauseSet1 = A set of clauses PROLOG-syntax */ +; /* ClauseSet2 = A set of clauses PROLOG-syntax */ +; /* Theory = A set of clauses PROLOG-syntax */ +; /* */ +; /******************************************************************/ +; /* This procedure implements equivalence based on the generalized */ +; /* subsumption between two clause sets, w.r.t. a background */ +; /* theory. */ +; /******************************************************************/ - (= - (help) - ( (write 'Load example calls with command: [Filename].') - (nl) - (write 'Call examples with: test1, test2, test3a, test3b,') - (nl) - (write ' test4a, test4b, test4c, test4d, test5') - (nl))) -; - + (= (help) + (write 'Load example calls with command: [Filename].') + (nl) + (write 'Call examples with: test1, test2, test3a, test3b,') + (nl) + (write ' test4a, test4b, test4c, test4d, test5') + (nl)) !(help *) -; - diff --git a/logic/logic.metta b/logic/logic.metta index 5c2af95..cd58f02 100644 --- a/logic/logic.metta +++ b/logic/logic.metta @@ -1,248 +1,276 @@ +; (convert_to_metta_file logic $_215358 logic/logic.pl logic/logic.metta) - (= - (substitution $Term1 $Term2 $Sub_List) - ( (implies $Term1 $Term2) - (substitute - (:: $Term1) - (:: $Term2) $Subst1) - (sort $Subst1 $Subst2) - (remove-id $Subst2 $Sub_List) - (set-det))) -; - + (= (substitution $Term1 $Term2 $Sub_List) + (implies $Term1 $Term2) + (substitute + (:: $Term1) + (:: $Term2) $Subst1) + (sort $Subst1 $Subst2) + (remove-id $Subst2 $Sub_List) + (set-det)) +; /******************************************************************/ +; /* LOGIC.PRO Last Modification: Fri Jan 14 19:25:10 1994 */ +; /* Differerent logic procedures useful for learning: determination*/ +; /* of subsitutions, implies, Plotkin's least general generalisa- */ +; /* tion, Buntine's generalized subsumption. */ +; /******************************************************************/ +; ; ; Copyright (c) 1988 Stephen Muggleton ; ; This program is free software; you can redistribute it and/or ; modify it under the terms of the GNU General Public License ; Version 1 as published by the Free Software Foundation. ; ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; ; You should have received a copy of the GNU General Public ; License along with this program; if not, write to the Free ; Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, ; USA. ; +; /******************************************************************/ +; /* impl. by : Stephen Muggleton */ +; /* Turing Institute */ +; /* George House */ +; /* 36 North hanover Street */ +; /* Glasgow, G1 2AD */ +; /* U.K. */ +; /* E-Mail: steve@turing-institute.ac.uk */ +; /* 1988 */ +; /* */ +; /* reference : A note on inductive generalization */ +; /* Gordon Plotkin */ +; /* in: B. Meltzer, D. Michie (eds) */ +; /* Machine Intelligence 5 */ +; /* Elsevier North-Holland 1970 */ +; /* */ +; /* A further note on inductive generalization */ +; /* Gordon Plotkin */ +; /* in: B. Meltzer, D. Michie (eds) */ +; /* Machine Intelligence 6 */ +; /* Elsevier North-Holland 1971 */ +; /* */ +; /* Generalized Subsumption and Its Applications to */ +; /* Induction and Redundancy */ +; /* Wray Buntine */ +; /* Artificial Intelligence 36, 1988. */ +; /* */ +; /* ES2ML Tutorial Exercise */ +; /* Substitution matching and generalisation in */ +; /* MeTTa */ +; /* Stephen Muggleton */ +; /* */ +; /* call : see logic_1.pro */ +; /* */ +; /******************************************************************/ +; ; TH Sun May 30 15:12:41 1993 - made some minor modifications +; /******************************************************************/ +; /* */ +; /* call : subsitution (+Term1,+Term2,-Subst) */ +; /* */ +; /* arguments : Term1 = first-order logic Term, with variables */ +; /* Term2 = first-order logic Term, without */ +; /* variables */ +; /* Subst = List of minimal-sized substitutions */ +; /* */ +; /******************************************************************/ +; /* In PROLOG (and first-order logic), a term is recursively */ +; /* defined as being either a constant (in PROLOG a lower-case */ +; /* atom), a variable (in PROLOG a upper-case variable) or a */ +; /* function symbol (in PROLOG a relational expression of the form */ +; /* 'p(a,b, ..., X)') which takes a number of terms as arguments. */ +; /* Substitutions are unique mappings from variables to Terms, in */ +; /* the following denoted by S, and written out as sets of */ +; /* variable/term pairs, such as {A/b,B/f(X)}. When a substitution */ +; /* S is applied to a term t, each variable within t which is an */ +; /* element of the domain of S is replaced by the corresponding */ +; /* term within S. Thus, letting t = f(a,A) and S = {A/b,B/f(X)}, */ +; /* the term tS = f(a,b). */ +; /* The following predicate 'substitution', returns the minimal- */ +; /* sized substitution S such that t1 S = t2, when such a */ +; /* substitution exists, given two terms t1 and t2. */ +; /******************************************************************/ -; (error -; (syntax_error operator_expected) -; (file logic/logic.pl 95 8 5563)) +; (error +; (syntax_error operator_expected) +; (file logic/logic.pl 95 8 5563)) - (= - (skolemize () $N $N) True) -; - - (= - (skolemize - (Cons $Head $Tail) $N $M) - ( (= $Head - ($var $N)) - (skolemize $Tail - (s $N) $M) - (set-det))) -; - - (= - (skolemize - (Cons $Head $Tail) $N $M) - ( (=.. $Head - (Cons $F $Tail1)) - (skolemize $Tail1 $N $O) - (skolemize $Tail $O $M))) -; - + (= (skolemize () $N $N) True) + (= (skolemize (Cons $Head $Tail) $N $M) + (= $Head + ($var $N)) + (skolemize $Tail + (s $N) $M) + (set-det)) + (= (skolemize (Cons $Head $Tail) $N $M) + (=.. $Head + (Cons $F $Tail1)) + (skolemize $Tail1 $N $O) + (skolemize $Tail $O $M)) - (= - (substitute Nil Nil Nil) + (= (substitute Nil Nil Nil) + (set-det)) + (= (substitute (Cons $Head1 $Tail1) (Cons $Head2 $Tail2) (Cons (/ $Head1 $Head2) $Tail3)) + (var $Head1) + (substitute $Tail1 $Tail2 $Tail3) + (set-det)) + (= (substitute (Cons $Head1 $Tail1) (Cons $Head2 $Tail2) $Subst) + (=.. $Head1 + (Cons $F1 $Tail11)) + (=.. $Head2 + (Cons $F1 $Tail22)) + (substitute $Tail11 $Tail22 $Tail33) + (substitute $Tail1 $Tail2 $Tail4) + (append $Tail33 $Tail4 $Subst) (set-det)) -; - (= - (substitute - (Cons $Head1 $Tail1) - (Cons $Head2 $Tail2) - (Cons - (/ $Head1 $Head2) $Tail3)) - ( (var $Head1) - (substitute $Tail1 $Tail2 $Tail3) - (set-det))) -; - (= - (substitute - (Cons $Head1 $Tail1) - (Cons $Head2 $Tail2) $Subst) - ( (=.. $Head1 - (Cons $F1 $Tail11)) - (=.. $Head2 - (Cons $F1 $Tail22)) - (substitute $Tail11 $Tail22 $Tail33) - (substitute $Tail1 $Tail2 $Tail4) - (append $Tail33 $Tail4 $Subst) - (set-det))) -; - - - - (= - (remove-id Nil Nil) + (= (remove-id Nil Nil) (set-det)) -; - - (= - (remove-id - (:: $X) - (:: $X)) + (= (remove-id (:: $X) (:: $X)) (set-det)) -; - - (= - (remove-id - (Cons $A - (Cons $B $Tail)) $List) - ( (== $A $B) - (remove-id - (Cons $A $Tail) $List) - (set-det))) -; - - (= + (= (remove-id (Cons $A (Cons $B $Tail)) $List) + (== $A $B) (remove-id - (Cons $Head1 $Tail1) - (Cons $Head1 $Tail2)) - ( (remove-id $Tail1 $Tail2) (set-det))) -; - - - - (= - (lgg $Term1 $Term2 $Term3) - ( (lgg1 - (:: $Term1) - (:: $Term2) - (:: $Term3) Nil $Subst) (set-det))) -; - - + (Cons $A $Tail) $List) + (set-det)) + (= (remove-id (Cons $Head1 $Tail1) (Cons $Head1 $Tail2)) + (remove-id $Tail1 $Tail2) + (set-det)) - (= - (lgg1 () () () $Subst $Subst) True) -; - (= + (= (lgg $Term1 $Term2 $Term3) (lgg1 - (Cons $Head1 $Tail1) - (Cons $Head2 $Tail2) - (Cons $Head3 $Tail3) $Subst1 $Subst3) - ( (=.. $Head1 - (Cons $F $Tail11)) - (=.. $Head2 - (Cons $F $Tail22)) - (lgg1 $Tail11 $Tail22 $Tail33 $Subst1 $Subst2) - (=.. $Head3 - (Cons $F $Tail33)) - (lgg1 $Tail1 $Tail2 $Tail3 $Subst2 $Subst3) - (set-det))) -; - - (= - (lgg1 - (Cons $Head1 $Tail1) - (Cons $Head2 $Tail2) - (Cons $Head3 $Tail3) $Subst1 $Subst2) - ( (subst-member - (/ $Head3 - (, $Head1 $Head2)) $Subst1) - (lgg1 $Tail1 $Tail2 $Tail3 $Subst1 $Subst2) - (set-det))) -; - - (= - (lgg1 - (Cons $Head1 $Tail1) - (Cons $Head2 $Tail2) - (Cons $Head3 $Tail3) $Subst1 $Subst2) - ( (lgg1 $Tail1 $Tail2 $Tail3 - (Cons - (/ $Head3 - (, $Head1 $Head2)) $Subst1) $Subst2) (set-det))) -; - - + (:: $Term1) + (:: $Term2) + (:: $Term3) Nil $Subst) + (set-det)) +; /******************************************************************/ +; /* */ +; /* call : lgg (+Term1,+Term2,-Term3) */ +; /* */ +; /* arguments : Term1 = first-order logic Term */ +; /* Term2 = first-order logic Term */ +; /* Term3 = generalized first-order logic Term */ +; /* */ +; /******************************************************************/ +; /* We say that term t1 is a 'generalisation of (or subsumes)' t2 */ +; /* iff there exists a substitution S such that t1 S = t2. Also */ +; /* Term t is said to be a 'common generalisation' of terms u and */ +; /* v iff t is a generalisation of u and t is a generalisation of */ +; /* v. In paticular t is the 'least-general-generalisation (lgg)' */ +; /* of u and v iff t is a common generalisation of u and v, and */ +; /* every other common generalisation t' of u and v is also a */ +; /* generalisation of t. */ +; /******************************************************************/ + - (= + (= (lgg1 () () () $Subst $Subst) True) + (= (lgg1 (Cons $Head1 $Tail1) (Cons $Head2 $Tail2) (Cons $Head3 $Tail3) $Subst1 $Subst3) + (=.. $Head1 + (Cons $F $Tail11)) + (=.. $Head2 + (Cons $F $Tail22)) + (lgg1 $Tail11 $Tail22 $Tail33 $Subst1 $Subst2) + (=.. $Head3 + (Cons $F $Tail33)) + (lgg1 $Tail1 $Tail2 $Tail3 $Subst2 $Subst3) + (set-det)) + (= (lgg1 (Cons $Head1 $Tail1) (Cons $Head2 $Tail2) (Cons $Head3 $Tail3) $Subst1 $Subst2) (subst-member - (/ $A $B) + (/ $Head3 + (, $Head1 $Head2)) $Subst1) + (lgg1 $Tail1 $Tail2 $Tail3 $Subst1 $Subst2) + (set-det)) + (= (lgg1 (Cons $Head1 $Tail1) (Cons $Head2 $Tail2) (Cons $Head3 $Tail3) $Subst1 $Subst2) + (lgg1 $Tail1 $Tail2 $Tail3 (Cons - (/ $A $C) $_)) - ( (== $B $C) (set-det))) -; - - (= - (subst-member $A - (Cons $_ $B)) - ( (subst-member $A $B) (set-det))) -; + (/ $Head3 + (, $Head1 $Head2)) $Subst1) $Subst2) + (set-det)) + (= (subst-member (/ $A $B) (Cons (/ $A $C) $_)) + (== $B $C) + (set-det)) + (= (subst-member $A (Cons $_ $B)) + (subst-member $A $B) + (set-det)) - (= - (covers () $_) True) -; - (= + (= (covers () $_) True) +; /******************************************************************/ +; /* */ +; /* call : covers(+Goal,+ClauseList) */ +; /* */ +; /* arguments : Goal = An instance */ +; /* ClauseList = Clauses in a special PROLOG-syntax */ +; /* */ +; /******************************************************************/ +; /* An 'atomic formula' is defined as a predicate symbol which */ +; /* takes a number of terms as arguments (such as "mem(a,[b,a])"). */ +; /* A 'literal' is defined as being either an atomic formula or */ +; /* the negation of an atomic formula (such as "not mem(a,[b,c])". */ +; /* A 'clause' is a 'disjunction' of literals. Thus a clause */ +; /* (L1 \/ L2 \/ ... Ln) can be represented as a set */ +; /* {L1,L2, ... Ln} */ +; /* Given two clauses C and D we say that C is a 'generalisation */ +; /* (or subsumes)' D whenever there is a substitution S such that */ +; /* C S is a subset of or equal to D, w.r.t. a logic program P. */ +; /******************************************************************/ + (= (covers (Cons $H1 $T1) $P) + (member $C1 $P) + (copy $C1 + (= $H1 $B1)) + (covers-body $B1 $P) + (covers $T1 $P)) + + + (= (covers_body true $_) True) + (= (covers-body (, $H $B) $P) + (set-det) (covers - (Cons $H1 $T1) $P) - ( (member $C1 $P) - (copy $C1 - (= $H1 $B1)) - (covers-body $B1 $P) - (covers $T1 $P))) -; - - - - (= - (covers_body true $_) True) -; - - (= - (covers-body - (, $H $B) $P) - ( (set-det) - (covers - (:: $H) $P) - (covers-body $B $P))) -; - - (= - (covers-body $H $P) + (:: $H) $P) + (covers-body $B $P)) + (= (covers-body $H $P) (covers (:: $H) $P)) -; - - (= - (copy $A $B) + (= (copy $A $B) (or (, - (add-symbol &self + (add-is-symbol &self (yap_inst $A)) - (remove-symbol &self + (remove-is-symbol &self (yap_inst $B)) (set-det)) (, - (remove-symbol &self + (remove-is-symbol &self (yap_inst $_)) (fail)))) -; - - (= - (psubsumes $_ Nil) + (= (psubsumes $_ Nil) + (set-det)) +; /******************************************************************/ +; /* */ +; /* call : psubsumes(+PRG1,+PRG2) */ +; /* */ +; /* arguments : PRG1 = A clause set in a special PROLOG-syntax */ +; /* PRG2 = A clause set in a special PROLOG-syntax */ +; /* */ +; /******************************************************************/ +; /* MeTTa programs consist of a restricted form of clause called */ +; /* a 'Horn clause'. Horn clauses contains at most one positive (or*/ +; /* unnegated) literal. The positive literal is written as the */ +; /* 'head' of a MeTTa clause, while the 'body' of a MeTTa clause */ +; /* represents the set of negated literals. The 'goal' of a MeTTa */ +; /* program is simply a clause containing no positive literals. A */ +; /* MeTTa program should be viewed as a conjunction of clauses. */ +; /* This might be represented symbolically as: */ +; /* (C1 /\ C2 /\ ... Cn) or in set notation as */ +; /* {C1,C2,... Cn} */ +; /* Thus an entire MeTTa program can be viewed as a single logical*/ +; /* formula. The following is a simplified restatement of */ +; /* Herbrand's theorem: */ +; /* Given two formulae F1 and F2, F1 is more general than F2 */ +; /* iff for every substitution S, (F1 /\ not(F2)) S is false. */ +; /******************************************************************/ + (= (psubsumes $P (Cons $C $T)) + (bsubsumes $P $C) + (psubsumes $P $T) (set-det)) -; - - (= - (psubsumes $P - (Cons $C $T)) - ( (bsubsumes $P $C) - (psubsumes $P $T) - (set-det))) -; - ; (error ; (syntax_error operator_expected) @@ -250,73 +278,68 @@ - (= - (body-units True Nil) + (= (body-units True Nil) (set-det)) -; - - (= - (body-units - (, $Head1 $Tail1) - (Cons - (= $Head1 True) $Tail2)) - ( (body-units $Tail1 $Tail2) (set-det))) -; - - (= - (body_units $Head - ( (:- $Head true))) True) -; - - - - (= - (goal_units () ()) True) -; - - (= - (goal-units - (Cons $Head1 $Tail1) - (Cons - (= $Head1 True) $Tail2)) - ( (goal-units $Tail1 $Tail2) (set-det))) -; + (= (body-units (, $Head1 $Tail1) (Cons (= $Head1 True) $Tail2)) + (body-units $Tail1 $Tail2) + (set-det)) + (= (body_units $Head ((:- $Head true))) True) + (= (goal_units () ()) True) + (= (goal-units (Cons $Head1 $Tail1) (Cons (= $Head1 True) $Tail2)) + (goal-units $Tail1 $Tail2) + (set-det)) - (= - (p-subsumes $ClauseSet1 $Theory $ClauseSet2) - ( (append $ClauseSet1 $Theory $Program) (psubsumes $Program $ClauseSet2))) -; + (= (p-subsumes $ClauseSet1 $Theory $ClauseSet2) + (append $ClauseSet1 $Theory $Program) + (psubsumes $Program $ClauseSet2)) +; /******************************************************************/ +; /* */ +; /* call : p_subsumes(+ClauseSet1,+Theory,+ClauseSet2) */ +; /* */ +; /* arguments : ClauseSet1 = A set of clauses PROLOG-syntax */ +; /* ClauseSet2 = A set of clauses PROLOG-syntax */ +; /* Theory = A set of clauses PROLOG-syntax */ +; /* */ +; /******************************************************************/ +; /* This procedure implements the generalized subsumption between */ +; /* two clause sets, w.r.t. a background theory. */ +; /******************************************************************/ - (= - (p-equivalent $ClauseSet1 $Theory $ClauseSet2) - ( (append $ClauseSet1 $Theory $Program1) - (psubsumes $Program1 $ClauseSet2) - (append $ClauseSet2 $Theory $Program2) - (psubsumes $Program2 $ClauseSet1))) -; - + (= (p-equivalent $ClauseSet1 $Theory $ClauseSet2) + (append $ClauseSet1 $Theory $Program1) + (psubsumes $Program1 $ClauseSet2) + (append $ClauseSet2 $Theory $Program2) + (psubsumes $Program2 $ClauseSet1)) +; /******************************************************************/ +; /* */ +; /* call : p_subsumes(+ClauseSet1,+Theory,+ClauseSet2) */ +; /* */ +; /* arguments : ClauseSet1 = A set of clauses PROLOG-syntax */ +; /* ClauseSet2 = A set of clauses PROLOG-syntax */ +; /* Theory = A set of clauses PROLOG-syntax */ +; /* */ +; /******************************************************************/ +; /* This procedure implements equivalence based on the generalized */ +; /* subsumption between two clause sets, w.r.t. a background */ +; /* theory. */ +; /******************************************************************/ - (= - (help) - ( (write 'Load example calls with command: [Filename].') - (nl) - (write 'Call examples with: test1, test2, test3a, test3b,') - (nl) - (write ' test4a, test4b, test4c, test4d, test5') - (nl))) -; - + (= (help) + (write 'Load example calls with command: [Filename].') + (nl) + (write 'Call examples with: test1, test2, test3a, test3b,') + (nl) + (write ' test4a, test4b, test4c, test4d, test5') + (nl)) !(help *) -; - diff --git a/logic/logic_1.metta b/logic/logic_1.metta index 1a58963..9aed8a0 100644 --- a/logic/logic_1.metta +++ b/logic/logic_1.metta @@ -1,157 +1,107 @@ - - (= - (test1) - ( (substitution - (f - (g $A) $B) - (f - (g (h a)) - (i b)) $ERG) - (write $ERG) - (nl))) -; - - - - (= - (test2) - ( (lgg - (f - (g 3) 3 - (j 6)) - (f - (g 2) 2 - (j (h 6))) $ERG) - (write $ERG) - (nl))) -; - - - - (= - (test3a) +; (convert_to_metta_file logic_1 $_112516 logic/logic_1.pl logic/logic_1.metta) + + (= (test1) + (substitution + (f + (g $A) $B) + (f + (g (h a)) + (i b)) $ERG) + (write $ERG) + (nl)) + + + (= (test2) + (lgg + (f + (g 3) 3 + (j 6)) + (f + (g 2) 2 + (j (h 6))) $ERG) + (write $ERG) + (nl)) + + + (= (test3a) (covers (:: (mem 3 (:: 4 3))) (:: - (= - (mem $A - (Cons $A $_)) True) - (= - (mem $A - (Cons $_ $B)) + (= (mem $A (Cons $A $_)) True) + (= (mem $A (Cons $_ $B)) (mem $A $B))))) -; - - (= - (test3b) + (= (test3b) (covers (:: (mem 3 (:: 4 5))) (:: - (= - (mem $A - (Cons $A $_)) True) - (= - (mem $A - (Cons $_ $B)) + (= (mem $A (Cons $A $_)) True) + (= (mem $A (Cons $_ $B)) (mem $A $B))))) -; - - (= - (test4a) + (= (test4a) (psubsumes (:: - (= - (mem $A - (Cons $A $_)) True) - (= - (mem $B - (Cons $_ $C)) + (= (mem $A (Cons $A $_)) True) + (= (mem $B (Cons $_ $C)) (mem $B $C))) - (:: (= (mem $D (Cons $_ (Cons $_ $E))) (mem $D $E))))) -; + (:: (= (mem $D (Cons $_ (Cons $_ $E))) + (mem $D $E))))) - - (= - (test4b) + (= (test4b) (psubsumes (:: - (= - (mem $A - (Cons $A $_)) True) - (= - (mem $B - (Cons $_ $C)) + (= (mem $A (Cons $A $_)) True) + (= (mem $B (Cons $_ $C)) (mem $B $C))) (:: - (= - (mem $D - (Cons $_ - (Cons $_ $E))) + (= (mem $D (Cons $_ (Cons $_ $E))) (mem $D $E)) - (= - (mem $D - (Cons $_ - (Cons $_ - (Cons $_ $E)))) + (= (mem $D (Cons $_ (Cons $_ (Cons $_ $E)))) (mem $D $E))))) -; - - (= - (test4c) + (= (test4c) (psubsumes (:: - (= - (mem $A - (Cons $A $_)) True) - (= - (mem $B - (Cons $_ $C)) + (= (mem $A (Cons $A $_)) True) + (= (mem $B (Cons $_ $C)) (mem $B $C))) - (:: (= (mem $D (Cons $_ (Cons $_ $E))) (mem $X $E))))) -; + (:: (= (mem $D (Cons $_ (Cons $_ $E))) + (mem $X $E))))) - - (= - (test4d) + (= (test4d) (psubsumes - (:: (= (mem $B (Cons $_ $C)) (mem $B $C))) - (:: (= (mem $D (Cons $_ (Cons $_ $E))) (mem $D $E))))) -; - + (:: (= (mem $B (Cons $_ $C)) + (mem $B $C))) + (:: (= (mem $D (Cons $_ (Cons $_ $E))) + (mem $D $E))))) - (= - (test5) + (= (test5) (p-subsumes - (:: (= (cuddly-pet $X) ((small $X) (fluffy $X) (pet $X)))) + (:: (= (cuddly-pet $X) + (small $X) + (fluffy $X) + (pet $X))) (:: - (= - (pet $X) + (= (pet $X) (cat $X)) - (= - (pet $X) + (= (pet $X) (dog $X)) - (= - (small $X) + (= (small $X) (cat $X))) (:: - (= - (cuddly-pet $X) - ( (small $X) - (fluffy $X) - (dog $X))) - (= - (cuddly-pet $X) - ( (fluffy $X) (cat $X)))))) -; - + (= (cuddly-pet $X) + (small $X) + (fluffy $X) + (dog $X)) + (= (cuddly-pet $X) + (fluffy $X) + (cat $X))))) diff --git a/metagame/comms/chesstalk.metta b/metagame/comms/chesstalk.metta index e41a8b0..b163e75 100644 --- a/metagame/comms/chesstalk.metta +++ b/metagame/comms/chesstalk.metta @@ -1,864 +1,484 @@ +; (convert_to_metta_file chesstalk $_193886 metagame/comms/chesstalk.pl metagame/comms/chesstalk.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ; pattern.pl !(ensure-loaded (library pipes)) -; - - (= - (create) - ( (global chessprog $Prog) (create $Prog))) -; - + (= (create) + (global chessprog $Prog) + (create $Prog)) - (= - (create $Player) - ( (player-command $Player $Command) (talk-interface $Command))) -; - + (= (create $Player) + (player-command $Player $Command) + (talk-interface $Command)) - (= - (player-command gnu $Command) + (= (player-command gnu $Command) (gnu-command $Command)) -; - - (= - (player-command morph $Command) + (= (player-command morph $Command) (morph-command $Command)) -; - - (= - (gnu-command $Command) + (= (gnu-command $Command) (command-from-args (:: nice -10 gnuchess) $Command)) -; - - (= - (morph-command $Command) - ( (morph-setup-file $File) (command-from-args (:: '( cd ~/Morph/ ; nice -5 morph -q -wh -f' $File )) $Command))) -; - + (= (morph-command $Command) + (morph-setup-file $File) + (command-from-args + (:: '( cd ~/Morph/ ; nice -5 morph -q -wh -f' $File )) $Command)) +; ; command_from_args(['( cd ~/Morph/ ; nice -5 morph -wh -f morphstart )'],Command). - (= - (tellm $S) + (= (tellm $S) (tell-chess $S)) -; - - (= - (seem) + (= (seem) (see-chess)) -; - - (= - (tell-chess $Statement) + (= (tell-chess $Statement) (tell-outstream $Statement)) -; + (= (see-chess) + (global instream $I) + (set-input $I)) - (= - (see-chess) - ( (global instream $I) (set-input $I))) -; - - - - (= - (morph-setup-file $File) - ( (global handicap $File) (set-det))) -; - - (= - (morph_setup_file morphstart) True) -; + (= (morph-setup-file $File) + (global handicap $File) + (set-det)) + (= (morph_setup_file morphstart) True) ; -; - +; If there is a winning move, assume the opponent will play it, ; -; - - - (= - (chess-choose $Player $Move $SIn $SOut) - ( (victor-move $Move $SIn $SOut) - (set-det) - (format "King is in check; Game over!~n" Nil))) -; +; as you can't legally leave your king in check in real chess. - (= - (chess-choose $Player $Move $SIn $SOut) + (= (chess-choose $Player $Move $SIn $SOut) + (victor-move $Move $SIn $SOut) + (set-det) + (format "King is in check; Game over!~n" Nil)) + (= (chess-choose $Player $Move $SIn $SOut) (chess-choose-real $Player $Move $SIn $SOut)) -; - - - - (= - (chess-choose-real $Player $Move $SIn $SOut) - ( (update-chess $Player $SIn) - (current-input $OldStream) - (global instream $I) - (set-input $I) - (det-if-then-else - (chess-move $Player $_ $MoveString) - (, - (set-input $OldStream) - (det-if-then-else - (completed-move $MoveString $Move $SIn $SOut) - (print-choice $Move $SIn $SOut) - (, - (format "Strange string: ~w~n" - (:: $MoveString)) - (fail)))) - (, - (set-input $OldStream) - (fail))))) -; - + (= (chess-choose-real $Player $Move $SIn $SOut) + (update-chess $Player $SIn) + (current-input $OldStream) + (global instream $I) + (set-input $I) + (det-if-then-else + (chess-move $Player $_ $MoveString) + (, + (set-input $OldStream) + (det-if-then-else + (completed-move $MoveString $Move $SIn $SOut) + (print-choice $Move $SIn $SOut) + (, + (format "Strange string: ~w~n" + (:: $MoveString)) + (fail)))) + (, + (set-input $OldStream) + (fail)))) - (= - (init-chess-if $Role $SIn) - ( (should-init $Role $SIn) - (set-det) - (init-chess $Role $SIn))) -; - (= - (init_chess_if $Role $SIn) True) -; + (= (init-chess-if $Role $SIn) + (should-init $Role $SIn) + (set-det) + (init-chess $Role $SIn)) + (= (init_chess_if $Role $SIn) True) ; -; - +; If SETUP global was set to yes, then setup the ; -; +; pos, and reset it to no so we don't set it up each time! + (= (should-init $Role $SIn) + (move-count $N $SIn) + (< $N 2)) + (= (should-init $Role $SIn) + (global setup yes) + (setg setup no)) - (= - (should-init $Role $SIn) - ( (move-count $N $SIn) (< $N 2))) -; - - (= - (should-init $Role $SIn) - ( (global setup yes) (setg setup no))) -; + (= (init-chess $Role $SIn) + (global chessprog $Prog) + (init-prog $Prog $Role $SIn)) - (= - (init-chess $Role $SIn) - ( (global chessprog $Prog) (init-prog $Prog $Role $SIn))) -; - - - - - (= - (update-chess $Role $SIn) - ( (init-chess-if $Role $SIn) - (det-if-then-else - (last-move $Move) - (, - (meta-to-chess $Move $ChMove) - (format "To Chess: I played ~w~n" - (:: $ChMove)) - (= $ChMove $TellMove) - (tell-chess (:: $TellMove))) True) - (tell-chess-move))) -; - + (= (update-chess $Role $SIn) + (init-chess-if $Role $SIn) + (det-if-then-else + (last-move $Move) + (, + (meta-to-chess $Move $ChMove) + (format "To Chess: I played ~w~n" + (:: $ChMove)) + (= $ChMove $TellMove) + (tell-chess (:: $TellMove))) True) + (tell-chess-move)) +; ; ( N < 2 -> init_chess(Role,SIn) ; true), - (= tell_chess_move True) -; + (= tell_chess_move True) - (= - (flush-chess) - ( (global chessprog $Prog) (flush-prog $Prog))) -; + (= (flush-chess) + (global chessprog $Prog) + (flush-prog $Prog)) - - (= - (flush-prog gnu) + (= (flush-prog gnu) (tell-chess (:: bd))) -; - - (= - (flush_prog morph) True) -; - + (= (flush_prog morph) True) ; -; - +; This doesn't work, as gnuchess just plays if you tell it to, ; -; - +; regardless of whos move it is in the position! ; -; +; So Don't tell chess anything. - - (= - (chess-prompt $Player) + (= (chess-prompt $Player) (flush-chess)) -; - ; -; - +; player_color(Player,Color), ; -; - +; tell_chess([Color]). - (= - (meta-to-chess $Move $ChMove) - ( (chess-notation $Move $String) (concat-list $String $ChMove))) -; - - + (= (meta-to-chess $Move $ChMove) + (chess-notation $Move $String) + (concat-list $String $ChMove)) - (= - (chess-move $Player $Number $Move) - ( (chess-prompt $Player) - (chess-read $Number $FullMove) - (set-det) - (format "~s" - (:: $FullMove)) - (player-indent $Player $Indent) - (append $Indent $Move0 $FullMove) - (chess-to-meta $Move0 $Move))) -; + (= (chess-move $Player $Number $Move) + (chess-prompt $Player) + (chess-read $Number $FullMove) + (set-det) + (format "~s" + (:: $FullMove)) + (player-indent $Player $Indent) + (append $Indent $Move0 $FullMove) + (chess-to-meta $Move0 $Move)) - (= - (chess-header-string $Pattern) + (= (chess-header-string $Pattern) (append-list (:: "My move is: ") $Pattern)) -; - - - (= - (chess-read $Number $Move) - ( (chess-header-string $String) - (read-until-string $String) - (read-template $Move))) -; - + (= (chess-read $Number $Move) + (chess-header-string $String) + (read-until-string $String) + (read-template $Move)) - (= - (read-template $Move) - ( (global chessprog $Prog) (read-template $Prog $Move))) -; + (= (read-template $Move) + (global chessprog $Prog) + (read-template $Prog $Move)) +; ; read_line(Move), - (= - (read-template gnu $Move) + (= (read-template gnu $Move) (read-four $Move)) -; - - (= - (read-template morph $Move) + (= (read-template morph $Move) (read-five $Move)) -; - - (= - (read-four (:: $A $B $C $D)) - ( (get0 $A) - (get0 $B) - (get0 $C) - (get0 $D))) -; + (= (read-four (:: $A $B $C $D)) + (get0 $A) + (get0 $B) + (get0 $C) + (get0 $D)) + (= (read-five (:: $A $B $C $D)) + (get0 $A) + (get0 $B) + (get0 $_) + (get0 $C) + (get0 $D)) - (= - (read-five (:: $A $B $C $D)) - ( (get0 $A) - (get0 $B) - (get0 $_) - (get0 $C) - (get0 $D))) -; + (= (player_indent $_ "") True) - (= - (player_indent $_ "") True) -; - - - - (= - (chess-to-meta $A $B) + (= (chess-to-meta $A $B) (chess-to-meta $B $A Nil)) -; + (= (--> (chess_to_meta ()) ()) True) + (= (--> (chess_to_meta (Cons $XM (Cons $YM $Sqs))) (, ($X) (, ($Y) (, {(chess_conv_square $X $Y $XM $YM) } (chess_rest $Sqs))))) True) - (= - (--> - (chess_to_meta ()) ()) True) -; + (= (--> (chess_rest ()) ()) True) + (= (--> (chess_rest $Sqs) (, () (chess_to_meta $Sqs))) True) - (= - (--> - (chess_to_meta - (Cons $XM - (Cons $YM $Sqs))) - (, - ($X) - (, - ($Y) - (, - { (chess_conv_square $X $Y $XM $YM) } - (chess_rest $Sqs))))) True) -; - (= - (--> - (chess_rest ()) ()) True) -; - - (= - (--> - (chess_rest $Sqs) - (, () - (chess_to_meta $Sqs))) True) -; - - - - - (= - (chess-conv-square $X $Y $XM $YM) - ( (name $XM - (:: $X)) (name $YM (:: $Y)))) -; - + (= (chess-conv-square $X $Y $XM $YM) + (name $XM + (:: $X)) + (name $YM + (:: $Y))) - (= - (conv-x $X $XM) + (= (conv-x $X $XM) (is $XM (+ (- "h" $X) "a"))) -; - - (= - (conv-y $Y $YM) + (= (conv-y $Y $YM) (is $YM (+ (- "8" $Y) "1"))) -; - ; -; - +; ====================================================================== ; -; - - - (= - (chess-notation $ComplexMove $Notation) - ( (det-if-then-else - (var $ComplexMove) set-parsing-mode True) (chess-notation $ComplexMove $Notation Nil))) -; - +; Ensures parsing mode if really parsing, as otherwise get strange bugs. + (= (chess-notation $ComplexMove $Notation) + (det-if-then-else + (var $ComplexMove) set-parsing-mode True) + (chess-notation $ComplexMove $Notation Nil)) - (= - (--> - (chess_notation $M) - (, - (prelims $M $Pre) - (chess_main $Pre ()))) True) -; + (= (--> (chess_notation $M) (, (prelims $M $Pre) (chess_main $Pre ()))) True) ; -; +; CONSIDER_PROMOTE + (= (--> (chess_consider_promote (Cons $T $Sel) $Rest) (, (chess_attempt_promote $T) (chess_select_promote $Sel $Rest))) True) - (= - (--> - (chess_consider_promote - (Cons $T $Sel) $Rest) - (, - (chess_attempt_promote $T) - (chess_select_promote $Sel $Rest))) True) -; - - - - (= - (--> - (chess_select_promote - (Cons - (promote_select $Square $OldPiece $OldPiece) $Rest) $Rest) ()) True) -; - - (= - (--> - (chess_select_promote - (Cons - (promote_select $Square $OldPiece $NewPiece) $Rest) $Rest) - (, - { (, - (\== $OldPiece $NewPiece) - (, - (piece_struct_name $NewPiece $Name) - (, - (name $Name - (Cons $NewC $_)) - (name $NewL - ($NewC))))) } - ($NewL))) True) -; - - (= - (--> - (chess_select_promote $Rest $Rest) ()) True) -; + (= (--> (chess_select_promote (Cons (promote_select $Square $OldPiece $OldPiece) $Rest) $Rest) ()) True) + (= (--> (chess_select_promote (Cons (promote_select $Square $OldPiece $NewPiece) $Rest) $Rest) (, {(, (\== $OldPiece $NewPiece) (, (piece_struct_name $NewPiece $Name) (, (name $Name (Cons $NewC $_)) (name $NewL ($NewC))))) } ($NewL))) True) + (= (--> (chess_select_promote $Rest $Rest) ()) True) ; -; - +; ATTEMPT_PROMOTE ; -; - +; attempt_promote(try_promote(square(5,1),piece(piece2,player),piece(piece3,player))) ; -; - +; --> [promote,'(',5,',',1,')',white,piece3,';'] ; -; - - (= - (--> - (chess_attempt_promote - (try_promote $Square $OldPiece ())) ()) True) -; - - (= - (--> - (chess_attempt_promote - (try_promote $Square $OldPiece $OldPiece)) ()) True) -; - +; Unless it promotes, it isn't mentioned in the notation. + (= (--> (chess_attempt_promote (try_promote $Square $OldPiece ())) ()) True) + (= (--> (chess_attempt_promote (try_promote $Square $OldPiece $OldPiece)) ()) True) ; -; - +; MAIN ; -; - - (= - (--> - (chess_main $In $Out) - (, - (chess_first_transfer $In $First) - (, - (chess_continued_transfers $First $T) - (chess_consider_promote $T $Out)))) True) -; - +; Repeated Transfers, followed by possible player promotion. + (= (--> (chess_main $In $Out) (, (chess_first_transfer $In $First) (, (chess_continued_transfers $First $T) (chess_consider_promote $T $Out)))) True) ; -; - - (= - (--> - (chess_transfers $In $Out) - (, - (chess_transfer $In $T) - (chess_continued_transfers $T $Out))) True) -; - +; TRANSFERS + (= (--> (chess_transfers $In $Out) (, (chess_transfer $In $T) (chess_continued_transfers $T $Out))) True) ; -; - +; CONTINUED_TRANSFERS ; -; - +; Either no more transfers, or ';' and more transfers. ; -; - - (= - (--> - (chess_continued_transfers $In $In) ()) True) -; - - (= - (--> - (chess_continued_transfers - (Cons end_continues $Rest) $Rest) ()) True) -; - - (= - (--> - (chess_continued_transfers $In $Out) - (chess_transfers $In $Out)) True) -; - +; Could tighten this rule: can't continue unless did a movement. + (= (--> (chess_continued_transfers $In $In) ()) True) + (= (--> (chess_continued_transfers (Cons end_continues $Rest) $Rest) ()) True) + (= (--> (chess_continued_transfers $In $Out) (chess_transfers $In $Out)) True) ; -; - +; TRANSFER : [move(piece(piece6,player),player,square(5,1),square(4,1)), ; -; - +; remove(piece(piece6,player),square(4,1))] ; -; - +; --> [white,piece6,'(',5,',',1,')',->,'(',4,',',1,')',x,'(',4,',',1,')'] ; ; + (= (--> (chess_transfer (Cons $Move $Capture) $Rest) (, (chess_moving $Move) (chess_capture $Capture $Rest))) True) - (= - (--> - (chess_transfer - (Cons $Move $Capture) $Rest) - (, - (chess_moving $Move) - (chess_capture $Capture $Rest))) True) -; - - - (= - (--> - (chess_first_transfer - (Cons $Move $Capture) $Rest) - (, - (chess_first_moving $Move) - (chess_capture $Capture $Rest))) True) -; - + (= (--> (chess_first_transfer (Cons $Move $Capture) $Rest) (, (chess_first_moving $Move) (chess_capture $Capture $Rest))) True) ; -; - +; MOVING ; -; - +; moving(move(piece(piece1,opponent),opponent,square(1,6),square(2,4)),S,[]). ; -; - - (= - (--> - (chess_first_moving - (move $Piece $Player $From $To)) - (, - (chess_square $From) - (chess_square $To))) True) -; +; S = [black,piece1,'(',1,',',6,')',->,'(',2,',',4,')'] + (= (--> (chess_first_moving (move $Piece $Player $From $To)) (, (chess_square $From) (chess_square $To))) True) + (= (--> (chess_moving (move $Piece $Player $From $To)) (chess_square $To)) True) - (= - (--> - (chess_moving - (move $Piece $Player $From $To)) - (chess_square $To)) True) -; + (= (--> (chess_capture $In $Out) (chess_null_capture $In $Out)) True) + (= (--> (chess_capture $In $Out) (chess_real_capture $In $Out)) True) + (= (--> (chess_null_capture $X $X) ()) True) - (= - (--> - (chess_capture $In $Out) - (chess_null_capture $In $Out)) True) -; - - (= - (--> - (chess_capture $In $Out) - (chess_real_capture $In $Out)) True) -; - - - (= - (--> - (chess_null_capture $X $X) ()) True) -; - - - (= - (--> - (chess_real_capture - (Cons $C $Cs) $Rest) - (, - (chess_simp_capture $C) - (chess_capture $Cs $Rest))) True) -; - - - (= - (--> - (chess_simp_capture $M) - (chess_remove $M)) True) -; - - (= - (--> - (chess_simp_capture $M) - (chess_possess $M)) True) -; + (= (--> (chess_real_capture (Cons $C $Cs) $Rest) (, (chess_simp_capture $C) (chess_capture $Cs $Rest))) True) + (= (--> (chess_simp_capture $M) (chess_remove $M)) True) + (= (--> (chess_simp_capture $M) (chess_possess $M)) True) ; -; - - (= - (--> - (chess_remove - (capture remove $Caps)) ()) True) -; - +; REMOVE + (= (--> (chess_remove (capture remove $Caps)) ()) True) ; -; - - (= - (--> - (chess_possess - (capture - (possess $Player) $Caps)) ()) True) -; - - +; POSSESS + (= (--> (chess_possess (capture (possess $Player) $Caps)) ()) True) - (= - (--> - (chess_square $Sq) - (, - { (square $Sq $X $Y) } - (, - ($Col) - (, - { (nth_letter $X $Col) } - (number $Y))))) True) -; + (= (--> (chess_square $Sq) (, {(square $Sq $X $Y) } (, ($Col) (, {(nth_letter $X $Col) } (number $Y))))) True) ; -; - +; ================================================================================ ; -; - +; User Interface ; -; +; ================================================================================ - - (= - (create-top) + (= (create-top) (create)) -; - - (= - (square-chess-name $Player $Sq $Name) + (= (square-chess-name $Player $Sq $Name) (square-chess-name $Player $Sq $Name $S)) -; - - - (= - (square-chess-name $Player $Sq $Name $S) - ( (player-role $Player) - (det-if-then-else - (var $S) - (checkpoint init $S) True) - (on $Piece $Sq $S) - (piece-struct-name $Piece $PName) - (piece-struct-owner $Piece $Player) - (player-piece-print-name $Player $PName $ChessName) - (chess-square $Sq $ChessSq Nil) - (concat-list - (Cons $ChessName $ChessSq) $Name))) -; - + (= (square-chess-name $Player $Sq $Name $S) + (player-role $Player) + (det-if-then-else + (var $S) + (checkpoint init $S) True) + (on $Piece $Sq $S) + (piece-struct-name $Piece $PName) + (piece-struct-owner $Piece $Player) + (player-piece-print-name $Player $PName $ChessName) + (chess-square $Sq $ChessSq Nil) + (concat-list + (Cons $ChessName $ChessSq) $Name)) - (= - (setup-gnu $S) - ( (tell-chess (:: edit)) - (tell-chess (:: #)) - (whenever - (square-chess-name player $_ $Name $S) - (tell-chess (:: $Name))) - (tell-chess (:: c)) - (whenever - (square-chess-name opponent $_ $Name $S) - (tell-chess (:: $Name))) - (tell-chess (:: .)))) -; + (= (setup-gnu $S) + (tell-chess (:: edit)) + (tell-chess (:: #)) + (whenever + (square-chess-name player $_ $Name $S) + (tell-chess (:: $Name))) + (tell-chess (:: c)) + (whenever + (square-chess-name opponent $_ $Name $S) + (tell-chess (:: $Name))) + (tell-chess (:: .))) - (= - (init_prog morph $Role $SIn) True) -; - + (= (init_prog morph $Role $SIn) True) ; -; - +; Careful when letting gnu play white in typical startup chess ; -; - - (= - (init-prog gnu $Role $S) - ( (global handicap $H) - (> $H 0) - (set-det) - (tell-chess (:: 1)) - (tell-chess (:: new)) - (setup-gnu $S) - (set-gnu-depth) - (init-gnu-role $Role))) -; +; positions, as he thinks kings can castle! + (= (init-prog gnu $Role $S) + (global handicap $H) + (> $H 0) + (set-det) + (tell-chess (:: 1)) + (tell-chess (:: new)) + (setup-gnu $S) + (set-gnu-depth) + (init-gnu-role $Role)) - - (= - (set-gnu-depth) + (= (set-gnu-depth) (det-if-then-else (global depth $D) (set-gnu-depth $D) True)) -; - - (= - (set-gnu-depth $DNum) - ( (number-chars $DNum $Chars) - (atom-chars $D $Chars) - (tell-chess (:: depth)) - (tell-chess (:: $D)))) -; + (= (set-gnu-depth $DNum) + (number-chars $DNum $Chars) + (atom-chars $D $Chars) + (tell-chess (:: depth)) + (tell-chess (:: $D))) - - (= - (init-gnu-role $Role) - ( (player-color $Role $Color) (tell-chess (:: $Color)))) -; - + (= (init-gnu-role $Role) + (player-color $Role $Color) + (tell-chess (:: $Color))) ; -; - +; init_gnu_role(player) :- tell_chess([switch]). ; -; - +; init_gnu_role(opponent). - (= - (tell-com $_ $_ $_ $X) + (= (tell-com $_ $_ $_ $X) (tell-chess $X)) -; - +; /* init_prog(gnu,Role) :- tell_chess(['1']), tell_chess([new]), tell_chess([get]), tell_chess(['metastart.game']), tell_chess(['']), init_gnu_role(Role). init_gnu_role(player) :- tell_chess([switch]). init_gnu_role(opponent). */ +; /* init_prog(gnu,Role,_S) :- tell_chess(['1']), tell_chess([new]), tell_chess([get]), tell_chess(['metastart.game']), tell_chess(['']), init_gnu_role(Role). */ +; ;========================================================================== - (= - (tell-top $X) + (= (tell-top $X) (tell-chess $X)) -; - - (= - (depth-com $_ $_ $_ $X) + (= (depth-com $_ $_ $_ $X) (set-gnu-depth $X)) -; - - (= - (depth-top $X) + (= (depth-top $X) (set-gnu-depth $X)) -; - diff --git a/metagame/comms/chinook.metta b/metagame/comms/chinook.metta index 884757d..5be6829 100644 --- a/metagame/comms/chinook.metta +++ b/metagame/comms/chinook.metta @@ -1,549 +1,289 @@ +; (convert_to_metta_file chinook $_406466 metagame/comms/chinook.pl metagame/comms/chinook.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ !(ensure-loaded (library pipes)) -; - - (= - (create-chinook) - ( (command-from-args - (:: nice -10 chinook) $Command) (interface-record-streams $Command $InStream $OutStream))) -; + (= (create-chinook) + (command-from-args + (:: nice -10 chinook) $Command) + (interface-record-streams $Command $InStream $OutStream)) - - (= - (tell-chinook $Statement) + (= (tell-chinook $Statement) (tell-outstream $Statement)) -; - - (= - (tellc $S) + (= (tellc $S) (tell-chinook $S)) -; - - (= - (seem) - ( (global instream $I) (set-input $I))) -; - + (= (seem) + (global instream $I) + (set-input $I)) ; -; - - - - (= - (chinook-quit) - ( (tell-chinook (:: q)) (interface-close-streams))) -; +; ; pattern.pl + (= (chinook-quit) + (tell-chinook (:: q)) + (interface-close-streams)) - (= - (chinook-choose $Player $Move $SIn $SOut) - ( (update-chinook $Player $SIn) - (current-input $OldStream) - (global instream $I) - (set-input $I) - (det-if-then-else - (chinook-move $Player $_ $MoveString) - (, - (set-input $OldStream) - (completed-move $MoveString $Move $SIn $SOut) - (print-choice $Move $SIn $SOut)) - (, - (set-input $OldStream) - (tell-chinook (:: O)) - (chinook-choose $Player $Move $SIn $SOut))))) -; + (= (chinook-choose $Player $Move $SIn $SOut) + (update-chinook $Player $SIn) + (current-input $OldStream) + (global instream $I) + (set-input $I) + (det-if-then-else + (chinook-move $Player $_ $MoveString) + (, + (set-input $OldStream) + (completed-move $MoveString $Move $SIn $SOut) + (print-choice $Move $SIn $SOut)) + (, + (set-input $OldStream) + (tell-chinook (:: O)) + (chinook-choose $Player $Move $SIn $SOut)))) !(add-global handicap 0) -; - - (= - (setup-chinook) - ( (global handicap $H) - (tell-chinook (:: i)) - (config $H))) -; - + (= (setup-chinook) + (global handicap $H) + (tell-chinook (:: i)) + (config $H)) ; -; - +; handicap_position(N,Init,Pos,Command) :- - (= - (config 0) True) -; - - (= - (config 1) + (= (config 0) True) + (= (config 1) (tell-chinook rb6)) -; - - (= - (config 2) + (= (config 2) (tell-chinook rb6rd6)) -; - - (= - (config 3) + (= (config 3) (tell-chinook rb6rd6rf6)) -; - - (= - (config 4) + (= (config 4) (tell-chinook rb6rd6rf6rh6)) -; - - (= - (config 8) - ( (tell-chinook rb6rd6rf6rh6) (tell-chinook ra7rc7re7rg7))) -; + (= (config 8) + (tell-chinook rb6rd6rf6rh6) + (tell-chinook ra7rc7re7rg7)) - - (= - (update-chinook $Role $SIn) - ( (move-count $N $SIn) - (det-if-then-else - (< $N 2) setup-chinook True) - (det-if-then-else - (last-move $Move) - (, - (meta-to-ch $Move $ChMove) - (format "To Chinook: I played ~w~n" - (:: $ChMove)) - (concat m $ChMove $TellMove) - (tell-chinook (:: $TellMove))) True) - (tell-chinook-move))) -; + (= (update-chinook $Role $SIn) + (move-count $N $SIn) + (det-if-then-else + (< $N 2) setup-chinook True) + (det-if-then-else + (last-move $Move) + (, + (meta-to-ch $Move $ChMove) + (format "To Chinook: I played ~w~n" + (:: $ChMove)) + (concat m $ChMove $TellMove) + (tell-chinook (:: $TellMove))) True) + (tell-chinook-move)) - - (= - (tell-chinook-move) + (= (tell-chinook-move) (tell-chinook (:: g))) -; - - (= - (meta-to-ch $Move $ChMove) - ( (ch-notation $Move $String) (concat-list $String $ChMove))) -; - + (= (meta-to-ch $Move $ChMove) + (ch-notation $Move $String) + (concat-list $String $ChMove)) - (= - (chinook-move $Player $Number $Move) - ( (chinook-read $Number $FullMove) - (set-det) - (format $FullMove Nil) - (player-indent $Player $Indent) - (append $Indent $Move0 $FullMove) - (ch-to-meta $Move0 $Move))) -; - + (= (chinook-move $Player $Number $Move) + (chinook-read $Number $FullMove) + (set-det) + (format $FullMove Nil) + (player-indent $Player $Indent) + (append $Indent $Move0 $FullMove) + (ch-to-meta $Move0 $Move)) ; -; - +; append(Move0,".",Move1), ; -; - +; tokenize_chars(Move1,Move). - (= - (chinook-read $Number $Move) - ( (append-list - (:: "I move") $Pattern) - (format "Looking for pattern: ~w~n" - (:: $Pattern)) - (found $Pattern) - (read-keyboard-tokens (:: $Number $_)) - (read-line $Move))) -; - - - - (= - (player_indent player " ") True) -; + (= (chinook-read $Number $Move) + (append-list + (:: "I move") $Pattern) + (format "Looking for pattern: ~w~n" + (:: $Pattern)) + (found $Pattern) + (read-keyboard-tokens (:: $Number $_)) + (read-line $Move)) +; ; append_list(["I move ",[Num],". "],Pattern), - (= - (player_indent opponent " ... ") True) -; + (= (player_indent player " ") True) + (= (player_indent opponent " ... ") True) ; -; - +; chmv([],[]) --> []. ; -; +; chmv([C|Cs],[M|Ms]) --> + (= (ch_to_meta () ()) True) + (= (ch-to-meta (Cons $X (Cons $Y $Rest)) (Cons $XM (Cons $YM $RestM))) + (conv-square $X $Y $XM $YM) + (ch-to-meta $Rest $RestM)) - (= - (ch_to_meta () ()) True) -; - (= - (ch-to-meta - (Cons $X - (Cons $Y $Rest)) - (Cons $XM - (Cons $YM $RestM))) - ( (conv-square $X $Y $XM $YM) (ch-to-meta $Rest $RestM))) -; - - - - (= - (conv-square $X $Y $XM $YM) - ( (conv-x $X $XM1) - (conv-y $Y $YM1) - (name $XM - (:: $XM1)) - (name $YM - (:: $YM1)))) -; + (= (conv-square $X $Y $XM $YM) + (conv-x $X $XM1) + (conv-y $Y $YM1) + (name $XM + (:: $XM1)) + (name $YM + (:: $YM1))) - - (= - (conv-x $X $XM) + (= (conv-x $X $XM) (is $XM (+ (- "h" $X) "a"))) -; - - (= - (conv-y $Y $YM) + (= (conv-y $Y $YM) (is $YM (+ (- "8" $Y) "1"))) -; - ; -; - +; ====================================================================== ; -; - - - (= - (ch-notation $ComplexMove $Notation) - ( (det-if-then-else - (var $ComplexMove) set-parsing-mode True) (ch-notation $ComplexMove $Notation Nil))) -; - +; Ensures parsing mode if really parsing, as otherwise get strange bugs. + (= (ch-notation $ComplexMove $Notation) + (det-if-then-else + (var $ComplexMove) set-parsing-mode True) + (ch-notation $ComplexMove $Notation Nil)) - (= - (--> - (ch_notation $M) - (, - (prelims $M $Pre) - (ch_main $Pre ()))) True) -; + (= (--> (ch_notation $M) (, (prelims $M $Pre) (ch_main $Pre ()))) True) ; -; - - (= - (--> - (ch_consider_promote - (Cons $T $Sel) $Rest) - (, - (ch_attempt_promote $T) - (ch_select_promote $Sel $Rest))) True) -; - - - (= - (--> - (ch_select_promote - (Cons - (promote_select $_ $_ $_) $Rest) $Rest) ()) True) -; - - (= - (--> - (ch_select_promote $Rest $Rest) ()) True) -; +; CONSIDER_PROMOTE + (= (--> (ch_consider_promote (Cons $T $Sel) $Rest) (, (ch_attempt_promote $T) (ch_select_promote $Sel $Rest))) True) + (= (--> (ch_select_promote (Cons (promote_select $_ $_ $_) $Rest) $Rest) ()) True) + (= (--> (ch_select_promote $Rest $Rest) ()) True) ; -; - +; ATTEMPT_PROMOTE ; -; - +; attempt_promote(try_promote(square(5,1),piece(piece2,player),piece(piece3,player))) ; -; - +; --> [promote,'(',5,',',1,')',white,piece3,';'] ; -; - - (= - (--> - (ch_attempt_promote - (try_promote $Square $OldPiece ())) ()) True) -; - - (= - (--> - (ch_attempt_promote - (try_promote $Square $OldPiece $NewPiece)) ()) True) -; - +; Unless it promotes, it isn't mentioned in the notation. + (= (--> (ch_attempt_promote (try_promote $Square $OldPiece ())) ()) True) + (= (--> (ch_attempt_promote (try_promote $Square $OldPiece $NewPiece)) ()) True) ; -; - +; MAIN ; -; - - (= - (--> - (ch_main $In $Out) - (, - (ch_first_transfer $In $First) - (, - (ch_continued_transfers $First $T) - (ch_consider_promote $T $Out)))) True) -; - +; Repeated Transfers, followed by possible player promotion. + (= (--> (ch_main $In $Out) (, (ch_first_transfer $In $First) (, (ch_continued_transfers $First $T) (ch_consider_promote $T $Out)))) True) ; -; - - (= - (--> - (ch_transfers $In $Out) - (, - (ch_transfer $In $T) - (ch_continued_transfers $T $Out))) True) -; - +; TRANSFERS + (= (--> (ch_transfers $In $Out) (, (ch_transfer $In $T) (ch_continued_transfers $T $Out))) True) ; -; - +; CONTINUED_TRANSFERS ; -; - +; Either no more transfers, or ';' and more transfers. ; -; - - (= - (--> - (ch_continued_transfers $In $In) ()) True) -; - - (= - (--> - (ch_continued_transfers - (Cons end_continues $Rest) $Rest) ()) True) -; - - (= - (--> - (ch_continued_transfers $In $Out) - (ch_transfers $In $Out)) True) -; - +; Could tighten this rule: can't continue unless did a movement. + (= (--> (ch_continued_transfers $In $In) ()) True) + (= (--> (ch_continued_transfers (Cons end_continues $Rest) $Rest) ()) True) + (= (--> (ch_continued_transfers $In $Out) (ch_transfers $In $Out)) True) ; -; - +; TRANSFER : [move(piece(piece6,player),player,square(5,1),square(4,1)), ; -; - +; remove(piece(piece6,player),square(4,1))] ; -; - +; --> [white,piece6,'(',5,',',1,')',->,'(',4,',',1,')',x,'(',4,',',1,')'] ; ; + (= (--> (ch_transfer (Cons $Move $Capture) $Rest) (, (ch_moving $Move) (ch_capture $Capture $Rest))) True) - (= - (--> - (ch_transfer - (Cons $Move $Capture) $Rest) - (, - (ch_moving $Move) - (ch_capture $Capture $Rest))) True) -; - - - (= - (--> - (ch_first_transfer - (Cons $Move $Capture) $Rest) - (, - (ch_first_moving $Move) - (ch_capture $Capture $Rest))) True) -; - + (= (--> (ch_first_transfer (Cons $Move $Capture) $Rest) (, (ch_first_moving $Move) (ch_capture $Capture $Rest))) True) ; -; - +; MOVING ; -; - +; moving(move(piece(piece1,opponent),opponent,square(1,6),square(2,4)),S,[]). ; -; - - (= - (--> - (ch_first_moving - (move $Piece $Player $From $To)) - (, - (ch_square $From) - (ch_square $To))) True) -; +; S = [black,piece1,'(',1,',',6,')',->,'(',2,',',4,')'] + (= (--> (ch_first_moving (move $Piece $Player $From $To)) (, (ch_square $From) (ch_square $To))) True) + (= (--> (ch_moving (move $Piece $Player $From $To)) (ch_square $To)) True) - (= - (--> - (ch_moving - (move $Piece $Player $From $To)) - (ch_square $To)) True) -; + (= (--> (ch_capture $In $Out) (ch_null_capture $In $Out)) True) + (= (--> (ch_capture $In $Out) (ch_real_capture $In $Out)) True) + (= (--> (ch_null_capture $X $X) ()) True) - (= - (--> - (ch_capture $In $Out) - (ch_null_capture $In $Out)) True) -; - - (= - (--> - (ch_capture $In $Out) - (ch_real_capture $In $Out)) True) -; - - - (= - (--> - (ch_null_capture $X $X) ()) True) -; - - - (= - (--> - (ch_real_capture - (Cons $C $Cs) $Rest) - (, - (ch_simp_capture $C) - (ch_capture $Cs $Rest))) True) -; - - - (= - (--> - (ch_simp_capture $M) - (ch_remove $M)) True) -; - - (= - (--> - (ch_simp_capture $M) - (ch_possess $M)) True) -; + (= (--> (ch_real_capture (Cons $C $Cs) $Rest) (, (ch_simp_capture $C) (ch_capture $Cs $Rest))) True) + (= (--> (ch_simp_capture $M) (ch_remove $M)) True) + (= (--> (ch_simp_capture $M) (ch_possess $M)) True) ; -; - - (= - (--> - (ch_remove - (capture remove $Caps)) ()) True) -; - +; REMOVE + (= (--> (ch_remove (capture remove $Caps)) ()) True) ; -; +; POSSESS + (= (--> (ch_possess (capture (possess $Player) $Caps)) ()) True) - (= - (--> - (ch_possess - (capture - (possess $Player) $Caps)) ()) True) -; - - - - (= - (--> - (ch_square $Sq) - (, - { (, - (invert $Sq $Sq1) - (square $Sq1 $X $Y)) } - (, - ($Col) - (, - { (nth_letter $X $Col) } - (number $Y))))) True) -; + (= (--> (ch_square $Sq) (, {(, (invert $Sq $Sq1) (square $Sq1 $X $Y)) } (, ($Col) (, {(nth_letter $X $Col) } (number $Y))))) True) diff --git a/metagame/comms/comms.metta b/metagame/comms/comms.metta index 3887200..a33866d 100644 --- a/metagame/comms/comms.metta +++ b/metagame/comms/comms.metta @@ -1,204 +1,139 @@ +; (convert_to_metta_file comms $_47128 metagame/comms/comms.pl metagame/comms/comms.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; comms.pl ; -; - +; ;; Deals with communications protocols, and starting remote matches. !(ensure-loaded (library shells)) -; - ; -; - +; ============================================================================ ; -; - +; Modifications to linda communications routines ; -; - +; ============================================================================ - (= - (linda-client-wait (with_self $ServerAddr $PortNum)) - ( (linda-client (with_self $ServerAddr $PortNum)) (set-det))) -; - - (= - (linda-client-wait (with_self $ServerAddr $PortNum)) + (= (linda-client-wait (with_self $ServerAddr $PortNum)) + (linda-client (with_self $ServerAddr $PortNum)) + (set-det)) + (= (linda-client-wait (with_self $ServerAddr $PortNum)) (linda-client-wait (with_self $ServerAddr $PortNum))) -; - - - (= - (in-wait $Pattern) - ( (format "~nWaiting to receive pattern: ~w~n" - (:: $Pattern)) - (in-wait-loop $Pattern) - (set-det) - (format "~nReceived pattern: ~w~n" - (:: $Pattern)))) -; + (= (in-wait $Pattern) + (format "~nWaiting to receive pattern: ~w~n" + (:: $Pattern)) + (in-wait-loop $Pattern) + (set-det) + (format "~nReceived pattern: ~w~n" + (:: $Pattern))) +; ; in(Pattern), !, ; -; - +; Keep waiting for TimeOut seconds, where linda:timeout(TimeOut), ; -; - +; until get a pattern. ; -; - +; Could have an ultimate time limit, after which we give up. ; -; - - - (= - (in-wait-loop $Pattern) - ( (in-noblock $Pattern) (set-det))) -; +; Could also have a waiting period between. - (= - (in-wait-loop $Pattern) + (= (in-wait-loop $Pattern) + (in-noblock $Pattern) + (set-det)) + (= (in-wait-loop $Pattern) (in-wait-loop $Pattern)) -; - - - (= - (rd-wait $Pattern) - ( (format "~nWaiting to observe pattern: ~w~n" - (:: $Pattern)) - (rd-wait-loop $Pattern) - (set-det) - (format "~nObserved pattern: ~w~n" - (:: $Pattern)))) -; + (= (rd-wait $Pattern) + (format "~nWaiting to observe pattern: ~w~n" + (:: $Pattern)) + (rd-wait-loop $Pattern) + (set-det) + (format "~nObserved pattern: ~w~n" + (:: $Pattern))) +; ; rd(Pattern), ; -; - +; Keep waiting for TimeOut seconds, where linda:timeout(TimeOut), ; -; - +; until get a pattern. ; -; - +; Could have an ultimate time limit, after which we give up. ; -; - - - (= - (rd-wait-loop $Pattern) - ( (rd-noblock $Pattern) (set-det))) -; +; Could also have a waiting period between. - (= - (rd-wait-loop $Pattern) + (= (rd-wait-loop $Pattern) + (rd-noblock $Pattern) + (set-det)) + (= (rd-wait-loop $Pattern) (rd-wait-loop $Pattern)) -; - ; -; - +; ============================================================================ - (= - (remote-metagame $Addr $Args $Title) + (= (remote-metagame $Addr $Args $Title) (shell-rsh $Addr /homes/bdp/prolog/play/metagame $Args $Title)) -; - ; -; - +; ============================================================================ ; -; - +; play_match(any,innes,'/homes/bdp/MeTTa/play/randomist',barney,'/homes/bdp/MeTTa/play/instantist'). ; -; - +; play_match(any,rando,'/homes/bdp/MeTTa/play/randomist',instanto,'/homes/bdp/MeTTa/play/instantist'). ; -; - - - - (= - (human_file /homes/bdp/prolog/play/humanist) True) -; - +; play_match(shoveller,rando,'/homes/bdp/MeTTa/play/randomist',instanto,'/homes/bdp/MeTTa/play/instantist'). - (= - (random_file /homes/bdp/prolog/play/randomist) True) -; + (= (human_file /homes/bdp/prolog/play/humanist) True) - (= - (instant_file /homes/bdp/prolog/play/instantist) True) -; + (= (random_file /homes/bdp/prolog/play/randomist) True) + (= (instant_file /homes/bdp/prolog/play/instantist) True) - (= - (play-human-match $Server $P1 $P2) - ( (human-file $F) (play-match $Server $P1 $F $P2 $F))) -; + (= (play-human-match $Server $P1 $P2) + (human-file $F) + (play-match $Server $P1 $F $P2 $F)) - - (= - (play-match $Server $Player1 $Info1 $Player2 $Info2) + (= (play-match $Server $Player1 $Info1 $Player2 $Info2) (make-server $Server $Player1 $Info1 $Player2 $Info2)) -; - - - (= - (make-server $Server $Player1 $Info1 $Player2 $Info2) - ( (command-from-args - (:: server $Server : $Player1 vs $Player2) - $Title) (remote-metagame $Server (:: file /homes/bdp/prolog/play/serve-tourney player1-name $Player1 player1-info $Info1 player2-name $Player2 player2-info $Info2) $Title))) -; + (= (make-server $Server $Player1 $Info1 $Player2 $Info2) + (command-from-args + (:: server $Server : $Player1 vs $Player2) - $Title) + (remote-metagame $Server + (:: file /homes/bdp/prolog/play/serve-tourney player1-name $Player1 player1-info $Info1 player2-name $Player2 player2-info $Info2) $Title)) - (= - (port-number $P $N) + (= (port-number $P $N) (atom-to-number $P $N)) -; - - - (= - (atom-to-number $A $N) - ( (name $A $N1) (number-chars $N $N1))) -; + (= (atom-to-number $A $N) + (name $A $N1) + (number-chars $N $N1)) diff --git a/metagame/comms/humanist.metta b/metagame/comms/humanist.metta index 2bb4403..9014455 100644 --- a/metagame/comms/humanist.metta +++ b/metagame/comms/humanist.metta @@ -1,27 +1,20 @@ +; (convert_to_metta_file humanist $_141280 metagame/comms/humanist.pl metagame/comms/humanist.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - - +; humanist.pl - (= - (move $Role $Move $SIn $SOut) - ( (my-name $Me) - (format "~nPlayer ~p, as ~p, wants your help to select his move.~n" - (:: $Me $Role)) - (human-choose $Role $Move $SIn $SOut))) -; + (= (move $Role $Move $SIn $SOut) + (my-name $Me) + (format "~nPlayer ~p, as ~p, wants your help to select his move.~n" + (:: $Me $Role)) + (human-choose $Role $Move $SIn $SOut)) diff --git a/metagame/comms/instantist.metta b/metagame/comms/instantist.metta index 684a59d..cc0cebc 100644 --- a/metagame/comms/instantist.metta +++ b/metagame/comms/instantist.metta @@ -1,26 +1,19 @@ +; (convert_to_metta_file instantist $_203568 metagame/comms/instantist.pl metagame/comms/instantist.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - - - (= - (move $Role $Move $SIn $SOut) - ( (my-name $Me) - (format "~nPlayer ~p, as ~p, will select an INSTANT move.~n" - (:: $Me $Role)) - (instant-choose $Role $Move $SIn $SOut))) -; +; instantist.pl + (= (move $Role $Move $SIn $SOut) + (my-name $Me) + (format "~nPlayer ~p, as ~p, will select an INSTANT move.~n" + (:: $Me $Role)) + (instant-choose $Role $Move $SIn $SOut)) diff --git a/metagame/comms/pipes.metta b/metagame/comms/pipes.metta index ecedb93..2ba22bc 100644 --- a/metagame/comms/pipes.metta +++ b/metagame/comms/pipes.metta @@ -1,316 +1,218 @@ +; (convert_to_metta_file pipes $_268156 metagame/comms/pipes.pl metagame/comms/pipes.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; +; ;; pipes.pl - - (= - (talk-interface $Command) + (= (talk-interface $Command) (interface-record-streams $Command $_ $_)) -; - - (= - (interface-record-streams $Command $InStream $OutStream) - ( (connect-pipes $Command $InStream $PipeIn $OutStream $PipeOut) - (add-global instream $InStream) - (add-global outstream $OutStream) - (add-global inpipe $PipeIn) - (add-global outpipe $PipeOut))) -; - + (= (interface-record-streams $Command $InStream $OutStream) + (connect-pipes $Command $InStream $PipeIn $OutStream $PipeOut) + (add-global instream $InStream) + (add-global outstream $OutStream) + (add-global inpipe $PipeIn) + (add-global outpipe $PipeOut)) ; -; - +; CONNECT_PIPES(+Command,-InStream,-PIn,-OutStream,-POut). ; -; - +; Calls Command with input from new pipe PipeOut, and output ; -; - +; to new pipe PipeIn, and opens inverted streams to those ; -; - +; pipes so that InStream gets command's output, and ; -; - +; OutStream sends command input. ; -; - +; Thus we are fully hooked up to talk to the command. ; ; - - (= - (connect-pipes $Command $InStream $PIn $OutStream $POut) - ( (open-new-pipe read $PIn $InStream) - (open-new-pipe write $POut $OutStream) - (shell (:: $Command > $PIn < $POut &)))) -; - - - + (= (connect-pipes $Command $InStream $PIn $OutStream $POut) + (open-new-pipe read $PIn $InStream) + (open-new-pipe write $POut $OutStream) + (shell (:: $Command > $PIn < $POut &))) - (= - (mode_arrow read <) True) -; - - (= - (mode_arrow write >) True) -; - - (= - (open-pipe $Pipe $Mode $Stream) - ( (mode-arrow $Mode $Arrow) - (command-from-args - (:: cat $Arrow $Pipe) $Command) - (unix (popen $Command $Mode $Stream)))) -; - + (= (mode_arrow read <) True) + (= (mode_arrow write >) True) - (= - (open-new-pipe $Mode $Pipe $Stream) - ( (new-pipe-file $Pipe) (open-pipe $Pipe $Mode $Stream))) -; + (= (open-pipe $Pipe $Mode $Stream) + (mode-arrow $Mode $Arrow) + (command-from-args + (:: cat $Arrow $Pipe) $Command) + (unix (popen $Command $Mode $Stream))) + (= (open-new-pipe $Mode $Pipe $Stream) + (new-pipe-file $Pipe) + (open-pipe $Pipe $Mode $Stream)) - (= - (new-pipe-file $Pipe) - ( (gensym pipe $P) - (concat-list - (:: /tmp/ $P XXXXXX) $Template) - (mktemp $Template $Pipe) - (shell (:: mknod $Pipe p)))) -; + (= (new-pipe-file $Pipe) + (gensym pipe $P) + (concat-list + (:: /tmp/ $P XXXXXX) $Template) + (mktemp $Template $Pipe) + (shell (:: mknod $Pipe p))) ; -; - +; If connection has been broken for some reason, ; -; - +; creates new streams corresponding to our input and ; -; - +; output pipes. ; ; + (= (reconnect-pipes) + (reconnect-inpipe) + (reconnect-outpipe)) - (= - (reconnect-pipes) - ( (reconnect-inpipe) (reconnect-outpipe))) -; + (= (reconnect-inpipe) + (global inpipe $PIn) + (open-pipe $PIn read $InStream) + (add-global instream $InStream)) - (= - (reconnect-inpipe) - ( (global inpipe $PIn) - (open-pipe $PIn read $InStream) - (add-global instream $InStream))) -; - + (= (reconnect-outpipe) + (global outpipe $POut) + (open-pipe $POut write $OutStream) + (add-global outstream $OutStream)) - (= - (reconnect-outpipe) - ( (global outpipe $POut) - (open-pipe $POut write $OutStream) - (add-global outstream $OutStream))) -; - - - - (= - (close-int) + (= (close-int) (interface-close)) -; - - (= - (interface-close) - ( (interface-close-streams) (interface-close-pipes))) -; - + (= (interface-close) + (interface-close-streams) + (interface-close-pipes)) - (= - (close-streams) + (= (close-streams) (interface-close-streams)) -; + (= (interface-close-streams) + (global instream $InStream) + (close $InStream) + (global outstream $OutStream) + (close $OutStream)) - (= - (interface-close-streams) - ( (global instream $InStream) - (close $InStream) - (global outstream $OutStream) - (close $OutStream))) -; - - - (= - (close-pipes) + (= (close-pipes) (interface-close-pipes)) -; - - (= - (interface-close-pipes) - ( (rm-gpipe inpipe) (rm-gpipe outpipe))) -; + (= (interface-close-pipes) + (rm-gpipe inpipe) + (rm-gpipe outpipe)) - - (= - (rm-gpipe $P) - ( (global $P $Pipe) (shell (:: rm $Pipe)))) -; - + (= (rm-gpipe $P) + (global $P $Pipe) + (shell (:: rm $Pipe))) ; -; - +; Use 'trace tellmove' to see what we are telling. ; ; - - (= - (tell-outstream $Statement) - ( (tracing-format tellmove "Telling : ~p~n" - (:: $Statement)) - (current-output $OldStream) - (global outstream $O) - (command-from-args $Statement $String) - (format $O $String Nil) - (format $O "~n" Nil) - (flush-output $O) - (set-output $OldStream))) -; - + (= (tell-outstream $Statement) + (tracing-format tellmove "Telling : ~p~n" + (:: $Statement)) + (current-output $OldStream) + (global outstream $O) + (command-from-args $Statement $String) + (format $O $String Nil) + (format $O "~n" Nil) + (flush-output $O) + (set-output $OldStream)) ; -; - +; --------------------------------------------------------------------------- ; -; - +; Pattern Matching in communications ; -; - +; --------------------------------------------------------------------------- !((abolish (/ found 1)) (abolish (/ found1 1))) -; - ; -; - +; Reads current data stream until finds a string Pattern. ; ; - - (= - (read-until-string $Pattern) - ( (tracing-format readmove "Looking for pattern: ~s~n" - (:: $Pattern)) - (found $Pattern) - (tracing-format readmove "~nPattern found: ~s~n" - (:: $Pattern)))) -; - + (= (read-until-string $Pattern) + (tracing-format readmove "Looking for pattern: ~s~n" + (:: $Pattern)) + (found $Pattern) + (tracing-format readmove "~nPattern found: ~s~n" + (:: $Pattern))) ; -; - +; FOUND(Symbol) ; ; - ; -; - +; Read a sequence of chars until a pattern is found which matches each ; -; - +; char. Uses Sahlin's routines above. - (= - (found $Symbol) + (= (found $Symbol) (found1 $Symbol)) -; - ; -; - - - (= - (found1 - (, $_ ())) True) -; - - (= - (found1 $SymbInfo) - ( (get0 $C) - (tracing-format readmove "~s" - (:: (:: $C))) - (new $C $SymbInfo $SymbInfoNew) - (found1 $SymbInfoNew))) -; +; Use 'trace readmove' to see what we are reading. + (= (found1 (, $_ ())) True) + (= (found1 $SymbInfo) + (get0 $C) + (tracing-format readmove "~s" + (:: (:: $C))) + (new $C $SymbInfo $SymbInfoNew) + (found1 $SymbInfoNew)) ; -; - +; --------------------------------------------------------------------------- ; -; - +; ================================================================================ ; -; - +; Interface ; -; - +; ================================================================================ diff --git a/metagame/comms/player.metta b/metagame/comms/player.metta index 502792c..5e61ad7 100644 --- a/metagame/comms/player.metta +++ b/metagame/comms/player.metta @@ -1,635 +1,433 @@ +; (convert_to_metta_file player $_380830 metagame/comms/player.pl metagame/comms/player.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; player.pl ; -; - +; ;; !(prolog-flag redefine-warnings $_ off) -; - ; -; - +; ================================================================================ ; -; - +; PLAYER ; -; - +; ================================================================================ ; ; - ; -; - +; PLAYER MeTTa process will be called with command like: ; -; - +; start_sicstus_shell(any, ; -; - +; [ server_name, ServerAddr, ; -; - +; server_port, Port, ; -; - +; local_name, Player, ; -; - +; file, MoveFile, ; -; - +; file,'~/MeTTa/play/player' ; -; - +; ]). ; -; - +; The MoveFile should define the search method which will be used when ; -; - +; this player is to move. ; -; +; Redefine metagame here, so we don't give menu and instead just start player. - - (= - (metagame) + (= (metagame) (start-player)) -; - - (= - (start-player) + (= (start-player) ( (find-my-name $Name) - (add-symbol &self + (add-is-symbol &self (my_name $Name)) (find-server $Addr $Port) (play $Addr $Port $Name))) -; - - (= - (find-my-name $N) + (= (find-my-name $N) (parameter player1-name $N)) -; - - - - (= - (find-server $S $P) - ( (parameter server-name $S) (parameter server-port $P))) -; + (= (find-server $S $P) + (parameter server-name $S) + (parameter server-port $P)) - (= - (play $ServerAddr $Port $Player) - ( (use-module (library linda/client)) - (port-number $Port $PortNum) - (format "Server address is ~q:~q~n" - (:: $ServerAddr $PortNum)) - (linda-client-wait (with_self $ServerAddr $PortNum)) - (greet-ref $Player) - (start-controller))) -; + (= (play $ServerAddr $Port $Player) + (use-module (library linda/client)) + (port-number $Port $PortNum) + (format "Server address is ~q:~q~n" + (:: $ServerAddr $PortNum)) + (linda-client-wait (with_self $ServerAddr $PortNum)) + (greet-ref $Player) + (start-controller)) - (= - (greet-ref $Player) + (= (greet-ref $Player) (format "~nHello, I'm player: ~w" (:: $Player))) -; - ; -; - +; These are the interface routines for a player to receive and send ; -; - +; information to a controller, when playing against an opponent. ; -; - +; Waits for a personal message, of the form: ; -; - - - (= - (in-wait-personal $Pattern) - ( (my-name $Me) (in-wait (message $Me $Pattern)))) -; +; message(,Pattern) + (= (in-wait-personal $Pattern) + (my-name $Me) + (in-wait (message $Me $Pattern))) ; -; - +; GET_MOVE(Player,Move) ; -; - +; If communicating directly (not via ref) don't need ; -; - +; above transmit, just one puts in, other takes out, and ; -; - +; vice versa. ; -; - +; Someone must say the move is legal, before I'll get it. ; -; - +; If not ref, the other player himself can do so. ; -; - +; This gets the string notation, which must later be parsed ; -; - +; into an internal representation denoting the legal move. ; -; - - - (= - (get-move $Player $Move) - ( (in-wait-personal legal) (in-wait (moved $Player $Move)))) -; +; moved(player,move) is the only message not personally addressed. + (= (get-move $Player $Move) + (in-wait-personal legal) + (in-wait (moved $Player $Move))) ; -; - +; COMMUNICATE_MOVE(Player,Move) ; -; - +; Sends the move, in string notation. ; -; - +; Doesn't need to be personal, as it mentions the ; -; - +; player and so won't be intercepted by anyone not involved. ; -; - +; And the other player won't see it till the ref. has said it is ; -; +; legal. - - (= - (communicate-move $Player $Move) + (= (communicate-move $Player $Move) (out (moved $Player $Move))) -; - ; -; +; RECEIVE_PLAYERS(White,Black) - - (= - (receive-players $White $Black) + (= (receive-players $White $Black) (in-wait-personal (players $White $Black))) -; - - (= - (process-game $GameName) - ( (atom $GameName) - (set-det) - (file-make-test-game $GameName))) -; - - (= - (process-game $GameString) + (= (process-game $GameName) + (atom $GameName) + (set-det) + (file-make-test-game $GameName)) + (= (process-game $GameString) (string-make-test-game $GameString)) -; - ; -; - +; ================================================================================ ; -; - +; Hooks to standard controller script ; -; - +; ================================================================================ - (= - (get-players $White $Black) + (= (get-players $White $Black) ( (receive-players $White $Black) (my-name $Me) (find-opponent $White $Black $Me $Opponent) - (remove-all-symbols &self + (remove-all-atoms &self (my_opponent $_)) - (add-symbol &self + (add-is-symbol &self (my_opponent $Opponent)))) -; - - - - (= - (find_opponent $White $Black $White $Black) True) -; - (= - (find_opponent $White $Black $Black $White) True) -; + (= (find_opponent $White $Black $White $Black) True) + (= (find_opponent $White $Black $Black $White) True) ; -; - +; ======================================== ; -; - +; GET_CURRENT_GAME ; -; - +; ======================================== ; -; - +; Receive the name of the next game to be played. ; -; +; Then load it as the current game. - - (= - (get-current-game) - ( (receive-game-name $GameName) (load-game $GameName))) -; + (= (get-current-game) + (receive-game-name $GameName) + (load-game $GameName)) - - (= - (receive-game-name $G) + (= (receive-game-name $G) (in-wait-personal (game-name $G))) -; - ; -; - +; ======================================== ; -; - +; GET_RANDOM_ASSIGNMENT(-Assignments) ; -; - +; ======================================== ; -; - +; External hook to determine random assignments ; -; - +; when necessary. ; -; - +; Gets the random assignment string from the referee, ; -; - - - (= - (get-random-assignment $Assignment) - ( (format "~nRequesting Random Assignment~n" Nil) - (get-init-state $AssignmentString) - (assignments-string $Assignment $AssignmentString) - (format "~nReceived random assignment: ~w~n" - (:: $Assignment)))) -; +; then parses it. + (= (get-random-assignment $Assignment) + (format "~nRequesting Random Assignment~n" Nil) + (get-init-state $AssignmentString) + (assignments-string $Assignment $AssignmentString) + (format "~nReceived random assignment: ~w~n" + (:: $Assignment))) ; -; - +; GET_INIT_STATE(-Assignment) ; -; - +; Gets the string representing the initial state assignment ; -; +; (for random-setup games). - - (= - (get-init-state $Assignment) + (= (get-init-state $Assignment) (in-wait-personal (init-state $Assignment))) -; - ; -; - +; ================================================================================ ; -; - +; TERMINATE_GAME(+FinalState) ; -; - +; ================================================================================ ; -; +; Hook called when the game has ended. - - (= - (terminate-game $SIn) - ( (format "~nI'm finished playing the game.~n" Nil) - (analyze-game $SIn) - (restart-or-end))) -; - + (= (terminate-game $SIn) + (format "~nI'm finished playing the game.~n" Nil) + (analyze-game $SIn) + (restart-or-end)) ; -; - - - (= - (analyze_game $_) True) -; +; To be defined by player's own programs. + (= (analyze_game $_) True) - (= - (restart-or-end) - ( (in-wait-personal (reset $R)) - (set-det) - (restart-if $R))) -; + (= (restart-or-end) + (in-wait-personal (reset $R)) + (set-det) + (restart-if $R)) + (= (restart-if new) + (format "~nStarting again!~n" Nil) + (start-controller)) + (= (restart-if end) + (format "~nTournament is finished. Bye!~n" Nil) + (close-player)) - (= - (restart-if new) - ( (format "~nStarting again!~n" Nil) (start-controller))) -; - (= - (restart-if end) - ( (format "~nTournament is finished. Bye!~n" Nil) (close-player))) -; - - - - (= close_player True) -; - + (= close_player True) ; -; - +; ================================================================================ ; -; - +; SHOULD_CONTINUE(SIn) ; -; - +; ================================================================================ ; -; - +; Another hook to controller. ; -; - +; Should return true if the player wants to continue the game. ; ; - ; -; +; Some routines here defined in local.pl - - (= - (should-continue $_) - ( (continuous) - (set-det) - (not-abort))) -; - - (= - (should-continue $_) + (= (should-continue $_) + (continuous) + (set-det) + (not-abort)) + (= (should-continue $_) (ask-continue y)) -; - ; -; - +; So someone else (like ref. or human) ; -; - - - (= - (not-abort) - ( (rd-noblock abort) - (set-det) - (format "~nUser chose to abort!~n") - (fail))) -; - - (= not_abort True) -; +; can emergency abort by connecting to the server also. + (= (not-abort) + (rd-noblock abort) + (set-det) + (format "~nUser chose to abort!~n") + (fail)) + (= not_abort True) ; -; - +; ================================================================================ ; -; - +; Move Selection methods ; -; - +; ================================================================================ ; -; - +; CHOOSE(Chooser,Role,SIn,SOut) ; -; - +; Contains a clause for whether local player is moving or not. ; -; - +; Currently: ; -; - +; If ME, calls MOVE as loaded in designated file. ; -; - +; If NOT ME, gets move from remote opponent. ; -; +; Note my_name was saved above. - - (= - (choose $Me $Role $SIn $SOut) - ( (my-name $Me) - (set-det) - (my-choice $Role $SIn $SOut))) -; - - (= - (choose $Other $Role $SIn $SOut) + (= (choose $Me $Role $SIn $SOut) + (my-name $Me) + (set-det) + (my-choice $Role $SIn $SOut)) + (= (choose $Other $Role $SIn $SOut) (other-choice $Role $SIn $SOut)) -; - ; -; - +; ================================================================================ ; -; - +; MOVE(Role,Move,SIn,SOut) ; -; - +; ================================================================================ ; -; - +; A hook into a file which is loaded by this player to determine how to ; -; - +; move. The result is the move that the player will choose. ; -; - +; By splitting this up, the PLAYER script can be used by all different ; -; - +; programs to play remotely, just as the CONTROLLER script is used ; -; - +; by all participants. ; -; - +; Some choices of files: humanist, randomist, instantist. ; -; - +; ================================================================================ ; -; - +; MY_CHOICE(Role,SIn,SOut) ; -; - +; What to do when it is my turn. ; -; - +; Uses move/4 defined in accompanying file to select a ; -; - +; move, returning the internal representation. ; -; - +; Then translate this into the appropriate grammatical string ; -; - - - (= - (my-choice $Role $SIn $SOut) - ( (my-name $Me) - (move $Role $Move $SIn $SOut) - (move-notation-string $Move $MoveString) - (communicate-move $Me $MoveString))) -; +; representation, and communicate this to the other player. + (= (my-choice $Role $SIn $SOut) + (my-name $Me) + (move $Role $Move $SIn $SOut) + (move-notation-string $Move $MoveString) + (communicate-move $Me $MoveString)) ; -; - +; OTHER_CHOICE(Role,SIn,SOut) ; -; - +; What to do when it's the other player's turn. ; -; - +; Get his move, parse it, and find the interpretation which is ; -; +; legal (assumed unambiguous w.r.t. current position). + (= (other-choice $Role $SIn $SOut) + (my-opponent $Player) + (get-move $Player $MoveString) + (nl) + (format "Received: ~s" + (:: $MoveString)) + (nl) + (find-correct-interpretation $Player $Role $MoveString $SIn $SOut)) +; ; nl, format(MoveString,[]), nl, - (= - (other-choice $Role $SIn $SOut) - ( (my-opponent $Player) - (get-move $Player $MoveString) - (nl) - (format "Received: ~s" - (:: $MoveString)) - (nl) - (find-correct-interpretation $Player $Role $MoveString $SIn $SOut))) -; - - - (= - (find-correct-interpretation $Player $Role $MoveString $SIn $SOut) - ( (move-notation-string $Move $MoveString) - (check-legality $Player $Role $Move $SIn $SOut) - (set-det))) -; - - (= - (find-correct-interpretation $Player $Role $MoveString $SIn $SOut) + (= (find-correct-interpretation $Player $Role $MoveString $SIn $SOut) + (move-notation-string $Move $MoveString) + (check-legality $Player $Role $Move $SIn $SOut) + (set-det)) + (= (find-correct-interpretation $Player $Role $MoveString $SIn $SOut) ( (format "~nCouldn't interpret the move, ~s, of player ~w, as ~w~n" (:: $MoveString $Player $Role)) - (add-symbol &self + (add-is-symbol &self (checkpoints $Player $Role $MoveString $SIn $SOut)) (break))) -; - - (= - (check-legality $Player $Role $Move $SIn $SOut) - ( (format "~nVerifying legality of move by Player ~w, as ~w:~w~n" - (:: $Player $Role $Move)) - (legal $Move $SIn $SOut) - (format "~nMove ~w passed legality check!~n" - (:: $Move)) - (print-state $SOut) - (print-notation $Move))) -; - + (= (check-legality $Player $Role $Move $SIn $SOut) + (format "~nVerifying legality of move by Player ~w, as ~w:~w~n" + (:: $Player $Role $Move)) + (legal $Move $SIn $SOut) + (format "~nMove ~w passed legality check!~n" + (:: $Move)) + (print-state $SOut) + (print-notation $Move)) diff --git a/metagame/comms/randomist.metta b/metagame/comms/randomist.metta index 58a9a10..b57671b 100644 --- a/metagame/comms/randomist.metta +++ b/metagame/comms/randomist.metta @@ -1,29 +1,23 @@ +; (convert_to_metta_file randomist $_39218 metagame/comms/randomist.pl metagame/comms/randomist.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - - +; randomist.pl - (= - (move $Role $Move $SIn $SOut) - ( (my-name $Me) - (format "~nPlayer ~p, as ~p, will select a RANDOM move.~n" - (:: $Me $Role)) - (random-choose $Role $Move $SIn $SOut) - (verbosely-format "~nPlayer ~p, as ~p, has chosen RANDOM move: ~p.~n" - (:: $Me $Role $Move)))) -; + (= (move $Role $Move $SIn $SOut) + (my-name $Me) + (format "~nPlayer ~p, as ~p, will select a RANDOM move.~n" + (:: $Me $Role)) + (random-choose $Role $Move $SIn $SOut) + (verbosely-format "~nPlayer ~p, as ~p, has chosen RANDOM move: ~p.~n" + (:: $Me $Role $Move))) +; ; set_verbose, ; spy(random_choose), ; debug, diff --git a/metagame/comms/referee.metta b/metagame/comms/referee.metta index a5e2c5f..c84fc70 100644 --- a/metagame/comms/referee.metta +++ b/metagame/comms/referee.metta @@ -1,748 +1,503 @@ +; (convert_to_metta_file referee $_103860 metagame/comms/referee.pl metagame/comms/referee.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; referee.pl ; -; - +; ;; !(prolog-flag redefine-warnings $_ off) -; - ; -; - +; ================================================================================ ; -; - +; REFEREE ; -; - +; ================================================================================ ; ; - ; -; - +; REFEREE MeTTa process will be called with command like: ; -; - +; start_sicstus_shell(any, ; -; - +; [server_name, ServerAddr, ; -; - +; server_port, Port, ; -; - +; player1_name, Player1, ; -; - +; player2_name, Player2, ; -; - +; file,'~/MeTTa/play/referee']). ; -; - +; Redefine metagame here, so we don't give menu and instead just start referee. - (= - (metagame) + (= (metagame) (start-ref)) -; - - (= - (start-ref) - ( (find-server $Server $Port) - (find-players $Player1 $Player2) - (referee $Server $Port $Player1 $Player2))) -; - - - - (= - (find-server $S $P) - ( (parameter server-name $S) (parameter server-port $P))) -; + (= (start-ref) + (find-server $Server $Port) + (find-players $Player1 $Player2) + (referee $Server $Port $Player1 $Player2)) + (= (find-server $S $P) + (parameter server-name $S) + (parameter server-port $P)) - (= - (find-players $Player1 $Player2) - ( (parameter player1-name $Player1) (parameter player2-name $Player2))) -; + (= (find-players $Player1 $Player2) + (parameter player1-name $Player1) + (parameter player2-name $Player2)) - (= - (referee $ServerAddr $Port $Player1 $Player2) + (= (referee $ServerAddr $Port $Player1 $Player2) ( (use-module (library linda/client)) (port-number $Port $PortNum) (linda-client-wait (with_self $ServerAddr $PortNum)) (greet-players $Player1 $Player2) (format "~nI'm your referee!~n" Nil) - (add-symbol &self + (add-is-symbol &self (players $Player1 $Player2)) (start-controller))) -; - - (= - (greet-players $P1 $P2) + (= (greet-players $P1 $P2) (format "~nHello, player1: ~w, player2: ~w~n" (:: $P1 $P2))) -; - ; -; - +; ================================================================================ ; -; - +; Play a number of contests between these ; -; +; players, for a given game definition. - - (= - (referee-game-contests $P1 $P2 $G 0) - ( (set-det) (record-statistics))) -; - - (= - (referee-game-contests $P1 $P2 $G $Contests) - ( (> $Contests 0) - (referee-contest $P1 $P2 $G) - (is $C1 - (- $Contests 1)) - (referee-game-contests $P1 $P2 $G $C1))) -; - + (= (referee-game-contests $P1 $P2 $G 0) + (set-det) + (record-statistics)) + (= (referee-game-contests $P1 $P2 $G $Contests) + (> $Contests 0) + (referee-contest $P1 $P2 $G) + (is $C1 + (- $Contests 1)) + (referee-game-contests $P1 $P2 $G $C1)) ; -; - +; For now, shut off everything. Eventually, can play ; -; - - +; role in more complicated tournament. - (= - (close-match $P1 $P2) - ( (close-players $P1 $P2) - (close-server) - (record-statistics) - (close-client))) -; + (= (close-match $P1 $P2) + (close-players $P1 $P2) + (close-server) + (record-statistics) + (close-client)) - (= - (close-server) + (= (close-server) (with_self (linda *) (linda-call halt))) -; - ; -; - +; =========================================================================== ; -; - +; CALL_FOR_PLAYERS(Player^Call) ; -; - +; =========================================================================== ; -; - +; Call is a goal, possibly requiring a variable Player. ; -; +; The goal will be called, instantiated in turn for both players. + (= (call-for-players $PlayerCall) + (players $Player1 $Player2) + (call-for-players $Player1 $Player2 $PlayerCall)) - (= - (call-for-players $PlayerCall) - ( (players $Player1 $Player2) (call-for-players $Player1 $Player2 $PlayerCall))) -; + (= (call-for-players $Player1 $Player2 $PlayerCall) + (call-for-player $Player1 $PlayerCall) + (call-for-player $Player2 $PlayerCall)) - (= - (call-for-players $Player1 $Player2 $PlayerCall) - ( (call-for-player $Player1 $PlayerCall) (call-for-player $Player2 $PlayerCall))) -; - - - - (= - (call-for-player $Name - (^ $Player $Call)) + (= (call-for-player $Name (^ $Player $Call)) (verify (, (= $Player $Name) (call $Call)))) -; - ; -; - +; OUT_TO_PLAYERS(Pattern) ; -; +; Send the same message to both players, personally addressed. - - (= - (out-to-players $Pattern) + (= (out-to-players $Pattern) (call-for-players (^ $P (out-personal $P $Pattern)))) -; - ; -; - +; Sends a personal message, of the form: ; -; - +; message(Player,Pattern) - (= - (out-personal $Player $Pattern) + (= (out-personal $Player $Pattern) (out1 (message $Player $Pattern))) -; - - (= - (out1 $Pattern) - ( (format "~nSending pattern: ~w~n" - (:: $Pattern)) (out $Pattern))) -; - + (= (out1 $Pattern) + (format "~nSending pattern: ~w~n" + (:: $Pattern)) + (out $Pattern)) ; -; - +; ================================================================================ ; -; - +; Hooks to standard controller script ; -; - +; ================================================================================ ; -; - +; ======================================== ; -; - +; GET_PLAYERS(White,Black) ; -; - - - (= - (get-players $White $Black) - ( (next-players $White $Black) (set-players $White $Black))) -; +; ======================================== + (= (get-players $White $Black) + (next-players $White $Black) + (set-players $White $Black)) ; -; - +; NEXT_PLAYERS(White,Black) ; -; - +; Could be determined from an external source, like a tournament ; -; - +; director, based on the current results of the tournament. ; -; - +; For now, just alternate colors each game. ; -; - - - (= - (next-players $White $Black) - ( (remove-symbol &self - (players $Black $White)) (add-symbol &self (players $White $Black)))) -; +; players(White,Black) is initially saved upon entry above. + (= (next-players $White $Black) + ( (remove-is-symbol &self + (players $Black $White)) (add-is-symbol &self (players $White $Black)))) ; -; - +; Sends to each player the information about the roles ; -; - +; both players are playing. - (= - (set-players $White $Black) + (= (set-players $White $Black) (out-to-players (players $White $Black))) -; - ; -; - +; ======================================== ; -; - +; GET_CURRENT_GAME ; -; - +; ======================================== ; -; - +; Provides external hook. ; -; - +; Selects next game, and loads it as the current game. ; -; - +; Then send the name of the game to the players. ; -; - +; We assume the players have already been sent the full ; -; - +; definitions of the games with these names. ; -; +; Probably this could be done over email. - - (= - (get-current-game) - ( (select-next-game $GameName) - (load-game $GameName) - (send-game-name-to-players $GameName))) -; - + (= (get-current-game) + (select-next-game $GameName) + (load-game $GameName) + (send-game-name-to-players $GameName)) - (= - (send-game-name-to-players $GameName) + (= (send-game-name-to-players $GameName) (out-to-players (game-name $GameName))) -; - ; -; - +; SELECT_NEXT_GAME(GameName). ; -; - +; Could be determined from an external source, like a tournament ; -; - +; director, based on the current results of the tournament. ; -; - +; Could also be determined from a file. ; -; - +; For the time being, to demonstrate the functionality, ; -; - +; we'll have them play chess, checkers, shogi, and turncoat_chess, ; -; - - - - (= - (select-next-game $GameName) - ( (next-alternate-game $GameName) (set-det))) -; - - (= - (select_next_game chess) True) -; +; and then tell them the match is over. + (= (select-next-game $GameName) + (next-alternate-game $GameName) + (set-det)) + (= (select_next_game chess) True) - (= - (next-alternate-game $GameName) - ( (player-current-game-name $OldGame) - (set-det) - (game-follows $OldGame $GameName))) -; + (= (next-alternate-game $GameName) + (player-current-game-name $OldGame) + (set-det) + (game-follows $OldGame $GameName)) - (= - (player-current-game-name $Name) - ( (player-current-game $G) (game-name $G $Name))) -; + (= (player-current-game-name $Name) + (player-current-game $G) + (game-name $G $Name)) - - (= - (game_follows chess checkers) True) -; - - (= - (game_follows checkers shogi) True) -; - - (= - (game_follows shogi turncoat_chess) True) -; - + (= (game_follows chess checkers) True) + (= (game_follows checkers shogi) True) + (= (game_follows shogi turncoat_chess) True) ; -; - +; ======================================== ; -; - +; GET_RANDOM_ASSIGNMENT(-Assignments) ; -; - +; ======================================== ; -; - +; External hook to determine random assignments ; -; - +; when necessary. ; -; - +; Here, the ref. generates a random assignment, ; -; - - - (= - (get-random-assignment $Assignment) - ( (game-assignments $Game $As) - (assignment-decision $As random $PieceNames $Squares) - (generate-random-assignment $PieceNames $Squares $Assignment) - (send-assignment $Assignment))) -; +; and sends the string representation to each of the players. + (= (get-random-assignment $Assignment) + (game-assignments $Game $As) + (assignment-decision $As random $PieceNames $Squares) + (generate-random-assignment $PieceNames $Squares $Assignment) + (send-assignment $Assignment)) ; -; - +; assign_pieces_to_squares is defined in generator - (= - (generate-random-assignment $PieceNames $Squares $Assignment) - ( (format "~nGenerating Random Assignment~n" Nil) (assign-pieces-to-squares $PieceNames $Squares $Assignment))) -; - + (= (generate-random-assignment $PieceNames $Squares $Assignment) + (format "~nGenerating Random Assignment~n" Nil) + (assign-pieces-to-squares $PieceNames $Squares $Assignment)) ; -; - +; Ex: ; -; - +; ?- send_assignment([piece1=[square(2,2)],piece2=[square(1,1)]]). ; -; - +; piece1 at { ( 2 , 2 ) } ; -; - +; piece2 at { ( 1 , 1 ) } . ; -; - +; Uses command call_for_players, to send copy to each player. ; -; - +; Send by name? ; -; - - - (= - (send-assignment $Assignment) - ( (assignments-string $Assignment $AssignmentString) - (format "~nSending random assignment: ~w~n" - (:: $Assignment)) - (out-to-players (init-state $AssignmentString)))) -; +; assignments_string/2 defined in game grammar file grammar.pl + (= (send-assignment $Assignment) + (assignments-string $Assignment $AssignmentString) + (format "~nSending random assignment: ~w~n" + (:: $Assignment)) + (out-to-players (init-state $AssignmentString))) ; -; - +; ================================================================================ ; -; - +; TERMINATE_GAME(+FinalState) ; -; - +; ================================================================================ ; -; +; Hook called when the game has ended. - - (= - (terminate-game $SIn) - ( (format "~nThe game has finished~n" Nil) - (process-results $SIn) - (restart-or-end))) -; - + (= (terminate-game $SIn) + (format "~nThe game has finished~n" Nil) + (process-results $SIn) + (restart-or-end)) ; -; +; How results are processed to be defined later. - - (= - (process_results $SIn) True) -; + (= (process_results $SIn) True) - - (= - (restart-or-end) + (= (restart-or-end) (det-if-then-else (next-alternate-game $GameName) restart goodbye-players)) -; - - (= - (restart) - ( (out-to-players (reset new)) (start-controller))) -; - - + (= (restart) + (out-to-players (reset new)) + (start-controller)) - (= - (goodbye-players) - ( (out-to-players (reset end)) (format "~nTournament is finished. Bye!~n" Nil))) -; + (= (goodbye-players) + (out-to-players (reset end)) + (format "~nTournament is finished. Bye!~n" Nil)) ; -; - +; ================================================================================ ; -; - +; SHOULD_CONTINUE(SIn) ; -; - +; ================================================================================ ; -; - +; Another hook to controller. ; -; - +; Should return true if the player wants to continue the game. - (= - (should-continue $SIn) - ( (continuous) - (set-det) - (not-abort))) -; - - (= - (should-continue $SIn) + (= (should-continue $SIn) + (continuous) + (set-det) + (not-abort)) + (= (should-continue $SIn) (ask-continue y)) -; - ; -; - +; So someone else (like ref. or human) ; -; - - - (= - (not-abort) - ( (rd-noblock abort) - (set-det) - (format "~nUser chose to abort!~n") - (fail))) -; - - (= not_abort True) -; +; can emergency abort by connecting to the server also. + (= (not-abort) + (rd-noblock abort) + (set-det) + (format "~nUser chose to abort!~n") + (fail)) + (= not_abort True) ; -; - +; ================================================================================ ; -; - +; Move Selection methods ; -; - +; ================================================================================ ; -; - +; CHOOSE(Chooser,Role,SIn,SOut) ; -; - +; Contains a clause for each decision method (or player) ; -; - +; Currently: ; -; - +; HUMAN ; -; - +; COMPUTER ; -; +; RANDOM - - (= - (choose $Player $Role $SIn $SOut) + (= (choose $Player $Role $SIn $SOut) (observe-choice $Player $Role $SIn $SOut)) -; - ; -; - +; If move is legal, then say it is, so the other player can process it. ; -; - +; (This is one attempt to avoid problems when both trying to rd/in ; -; - +; at the same time, so only 1 gets it). ; -; - +; Note we receive a move in string representation, and parse it ; -; - +; and find a legal interpretation in the current position. ; -; - - - (= - (observe-choice $Player $Role $SIn $SOut) - ( (format "~nPlayer ~w, as ~w, must select his move.~n" - (:: $Player $Role)) - (observe-move $Player $MoveString) - (nl) - (format "Observed: ~s" - (:: $MoveString)) - (nl) - (find-correct-interpretation $Player $Role $MoveString $SIn $SOut) - (other-player $Player $Other) - (out-personal $Other legal) - (format "~nPlayer ~w, as ~w, has selected his move.~n" - (:: $Player $Role)))) -; +; If the move isn't legal, we crash at the moment. + (= (observe-choice $Player $Role $SIn $SOut) + (format "~nPlayer ~w, as ~w, must select his move.~n" + (:: $Player $Role)) + (observe-move $Player $MoveString) + (nl) + (format "Observed: ~s" + (:: $MoveString)) + (nl) + (find-correct-interpretation $Player $Role $MoveString $SIn $SOut) + (other-player $Player $Other) + (out-personal $Other legal) + (format "~nPlayer ~w, as ~w, has selected his move.~n" + (:: $Player $Role))) - (= - (find-correct-interpretation $Player $Role $MoveString $SIn $SOut) - ( (move-notation-string $Move $MoveString) - (check-legality $Player $Role $Move $SIn $SOut) - (set-det))) -; - - (= - (find-correct-interpretation $Player $Role $MoveString $SIn $SOut) + (= (find-correct-interpretation $Player $Role $MoveString $SIn $SOut) + (move-notation-string $Move $MoveString) + (check-legality $Player $Role $Move $SIn $SOut) + (set-det)) + (= (find-correct-interpretation $Player $Role $MoveString $SIn $SOut) ( (format "~nCouldn't interpret the move, ~s, of player ~w, as ~w~n" (:: $MoveString $Player $Role)) - (add-symbol &self + (add-is-symbol &self (checkpoints $Player $Role $MoveString $SIn $SOut)) (break))) -; - - (= - (check-legality $Player $Role $Move $SIn $SOut) - ( (format "~nVerifying legality of move by Player ~w, as ~w:~w~n" - (:: $Player $Role $Move)) - (legal $Move $SIn $SOut) - (format "~nMove ~w passed legality check!~n" - (:: $Move)) - (print-state $SOut) - (print-notation $Move))) -; - + (= (check-legality $Player $Role $Move $SIn $SOut) + (format "~nVerifying legality of move by Player ~w, as ~w:~w~n" + (:: $Player $Role $Move)) + (legal $Move $SIn $SOut) + (format "~nMove ~w passed legality check!~n" + (:: $Move)) + (print-state $SOut) + (print-notation $Move)) - (= - (observe-choice $Player $Role $SIn $SOut) - ( (format "~nPlayer ~w, as ~w, selected an illegal move!!!~n" - (:: $Player $Role)) - (set-det) - (fail))) -; + (= (observe-choice $Player $Role $SIn $SOut) + (format "~nPlayer ~w, as ~w, selected an illegal move!!!~n" + (:: $Player $Role)) + (set-det) + (fail)) - - (= - (observe-move $Player $Move) + (= (observe-move $Player $Move) (rd-wait (moved $Player $Move))) -; - - (= - (role_player player $White $_ $White) True) -; - - (= - (role_player opponent $_ $Black $Black) True) -; - + (= (role_player player $White $_ $White) True) + (= (role_player opponent $_ $Black $Black) True) - (= - (other-player $Player $Other) + (= (other-player $Player $Other) (players $Player $Other)) -; - - (= - (other-player $Player $Other) + (= (other-player $Player $Other) (players $Other $Player)) -; - diff --git a/metagame/comms/serve_tourney.metta b/metagame/comms/serve_tourney.metta index 90f06ea..2c0dc79 100644 --- a/metagame/comms/serve_tourney.metta +++ b/metagame/comms/serve_tourney.metta @@ -1,155 +1,112 @@ +; (convert_to_metta_file serve_tourney $_298140 metagame/comms/serve_tourney.pl metagame/comms/serve_tourney.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; serve_tourney.pl !(prolog-flag redefine-warnings $_ off) -; - ; -; - +; ================================================================================ ; -; - +; SERVER ; -; - +; ================================================================================ ; ; - ; -; - +; SERVER MeTTa process will be called with command like: ; -; - +; metagame ; -; - +; 'file' ; -; - +; this file (serve_tourney) ; -; - +; player1 NAME INFO1a .. INFO1n ; -; - +; player2 NAME INFO2a .. INFO1n ; -; - +; For now just assume info1 is an atom with all the nec. info (like a filename?). ; -; - +; Redefine METAGAME here, so automatically start serving upon startup. - (= - (metagame) + (= (metagame) (serve-tourney)) -; - - (= - (serve-tourney) - ( (find-players $Player1 $Info1 $Player2 $Info2) (serve-tourney $Player1 $Info1 $Player2 $Info2))) -; + (= (serve-tourney) + (find-players $Player1 $Info1 $Player2 $Info2) + (serve-tourney $Player1 $Info1 $Player2 $Info2)) + (= (find-players $Player1 $Info1 $Player2 $Info2) + (parameter player1-name $Player1) + (parameter player1-info $Info1) + (parameter player2-name $Player2) + (parameter player2-info $Info2)) - (= - (find-players $Player1 $Info1 $Player2 $Info2) - ( (parameter player1-name $Player1) - (parameter player1-info $Info1) - (parameter player2-name $Player2) - (parameter player2-info $Info2))) -; + (= (serve-tourney $Player1 $Info1 $Player2 $Info2) + (use-module (library linda/server)) + (greet-players $Player1 $Player2) + (nl) + (write ' I am your friendly Linda Server!') + (nl) + (linda (- $Addr (create-tourney $Addr $Player1 $Info1 $Player2 $Info2)))) +; ; nl, write('just used server'), nl, +; ; linda((Addr-format('Server address is ~q~n',[Addr]))). - (= - (serve-tourney $Player1 $Info1 $Player2 $Info2) - ( (use-module (library linda/server)) - (greet-players $Player1 $Player2) - (nl) - (write ' I am your friendly Linda Server!') - (nl) - (linda (- $Addr (create-tourney $Addr $Player1 $Info1 $Player2 $Info2))))) -; - - - - (= - (greet-players $P1 $P2) + (= (greet-players $P1 $P2) (format "~nHello, player1: ~w, player2: ~w~n" (:: $P1 $P2))) -; - - (= - (create-tourney $Addr $Player1 $Info1 $Player2 $Info2) - ( (format "Server address is ~q~n" - (:: $Addr)) - (start-player $Addr $Player1 $Info1) - (wait-msecs 45000) - (start-ref $Addr $Player1 $Player2) - (wait-msecs 45000) - (start-player $Addr $Player2 $Info2))) -; - + (= (create-tourney $Addr $Player1 $Info1 $Player2 $Info2) + (format "Server address is ~q~n" + (:: $Addr)) + (start-player $Addr $Player1 $Info1) + (wait-msecs 45000) + (start-ref $Addr $Player1 $Player2) + (wait-msecs 45000) + (start-player $Addr $Player2 $Info2)) +; ; wait 45 seconds +; ; wait 45 seconds ; -; +; good_addr(any). + (= (good_addr shoveller) True) - (= - (good_addr shoveller) True) -; + (= (start-ref (with_self $ServerAddr $Port) $Player1 $Player2) + (good-addr $Slave) + (command-from-args + (:: ref $ServerAddr : $Player1 vs $Player2) - $Title) + (remote-metagame $Slave + (:: server-name $ServerAddr server-port $Port player1-name $Player1 player2-name $Player2 file ~/prolog/play/referee) $Title)) - (= - (start-ref - (with_self $ServerAddr $Port) $Player1 $Player2) - ( (good-addr $Slave) - (command-from-args - (:: ref $ServerAddr : $Player1 vs $Player2) - $Title) - (remote-metagame $Slave - (:: server-name $ServerAddr server-port $Port player1-name $Player1 player2-name $Player2 file ~/prolog/play/referee) $Title))) -; - - - - (= - (start-player - (with_self $ServerAddr $Port) $Player $MoveFile) - ( (good-addr $Slave) - (command-from-args - (:: $ServerAddr : $Player $MoveFile) - $Title) - (remote-metagame $Slave - (:: server-name $ServerAddr server-port $Port player1-name $Player file $MoveFile file ~/prolog/play/player) $Title))) -; - + (= (start-player (with_self $ServerAddr $Port) $Player $MoveFile) + (good-addr $Slave) + (command-from-args + (:: $ServerAddr : $Player $MoveFile) - $Title) + (remote-metagame $Slave + (:: server-name $ServerAddr server-port $Port player1-name $Player file $MoveFile file ~/prolog/play/player) $Title)) diff --git a/metagame/generator/gen.metta b/metagame/generator/gen.metta index 79e37fa..bb2a244 100644 --- a/metagame/generator/gen.metta +++ b/metagame/generator/gen.metta @@ -1,2918 +1,1932 @@ +; (convert_to_metta_file gen $_397920 metagame/generator/gen.pl metagame/generator/gen.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; gen.pl ; -; - +; Generates new symmetric chess-like games. !(my-ensure-loaded (library piece-names)) -; - !(my-ensure-loaded (library genstructs)) -; - ; -; - +; ================================================================================ ; -; - +; GENERATE GAME ; -; +; ================================================================================ - - (= - (generate-game (game $Name $Board $PieceDefs $Goal $Constraints)) - ( (record-seed) - (new-game-name $Name) - (generate-board $Board) - (write 'Generated Board') - (nl) - (generate-pieces $Board $PieceDefs) - (write 'Generated Pieces') - (nl) - (generate-global-constraints $Constraints) - (write 'Generated Global Constraints') - (nl) - (generate-goal $Board $Goal) - (write 'Generated Goal ... And Game.') - (nl))) -; - + (= (generate-game (game $Name $Board $PieceDefs $Goal $Constraints)) + (record-seed) + (new-game-name $Name) + (generate-board $Board) + (write 'Generated Board') + (nl) + (generate-pieces $Board $PieceDefs) + (write 'Generated Pieces') + (nl) + (generate-global-constraints $Constraints) + (write 'Generated Global Constraints') + (nl) + (generate-goal $Board $Goal) + (write 'Generated Goal ... And Game.') + (nl)) - (= - (new-game-name $Name) + (= (new-game-name $Name) (gensym game $Name)) -; - - (= - (reset-game-name) + (= (reset-game-name) (reset-gensym game)) -; - ; -; - +; ================================================================================ ; -; - +; GENERATE BOARD ; -; - +; ================================================================================ ; -; - +; Parameters used: ; -; - +; board_type ; -; - +; board_size ; -; - +; board_crowding ; -; - +; row_crowding ; -; - +; placement_method ; -; - +; promotion_fraction ; -; - +; promote_only ; ; - ; -; - +; board_size: Avg. size of square board. Chess has 8 squares. ; -; - +; board_crowding: Fraction of board to use for placing initial arrays. ; -; - +; Chess uses 1/2 the board ; -; - +; row_crowding: Fraction of each row in init array to fill. Chess fills ; -; - +; the rows entirely. ; -; - +; piece_variety: Of possible pieces (# used array locations), fraction which ; -; - +; will be unique piece types. ; -; - +; promote_only: A number of pieces-types which are generated, but not placed ; -; - +; on the initial board, and thus can only appear by promotion. ; -; - +; While piece_variety is a fraction constrained by the board size, ; -; - +; this is unconstrained, and is thus a range parameter. ; -; - +; Thus, the number of unique piece-types used in a game will be: ; -; - +; placed_pieces: (board_size^2/2)*board_crowding*row_crowding*piece_variety ; -; - +; promote_only: [Lower,Upper] ; -; - +; total = placed_pieces + promote_only ; ; - ; -; - +; Note that the total number of piece types is a major source of complexity ; -; - +; in these games. It does not generally influence the branching factor ; -; - +; (as new pieces only appear when old ones go away), ; -; - +; but it increases exponentially the number of possible positions which can ; -; - +; occur. ; -; - +; board(Size,Type,Inversion,MaxRow,PromoteRow,_KilledSquares, ; -; +; UniquePieces,UniquePlacedPieces,Assignments)) :- - - (= - (generate-board $B) - ( (board $B) - (board-size $B $Size) - (board-type $B $Type) - (board-inversion $B $Inversion) - (board-promote-rows $B $PromoteRow) - (board-array-rows $B $MaxRow) - (board-piece-types $B $UniquePieces) - (board-placed-pieces $B $UniquePlacedPieces) - (board-assignments $B $Assignments) - (choose-board-size $Size) - (size $Size $XMax $YMax) - (choose-board-type $Type) - (choose-board-inversion $Inversion) - (choose-board-crowding $Crowd) - (choose-initial-array-rows $YMax $Crowd $MaxRow) - (choose-promotion-regions $MaxRow $MinRow) - (is $PromoteRow - (- $YMax $MinRow)) - (array-squares $XMax $MaxRow $ArSquares) - (placeable-pieces $ArSquares $UniquePlacedPieces $PlacedPieceSet) - (place-pieces-if-arbitrary $ArSquares $PlacedPieceSet $Assignments) - (promote-only-pieces $UniquePlacedPieces $PromotePieces) - (append $UniquePlacedPieces $PromotePieces $UniquePieces))) -; - + (= (generate-board $B) + (board $B) + (board-size $B $Size) + (board-type $B $Type) + (board-inversion $B $Inversion) + (board-promote-rows $B $PromoteRow) + (board-array-rows $B $MaxRow) + (board-piece-types $B $UniquePieces) + (board-placed-pieces $B $UniquePlacedPieces) + (board-assignments $B $Assignments) + (choose-board-size $Size) + (size $Size $XMax $YMax) + (choose-board-type $Type) + (choose-board-inversion $Inversion) + (choose-board-crowding $Crowd) + (choose-initial-array-rows $YMax $Crowd $MaxRow) + (choose-promotion-regions $MaxRow $MinRow) + (is $PromoteRow + (- $YMax $MinRow)) + (array-squares $XMax $MaxRow $ArSquares) + (placeable-pieces $ArSquares $UniquePlacedPieces $PlacedPieceSet) + (place-pieces-if-arbitrary $ArSquares $PlacedPieceSet $Assignments) + (promote-only-pieces $UniquePlacedPieces $PromotePieces) + (append $UniquePlacedPieces $PromotePieces $UniquePieces)) ; -; - - - (= - (array-squares $MaxCol $MaxRow $Squares) - ( (squares-in-rows 1 $MaxRow $MaxCol $Squares1) (reverse $Squares1 $Squares))) -; +; array_squares(+XMax,+YMax,-Squares) + (= (array-squares $MaxCol $MaxRow $Squares) + (squares-in-rows 1 $MaxRow $MaxCol $Squares1) + (reverse $Squares1 $Squares)) ; -; - +; squares_in_rows(MinRow,MaxRow,MaxCol,Squares) ; -; - +; Generates MaxCol squares in each of rows [MinRow .. MaxRow]. - (= - (squares-in-rows $Min $Max $Size $Squares) - ( (is $Min1 - (- $Min 1)) (squares-in-rows $Max $Min1 $Max $Size $Squares))) -; - + (= (squares-in-rows $Min $Max $Size $Squares) + (is $Min1 + (- $Min 1)) + (squares-in-rows $Max $Min1 $Max $Size $Squares)) - (= - (squares-in-rows $Min $Min $Max $Size Nil) + (= (squares-in-rows $Min $Min $Max $Size Nil) (set-det)) -; - - (= - (squares-in-rows $_ $_ $_ 0 Nil) + (= (squares-in-rows $_ $_ $_ 0 Nil) (set-det)) -; - - (= - (squares-in-rows $Row $Min $Max $Size $Squares) - ( (squares-in-row $Row $Size $RowSquares) - (is $Row1 - (- $Row 1)) - (squares-in-rows $Row1 $Min $Max $Size $RestRows) - (append $RowSquares $RestRows $Squares))) -; + (= (squares-in-rows $Row $Min $Max $Size $Squares) + (squares-in-row $Row $Size $RowSquares) + (is $Row1 + (- $Row 1)) + (squares-in-rows $Row1 $Min $Max $Size $RestRows) + (append $RowSquares $RestRows $Squares)) - - (= - (squares-in-row $Row 0 Nil) + (= (squares-in-row $Row 0 Nil) (set-det)) -; - - (= - (squares-in-row $Row $Size - (Cons $Square $Squares)) - ( (is $Size1 - (- $Size 1)) - (square $Square $Size $Row) - (squares-in-row $Row $Size1 $Squares))) -; - + (= (squares-in-row $Row $Size (Cons $Square $Squares)) + (is $Size1 + (- $Size 1)) + (square $Square $Size $Row) + (squares-in-row $Row $Size1 $Squares)) +; ; Column first, then row. ; -; - +; PLACE_PIECES_IF_ARBITRARY(+ArSquares,+PieceSet,-Assignments) ; -; - +; PieceSet is the set of pieces which will be assigned to ; -; - +; squares in ArSquares (the initial array squares). ; -; - +; This is either done arbitrarily, in which case the pairings ; -; - +; are made now, or by some method of decision, in which ; -; - +; case the piece set and assignable squares will be given with ; -; - +; the corresponding method, the assignment itself to be done at ; -; - +; game time. ; ; - ; -; - +; Parameter: placement_method ; ; - - (= - (place-pieces-if-arbitrary $ArSquares $PieceSet $Assignments) - ( (choose-placement-method $Method) (placement-for-method $Method $PieceSet $ArSquares $Assignments))) -; - + (= (place-pieces-if-arbitrary $ArSquares $PieceSet $Assignments) + (choose-placement-method $Method) + (placement-for-method $Method $PieceSet $ArSquares $Assignments)) - (= - (placement-for-method arbitrary $PieceSet $ArSquares $Assignments) - ( (set-det) (assign-pieces-to-squares $PieceSet $ArSquares $Assignments))) -; - - (= - (placement-for-method $Method $PieceSet $ArSquares $Assignments) + (= (placement-for-method arbitrary $PieceSet $ArSquares $Assignments) + (set-det) + (assign-pieces-to-squares $PieceSet $ArSquares $Assignments)) + (= (placement-for-method $Method $PieceSet $ArSquares $Assignments) (decision $Assignments $Method $PieceSet $ArSquares)) -; - - (= - (assign-pieces-to-squares $Pieces $Squares $Assignments) - ( (randomly-pair $Pieces $Squares $Assignments1) (collect-placements $Assignments1 $Assignments))) -; - + (= (assign-pieces-to-squares $Pieces $Squares $Assignments) + (randomly-pair $Pieces $Squares $Assignments1) + (collect-placements $Assignments1 $Assignments)) - (= - (collect-placements $In $Out) + (= (collect-placements $In $Out) (collect-placements $In Nil $Out)) -; - - - (= - (collect_placements () $X $X) True) -; - - (= - (collect-placements - (Cons - (= $A $Elt) $Rest) $Current $New) - ( (collapse - (= $A $Elt) $Current $New1) (collect-placements $Rest $New1 $New))) -; + (= (collect_placements () $X $X) True) + (= (collect-placements (Cons (= $A $Elt) $Rest) $Current $New) + (collapse + (= $A $Elt) $Current $New1) + (collect-placements $Rest $New1 $New)) - (= - (collapse - (= $A $Elt) Nil - (:: (= $A (:: $Elt)))) + (= (collapse (= $A $Elt) Nil (:: (= $A (:: $Elt)))) (set-det)) -; - - (= - (collapse - (= $A $Elt) - (Cons - (= $A $Elts) $Rest) - (Cons - (= $A - (Cons $Elt $Elts)) $Rest)) + (= (collapse (= $A $Elt) (Cons (= $A $Elts) $Rest) (Cons (= $A (Cons $Elt $Elts)) $Rest)) (set-det)) -; - - (= - (collapse - (= $A $Elt) - (Cons $H $Rest) - (Cons $H $Out)) + (= (collapse (= $A $Elt) (Cons $H $Rest) (Cons $H $Out)) (collapse (= $A $Elt) $Rest $Out)) -; - ; -; - - - - (= - (uncollect () ()) True) -; - - (= - (uncollect - (Cons - (= $A $Elts) $Rest) $Out) - ( (uncollapse $A $Elts $As) - (uncollect $Rest $R) - (append $As $R $Out))) -; +; collapse(X,Y,[X|Y]). + (= (uncollect () ()) True) + (= (uncollect (Cons (= $A $Elts) $Rest) $Out) + (uncollapse $A $Elts $As) + (uncollect $Rest $R) + (append $As $R $Out)) - (= - (uncollapse $_ () ()) True) -; - (= - (uncollapse $A - (Cons $H $T) - (Cons - (= $A $H) $Ts)) + (= (uncollapse $_ () ()) True) + (= (uncollapse $A (Cons $H $T) (Cons (= $A $H) $Ts)) (uncollapse $A $T $Ts)) -; - - (= - (unpair () ()) True) -; - - (= - (unpair - (Cons - (= $Piece $Sq) $Rest) - (Cons $Sq $Squares)) + (= (unpair () ()) True) + (= (unpair (Cons (= $Piece $Sq) $Rest) (Cons $Sq $Squares)) (unpair $Rest $Squares)) -; - ; -; - +; PLACEABLE_PIECES(+ArSquares,-UniquePieces,-PieceSet) ; -; - +; ------------- ; -; - +; ARSQUARES: a set of squares to which pieces might be ; -; - +; initially assigned. ; -; - +; UNIQUEPIECES: a set of unique piece names (containing at least 1 piece) ; -; - +; PIECESET: duplicates these unique pieces to achieve a set of the right size. ; ; - ; -; - +; Parameters used here: ; -; - +; row_crowding: what fraction of squares to place pieces on in initial array. ; -; - +; piece_variety: of a possible number of pieces, what fraction should be unique. ; -; - +; (Checkers has low variety, chess has high, shogi even higher). ; -; - +; row_crowding * possible_set_size --> number of squares to be assigned pieces ; -; - +; piece_variety * assigned_squares --> number of unique pieces to be generated. ; ; + (= (placeable-pieces $ArSquares $UniquePieces $PieceSet) + (length $ArSquares $Possible) + (unique-piece-size $Possible $UniqueNum $SetSize) + (tracing-gen-format pieces "Out of <~p> max possible types, chose <~p>, <~p> unique~n" + (:: $Possible $SetSize $UniqueNum)) + (n-piece-names $UniqueNum $UniquePieces) + (duplicate-pieces $UniquePieces $SetSize $PieceSet) + (tracing-gen-format pieces "Unique: ~p~n Resulting set: ~p~n" + (:: $UniquePieces $PieceSet))) - (= - (placeable-pieces $ArSquares $UniquePieces $PieceSet) - ( (length $ArSquares $Possible) - (unique-piece-size $Possible $UniqueNum $SetSize) - (tracing-gen-format pieces "Out of <~p> max possible types, chose <~p>, <~p> unique~n" - (:: $Possible $SetSize $UniqueNum)) - (n-piece-names $UniqueNum $UniquePieces) - (duplicate-pieces $UniquePieces $SetSize $PieceSet) - (tracing-gen-format pieces "Unique: ~p~n Resulting set: ~p~n" - (:: $UniquePieces $PieceSet)))) -; - - - - (= - (unique-piece-size $Possible $UniqueNum $SetSize) - ( (piece-set-size $Possible $SetSize) - (choose-parameter piece-variety $Variety_Factor) - (is $UniqueNum1 - (integer (* $SetSize $Variety_Factor))) - (max $UniqueNum1 1 $UniqueNum))) -; + (= (unique-piece-size $Possible $UniqueNum $SetSize) + (piece-set-size $Possible $SetSize) + (choose-parameter piece-variety $Variety_Factor) + (is $UniqueNum1 + (integer (* $SetSize $Variety_Factor))) + (max $UniqueNum1 1 $UniqueNum)) ; -; - +; PIECE_SET_SIZE(+Possible,-SetSize) ; -; - +; Out of some possible maximum size, chooses some subset of ; -; - +; squares to assign pieces to initially, based on the parameter ; -; - - - (= - (piece-set-size $Possible $SetSize) - ( (choose-parameter row-crowding $Crowding) - (is $Size - (integer (* $Crowding $Possible))) - (max $Size 1 $SetSize))) -; +; ROW_CROWDING, the average fraction of possible squares to use. + (= (piece-set-size $Possible $SetSize) + (choose-parameter row-crowding $Crowding) + (is $Size + (integer (* $Crowding $Possible))) + (max $Size 1 $SetSize)) ; -; - +; PROMOTE_ONLY_PIECES(-Pieces) ; -; - +; Generates a number of unique piece types, which will ; -; - +; only be seen via promotion (i.e. they are not placed on ; -; - +; the initial board). ; -; - +; We ensure that no more than 26 pieces will be placed in total, ; -; - +; else we can no longer distinguish them using letters! ; -; - +; Parameter: promote_only ; -; - +; Note this parameter is independent of board size, ; -; - +; and is specified as a range. ; ; - - (= - (promote-only-pieces $PlacedPieces $Pieces) - ( (choose-parameter promote-only-pieces $N) - (length $PlacedPieces $Used) - (is $Next - (+ $Used 1)) - (is $Last1 - (+ $Next $N)) - (min $Last1 26 $Last) - (n-piece-names $Next $Last $Pieces))) -; - + (= (promote-only-pieces $PlacedPieces $Pieces) + (choose-parameter promote-only-pieces $N) + (length $PlacedPieces $Used) + (is $Next + (+ $Used 1)) + (is $Last1 + (+ $Next $N)) + (min $Last1 26 $Last) + (n-piece-names $Next $Last $Pieces)) ; -; - +; DUPLICATE_PIECES ; -; - +; continue duplicating random elements until achieve ; -; +; a set of the desired size. Resulting list is sorted. + (= (duplicate-pieces $UniquePieces $SetSize $PieceSet) + (duplicate-elements $UniquePieces $SetSize $PieceSet1) + (stable-sort $PieceSet1 $PieceSet)) - (= - (duplicate-pieces $UniquePieces $SetSize $PieceSet) - ( (duplicate-elements $UniquePieces $SetSize $PieceSet1) (stable-sort $PieceSet1 $PieceSet))) -; + (= (duplicate-elements $UniqueElements $SetSize $Elementset) + (length $UniqueElements $L) + (duplicate-elements $UniqueElements $L $SetSize $DuplicateSet) + (append $UniqueElements $DuplicateSet $Elementset)) - - (= - (duplicate-elements $UniqueElements $SetSize $Elementset) - ( (length $UniqueElements $L) - (duplicate-elements $UniqueElements $L $SetSize $DuplicateSet) - (append $UniqueElements $DuplicateSet $Elementset))) -; - - - (= - (duplicate-elements $Types $Size $Size Nil) + (= (duplicate-elements $Types $Size $Size Nil) (set-det)) -; - - (= - (duplicate-elements $Types $Size $Target - (Cons $E $Elements)) - ( (random-element $Types $E) - (is $Size1 - (+ $Size 1)) - (duplicate-elements $Types $Size1 $Target $Elements))) -; - + (= (duplicate-elements $Types $Size $Target (Cons $E $Elements)) + (random-element $Types $E) + (is $Size1 + (+ $Size 1)) + (duplicate-elements $Types $Size1 $Target $Elements)) ; -; - +; ================================================================================ ; -; - +; Generating unique piece names ; -; +; ================================================================================ - - (= - (n-piece-names $N $Pieces) + (= (n-piece-names $N $Pieces) (n-piece-names 1 $N $Pieces)) -; - - (= - (n-piece-names $N $Max Nil) - ( (> $N $Max) (set-det))) -; - - (= - (n-piece-names $N $Max - (Cons $P $Pieces)) - ( (new-piece-name $N $P) - (is $N1 - (+ $N 1)) - (n-piece-names $N1 $Max $Pieces))) -; - + (= (n-piece-names $N $Max Nil) + (> $N $Max) + (set-det)) + (= (n-piece-names $N $Max (Cons $P $Pieces)) + (new-piece-name $N $P) + (is $N1 + (+ $N 1)) + (n-piece-names $N1 $Max $Pieces)) - (= - (new-piece-name $Index $Name) + (= (new-piece-name $Index $Name) (random-success (possible-index-piece $Index $Name))) -; - - (= - (possible-index-piece $I $Name) - ( (indexed-names $I $Names) (member $Name $Names))) -; - + (= (possible-index-piece $I $Name) + (indexed-names $I $Names) + (member $Name $Names)) ; -; +; ================================================================================ - - (= - (choose-board-size $Size) - ( (choose-parameter board-size $XMax) - (choose-parameter board-size $YMax) - (size $Size $XMax $YMax))) -; - + (= (choose-board-size $Size) + (choose-parameter board-size $XMax) + (choose-parameter board-size $YMax) + (size $Size $XMax $YMax)) - (= - (choose-board-type $Type) + (= (choose-board-type $Type) (choose-parameter board-type $Type)) -; - - (= - (choose-board-inversion $Type) + (= (choose-board-inversion $Type) (choose-parameter board-inversion $Type)) -; - - (= - (choose-board-crowding $Crowd) + (= (choose-board-crowding $Crowd) (choose-parameter board-crowding $Crowd)) -; + (= (choose-initial-array-rows $Size $Crowding $MaxRow) + (is $MaxRow1 + (integer (/ (* $Size $Crowding) 2))) + (max 1 $MaxRow1 $MaxRow)) - (= - (choose-initial-array-rows $Size $Crowding $MaxRow) - ( (is $MaxRow1 - (integer (/ (* $Size $Crowding) 2))) (max 1 $MaxRow1 $MaxRow))) -; + (= (choose-promotion-regions $MaxRow $MinRow) + (choose-promotion-fraction $D) + (is $MinRow + (integer (* $MaxRow $D)))) - (= - (choose-promotion-regions $MaxRow $MinRow) - ( (choose-promotion-fraction $D) (is $MinRow (integer (* $MaxRow $D))))) -; - - - - (= - (choose-promotion-fraction $D) + (= (choose-promotion-fraction $D) (choose-parameter promotion-fraction $D)) -; - - (= - (choose-placement-method $M) + (= (choose-placement-method $M) (choose-parameter placement-method $M)) -; - ; -; - +; ================================================================================ ; -; - +; GENERATE PIECES ; -; +; ================================================================================ - - (= - (generate-pieces $Board $PieceDefs) - ( (board-piece-types $Board $Types) - (generate-pieces $Types $Board $PieceDefs1) - (sort $PieceDefs1 $PieceDefs))) -; - + (= (generate-pieces $Board $PieceDefs) + (board-piece-types $Board $Types) + (generate-pieces $Types $Board $PieceDefs1) + (sort $PieceDefs1 $PieceDefs)) ; -; +; generate_pieces(+PieceTypes,+Board,-PieceDefs) + (= (generate_pieces () $_ ()) True) + (= (generate-pieces (Cons $P $Ps) $Board (Cons $Def $Defs)) + (generate-piece $P $Board $Def) + (generate-pieces $Ps $Board $Defs)) - (= - (generate_pieces () $_ ()) True) -; - - (= - (generate-pieces - (Cons $P $Ps) $Board - (Cons $Def $Defs)) - ( (generate-piece $P $Board $Def) (generate-pieces $Ps $Board $Defs))) -; - - - (= - (generate-piece $Name $Board $Piece) - ( (piece $Piece) - (piece-name $Piece $Name) - (assign-movement-power $Piece $Board) - (assign-capture-power $Piece $Board) - (assign-promotion-power $Piece $Board) - (assign-piece-constraints $Piece $Board))) -; - + (= (generate-piece $Name $Board $Piece) + (piece $Piece) + (piece-name $Piece $Name) + (assign-movement-power $Piece $Board) + (assign-capture-power $Piece $Board) + (assign-promotion-power $Piece $Board) + (assign-piece-constraints $Piece $Board)) ; -; - +; ============================================================ ; -; - +; Constructing movements ; -; +; ============================================================ - - (= - (assign-movement-power $Piece $Board) - ( (create-complex-movement $Board $Movement) (piece-movement $Piece $Movement))) -; - + (= (assign-movement-power $Piece $Board) + (create-complex-movement $Board $Movement) + (piece-movement $Piece $Movement)) - (= - (create-complex-movement $Board $Movement) - ( (create-movement $Board $M1) (complexify-movement $Board $M1 $Movement))) -; + (= (create-complex-movement $Board $Movement) + (create-movement $Board $M1) + (complexify-movement $Board $M1 $Movement)) - - (= - (complexify-movement $Board $MIn - (Cons $MIn $MOut)) - ( (choose-parameter movement-complexity) - (set-det) - (create-complex-movement $Board $MOut))) -; - - (= - (complexify_movement $_ $X - ($X)) True) -; - + (= (complexify-movement $Board $MIn (Cons $MIn $MOut)) + (choose-parameter movement-complexity) + (set-det) + (create-complex-movement $Board $MOut)) + (= (complexify_movement $_ $X ($X)) True) - (= - (create-movement $Board $Movement) - ( (movement $Movement) - (choose-direction $Board $Dir) - (movement-dir $Movement $Dir) - (choose-symmetries $Syms) - (movement-sym $Movement $Syms) - (choose-movement-type $Type) - (constrain-movement $Type $Dir $Board $Movement))) -; - + (= (create-movement $Board $Movement) + (movement $Movement) + (choose-direction $Board $Dir) + (movement-dir $Movement $Dir) + (choose-symmetries $Syms) + (movement-sym $Movement $Syms) + (choose-movement-type $Type) + (constrain-movement $Type $Dir $Board $Movement)) ; -; - +; ======================================== ; -; - +; Directions of movement ; -; - +; ======================================== ; -; - +; Scales in both directions, s.t. a wide board ; -; - +; is likely to have pieces which move farther in ; -; - +; Y direction than in X. ; -; - +; Subtracts 1 from X & Y, since piece must be on ; -; +; a square initially, so 1 less to move total. - - (= - (choose-direction $Board $Dir) - ( (choose-locality $L) - (board-size $Board $X $Y) - (is $XMax1 - (integer (* (- $X 1) $L))) - (is $YMax1 - (integer (* (- $Y 1) $L))) - (max 1 $XMax1 $XMax) - (max 1 $YMax1 $YMax) - (choose-dir $XMax $YMax $Dir))) -; + (= (choose-direction $Board $Dir) + (choose-locality $L) + (board-size $Board $X $Y) + (is $XMax1 + (integer (* (- $X 1) $L))) + (is $YMax1 + (integer (* (- $Y 1) $L))) + (max 1 $XMax1 $XMax) + (max 1 $YMax1 $YMax) + (choose-dir $XMax $YMax $Dir)) +; ; XMax1 is (X-1)*L // 1, ; YMax1 is (Y-1)*L // 1, - - (= - (choose-dir $XMax $YMax $Dir) - ( (choose-delta $XMax $Dx) - (choose-delta $YMax $Dy) - (legal-dir $XMax $YMax $Dx $Dy $Dir))) -; - + (= (choose-dir $XMax $YMax $Dir) + (choose-delta $XMax $Dx) + (choose-delta $YMax $Dy) + (legal-dir $XMax $YMax $Dx $Dy $Dir)) ; -; - +; If (0,0), choose both again. ; -; - - - (= - (legal-dir $XMax $YMax 0 0 $Dir) - ( (set-det) (choose-dir $XMax $YMax $Dir))) -; +; Rules out ZERO leaper (Dickens). - (= - (legal-dir $_ $_ $Dx $Dy $Dir) + (= (legal-dir $XMax $YMax 0 0 $Dir) + (set-det) + (choose-dir $XMax $YMax $Dir)) + (= (legal-dir $_ $_ $Dx $Dy $Dir) (direction $Dir $Dx $Dy)) -; - ; -; - +; A delta is any random integer from [0,Max]. - (= - (choose-delta $Max $Delta) - ( (is $M - (+ $Max 1)) (random 0 $M $Delta))) -; + (= (choose-delta $Max $Delta) + (is $M + (+ $Max 1)) + (random 0 $M $Delta)) - - (= - (max-delta $Dir $D) - ( (direction $Dir $X $Y) (max $X $Y $D))) -; - + (= (max-delta $Dir $D) + (direction $Dir $X $Y) + (max $X $Y $D)) ; -; - +; ======================================== ; -; - +; Symmetries ; -; - +; ======================================== ; -; - +; Chooses the three symmetries with their respective (and independent) ; -; - +; probabilities (which are parameters). ; ; - - (= - (choose-symmetries $Sym) - ( (symmetry $Sym) - (choose-parameter - (symmetry rotation) $R) - (choose-parameter - (symmetry forward) $F) - (choose-parameter - (symmetry side) $S) - (sym-forward $Sym $F) - (sym-side $Sym $S) - (sym-rotation $Sym $R))) -; - + (= (choose-symmetries $Sym) + (symmetry $Sym) + (choose-parameter + (symmetry rotation) $R) + (choose-parameter + (symmetry forward) $F) + (choose-parameter + (symmetry side) $S) + (sym-forward $Sym $F) + (sym-side $Sym $S) + (sym-rotation $Sym $R)) ; -; - +; ======================================== ; -; - +; Constraints on movements ; -; - +; ======================================== ; -; - +; Movement types are chosen with different exclusive probabilities, ; -; - +; using the parameter: movement_type. ; -; - +; Leapers are unconstrained. ; -; - +; Riders can have a min, max, and longest restrictions (must ride). ; -; - +; Hoppers have number before, over, after, and hopped-over piece_type restrictions. - (= - (choose-locality $L) + (= (choose-locality $L) (choose-parameter locality $L)) -; - - (= - (choose-movement-type $T) + (= (choose-movement-type $T) (choose-parameter movement-type $T)) -; - - (= - (constrain-movement leaper $_ $Board $Movement) - ( (set-det) - (leaper $L) - (movement-type $Movement $L))) -; - - (= - (constrain-movement rider $Dir $Board $Movement) - ( (set-det) - (rider $Rider) - (choose-must-ride $Rider) - (choose-min-ride $Board $Dir $Rider) - (choose-max-ride $Board $Dir $Rider) - (movement-type $Movement $Rider))) -; - - (= - (constrain-movement hopper $Dir $Board $Movement) - ( (set-det) - (hopper $Hopper) - (choose-hopper-type $Board $R) - (hopper-type $Hopper $R) - (choose-before $Hopper $Board) - (choose-over $Hopper $Board) - (choose-after $Hopper $Board) - (valid-hopper $Hopper $Dir $Board $Movement))) -; - + (= (constrain-movement leaper $_ $Board $Movement) + (set-det) + (leaper $L) + (movement-type $Movement $L)) + (= (constrain-movement rider $Dir $Board $Movement) + (set-det) + (rider $Rider) + (choose-must-ride $Rider) + (choose-min-ride $Board $Dir $Rider) + (choose-max-ride $Board $Dir $Rider) + (movement-type $Movement $Rider)) + (= (constrain-movement hopper $Dir $Board $Movement) + (set-det) + (hopper $Hopper) + (choose-hopper-type $Board $R) + (hopper-type $Hopper $R) + (choose-before $Hopper $Board) + (choose-over $Hopper $Board) + (choose-after $Hopper $Board) + (valid-hopper $Hopper $Dir $Board $Movement)) ; -; - +; ======================================== ; -; - +; Riders ; -; +; ======================================== - - (= - (choose-must-ride $Rider) - ( (choose-parameter must-ride $Must) (rider-must $Rider $Must))) -; - + (= (choose-must-ride $Rider) + (choose-parameter must-ride $Must) + (rider-must $Rider $Must)) - (= - (choose-min-ride $Board $Dir $Rider) + (= (choose-min-ride $Board $Dir $Rider) (rider-min $Rider 1)) -; - ; -; - +; CHOOSE_MAX_RIDE(+Board,+Dir,+Rider) ; -; - +; Parameters: ; -; - +; locality: the fraction of a board which should be traversible ; -; - +; by an average piece movement. ; -; - +; The max ride is then some number of rides s.t. a piece won't ; -; +; go beyond this locality by riding the max distance. - - (= - (choose-max-ride $Board $Dir $Rider) - ( (choose-locality $L) - (board-max-size $Board $Size) - (max-delta $Dir $D) - (is $Rides - (integer (/ (* $L $Size) $D))) - (set-max-rides $Rider $Rides))) -; + (= (choose-max-ride $Board $Dir $Rider) + (choose-locality $L) + (board-max-size $Board $Size) + (max-delta $Dir $D) + (is $Rides + (integer (/ (* $L $Size) $D))) + (set-max-rides $Rider $Rides)) +; ; Dist is L*Size // 1, ; Rides is Dist // D, - - (= - (set-max-rides $Rider $Rides) - ( (> $Rides 1) - (set-det) - (rider-max $Rider $Rides))) -; - - (= - (set-max-rides $Rider $_) + (= (set-max-rides $Rider $Rides) + (> $Rides 1) + (set-det) + (rider-max $Rider $Rides)) + (= (set-max-rides $Rider $_) (rider-max $Rider any)) -; - ; -; - -; -; - -; -; - +; ======================================== +; +; Hoppers +; +; ======================================== - (= - (choose-before $Hopper $Board) + (= (choose-before $Hopper $Board) (constrain-hopper before $Board $Hopper)) -; - - (= - (choose-over $Hopper $Board) + (= (choose-over $Hopper $Board) (constrain-hopper over $Board $Hopper)) -; - - (= - (choose-after $Hopper $Board) + (= (choose-after $Hopper $Board) (constrain-hopper after $Board $Hopper)) -; - ; -; - +; CONSTRAIN_HOPPER(+Type,+Board,+Hopper) ; -; - +; Different Hop fields (before, over, after) ; -; - +; are constrained or not with their own probabililities, ; -; - +; defined by parameters. ; -; - +; If they aren't to be constrained, an unconstraining value ; -; - +; is placed in that slot (by hopper_any/2). ; ; - - (= - (constrain-hopper $Type $Board $Hopper) + (= (constrain-hopper $Type $Board $Hopper) (det-if-then-else (choose-parameter (constrain (hopper $Type $_))) (hopper-equation $Type $Board $Hopper) (hopper-any $Type $Hopper))) -; - ; -; - +; HOPPER_EQUATION(Type,Board,Hopper) ; -; - +; If a certain field (like BEFORE) is to be constrained, ; ; - - (= - (hopper-equation $Type $Board $Hopper) - ( (board-max-size $Board $Dist) - (hopper-component $Type $Hopper $Comp) - (choose-parameter - (hopper $Type $Dist) $P) - (choose-equation $P $Comp))) -; - + (= (hopper-equation $Type $Board $Hopper) + (board-max-size $Board $Dist) + (hopper-component $Type $Hopper $Comp) + (choose-parameter + (hopper $Type $Dist) $P) + (choose-equation $P $Comp)) ; -; - - - (= - (hopper-any over $Hopper) - ( (set-det) - (comparison $C geq 1) - (hopper-component over $Hopper $C))) -; - - (= - (hopper-any $Type $Hopper) - ( (comparison $C geq 0) (hopper-component $Type $Hopper $C))) -; +; Must always hop over at least one piece. + (= (hopper-any over $Hopper) + (set-det) + (comparison $C geq 1) + (hopper-component over $Hopper $C)) + (= (hopper-any $Type $Hopper) + (comparison $C geq 0) + (hopper-component $Type $Hopper $C)) ; -; - +; ======================================== ; -; - +; Hopper Type ; -; - +; ======================================== ; -; - +; Given a hopper might hop over some pieces, ; -; - +; the legality of the hop may be ; -; - +; restricted to only some kinds of pieces, based on who ; -; - +; owns them, and what type they are. ; -; - +; Doesn't distinguish between order or positions of hopped ; -; - +; pieces (as in hop over 2 empty, then 1player,1opponent,1queen), ; -; - +; though this would be interesting extension. - (= - (choose-hopper-type $Board $C) + (= (choose-hopper-type $Board $C) (choose-piece-description $Board $C)) -; - - (= - (hopper-component before $Hopper $X) + (= (hopper-component before $Hopper $X) (hopper-before $Hopper $X)) -; - - (= - (hopper-component over $Hopper $X) + (= (hopper-component over $Hopper $X) (hopper-over $Hopper $X)) -; - - (= - (hopper-component after $Hopper $X) + (= (hopper-component after $Hopper $X) (hopper-after $Hopper $X)) -; - ; -; - +; Check constraints possible on board, else get new one. - (= - (valid-hopper $Hopper $Dir $Board $Movement) - ( (hopper-can-move $Hopper $Dir $Board) - (set-det) - (movement-type $Movement $Hopper))) -; - - (= - (valid-hopper $Hopper $Dir $Board $Movement) + (= (valid-hopper $Hopper $Dir $Board $Movement) + (hopper-can-move $Hopper $Dir $Board) + (set-det) + (movement-type $Movement $Hopper)) + (= (valid-hopper $Hopper $Dir $Board $Movement) (constrain-movement hopper $Dir $Board $Movement)) -; - ; -; - +; HOPPER_CAN_MOVE(?Hopper,+Dir,+Board) ; -; - +; A hopper can move if it could be on square (1,1), ; -; - +; and make the minimum number of rides along ; -; - +; its principal direction , and still be on the board. ; ; - ; -; - +; Note it is possible a hopper might be able to hop even if ; -; - +; this is false, because of symmetries, but here we ensure ; -; - - - (= - (hopper-can-move $Hopper $Dir $Board) - ( (hopper-min-rides $Hopper $Rides) - (board-size $Board $BX $BY) - (direction $Dir $DX $DY) - (< - (* $Rides $DX) $BX) - (< - (* $Rides $DY) $BY))) -; - +; it can without using symmetries. + (= (hopper-can-move $Hopper $Dir $Board) + (hopper-min-rides $Hopper $Rides) + (board-size $Board $BX $BY) + (direction $Dir $DX $DY) + (< + (* $Rides $DX) $BX) + (< + (* $Rides $DY) $BY)) +; ; Must be at least 1. - (= - (valid-hopper-max-dir $Dx $Dy $Max) - ( (current-board-size $Bx $By) - (is $XMax - (// $Bx $Dx)) - (is $YMax - (// $By $Dy)) - (min $XMax $YMax $Max))) -; + (= (valid-hopper-max-dir $Dx $Dy $Max) + (current-board-size $Bx $By) + (is $XMax + (// $Bx $Dx)) + (is $YMax + (// $By $Dy)) + (min $XMax $YMax $Max)) ; -; - +; hopper_min_rides(+Hopper,-Min) ; -; - +; The Hopper requires at least MIN rides to make ; -; - +; a valid move: ; -; - +; Before_min + Over_min + After_min ; -; +; +1 (as hop finishes with a leap) - - (= - (hopper-min-rides $H $Min) - ( (component-min $H before $Min1) - (component-min $H over $Min2) - (component-min $H after $Min3) - (is $Min + (= (hopper-min-rides $H $Min) + (component-min $H before $Min1) + (component-min $H over $Min2) + (component-min $H after $Min3) + (is $Min + (+ (+ - (+ - (+ $Min1 $Min2) $Min3) 1)))) -; - - + (+ $Min1 $Min2) $Min3) 1))) - (= - (component-min $H $T $Min) - ( (hopper-component $T $H $Eq) (min-rides $Eq $Min))) -; + (= (component-min $H $T $Min) + (hopper-component $T $H $Eq) + (min-rides $Eq $Min)) - (= - (min-rides $Eq $Min) - ( (comparison $Eq geq $Min) (set-det))) -; - - (= - (min-rides $Eq $Min) - ( (comparison $Eq eq $Min) (set-det))) -; - - (= - (min_rides $Eq 0) True) -; - - + (= (min-rides $Eq $Min) + (comparison $Eq geq $Min) + (set-det)) + (= (min-rides $Eq $Min) + (comparison $Eq eq $Min) + (set-det)) + (= (min_rides $Eq 0) True) - (= - (choose-equation $Num $Eq) - ( (choose-parameter comparative $C) (comparison $Eq $C $Num))) -; + (= (choose-equation $Num $Eq) + (choose-parameter comparative $C) + (comparison $Eq $C $Num)) ; -; - +; =========================================================================== ; -; - +; Generalized Piece Descriptions ; -; - +; =========================================================================== ; -; - +; Piece Description has two components: ; -; - +; Player ; -; - +; Name ; -; - +; Generalizing player, we can get: Player, Any_Player ; -; - +; Generalizing Name, we can get: Piece_list, Any_Piece ; ; - ; -; - +; | ?- board_piece_types(B,[piece1,piece2]),choose_piece_description(B,Desc). ; ; - ; -; - +; B = board(_233,_234,_235,_236,_237,[piece1,piece2],_239,_240), ; -; - - - - (= - (choose-piece-description $Board $Desc) - ( (player-generalization $Board $Player) - (piece-generalization $Board $Pieces) - (piece-description $Desc $Player $Pieces))) -; +; Desc = piece_desc(opponent,piece2) ? + (= (choose-piece-description $Board $Desc) + (player-generalization $Board $Player) + (piece-generalization $Board $Pieces) + (piece-description $Desc $Player $Pieces)) - (= - (piece-generalization $Board $Gen) - ( (choose-piece-generalization-level $L) (generalize-piece $L $Board $Gen))) -; + (= (piece-generalization $Board $Gen) + (choose-piece-generalization-level $L) + (generalize-piece $L $Board $Gen)) - (= - (generalize-piece specific $Board $Pieces) + (= (generalize-piece specific $Board $Pieces) (choose-general-piece-set $Board $Pieces)) -; - - (= - (generalize_piece any $Board any_piece) True) -; - + (= (generalize_piece any $Board any_piece) True) ; -; - +; ---------------------------------------------------------------- ; -; - +; Choosing subsets of defined pieces ; -; - +; ---------------------------------------------------------------- ; -; - +; CHOOSE_GENERAL_PIECE_SET(Board,Pieces) ; -; - - - (= - (choose-general-piece-set $Board $Pieces) - ( (board-piece-types $Board $General) (choose-set-by-param $General more-general-pieces $Pieces))) -; +; Chooses a set of any defined pieces. + (= (choose-general-piece-set $Board $Pieces) + (board-piece-types $Board $General) + (choose-set-by-param $General more-general-pieces $Pieces)) ; -; - +; CHOOSE_UNPLACED_PIECE_SET(Board,Pieces) ; -; - - - (= - (choose-unplaced-piece-set $Board $Pieces) - ( (board-unplaced-pieces $Board $Unplaced) (choose-set-by-param $Unplaced more-arrival-pieces $Pieces))) -; +; Chooses a set of unplaced (promote_only) pieces. + (= (choose-unplaced-piece-set $Board $Pieces) + (board-unplaced-pieces $Board $Unplaced) + (choose-set-by-param $Unplaced more-arrival-pieces $Pieces)) ; -; - +; ======================================= ; -; - +; CHOOSE_SET_BY_PARAM(+Set,+Param,-Items) ; -; - +; ======================================= ; -; - +; Choose conditionally subject to the boolean parameter ; -; - +; Param. ; ; - - (= - (choose-set-by-param $Set $Param $Items) - ( (= $Goal - (choose-parameter $Param)) (choose-conditionally-from-set $Set $Goal $Items))) -; - + (= (choose-set-by-param $Set $Param $Items) + (= $Goal + (choose-parameter $Param)) + (choose-conditionally-from-set $Set $Goal $Items)) ; -; - +; ================================================ ; -; - +; CHOOSE_CONDITIONALLY_FROM_SET(+Set,+Goal,-Items) ; -; - +; ================================================ ; -; - +; Choose a random Item from Set, and if Goal is ; -; - +; satisfied, continue choosing more items. ; -; - +; Ends when no more items to choose, or Goal fails. ; -; - +; Goal should be random from this to be useful. ; -; - +; Resulting list is sorted. ; ; + (= (choose-conditionally-from-set $Set $Goal $Items) + (random-permute $Set $Set1) + (choose-conditionally-from-set1 $Set1 $Goal $Items1) + (sort $Items1 $Items)) - (= - (choose-conditionally-from-set $Set $Goal $Items) - ( (random-permute $Set $Set1) - (choose-conditionally-from-set1 $Set1 $Goal $Items1) - (sort $Items1 $Items))) -; - - - - (= - (choose_conditionally_from_set1 () $_ ()) True) -; - (= - (choose-conditionally-from-set1 - (Cons $Item $Rest) $Goal - (Cons $Item $Items)) + (= (choose_conditionally_from_set1 () $_ ()) True) + (= (choose-conditionally-from-set1 (Cons $Item $Rest) $Goal (Cons $Item $Items)) (det-if-then-else (call $Goal) (choose-conditionally-from-set $Rest $Goal $Items) (= $Items Nil))) -; - - (= - (player-generalization $Board $Gen) - ( (choose-player-generalization-level $L) (generalize-player $L $Board $Gen))) -; - + (= (player-generalization $Board $Gen) + (choose-player-generalization-level $L) + (generalize-player $L $Board $Gen)) ; -; - - - (= - (generalize-player specific $Board $Player) - ( (set-det) (random-player $Board $Player))) -; - - (= - (generalize_player any $Board any_player) True) -; - - - - (= - (random-player $Board $Player) - ( (players $Players) (random-element $Players $Player))) -; - +; Simplified: just either choose specific or any. + (= (generalize-player specific $Board $Player) + (set-det) + (random-player $Board $Player)) + (= (generalize_player any $Board any_player) True) - (= - (players - (player opponent)) True) -; + (= (random-player $Board $Player) + (players $Players) + (random-element $Players $Player)) + (= (players (player opponent)) True) - (= - (random-piece $Board $Piece) - ( (board-piece-types $Board $Types) (random-element $Types $Piece))) -; + (= (random-piece $Board $Piece) + (board-piece-types $Board $Types) + (random-element $Types $Piece)) - (= - (random-square $Board $Sq) - ( (board-size $Board $XMax $YMax) - (random $XMax $X) - (random $YMax $Y) - (square $Sq $X $Y))) -; + (= (random-square $Board $Sq) + (board-size $Board $XMax $YMax) + (random $XMax $X) + (random $YMax $Y) + (square $Sq $X $Y)) - (= - (choose-player-generalization-level $L) + (= (choose-player-generalization-level $L) (choose-parameter player-generalization-level $L)) -; - - (= - (choose-piece-generalization-level $L) + (= (choose-piece-generalization-level $L) (choose-parameter piece-generalization-level $L)) -; - ; -; - +; ============================================================ ; -; - +; Constructing capturing powers ; -; - - - - (= - (assign-capture-power $Piece $Board) - ( (create-complex-capture $Board $Capture) (piece-capture $Piece $Capture))) -; - - +; ============================================================ - (= - (create-complex-capture $Board $Capture) - ( (create-capture $Board $C1) (complexify-capture $Board $C1 $Capture))) -; + (= (assign-capture-power $Piece $Board) + (create-complex-capture $Board $Capture) + (piece-capture $Piece $Capture)) - (= - (complexify-capture $Board $CIn - (Cons $CIn $C1)) - ( (choose-parameter capture-complexity) - (set-det) - (create-complex-capture $Board $C1))) -; + (= (create-complex-capture $Board $Capture) + (create-capture $Board $C1) + (complexify-capture $Board $C1 $Capture)) - (= - (complexify_capture $_ $X - ($X)) True) -; - + (= (complexify-capture $Board $CIn (Cons $CIn $C1)) + (choose-parameter capture-complexity) + (set-det) + (create-complex-capture $Board $C1)) + (= (complexify_capture $_ $X ($X)) True) - (= - (create-capture $Board $Capture) - ( (choose-capture-movements $Board $Movement) - (capture-movement $Capture $Movement) - (choose-capture-methods $Method) - (capture-methods $Capture $Method) - (choose-capture-type $Board $Restrict) - (capture-type $Capture $Restrict) - (choose-capture-effect $Effect) - (capture-effect $Capture $Effect))) -; + (= (create-capture $Board $Capture) + (choose-capture-movements $Board $Movement) + (capture-movement $Capture $Movement) + (choose-capture-methods $Method) + (capture-methods $Capture $Method) + (choose-capture-type $Board $Restrict) + (capture-type $Capture $Restrict) + (choose-capture-effect $Effect) + (capture-effect $Capture $Effect)) ; -; - +; ======================================== ; -; - +; Capture Movements ; -; - +; ======================================== ; -; - +; (Given a piece which moves in some ways) ; -; - +; Find how a piece can move for purposes of capturing. ; ; - ; -; - +; An interesting additional structure parameter could make ; -; +; it prefer to just use same movement as capture. - - (= - (choose-capture-movements $Board $Movement) + (= (choose-capture-movements $Board $Movement) (create-complex-movement $Board $Movement)) -; - -; -; - ; -; - +; ======================================== ; -; - +; Capture Methods ; -; - +; ======================================== ; -; - +; Given a movement, how does piece capture another piece when ; -; - +; making that movement? ; ; - +; +; Kill HOP if piece has no hopping movements when capturing? - (= - (choose-capture-methods $Methods) - ( (choose-parameter - (capture-method retrieve) $R) - (choose-parameter - (capture-method clobber) $C) - (choose-parameter - (capture-method hop) $H) - (method-retrieve $Methods $R) - (method-clobber $Methods $C) - (method-hop $Methods $H))) -; - + (= (choose-capture-methods $Methods) + (choose-parameter + (capture-method retrieve) $R) + (choose-parameter + (capture-method clobber) $C) + (choose-parameter + (capture-method hop) $H) + (method-retrieve $Methods $R) + (method-clobber $Methods $C) + (method-hop $Methods $H)) ; -; - +; ======================================== ; -; - +; Capture Effect ; -; - +; ======================================== ; -; - +; Given a movement that finds a captured piece, ; -; - +; how is the board changed (what happens to both ; -; - +; pieces?). - (= - (choose-capture-effect $E) + (= (choose-capture-effect $E) (choose-parameter capture-effect $E)) -; - ; -; - +; ======================================== ; -; - +; Capture Type ; -; - +; ======================================== ; -; - +; Given a movement that finds a potentially ; -; - +; captured piece, the legality of the capture may be ; -; - +; restricted to only some pieces, based on who ; -; - +; owns them, and what type they are. - (= - (choose-capture-type $Board $C) + (= (choose-capture-type $Board $C) (choose-piece-description $Board $C)) -; - ; -; - +; ============================================================ ; -; - +; Constructing promotion powers ; -; - +; ============================================================ - (= - (assign-promotion-power $Piece $Board) - ( (choose-promotion $Board $Prom) (piece-promote $Piece $Prom))) -; - + (= (assign-promotion-power $Piece $Board) + (choose-promotion $Board $Prom) + (piece-promote $Piece $Prom)) - (= - (choose-promotion $Board $Prom) + (= (choose-promotion $Board $Prom) (det-if-then-else (choose-parameter specific-promotion) (specific-promotion $Board $Prom) - (promotion-decision $Board $Prom))) -; - + (promotion-decision $Board $Prom))) - (= - (specific-promotion $Board - (promote $Piece)) + (= (specific-promotion $Board (promote $Piece)) (random-piece $Board $Piece)) -; - - - - (= - (promotion-decision $Board $D) - ( (random-player $Player) - (choose-piece-description $Board $Desc) - (decision $D) - (decision-chooser $D $Player) - (decision-options $D $Desc))) -; + (= (promotion-decision $Board $D) + (random-player $Player) + (choose-piece-description $Board $Desc) + (decision $D) + (decision-chooser $D $Player) + (decision-options $D $Desc)) - (= - (random-player $P) - ( (board-players $_ $Players) (random-element $Players $P))) -; + (= (random-player $P) + (board-players $_ $Players) + (random-element $Players $P)) - (= - (board-players $B - (:: player opponent)) + (= (board-players $B (:: player opponent)) (board $B)) -; - ; -; - +; ============================================================ ; -; - +; Constructing Piece Move Constraints ; -; - +; ============================================================ ; -; - +; Given a piece can execute different powers, ; -; - +; there are constraints on whether one type of ; -; - +; power must take priority, and whether a ; -; - +; power can be repeated. If so there's a choice ; -; +; whether it MUST be repeated. - - (= - (assign-piece-constraints $Piece $Board) - ( (choose-piece-constraints $Board $Con) (piece-constraints $Piece $Con))) -; - + (= (assign-piece-constraints $Piece $Board) + (choose-piece-constraints $Board $Con) + (piece-constraints $Piece $Con)) - (= - (choose-piece-constraints $Board $Con) - ( (constraint $Con) - (choose-parameter must-capture $Must) - (constraint-must-capture $Con $Must) - (choose-parameter continue-captures $Cont) - (constraint-continue-captures $Con $Cont))) -; - - + (= (choose-piece-constraints $Board $Con) + (constraint $Con) + (choose-parameter must-capture $Must) + (constraint-must-capture $Con $Must) + (choose-parameter continue-captures $Cont) + (constraint-continue-captures $Con $Cont)) - (= - (piece-must-capture $Piece $Must) - ( (piece-constraints $Piece $Con) (constraint-must-capture $Con $Must))) -; - + (= (piece-must-capture $Piece $Must) + (piece-constraints $Piece $Con) + (constraint-must-capture $Con $Must)) - (= - (piece-continue-captures $Piece $Continue) - ( (piece-constraints $Piece $Con) (constraint-continue-captures $Con $Continue))) -; + (= (piece-continue-captures $Piece $Continue) + (piece-constraints $Piece $Con) + (constraint-continue-captures $Con $Continue)) ; -; - +; ============================================================ ; -; - +; Constructing Global Capture Constraints ; -; - +; ============================================================ ; -; - +; Given a piece can execute different powers, ; -; - +; there are constraints on whether one type of ; -; - +; power must take priority, and whether a ; -; - +; power can be repeated. If so there's a choice ; -; +; whether it MUST be repeated. - - (= - (generate-global-constraints $Con) + (= (generate-global-constraints $Con) (choose-game-constraints $Con)) -; - ; -; - +; Games don't continue capturing, only pieces do. ; ; - - (= - (choose-game-constraints $Con) - ( (constraint $Con) - (choose-parameter must-capture $Must) - (constraint-must-capture $Con $Must) - (constraint-continue-captures $Con no))) -; - + (= (choose-game-constraints $Con) + (constraint $Con) + (choose-parameter must-capture $Must) + (constraint-must-capture $Con $Must) + (constraint-continue-captures $Con no)) +; ; choose_parameter(continue_captures,Cont), - (= - (game-must-capture $Game $Must) - ( (game-constraints $Game $Con) (constraint-must-capture $Con $Must))) -; - + (= (game-must-capture $Game $Must) + (game-constraints $Game $Con) + (constraint-must-capture $Con $Must)) - (= - (game-continue-captures $Game $Continue) - ( (game-constraints $Game $Con) (constraint-continue-captures $Con $Continue))) -; - + (= (game-continue-captures $Game $Continue) + (game-constraints $Game $Con) + (constraint-continue-captures $Con $Continue)) ; -; - +; ================================================================================ ; -; - +; GENERATE GOAL ; -; - +; ================================================================================ ; -; - +; G = [stalemate(opponent),(eradicate(piece_desc(player,t)), ; -; - +; arrive(piece_desc(opponent,t),[square(2,2)]))] ? ; ; - ; -; - +; First geneates a stalemate goal, to stalemate either (not both) of the players. ; -; - +; Then, based on GOAL COMPLEXITY parameters, continues to add in ; -; - +; arrival and eradicate goals. The more complex the goal, the easier it is to ; -; - +; achieve, as a player wins if ANY of his goals are achieved (but not those of his opponent). ; ; - ; -; - +; Each additional goal to be added is ensured to add a new winning condition, ; -; - +; in the sense that it is not subsumed by any of the existing goals. ; ; - ; -; - +; After the goal conditions are made as complex as desired, ; -; - +; the goals are SIMPLIFIED. This proceeds as follows: ; -; - +; 1. Remove FULLY DUPLICATE goals ; -; - +; 2. Remove SUBSUMED goals. ; -; - +; This is necessary for goals added which subsume earlier ones (ie were not ; -; - +; subsumed themselves). Thus the earlier ones must be removed. ; ; - ; -; - +; Any other simplifications require more serious theorem proving, ; -; - +; which is beyond the scope of the generator. ; ; - ; -; - +; Subsumed goals: ; -; - +; ---------------- ; -; - +; When the generator produces many goals, it is very likely that several of them ; -; - +; will be somehow redundant. The generator deals with the following types of ; -; - +; redundancy as follows: ; ; - ; -; - +; A goal G1 for SUBSUMES another G2 when G2 being true in a position implies G1 will ; -; - +; also (or already) be true. ; -; - +; a. Both goals are for PLAYER (like eradicate player's [a,b] and player's [a]). ; -; - +; In this case the subsumption is straightforward, based on the sets of pieces ; -; - +; mentioned in the two goals. ; -; - +; b. One goal is for PLAYER, the other for OPPONENT. This is more tricky, ; -; - +; and (in the case of arrival goals) involves inverting the squares mentioned in ; -; - +; the opponent's goal. ; ; - ; -; - +; One effect of this checking is that we will not generate pairs of goals which REQUIRE ; -; - +; to be achieved simultaneously (like a goal to eradicate my king and your king). ; -; - +; However, it still allows situations in which two goals HAPPEN TO BE are achieved ; -; - +; together, and this outcome is declared to be a draw. ; ; - ; -; - +; For example, consider the goals: ; -; - +; stalemate(opponent) ; -; - +; eradicate([player,any_piece]). ; ; - ; -; - +; Here, it is possible to capture your last piece, thus achieving both goals ; -; - +; (as it is your move but your stalemated, so you achieve the first, while I achieve ; -; - +; the second as you have no more pieces). ; -; - +; However, it may still be possible to stalemate you w/o eradicating all your pieces, ; -; - +; so I could still win alone. Thus neither goal subsumes the other. ; ; - - (= - (generate-goal $Board $Goals) - ( (choose-stalemate-goal $Board $Goal1) - (complexify-goal $Board Nil $ComplexGoal) - (tracing-gen-format goals "~n** Simplifying goals ...~n" Nil) - (tracing-gen simplify - (, - (format "Before: ~n" Nil) - (ppl (Cons $Goal1 $ComplexGoal)))) - (simplify-goals - (Cons $Goal1 $ComplexGoal) $Board $Goals) - (tracing-gen-format goals "~n** Done Simplifying.~n" Nil) - (tracing-gen simplify - (, - (format "~nAfter: ~n" Nil) - (ppl $Goals))))) -; - + (= (generate-goal $Board $Goals) + (choose-stalemate-goal $Board $Goal1) + (complexify-goal $Board Nil $ComplexGoal) + (tracing-gen-format goals "~n** Simplifying goals ...~n" Nil) + (tracing-gen simplify + (, + (format "Before: ~n" Nil) + (ppl (Cons $Goal1 $ComplexGoal)))) + (simplify-goals + (Cons $Goal1 $ComplexGoal) $Board $Goals) + (tracing-gen-format goals "~n** Done Simplifying.~n" Nil) + (tracing-gen simplify + (, + (format "~nAfter: ~n" Nil) + (ppl $Goals)))) - (= - (complexify-goal $Board $GIn $G) - ( (choose-parameter goal-complexity) - (set-det) - (unsubsumed-goal $GIn $Board $GNew) - (complexify-goal $Board - (Cons $GNew $GIn) $G))) -; - - (= - (complexify_goal $_ $X $X) True) -; - + (= (complexify-goal $Board $GIn $G) + (choose-parameter goal-complexity) + (set-det) + (unsubsumed-goal $GIn $Board $GNew) + (complexify-goal $Board + (Cons $GNew $GIn) $G)) + (= (complexify_goal $_ $X $X) True) ; -; - +; Keep creating goals until we make one which is not ; -; - - - (= - (unsubsumed-goal $Goals $Board $NewGoal) - ( (create-goal $Board $Goal) (ensure-new-goal $Goals $Board $Goal $NewGoal))) -; - - - - (= - (ensure-new-goal $Goals $Board $Goal $NewGoal) - ( (member $Goal $Goals) - (set-det) - (unsubsumed-goal $Goals $Board $NewGoal))) -; +; subsumed by the existing ones. - (= - (ensure-new-goal $Goals $Board $Goal $NewGoal) - ( (subsumed-goal $Goal $Goals $Board) - (set-det) - (unsubsumed-goal $Goals $Board $NewGoal))) -; + (= (unsubsumed-goal $Goals $Board $NewGoal) + (create-goal $Board $Goal) + (ensure-new-goal $Goals $Board $Goal $NewGoal)) - (= - (ensure_new_goal $Goals $Board $Goal $Goal) True) -; + (= (ensure-new-goal $Goals $Board $Goal $NewGoal) + (member $Goal $Goals) + (set-det) + (unsubsumed-goal $Goals $Board $NewGoal)) + (= (ensure-new-goal $Goals $Board $Goal $NewGoal) + (subsumed-goal $Goal $Goals $Board) + (set-det) + (unsubsumed-goal $Goals $Board $NewGoal)) + (= (ensure_new_goal $Goals $Board $Goal $Goal) True) ; -; - +; ------------------------- ; -; - +; CREATE_GOAL(+Board,-Goal) ; -; - +; ------------------------- ; -; - - - (= - (create-goal $Board $Goal) - ( (choose-parameter goal-type $Type) (choose-goal-of-type $Type $Board $Goal))) -; +; Determines the type of goal based on param: GOAL_TYPE. + (= (create-goal $Board $Goal) + (choose-parameter goal-type $Type) + (choose-goal-of-type $Type $Board $Goal)) - (= - (choose-goal-of-type arrive $B $Goal) + (= (choose-goal-of-type arrive $B $Goal) (choose-arrive-goal $B $Goal)) -; - - (= - (choose-goal-of-type eradicate $B $Goal) + (= (choose-goal-of-type eradicate $B $Goal) (choose-eradicate-goal $B $Goal)) -; - ; -; - +; ================================== ; -; - +; CHOOSE_STALEMATE_GOAL(+Board,Goal) ; -; - +; ================================== ; -; - +; Just pick a random player to be stalemated. ; -; - - - (= - (choose-stalemate-goal $Board $Stale) - ( (random-player $Board $Player) (stalemate-goal $Stale $Player))) -; - +; Could make this depend on a parameter. -; -; + (= (choose-stalemate-goal $Board $Stale) + (random-player $Board $Player) + (stalemate-goal $Stale $Player)) ; -; - +; ================================ ; -; - +; CHOOSE_ARRIVE_GOAL(+Board,-Goal) ; -; - +; ================================ ; -; - +; Arrival goals have list of squares in the grammar. ; -; - - +; Here we generate a list with only 1 square, since the same effect +; +; can be achieved by multiple arrival goals. - (= - (choose-arrive-goal $Board $Goal) - ( (choose-parameter arrive-goal-player $Player) - (choose-arrive-goal-for-player $Player $Type $Squares $Board) - (piece-description $Desc $Player $Type) - (arrive-goal $Goal $Desc $Squares))) -; + (= (choose-arrive-goal $Board $Goal) + (choose-parameter arrive-goal-player $Player) + (choose-arrive-goal-for-player $Player $Type $Squares $Board) + (piece-description $Desc $Player $Type) + (arrive-goal $Goal $Desc $Squares)) - (= - (choose-arrive-goal-for-player player $Type $Squares $Board) + (= (choose-arrive-goal-for-player player $Type $Squares $Board) (player-arrive-goal $Type $Squares $Board)) -; - - (= - (choose-arrive-goal-for-player any-player $Type $Squares $Board) + (= (choose-arrive-goal-for-player any-player $Type $Squares $Board) (player-arrive-goal $Type $Squares $Board)) -; - - (= - (choose-arrive-goal-for-player opponent $Type $Squares $Board) + (= (choose-arrive-goal-for-player opponent $Type $Squares $Board) (opponent-arrive-goal $Type $Squares $Board)) -; - ; -; - - - (= - (player-arrive-goal $Type $Squares $Board) - ( (choose-unplaced-piece-set $Board $Type) - (random-square $Board $Sq) - (= $Squares - (:: $Sq)))) -; +; Player and any_player arrival goals restricted to promote_only pieces. + (= (player-arrive-goal $Type $Squares $Board) + (choose-unplaced-piece-set $Board $Type) + (random-square $Board $Sq) + (= $Squares + (:: $Sq))) ; -; - +; Opponent arrival goals constrained not to be square ; -; - +; to which opponent's pieces might be assigned. ; ; + (= (opponent-arrive-goal $Type $Squares $Board) + (piece-generalization $Board $Type) + (opponent-random-free-square $Board $Sq) + (= $Squares + (:: $Sq))) - (= - (opponent-arrive-goal $Type $Squares $Board) - ( (piece-generalization $Board $Type) - (opponent-random-free-square $Board $Sq) - (= $Squares - (:: $Sq)))) -; - - - - - (= - (opponent-random-free-square $Board $Sq) - ( (board-size $Board $XMax $YMax) - (array-squares $XMax $YMax $BSquares) - (random-permute $BSquares $RSquares) - (board-player-assigned-squares $Board opponent $Assigned) - (free-different-member $RSquares $Assigned $Sq))) -; + (= (opponent-random-free-square $Board $Sq) + (board-size $Board $XMax $YMax) + (array-squares $XMax $YMax $BSquares) + (random-permute $BSquares $RSquares) + (board-player-assigned-squares $Board opponent $Assigned) + (free-different-member $RSquares $Assigned $Sq)) - (= - (free-different-member Nil $_ $_) - ( (format "Error: no free squares for opponent arrival goal!~n" Nil) - (set-det) - (fail))) -; - (= - (free-different-member - (Cons $S $Sqs) $Assigned $Sq) + (= (free-different-member Nil $_ $_) + (format "Error: no free squares for opponent arrival goal!~n" Nil) + (set-det) + (fail)) + (= (free-different-member (Cons $S $Sqs) $Assigned $Sq) (det-if-then-else (member $S $Assigned) (free-different-member $Sqs $Assigned $Sq) (= $Sq $S))) -; - ; -; - +; =================================== ; -; - +; CHOOSE_ERADICATE_GOAL(+Board,-Goal) ; -; - +; =================================== ; -; - +; Checks that eradicate goal contains at least 1 piece which will ; -; - +; actually be on the board at the start of the game (after ; -; - +; placements). Otherwise the game would always be a draw. - (= - (choose-eradicate-goal $Board $Goal) - ( (choose-parameter eradicate-goal-player $Player) - (choose-eradicate-goal-for-player $Player $Type $Board) - (piece-description $Desc $Player $Type) - (eradicate-goal $Goal $Desc))) -; - + (= (choose-eradicate-goal $Board $Goal) + (choose-parameter eradicate-goal-player $Player) + (choose-eradicate-goal-for-player $Player $Type $Board) + (piece-description $Desc $Player $Type) + (eradicate-goal $Goal $Desc)) - (= - (choose-eradicate-goal-for-player $Player $PieceGen $Board) + (= (choose-eradicate-goal-for-player $Player $PieceGen $Board) (eradicate-piece-generalization $Board $PieceGen)) -; - ; -; - +; ----------------------------------------- ; -; - +; ERADICATE_PIECE_GENERALIZATION(Board,Gen) ; -; - +; ----------------------------------------- ; -; - +; Either choose any_piece, or some specific set of pieces. ; -; - +; Depends on params: ; -; - +; eradicate_generalization_level (specific or any) ; -; - +; more_eradicate_pieces (boolean) ; ; - - (= - (eradicate-piece-generalization $Board $Gen) - ( (choose-eradicate-generalization-level $L) (generalize-eradicate-piece $L $Board $Gen))) -; - + (= (eradicate-piece-generalization $Board $Gen) + (choose-eradicate-generalization-level $L) + (generalize-eradicate-piece $L $Board $Gen)) ; -; - +; ================================= ; -; - +; ERADICATE_PIECE_SET(Pieces,Board) ; -; - +; ================================= ; -; - +; Choose a random piece which we are sure will be on the ; -; - +; board. Then possibly choose any other pieces. ; ; + (= (eradicate-piece-set $Board $SortedPieces) + (random-placed-piece $Board $Placed) + (board-piece-types $Board $Types) + (select $Placed $Types $Rest) + (choose-set-by-param $Rest more-eradicate-pieces $Pieces) + (sort + (Cons $Placed $Pieces) $SortedPieces)) - (= - (eradicate-piece-set $Board $SortedPieces) - ( (random-placed-piece $Board $Placed) - (board-piece-types $Board $Types) - (select $Placed $Types $Rest) - (choose-set-by-param $Rest more-eradicate-pieces $Pieces) - (sort - (Cons $Placed $Pieces) $SortedPieces))) -; - - - - (= - (random-placed-piece $Board $Piece) - ( (board-placed-pieces $Board $Pieces) (random-element $Pieces $Piece))) -; + (= (random-placed-piece $Board $Piece) + (board-placed-pieces $Board $Pieces) + (random-element $Pieces $Piece)) - (= - (choose-eradicate-generalization-level $L) + (= (choose-eradicate-generalization-level $L) (choose-parameter eradicate-generalization-level $L)) -; - - (= - (generalize-eradicate-piece specific $Board $Pieces) + (= (generalize-eradicate-piece specific $Board $Pieces) (eradicate-piece-set $Board $Pieces)) -; - - (= - (generalize_eradicate_piece any $Board any_piece) True) -; - + (= (generalize_eradicate_piece any $Board any_piece) True) ; -; - +; -------------------------------------------------------------------------------- ; -; - +; Simplifying Goals ; -; - +; -------------------------------------------------------------------------------- ; -; - +; =========================================== ; -; - +; SIMPLIFY_GOALS(+Complex,+Board,-Simplified) ; -; - +; =========================================== - (= - (simplify-goals $Complex $Board $Simplified) - ( (remove-duplicates $Complex $Simp1) (remove-subsumed $Simp1 $Board $Simplified))) -; - + (= (simplify-goals $Complex $Board $Simplified) + (remove-duplicates $Complex $Simp1) + (remove-subsumed $Simp1 $Board $Simplified)) - (= - (remove-subsumed $Goals $Board $Simplified) + (= (remove-subsumed $Goals $Board $Simplified) (remove-subsumed $Goals $Goals $Board $Simplified)) -; - ; -; - +; Removes all the goals in arg1 which are subsumed by ; -; - - (= - (remove_subsumed () $_ $_ ()) True) -; - - (= - (remove-subsumed - (Cons $Goal $Goals) $AllGoals $Board $Gs) - ( (subsumed-goal $Goal $AllGoals $Board) - (set-det) - (remove-subsumed $Goals $AllGoals $Board $Gs))) -; - - (= - (remove-subsumed - (Cons $Goal $Goals) $AllGoals $Board - (Cons $Goal $Gs)) +; a goal in arg2, given current board Board, resulting in arg4. + (= (remove_subsumed () $_ $_ ()) True) + (= (remove-subsumed (Cons $Goal $Goals) $AllGoals $Board $Gs) + (subsumed-goal $Goal $AllGoals $Board) + (set-det) + (remove-subsumed $Goals $AllGoals $Board $Gs)) + (= (remove-subsumed (Cons $Goal $Goals) $AllGoals $Board (Cons $Goal $Gs)) (remove-subsumed $Goals $AllGoals $Board $Gs)) -; - ; -; - +; ================================== ; -; - +; SUBSUMED_GOAL(+Goal,+Goals,+Board) ; -; - +; ================================== ; -; - +; A goal is subsumed by a set of goals if there is some *other* ; -; - - - (= - (subsumed-goal $Goal $Goals $Board) - ( (member $Sub $Goals) - (not (= $Sub $Goal)) - (subsumes $Sub $Goal $Board) - (tracing-gen-format subsume "~nSubsumed Goal: ~p~nSubsumed by: ~p~n" - (:: $Goal $Sub)))) -; +; goal Sub in Goals which subsumes it. + (= (subsumed-goal $Goal $Goals $Board) + (member $Sub $Goals) + (not (= $Sub $Goal)) + (subsumes $Sub $Goal $Board) + (tracing-gen-format subsume "~nSubsumed Goal: ~p~nSubsumed by: ~p~n" + (:: $Goal $Sub))) ; -; - +; ----------------------------- ; -; - +; SUBSUMES(Subsumer,Goal,Board) ; -; +; ----------------------------- - - (= - (subsumes $Sub $Goal $Board) + (= (subsumes $Sub $Goal $Board) (goal-implies $Goal $Sub $Board)) -; - - (= - (goal-implies $Erad1 $Erad2 $Board) - ( (eradicate-goal $Erad1 $Player1 $Type1) - (eradicate-goal $Erad2 $Player2 $Type2) - (erad-implies $Player1 $Type1 $Player2 $Type2))) -; - - (= - (goal-implies $Arr1 $Arr2 $Board) - ( (arrive-goal $Arr1 $Player1 $Type1 $Sq1) - (arrive-goal $Arr2 $Player2 $Type2 $Sq2) - (arrive-implies $Player1 $Type1 $Sq1 $Player2 $Type2 $Sq2 $Board))) -; - + (= (goal-implies $Erad1 $Erad2 $Board) + (eradicate-goal $Erad1 $Player1 $Type1) + (eradicate-goal $Erad2 $Player2 $Type2) + (erad-implies $Player1 $Type1 $Player2 $Type2)) + (= (goal-implies $Arr1 $Arr2 $Board) + (arrive-goal $Arr1 $Player1 $Type1 $Sq1) + (arrive-goal $Arr2 $Player2 $Type2 $Sq2) + (arrive-implies $Player1 $Type1 $Sq1 $Player2 $Type2 $Sq2 $Board)) ; -; - +; ------------ ; -; - +; erad_implies ; -; - +; ------------ ; -; - +; a. true(erad(player,any_piece)) => true(erad(player,[piece1,piece2])). ; -; - +; true(erad(player,[piece1,piece2,piece3)) => true(erad(player,[piece1,piece2])). ; -; - +; true(erad(player,[piece1,piece2,piece3])) ; -; - +; => (for opponent) true(erad(opponent,[piece1,piece2])). ; ; - - (= - (erad-implies $Player1 $Type1 $Player2 $Type2) + (= (erad-implies $Player1 $Type1 $Player2 $Type2) (type-contains $Type1 $Type2)) -; - ; -; - +; -------------- ; -; - +; arrive_implies ; -; - +; -------------- ; -; - +; a. true(arrive(player,[piece1],square1)) => true(arrive(player,[piece1,piece2],square1)). ; -; - +; true(arrive(player,[piece1],square1)) => ; -; - +; true(arrive(player,[piece1,piece2],[square1,square2)). ; -; - +; b. true(arrive(player,[piece1],square1)) => ; -; - - - (= - (arrive-implies $Player1 $Type1 $Sq1 $Player1 $Type2 $Sq2 $Board) - ( (set-det) (arrive-implies $Type1 $Sq1 $Type2 $Sq2))) -; - - (= - (arrive-implies $Player1 $Type1 $Sq1 $Player2 $Type2 $Sq2 $Board) - ( (invert-board-squares $Board $Sq1 $Sq1Inv) (arrive-implies $Type1 $Sq1Inv $Type2 $Sq2))) -; +; true(arrive(opponent,[piece1,piece2],square2)) {when sq2 is inverted sq1} + (= (arrive-implies $Player1 $Type1 $Sq1 $Player1 $Type2 $Sq2 $Board) + (set-det) + (arrive-implies $Type1 $Sq1 $Type2 $Sq2)) + (= (arrive-implies $Player1 $Type1 $Sq1 $Player2 $Type2 $Sq2 $Board) + (invert-board-squares $Board $Sq1 $Sq1Inv) + (arrive-implies $Type1 $Sq1Inv $Type2 $Sq2)) - (= - (arrive-implies $Type1 $Sq1 $Type2 $Sq2) - ( (type-contains $Type2 $Type1) (squares-contains $Sq2 $Sq1))) -; - + (= (arrive-implies $Type1 $Sq1 $Type2 $Sq2) + (type-contains $Type2 $Type1) + (squares-contains $Sq2 $Sq1)) - (= - (squares-contains $Sq1 $Sq2) + (= (squares-contains $Sq1 $Sq2) (ord-subset $Sq2 $Sq1)) -; - - (= - (type_contains any_piece $_) True) -; - - (= - (type-contains $Type1 $Type2) + (= (type_contains any_piece $_) True) + (= (type-contains $Type1 $Type2) (ord-subset $Type2 $Type1)) -; - ; -; - +; -------------------------------------------------------------------- ; -; - +; These are not used in the generator, but may be useful elsewhere. ; -; - +; -------------------------------------------------------------------- ; -; - +; True if Desc *cannot* match any PLACED pieces. - (= - (unplaced-piece-description $Board $Desc) + (= (unplaced-piece-description $Board $Desc) (not (placed-piece-description $Board $Desc))) -; - ; -; - - - (= - (placed-piece-description $Board $Desc) - ( (piece-description-piece $Desc $Piece) (contains-placed-piece $Piece $Board))) -; +; True if Desc *can* match some PLACED pieces. + (= (placed-piece-description $Board $Desc) + (piece-description-piece $Desc $Piece) + (contains-placed-piece $Piece $Board)) - (= - (contains-placed-piece any-piece $_) + (= (contains-placed-piece any-piece $_) + (set-det)) + (= (contains-placed-piece $Pieces $Board) + (board-placed-pieces $Board $Placed) + (member $P $Pieces) + (member $P $Placed) (set-det)) -; - - (= - (contains-placed-piece $Pieces $Board) - ( (board-placed-pieces $Board $Placed) - (member $P $Pieces) - (member $P $Placed) - (set-det))) -; - ; -; - +; -------------------------------------------------------------------- ; -; - +; ================================================================================ ; -; - +; TRACING execution of game generation routines ; -; - +; ================================================================================ ; -; - +; The following tracing modules are used in this file: ; -; - +; goals: info goal generation ; -; - +; simplify: info on goal simplification ; -; - +; subsume: info on goal redundancy checking and elimination ; -; - +; pieces: info on piece generation. ; ; - ; -; - +; Each module can be set on/off, using set_gen_verbosity (see below), or ; -; - +; using trace_gen_. ; ; - ; -; - +; All can be turned off with silent_gen. !(my-ensure-loaded (library tracing)) -; - - (= - (tracing-gen $Type $Call) + (= (tracing-gen $Type $Call) (det-if-then-else (tracing (gen $Type)) (call $Call) True)) -; - ; -; +; Might cause trouble later when want to use streams also. - - (= - (tracing-gen-format $Type $String $Args) + (= (tracing-gen-format $Type $String $Args) (det-if-then-else (tracing (gen $Type)) (format $String $Args) True)) -; - - (= - (tracing-gen-timing $Type $Call) + (= (tracing-gen-timing $Type $Call) (trace-timing (gen $Type) $Call)) -; - - (= - (set-gen-verbosity $Level $Status) + (= (set-gen-verbosity $Level $Status) (set-tracing (gen $Level) $Status)) -; - - (= - (silent-gen) + (= (silent-gen) (all-gen off)) -; - - (= - (loud-gen) + (= (loud-gen) (all-gen on)) -; - - (= - (all-gen $Status) - ( (set-gen-verbosity goals $Status) - (set-gen-verbosity simplify $Status) - (set-gen-verbosity subsume $Status) - (set-gen-verbosity pieces $Status))) -; - + (= (all-gen $Status) + (set-gen-verbosity goals $Status) + (set-gen-verbosity simplify $Status) + (set-gen-verbosity subsume $Status) + (set-gen-verbosity pieces $Status)) - (= - (trace-gen-subsume) - (set-gen-verbosity subsume on)) -; - + (= (trace-gen-subsume) + (set-gen-verbosity subsume on)) - (= - (trace-gen-simplify) - (set-gen-verbosity simplify on)) -; - + (= (trace-gen-simplify) + (set-gen-verbosity simplify on)) - (= - (trace-gen-goals) - (set-gen-verbosity goals on)) -; - + (= (trace-gen-goals) + (set-gen-verbosity goals on)) - (= - (trace-gen-pieces) - (set-gen-verbosity pieces on)) -; - + (= (trace-gen-pieces) + (set-gen-verbosity pieces on)) ; -; - +; :- trace_gen_simplify. ; -; - +; :- silent_gen. diff --git a/metagame/generator/gen_parameters.metta b/metagame/generator/gen_parameters.metta index cbbf65c..f5c29ee 100644 --- a/metagame/generator/gen_parameters.metta +++ b/metagame/generator/gen_parameters.metta @@ -1,1002 +1,558 @@ +; (convert_to_metta_file gen_parameters $_89120 metagame/generator/gen_parameters.pl metagame/generator/gen_parameters.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; gen_parameters.pl ; -; - +; Defines the parameters used in the chess-like game generator. ; -; - +; board_size: Avg. size of square board. Chess has 8 squares. ; -; - +; board_crowding: Fraction of board to use for placing initial arrays. ; -; - +; Chess uses 1/2 the board ; -; - +; row_crowding: Fraction of each row in init array to fill. Chess fills ; -; - +; the rows entirely. ; -; - +; piece_variety: Of possible pieces (# used array locations), fraction which ; -; - +; will be unique piece types. ; ; - ; -; - +; Thus, the number of unique piece-types used in a game will be: ; -; - +; (board_size^2/2)*board_crowding*row_crowding*piece_variety !(dynamic (/ forced-gen-parameter 2)) -; - !(dynamic (/ gen-parameter 2)) -; - - (= - (gen_parameter board_size - (range 5 6)) True) -; - + (= (gen_parameter board_size (range 5 6)) True) ; -; - +; board_crowding: Fraction of board to use for placing initial arrays. ; -; - +; Chess uses 1/2 the board (4/8 rows) ; -; - +; Checkers uses 3/4 the board (6/8 rows) ; -; - - (= - (gen_parameter board_crowding - (distribution - ( (= 0.5 0.7) - (= 0.3 0.15) - (= 0.7 0.15)))) True) -; - +; Correct to mean distribution later. + (= (gen_parameter board_crowding (distribution ((= 0.5 0.7) (= 0.3 0.15) (= 0.7 0.15)))) True) ; -; - +; row_crowding: what fraction of squares to place pieces on in initial array. ; -; - - (= - (gen_parameter row_crowding - (distribution - ( (= 1.0 0.7) (= 0.7 0.3)))) True) -; - +; Correct to mean distribution eventually. + (= (gen_parameter row_crowding (distribution ((= 1.0 0.7) (= 0.7 0.3)))) True) ; -; - +; Fraction of initial array rows used for promotion, ; -; - - (= - (gen_parameter promotion_fraction - (distribution - ( (= 1.0 0.3) - (= 0.8 0.1) - (= 0.6 0.1) - (= 0.4 0.2) - (= 0.2 0.2) - (= 0 0.1)))) True) -; - +; where smaller fraction means farther distance to promotion. + (= (gen_parameter promotion_fraction (distribution ((= 1.0 0.3) (= 0.8 0.1) (= 0.6 0.1) (= 0.4 0.2) (= 0.2 0.2) (= 0 0.1)))) True) ; -; - +; Of a possible number of pieces, what fraction should be unique. ; -; - - (= - (gen_parameter piece_variety - (distribution - ( (= 1.0 0.4) - (= 0.8 0.2) - (= 0.6 0.2) - (= 0.4 0.2) - (= 0.2 0.0)))) True) -; - +; (Checkers has low variety, chess has high, shogi even higher). + (= (gen_parameter piece_variety (distribution ((= 1.0 0.4) (= 0.8 0.2) (= 0.6 0.2) (= 0.4 0.2) (= 0.2 0.0)))) True) ; -; - +; Number of unique piece types, which will ; -; - +; only be seen via promotion (i.e. they are not placed on ; -; - +; the initial board. ; -; - +; Note this gen_parameter is independent of board size. ; ; - - (= - (gen_parameter promote_only_pieces - (range 1 3)) True) -; - + (= (gen_parameter promote_only_pieces (range 1 3)) True) ; -; - +; placement_method: How the init. config is determined. ; -; - +; Random --> randomly determined before each game. ; -; - +; Arbitrary --> randomly determined before first game, then fixed. ; -; - +; Player --> each player alternates deciding his placement. ; -; - +; Opponent --> each player alternates deciding opponent's placement. ; ; - ; -; - +; So arbitrary is most pre-structured, random is least, decision ; -; - - - (= - (gen_parameter placement_method - (distribution - ( (= random 0.2) - (= arbitrary 0.6) - (= player 0.1) - (= opponent 0.1)))) True) -; +; is midway. + (= (gen_parameter placement_method (distribution ((= random 0.2) (= arbitrary 0.6) (= player 0.1) (= opponent 0.1)))) True) ; -; - - (= - (gen_parameter board_type - (distribution - ( (= planar 0.9) (= vertical_cylinder 0.1)))) True) -; - +; Probability to choose planar vs. cylinder boards. + (= (gen_parameter board_type (distribution ((= planar 0.9) (= vertical_cylinder 0.1)))) True) ; -; - - (= - (gen_parameter board_inversion - (distribution - ( (= forward 0.5) (= diagonal 0.5)))) True) -; - +; Probability to choose forward vs. diagonal board inversion. + (= (gen_parameter board_inversion (distribution ((= forward 0.5) (= diagonal 0.5)))) True) ; -; - - (= - (gen_parameter - (symmetry rotation) 0.9) True) -; - - (= - (gen_parameter - (symmetry forward) 0.9) True) -; - - (= - (gen_parameter - (symmetry side) 0.9) True) -; - +; Prob. of choosing each kind of symmetry (independent). + (= (gen_parameter (symmetry rotation) 0.9) True) + (= (gen_parameter (symmetry forward) 0.9) True) + (= (gen_parameter (symmetry side) 0.9) True) ; -; - +; Complexity of pieces ; -; - +; Upper bound on fraction of board leapers should traverse ; -; - - (= - (gen_parameter locality - (range 0.1 0.8)) True) -; - +; each step. + (= (gen_parameter locality (range 0.1 0.8)) True) ; -; - - (= - (gen_parameter movement_type - (distribution - ( (= leaper 0.4) - (= rider 0.4) - (= hopper 0.2)))) True) -; - +; What fraction of movements should be leapers, riders, and hoppers. + (= (gen_parameter movement_type (distribution ((= leaper 0.4) (= rider 0.4) (= hopper 0.2)))) True) ; -; - - (= - (gen_parameter must_ride 0.2) True) -; - +; Whether riders must make the longest ride (continue riding as long as possible). + (= (gen_parameter must_ride 0.2) True) ; -; - +; Whether to constrain part of the description of a hopper. ; -; - - (= - (gen_parameter - (constrain - (hopper before $_)) 0.5) True) -; - - (= - (gen_parameter - (constrain - (hopper over $_)) 0.5) True) -; - - (= - (gen_parameter - (constrain - (hopper after $_)) 0.5) True) -; - +; (Each component determined independently) + (= (gen_parameter (constrain (hopper before $_)) 0.5) True) + (= (gen_parameter (constrain (hopper over $_)) 0.5) True) + (= (gen_parameter (constrain (hopper after $_)) 0.5) True) ; -; - - (= - (gen_parameter - (hopper before $Max) - (range 0 $Max)) True) -; - +; A hopper can hop 0..Max squares before a piece. + (= (gen_parameter (hopper before $Max) (range 0 $Max)) True) ; -; - - (= - (gen_parameter - (hopper over $Max) - (range 1 $Max)) True) -; - +; A hopper can hop over 1..Max pieces. + (= (gen_parameter (hopper over $Max) (range 1 $Max)) True) ; -; - - (= - (gen_parameter - (hopper after $Max) - (range 1 $Max)) True) -; - +; A hopper can hop 1..Max squares after the last piece. + (= (gen_parameter (hopper after $Max) (range 1 $Max)) True) ; -; - - (= - (gen_parameter comparative - (distribution - ( (= eq 0.5) - (= geq 0.2) - (= leq 0.3)))) True) -; - +; When need a comparison term, which one to use. + (= (gen_parameter comparative (distribution ((= eq 0.5) (= geq 0.2) (= leq 0.3)))) True) ; -; - +; Prob. of continuing to add piece_definitions to a piece_type. ; -; - - (= - (gen_parameter movement_complexity 0.2) True) -; - - (= - (gen_parameter capture_complexity 0.2) True) -; - - (= - (gen_parameter goal_complexity 0.6) True) -; - +; So X; chance of piece having >1 method of moving/capturing. + (= (gen_parameter movement_complexity 0.2) True) + (= (gen_parameter capture_complexity 0.2) True) + (= (gen_parameter goal_complexity 0.6) True) ; -; - +; Independent Prob. of assigning each type of capturing method to ; -; - +; a piece (they can have multiple powers). ; -; - +; Hopping power can only be attached when the capture_movement ; -; - - - (= - (gen_parameter - (capture_method retrieve) 0.2) True) -; - - (= - (gen_parameter - (capture_method clobber) 0.9) True) -; +; is hopping already. - (= - (gen_parameter - (capture_method hop) 0.5) True) -; - - + (= (gen_parameter (capture_method retrieve) 0.2) True) + (= (gen_parameter (capture_method clobber) 0.9) True) + (= (gen_parameter (capture_method hop) 0.5) True) - (= - (gen_parameter capture_effect - (distribution - ( (= remove 0.5) - (= - (possess player) 0.3) - (= - (possess opponent) 0.2)))) True) -; + (= (gen_parameter capture_effect (distribution ((= remove 0.5) (= (possess player) 0.3) (= (possess opponent) 0.2)))) True) ; -; - +; Whether to use any_player or a particular ; -; - - - (= - (gen_parameter player_generalization_level - (distribution - ( (= any 0.2) (= specific 0.8)))) True) -; +; player in general piece descriptions (ie. for capturing and hopping). + (= (gen_parameter player_generalization_level (distribution ((= any 0.2) (= specific 0.8)))) True) ; -; - +; Whether to use any_piece or a particular ; -; - +; set of pieces in piece descriptions. ; -; - +; The more general, the less constrained is the game, ; -; - - - (= - (gen_parameter piece_generalization_level - (distribution - ( (= any 0.5) (= specific 0.5)))) True) -; +; as all interactions apply to more objects. + (= (gen_parameter piece_generalization_level (distribution ((= any 0.5) (= specific 0.5)))) True) ; -; - +; If true, adds some pieces to set in a description. ; -; - +; Thus, a high setting will have more genereral piece ; -; - +; descriptions (when the specific option is selected ; -; +; by piece_generalization_level above). + (= (gen_parameter more_pieces 0.8) True) - (= - (gen_parameter more_pieces 0.8) True) -; - - - (= - (gen_parameter more_general_pieces 0.8) True) -; - + (= (gen_parameter more_general_pieces 0.8) True) ; -; - - - (= - (gen_parameter must_capture 0.3) True) -; +; Whether a piece must capture if it can. + (= (gen_parameter must_capture 0.3) True) ; -; - +; Whether you can continue capturing with a piece once you've captured ; -; - - - (= - (gen_parameter continue_captures 0.1) True) -; +; something. + (= (gen_parameter continue_captures 0.1) True) ; -; - +; For additional goals besides stalemate, the probability of adding ; -; - - - (= - (gen_parameter goal_type - (distribution - ( (= eradicate 0.5) (= arrive 0.5)))) True) -; +; eradicate or arrive goals. + (= (gen_parameter goal_type (distribution ((= eradicate 0.5) (= arrive 0.5)))) True) ; -; - +; Whether an arrival goal is to arrive player's piece, ; -; - +; opponent's piece, or either player's piece on a square. ; -; - +; In goals, having any_player too often makes the game a draw, ; -; - +; as arrival or eradicate goals predicated on any_player ; -; - +; are always achieved for both players together. ; -; - - - (= - (gen_parameter arrive_goal_player - (distribution - ( (= player 0.5) (= opponent 0.5)))) True) -; +; Thus these any_player options have now been removed. + (= (gen_parameter arrive_goal_player (distribution ((= player 0.5) (= opponent 0.5)))) True) ; -; - +; If true, adds more pieces to those which are in the ; -; - +; arrival goal for a player. ; -; - +; Thus, a high setting will make a given arrival goal ; -; - - - (= - (gen_parameter more_arrival_pieces 0.8) True) -; +; easier to achieve. + (= (gen_parameter more_arrival_pieces 0.8) True) ; -; - +; Whether an eradicate goal is to eradicate player's piece ; -; - - (= - (gen_parameter eradicate_goal_player - (distribution - ( (= player 0.2) (= opponent 0.8)))) True) -; - +; or opponent's piece. + (= (gen_parameter eradicate_goal_player (distribution ((= player 0.2) (= opponent 0.8)))) True) ; -; - +; If true, adds more pieces to those which are in the ; -; - +; eradicate goal for a player. ; -; - +; Thus, a high setting will make a given eradicate goal ; -; - - - (= - (gen_parameter more_eradicate_pieces 0.8) True) -; +; *harder* to achieve. + (= (gen_parameter more_eradicate_pieces 0.8) True) ; -; - +; Whether to use any_piece or a particular ; -; - +; set of pieces in a given eradicate goal. ; -; - +; The more general, the more pieces will need to be ; -; - - - (= - (gen_parameter eradicate_generalization_level - (distribution - ( (= any 0.2) (= specific 0.8)))) True) -; +; eradicated, and thus the goal becomes harder. + (= (gen_parameter eradicate_generalization_level (distribution ((= any 0.2) (= specific 0.8)))) True) ; -; - +; The probability of having a piece promote to exactly 1 type of piece, ; -; - - - (= - (gen_parameter specific_promotion 0.4) True) -; +; or having a piece promote as a decision of one of the players. + (= (gen_parameter specific_promotion 0.4) True) ; -; - - - (= - (gen_parameter promotion_method - (distribution - ( (= arbitrary 0.3) - (= player 0.5) - (= opponent 0.1)))) True) -; +; The method of promoting a given piece, if it is not arbitrary. + (= (gen_parameter promotion_method (distribution ((= arbitrary 0.3) (= player 0.5) (= opponent 0.1)))) True) ; -; - +; ================================================================================ ; -; - +; CHOOSE_PARAMETER(+Name,-Value) ; -; - - - (= - (choose-parameter $Name $Value) - ( (forced-gen-parameter $Name - (distribution $Dist)) - (set-det) - (sample-from-distribution - (distribution $Dist) $Value))) -; +; Still must include option for Mean,Std. - (= - (choose-parameter $Name $Value) - ( (gen-parameter $Name - (distribution $Dist)) - (set-det) - (sample-from-distribution - (distribution $Dist) $Value))) -; + (= (choose-parameter $Name $Value) + (forced-gen-parameter $Name + (distribution $Dist)) + (set-det) + (sample-from-distribution + (distribution $Dist) $Value)) + (= (choose-parameter $Name $Value) + (gen-parameter $Name + (distribution $Dist)) + (set-det) + (sample-from-distribution + (distribution $Dist) $Value)) + (= (choose-parameter $Name $Value) + (gen-parameter $Name + (range $Min $Max)) + (set-det) + (sample-from-range + (range $Min $Max) $Value)) + (= (choose-parameter $Name $Value) + (gen-parameter $Name $Int) + (integer $Int) + (set-det) + (adjust-mean $Int $Value)) + (= (choose-parameter $Name $Value) + (gen-parameter $Name $Prob) + (sample-from-distribution + (distribution (:: (= yes $Prob) (= no 1))) $Value)) - (= - (choose-parameter $Name $Value) - ( (gen-parameter $Name - (range $Min $Max)) - (set-det) - (sample-from-range - (range $Min $Max) $Value))) -; - (= - (choose-parameter $Name $Value) - ( (gen-parameter $Name $Int) - (integer $Int) - (set-det) - (adjust-mean $Int $Value))) -; - - (= - (choose-parameter $Name $Value) - ( (gen-parameter $Name $Prob) (sample-from-distribution (distribution (:: (= yes $Prob) (= no 1))) $Value))) -; - - - - (= - (choose-parameter $Name) + (= (choose-parameter $Name) (choose-parameter $Name yes)) -; - - - (= - (block-parameter $Name $Items) - ( (block-distribution $Name $Items $Dist) (add-symbol &self (forced_gen_parameter $Name (distribution $Dist))))) -; + (= (block-parameter $Name $Items) + ( (block-distribution $Name $Items $Dist) (add-is-symbol &self (forced_gen_parameter $Name (distribution $Dist))))) - (= - (unblock-parameter $Name) - (remove-symbol &self + (= (unblock-parameter $Name) + (remove-is-symbol &self (forced_gen_parameter $Name (distribution $Dist)))) -; - - (= - (reset-gen-parameters) - (remove-all-symbols &self + (= (reset-gen-parameters) + (remove-all-atoms &self (forced_gen_parameter $_ $_))) -; - - (= - (set-gen-parameter $P $V) + (= (set-gen-parameter $P $V) (det-if-then-else - (remove-symbol &self + (remove-is-symbol &self (gen_parameter $P $_)) - (add-symbol &self + (add-is-symbol &self (gen_parameter $P $V)) (det-if-then otherwise (trace-output 'Unknown generator parameter ~p!~n' (:: $P))))) -; - ; -; - +; Removes the possible events in ITEMS from ; -; - +; appearing in distribution for gen_parameter NAME, ; -; - - - (= - (block-distribution $Name $Items $Dist) - ( (gen-parameter $Name - (distribution $Dist0)) - (set-det) - (remove-items $Items $Dist0 $Prob $Dist1) - (is $P1 - (/ 1 - (- 1 $Prob))) - (renormalize $Dist1 $P1 $Dist))) -; +; renormalizing, and saving as a blocked distribution. + (= (block-distribution $Name $Items $Dist) + (gen-parameter $Name + (distribution $Dist0)) + (set-det) + (remove-items $Items $Dist0 $Prob $Dist1) + (is $P1 + (/ 1 + (- 1 $Prob))) + (renormalize $Dist1 $P1 $Dist)) - (= - (remove_items () $D 0 $D) True) -; - - (= - (remove-items - (Cons $I $Is) $Dist1 $Prob $Dist) - ( (remove-item $I $Dist1 $Prob1 $Dist2) - (remove-items $Is $Dist2 $Prob2 $Dist) - (is $Prob - (+ $Prob1 $Prob2)))) -; + (= (remove_items () $D 0 $D) True) + (= (remove-items (Cons $I $Is) $Dist1 $Prob $Dist) + (remove-item $I $Dist1 $Prob1 $Dist2) + (remove-items $Is $Dist2 $Prob2 $Dist) + (is $Prob + (+ $Prob1 $Prob2))) - - (= - (remove_item $I - (Cons - (= $I $P) $Dist) $P $Dist) True) -; - - (= - (remove-item $I - (Cons $H $T) $P - (Cons $H $Dist)) + (= (remove_item $I (Cons (= $I $P) $Dist) $P $Dist) True) + (= (remove-item $I (Cons $H $T) $P (Cons $H $Dist)) (remove-item $I $T $P $Dist)) -; - - - (= - (renormalize () $_ ()) True) -; - - (= - (renormalize - (Cons - (= $H $P) $Rest) $Ratio - (Cons - (= $H $P1) $Rest1)) - ( (is $P1 - (* $P $Ratio)) (renormalize $Rest $Ratio $Rest1))) -; + (= (renormalize () $_ ()) True) + (= (renormalize (Cons (= $H $P) $Rest) $Ratio (Cons (= $H $P1) $Rest1)) + (is $P1 + (* $P $Ratio)) + (renormalize $Rest $Ratio $Rest1)) ; -; - - - (= - (adjust_mean $Int $Int) True) -; +; For now, just return it. + (= (adjust_mean $Int $Int) True) ; -; - +; ============================================================================== ; -; - +; Printing generator parameters ; -; +; ============================================================================== - - (= - (show-gen-parameters) - ( (whenever - (gen-parameter $Name $Val) - (, - (portray-param (gen-parameter $Name $Val)) - (nl))) - (getrand $R) - (format '~nrandom seed = ~p~n' - (:: $R)))) -; - + (= (show-gen-parameters) + (whenever + (gen-parameter $Name $Val) + (, + (portray-param (gen-parameter $Name $Val)) + (nl))) + (getrand $R) + (format '~nrandom seed = ~p~n' + (:: $R))) - (= - (portray-param (gen-parameter $Name $Val)) + (= (portray-param (gen-parameter $Name $Val)) (format "<~p> --> ~p~n" (:: $Name $Val))) -; - - (= - (portray-range (range $Min $Max)) + (= (portray-range (range $Min $Max)) (format "[~p .. ~p]" (:: $Min $Max))) -; - - (= - (portray-dist (distribution $Pairs)) + (= (portray-dist (distribution $Pairs)) (portray-pairs $Pairs)) -; - - (= - (portray_pairs ()) True) -; - - (= - (portray-pairs (Cons $Pair $Pairs)) - ( (portray-pair $Pair) (portray-pairs $Pairs))) -; - + (= (portray_pairs ()) True) + (= (portray-pairs (Cons $Pair $Pairs)) + (portray-pair $Pair) + (portray-pairs $Pairs)) - (= - (portray-pair (= $Event $Val)) + (= (portray-pair (= $Event $Val)) (format "\n ~p: ~p" (:: $Event $Val))) -; - !(add-portrayals (:: portray-param portray-range portray-dist)) -; - ; -; - +; ============================================================================== ; -; - +; Interface for changing generator parameters ; -; - - - - (= - (change-gen-param $Name) - ( (read-new-gen-value $Name $New) (set-gen-parameter $Name $New))) -; +; ============================================================================== - - (= - (read-new-gen-value $Name $New) - ( (gen-parameter $Name $Value) (read-gen-value $Name $Value $New))) -; - + (= (change-gen-param $Name) + (read-new-gen-value $Name $New) + (set-gen-parameter $Name $New)) - (= - (read-gen-value $Name $Value $New) - ( (format "Enter new settings for parameter <~p>:~n" - (:: $Name)) - (format "Old parameter setting: ~p~n" - (:: $Value)) - (read-gen-value $Value $New) - (format "New parameter setting: ~p~n" - (:: $New)))) -; - + (= (read-new-gen-value $Name $New) + (gen-parameter $Name $Value) + (read-gen-value $Name $Value $New)) - (= - (read-gen-value - (distribution $Dist) - (distribution $New)) - ( (set-det) (read-dist $Dist $New))) -; + (= (read-gen-value $Name $Value $New) + (format "Enter new settings for parameter <~p>:~n" + (:: $Name)) + (format "Old parameter setting: ~p~n" + (:: $Value)) + (read-gen-value $Value $New) + (format "New parameter setting: ~p~n" + (:: $New))) - (= - (read-gen-value - (range $Min1 $Max1) - (range $Min $Max)) - ( (set-det) (read-range $Min1 $Max1 $Min $Max))) -; - (= - (read-gen-value $Old $New) + (= (read-gen-value (distribution $Dist) (distribution $New)) + (set-det) + (read-dist $Dist $New)) + (= (read-gen-value (range $Min1 $Max1) (range $Min $Max)) + (set-det) + (read-range $Min1 $Max1 $Min $Max)) + (= (read-gen-value $Old $New) (read-new-val new $Old $New)) -; - - - - - (= - (read_dist () ()) True) -; - (= - (read-dist - (Cons - (= $Event $Prob1) $Rest1) - (Cons - (= $Event $Prob2) $Rest2)) - ( (read-event $Event $Prob1 $Prob2) (read-dist $Rest1 $Rest2))) -; + (= (read_dist () ()) True) + (= (read-dist (Cons (= $Event $Prob1) $Rest1) (Cons (= $Event $Prob2) $Rest2)) + (read-event $Event $Prob1 $Prob2) + (read-dist $Rest1 $Rest2)) - (= - (read-event $Event $Old $New) - ( (format "Prob for <~p> (~p): " - (:: $Event $Old)) - (read $New1) - (new-event-val $Event $Old $New1 $New))) -; + (= (read-event $Event $Old $New) + (format "Prob for <~p> (~p): " + (:: $Event $Old)) + (read $New1) + (new-event-val $Event $Old $New1 $New)) - (= - (new-event-val $Event $Old $New1 $New) + (= (new-event-val $Event $Old $New1 $New) (new-val $Old $New1 $New)) -; - - (= - (new-val $Old $New1 $New) + (= (new-val $Old $New1 $New) (det-if-then-else (= $New1 z) (= $New $Old) (= $New $New1))) -; - - (= - (read-range $Min1 $Max1 $Min $Max) - ( (read-new-val min $Min1 $Min) (read-new-val max $Max1 $Max))) -; - + (= (read-range $Min1 $Max1 $Min $Max) + (read-new-val min $Min1 $Min) + (read-new-val max $Max1 $Max)) - (= - (read-new-val $Name $Old $New) - ( (format "<~p> value (~p): " - (:: $Name $Old)) - (read $New1) - (new-val $Old $New1 $New))) -; - + (= (read-new-val $Name $Old $New) + (format "<~p> value (~p): " + (:: $Name $Old)) + (read $New1) + (new-val $Old $New1 $New)) diff --git a/metagame/generator/genstructs.metta b/metagame/generator/genstructs.metta index ef5b529..74c6bbb 100644 --- a/metagame/generator/genstructs.metta +++ b/metagame/generator/genstructs.metta @@ -1,1009 +1,595 @@ +; (convert_to_metta_file genstructs $_315834 metagame/generator/genstructs.pl metagame/generator/genstructs.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; genstructs.pl ; -; - +; ;; Data Structures used in generating and manipulating game structures. !(my-ensure-loaded (library invert)) -; - ; -; - +; =========================================================================== ; -; - +; Data Structures ; -; - +; =========================================================================== ; -; - +; =========================================================================== ; -; - +; GAME Data Structure ; -; - +; =========================================================================== - (= - (game $X) + (= (game $X) (functor $X game 5)) -; + (= (game (game $N $B $P $G $C) $N $B $P $G $C) True) - (= - (game - (game $N $B $P $G $C) $N $B $P $G $C) True) -; - - - (= - (game-name $G $X) + (= (game-name $G $X) (arg 1 $G $X)) -; - - (= - (game-board $G $X) + (= (game-board $G $X) (arg 2 $G $X)) -; - - (= - (game-pieces $G $X) + (= (game-pieces $G $X) (arg 3 $G $X)) -; - - (= - (game-goal $G $X) + (= (game-goal $G $X) (arg 4 $G $X)) -; - - (= - (game-constraints $G $X) - (arg 5 $G $X)) -; - + (= (game-constraints $G $X) + (arg 5 $G $X)) ; -; - +; =========================================================================== ; -; - +; BOARD Data Structure ; -; - - +; =========================================================================== - (= - (board $B $Size $Type $Inv $R $Arr $K $Types $Set $Ass) - ( (board-size $B $Size) - (board-type $B $Type) - (board-inversion $B $Inv) - (board-promote-rows $B $R) - (board-array-rows $B $Arr) - (board-killed $B $K) - (board-piece-types $B $Types) - (board-placed-pieces $B $Set) - (board-assignments $B $Ass))) -; - (= - (board $X) + (= (board $B $Size $Type $Inv $R $Arr $K $Types $Set $Ass) + (board-size $B $Size) + (board-type $B $Type) + (board-inversion $B $Inv) + (board-promote-rows $B $R) + (board-array-rows $B $Arr) + (board-killed $B $K) + (board-piece-types $B $Types) + (board-placed-pieces $B $Set) + (board-assignments $B $Ass)) + (= (board $X) (functor $X board 9)) -; - - (= - (board-size $B $X) + (= (board-size $B $X) (arg 1 $B $X)) -; - - (= - (board-type $B $X) + (= (board-type $B $X) (arg 2 $B $X)) -; - - (= - (board-inversion $B $X) + (= (board-inversion $B $X) (arg 3 $B $X)) -; - - (= - (board-promote-rows $B $X) + (= (board-promote-rows $B $X) (arg 4 $B $X)) -; - - (= - (board-killed $B $X) + (= (board-killed $B $X) (arg 5 $B $X)) -; + (= (board-piece-types $B $X) + (arg 6 $B $X)) - (= - (board-piece-types $B $X) - (arg 6 $B $X)) -; - + (= (board-placed-pieces $B $X) + (arg 7 $B $X)) - (= - (board-placed-pieces $B $X) - (arg 7 $B $X)) -; - - - (= - (board-assignments $B $X) + (= (board-assignments $B $X) (arg 8 $B $X)) -; - - (= - (board-array-rows $B $X) + (= (board-array-rows $B $X) (arg 9 $B $X)) -; - - - - (= - (board-unplaced-pieces $Board $Set) - ( (board-placed-pieces $Board $Placed) - (board-piece-types $Board $Types) - (ord-subtract $Types $Placed $Set))) -; + (= (board-unplaced-pieces $Board $Set) + (board-placed-pieces $Board $Placed) + (board-piece-types $Board $Types) + (ord-subtract $Types $Placed $Set)) - (= - (board-size $B $X $Y) - ( (board-size $B $Size) (size $Size $X $Y))) -; + (= (board-size $B $X $Y) + (board-size $B $Size) + (size $Size $X $Y)) - (= - (board-max-size $B $M) - ( (board-size $B $X $Y) (max $X $Y $M))) -; + (= (board-max-size $B $M) + (board-size $B $X $Y) + (max $X $Y $M)) + (= (board-assigned-squares $Board $Squares) + (board-assignments $Board $As) + (assignments-use-squares $As $Squares)) - (= - (board-assigned-squares $Board $Squares) - ( (board-assignments $Board $As) (assignments-use-squares $As $Squares))) -; + (= (board-player-assigned-squares $Board $Player $Squares) + (board-assigned-squares $Board $Squares1) + (invert-board-squares-player $Player $Board $Squares1 $Squares)) - (= - (board-player-assigned-squares $Board $Player $Squares) - ( (board-assigned-squares $Board $Squares1) (invert-board-squares-player $Player $Board $Squares1 $Squares))) -; - - - - (= - (assignments-use-squares $As $Squares) - ( (decision $As $Player $PieceSet $Squares) (set-det))) -; - - (= - (assignments-use-squares $Assigns $Squares) + (= (assignments-use-squares $As $Squares) + (decision $As $Player $PieceSet $Squares) + (set-det)) + (= (assignments-use-squares $Assigns $Squares) (assigned-squares $Assigns $Squares)) -; - - - (= - (assigned-squares $Assigns $Squares) - ( (uncollect $Assigns $Pairs) (unpair $Pairs $Squares))) -; + (= (assigned-squares $Assigns $Squares) + (uncollect $Assigns $Pairs) + (unpair $Pairs $Squares)) - (= - (invert_board_squares_player player $Board $Squares $Squares) True) -; - - (= - (invert-board-squares-player opponent $Board $Squares1 $Squares) + (= (invert_board_squares_player player $Board $Squares $Squares) True) + (= (invert-board-squares-player opponent $Board $Squares1 $Squares) (invert-board-squares $Board $Squares1 $Squares)) -; - - - - (= - (invert-board-squares $Board $Squares1 $Squares) - ( (board-size $Board $XN $YN) - (board-inversion $Board $Inv) - (invert-squares-dim $Squares1 $Inv $XN $YN $Squares))) -; - - - (= - (invert_squares_dim () $Inv $XN $YN ()) True) -; - (= - (invert-squares-dim - (Cons $Sq $Sqs) $Inv $XN $YN - (Cons $ISq $ISqs)) - ( (invert-square-dim $Inv $XN $YN $Sq $ISq) (invert-squares-dim $Sqs $Inv $XN $YN $ISqs))) -; + (= (invert-board-squares $Board $Squares1 $Squares) + (board-size $Board $XN $YN) + (board-inversion $Board $Inv) + (invert-squares-dim $Squares1 $Inv $XN $YN $Squares)) + (= (invert_squares_dim () $Inv $XN $YN ()) True) + (= (invert-squares-dim (Cons $Sq $Sqs) $Inv $XN $YN (Cons $ISq $ISqs)) + (invert-square-dim $Inv $XN $YN $Sq $ISq) + (invert-squares-dim $Sqs $Inv $XN $YN $ISqs)) - (= - (invert-square-on-board $Board $Sq1 $Sq2) - ( (board-size $Board $XN $YN) - (board-inversion $Inv) - (invert-square-dim $Inv $XN $YN $Sq1 $Sq2))) -; + (= (invert-square-on-board $Board $Sq1 $Sq2) + (board-size $Board $XN $YN) + (board-inversion $Inv) + (invert-square-dim $Inv $XN $YN $Sq1 $Sq2)) ; -; - +; =========================================================================== ; -; - +; SIZE Data Structure ; -; - +; =========================================================================== - (= - (size - (size $X $Y) $X $Y) True) -; - + (= (size (size $X $Y) $X $Y) True) ; -; - +; =========================================================================== ; -; - +; PIECE Data Structure ; -; +; =========================================================================== - - (= - (piece $Def) + (= (piece $Def) (piece-definition $Def)) -; - - (= - (piece-definition $Def) + (= (piece-definition $Def) (functor $Def piece 5)) -; - - - (= - (piece-definition $Def $Name $Movement $Capture $Promote $Con) - ( (piece-definition $Def) - (piece-name $Def $Name) - (piece-movement $Def $Movement) - (piece-capture $Def $Capture) - (piece-promote $Def $Promote) - (piece-constraints $Def $Con))) -; + (= (piece-definition $Def $Name $Movement $Capture $Promote $Con) + (piece-definition $Def) + (piece-name $Def $Name) + (piece-movement $Def $Movement) + (piece-capture $Def $Capture) + (piece-promote $Def $Promote) + (piece-constraints $Def $Con)) - (= - (piece-name $Piece $X) + (= (piece-name $Piece $X) (arg 1 $Piece $X)) -; - - (= - (piece-movement $Piece $X) + (= (piece-movement $Piece $X) (arg 2 $Piece $X)) -; - - (= - (piece-capture $Piece $X) + (= (piece-capture $Piece $X) (arg 3 $Piece $X)) -; - - (= - (piece-promote $Piece $X) + (= (piece-promote $Piece $X) (arg 4 $Piece $X)) -; - - (= - (piece-constraints $Piece $X) + (= (piece-constraints $Piece $X) (arg 5 $Piece $X)) -; - ; -; - +; =========================================================================== ; -; - +; DIRECTION Data Structure ; -; - - +; =========================================================================== - (= - (direction - (dir $X $Y) $X $Y) True) -; + (= (direction (dir $X $Y) $X $Y) True) ; -; - +; =========================================================================== ; -; - +; SYMMETRY Data Structure ; -; - +; =========================================================================== - (= - (symmetry $X) + (= (symmetry $X) (functor $X symmetry 3)) -; + (= (symmetry (symmetry $F $S $R) $F $S $R) True) - (= - (symmetry - (symmetry $F $S $R) $F $S $R) True) -; - - - (= - (sym-forward $Sym $F) + (= (sym-forward $Sym $F) (arg 1 $Sym $F)) -; - - (= - (sym-side $Sym $S) + (= (sym-side $Sym $S) (arg 2 $Sym $S)) -; - - (= - (sym-rotation $Sym $R) + (= (sym-rotation $Sym $R) (arg 3 $Sym $R)) -; - - (= - (forward $Sym) + (= (forward $Sym) (sym-forward $Sym yes)) -; - - (= - (side $Sym) + (= (side $Sym) (sym-side $Sym yes)) -; - - (= - (rotation $Sym) + (= (rotation $Sym) (sym-rotation $Sym yes)) -; - - (= - (has-symmetry $Sym forward) + (= (has-symmetry $Sym forward) (forward $Sym)) -; - - (= - (has-symmetry $Sym side) + (= (has-symmetry $Sym side) (side $Sym)) -; - - (= - (has-symmetry $Sym rotation) + (= (has-symmetry $Sym rotation) (rotation $Sym)) -; - ; -; - +; =========================================================================== ; -; - +; LEAPER Data Structure ; -; +; =========================================================================== - - (= - (leaper leaper) True) -; - + (= (leaper leaper) True) ; -; - +; =========================================================================== ; -; - +; RIDER Data Structure ; -; - - +; =========================================================================== - (= - (rider - (rider $Must $Min $Max) $Must $Min $Max) True) -; - (= - (rider $R) + (= (rider (rider $Must $Min $Max) $Must $Min $Max) True) + (= (rider $R) (functor $R rider 3)) -; - - (= - (rider-must $R $Must) + (= (rider-must $R $Must) (arg 1 $R $Must)) -; - - (= - (rider-min $R $Min) + (= (rider-min $R $Min) (arg 2 $R $Min)) -; - - (= - (rider-max $R $Max) + (= (rider-max $R $Max) (arg 3 $R $Max)) -; - - (= - (rider-must $Rider) + (= (rider-must $Rider) (rider-must $Rider yes)) -; - ; -; - +; =========================================================================== ; -; - +; HOPPER Data Structure ; -; - - +; =========================================================================== - (= - (hopper - (hopper $Restr $B $O $A) $Restr $B $O $A) True) -; - (= - (hopper $H) + (= (hopper (hopper $Restr $B $O $A) $Restr $B $O $A) True) + (= (hopper $H) (functor $H hopper 4)) -; + (= (hopper-type $H $X) + (hopper $H) + (arg 1 $H $X)) - (= - (hopper-type $H $X) - ( (hopper $H) (arg 1 $H $X))) -; + (= (hopper-before $H $X) + (hopper $H) + (arg 2 $H $X)) + (= (hopper-over $H $X) + (hopper $H) + (arg 3 $H $X)) - (= - (hopper-before $H $X) - ( (hopper $H) (arg 2 $H $X))) -; - - - (= - (hopper-over $H $X) - ( (hopper $H) (arg 3 $H $X))) -; - - - (= - (hopper-after $H $X) - ( (hopper $H) (arg 4 $H $X))) -; - + (= (hopper-after $H $X) + (hopper $H) + (arg 4 $H $X)) ; -; - +; =========================================================================== ; -; - +; MOVEMENT Data Structure ; -; - +; =========================================================================== - (= - (movement $M) + (= (movement $M) (functor $M movement 3)) -; - - (= - (movement-type $M $X) + (= (movement-type $M $X) (arg 1 $M $X)) -; - - (= - (movement-dir $M $X) + (= (movement-dir $M $X) (arg 2 $M $X)) -; - - (= - (movement-sym $M $X) + (= (movement-sym $M $X) (arg 3 $M $X)) -; - ; -; - +; =========================================================================== ; -; - +; COMPLEX_MOVEMENT Data Structure ; -; - - - (= - (complex_movement - (or $M1 $M2) $M1 $M2) True) -; +; =========================================================================== + (= (complex_movement (or $M1 $M2) $M1 $M2) True) ; -; - +; =========================================================================== ; -; - +; COMPLEX_CAPTURE Data Structure ; -; - - - (= - (complex_capture - (or $C1 $C2) $C1 $C2) True) -; +; =========================================================================== + (= (complex_capture (or $C1 $C2) $C1 $C2) True) ; -; - +; =========================================================================== ; -; - +; CAPTURE Data Structure ; -; +; =========================================================================== + (= (capture (capture $Move $Methods $Restr $Effect) $Move $Methods $Restr $Effect) True) - (= - (capture - (capture $Move $Methods $Restr $Effect) $Move $Methods $Restr $Effect) True) -; - - - (= - (capture $X) + (= (capture $X) (functor $X capture 4)) -; - ; -; +; capture_dir(H,X) :- capture(H), arg(1,H,X). + (= (capture-movement $H $X) + (capture $H) + (arg 1 $H $X)) - (= - (capture-movement $H $X) - ( (capture $H) (arg 1 $H $X))) -; + (= (capture-methods $H $X) + (capture $H) + (arg 2 $H $X)) + (= (capture-type $H $X) + (capture $H) + (arg 3 $H $X)) - (= - (capture-methods $H $X) - ( (capture $H) (arg 2 $H $X))) -; - - - (= - (capture-type $H $X) - ( (capture $H) (arg 3 $H $X))) -; - - - (= - (capture-effect $H $X) - ( (capture $H) (arg 4 $H $X))) -; - + (= (capture-effect $H $X) + (capture $H) + (arg 4 $H $X)) ; -; - +; =========================================================================== ; -; - +; COMPARISON Data Structure ; -; - +; =========================================================================== - (= - (comparison $X) + (= (comparison $X) (functor $X comparison 2)) -; - - (= - (comparison - (comparison $Comp $Num) $Comp $Num) True) -; - + (= (comparison (comparison $Comp $Num) $Comp $Num) True) - (= - (comparison-comp $M $X) - ( (comparison $M) (arg 1 $M $X))) -; - - - (= - (comparison-num $M $X) - ( (comparison $M) (arg 2 $M $X))) -; + (= (comparison-comp $M $X) + (comparison $M) + (arg 1 $M $X)) + (= (comparison-num $M $X) + (comparison $M) + (arg 2 $M $X)) ; -; - +; comparison_sym(M,X) :- comparison(M),arg(3,M,X). ; -; - +; =========================================================================== ; -; - +; SQUARE Data Structure ; -; - - +; =========================================================================== - (= - (square - (square $X $Y) $X $Y) True) -; + (= (square (square $X $Y) $X $Y) True) ; -; - +; =========================================================================== ; -; - +; METHOD Data Structure ; -; - +; =========================================================================== - (= - (method $X) + (= (method $X) (functor $X method 3)) -; - - (= - (method - (method $C $R $H) $C $R $H) True) -; - - + (= (method (method $C $R $H) $C $R $H) True) - (= - (method-clobber $M $X) - ( (method $M) (arg 1 $M $X))) -; - - - (= - (method-retrieve $M $X) - ( (method $M) (arg 2 $M $X))) -; + (= (method-clobber $M $X) + (method $M) + (arg 1 $M $X)) - (= - (method-hop $M $X) - ( (method $M) (arg 3 $M $X))) -; + (= (method-retrieve $M $X) + (method $M) + (arg 2 $M $X)) + (= (method-hop $M $X) + (method $M) + (arg 3 $M $X)) ; -; - +; =========================================================================== ; -; - +; PIECE_DESCRIPTION Data Structure ; -; - +; =========================================================================== - (= - (piece_description - (piece_desc $Player $Piece) $Player $Piece) True) -; - - (= - (piece-description $X) + (= (piece_description (piece_desc $Player $Piece) $Player $Piece) True) + (= (piece-description $X) (functor $X piece-desc 2)) -; - - (= - (piece-description-player $M $X) - ( (piece-description $M) (arg 1 $M $X))) -; - - - (= - (piece-description-piece $M $X) - ( (piece-description $M) (arg 2 $M $X))) -; + (= (piece-description-player $M $X) + (piece-description $M) + (arg 1 $M $X)) + (= (piece-description-piece $M $X) + (piece-description $M) + (arg 2 $M $X)) ; -; - +; piece_description_sym(M,X) :- piece_description(M),arg(3,M,X). ; -; - +; =========================================================================== ; -; - +; CONSTRAINT Data Structure ; -; - - +; =========================================================================== - (= - (constraint - (constraint $Must $Cont) $Must $Cont) True) -; - (= - (constraint $X) + (= (constraint (constraint $Must $Cont) $Must $Cont) True) + (= (constraint $X) (functor $X constraint 2)) -; - - (= - (constraint-must-capture $M $X) + (= (constraint-must-capture $M $X) (arg 1 $M $X)) -; - - (= - (constraint-continue-captures $M $X) + (= (constraint-continue-captures $M $X) (arg 2 $M $X)) -; - - (= - (constraint-continue-captures $M) - ( (constraint $M) (constraint-continue-captures $M yes))) -; - - - (= - (constraint-must-capture $M) - ( (constraint $M) (constraint-must-capture $M yes))) -; + (= (constraint-continue-captures $M) + (constraint $M) + (constraint-continue-captures $M yes)) + (= (constraint-must-capture $M) + (constraint $M) + (constraint-must-capture $M yes)) ; -; - +; =========================================================================== ; -; - +; COMPLEX_GOAL Data Structure ; -; - - - (= - (complex_goal - (or $M1 $M2) $M1 $M2) True) -; +; =========================================================================== + (= (complex_goal (or $M1 $M2) $M1 $M2) True) ; -; - +; =========================================================================== ; -; - +; Simple GOAL Data Structures ; -; - +; =========================================================================== ; -; +; ARRIVE + (= (arrive_goal (arrive $Desc $Sq) $Desc $Sq) True) - (= - (arrive_goal - (arrive $Desc $Sq) $Desc $Sq) True) -; - - - (= - (arrive-goal - (arrive $Desc $Sq) $Player $Type $Sq) + (= (arrive-goal (arrive $Desc $Sq) $Player $Type $Sq) (piece-description $Desc $Player $Type)) -; - ; -; - +; ERADICATE - (= - (eradicate_goal - (eradicate $Desc) $Desc) True) -; + (= (eradicate_goal (eradicate $Desc) $Desc) True) - - (= - (eradicate-goal - (eradicate $Desc) $Player $Type) + (= (eradicate-goal (eradicate $Desc) $Player $Type) (piece-description $Desc $Player $Type)) -; - ; -; - - - (= - (stalemate_goal - (stalemate $Player) $Player) True) -; +; STALEMATE + (= (stalemate_goal (stalemate $Player) $Player) True) ; -; - +; =========================================================================== ; -; - +; Decision data structures ; -; - +; =========================================================================== ; -; - +; decision(Decision,Chooser,Options,Constraints). ; -; - +; For promote decisions: ; -; - +; Chooser is just the player who makes this decision. ; -; - +; [Player_Gen,Piece_Gen] is a description of the options. ; -; - +; No constraints. ; -; - +; For assignement decisions: ; -; - +; Chooser is just the player who makes this decision. ; -; - +; [Piece1,...], a set of pieces, is the Options. ; -; +; Constraints is a set of squares on which the pieces can be placed. - - (= - (decision $X) + (= (decision $X) (functor $X decision 3)) -; - - (= - (decision - (decision $C $O $Con) $C $O $Con) True) -; - + (= (decision (decision $C $O $Con) $C $O $Con) True) - (= - (decision-chooser $D $C) + (= (decision-chooser $D $C) (decision $D $C $_ $_)) -; - - (= - (decision-options $D $O) + (= (decision-options $D $O) (decision $D $_ $O $_)) -; - - (= - (decision-constraints $D $Con) + (= (decision-constraints $D $Con) (decision $D $_ $_ $Con)) -; - diff --git a/metagame/generator/grammar.metta b/metagame/generator/grammar.metta index 76f2f7f..2177e2b 100644 --- a/metagame/generator/grammar.metta +++ b/metagame/generator/grammar.metta @@ -1,1817 +1,609 @@ +; (convert_to_metta_file grammar $_89850 metagame/generator/grammar.pl metagame/generator/grammar.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; grammar.pl ; -; - +; ;; This file defines the grammar for symmetric chess-like games. ; -; - +; ;; This grammar is used bidirectionally, to parse game definitions ; -; - +; ;; into an internal representation, and to generate definitions ; -; - +; ;; from an internal representation. ; -; - +; ;; ; -; - +; ;; The grammar is described in the paper: ; -; - +; ;; Metagame in Symmetric Chess-Like Games ; -; - +; ;; ; -; - +; ;; The line and tab symbols in the rules are used for pretty-printing ; -; +; ;; purposes, and are ignored when parameter parsing_mode is parsing. + (= (--> (game $Game) (, {(game $Game $Name $Board $Pieces $Goals $Constraints) } (, (game) (, (game_name $Name) (, line (, (goal_defs $Goals) (, line (, (board $Board) (, line (, (opt_constraints $Constraints) (, line (, (piece_defs $Pieces) (, (end game) period))))))))))))) True) - (= - (--> - (game $Game) - (, - { (game $Game $Name $Board $Pieces $Goals $Constraints) } - (, - (game) - (, - (game_name $Name) - (, line - (, - (goal_defs $Goals) - (, line - (, - (board $Board) - (, line - (, - (opt_constraints $Constraints) - (, line - (, - (piece_defs $Pieces) - (, - (end game) period))))))))))))) True) -; + (= (--> (game_name $Game) (, ($Game) {(is-symbol $Game) })) True) + (= (--> (board $B) (, {(, (board $B) (, (board_size $B $XMax $YMax) (, (board_type $B $Type) (, (board_promote_rows $B $Promote) (, (board_inversion $B $Inversion) (board_assignments $B $Assignments)))))) } (, (board_size) (, (number $XMax) (, (by) (, (number $YMax) (, line (, (board_type) (, (board_type $Type) (, line (, (opt_inversion $Inversion) (, (promote_rank) (, (number $Promote) (, line (, (setup) (, line (assignment_list $Assignments))))))))))))))))) True) - (= - (--> - (game_name $Game) - (, - ($Game) - { (is-symbol $Game) })) True) -; - - - (= - (--> - (board $B) - (, - { (, - (board $B) - (, - (board_size $B $XMax $YMax) - (, - (board_type $B $Type) - (, - (board_promote_rows $B $Promote) - (, - (board_inversion $B $Inversion) - (board_assignments $B $Assignments)))))) } - (, - (board_size) - (, - (number $XMax) - (, - (by) - (, - (number $YMax) - (, line - (, - (board_type) - (, - (board_type $Type) - (, line - (, - (opt_inversion $Inversion) - (, - (promote_rank) - (, - (number $Promote) - (, line - (, - (setup) - (, line - (assignment_list $Assignments))))))))))))))))) True) -; + (= (--> (board_type planar) (planar)) True) + (= (--> (board_type vertical_cylinder) (vertical_cylinder)) True) - (= - (--> - (board_type planar) - (planar)) True) -; + (= (inversion_type forward) True) + (= (inversion_type diagonal) True) - (= - (--> - (board_type vertical_cylinder) - (vertical_cylinder)) True) -; - (= - (inversion_type forward) True) -; + (= (--> (assignment_list $A) (| (assignment_decision $A) (assignments $A))) True) - (= - (inversion_type diagonal) True) -; + (= (--> (assignments ($A)) (assignment $A)) True) + (= (--> (assignments (Cons $A $As)) (, (assignment $A) (, line (assignments $As)))) True) + (= (--> (assignment (= $A $S)) (, (tab 5) (, (piece_name $A) (, (at) (square_list $S))))) True) + (= (--> (assignment_decision $D) (, {(, (decision $D) (, (decision_chooser $D $C) (, (decision_options $D $O) (decision_constraints $D $Con)))) } (, (tab 3) (, (decision) (, (assigner $C) (, (assigns) (, (piece_names $O) (, line (, (tab 5) (, (to) (, (square_list $Con) (, line (, (tab 3) (end decision)))))))))))))) True) - - (= - (--> - (assignment_list $A) - (| - (assignment_decision $A) - (assignments $A))) True) -; - - - - (= - (--> - (assignments - ($A)) - (assignment $A)) True) -; - - (= - (--> - (assignments - (Cons $A $As)) - (, - (assignment $A) - (, line - (assignments $As)))) True) -; - - - (= - (--> - (assignment - (= $A $S)) - (, - (tab 5) - (, - (piece_name $A) - (, - (at) - (square_list $S))))) True) -; - - - (= - (--> - (assignment_decision $D) - (, - { (, - (decision $D) - (, - (decision_chooser $D $C) - (, - (decision_options $D $O) - (decision_constraints $D $Con)))) } - (, - (tab 3) - (, - (decision) - (, - (assigner $C) - (, - (assigns) - (, - (piece_names $O) - (, line - (, - (tab 5) - (, - (to) - (, - (square_list $Con) - (, line - (, - (tab 3) - (end decision)))))))))))))) True) -; - - - (= - (--> - (assigner $C) - (player $C)) True) -; - - (= - (--> - (assigner random) - (random)) True) -; - + (= (--> (assigner $C) (player $C)) True) + (= (--> (assigner random) (random)) True) ; -; - - (= - (--> - (piece_defs ()) ()) True) -; - - (= - (--> - (piece_defs - (Cons $D $Defs)) - (, - (piece_def $D) - (, line - (piece_defs $Defs)))) True) -; +; 0 or more piece definitions. + (= (--> (piece_defs ()) ()) True) + (= (--> (piece_defs (Cons $D $Defs)) (, (piece_def $D) (, line (piece_defs $Defs)))) True) - - (= - (--> - (piece_def $Def) - (, - { (piece_definition $Def $Name $Movement $Capture $Promote $Con) } - (, - (define) - (, - (piece_name $Name) - (, line - (, - (opt_moving $Movement) - (, - (opt_capturing $Capture) - (, - (opt_promoting $Name $Promote) - (, - (opt_constraints $Con) - (, - (end define) line)))))))))) True) -; + (= (--> (piece_def $Def) (, {(piece_definition $Def $Name $Movement $Capture $Promote $Con) } (, (define) (, (piece_name $Name) (, line (, (opt_moving $Movement) (, (opt_capturing $Capture) (, (opt_promoting $Name $Promote) (, (opt_constraints $Con) (, (end define) line)))))))))) True) + (= (--> (opt_moving ()) ()) True) + (= (--> (opt_moving $Movement) (, (tab 3) (, (moving) (, line (, (movement_def $Movement) (, line (, (tab 3) (, (end moving) line)))))))) True) - (= - (--> - (opt_moving ()) ()) True) -; - - (= - (--> - (opt_moving $Movement) - (, - (tab 3) - (, - (moving) - (, line - (, - (movement_def $Movement) - (, line - (, - (tab 3) - (, - (end moving) line)))))))) True) -; - - - (= - (--> - (opt_capturing ()) ()) True) -; - - (= - (--> - (opt_capturing $Capture) - (, - (tab 3) - (, - (capturing) - (, line - (, - (capture_def $Capture) - (, line - (, - (tab 3) - (, - (end capturing) line)))))))) True) -; - + (= (--> (opt_capturing ()) ()) True) + (= (--> (opt_capturing $Capture) (, (tab 3) (, (capturing) (, line (, (capture_def $Capture) (, line (, (tab 3) (, (end capturing) line)))))))) True) ; -; - - (= - (--> - (opt_promoting $Name - (promote $Name)) ()) True) -; - - (= - (--> - (opt_promoting $_ $Promote) - (, - (tab 3) - (, - (promoting) - (, - (promote_def $Promote) - (, line - (, - (tab 3) - (, - (end promoting) line))))))) True) -; - +; If no promote name is given defaults to promoting to same piece. + (= (--> (opt_promoting $Name (promote $Name)) ()) True) + (= (--> (opt_promoting $_ $Promote) (, (tab 3) (, (promoting) (, (promote_def $Promote) (, line (, (tab 3) (, (end promoting) line))))))) True) - (= - (--> - (opt_constraints $Constraint) - (, - { (, - (constraint $Constraint) - (, - (constraint_must_capture $Constraint no) - (constraint_continue_captures $Constraint no))) } ())) True) -; - - (= - (--> - (opt_constraints $Constraint) - (, - (tab 3) - (, - (constraints) - (, - (constraint_def $Constraint) line)))) True) -; - + (= (--> (opt_constraints $Constraint) (, {(, (constraint $Constraint) (, (constraint_must_capture $Constraint no) (constraint_continue_captures $Constraint no))) } ())) True) + (= (--> (opt_constraints $Constraint) (, (tab 3) (, (constraints) (, (constraint_def $Constraint) line)))) True) ; -; +; Defaults to diagonal inversion. + (= (--> (opt_inversion diagonal) ()) True) + (= (--> (opt_inversion $Inversion) (, (inversion) (, (inversion_def $Inversion) line))) True) - (= - (--> - (opt_inversion diagonal) ()) True) -; - - (= - (--> - (opt_inversion $Inversion) - (, - (inversion) - (, - (inversion_def $Inversion) line))) True) -; - + (= (--> (inversion_def $Inversion) (, {(inversion_type $Inversion) } ($Inversion))) True) - (= - (--> - (inversion_def $Inversion) - (, - { (inversion_type $Inversion) } - ($Inversion))) True) -; + (= (--> (movement_def ($M)) (simple_movement $M)) True) + (= (--> (movement_def (Cons $M $Ms)) (, (simple_movement $M) (, line (, line (movement_def $Ms))))) True) + (= (--> (simple_movement $M) (, {(, (movement $M) (, (movement_type $M $T) (, (movement_dir $M $D) (movement_sym $M $S)))) } (, (tab 15) (, (movement) (, line (, (movement_type $T) (, line (, (gdirection $D) (, (syms $S) (, line (, (tab 15) (end movement)))))))))))) True) - (= - (--> - (movement_def - ($M)) - (simple_movement $M)) True) -; - (= - (--> - (movement_def - (Cons $M $Ms)) - (, - (simple_movement $M) - (, line - (, line - (movement_def $Ms))))) True) -; + (= (--> (movement_type $T) (leaper $T)) True) + (= (--> (movement_type $T) (rider $T)) True) + (= (--> (movement_type $T) (hopper $T)) True) + (= (--> (leaper $L) (, {(leaper $L) } (, (tab 20) (leap)))) True) - (= - (--> - (simple_movement $M) - (, - { (, - (movement $M) - (, - (movement_type $M $T) - (, - (movement_dir $M $D) - (movement_sym $M $S)))) } - (, - (tab 15) - (, - (movement) - (, line - (, - (movement_type $T) - (, line - (, - (gdirection $D) - (, - (syms $S) - (, line - (, - (tab 15) - (end movement)))))))))))) True) -; + (= (--> (rider $R) (, {(, (rider $R) (, (rider_must $R $Must) (, (rider_min $R $Min) (rider_max $R $Max)))) } (, (tab 20) (, (ride) (, (min_dist $Min) (, (max_dist $Max) (longest $Must))))))) True) + (= (--> (min_dist 1) ()) True) + (= (--> (min_dist $Min) (, (min) (number $Min))) True) + (= (--> (max_dist any) ()) True) + (= (--> (max_dist $N) (, (max) (number $N))) True) - (= - (--> - (movement_type $T) - (leaper $T)) True) -; - - (= - (--> - (movement_type $T) - (rider $T)) True) -; - - (= - (--> - (movement_type $T) - (hopper $T)) True) -; + (= (--> (longest no) ()) True) + (= (--> (longest yes) (longest)) True) - (= - (--> - (leaper $L) - (, - { (leaper $L) } - (, - (tab 20) - (leap)))) True) -; - - - (= - (--> - (rider $R) - (, - { (, - (rider $R) - (, - (rider_must $R $Must) - (, - (rider_min $R $Min) - (rider_max $R $Max)))) } - (, - (tab 20) - (, - (ride) - (, - (min_dist $Min) - (, - (max_dist $Max) - (longest $Must))))))) True) -; - - - (= - (--> - (min_dist 1) ()) True) -; - - (= - (--> - (min_dist $Min) - (, - (min) - (number $Min))) True) -; - - - (= - (--> - (max_dist any) ()) True) -; - - (= - (--> - (max_dist $N) - (, - (max) - (number $N))) True) -; - - - (= - (--> - (longest no) ()) True) -; - - (= - (--> - (longest yes) - (longest)) True) -; - - - - (= - (--> - (hopper $H) - (, - { (, - (hopper $H) - (, - (hopper_before $H $B) - (, - (hopper_over $H $O) - (, - (hopper_after $H $A) - (hopper_type $H $R))))) } - (, - (tab 20) - (, - (hop) - (, - (before) - (, - (compare_eq $B) - (, - (over) - (, - (compare_eq $O) - (, - (after) - (, - (compare_eq $A) - (, line - (, - (tab 20) - (, - (hop_over) - (description $R)))))))))))))) True) -; - + (= (--> (hopper $H) (, {(, (hopper $H) (, (hopper_before $H $B) (, (hopper_over $H $O) (, (hopper_after $H $A) (hopper_type $H $R))))) } (, (tab 20) (, (hop) (, (before) (, (compare_eq $B) (, (over) (, (compare_eq $O) (, (after) (, (compare_eq $A) (, line (, (tab 20) (, (hop_over) (description $R)))))))))))))) True) ; -; - +; -------------- ; -; - +; Symmetries ; -; - - - (= - (--> - (syms $Sym) - (, - { (symmetry $Sym) } - (, - (symmetry) - (symmetry_set $Sym)))) True) -; +; -------------- + (= (--> (syms $Sym) (, {(symmetry $Sym) } (, (symmetry) (symmetry_set $Sym)))) True) ; -; - - (= - (--> - (symmetry_set $Sym) - (, - { (, - (sym_forward $Sym yes) - (, - (sym_side $Sym yes) - (sym_rotation $Sym yes))) } - (all_symmetry))) True) -; - - (= - (--> - (symmetry_set $Sym) - (, openbrace - (, - (sym_set $Sym) closebrace))) True) -; - - - (= - (--> - (sym_set $Sym) - (, - (forward $Sym) - (, - (side $Sym) - (rotation $Sym)))) True) -; - +; Not produced all_sym. + (= (--> (symmetry_set $Sym) (, {(, (sym_forward $Sym yes) (, (sym_side $Sym yes) (sym_rotation $Sym yes))) } (all_symmetry))) True) + (= (--> (symmetry_set $Sym) (, openbrace (, (sym_set $Sym) closebrace))) True) - - (= - (--> - (forward $Sym) - (, () - { (sym_forward $Sym no) })) True) -; - - (= - (--> - (forward $Sym) - (, - (forward) - { (sym_forward $Sym yes) })) True) -; + (= (--> (sym_set $Sym) (, (forward $Sym) (, (side $Sym) (rotation $Sym)))) True) - (= - (--> - (side $Sym) - (, () - { (sym_side $Sym no) })) True) -; - - (= - (--> - (side $Sym) - (, - (side) - { (sym_side $Sym yes) })) True) -; + (= (--> (forward $Sym) (, () {(sym_forward $Sym no) })) True) + (= (--> (forward $Sym) (, (forward) {(sym_forward $Sym yes) })) True) + (= (--> (side $Sym) (, () {(sym_side $Sym no) })) True) + (= (--> (side $Sym) (, (side) {(sym_side $Sym yes) })) True) - (= - (--> - (rotation $Sym) - (, - (rotation) - { (sym_rotation $Sym yes) })) True) -; - - (= - (--> - (rotation $Sym) - (, - { (sym_rotation $Sym no) } ())) True) -; - + (= (--> (rotation $Sym) (, (rotation) {(sym_rotation $Sym yes) })) True) + (= (--> (rotation $Sym) (, {(sym_rotation $Sym no) } ())) True) ; -; - +; -------------- ; -; - +; Equations ; -; - +; -------------- ; -; - - - (= - (--> - (compare_eq $C) - (, - { (, - (comparison $C $Comp $Number) - (, - (comparison_comp $C $Comp) - (comparison_num $C $Number))) } - (, openb - (, - (x) - (, - (comparative $Comp) - (, - (delta $Number) closeb)))))) True) -; +; Change from eq to = in generator. + (= (--> (compare_eq $C) (, {(, (comparison $C $Comp $Number) (, (comparison_comp $C $Comp) (comparison_num $C $Number))) } (, openb (, (x) (, (comparative $Comp) (, (delta $Number) closeb)))))) True) ; -; - - - (= - (--> - (comparative geq) - (>=)) True) -; - - (= - (--> - (comparative eq) - (=)) True) -; - - (= - (--> - (comparative leq) - (<=)) True) -; +; comparative(Comp) --> [Comp], {comparative(Comp)}. + (= (--> (comparative geq) (>=)) True) + (= (--> (comparative eq) (=)) True) + (= (--> (comparative leq) (<=)) True) ; -; - +; ----------------------------- ; -; - +; Directions, Square_List, Deltas ; -; - - - (= - (--> - (gdirection $Dir) - (, - { (direction $Dir $X $Y) } - (, - (tab 20) - (, - (<) - (, - (delta $X) - (, comma - (, - (delta $Y) - (>)))))))) True) -; - - - (= - (--> - (square_list $Squares) - (, openbrace - (, - (squares $Squares) closebrace))) True) -; +; ---------------------------- + (= (--> (gdirection $Dir) (, {(direction $Dir $X $Y) } (, (tab 20) (, (<) (, (delta $X) (, comma (, (delta $Y) (>)))))))) True) - (= - (--> - (squares - ($H)) - (gsquare $H)) True) -; + (= (--> (square_list $Squares) (, openbrace (, (squares $Squares) closebrace))) True) - (= - (--> - (squares - (Cons $H $T)) - (, - (gsquare $H) - (squares $T))) True) -; + (= (--> (squares ($H)) (gsquare $H)) True) + (= (--> (squares (Cons $H $T)) (, (gsquare $H) (squares $T))) True) + (= (--> (gsquare $Sq) (, {(, (square $Sq $X $Y) (alpha_squares_mode on)) } (, (() (, ($Col) (, {(nth_letter $X $Col) } (, comma (, (number $Y) ())))))))) True) - (= - (--> - (gsquare $Sq) - (, - { (, - (square $Sq $X $Y) - (alpha_squares_mode on)) } - (, - (() - (, - ($Col) - (, - { (nth_letter $X $Col) } - (, comma - (, - (number $Y) - ())))))))) True) -; - - - (= - (--> - (gsquare $Sq) - (, - { (, - (square $Sq $X $Y) - (alpha_squares_mode off)) } - (, - (() - (, - (number $X) - (, comma - (, - (number $Y) - ()))))))) True) -; - - - - (= - (--> - (delta $Delta) - (number $Delta)) True) -; + (= (--> (gsquare $Sq) (, {(, (square $Sq $X $Y) (alpha_squares_mode off)) } (, (() (, (number $X) (, comma (, (number $Y) ()))))))) True) - (= - (--> - (number $N) - (, - ($N) - { (number $N) })) True) -; + (= (--> (delta $Delta) (number $Delta)) True) + (= (--> (number $N) (, ($N) {(number $N) })) True) ; -; - +; -------------- ; -; - +; CAPTURES ; -; - - - (= - (--> - (capture_def - ($C)) - (simple_capture $C)) True) -; - - (= - (--> - (capture_def - (Cons $C $Cs)) - (, - (simple_capture $C) - (, line - (, line - (capture_def $Cs))))) True) -; - - - (= - (--> - (simple_capture $C) - (, - { (, - (capture $C) - (, - (capture_movement $C $M) - (, - (capture_methods $C $T) - (, - (capture_type $C $R) - (capture_effect $C $E))))) } - (, - (tab 5) - (, - (capture by) - (, - (capture_methods $T) - (, line - (, - (tab 14) - (, - (type) - (, - (description $R) - (, line - (, - (tab 14) - (, - (effect) - (, - (effect $E) - (, line - (, - (movement_def $M) - (, line - (, - (tab 5) - (end capture)))))))))))))))))) True) -; - - - (= - (--> - (capture_methods $M) - (, - { (method $M) } - (, openbrace - (, - (retrieve $M) - (, - (clobber $M) - (, - (hop $M) closebrace)))))) True) -; +; -------------- + (= (--> (capture_def ($C)) (simple_capture $C)) True) + (= (--> (capture_def (Cons $C $Cs)) (, (simple_capture $C) (, line (, line (capture_def $Cs))))) True) + (= (--> (simple_capture $C) (, {(, (capture $C) (, (capture_movement $C $M) (, (capture_methods $C $T) (, (capture_type $C $R) (capture_effect $C $E))))) } (, (tab 5) (, (capture by) (, (capture_methods $T) (, line (, (tab 14) (, (type) (, (description $R) (, line (, (tab 14) (, (effect) (, (effect $E) (, line (, (movement_def $M) (, line (, (tab 5) (end capture)))))))))))))))))) True) - (= - (--> - (retrieve $Method) - (, () - { (method_retrieve $Method no) })) True) -; - - (= - (--> - (retrieve $Method) - (, - (retrieve) - { (method_retrieve $Method yes) })) True) -; + (= (--> (capture_methods $M) (, {(method $M) } (, openbrace (, (retrieve $M) (, (clobber $M) (, (hop $M) closebrace)))))) True) - (= - (--> - (clobber $Method) - (, () - { (method_clobber $Method no) })) True) -; + (= (--> (retrieve $Method) (, () {(method_retrieve $Method no) })) True) + (= (--> (retrieve $Method) (, (retrieve) {(method_retrieve $Method yes) })) True) - (= - (--> - (clobber $Method) - (, - (clobber) - { (method_clobber $Method yes) })) True) -; + (= (--> (clobber $Method) (, () {(method_clobber $Method no) })) True) + (= (--> (clobber $Method) (, (clobber) {(method_clobber $Method yes) })) True) - - (= - (--> - (hop $Method) - (, - (hop) - { (method_hop $Method yes) })) True) -; - - (= - (--> - (hop $Method) - (, - { (method_hop $Method no) } ())) True) -; - + (= (--> (hop $Method) (, (hop) {(method_hop $Method yes) })) True) + (= (--> (hop $Method) (, {(method_hop $Method no) } ())) True) ; -; - +; Simplified as in paper grammar. ; -; - - (= - (--> - (effect remove) - (remove)) True) -; - - (= - (--> - (effect - (possess $Player)) - ($Player possesses)) True) -; - +; Removed displacement + (= (--> (effect remove) (remove)) True) + (= (--> (effect (possess $Player)) ($Player possesses)) True) ; -; - +; effect(give) --> [opponent,possesses]. ; -; - +; effect(displace(Player)) --> [Player, displaces]. ; -; - +; effect(displace_enemy) --> [opponent, displaces]. ; -; - +; -------------- ; -; - +; GOALS ; -; - +; -------------- ; -; - +; The generator always produces 1 stalemate goal, ; -; - +; then adds the other 2 types of goals. But this ; -; - +; grammar is actually more general than the games ; -; - +; generated, and programs must be able to read anything ; -; - - - (= - (--> - (goal_defs $Goals) - (, - (goals) - (goals $Goals))) True) -; - - - (= - (--> - (goals ()) ()) True) -; - - (= - (--> - (goals - (Cons $G $Goals)) - (, - (simple_goal $G) - (, line - (, - (tab 5) - (goals $Goals))))) True) -; +; in the class defined by this grammar. + (= (--> (goal_defs $Goals) (, (goals) (goals $Goals))) True) - (= - (--> - (simple_goal $Arrive) - (, - { (arrive_goal $Arrive $Desc $Squares) } - (, - (arrive) - (, - (description $Desc) - (, - (at) - (square_list $Squares)))))) True) -; - + (= (--> (goals ()) ()) True) + (= (--> (goals (Cons $G $Goals)) (, (simple_goal $G) (, line (, (tab 5) (goals $Goals))))) True) - (= - (--> - (simple_goal $Eradicate) - (, - { (eradicate_goal $Eradicate $Desc) } - (, - (eradicate) - (description $Desc)))) True) -; + (= (--> (simple_goal $Arrive) (, {(arrive_goal $Arrive $Desc $Squares) } (, (arrive) (, (description $Desc) (, (at) (square_list $Squares)))))) True) + (= (--> (simple_goal $Eradicate) (, {(eradicate_goal $Eradicate $Desc) } (, (eradicate) (description $Desc)))) True) - (= - (--> - (simple_goal $Stalemate) - (, - { (stalemate_goal $Stalemate $Player) } - (, - (stalemate) - (player $Player)))) True) -; - + (= (--> (simple_goal $Stalemate) (, {(stalemate_goal $Stalemate $Player) } (, (stalemate) (player $Player)))) True) ; -; - +; -------------------- ; -; - +; Descriptions ; -; - - - (= - (--> - (description $Desc) - (, - { (piece_description $Desc $Player $Pieces) } - (, openb - (, - (player_gen $Player) - (, - (piece_names $Pieces) closeb))))) True) -; +; -------------------- + (= (--> (description $Desc) (, {(piece_description $Desc $Player $Pieces) } (, openb (, (player_gen $Player) (, (piece_names $Pieces) closeb))))) True) - (= - (--> - (piece_names any_piece) - (any_piece)) True) -; + (= (--> (piece_names any_piece) (any_piece)) True) + (= (--> (piece_names $Pieces) (, openbrace (, (identifiers $Pieces) closebrace))) True) - (= - (--> - (piece_names $Pieces) - (, openbrace - (, - (identifiers $Pieces) closebrace))) True) -; + (= (--> (identifiers ($Piece)) (piece_name $Piece)) True) + (= (--> (identifiers (Cons $P $Pieces)) (, (piece_name $P) (identifiers $Pieces))) True) - (= - (--> - (identifiers - ($Piece)) - (piece_name $Piece)) True) -; + (= (--> (piece_name $Piece) (, ($Piece) {(is-symbol $Piece) })) True) - (= - (--> - (identifiers - (Cons $P $Pieces)) - (, - (piece_name $P) - (identifiers $Pieces))) True) -; + (= (--> (player_gen $Player) (, openbrace (, (player $Player) closebrace))) True) + (= (--> (player_gen any_player) (any_player)) True) + (= (--> (player player) (player)) True) + (= (--> (player opponent) (opponent)) True) - (= - (--> - (piece_name $Piece) - (, - ($Piece) - { (is-symbol $Piece) })) True) -; - - - - (= - (--> - (player_gen $Player) - (, openbrace - (, - (player $Player) closebrace))) True) -; - - (= - (--> - (player_gen any_player) - (any_player)) True) -; - - - (= - (--> - (player player) - (player)) True) -; - - (= - (--> - (player opponent) - (opponent)) True) -; - - - - (= - (player player) True) -; - - (= - (player opponent) True) -; + (= (player player) True) + (= (player opponent) True) ; -; - +; -------------- ; -; - +; Piece Movement Constraints ; -; +; -------------- + (= (--> (constraint_defs $Constraint) (, {(, (constraint $Constraint) (, (constraint_must_capture $Constraint no) (constraint_continue_captures $Constraint no))) } ())) True) + (= (--> (constraint_defs $Constraint) (, (constraints) (constraint_def $Constraint))) True) - (= - (--> - (constraint_defs $Constraint) - (, - { (, - (constraint $Constraint) - (, - (constraint_must_capture $Constraint no) - (constraint_continue_captures $Constraint no))) } ())) True) -; - - (= - (--> - (constraint_defs $Constraint) - (, - (constraints) - (constraint_def $Constraint))) True) -; - - - - - (= - (--> - (constraint_def $Constraint) - (, - { (constraint $Constraint) } - (, - (must_capture $Constraint) - (continue_captures $Constraint)))) True) -; - (= - (--> - (must_capture $Constraint) - (, - { (constraint_must_capture $Constraint no) } ())) True) -; - - (= - (--> - (must_capture $Constraint) - (, - (must_capture) - { (constraint_must_capture $Constraint yes) })) True) -; + (= (--> (constraint_def $Constraint) (, {(constraint $Constraint) } (, (must_capture $Constraint) (continue_captures $Constraint)))) True) + (= (--> (must_capture $Constraint) (, {(constraint_must_capture $Constraint no) } ())) True) + (= (--> (must_capture $Constraint) (, (must_capture) {(constraint_must_capture $Constraint yes) })) True) - (= - (--> - (continue_captures $Constraint) - (, () - { (constraint_continue_captures $Constraint no) })) True) -; - - (= - (--> - (continue_captures $Constraint) - (, - { (constraint_continue_captures $Constraint yes) } - (continue_captures))) True) -; - + (= (--> (continue_captures $Constraint) (, () {(constraint_continue_captures $Constraint no) })) True) + (= (--> (continue_captures $Constraint) (, {(constraint_continue_captures $Constraint yes) } (continue_captures))) True) ; -; - +; promote_def(Special) --> {promotion(Special,Prom)}, ; -; - - - (= - (--> - (promote_def $Prom) - (, - { (decision $Prom) } - (promotion_decision $Prom))) True) -; - - (= - (--> - (promote_def - (promote $Prom)) - (, - (promote_to) - (piece_name $Prom))) True) -; +; promotion(Prom). + (= (--> (promote_def $Prom) (, {(decision $Prom) } (promotion_decision $Prom))) True) + (= (--> (promote_def (promote $Prom)) (, (promote_to) (piece_name $Prom))) True) ; -; - +; Added chooser to promote within his own, other guys, or anyones ; -; - - - (= - (--> - (promotion_decision $D) - (, - { (, - (decision $D) - (, - (decision_chooser $D $C) - (decision_options $D $O))) } - (, - (decision) - (, - (player $C) - (, line - (, - (tab 10) - (, - (options) - (description $O)))))))) True) -; - - +; piece_names. Must make sure this works, and generator uses it! + (= (--> (promotion_decision $D) (, {(, (decision $D) (, (decision_chooser $D $C) (decision_options $D $O))) } (, (decision) (, (player $C) (, line (, (tab 10) (, (options) (description $O)))))))) True) - (= - (--> line - (, - { (parsing_mode printing) } - (line))) True) -; - (= - (--> line - (, - { (parsing_mode parsing) } ())) True) -; + (= (--> line (, {(parsing_mode printing) } (line))) True) + (= (--> line (, {(parsing_mode parsing) } ())) True) - (= - (--> - (tab $T) - (, - { (parsing_mode printing) } - ( (tab $T)))) True) -; + (= (--> (tab $T) (, {(parsing_mode printing) } ((tab $T)))) True) + (= (--> (tab $T) (, {(parsing_mode parsing) } ())) True) - (= - (--> - (tab $T) - (, - { (parsing_mode parsing) } ())) True) -; + (= (--> (true any) ()) True) - (= - (--> - (true any) ()) True) -; + (= (--> semi (;)) True) + (= (--> colon (:)) True) + (= (--> comma (,)) True) - (= - (--> semi - (;)) True) -; + (= (--> openp (()) True) + (= (--> closep ())) True) - (= - (--> colon - (:)) True) -; + (= (--> openb ([)) True) + (= (--> closeb (])) True) - (= - (--> comma - (,)) True) -; + (= (--> openbrace ({)) True) + (= (--> closebrace (})) True) - (= - (--> openp - (()) True) -; - + (= (--> period (.)) True) - (= - (--> closep - ())) True) -; - - - (= - (--> openb - ([)) True) -; - - - (= - (--> closeb - (])) True) -; - - - (= - (--> openbrace - ({)) True) -; - - - (= - (--> closebrace - (})) True) -; - - - (= - (--> period - (.)) True) -; - - - - (= - (--> identifier - (, - ($X) - { (is-symbol $X) })) True) -; + (= (--> identifier (, ($X) {(is-symbol $X) })) True) ; -; - +; ================================================================================ ; -; - +; Printing Assignments to strings ; -; - +; ================================================================================ ; -; - +; Along with the move and game grammars, the standard form for assignments ; -; - +; in the grammar above is used to transmit initial random assignments to the ; -; - +; players at play-time. ; -; - +; The following routines convert between the grammatical (token) ; -; - +; representation, my system's internal representation, and a character string ; -; - +; encoding of these tokens for communication purposes. ; -; - +; Note the period is added as in all other string representations I use, ; -; +; to determine end of strings. - - (= - (assignments-string $Assignment $String) - ( (var $String) - (set-det) - (assignments $Assignment $Tokens - (Cons . $Rest)) - (print-tokens-to-string $Tokens $String))) -; - - (= - (assignments-string $Assignment $String) - ( (var $Assignment) - (read-tokens-from-string $String $Tokens) - (assignments $Assignment $Tokens - (Cons . $Rest)))) -; - + (= (assignments-string $Assignment $String) + (var $String) + (set-det) + (assignments $Assignment $Tokens + (Cons . $Rest)) + (print-tokens-to-string $Tokens $String)) + (= (assignments-string $Assignment $String) + (var $Assignment) + (read-tokens-from-string $String $Tokens) + (assignments $Assignment $Tokens + (Cons . $Rest))) ; -; - +; ================================================================================ ; -; - +; PORTRAY functions to print certain grammatical constructs ; -; - +; for interface purposes. ; -; +; ================================================================================ - - (= - (portray-square (square $X $Y)) - ( (with-alpha-squares (gsquare (square $X $Y) $S Nil)) (print-tokens $S))) -; + (= (portray-square (square $X $Y)) + (with-alpha-squares (gsquare (square $X $Y) $S Nil)) + (print-tokens $S)) - - (= - (portray-player player) + (= (portray-player player) (write white)) -; - - (= - (portray-player opponent) + (= (portray-player opponent) (write black)) -; + (= (portray-piece (piece $A $B)) + (piece + (piece $A $B) $S Nil) + (print-tokens $S)) - (= - (portray-piece (piece $A $B)) - ( (piece - (piece $A $B) $S Nil) (print-tokens $S))) -; - - - - (= - (portray-moving (move $Piece $Player $From $To)) - ( (moving - (move $Piece $Player $From $To) $S Nil) (print-tokens $S))) -; + (= (portray-moving (move $Piece $Player $From $To)) + (moving + (move $Piece $Player $From $To) $S Nil) + (print-tokens $S)) - (= - (portray-game (game $Name $Board $Pieces $Goals $Constraints)) + (= (portray-game (game $Name $Board $Pieces $Goals $Constraints)) (format "" (:: $Name))) -; - ; -; - +; ================================================================================ ; -; - +; Printing games ; -; - +; ================================================================================ ; -; - +; GEN(L): generates an internal game representation, ; -; - +; and then returns the list which is its grammatical representation ; -; - +; using the grammar above. ; ; - - (= - (gen $L) - ( (generate-game $G) (game $G $L $_))) -; - + (= (gen $L) + (generate-game $G) + (game $G $L $_)) ; -; - +; RANDOM_GAME_TO_FILE(+File) ; -; - +; ------------------- ; -; - +; The predicate used most commonly for generating new games. ; -; - +; Outputs the game to File. ; ; - - (= - (random-game-to-file $File) + (= (random-game-to-file $File) (print-gen-game-to-file $File)) -; - - (= - (print-gen-game) - ( (record-seed) - (gen $G) - (print-tokens $G))) -; - - - - (= - (print-gen-game-to-file $File) - ( (record-seed) - (generate-game $G) - (set-printing-mode) - (game $G $GameList $_) - (print-game-to-file $GameList $File) - (set-parsing-mode))) -; + (= (print-gen-game) + (record-seed) + (gen $G) + (print-tokens $G)) + (= (print-gen-game-to-file $File) + (record-seed) + (generate-game $G) + (set-printing-mode) + (game $G $GameList $_) + (print-game-to-file $GameList $File) + (set-parsing-mode)) - (= - (print-game-struct $G) - ( (set-printing-mode) - (game $G $GameList $_) - (set-parsing-mode) - (print-tokens $GameList))) -; + (= (print-game-struct $G) + (set-printing-mode) + (game $G $GameList $_) + (set-parsing-mode) + (print-tokens $GameList)) - (= - (prettify-game $GameList $Pretty) - ( (set-parsing-mode) - (game $G $GameList $_) - (set-printing-mode) - (game $G $Pretty) - (set-parsing-mode))) -; - + (= (prettify-game $GameList $Pretty) + (set-parsing-mode) + (game $G $GameList $_) + (set-printing-mode) + (game $G $Pretty) + (set-parsing-mode)) - (= - (pretty-print-game-to-file $GameList $File) - ( (prettify-game $GameList $Pretty) (print-game-to-file $Pretty $File))) -; - + (= (pretty-print-game-to-file $GameList $File) + (prettify-game $GameList $Pretty) + (print-game-to-file $Pretty $File)) ; -; - +; PRINT_GAME_TO_FILE(+Game,+File) ; -; - - - (= - (print-game-to-file $Game $File) - ( (sys-suffixed-filename $File game $GameFile) - (format "~nWriting game to file: ~w~n" - (:: $GameFile)) - (tell $GameFile) - (write-old-seed) - (print-tokens $Game) - (told))) -; +; Outputs a game to file File.game. + (= (print-game-to-file $Game $File) + (sys-suffixed-filename $File game $GameFile) + (format "~nWriting game to file: ~w~n" + (:: $GameFile)) + (tell $GameFile) + (write-old-seed) + (print-tokens $Game) + (told)) ; -; - +; If we've just generated a game, print its ; -; - - - (= - (write-old-seed) - ( (old-seed $Seed) - (set-det) - (nl) - (write '% seed: ') - (write $Seed) - (nl))) -; - - (= write_old_seed True) -; +; seed as a comment. + (= (write-old-seed) + (old-seed $Seed) + (set-det) + (nl) + (write '% seed: ') + (write $Seed) + (nl)) + (= write_old_seed True) ; -; - +; ================================================================================ ; -; - +; Reading games from files, printing back. ; -; - +; ================================================================================ ; -; - +; ;; Read from pascal-like game output, into list. ; -; - +; ;; Reading is CASE-INSENSITIVE: all alpha characters ; -; - +; ;; are converted to lower case when read in. ; -; - +; ;; Also ignores extra blanks, tabs, and linefeeds. ; -; - +; ;; Comments occur from some point in a line started by ;, ; -; - +; ;; and will be ignored to end of line. ; -; - +; ;; Can read games without spaces between operators and atoms, ; -; - +; ;; so squares can be written (X,Y) instead of ( X , Y ). ; -; - +; ;; ; -; - +; read_game_from_file_to_list('~/MeTTa/play/game.2.5.92',Game). ; -; - - - - (= - (print-read-game $File) - ( (format "~nReading game from file~n" Nil) - (read-game-from-file-to-list $File $Game) - (format "~nRead game from file~n" Nil) - (set-parsing-mode) - (format "~nParsing game in parse mode~n" Nil) - (game $G $Game Nil) - (set-printing-mode) - (format "~nParsing game in print mode~n" Nil) - (game $G $Game1 Nil) - (format "~nPrinting game~n" Nil) - (print-tokens $Game1))) -; +; print_read_game('~/MeTTa/play/game.2.5.92'). + (= (print-read-game $File) + (format "~nReading game from file~n" Nil) + (read-game-from-file-to-list $File $Game) + (format "~nRead game from file~n" Nil) + (set-parsing-mode) + (format "~nParsing game in parse mode~n" Nil) + (game $G $Game Nil) + (set-printing-mode) + (format "~nParsing game in print mode~n" Nil) + (game $G $Game1 Nil) + (format "~nPrinting game~n" Nil) + (print-tokens $Game1)) - (= - (read-game-from-file-to-list $File $Game) - ( (format "~nReading game from file: ~w~n" - (:: $File)) (read-tokens-from-file $File $Game))) -; + (= (read-game-from-file-to-list $File $Game) + (format "~nReading game from file: ~w~n" + (:: $File)) + (read-tokens-from-file $File $Game)) - (= - (read-game-from-string-to-list $String $Game) - ( (format "~nReading game from string. ~n" Nil) (read-tokens-from-string $String $Game))) -; + (= (read-game-from-string-to-list $String $Game) + (format "~nReading game from string. ~n" Nil) + (read-tokens-from-string $String $Game)) - - (= - (read-game-to-list $Game) + (= (read-game-to-list $Game) (read-tokens $Game)) -; - diff --git a/metagame/generator/piece_names.metta b/metagame/generator/piece_names.metta index 789a3fa..392342a 100644 --- a/metagame/generator/piece_names.metta +++ b/metagame/generator/piece_names.metta @@ -1,164 +1,51 @@ +; (convert_to_metta_file piece_names $_351584 metagame/generator/piece_names.pl metagame/generator/piece_names.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; piece_names.pl ; ; - ; -; - +; This file defines a mapping from an index, to a set of possible pieces for that index. ; -; - +; They are organized s.t. no different indices contain piece names which start with the same letter. ; -; - +; Disclaimer: These names were the product of a random mind at 4:30 am, and shall not ; -; +; be used as evidence for compiling psychological profiles of the author! - - (= - (indexed_names 1 - (ant apple artist archer albino aardvark asimov acorn andover avenger)) True) -; - - (= - (indexed_names 2 - (bear badger burgler boy bandit blaster bouncer blanket berkeley bishop barney bush budda)) True) -; - - (= - (indexed_names 3 - (cat coyote camel condor cambridge casket climber changer cleric clinton christ cheeseman)) True) -; - - (= - (indexed_names 4 - (dog dragger digger dumbo duke duchess drainer destroyer death)) True) -; - - (= - (indexed_names 5 - (friend fanatic flier fungus fool frenchman ferdi firefly fairy)) True) -; - - (= - (indexed_names 6 - (handler heaven hooter hoover honey hitchcock hoyle)) True) -; - - (= - (indexed_names 7 - (jerk jupiter jello jammer jester jouster)) True) -; - - (= - (indexed_names 8 - (lance lover loner lord laster liver llama)) True) -; - - (= - (indexed_names 9 - (man mango master monster mortal machine machete maimer mercury mohammed minsky morph)) True) -; - - (= - (indexed_names 10 - (popper pealer pot potato perot plato)) True) -; - - (= - (indexed_names 11 - (queen quester quelcher quagmire quayle)) True) -; - - (= - (indexed_names 12 - (rat robber raccoon rabbi roach railroad raster rama)) True) -; - - (= - (indexed_names 13 - (sleeper slug siren soarer screen slipper sapling squid shiva schank simon)) True) -; - - (= - (indexed_names 14 - (termite twister tusker torch totem taboo tamer thatcher)) True) -; - - (= - (indexed_names 15 - (umbrella user uranus)) True) -; - - (= - (indexed_names 16 - (violet venus volcano victor vishnu)) True) -; - - (= - (indexed_names 17 - (wheelie william welcomer warden wilkins)) True) -; - - (= - (indexed_names 18 - (xenon xylem xerox)) True) -; - - (= - (indexed_names 19 - (youth yellow yard)) True) -; - - (= - (indexed_names 20 - (zebra zero zaire zoo zeus)) True) -; - - (= - (indexed_names 21 - (elephant emu eskimo earth epstein elvis)) True) -; - - (= - (indexed_names 22 - (guru girl giraffe gasper ghandi)) True) -; - - (= - (indexed_names 23 - (igloo iceman icarus)) True) -; - - (= - (indexed_names 24 - (king kangaroo killer krishna korf kant)) True) -; - - (= - (indexed_names 25 - (necromancer nasty night nicko)) True) -; - - (= - (indexed_names 26 - (ostrich oak oven oscar opener)) True) -; - + (= (indexed_names 1 (ant apple artist archer albino aardvark asimov acorn andover avenger)) True) + (= (indexed_names 2 (bear badger burgler boy bandit blaster bouncer blanket berkeley bishop barney bush budda)) True) + (= (indexed_names 3 (cat coyote camel condor cambridge casket climber changer cleric clinton christ cheeseman)) True) + (= (indexed_names 4 (dog dragger digger dumbo duke duchess drainer destroyer death)) True) + (= (indexed_names 5 (friend fanatic flier fungus fool frenchman ferdi firefly fairy)) True) + (= (indexed_names 6 (handler heaven hooter hoover honey hitchcock hoyle)) True) + (= (indexed_names 7 (jerk jupiter jello jammer jester jouster)) True) + (= (indexed_names 8 (lance lover loner lord laster liver llama)) True) + (= (indexed_names 9 (man mango master monster mortal machine machete maimer mercury mohammed minsky morph)) True) + (= (indexed_names 10 (popper pealer pot potato perot plato)) True) + (= (indexed_names 11 (queen quester quelcher quagmire quayle)) True) + (= (indexed_names 12 (rat robber raccoon rabbi roach railroad raster rama)) True) + (= (indexed_names 13 (sleeper slug siren soarer screen slipper sapling squid shiva schank simon)) True) + (= (indexed_names 14 (termite twister tusker torch totem taboo tamer thatcher)) True) + (= (indexed_names 15 (umbrella user uranus)) True) + (= (indexed_names 16 (violet venus volcano victor vishnu)) True) + (= (indexed_names 17 (wheelie william welcomer warden wilkins)) True) + (= (indexed_names 18 (xenon xylem xerox)) True) + (= (indexed_names 19 (youth yellow yard)) True) + (= (indexed_names 20 (zebra zero zaire zoo zeus)) True) + (= (indexed_names 21 (elephant emu eskimo earth epstein elvis)) True) + (= (indexed_names 22 (guru girl giraffe gasper ghandi)) True) + (= (indexed_names 23 (igloo iceman icarus)) True) + (= (indexed_names 24 (king kangaroo killer krishna korf kant)) True) + (= (indexed_names 25 (necromancer nasty night nicko)) True) + (= (indexed_names 26 (ostrich oak oven oscar opener)) True) diff --git a/metagame/generator/tokenizer.metta b/metagame/generator/tokenizer.metta index 5adc056..7be58ed 100644 --- a/metagame/generator/tokenizer.metta +++ b/metagame/generator/tokenizer.metta @@ -1,1165 +1,592 @@ +; (convert_to_metta_file tokenizer $_437342 metagame/generator/tokenizer.pl metagame/generator/tokenizer.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; tokenizer.pl ; -; - +; ;; ; -; - +; ;; Read from pascal-like syntax, into list. ; -; - +; ;; Reading is CASE-INSENSITIVE: all alpha characters ; -; - +; ;; are converted to lower case when read in. ; -; - +; ;; Also ignores extra blanks, tabs, and linefeeds. ; -; - +; ;; Comments occur from some point in a line started by ;, ; -; - +; ;; and will be ignored to end of line. ; -; - +; ;; Ignores spaces between operators and atoms, ; -; - +; ;; so squares can be written (X,Y) instead of ( X , Y ). ; -; - - - (= - (read-tokens-from-file $File $Tokens) - ( (see $File) - (read-tokens $Tokens) - (set-det) - (seen))) -; - - (= - (read-tokens-from-file $File $Tokens) - ( (format "~nError: Couldn't read tokens from file ~w~n" - (:: $File)) - (seen) - (fail))) -; +; READ_TOKENS_FROM_FILE(+File,-Tokens) + (= (read-tokens-from-file $File $Tokens) + (see $File) + (read-tokens $Tokens) + (set-det) + (seen)) + (= (read-tokens-from-file $File $Tokens) + (format "~nError: Couldn't read tokens from file ~w~n" + (:: $File)) + (seen) + (fail)) ; -; - +; READ_TOKENS(-Tokens). ; -; - +; First reads input literally (as number codes of characters), ; -; - +; then converts to tokens. ; -; - - - (= - (read-tokens $Tokens) - ( (read-chars $Chars) (tokenize-chars $Chars $Tokens))) -; +; After this, the tokens can be parsed into a higher-level structure. + (= (read-tokens $Tokens) + (read-chars $Chars) + (tokenize-chars $Chars $Tokens)) ; -; - +; READ_KEYBOARD_TOKENS(-Tokens). ; -; - +; First reads input literally (as number codes of characters), ; -; - +; then converts to tokens. ; -; - - - (= - (read-keyboard-tokens $Tokens) - ( (read-chars-period-include $Chars) (tokenize-chars $Chars $Tokens))) -; +; After this, the tokens can be parsed into a higher-level structure. + (= (read-keyboard-tokens $Tokens) + (read-chars-period-include $Chars) + (tokenize-chars $Chars $Tokens)) ; -; - +; READ_CHARS(-Chars) ; -; - +; Reads in a list of numerical character codes, until encountering ; -; +; the end_of_file (returns code -1). - - (= - (read-chars $Chars) + (= (read-chars $Chars) (read-chars -1 n $Chars)) -; - ; -; - +; READ_LINE(-Chars) ; -; - +; Reads in a list of numerical character codes, until encountering ; -; +; a new line (char code 10). - - (= - (read-line $Chars) + (= (read-line $Chars) (read-chars 10 n $Chars)) -; - ; -; - +; READ_CHARS_PERIOD_INCLUDE(-Chars) ; -; - +; Reads in a list of numerical character codes, until encountering ; -; - +; a period, which will be the last char. - (= - (read-chars-period-include $Chars) + (= (read-chars-period-include $Chars) (read-chars 46 y $Chars)) -; - ; -; - +; READ_CHARS_PERIOD(-Chars) ; -; - +; Reads in a list of numerical character codes, until encountering ; -; - +; a period, which will be omitted from the string. - (= - (read-chars-period $Chars) + (= (read-chars-period $Chars) (read-chars 46 n $Chars)) -; - ; -; - +; READ_CHARS(+EndChar,+Include,-Chars) ; -; - +; Reads in a list of numerical character codes, until encountering ; -; - +; either: ; -; - +; a. end_of_file [-1], or ; -; - +; b. EndChar, unless in a quotation ('...') context. ; -; - +; c. EndChar, unless in a comment (; ...) context. ; -; - +; EndChar will be included in Chars if Include=y. ; ; - - (= - (read-chars $End $Include $Chars) + (= (read-chars $End $Include $Chars) (read-chars $End n n $Include $Chars)) -; - - (= - (read-chars $End $Quote $Comment $Include $Chars) - ( (read-char $C) (read-chars $C $End $Quote $Comment $Include $Chars))) -; + (= (read-chars $End $Quote $Comment $Include $Chars) + (read-char $C) + (read-chars $C $End $Quote $Comment $Include $Chars)) - - (= - (read-chars $End $End n n y - (:: $End)) + (= (read-chars $End $End n n y (:: $End)) (set-det)) -; - - (= - (read-chars $End $End n n n Nil) + (= (read-chars $End $End n n n Nil) (set-det)) -; - - (= - (read-chars -1 $_ $_ $_ $_ Nil) + (= (read-chars -1 $_ $_ $_ $_ Nil) (set-det)) -; - - (= - (read-chars $C $End $Quote1 $Comment1 $Include - (Cons $C $Cs)) - ( (toggle-contexts $C $Quote1 $Comment1 $Quote $Comment) (read-chars $End $Quote $Comment $Include $Cs))) -; - + (= (read-chars $C $End $Quote1 $Comment1 $Include (Cons $C $Cs)) + (toggle-contexts $C $Quote1 $Comment1 $Quote $Comment) + (read-chars $End $Quote $Comment $Include $Cs)) - (= - (toggle-contexts $C $Quote1 $Comment1 $Quote $Comment) - ( (toggle-quote $C $Quote1 $Quote) (toggle-comment $C $Comment1 $Comment))) -; - + (= (toggle-contexts $C $Quote1 $Comment1 $Quote $Comment) + (toggle-quote $C $Quote1 $Quote) + (toggle-comment $C $Comment1 $Comment)) ; -; - +; toggle_quote(Char,OldQuote,NewQuote) ; -; - - - (= - (toggle_quote 39 n y) True) -; - - (= - (toggle_quote 39 y n) True) -; - - (= - (toggle_quote $_ $Q $Q) True) -; +; Quote char is: 0'' (ie.: "'"). + (= (toggle_quote 39 n y) True) + (= (toggle_quote 39 y n) True) + (= (toggle_quote $_ $Q $Q) True) ; -; - +; toggle_comment(Char,OldComment,NewComment) ; -; - +; Start Comment char is: 0'; (ie.: ";"). ; -; - - - (= - (toggle_comment 37 n y) True) -; - - (= - (toggle_comment 10 y n) True) -; - - (= - (toggle_comment $_ $C $C) True) -; +; End Comment char is newline. + (= (toggle_comment 37 n y) True) + (= (toggle_comment 10 y n) True) + (= (toggle_comment $_ $C $C) True) ; -; - +; read_char(Char) :- get0(N), name(Char,[N]). - (= - (read-char $Char) + (= (read-char $Char) (get0 $Char)) -; - ; -; - +; READ_TOKENS_FROM_STRING(+String,-Tokens). ; -; - +; Reads input from String (list of number codes of characters), ; -; - +; then converts to tokens. ; -; - +; After this, the tokens can be parsed into a higher-level structure. ; -; +; This is just an alias for the procedure below. - - (= - (read-tokens-from-string $String $Tokens) + (= (read-tokens-from-string $String $Tokens) (tokenize-chars $String $Tokens)) -; - ; -; - +; TOKENIZE_CHARS(+Chars,-Tokens) ; -; - +; Given a string of characters (like "barney." or ; -; - +; equivalently [0'b,0'a,0'r,0'n,0'e,0'y,0'.] ; -; - +; or the corresponding numbers [98,97,114,110,101,121,46] ; -; - +; Tokens is a list of atomic tokens read from this ; -; - +; string. ; -; - +; For the simple requirements of game and move grammars, this also ; -; - +; gives us the ability to read directly from strings. ; -; - +; Note that the tokens in the string ends when we read the 0'. ; -; +; character. If a string doesn't have this, we fail. - - (= - (tokenize-chars $Chars $Tokens) + (= (tokenize-chars $Chars $Tokens) (tokens $Tokens Nil $Chars $_)) -; - ; -; - +; tokenize_chars(Chars,Tokens) :- ; -; - - - - (= - (--> - (tokens - (.) ()) - (46)) True) -; - - (= - (--> - (tokens $In $Out) - (, - (token $In $S) - (tokens $S $Out))) True) -; - +; tokens(Tokens,[],Chars,[]). - (= - (--> - (token - (Cons $C $Rest) $Rest) - (, - (identifier $C) !)) True) -; - - (= - (--> - (token $Rest $Rest) - (, - (layout_string $C) !)) True) -; - - (= - (--> - (token $Rest $Rest) - (, - (comment $C) !)) True) -; - - (= - (--> - (token - (Cons $C $Rest) $Rest) - (operator $C)) True) -; + (= (--> (tokens (.) ()) (46)) True) + (= (--> (tokens $In $Out) (, (token $In $S) (tokens $S $Out))) True) - (= - (--> - (token - (Cons $C $Rest) $Rest) - (quote_symbol $C)) True) -; + (= (--> (token (Cons $C $Rest) $Rest) (, (identifier $C) !)) True) + (= (--> (token $Rest $Rest) (, (layout_string $C) !)) True) + (= (--> (token $Rest $Rest) (, (comment $C) !)) True) + (= (--> (token (Cons $C $Rest) $Rest) (operator $C)) True) + (= (--> (token (Cons $C $Rest) $Rest) (quote_symbol $C)) True) ; -; - +; ---------------------------------------- ; -; - +; Quoted atom ; -; +; ---------------------------------------- + (= (--> (quote_symbol $C) (, (quote_char $_) (, (non_quote_chars $Cs) (, (quote_char $_) {(string_chars $Cs $C) })))) True) - (= - (--> - (quote_symbol $C) - (, - (quote_char $_) - (, - (non_quote_chars $Cs) - (, - (quote_char $_) - { (string_chars $Cs $C) })))) True) -; + (= (--> (non_quote_chars ()) ()) True) + (= (--> (non_quote_chars (Cons $C $Cs)) (, (non_quote_char $C) (more_non_quote_chars $Cs))) True) + (= (--> (more_non_quote_chars $Cs) (non_quote_chars $Cs)) True) + (= (--> (more_non_quote_chars ()) ()) True) - (= - (--> - (non_quote_chars ()) ()) True) -; - - (= - (--> - (non_quote_chars - (Cons $C $Cs)) - (, - (non_quote_char $C) - (more_non_quote_chars $Cs))) True) -; - - - (= - (--> - (more_non_quote_chars $Cs) - (non_quote_chars $Cs)) True) -; - - (= - (--> - (more_non_quote_chars ()) ()) True) -; - - - (= - (--> - (non_quote_char $C) - (, - (quote_char $C) - (, ! - {fail }))) True) -; - - (= - (--> - (non_quote_char $C) - ($C)) True) -; - - - (= - (--> - (quote_char 39) - (39)) True) -; + (= (--> (non_quote_char $C) (, (quote_char $C) (, ! {fail }))) True) + (= (--> (non_quote_char $C) ($C)) True) + (= (--> (quote_char 39) (39)) True) ; -; - +; ---------------------------------------- ; -; - +; Comment ; -; +; ---------------------------------------- + (= (--> (comment $C) (, (37) (, (non_lf_chars $Cs) (, (linefeed $_) {(string_chars $Cs $C) })))) True) - (= - (--> - (comment $C) - (, - (37) - (, - (non_lf_chars $Cs) - (, - (linefeed $_) - { (string_chars $Cs $C) })))) True) -; + (= (--> (non_lf_chars ()) ()) True) + (= (--> (non_lf_chars (Cons $C $Cs)) (, (non_lf_char $C) (more_non_lf_chars $Cs))) True) + (= (--> (more_non_lf_chars $Cs) (non_lf_chars $Cs)) True) + (= (--> (more_non_lf_chars ()) ()) True) - (= - (--> - (non_lf_chars ()) ()) True) -; + (= (--> (non_lf_char $C) (, (linefeed $C) (, ! {fail }))) True) + (= (--> (non_lf_char $C) ($C)) True) - (= - (--> - (non_lf_chars - (Cons $C $Cs)) - (, - (non_lf_char $C) - (more_non_lf_chars $Cs))) True) -; - - - (= - (--> - (more_non_lf_chars $Cs) - (non_lf_chars $Cs)) True) -; - - (= - (--> - (more_non_lf_chars ()) ()) True) -; - - - (= - (--> - (non_lf_char $C) - (, - (linefeed $C) - (, ! - {fail }))) True) -; - - (= - (--> - (non_lf_char $C) - ($C)) True) -; - - - (= - (--> - (linefeed 10) - (10)) True) -; - + (= (--> (linefeed 10) (10)) True) ; -; - +; ---------------------------------------- ; -; - +; Operator ; -; - - - - (= - (--> - (operator $X) - (, - (comparison_operator $X) !)) True) -; - - (= - (--> - (operator $X) - (, - (transfer_operator $X) !)) True) -; - - (= - (--> - (operator $X) - (, - ($Y) - { (terminal_char $Y $X) })) True) -; - - - (= - (--> - (comparison_operator >=) - (, - (62) - (61))) True) -; - - (= - (--> - (comparison_operator <=) - (, - (60) - (61))) True) -; +; ---------------------------------------- - (= - (--> - (transfer_operator ->) - (45 62)) True) -; + (= (--> (operator $X) (, (comparison_operator $X) !)) True) + (= (--> (operator $X) (, (transfer_operator $X) !)) True) + (= (--> (operator $X) (, ($Y) {(terminal_char $Y $X) })) True) + (= (--> (comparison_operator >=) (, (62) (61))) True) + (= (--> (comparison_operator <=) (, (60) (61))) True) + (= (--> (transfer_operator ->) (45 62)) True) - (= - (terminal-char $X $Y) - ( (terminal $X) (name $Y (:: $X)))) -; + (= (terminal-char $X $Y) + (terminal $X) + (name $Y + (:: $X))) ; -; +; terminal(0'.). + (= (terminal 123) True) + (= (terminal 125) True) + (= (terminal 44) True) + (= (terminal 60) True) + (= (terminal 62) True) + (= (terminal 91) True) + (= (terminal 93) True) + (= (terminal 40) True) + (= (terminal 41) True) + (= (terminal 61) True) - (= - (terminal 123) True) -; - - (= - (terminal 125) True) -; - - (= - (terminal 44) True) -; - - (= - (terminal 60) True) -; - - (= - (terminal 62) True) -; - - (= - (terminal 91) True) -; - - (= - (terminal 93) True) -; - - (= - (terminal 40) True) -; - - (= - (terminal 41) True) -; - - (= - (terminal 61) True) -; - - - (= - (terminal 45) True) -; - - (= - (terminal 47) True) -; - - (= - (terminal 59) True) -; - + (= (terminal 45) True) + (= (terminal 47) True) + (= (terminal 59) True) ; -; - +; ---------------------------------------- ; -; - +; Layout String ; -; - - - - (= - (--> - (layout_string - (Cons $X $Xs)) - (, - (layout_char $X) - (more_layout_chars $Xs))) True) -; - - (= - (--> - (more_layout_chars $Xs) - (, - (layout_string $Xs) !)) True) -; +; ---------------------------------------- - (= - (--> - (more_layout_chars ()) ()) True) -; - - - - (= - (--> - (layout_char $X) - (, - ($X) - { (layout_char $X) })) True) -; + (= (--> (layout_string (Cons $X $Xs)) (, (layout_char $X) (more_layout_chars $Xs))) True) + (= (--> (more_layout_chars $Xs) (, (layout_string $Xs) !)) True) + (= (--> (more_layout_chars ()) ()) True) - (= - (layout_char 9) True) -; + (= (--> (layout_char $X) (, ($X) {(layout_char $X) })) True) - (= - (layout_char 10) True) -; - - (= - (layout_char 32) True) -; + (= (layout_char 9) True) + (= (layout_char 10) True) + (= (layout_char 32) True) ; -; - +; ---------------------------------------- ; -; - +; Identifier ; -; - +; ---------------------------------------- - (= - (--> - (identifier $Id) - (, - (alphanumchars $Chars) - { (string_chars $Chars $Id) })) True) -; - + (= (--> (identifier $Id) (, (alphanumchars $Chars) {(string_chars $Chars $Id) })) True) - (= - (string-chars $Chars $Id) + (= (string-chars $Chars $Id) (name $Id $Chars)) -; - - (= - (chars_to_nums () ()) True) -; - - (= - (chars-to-nums - (Cons $H $T) - (Cons $NH $NT)) - ( (name $H - (:: $NH)) (chars-to-nums $T $NT))) -; + (= (chars_to_nums () ()) True) +; /* not used */ + (= (chars-to-nums (Cons $H $T) (Cons $NH $NT)) + (name $H + (:: $NH)) + (chars-to-nums $T $NT)) + (= (--> (alphanumchars (Cons $X $Xs)) (, (alphanumchar $X) (more_alphanumchars $Xs))) True) - (= - (--> - (alphanumchars - (Cons $X $Xs)) - (, - (alphanumchar $X) - (more_alphanumchars $Xs))) True) -; - - - (= - (--> - (more_alphanumchars $X) - (, - (alphanumchars $X) !)) True) -; - - (= - (--> - (more_alphanumchars ()) ()) True) -; - - - (= - (--> - (alphanumchar $Y) - (, - ($X) - { (alphanumchar $X $Y) })) True) -; + (= (--> (more_alphanumchars $X) (, (alphanumchars $X) !)) True) + (= (--> (more_alphanumchars ()) ()) True) + (= (--> (alphanumchar $Y) (, ($X) {(alphanumchar $X $Y) })) True) ; -; - - - (= - (alphanumchar $X $X) - ( (>= $X 97) (=< $X 122))) -; +; converts to lower-case - (= - (alphanumchar $X $X) - ( (>= $X 48) (=< $X 57))) -; + (= (alphanumchar $X $X) + (>= $X 97) + (=< $X 122)) + (= (alphanumchar $X $X) + (>= $X 48) + (=< $X 57)) + (= (alphanumchar $X $Y) + (>= $X 65) + (=< $X 90) + (downcase-char $X $Y)) + (= (alphanumchar 95 95) True) - (= - (alphanumchar $X $Y) - ( (>= $X 65) - (=< $X 90) - (downcase-char $X $Y))) -; - (= - (alphanumchar 95 95) True) -; - - - - (= - (downcase-char $Upper $Lower) + (= (downcase-char $Upper $Lower) (downcase-char-num $Upper $Lower)) -; + (= (downcase-char-num $Upper $Lower) + (uppercase $Upper) + (set-det) + (is $Lower + (- + (+ $Upper "a") "A"))) + (= (downcase_char_num $X $X) True) - (= - (downcase-char-num $Upper $Lower) - ( (uppercase $Upper) - (set-det) - (is $Lower - (- - (+ $Upper "a") "A")))) -; - - (= - (downcase_char_num $X $X) True) -; - - - - (= - (uppercase $N) - ( (>= $N "A") (=< $N "Z"))) -; + (= (uppercase $N) + (>= $N "A") + (=< $N "Z")) ; -; - +; ================================================================================ ; -; - +; Pretty-Printing Token Lists ; -; - +; ================================================================================ ; ; - ; -; - +; When tokens are parsed, they can also be generated back with ; -; - +; special printing information, such as insertion of lines and tabs. ; -; - +; These routines print these out nicely, destroying the list notation. ; -; - +; However, they can always be read back in again, by the tokenizer. ; -; - +; ---------------------------------------- ; -; - +; PARSING_MODE(-Mode) ; -; - +; Mode should be: PARSING in general, ; -; - +; but PRINTING, when using grammars to generate strings which will ; -; - +; then be pretty-printed. - (= - (parsing-mode $M) + (= (parsing-mode $M) (parameter parsing-mode $M)) -; - ; -; - +; SET_PARSING_MODE(Mode) - (= - (set-parsing-mode $Mode) + (= (set-parsing-mode $Mode) (set-parameter parsing-mode $Mode)) -; - - (= - (set-parsing-mode) + (= (set-parsing-mode) (set-parsing-mode parsing)) -; - - (= - (set-printing-mode) + (= (set-printing-mode) (set-parsing-mode printing)) -; - ; -; - +; ---------------------------------------- ; -; - +; ALPHA_SQUARES_MODE(-Mode) ; -; - +; ; Mode values: {on,off} ; -; - +; ; description: whether can use (a,1) notation to denote ; -; - +; ; squares in move and game grammars ; -; - +; ; on: use (a,1) notation ; -; - +; ; off: use (1,1) notation ; -; - +; ; used in: grammar.pl, notation.pl, interface.pl, tokenizer.pl ; -; - +; ; In general, this param is off, except for humans ; -; - +; ; entering moves requiring completion. It could be ; -; - +; ; used to generate pretty initial assignments for games, ; -; - +; ; but CAUTION, it will not parse games or moves in the ; -; - +; ; other mode. - (= - (set-alpha-squares-mode $M) + (= (set-alpha-squares-mode $M) (set-parameter alpha-squares-mode $M)) -; - - (= - (alpha-squares-mode $M) + (= (alpha-squares-mode $M) (parameter alpha-squares-mode $M)) -; - ; -; - +; WITH_ALPHA_SQUARES(+Goal) ; -; - +; Calls Goal with alpha squares mode on, then ; -; - +; resets the mode to what it was before. ; -; - +; Goal must be deterministic for this to work properly. - (= - (with-alpha-squares $Goal) - ( (alpha-squares-mode $Mode) - (set-alpha-squares-mode on) - (with-alpha-squares $Goal $Mode))) -; - + (= (with-alpha-squares $Goal) + (alpha-squares-mode $Mode) + (set-alpha-squares-mode on) + (with-alpha-squares $Goal $Mode)) - (= - (with-alpha-squares $Goal $Mode) - ( (call $Goal) - (set-det) - (set-alpha-squares-mode $Mode))) -; + (= (with-alpha-squares $Goal $Mode) + (call $Goal) + (set-det) + (set-alpha-squares-mode $Mode)) + (= (with-alpha-squares $Goal $Mode) + (set-alpha-squares-mode $Mode) + (fail)) - (= - (with-alpha-squares $Goal $Mode) - ( (set-alpha-squares-mode $Mode) (fail))) -; - - - (= - (recover-grammar) + (= (recover-grammar) (add-parameter alpha-squares-mode off)) -; - ; -; +; ---------------------------------------- + (= (print-token line) + (set-det) + (nl)) + (= (print-token (tab $T)) + (set-det) + (tab $T)) + (= (print-token $X) + (write $X) + (tab 1)) - (= - (print-token line) - ( (set-det) (nl))) -; - (= - (print-token (tab $T)) - ( (set-det) (tab $T))) -; + (= (print_tokens ()) True) + (= (print-tokens (Cons $H $T)) + (print-token $H) + (print-tokens $T)) - (= - (print-token $X) - ( (write $X) (tab 1))) -; - - - - (= - (print_tokens ()) True) -; - - (= - (print-tokens (Cons $H $T)) - ( (print-token $H) (print-tokens $T))) -; - - - - (= - (print-tokens-to-file $Tokens $File) - ( (set-printing-mode) - (tell $File) - (print-tokens $Tokens) - (told))) -; + (= (print-tokens-to-file $Tokens $File) + (set-printing-mode) + (tell $File) + (print-tokens $Tokens) + (told)) - (= - (print-token-to-string line Nil) + (= (print-token-to-string line Nil) (set-det)) -; - - (= - (print-token-to-string - (tab $T) Nil) + (= (print-token-to-string (tab $T) Nil) (set-det)) -; - - (= - (print-token-to-string $X $String) + (= (print-token-to-string $X $String) (name $X $String)) -; - ; -; - +; PRINT_TOKENS_TO_STRING(Tokens,String) ; -; - +; Prints out Tokens (a list of atoms) into a String which. ; -; - +; If String were then printed, the printout would ; -; - +; look just like printing each of the tokens, with ; -; - +; 1 space between each token. ; -; - +; This string is of the right form to be read in later by ; -; - +; READ_TOKENS_FROM_STRING/2 : ; ; - ; -; - +; | ?- print_tokens_to_string([barney,is,happy,'.'],S), read_tokens_from_string(S,T). ; ; - ; -; - +; S = [98,97,114,110,101,121,32,105,115,32,104,97,112,112,121,32,46,32], ; -; - - +; T = [barney,is,happy,'.'] ? - (= - (print_tokens_to_string () ()) True) -; - - (= - (print-tokens-to-string - (Cons $H $T) $String) - ( (print-token-to-string $H $StrH) - (print-tokens-to-string $T $StrT) - (append $StrH - (Cons 32 $StrT) $String))) -; + (= (print_tokens_to_string () ()) True) + (= (print-tokens-to-string (Cons $H $T) $String) + (print-token-to-string $H $StrH) + (print-tokens-to-string $T $StrT) + (append $StrH + (Cons 32 $StrT) $String)) diff --git a/metagame/learning/analysis.metta b/metagame/learning/analysis.metta index 131b512..513e976 100644 --- a/metagame/learning/analysis.metta +++ b/metagame/learning/analysis.metta @@ -1,1182 +1,825 @@ +; (convert_to_metta_file analysis $_168170 metagame/learning/analysis.pl metagame/learning/analysis.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; analysis.pl ; -; - - - (= - (build-transition-matrix) - ( (new-empty-state $State) (build-transition-matrix $Matrix $State))) -; +; ;; Analysing game definitions to extract useful info. + (= (build-transition-matrix) + (new-empty-state $State) + (build-transition-matrix $Matrix $State)) +; /* I really want to make some reachability tables: 1. piece-square: for each square, the set of squares a piece token can eventually reach starting from that square. 2. piece-piece: for each piece (and square?) the set of other piece types which could be promoted into, given we start with a piece on that square. 3. piece-notpiece: for each piece, init square, and target square, the set of piece types which could eventually be captured (or just removed?) from that target square, given a piece type on the init square. */ +; /* :- module(analysis, [ build_distance_table/0, build_transition_table/0, build_mobility_table/0, print_distance_table/0, print_transition_table/0, print_mobility_table/0, square_piece_mobility/3, square_piece_transition/3, square_piece_distance/4, square_index/2, piece_index/2, board_square/2 ]). */ +; ;============================================================================== ; Square-Piece-Square (Immediate Transition) Matrix ;============================================================================== ; This matrix is the only one which refers to the piece movements, ; board state, etc. The others are based only on this. ; Thus it should be performed before the others. ; - (= - (build-transition-matrix $Matrix $State) + (= (build-transition-matrix $Matrix $State) (map-piece-table transition-matrix (:: $State) $Matrix)) -; - - (= - (print-transition-matrix) + (= (print-transition-matrix) (print-transition-matrix $Sq $Piece $SqT)) -; - - - (= - (print-transition-matrix $Sq $Piece $SqT) - ( (format "Piece Square Transition Matrix:~n" Nil) (or (, (square-piece-transition $Sq $Piece $SqT) (format "~p: ~p -> ~p~n" (:: $Piece $Sq $SqT)) (fail)) True))) -; + (= (print-transition-matrix $Sq $Piece $SqT) + (format "Piece Square Transition Matrix:~n" Nil) + (or + (, + (square-piece-transition $Sq $Piece $SqT) + (format "~p: ~p -> ~p~n" + (:: $Piece $Sq $SqT)) + (fail)) True)) +; ; format("matrix[~p][~p] = ~p~n",[Sq,Piece,SqT]), - (= - (spt $S $P $V) + (= (spt $S $P $V) (square-piece-transition $S $P $V)) -; - ; -; - +; SQUARE_PIECE_TRANSITION(?Sq,?Piece,?SqT) ; -; - +; Very nice table indicating when a piece could ; -; - - - (= - (square-piece-transition $Sq $Piece $SqT) - ( (advice-tables $Tables) (square-piece-transition $Sq $Piece $SqT $Tables))) -; +; move directly from one square to another on an empty board. + (= (square-piece-transition $Sq $Piece $SqT) + (advice-tables $Tables) + (square-piece-transition $Sq $Piece $SqT $Tables)) ; -; - +; SQUARE_PIECE_TRANSITION(?Sq,?Piece,?SqT,+Tables) ; -; - +; Very nice table indicating when a piece could ; -; - - (= - (square-piece-transition $Sq $Piece $SqT $Tables) +; move directly from one square to another on an empty board. + (= (square-piece-transition $Sq $Piece $SqT $Tables) (square-piece-transition $Sq $SqI $Piece $PieceI $SqT $SqTI $Tables)) -; - - - (= - (square-piece-transition $Sq $SqI $Piece $PieceI $SqT $SqTI $Tables) - ( (piece-index $Piece $PieceI) - (square-index $Sq $SqI) - (square-piece-sq $SqI $PieceI $SqTI $Tables) - (square-index $SqT $SqTI))) -; + (= (square-piece-transition $Sq $SqI $Piece $PieceI $SqT $SqTI $Tables) + (piece-index $Piece $PieceI) + (square-index $Sq $SqI) + (square-piece-sq $SqI $PieceI $SqTI $Tables) + (square-index $SqT $SqTI)) - (= - (square-piece-sq $SqI $PieceI $SqTI $Tables) - ( (transition-matrix $Tables $M) (square-piece-sq1 $SqI $PieceI $SqTI $M))) -; + (= (square-piece-sq $SqI $PieceI $SqTI $Tables) + (transition-matrix $Tables $M) + (square-piece-sq1 $SqI $PieceI $SqTI $M)) + (= (square-piece-sq1 $SqI $PieceI $SqTI $M) + (piece-table-entry $_ $PieceI $M $Entry) + (member1-pair + (- $SqI $Ts) $Entry) + (member $SqTI $Ts)) - (= - (square-piece-sq1 $SqI $PieceI $SqTI $M) - ( (piece-table-entry $_ $PieceI $M $Entry) - (member1-pair - (- $SqI $Ts) $Entry) - (member $SqTI $Ts))) -; + (= (square-piece-sqs $SqI $PieceI $TIs) + (transition-matrix $M) + (square-piece-sqs $SqI $PieceI $TIs $M)) - - (= - (square-piece-sqs $SqI $PieceI $TIs) - ( (transition-matrix $M) (square-piece-sqs $SqI $PieceI $TIs $M))) -; - - - (= - (square-piece-sqs $SqI $PieceI $TIs $M) - ( (piece-table-entry $_ $PieceI $M $Entry) (member1-pair (- $SqI $TIs) $Entry))) -; - + (= (square-piece-sqs $SqI $PieceI $TIs $M) + (piece-table-entry $_ $PieceI $M $Entry) + (member1-pair + (- $SqI $TIs) $Entry)) ; -; - +; Reversed order of args to use map table. ; -; - - - (= - (transition-matrix $Piece $PieceIndex $State $Matrix) - ( (piece-index $Piece $PieceIndex) - (setof - (- $SqIndex $SqTIndices) - (^ $Sq - (safe-transitions-type $Piece $PieceIndex $Sq $SqIndex moving $SqTIndices $State)) $Matrix) - (tracing-anal-format tables "Built transition matrix for <~p>~n" - (:: $Piece)))) -; +; transition_matrix(Piece,PieceIndex,Matrix,State) :- + (= (transition-matrix $Piece $PieceIndex $State $Matrix) + (piece-index $Piece $PieceIndex) + (setof + (- $SqIndex $SqTIndices) + (^ $Sq + (safe-transitions-type $Piece $PieceIndex $Sq $SqIndex moving $SqTIndices $State)) $Matrix) + (tracing-anal-format tables "Built transition matrix for <~p>~n" + (:: $Piece))) +; ; new_empty_state(State), ; for testing ; -; - +; The safe transition code is in exclude.pl ; -; - +; ============================================================================== ; -; - +; Piece Square Mobility Table ; -; - +; ============================================================================== ; -; - +; Requires transition table now. ; -; +; Could probably put here a line to build it, but maybe wasteful! - - (= - (build-mobility-matrix $Matrix) - ( (transition-matrix $Trans) (build-mobility-matrix $Trans $Matrix))) -; - + (= (build-mobility-matrix $Matrix) + (transition-matrix $Trans) + (build-mobility-matrix $Trans $Matrix)) ; -; - - (= - (build-mobility-matrix $Trans $Matrix) +; Uses saved transition-matrix. + (= (build-mobility-matrix $Trans $Matrix) (map-piece-table mobility-matrix (:: $Trans) $Matrix)) -; - - (= - (mobility-matrix $Piece $PieceIndex $Matrix) - ( (transition-matrix $Trans) (mobility-matrix $Piece $PieceIndex $Trans $Matrix))) -; - + (= (mobility-matrix $Piece $PieceIndex $Matrix) + (transition-matrix $Trans) + (mobility-matrix $Piece $PieceIndex $Trans $Matrix)) - (= - (mobility-matrix $Piece $PieceIndex $Trans $Matrix) - ( (piece-index $Piece $PieceIndex) - (map-square-table square-p-mob - (:: $Piece $PieceIndex $Trans) $Matrix) - (tracing-anal-format tables "Built mobility table for <~p>~n" - (:: $Piece)))) -; + (= (mobility-matrix $Piece $PieceIndex $Trans $Matrix) + (piece-index $Piece $PieceIndex) + (map-square-table square-p-mob + (:: $Piece $PieceIndex $Trans) $Matrix) + (tracing-anal-format tables "Built mobility table for <~p>~n" + (:: $Piece))) - - (= - (square-p-mob $Sq $SqIndex $Piece $PieceIndex $Trans $Value) + (= (square-p-mob $Sq $SqIndex $Piece $PieceIndex $Trans $Value) (piece-square-mob $Piece $PieceIndex $Sq $SqIndex $Trans $Value)) -; + (= (square-piece-mob $SqI $PieceI $Val) + (advice-tables $Tables) + (square-piece-mob $SqI $PieceI $Val $Tables)) - (= - (square-piece-mob $SqI $PieceI $Val) - ( (advice-tables $Tables) (square-piece-mob $SqI $PieceI $Val $Tables))) -; + (= (square-piece-mob $SqI $PieceI $Val $Tables) + (mobility-matrix $Tables $M) + (pindex-table-entry $PieceI $M $Entry) + (sindex-table-entry $SqI $Entry $Val)) - (= - (square-piece-mob $SqI $PieceI $Val $Tables) - ( (mobility-matrix $Tables $M) - (pindex-table-entry $PieceI $M $Entry) - (sindex-table-entry $SqI $Entry $Val))) -; - - - - (= - (spm $S $P $V) + (= (spm $S $P $V) (square-piece-mobility $S $P $V)) -; - ; -; - +; SQUARE_PIECE_MOBILITY(?Sq,?Piece,?Value) ; -; - +; Very nice table indicating the mobility a piece would ; -; - - - (= - (square-piece-mobility $Sq $Piece $Value) - ( (advice-tables $Tables) (square-piece-mobility $Sq $Piece $Value $Tables))) -; +; have from a square on an empty board. + (= (square-piece-mobility $Sq $Piece $Value) + (advice-tables $Tables) + (square-piece-mobility $Sq $Piece $Value $Tables)) ; -; - +; SQUARE_PIECE_MOBILITY(?Sq,?Piece,?Value,+Tables) ; -; - +; Very nice table indicating the mobility a piece would ; -; - - (= - (square-piece-mobility $Sq $Piece $Value $Tables) - ( (piece-index $Piece $PieceI) - (square-index $Sq $SqI) - (square-piece-mob $SqI $PieceI $Value $Tables))) -; - +; have from a square on an empty board. + (= (square-piece-mobility $Sq $Piece $Value $Tables) + (piece-index $Piece $PieceI) + (square-index $Sq $SqI) + (square-piece-mob $SqI $PieceI $Value $Tables)) - (= - (piece-square-mob $Piece $Sq $Value) - ( (transition-matrix $TransMatrix) (piece-square-mob $Piece $Sq $TransMatrix $Value))) -; - + (= (piece-square-mob $Piece $Sq $Value) + (transition-matrix $TransMatrix) + (piece-square-mob $Piece $Sq $TransMatrix $Value)) - (= - (piece-square-mob $Piece $Sq $TransMatrix $Value) + (= (piece-square-mob $Piece $Sq $TransMatrix $Value) (piece-square-mob $Piece $PieceIndex $Sq $SquareIndex $TransMatrix $Value)) -; - - (= - (piece-square-mob $Piece $PieceIndex $Sq $SquareIndex $TransMatrix $Value) - ( (piece-index $Piece $PieceIndex) - (trace-timing - (anal mob-count) - (mob-count $PieceIndex $SquareIndex $TransMatrix $Value)) - (tracing-anal-format detailed "~p: ~p -> ~p~n" - (:: $Piece $Sq $Value)))) -; - - + (= (piece-square-mob $Piece $PieceIndex $Sq $SquareIndex $TransMatrix $Value) + (piece-index $Piece $PieceIndex) + (trace-timing + (anal mob-count) + (mob-count $PieceIndex $SquareIndex $TransMatrix $Value)) + (tracing-anal-format detailed "~p: ~p -> ~p~n" + (:: $Piece $Sq $Value))) +; ; new_empty_state(State), ; for testing +; ; square_index(Sq,SquareIndex), - (= - (mob-count $Piece $Sq $Trans $Value) - ( (square-piece-sqs $Sq $Piece $Moves $Trans) (length $Moves $Value))) -; + (= (mob-count $Piece $Sq $Trans $Value) + (square-piece-sqs $Sq $Piece $Moves $Trans) + (length $Moves $Value)) ; -; - +; Printing mobility matrix ; ; - - (= - (print-mobility-matrix) + (= (print-mobility-matrix) (print-mobility-matrix $_ $_)) -; - - - (= - (print-mobility-matrix $Sq $Piece) - ( (format "Square Piece Mobility Matrix:~n" Nil) (or (, (square-piece-mobility $Sq $Piece $Value) (format "matrix[~p][~p] = ~p~n" (:: $Sq $Piece $Value)) (fail)) True))) -; + (= (print-mobility-matrix $Sq $Piece) + (format "Square Piece Mobility Matrix:~n" Nil) + (or + (, + (square-piece-mobility $Sq $Piece $Value) + (format "matrix[~p][~p] = ~p~n" + (:: $Sq $Piece $Value)) + (fail)) True)) ; -; - +; ============================================================================== ; -; - +; Eventual Mobility Table ; -; - +; ============================================================================== ; -; - +; Requires transition table now. ; -; - +; Could probably put here a line to build it, but maybe wasteful! - (= - (build-eventual-matrix $Matrix) - ( (distance-matrix $Dist) (build-eventual-matrix $Dist $Matrix))) -; - + (= (build-eventual-matrix $Matrix) + (distance-matrix $Dist) + (build-eventual-matrix $Dist $Matrix)) ; -; - - (= - (build-eventual-matrix $Dist $Matrix) +; Uses saved transition-matrix. + (= (build-eventual-matrix $Dist $Matrix) (map-piece-table eventual-matrix (:: $Dist) $Matrix)) -; - - (= - (eventual-matrix $Piece $PieceIndex $Matrix) - ( (distance-matrix $Dist) (eventual-matrix $Piece $PieceIndex $Dist $Matrix))) -; - + (= (eventual-matrix $Piece $PieceIndex $Matrix) + (distance-matrix $Dist) + (eventual-matrix $Piece $PieceIndex $Dist $Matrix)) ; -; - - (= - (eventual-matrix $Piece $PieceIndex $DistMatrix $Matrix) - ( (= $Distance 4) - (piece-indist-matrix $Piece $PieceIndex $Distance $DistMatrix $Matrix) - (tracing-anal-format tables "Built eventual table for <~p>~n" - (:: $Piece)))) -; - +; Uses a fixed max DISTANCE. + (= (eventual-matrix $Piece $PieceIndex $DistMatrix $Matrix) + (= $Distance 4) + (piece-indist-matrix $Piece $PieceIndex $Distance $DistMatrix $Matrix) + (tracing-anal-format tables "Built eventual table for <~p>~n" + (:: $Piece))) ; -; - +; SQUARE_PIECE_REACHABILITY(?Sq,?Piece,?Value) ; -; - +; Very nice table indicating the reachability a piece would ; -; - - - (= - (square-piece-reachability $Sq $Piece $Value) - ( (advice-tables $Tables) (square-piece-reachability $Sq $Piece $Value $Tables))) -; +; have from a square on an empty board. + (= (square-piece-reachability $Sq $Piece $Value) + (advice-tables $Tables) + (square-piece-reachability $Sq $Piece $Value $Tables)) ; -; - +; SQUARE_PIECE_REACHABILITY(?Sq,?Piece,?Value,+Tables) ; -; - +; Very nice table indicating the reachability a piece would ; -; - - (= - (square-piece-reachability $Sq $Piece $Value $Tables) - ( (piece-index $Piece $PieceI) - (square-index $Sq $SqI) - (square-piece-reach $SqI $PieceI $Value $Tables))) -; - +; have from a square on an empty board. + (= (square-piece-reachability $Sq $Piece $Value $Tables) + (piece-index $Piece $PieceI) + (square-index $Sq $SqI) + (square-piece-reach $SqI $PieceI $Value $Tables)) - (= - (square-piece-reach $SqI $PieceI $Val $Tables) - ( (eventual-matrix $Tables $M) - (pindex-table-entry $PieceI $M $Entry) - (sindex-table-entry $SqI $Entry $Val))) -; - + (= (square-piece-reach $SqI $PieceI $Val $Tables) + (eventual-matrix $Tables $M) + (pindex-table-entry $PieceI $M $Entry) + (sindex-table-entry $SqI $Entry $Val)) ; -; - +; Printing eventual matrix ; ; - - (= - (print-eventual-matrix) + (= (print-eventual-matrix) (print-eventual-matrix $_ $_)) -; - - - (= - (print-eventual-matrix $Sq $Piece) - ( (format "Square Piece Eventual Matrix:~n" Nil) (or (, (square-piece-reachability $Sq $Piece $Value) (format "matrix[~p][~p] = ~p~n" (:: $Sq $Piece $Value)) (fail)) True))) -; + (= (print-eventual-matrix $Sq $Piece) + (format "Square Piece Eventual Matrix:~n" Nil) + (or + (, + (square-piece-reachability $Sq $Piece $Value) + (format "matrix[~p][~p] = ~p~n" + (:: $Sq $Piece $Value)) + (fail)) True)) ; -; - +; ============================================================================== ; -; - +; Square-Piece-Square Distance Table ; -; - +; ============================================================================== ; -; - +; Requires transition-matrix (at the moment). - (= - (build-distance-matrix $Trans $Matrix) + (= (build-distance-matrix $Trans $Matrix) (map-piece-table distance-matrix (:: $Trans) $Matrix)) -; - - (= - (build-distance-table) - ( (distance-matrix $M) (build-distance-table $M $_))) -; - + (= (build-distance-table) + (distance-matrix $M) + (build-distance-table $M $_)) ; -; - - (= - (build-distance-table $Trans $Matrix) +; Requires distance-matrix + (= (build-distance-table $Trans $Matrix) (map-piece-table distance-table (:: $Trans) $Matrix)) -; + (= (distance-matrix $Piece $PieceIndex $Matrix) + (transition-matrix $Trans) + (distance-matrix $Piece $PieceIndex $Trans $Matrix)) - (= - (distance-matrix $Piece $PieceIndex $Matrix) - ( (transition-matrix $Trans) (distance-matrix $Piece $PieceIndex $Trans $Matrix))) -; + (= (distance-matrix $Piece $PieceIndex $Trans $Matrix) + (piece-table-entry $Piece $PieceIndex $Trans $Matrix1) + (s-floyd $Matrix1 $Matrix) + (tracing-anal-format tables "Built distance matrix for <~p>~n" + (:: $Piece))) - (= - (distance-matrix $Piece $PieceIndex $Trans $Matrix) - ( (piece-table-entry $Piece $PieceIndex $Trans $Matrix1) - (s-floyd $Matrix1 $Matrix) - (tracing-anal-format tables "Built distance matrix for <~p>~n" - (:: $Piece)))) -; + (= (distance-table $Piece $PieceIndex $Table) + (distance-matrix $Matrix) + (distance-table $Piece $PieceIndex $Matrix $Table)) - - - (= - (distance-table $Piece $PieceIndex $Table) - ( (distance-matrix $Matrix) (distance-table $Piece $PieceIndex $Matrix $Table))) -; - - - (= - (distance-table $Piece $PieceIndex $Dist $Table) - ( (piece-table-entry $Piece $PieceIndex $Dist $Matrix) - (matrix-to-square-table $Matrix $Table) - (tracing-anal-format tables "Built distance table for <~p>~n" - (:: $Piece)))) -; - + (= (distance-table $Piece $PieceIndex $Dist $Table) + (piece-table-entry $Piece $PieceIndex $Dist $Matrix) + (matrix-to-square-table $Matrix $Table) + (tracing-anal-format tables "Built distance table for <~p>~n" + (:: $Piece))) - (= - (square-piece-sq-dist $SqI $PieceI $SqTI $Dist $Tables) - ( (distance-table $Tables $Table) (square-piece-sq-dist1 $SqI $PieceI $SqTI $Table $Dist))) -; - + (= (square-piece-sq-dist $SqI $PieceI $SqTI $Dist $Tables) + (distance-table $Tables $Table) + (square-piece-sq-dist1 $SqI $PieceI $SqTI $Table $Dist)) ; -; +; Cut seems to help speed here, don't know why. - - (= - (square-piece-sq-dist1 $SqI $PieceI $SqTI $Table $Dist) - ( (piece-table-entry $_ $PieceI $Table $Entry) - (square-table-distance $SqI $SqTI $Entry $Dist) - (set-det))) -; - + (= (square-piece-sq-dist1 $SqI $PieceI $SqTI $Table $Dist) + (piece-table-entry $_ $PieceI $Table $Entry) + (square-table-distance $SqI $SqTI $Entry $Dist) + (set-det)) ; -; - +; Returns 10000 if no such dist is found. (used in arrive.pl) - (= - (square-piece-sq-dist-max $SqI $PieceI $SqTI $DTable $Dist) + (= (square-piece-sq-dist-max $SqI $PieceI $SqTI $DTable $Dist) (det-if-then-else (square-piece-sq-dist1 $SqI $PieceI $SqTI $DTable $Dist) True (= $Dist 10000))) -; - - (= - (square-piece-list-dist $SqI $PieceI $SqTI $Dist) - ( (distance-matrix $Matrix) (square-piece-list-dist $SqI $PieceI $SqTI $Matrix $Dist))) -; - + (= (square-piece-list-dist $SqI $PieceI $SqTI $Dist) + (distance-matrix $Matrix) + (square-piece-list-dist $SqI $PieceI $SqTI $Matrix $Dist)) - (= - (square-piece-list-dist $SqI $PieceI $SqTI $Table $Dist) - ( (piece-table-entry $_ $PieceI $Table $Entry) (square-matrix-distance $SqI $SqTI $Entry $Dist))) -; - - + (= (square-piece-list-dist $SqI $PieceI $SqTI $Table $Dist) + (piece-table-entry $_ $PieceI $Table $Entry) + (square-matrix-distance $SqI $SqTI $Entry $Dist)) - (= - (square-piece-list-distance $SqI $PieceI $SqTI $Dist) - ( (distance-matrix $Matrix) (square-piece-list-distance $SqI $PieceI $SqTI $Matrix $Dist))) -; + (= (square-piece-list-distance $SqI $PieceI $SqTI $Dist) + (distance-matrix $Matrix) + (square-piece-list-distance $SqI $PieceI $SqTI $Matrix $Dist)) - (= - (square-piece-list-distance $SqI $PieceI $SqTI $Table $Dist) - ( (piece-table-entry $_ $PieceI $Table $Entry) (square-matrix-distance $SqI $SqTI $Entry $Dist))) -; - + (= (square-piece-list-distance $SqI $PieceI $SqTI $Table $Dist) + (piece-table-entry $_ $PieceI $Table $Entry) + (square-matrix-distance $SqI $SqTI $Entry $Dist)) - (= - (print-distance-matrix) + (= (print-distance-matrix) (print-distance-matrix $_ $_ $_)) -; - - (= - (print-distance-matrix $Sq $Piece $SqT) - ( (format "Square Piece Distance Matrix:~n" Nil) (or (, (square-piece-list-distance $Sq $Piece $SqT $Dist) (format "~p: ~p -> ~p <~p>~n" (:: $Piece $Sq $SqT $Dist)) (fail)) True))) -; - + (= (print-distance-matrix $Sq $Piece $SqT) + (format "Square Piece Distance Matrix:~n" Nil) + (or + (, + (square-piece-list-distance $Sq $Piece $SqT $Dist) + (format "~p: ~p -> ~p <~p>~n" + (:: $Piece $Sq $SqT $Dist)) + (fail)) True)) +; ; format("matrix[~p][~p] = ~p~n",[Sq,Piece,SqT]), - (= - (print-distance-table) + (= (print-distance-table) (print-distance-table $_ $_ $_)) -; + (= (print-distance-table $Sq $Piece $SqT) + (format "Square Piece Distance Table:~n" Nil) + (or + (, + (square-piece-distance $Sq $Piece $SqT $Dist) + (format "~p: ~p -> ~p <~p>~n" + (:: $Piece $Sq $SqT $Dist)) + (fail)) True)) +; ; format("table[~p][~p] = ~p~n",[Sq,Piece,SqT]), - (= - (print-distance-table $Sq $Piece $SqT) - ( (format "Square Piece Distance Table:~n" Nil) (or (, (square-piece-distance $Sq $Piece $SqT $Dist) (format "~p: ~p -> ~p <~p>~n" (:: $Piece $Sq $SqT $Dist)) (fail)) True))) -; + (= (piece-distance-table $Piece $Table) + (distance-table $D) + (piece-table-entry $Piece $_ $D $Table)) - (= - (piece-distance-table $Piece $Table) - ( (distance-table $D) (piece-table-entry $Piece $_ $D $Table))) -; - - - - (= - (spd $S $P $SqT $V) + (= (spd $S $P $SqT $V) (square-piece-distance $S $P $SqT $V)) -; - ; -; - +; SQUARE_PIECE_DISTANCE(?Sq,?Piece,?SqT,?Dist) ; -; - +; Very nice table indicating the minimum distance a piece would ; -; - +; take to move from one square to another on an empty board. ; -; - - - (= - (square-piece-distance $Sq $Piece $SqT $Dist) - ( (advice-tables $Tables) (square-piece-distance $Sq $Piece $SqT $Dist $Tables))) -; +; The extra arg version returns indices also. + (= (square-piece-distance $Sq $Piece $SqT $Dist) + (advice-tables $Tables) + (square-piece-distance $Sq $Piece $SqT $Dist $Tables)) ; -; - +; SQUARE_PIECE_DISTANCE(?Sq,?Piece,?SqT,?Dist,+Tables) ; -; - +; Very nice table indicating the minimum distance a piece would ; -; - +; take to move from one square to another on an empty board. ; -; - - (= - (square-piece-distance $Sq $Piece $SqT $Dist $Tables) +; The extra arg version returns indices also. + (= (square-piece-distance $Sq $Piece $SqT $Dist $Tables) (square-piece-distance $Sq $SqI $Piece $PieceI $SqT $SqTI $Dist $Tables)) -; - - - (= - (square-piece-distance $Sq $SqI $Piece $PieceI $SqT $SqTI $Dist $Tables) - ( (piece-index $Piece $PieceI) - (square-index $Sq $SqI) - (square-index $SqT $SqTI) - (square-piece-sq-dist $SqI $PieceI $SqTI $Dist $Tables))) -; + (= (square-piece-distance $Sq $SqI $Piece $PieceI $SqT $SqTI $Dist $Tables) + (piece-index $Piece $PieceI) + (square-index $Sq $SqI) + (square-index $SqT $SqTI) + (square-piece-sq-dist $SqI $PieceI $SqTI $Dist $Tables)) ; -; - +; ============================================================================== ; -; - +; Reachability using Transition Matrix ; -; +; ============================================================================== + (= (square-piece-reaches $Sq $Piece $Squares) + (transition-matrix $Trans) + (piece-table-entry $Piece $_ $Trans $PTrans) + (square-piece-reaches $Sq $SqIndex $PTrans $Squares)) - (= - (square-piece-reaches $Sq $Piece $Squares) - ( (transition-matrix $Trans) - (piece-table-entry $Piece $_ $Trans $PTrans) - (square-piece-reaches $Sq $SqIndex $PTrans $Squares))) -; - - - (= - (square-piece-reaches $Sq $SqIndex $Trans $Squares) - ( (square-index $Sq $SqIndex) (sq-piece-reaches $SqIndex $Trans $Squares))) -; + (= (square-piece-reaches $Sq $SqIndex $Trans $Squares) + (square-index $Sq $SqIndex) + (sq-piece-reaches $SqIndex $Trans $Squares)) - - (= - (sq-piece-reaches $Sq $Trans $Squares) + (= (sq-piece-reaches $Sq $Trans $Squares) (reachable $Sq $Trans $Squares)) -; - - (= - (indist-set $Piece $Sq $SqT $Dist $Set) + (= (indist-set $Piece $Sq $SqT $Dist $Set) (setof $SqT (indist $Piece $Sq $SqT $Dist) $Set)) -; - +; ; piece_index(Piece,PI), ; square_index(Sq,SqI), ; square_index(SqT,SqTI), - (= - (indist-set2 $Piece $Sq $SqT $Dist $Set) + (= (indist-set2 $Piece $Sq $SqT $Dist $Set) (setof $SqT (indist $Piece $Sq $SqT $Dist) $Set)) -; - - (= - (indist $Piece $Sq $SqT $Dist) - ( (distance-table $Table) (piece-square-within-distance $Piece $_ $Sq $SqI $SqT $SqTI $Dist $Table))) -; - + (= (indist $Piece $Sq $SqT $Dist) + (distance-table $Table) + (piece-square-within-distance $Piece $_ $Sq $SqI $SqT $SqTI $Dist $Table)) - (= - (piece-square-at-distance $Piece $PieceI $Sq $SqI $SqT $SqTI $Dist $Table) - ( (piece-table-entry $Piece $PieceI $Table $T) - (square-index $Sq $SqI) - (square-index $SqT $SqTI) - (square-table-distance $SqI $SqTI $T $D) - (=< $D $Dist))) -; - + (= (piece-square-at-distance $Piece $PieceI $Sq $SqI $SqT $SqTI $Dist $Table) + (piece-table-entry $Piece $PieceI $Table $T) + (square-index $Sq $SqI) + (square-index $SqT $SqTI) + (square-table-distance $SqI $SqTI $T $D) + (=< $D $Dist)) ; -; - - - (= - (piece-dist-squares-matrix $P $PI $Sq $SqI $Squares) - ( (distance-matrix $D) (piece-dist-squares-matrix $P $PI $Sq $SqI $D $Squares))) -; - - - - (= - (piece-dist-squares-matrix $P $PI $Sq $SqI $DistMatrix $Squares) - ( (piece-table-entry $P $PI $DistMatrix $Matrix) - (member1-pair - (- $SqI $Dist) $Matrix) - (p-transpose $Dist $New) - (p-to-s-graph $New $Squares))) -; - - - - (= - (piece-dist-squares $P $PI $Sq $SqI $Distance $Squares) - ( (distance-matrix $DistMatrix) (piece-dist-squares $P $PI $Sq $SqI $Distance $DistMatrix $Squares))) -; +; Returns a list of the squarse + (= (piece-dist-squares-matrix $P $PI $Sq $SqI $Squares) + (distance-matrix $D) + (piece-dist-squares-matrix $P $PI $Sq $SqI $D $Squares)) - (= - (piece-dist-squares $P $PI $Sq $SqI $Distance $DistMatrix $Squares) - ( (piece-dist-squares-matrix $P $PI $Sq $SqI $DistMatrix $Matrix) (member1-pair (- $Distance $Squares) $Matrix))) -; + (= (piece-dist-squares-matrix $P $PI $Sq $SqI $DistMatrix $Squares) + (piece-table-entry $P $PI $DistMatrix $Matrix) + (member1-pair + (- $SqI $Dist) $Matrix) + (p-transpose $Dist $New) + (p-to-s-graph $New $Squares)) - (= - (piece-dist-count $P $Sq $Distance $Count) - ( (piece-index $P $PI) - (square-index $Sq $SqI) - (piece-dist-count $P $PI $Sq $SqI $Distance $Count))) -; + (= (piece-dist-squares $P $PI $Sq $SqI $Distance $Squares) + (distance-matrix $DistMatrix) + (piece-dist-squares $P $PI $Sq $SqI $Distance $DistMatrix $Squares)) + (= (piece-dist-squares $P $PI $Sq $SqI $Distance $DistMatrix $Squares) + (piece-dist-squares-matrix $P $PI $Sq $SqI $DistMatrix $Matrix) + (member1-pair + (- $Distance $Squares) $Matrix)) - (= - (piece-dist-count $P $PI $Sq $SqI $Distance $Count) - ( (distance-matrix $DistMatrix) (piece-dist-count $P $PI $Sq $SqI $Distance $DistMatrix $Count))) -; + (= (piece-dist-count $P $Sq $Distance $Count) + (piece-index $P $PI) + (square-index $Sq $SqI) + (piece-dist-count $P $PI $Sq $SqI $Distance $Count)) - (= - (piece-dist-count $P $PI $Sq $SqI $Distance $DistMatrix $Count) - ( (piece-dist-squares $P $PI $Sq $SqI $Distance $DistMatrix $Squares) (length $Squares $Count))) -; - + (= (piece-dist-count $P $PI $Sq $SqI $Distance $Count) + (distance-matrix $DistMatrix) + (piece-dist-count $P $PI $Sq $SqI $Distance $DistMatrix $Count)) + (= (piece-dist-count $P $PI $Sq $SqI $Distance $DistMatrix $Count) + (piece-dist-squares $P $PI $Sq $SqI $Distance $DistMatrix $Squares) + (length $Squares $Count)) - (= - (piece-indist-sum $Piece $PieceI $Sq $SqI $Distance $Count) - ( (distance-matrix $DistMatrix) (piece-indist-sum $Piece $PieceI $Sq $SqI $Distance $DistMatrix $Count))) -; + (= (piece-indist-sum $Piece $PieceI $Sq $SqI $Distance $Count) + (distance-matrix $DistMatrix) + (piece-indist-sum $Piece $PieceI $Sq $SqI $Distance $DistMatrix $Count)) - (= - (piece-indist-sum $Piece $PieceI $Sq $SqI $Distance $DistMatrix $Count) - ( (bagof $Count1 - (piece-indist-count $Piece $PieceI $Sq $SqI $Distance $DistMatrix $Count1) $Counts) - (square-index $Sq $SqI) - (sumlist $Counts $Count))) -; - + (= (piece-indist-sum $Piece $PieceI $Sq $SqI $Distance $DistMatrix $Count) + (bagof $Count1 + (piece-indist-count $Piece $PieceI $Sq $SqI $Distance $DistMatrix $Count1) $Counts) + (square-index $Sq $SqI) + (sumlist $Counts $Count)) +; ; piece_index(Piece,PI), ; square_index(Sq,SqI), - (= - (piece-indist-count $Piece $PieceI $Sq $SqI $Distance $Count) - ( (distance-matrix $DistMatrix) (piece-indist-count $Piece $PieceI $Sq $SqI $Distance $DistMatrix $Count))) -; + (= (piece-indist-count $Piece $PieceI $Sq $SqI $Distance $Count) + (distance-matrix $DistMatrix) + (piece-indist-count $Piece $PieceI $Sq $SqI $Distance $DistMatrix $Count)) + (= (piece-indist-count $Piece $PieceI $Sq $SqI $Distance $DistMatrix $Count) + (piece-dist-count $Piece $PieceI $Sq $SqI $Dist1 $DistMatrix $Count) + (=< $Dist1 $Distance)) - (= - (piece-indist-count $Piece $PieceI $Sq $SqI $Distance $DistMatrix $Count) - ( (piece-dist-count $Piece $PieceI $Sq $SqI $Dist1 $DistMatrix $Count) (=< $Dist1 $Distance))) -; + (= (piece-indist-crunchsum $P $PI $Sq $SqI $Distance $Count) + (distance-matrix $DistMatrix) + (piece-indist-crunchsum $P $PI $Sq $SqI $Distance $DistMatrix $Count)) + (= (piece-indist-crunchsum $P $PI $Sq $SqI $Distance $DistMatrix $Count) + (piece-dist-squares-matrix $P $PI $Sq $SqI $DistMatrix $Squares) + (crunch-ds $Squares $S) + (count-less $S $Distance $Count)) - (= - (piece-indist-crunchsum $P $PI $Sq $SqI $Distance $Count) - ( (distance-matrix $DistMatrix) (piece-indist-crunchsum $P $PI $Sq $SqI $Distance $DistMatrix $Count))) -; - (= - (piece-indist-crunchsum $P $PI $Sq $SqI $Distance $DistMatrix $Count) - ( (piece-dist-squares-matrix $P $PI $Sq $SqI $DistMatrix $Squares) - (crunch-ds $Squares $S) - (count-less $S $Distance $Count))) -; + (= (piece-discounted-sum $P $PI $Sq $SqI $Distance $Count) + (distance-matrix $DistMatrix) + (piece-discounted-sum $P $PI $Sq $SqI $Distance $DistMatrix $Count)) - - - - (= - (piece-discounted-sum $P $PI $Sq $SqI $Distance $Count) - ( (distance-matrix $DistMatrix) (piece-discounted-sum $P $PI $Sq $SqI $Distance $DistMatrix $Count))) -; - - - (= - (piece-discounted-sum $P $PI $Sq $SqI $Distance $DistMatrix $Count) - ( (piece-dist-squares-matrix $P $PI $Sq $SqI $DistMatrix $Squares) - (crunch-ds $Squares $Series) - (discounted-sum $Series $Distance $Count))) -; + (= (piece-discounted-sum $P $PI $Sq $SqI $Distance $DistMatrix $Count) + (piece-dist-squares-matrix $P $PI $Sq $SqI $DistMatrix $Squares) + (crunch-ds $Squares $Series) + (discounted-sum $Series $Distance $Count)) + (= (piece-indist-matrix $P $PI $Distance $Matrix) + (distance-matrix $DistMatrix) + (piece-indist-matrix $P $PI $Distance $DistMatrix $Matrix)) - (= - (piece-indist-matrix $P $PI $Distance $Matrix) - ( (distance-matrix $DistMatrix) (piece-indist-matrix $P $PI $Distance $DistMatrix $Matrix))) -; - - - (= - (piece-indist-matrix $P $PI $Distance $DistMatrix $Matrix) - ( (piece-index $P $PI) (map-square-table sq-piece-indist-crunchsum (:: $P $PI $Distance $DistMatrix) $Matrix))) -; - + (= (piece-indist-matrix $P $PI $Distance $DistMatrix $Matrix) + (piece-index $P $PI) + (map-square-table sq-piece-indist-crunchsum + (:: $P $PI $Distance $DistMatrix) $Matrix)) ; -; - +; Discounted Sum: The value of a square decays exponentially with ; -; - +; distance. ; -; - +; Crunchsum: We add all the squares within a given distance, ; -; - +; weighed equally independent of their distance. ; -; - +; These do not give the same ordering: A square with a better crunchsum ; -; - +; may have many moves far away. The discounted sum will prefer closer ; -; - +; moves, and put pieces on squares with (foremost) the highest immediate ; -; +; mobility. - - (= - (sq-piece-indist-crunchsum $Sq $SqI $P $PI $Distance $DistMatrix $Count) + (= (sq-piece-indist-crunchsum $Sq $SqI $P $PI $Distance $DistMatrix $Count) (piece-discounted-sum $P $PI $_ $SqI $Distance $DistMatrix $Count)) -; +; ; piece_indist_crunchsum(P,PI,_,SqI,Distance,DistMatrix,Count). - - (= - (crunch-invert $SqDs $DSqs) - ( (p-transpose $SqDs $New) (p-to-s-graph $New $DSqs))) -; + (= (crunch-invert $SqDs $DSqs) + (p-transpose $SqDs $New) + (p-to-s-graph $New $DSqs)) - - (= - (crunchtop () ()) True) -; - - (= - (crunchtop - (Cons - (- $Sq $Sqs) $G) - (Cons - (- $Sq $Ds) $GRest)) - ( (crunch-invert $Sqs $DSqs) - (crunch-ds $DSqs $Ds) - (crunchtop $G $GRest))) -; - + (= (crunchtop () ()) True) + (= (crunchtop (Cons (- $Sq $Sqs) $G) (Cons (- $Sq $Ds) $GRest)) + (crunch-invert $Sqs $DSqs) + (crunch-ds $DSqs $Ds) + (crunchtop $G $GRest)) ; -; - +; crunch_ds([1-[a,b,c],2-[d,e,f],4-[g]],C). ; -; - +; C = [1-3,2-3,4-1] ; ; + (= (crunch_ds () ()) True) + (= (crunch-ds (Cons (- $D $Sqs) $G) (Cons (- $D $Count) $Rest)) + (length $Sqs $Count) + (crunch-ds $G $Rest)) - (= - (crunch_ds () ()) True) -; - - (= - (crunch-ds - (Cons - (- $D $Sqs) $G) - (Cons - (- $D $Count) $Rest)) - ( (length $Sqs $Count) (crunch-ds $G $Rest))) -; - - - - (= - (count_less () $_ 0) True) -; - - (= - (count-less - (Cons - (- $Dist $_) $_) $Max 0) - ( (< $Max $Dist) (set-det))) -; - - (= - (count-less - (Cons - (- $Dist $C1) $As) $Max $Count) - ( (count-less $As $Max $CRest) (is $Count (+ $C1 $CRest)))) -; + (= (count_less () $_ 0) True) + (= (count-less (Cons (- $Dist $_) $_) $Max 0) + (< $Max $Dist) + (set-det)) + (= (count-less (Cons (- $Dist $C1) $As) $Max $Count) + (count-less $As $Max $CRest) + (is $Count + (+ $C1 $CRest))) +; ; Max >= Dist, !, ; -; - +; discounted_sum(Series,Discount,Sum). - (= - (discounted-sum $Series $Discount $Sum) + (= (discounted-sum $Series $Discount $Sum) (discounted-sum $Series $Discount 0 $Sum)) -; + (= (discounted_sum () $_ $Count $Count) True) + (= (discounted-sum (Cons (- $Dist $C1) $Rest) $Discount $Sum1 $Sum) + (discount-value $Dist $C1 $Discount $Val) + (is $Sum2 + (+ $Sum1 $Val)) + (discounted-sum $Rest $Discount $Sum2 $Sum)) - (= - (discounted_sum () $_ $Count $Count) True) -; - - (= - (discounted-sum - (Cons - (- $Dist $C1) $Rest) $Discount $Sum1 $Sum) - ( (discount-value $Dist $C1 $Discount $Val) - (is $Sum2 - (+ $Sum1 $Val)) - (discounted-sum $Rest $Discount $Sum2 $Sum))) -; - - - - (= - (discount-value $Distance $Count $Discount $Val) - ( (distance-value $Distance $V) (is $Val (* $Count $V)))) -; + (= (discount-value $Distance $Count $Discount $Val) + (distance-value $Distance $V) + (is $Val + (* $Count $V))) ; -; - +; ============================================================================== ; -; - +; Reverse matrices ; -; - +; ============================================================================== ; -; - +; Reverse matrices: Tell for each square, how many moves ; -; - +; away the other squares are from moving to it. ; -; - +; Interesting fact: If the piece movements this is based upon ; -; - - - (= - (rev-transition-matrix $Piece $PieceIndex $Matrix $State) - ( (transition-matrix $Piece $PieceIndex $Matrix1 $State) (s-transpose $Matrix1 $Matrix))) -; - +; are symmetric, this is the same as the forward matrix! + (= (rev-transition-matrix $Piece $PieceIndex $Matrix $State) + (transition-matrix $Piece $PieceIndex $Matrix1 $State) + (s-transpose $Matrix1 $Matrix)) - (= - (rev-distance-matrix $Piece $PieceIndex $Matrix $State) - ( (rev-transition-matrix $Piece $PieceIndex $Matrix1 $State) (s-floyd $Matrix1 $Matrix))) -; + (= (rev-distance-matrix $Piece $PieceIndex $Matrix $State) + (rev-transition-matrix $Piece $PieceIndex $Matrix1 $State) + (s-floyd $Matrix1 $Matrix)) - (= - (rev-distance-table $Piece $PieceIndex $Table $State) - ( (rev-distance-matrix $Piece $PieceIndex $Matrix $State) (d-to-array $Matrix $Table))) -; - + (= (rev-distance-table $Piece $PieceIndex $Table $State) + (rev-distance-matrix $Piece $PieceIndex $Matrix $State) + (d-to-array $Matrix $Table)) ; -; - +; ================================================================================ ; -; - +; TRACING execution of analysis routines ; -; - +; ================================================================================ ; -; - +; This main tracing module is called: anal. ; -; - +; The following tracing modules are used in this file: ; -; - +; index: info on piece indexing ; ; - ; -; - +; Each module can be set on/off, using set_anal_verbosity (see below), or ; -; - +; using trace_anal_. ; ; - ; -; - +; All can be turned off with silent_anal. !(my-ensure-loaded (library tracing)) -; - - (= - (tracing-anal $Type $Call) + (= (tracing-anal $Type $Call) (det-if-then-else (tracing (anal $Type)) (call $Call) True)) -; - ; -; +; Might cause trouble later when want to use streams also. - - (= - (tracing-anal-format $Type $String $Args) + (= (tracing-anal-format $Type $String $Args) (det-if-then-else (tracing (anal $Type)) (format $String $Args) True)) -; - - (= - (tracing-anal-timing $Type $Call) + (= (tracing-anal-timing $Type $Call) (trace-timing (anal $Type) $Call)) -; - - (= - (set-anal-verbosity $Level $Status) + (= (set-anal-verbosity $Level $Status) (set-tracing (anal $Level) $Status)) -; - - (= - (silent-anal) + (= (silent-anal) (all-anal off)) -; - - (= - (loud-anal) + (= (loud-anal) (all-anal on)) -; - - (= - (all-anal $Status) - ( (set-anal-verbosity index $Status) - (set-anal-verbosity simplify $Status) - (set-anal-verbosity subsume $Status) - (set-anal-verbosity pieces $Status))) -; - + (= (all-anal $Status) + (set-anal-verbosity index $Status) + (set-anal-verbosity simplify $Status) + (set-anal-verbosity subsume $Status) + (set-anal-verbosity pieces $Status)) - (= - (trace-anal-tables) - (set-anal-verbosity tables on)) -; - + (= (trace-anal-tables) + (set-anal-verbosity tables on)) - (= - (trace-anal-index) - (set-anal-verbosity index on)) -; - + (= (trace-anal-index) + (set-anal-verbosity index on)) - (= - (trace-anal-subsume) - (set-anal-verbosity subsume on)) -; - + (= (trace-anal-subsume) + (set-anal-verbosity subsume on)) - (= - (trace-anal-simplify) - (set-anal-verbosity simplify on)) -; - + (= (trace-anal-simplify) + (set-anal-verbosity simplify on)) - (= - (trace-anal-pieces) - (set-anal-verbosity pieces on)) -; - + (= (trace-anal-pieces) + (set-anal-verbosity pieces on)) !(trace-anal-tables *) -; - ; -; - +; :- silent_anal. diff --git a/metagame/learning/arrive.metta b/metagame/learning/arrive.metta index c407634..7e6c883 100644 --- a/metagame/learning/arrive.metta +++ b/metagame/learning/arrive.metta @@ -1,284 +1,187 @@ +; (convert_to_metta_file arrive $_85810 metagame/learning/arrive.pl metagame/learning/arrive.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; arrive.pl ; -; - +; ARRIVAL Strategy ; -; - +; This strategy for a player favors positions in which that player ; -; - +; owns pieces which are closer to the destination for his arrival goals. ; ; - ; -; - +; We check that the piece is owned by the player ; -; - +; who has the goal, as this strategy will not in general help us ; -; - +; get our opponent's pieces to square they don't want to be on. ; ; - ; -; - +; The value returned by this strategy is a probability, + or -, ; -; - +; that the player will achieve a given goal (on backtracking, ; -; - - +; gives value for each of his goals). - (= - (arrive-value $Piece $Sq $SqT $Goal $Value $Pos $Tables) - ( (owns $Piece $Player) - (game-player-has-goal $_ $Player $Goal) - (arrive-goal $Goal $Player $Type $Sqs) - (arrive-goal $Goal $Descr $Squares) - (arrive-distance $Piece $Sq $SqT $Descr $Squares $SqDist $Tables) - (clear-path-cost $Piece $Player $Sq $SqT $SqDist $PathCost $Pos) - (arrive-likelihood $PathCost $Prob) - (reasonable-likelihood $Prob) - (arrive-goal-value $Piece $IValue) - (expected-value $Prob $IValue $AbsVal) - (negate-for-player $Player $AbsVal $Value))) -; + (= (arrive-value $Piece $Sq $SqT $Goal $Value $Pos $Tables) + (owns $Piece $Player) + (game-player-has-goal $_ $Player $Goal) + (arrive-goal $Goal $Player $Type $Sqs) + (arrive-goal $Goal $Descr $Squares) + (arrive-distance $Piece $Sq $SqT $Descr $Squares $SqDist $Tables) + (clear-path-cost $Piece $Player $Sq $SqT $SqDist $PathCost $Pos) + (arrive-likelihood $PathCost $Prob) + (reasonable-likelihood $Prob) + (arrive-goal-value $Piece $IValue) + (expected-value $Prob $IValue $AbsVal) + (negate-for-player $Player $AbsVal $Value)) - (= - (arrive-distance $Piece $Sq $SqT - (arrive $Descr $Squares) $Dist $Tables) + (= (arrive-distance $Piece $Sq $SqT (arrive $Descr $Squares) $Dist $Tables) (arrive-distance $Piece $Sq $SqT $Descr $Squares $Dist $Tables)) -; - ; -; - +; We approximate the distance by using the static piece distance, ; -; - - - (= - (arrive-distance $Piece $Sq $SqT $Descr $Squares $Dist $Tables) - ( (matches $Descr $Piece) - (member $SqT $Squares) - (approx-path-distance $Sq $Piece $SqT $Dist $Tables))) -; +; instead of checking the current board dynamically. + (= (arrive-distance $Piece $Sq $SqT $Descr $Squares $Dist $Tables) + (matches $Descr $Piece) + (member $SqT $Squares) + (approx-path-distance $Sq $Piece $SqT $Dist $Tables)) ; -; - +; How much do we value achieving arrival goals? Can't make it ; -; - +; infinite, as this will then dominate all other considerations. ; -; - +; It may be a function of different pieces. ; -; - - - (= - (arrive_goal_value $Piece 1) True) -; +; For now we'll set it to 1, and use a parameter to control it. + (= (arrive_goal_value $Piece 1) True) ; -; - +; The likelihood of getting a piece to a square decreases ; -; - +; exponentially with the number of moves required to ; -; - +; achieve it. This uses the same decay rate as is used ; -; +; in eventual mobility determination, and for promotions. - - (= - (arrive-likelihood $Distance $Prob) + (= (arrive-likelihood $Distance $Prob) (distance-value $Distance $Prob)) -; - ; -; - +; DISTANCE_VALUE(Distance,Value) ; -; - +; Distance is a positive integer, usually an abstract number of ; -; - +; moves. The likelihood of realizing a goal decreases ; -; - +; by some decreasing function of the number of moves required to ; -; - - - (= - (distance-value $Distance $Value) - ( (parameter discount $D) (discount-fn $D $Distance $Value))) -; +; achieve it. + (= (distance-value $Distance $Value) + (parameter discount $D) + (discount-fn $D $Distance $Value)) - (= - (discount-fn inverse $Distance $Value) + (= (discount-fn inverse $Distance $Value) (is $Value (/ 1 (+ 1 $Distance)))) -; - - (= - (discount-fn exponent $Distance $Value) + (= (discount-fn exponent $Distance $Value) (is $Value (/ 1 (<< 1 $Distance)))) -; - ; -; - +; If there is some distance, use it. ; -; - +; Otherwise assume it is very far away (make this a parameter also?) ; -; - +; This at least gives some points for having the right type of ; -; - - - (= - (approx-path-distance $Sq $Piece $SqT $Dist $Tables) - ( (square-piece-distance $Sq $Piece $SqT $Dist $Tables) (set-det))) -; - - (= - (approx_path_distance $Sq $Piece $SqT 10 $Tables) True) -; +; piece on the board. + (= (approx-path-distance $Sq $Piece $SqT $Dist $Tables) + (square-piece-distance $Sq $Piece $SqT $Dist $Tables) + (set-det)) + (= (approx_path_distance $Sq $Piece $SqT 10 $Tables) True) ; -; - +; The cost (in moves) of clearing the path to a square ; -; - +; and then moving the piece to it. ; -; - +; Could take into account whether piece could capture occupier ; -; - +; and thus give a discount as nobody else need do so. ; -; - +; Now adding 1 move penalty if player is not in control in ; -; - +; the current position, as this would be a handicap in a race ; -; - - - (= - (clear-path-cost $Piece $Player $Sq $SqT $SqDist $PathCost $Pos) - ( (clear-square-cost $SqT $Player $SqClearCost $Pos) - (control-cost $Player $ControlCost $Pos) - (is $PathCost - (+ - (+ $ControlCost $SqDist) $SqClearCost)))) -; +; to get somewhere. + (= (clear-path-cost $Piece $Player $Sq $SqT $SqDist $PathCost $Pos) + (clear-square-cost $SqT $Player $SqClearCost $Pos) + (control-cost $Player $ControlCost $Pos) + (is $PathCost + (+ + (+ $ControlCost $SqDist) $SqClearCost))) - (= - (clear-square-cost $SqT $Player $SqClearCost $Pos) - ( (on $Occupier $SqT $Pos) (clear-occupier $Occupier $Player $SqClearCost))) -; - + (= (clear-square-cost $SqT $Player $SqClearCost $Pos) + (on $Occupier $SqT $Pos) + (clear-occupier $Occupier $Player $SqClearCost)) ; -; - +; Rather arbitrary value for cost of clearing opponent ; -; - - - (= - (clear_occupier empty $_ 0) True) -; +; from the square! - (= - (clear-occupier - (piece $Type $Player) $Player 1) + (= (clear_occupier empty $_ 0) True) + (= (clear-occupier (piece $Type $Player) $Player 1) (set-det)) -; - - (= - (clear_occupier - (piece $Type $Player) $Opponent 5) True) -; + (= (clear_occupier (piece $Type $Player) $Opponent 5) True) - - (= - (reasonable-likelihood $Prob) + (= (reasonable-likelihood $Prob) (> $Prob 0)) -; - - (= - (expected-value $Prob $IVal $Value) + (= (expected-value $Prob $IVal $Value) (is $Value (* $Prob $IVal))) -; - - (= - (test $Sq $SqT $Value) + (= (test $Sq $SqT $Value) (arrive-value (piece slug player) $Sq $SqT (piece-desc any-player any-piece) (:: $SqT) $Value)) -; - diff --git a/metagame/learning/dominate.metta b/metagame/learning/dominate.metta index 7c73204..7b7921c 100644 --- a/metagame/learning/dominate.metta +++ b/metagame/learning/dominate.metta @@ -1,255 +1,207 @@ +; (convert_to_metta_file dominate $_206796 metagame/learning/dominate.pl metagame/learning/dominate.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - - - - (= - (attacks-i $PieceAI $SqAI $SqTI $PieceVI $SqVI $S) - ( (attacks $PieceA $SqA $SqT $PieceV $SqV $S) - (piece-index $PieceA $PieceAI) - (piece-index $PieceV $PieceVI) - (square-index $SqA $SqAI) - (square-index $SqV $SqVI))) -; +; ============================================================ + (= (attacks-i $PieceAI $SqAI $SqTI $PieceVI $SqVI $S) + (attacks $PieceA $SqA $SqT $PieceV $SqV $S) + (piece-index $PieceA $PieceAI) + (piece-index $PieceV $PieceVI) + (square-index $SqA $SqAI) + (square-index $SqV $SqVI)) - (= - (attacks $PieceA $SqA $SqT $PieceV $SqV $S) - ( (det-if-then-else - (or - (nonvar $SqA) - (nonvar $SqT)) True - (board-square $SqA)) (attacks1 $PieceA $SqA $SqT $PieceV $SqV $S))) -; + (= (attacks $PieceA $SqA $SqT $PieceV $SqV $S) + (det-if-then-else + (or + (nonvar $SqA) + (nonvar $SqT)) True + (board-square $SqA)) + (attacks1 $PieceA $SqA $SqT $PieceV $SqV $S)) ; -; - +; PieceA is on SqA in the ; -; - +; position, and he can take PieceV on SqV by moving to SqT. ; -; +; (Need to set the right player in control to do this correctly). + (= (attacks0 $PieceA $SqA $SqT $PieceV $SqV $S) + (blank-state $S) + (player-role $Player) + (control $Player $S) + (owns $PieceA $Player) + (on $PieceA $SqA $S) + (captures $PieceA $Player $SqA $SqT $Effect $Captured $S) + (captured-piece $PieceV $SqV $Captured)) - (= - (attacks0 $PieceA $SqA $SqT $PieceV $SqV $S) - ( (blank-state $S) - (player-role $Player) - (control $Player $S) - (owns $PieceA $Player) - (on $PieceA $SqA $S) - (captures $PieceA $Player $SqA $SqT $Effect $Captured $S) - (captured-piece $PieceV $SqV $Captured))) -; - - - - (= - (attacks1 $PieceA $SqA $SqT $PieceV $SqV $S) - ( (blank-state-if $S) - (player-role $Player) - (put-control $Player $S $S1) - (owns $PieceA $Player) - (captures $PieceA $Player $SqA $SqT $Effect $Captured $S1) - (captured-piece $PieceV $SqV $Captured))) -; + (= (attacks1 $PieceA $SqA $SqT $PieceV $SqV $S) + (blank-state-if $S) + (player-role $Player) + (put-control $Player $S $S1) + (owns $PieceA $Player) + (captures $PieceA $Player $SqA $SqT $Effect $Captured $S1) + (captured-piece $PieceV $SqV $Captured)) +; /* attacks1(PieceA,SqA,SqT,PieceV,SqV,S) :- blank_state_if(S), player_role(Player), control(Player,S), owns(PieceA,Player), captures(PieceA,Player,SqA,SqT,_Effect,Captured,S), captured_piece(PieceV,SqV,Captured). */ +; ; If PieceA were on SqA and Player in control in the ; position, he could take PieceV on SqV by moving to SqT. ; ; -; - +; This is very inefficient if we know the position already, ; -; - +; as it first genetes hypothetical attacks, and then sees if the ; -; - - - (= - (attackshow $PieceA $SqA $SqT $PieceV $SqV $S) - ( (attacks $PieceA $SqA $SqT $PieceV $SqV $S) (on $PieceA $SqA $S))) -; +; piece really is on the board! + (= (attackshow $PieceA $SqA $SqT $PieceV $SqV $S) + (attacks $PieceA $SqA $SqT $PieceV $SqV $S) + (on $PieceA $SqA $S)) - (= - (blank-state-if $S) + (= (blank-state-if $S) (det-if-then-else (var $S) (blank-state $S) True)) -; - - (= - (blank-state $S) + (= (blank-state $S) (blank-state $Player $Stage 0 $S)) -; - - - (= - (blank-state $Player $Stage $Move $S) - ( (new-state $S0) (initialize-state-properties $Stage $Player $Move $S0 $S))) -; + (= (blank-state $Player $Stage $Move $S) + (new-state $S0) + (initialize-state-properties $Stage $Player $Move $S0 $S)) ; -; - +; PA on SqA is Dist moves from a square SqI on which it ; -; - +; would attack PV on SqV, in State. ; ; - - (= - (attack-distance $PA $SqA $SqI $PV $SqV $Dist $State) - ( (attacks $PA $SqI $SqT $PV $SqV $State) (square-piece-distance $SqA $PA $SqI $Dist))) -; - + (= (attack-distance $PA $SqA $SqI $PV $SqV $Dist $State) + (attacks $PA $SqI $SqT $PV $SqV $State) + (square-piece-distance $SqA $PA $SqI $Dist)) +; ; attackshow(PA,SqI,_SqT,PV,SqV,State), - (= - (closest-attack $PA $SqA $SqI $PV $SqV $Dist $State $Tables) - ( (setof + (= (closest-attack $PA $SqA $SqI $PV $SqV $Dist $State $Tables) + (setof + (- + (- $Dist1 $SqI) $State) + (attack-distance $PA $SqA $SqI $PV $SqV $Dist1 $State) $Places) + (= $Places + (Cons (- - (- $Dist1 $SqI) $State) - (attack-distance $PA $SqA $SqI $PV $SqV $Dist1 $State) $Places) (= $Places (Cons (- (- $Dist $SqI) $State) $Rest)))) -; - + (- $Dist $SqI) $State) $Rest))) - (= - (testa $Dist $State) + (= (testa $Dist $State) (attack-distance (piece king player) (square 5 3) $SqI (piece man opponent) (square 2 2) $Dist $State)) -; + (= (dominate-value $PieceA $SqA $PieceV $SqV $Goal $Value $Pos $Tables) + (blank-state-if $Pos) + (game-player-has-goal $_ $Player $Goal) + (opposite-role $Player $Opponent) + (eradicate-goal $Goal $Opponent $Type) + (eradicate-goal $Goal $Descr) + (weighted-dominate $Descr $PieceA $Player $SqA $PieceV $SqV $Value $Pos $Tables)) +; /* ; A piece is dominated to the extent that there are enemy pieces close to ; its square and squares it can move to. ; The simplest way to do this analysis may be to build a graph which says for ; each square, the pieces (now on the board?) which would attack it if they got to ; some square. ; Well, first find the target squares. Consider each one separately. ; Dominating a target square: ; For each piece type, find the squares it would be on to attack the target. ; Then consider the pieces on the board separately. Look up their entry (set of ; squares) in this table, find the distance to each of these, and take the minimum. ; Score some points which decrease as the distance gets farther. This can be done most simply to start by having just 1 piece on the board. Domination is slightly worse for the player who has to move, because of Zugswang. [?] Also important for domination is the number of pieces left to capture before the goal is achieved. Thus when a player has just one king, this is vital to protect, whereas when he has lots of checkers, dominating any 1 isn't that crucial until the numbers are smaller. To model this, we should first count the number matching this goal, and then weight the resulting domination value for each target piece by some value which decreases as the number of such targets increases. In fact, maybe don't even think about domination until the number of targets is smaller. */ +; /* dominate_value(PieceA,SqA,PieceV,SqV,Goal,Value,Pos,Tables) :- game_player_has_goal(_,Player,Goal), eradicate_goal(Goal,Opponent,_Type), eradicate_goal(Goal,Descr), opposite_role(Player,Opponent), dominate_val1(PieceA,Player,SqA,PieceV,SqV,Descr,Value,Pos,Tables). dominate_val1(PieceA,Player,SqA,PieceV,SqV,Descr,Value,Pos,Tables) :- blank_state_if(Pos), on(PieceV,_,SqV,Pos), matches(Descr,PieceV), closest_attack(PieceA,SqA,_SqI,PieceV,SqV,Dist,_State,Tables), distance_value(Dist,Val), negate_for_player(Player,Val,Value). */ - (= - (dominate-value $PieceA $SqA $PieceV $SqV $Goal $Value $Pos $Tables) - ( (blank-state-if $Pos) - (game-player-has-goal $_ $Player $Goal) - (opposite-role $Player $Opponent) - (eradicate-goal $Goal $Opponent $Type) - (eradicate-goal $Goal $Descr) - (weighted-dominate $Descr $PieceA $Player $SqA $PieceV $SqV $Value $Pos $Tables))) -; - - -; (error -; (syntax_error operator_expected) -; (file metagame/learning/dominate.pl 158 13 5055)) +; (error +; (syntax_error operator_expected) +; (file metagame/learning/dominate.pl 158 13 5055)) -; (error -; (syntax_error operator_expected) -; (file metagame/learning/dominate.pl 163 13 5214)) +; (error +; (syntax_error operator_expected) +; (file metagame/learning/dominate.pl 163 13 5214)) - (= - (dominate-val1 $PieceA $Player $SqA $PieceV $SqV $Value $Pos $Tables) - ( (blank-state-if $Pos) - (closest-attack $PieceA $SqA $SqI $PieceV $SqV $Dist $State $Tables) - (distance-value $Dist $Val) - (negate-for-player $Player $Val $Value))) -; - + (= (dominate-val1 $PieceA $Player $SqA $PieceV $SqV $Value $Pos $Tables) + (blank-state-if $Pos) + (closest-attack $PieceA $SqA $SqI $PieceV $SqV $Dist $State $Tables) + (distance-value $Dist $Val) + (negate-for-player $Player $Val $Value)) - (= - (matching-square $Piece $Sq $Descr $Pos) - ( (on $Piece $_ $Sq $Pos) (matches $Descr $Piece))) -; - + (= (matching-square $Piece $Sq $Descr $Pos) + (on $Piece $_ $Sq $Pos) + (matches $Descr $Piece)) - (= - (enough-target-urgency $Targets $Weight) - ( (length $Targets $Length) - (< $Length 4) - (is $Weight - (/ 1 $Length)))) -; - + (= (enough-target-urgency $Targets $Weight) + (length $Targets $Length) + (< $Length 4) + (is $Weight + (/ 1 $Length))) +; ; Make a param - (= - (test2 $PV $SV $Val $S) - ( (checkpoint test $S) (dominate-value (piece king player) (square 4 2) $PV $SV $Goal $Val $S))) -; - - - - (= - (test3) - ( (setof - (, $A $B $C $D $E) - (^ $S - (attacks $A $B $C $D $E $S)) $Sets) (ppl $Sets))) -; - + (= (test2 $PV $SV $Val $S) + (checkpoint test $S) + (dominate-value + (piece king player) + (square 4 2) $PV $SV $Goal $Val $S)) - (= - (test4) - ( (setof - (, $D $A $E $B) - (^ - (, $C $S) - (attacks $A $B $C $D $E $S)) $Sets) (ppl $Sets))) -; + (= (test3) + (setof + (, $A $B $C $D $E) + (^ $S + (attacks $A $B $C $D $E $S)) $Sets) + (ppl $Sets)) + (= (test4) + (setof + (, $D $A $E $B) + (^ + (, $C $S) + (attacks $A $B $C $D $E $S)) $Sets) + (ppl $Sets)) +; /* black king ,( a , 1 ) ,( c , 3 ) ,white king ,( b , 2 ) black king ,( a , 1 ) ,( c , 3 ) ,white man ,( b , 2 ) black king ,( a , 2 ) ,( c , 4 ) ,white king ,( b , 3 ) black king ,( a , 2 ) ,( c , 4 ) ,white man ,( b , 3 ) */ - (= - (test5) - ( (setof - (, $D $A $E $B) - (^ - (, $C $S) - (attacks-i $A $B $C $D $E $S)) $Sets) (ppl $Sets))) -; + (= (test5) + (setof + (, $D $A $E $B) + (^ + (, $C $S) + (attacks-i $A $B $C $D $E $S)) $Sets) + (ppl $Sets)) - (= - (attackset $Attacks $State) + (= (attackset $Attacks $State) (setof (^ $PieceV (^ $PieceA @@ -257,57 +209,32 @@ (^ (, $SqT $State) (attacks-i $PieceA $SqA $SqT $PieceV $SqV $State)) $Attacks)) -; - +; /* 1,3,45,38 1,3,45,52 1,3,45,54 1,3,46,37 1,3,46,39 */ ; -; - - - (= - (dom-table $DomTable $State) - ( (attackset $Attacks $State) - (do-graph $Attacks $GroupedTargs) - (group-attacks $GroupedTargs $DomTable))) -; +; Attackset gives us: [Targ^Attack^TargSq^AttackSq|Rest] + (= (dom-table $DomTable $State) + (attackset $Attacks $State) + (do-graph $Attacks $GroupedTargs) + (group-attacks $GroupedTargs $DomTable)) ; -; - +; Grouped attacks gives us: [Targ-[Attack^TargSq^AttackSq|RestAttacks]|RestTargs] - (= - (group_attacks () ()) True) -; + (= (group_attacks () ()) True) + (= (group-attacks (Cons (- $T $As) $Rest) (Cons (- $T $GroupedAs) $GRest)) + (do-graph $As $Grouped1) + (group-targsq $Grouped1 $GroupedAs) + (group-attacks $Rest $GRest)) - (= - (group-attacks - (Cons - (- $T $As) $Rest) - (Cons - (- $T $GroupedAs) $GRest)) - ( (do-graph $As $Grouped1) - (group-targsq $Grouped1 $GroupedAs) - (group-attacks $Rest $GRest))) -; - - - - (= - (group_targsq () ()) True) -; - - (= - (group-targsq - (Cons - (- $A $Sqs) $Rest) - (Cons - (- $A $GroupedSqs) $GRest)) - ( (do-graph $Sqs $GroupedSqs) (group-targsq $Rest $GRest))) -; + (= (group_targsq () ()) True) + (= (group-targsq (Cons (- $A $Sqs) $Rest) (Cons (- $A $GroupedSqs) $GRest)) + (do-graph $Sqs $GroupedSqs) + (group-targsq $Rest $GRest)) diff --git a/metagame/learning/exclude.metta b/metagame/learning/exclude.metta index f06ceac..3e99ce2 100644 --- a/metagame/learning/exclude.metta +++ b/metagame/learning/exclude.metta @@ -1,245 +1,175 @@ +; (convert_to_metta_file exclude $_91940 metagame/learning/exclude.pl metagame/learning/exclude.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; exclude.pl ; -; - +; ;; Filtering piece movement transitions based on goals. ; -; - +; ;; The only external module here is SAFE_TRANSITION_TYPE/8. ; -; - +; GOAL_SQUARE(Piece,Sq,Player,Goal) ; -; - - - (= - (goal-square $Piece $Sq $Player $Goal) - ( (game-player-has-goal $_ $Player $Goal) - (arrive-goal $Goal $Descr $Squares) - (matches $Descr $Piece) - (member1 $Sq $Squares))) -; - +; Player has goal Goal to get Piece to Sq (in the current game). + (= (goal-square $Piece $Sq $Player $Goal) + (game-player-has-goal $_ $Player $Goal) + (arrive-goal $Goal $Descr $Squares) + (matches $Descr $Piece) + (member1 $Sq $Squares)) - (= - (safe-transitions-type $Piece $PieceIndex $Sq $SqIndex $Type $SqTIndices $State) - ( (square-index $Sq $SqIndex) (det-if-then-else (setof $SqTIndex (^ $SqT (safe-transition-type $Piece $PieceIndex $Sq $SqIndex $SqT $SqTIndex $Type $State)) $SqTIndices) True (= $SqTIndices Nil)))) -; + (= (safe-transitions-type $Piece $PieceIndex $Sq $SqIndex $Type $SqTIndices $State) + (square-index $Sq $SqIndex) + (det-if-then-else + (setof $SqTIndex + (^ $SqT + (safe-transition-type $Piece $PieceIndex $Sq $SqIndex $SqT $SqTIndex $Type $State)) $SqTIndices) True + (= $SqTIndices Nil))) - (= - (safe-transition $Piece $Sq $SqT $State) + (= (safe-transition $Piece $Sq $SqT $State) (safe-transition $Piece $PieceIndex $Sq $SquareIndex $SqT $SqTIndex $State)) -; - - (= - (safe-transition $Piece $PieceIndex $Sq $SquareIndex $SqT $SqTIndex $State) + (= (safe-transition $Piece $PieceIndex $Sq $SquareIndex $SqT $SqTIndex $State) (safe-transition-type $Piece $PieceIndex $Sq $SquareIndex $SqT $SqTIndex moving $State)) -; - ; -; - +; SAFE_TRANSITION_TYPE(Piece,PieceIndex,Sq,SquareIndex,SqT,SqTIndex,Type,State) ; ; - ; -; - +; Check here before calling piece-movement that Sq is not a goal square for Piece ; -; - +; (for either player), as if it is these transitions are irrelevant as the game will ; -; - +; end first. ; -; - +; Then check that target square SqT is not necessarily a *loss* (goal square for the ; -; - +; enemy alone) as if it is this transition will likely never be made. ; -; - +; Not sure about this: ; -; - +; I might capture your piece by landing on a losing square, thus ending the ; -; - +; game in a draw (but we're probably not doing captures here!). ; ; - - (= - (safe-transition-type $Piece $PieceIndex $Sq $SquareIndex $SqT $SqTIndex $Type $State) - ( (square-index $Sq $SquareIndex) - (piece-index $Piece $PieceIndex) - (not (excluded-from $Piece $Sq)) - (piece-move-for-type $Type $Piece $Sq $SqT $State) - (not (excluded-to $Piece $SqT)) - (square-index $SqT $SqTIndex) - (tracing-anal-format detailed "~p: ~p -> ~p~n" - (:: $Piece $Sq $SqT)))) -; - + (= (safe-transition-type $Piece $PieceIndex $Sq $SquareIndex $SqT $SqTIndex $Type $State) + (square-index $Sq $SquareIndex) + (piece-index $Piece $PieceIndex) + (not (excluded-from $Piece $Sq)) + (piece-move-for-type $Type $Piece $Sq $SqT $State) + (not (excluded-to $Piece $SqT)) + (square-index $SqT $SqTIndex) + (tracing-anal-format detailed "~p: ~p -> ~p~n" + (:: $Piece $Sq $SqT))) +; ; new_empty_state(State), ; for testing ; -; - +; A piece will never move from a goal square for either player, ; -; +; as the game will already have ended. - - (= - (excluded-from $Piece $Sq) - (goal-square $Piece $Sq $Player $Goal)) -; - + (= (excluded-from $Piece $Sq) + (goal-square $Piece $Sq $Player $Goal)) ; -; - +; A piece will never move to a goal square for the opponent, ; -; - +; unless immediately on that square it is able to force promotion into ; -; - +; a piece which is not *only* an opponent goal on that square. ; ; - ; -; - +; Similarly, a piece will never move onto a square where it is forced to promote ; -; - - - (= - (excluded-to $Piece $SqT) - ( (owns $Piece $Player) - (goal-square $Piece $SqT $Opp $_) - (opposite-role $Player $Opp) - (not (goal-square $Piece $SqT $Player $_)) - (not (safe-promotion $Piece $Player $SqT)) - (tracing-anal-format filter "Filter: <~p> can't safely move to ~p~n" - (:: $Piece $SqT)))) -; - - (= - (excluded-to $Piece $SqT) - ( (owns $Piece $Player) - (player-promotion-square $Player $SqT) - (not (safe-prom1 $Piece $Player $SqT)) - (tracing-anal-format filter "Filter: <~p> can't safely promote on ~p~n" - (:: $Piece $SqT)))) -; +; into a goal for the opponent. + (= (excluded-to $Piece $SqT) + (owns $Piece $Player) + (goal-square $Piece $SqT $Opp $_) + (opposite-role $Player $Opp) + (not (goal-square $Piece $SqT $Player $_)) + (not (safe-promotion $Piece $Player $SqT)) + (tracing-anal-format filter "Filter: <~p> can't safely move to ~p~n" + (:: $Piece $SqT))) + (= (excluded-to $Piece $SqT) + (owns $Piece $Player) + (player-promotion-square $Player $SqT) + (not (safe-prom1 $Piece $Player $SqT)) + (tracing-anal-format filter "Filter: <~p> can't safely promote on ~p~n" + (:: $Piece $SqT))) ; -; - +; A safe promotion occurs when we are in promotion zone and either: ; -; - +; 1. We choose the promotion, and there is some non-losing choice. ; -; +; 2. Opponent chooses, and there is no losing choice. - - (= - (safe-promotion $Piece $Player $SqT) - ( (owns $Piece $Player) - (player-promotion-square $Player $SqT) - (safe-prom1 $Piece $Player $SqT))) -; - + (= (safe-promotion $Piece $Player $SqT) + (owns $Piece $Player) + (player-promotion-square $Player $SqT) + (safe-prom1 $Piece $Player $SqT)) ; -; - +; Case 1: we can choose safely. ; -; - +; Case 2: opponent must choose safely. - (= - (safe-prom1 $Piece $Player $SqT) + (= (safe-prom1 $Piece $Player $SqT) (player-safe-prom $Piece $Player $SqT)) -; - - (= - (safe-prom1 $Piece $Player $SqT) + (= (safe-prom1 $Piece $Player $SqT) (opponent-safe-prom $Piece $Player $SqT)) -; - - - - - (= - (player-safe-prom $Piece $Player $SqT) - ( (promotes-into $Piece $PieceT $Player $Player) - (opposite-role $Player $Opp) - (not (goal-square $PieceT $SqT $Opp $_)))) -; + (= (player-safe-prom $Piece $Player $SqT) + (promotes-into $Piece $PieceT $Player $Player) + (opposite-role $Player $Opp) + (not (goal-square $PieceT $SqT $Opp $_))) - (= - (opponent-safe-prom $Piece $Player $SqT) - ( (opponent-promotes $Piece) (not (opponent-wins-prom $Piece $Player $SqT)))) -; + (= (opponent-safe-prom $Piece $Player $SqT) + (opponent-promotes $Piece) + (not (opponent-wins-prom $Piece $Player $SqT))) +; /* Moved this to prom.pl. ; Player can promote Piece to PieceT on SqT. ; Backtracks over all SqT. player_safe_new_prom(Piece,Player,PieceT,SqT) :- promotes_into(Piece,PieceT,Player,Player), Piece \== PieceT, player_promotion_square(Player,SqT), opposite_role(Player,Opp), \+ goal_square(PieceT,SqT,Opp,_). */ - (= - (opponent-wins-prom $Piece $Player $SqT) - ( (promotes-into $Piece $PieceT $Player $Opp) - (opposite-role $Player $Opp) - (goal-square $PieceT $SqT $Opp $_))) -; + (= (opponent-wins-prom $Piece $Player $SqT) + (promotes-into $Piece $PieceT $Player $Opp) + (opposite-role $Player $Opp) + (goal-square $PieceT $SqT $Opp $_)) ; -; - +; arrive_value(Piece,Sq,SqT,Goal,Value,Pos) :- ; -; - +; game_player_has_goal(_,Player,Goal), ; -; - +; arrive_goal(Goal,Player,_Type,_Sqs), ; -; - +; arrive_goal(Goal,Descr,Squares), diff --git a/metagame/learning/flight.metta b/metagame/learning/flight.metta index 27d0f0c..329ab13 100644 --- a/metagame/learning/flight.metta +++ b/metagame/learning/flight.metta @@ -1,223 +1,162 @@ +; (convert_to_metta_file flight $_216976 metagame/learning/flight.pl metagame/learning/flight.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; SAFE_FLIGHT_SQUARE(Piece,Player,SqF,SqT,Pos,Tables) ; -; - +; A safe flight square is one where the piece can move (perhaps by capture), ; -; - +; the new square doesn't win for the enemy, and in the resulting position ; -; - +; no piece is attacking it. ; -; - +; We could restrict attacking pieces to those which wouldn't be attacked in the ; -; - +; next position, to pieces which could safely move onto their dest square when ; -; +; capturing us, etc., but this should do as a first cut! - - (= - (safe-flight-square $Piece $Player $SqF $SqT $Pos $Tables) - ( (opposite-role $Player $Opp) - (flight-square $Piece $Player $SqF $SqT $Pos $PosOut $Tables) - (not (threatens $PieceA $Opp $SqA $SqTA $Piece $SqT $Effect $PosOut)))) -; - + (= (safe-flight-square $Piece $Player $SqF $SqT $Pos $Tables) + (opposite-role $Player $Opp) + (flight-square $Piece $Player $SqF $SqT $Pos $PosOut $Tables) + (not (threatens $PieceA $Opp $SqA $SqTA $Piece $SqT $Effect $PosOut))) ; -; +; The exclusion check now in global.pl when we build tables in the first place. - - (= - (flight-square $Piece $Player $SqF $SqT $Pos $PosOut $Tables) - ( (blank-state-if $Pos) - (on $Piece $SqF $Pos) - (piece-index $Piece $_) - (general-move $Piece $Player $SqF $SqT $Pos $PosOut $Tables))) -; + (= (flight-square $Piece $Player $SqF $SqT $Pos $PosOut $Tables) + (blank-state-if $Pos) + (on $Piece $SqF $Pos) + (piece-index $Piece $_) + (general-move $Piece $Player $SqF $SqT $Pos $PosOut $Tables)) +; ; find_advice_tables_if(Tables), ; add_dynamic_tables_if(Pos,Tables), - - (= - (general-move $Piece $Player $SqF $SqT $Pos $PosOut $Tables) + (= (general-move $Piece $Player $SqF $SqT $Pos $PosOut $Tables) (done-move-threat $Piece $Player $SqF $SqT $Pos $PosOut $Tables)) -; - - (= - (general-move $Piece $Player $SqF $SqT $Pos $PosOut $Tables) + (= (general-move $Piece $Player $SqF $SqT $Pos $PosOut $Tables) (done-capture-threat $Piece $Player $SqF $SqT $PieceV $SqV $Effect $Pos $PosOut $Tables)) -; - - (= - (testflight) - ( (checkpoint cap $Pos) - (flight-square $Piece player $SqF $SqT $Pos $ZOut $Tables) - (format "~p->~p~n" - (:: $SqF $SqT)))) -; - + (= (testflight) + (checkpoint cap $Pos) + (flight-square $Piece player $SqF $SqT $Pos $ZOut $Tables) + (format "~p->~p~n" + (:: $SqF $SqT))) ; -; - +; ================================================================================ ; -; - +; Flight_square without changing position (not used). ; -; - - +; ================================================================================ - (= - (flight-square $Piece $Player $SqF $SqT $Pos $Tables) - ( (blank-state-if $Pos) - (on $Piece $SqF $Pos) - (piece-index $Piece $_) - (general-move $Piece $Player $SqF $SqT $Pos $Tables))) -; + (= (flight-square $Piece $Player $SqF $SqT $Pos $Tables) + (blank-state-if $Pos) + (on $Piece $SqF $Pos) + (piece-index $Piece $_) + (general-move $Piece $Player $SqF $SqT $Pos $Tables)) +; ; find_advice_tables_if(Tables), ; add_dynamic_tables_if(Pos,Tables), ; -; +; use routines in global.pl - - (= - (general-move $Piece $Player $SqF $SqT $Pos $Tables) + (= (general-move $Piece $Player $SqF $SqT $Pos $Tables) (move-threat $Piece $Player $SqF $SqT $Tables)) -; - - (= - (general-move $PieceA $Player $SqA $SqT $Pos $Tables) + (= (general-move $PieceA $Player $SqA $SqT $Pos $Tables) (capture-threat $PieceA $Player $SqA $SqT $PieceV $SqV $Effect $Tables)) -; - ; -; - +; ================================================================================ ; -; - +; Using flight info for dominate goals ; -; +; ================================================================================ + (= (eradicate-safety $Player $Piece $Sq $Goal $Value $Pos $Tables) + (opposite-role $Player $Opponent) + (game-player-has-goal $_ $Opponent $Goal) + (eradicate-goal $Goal $Player $Type) + (eradicate-goal $Goal $Descr) + (owns $Piece $Player) + (weighted-dominate $Descr $Player $Piece $Sq $Value $Pos $Tables)) +; /* A piece is tightly-dominated to the extent that its flight squares are covered by enemy pieces. Domination is slightly worse for the player who has to move, because of Zugswang. [?] Also important for domination is the number of pieces left to capture before the goal is achieved. Thus when a player has just one king, this is vital to protect, whereas when he has lots of checkers, dominating any 1 isn't that crucial until the numbers are smaller. To model this, we should first count the number matching this goal, and then weight the resulting domination value for each target piece by some value which decreases as the number of such targets increases. In fact, maybe don't even think about domination until the number of targets is smaller. */ - (= - (eradicate-safety $Player $Piece $Sq $Goal $Value $Pos $Tables) - ( (opposite-role $Player $Opponent) - (game-player-has-goal $_ $Opponent $Goal) - (eradicate-goal $Goal $Player $Type) - (eradicate-goal $Goal $Descr) - (owns $Piece $Player) - (weighted-dominate $Descr $Player $Piece $Sq $Value $Pos $Tables))) -; - - -; (error -; (syntax_error operator_expected) -; (file metagame/learning/flight.pl 105 12 3822)) +; (error +; (syntax_error operator_expected) +; (file metagame/learning/flight.pl 105 12 3822)) -; (error -; (syntax_error operator_expected) -; (file metagame/learning/flight.pl 110 13 3967)) +; (error +; (syntax_error operator_expected) +; (file metagame/learning/flight.pl 110 13 3967)) ; -; - +; A dominated piece gets points for its owner for each safe ; -; - +; flight square it has, with each square weighted by the ; -; - +; eventual mobility the piece would have from that square. ; -; - +; Thus, a king near the corner, with 8 flight squares, may still be ; -; - +; worse than a king in the center with only 3 flight squares. ; -; - +; Also, this says that if we want to take away just 1 flight square ; -; - +; from the piece, take the more central one to force it backward! ; -; - +; If this is annoying we can change it to just count the number of ; -; - - - (= - (dominate-val1 $Player $Piece $SqF $Value $Pos $Tables) - ( (blank-state-if $Pos) - (safe-flight-square $Piece $Player $SqF $SqT $Pos $Tables) - (eventual-piece-mobility $Piece $SqT $Val $Pos $Tables) - (negate-for-player $Player $Val $Value))) -; +; moves it has. + (= (dominate-val1 $Player $Piece $SqF $Value $Pos $Tables) + (blank-state-if $Pos) + (safe-flight-square $Piece $Player $SqF $SqT $Pos $Tables) + (eventual-piece-mobility $Piece $SqT $Val $Pos $Tables) + (negate-for-player $Player $Val $Value)) - (= - (matching-square $Piece $Sq $Descr $Pos) - ( (on $Piece $_ $Sq $Pos) (matches $Descr $Piece))) -; - + (= (matching-square $Piece $Sq $Descr $Pos) + (on $Piece $_ $Sq $Pos) + (matches $Descr $Piece)) ; -; - +; VITAL_NUMBER parameter controls max number left st we consider ; -; - - - (= - (enough-target-urgency $Targets $Weight) - ( (parameter vital-number $N) - (length $Targets $Length) - (=< $Length $N) - (is $Weight - (/ 1 $Length)))) -; +; remaining eradicate targets to be vital to our safety. + (= (enough-target-urgency $Targets $Weight) + (parameter vital-number $N) + (length $Targets $Length) + (=< $Length $N) + (is $Weight + (/ 1 $Length))) ; (error @@ -227,97 +166,71 @@ - (= - (eradicate-goal-targets $Player $Goal $Targets $Pos) - ( (opposite-role $Player $Opponent) - (game-player-has-goal $_ $Player $Goal) - (eradicate-goal $Goal $Opponent $Type) - (eradicate-goal $Goal $Descr) - (dominate-targets $Descr $Targets $Pos))) -; - + (= (eradicate-goal-targets $Player $Goal $Targets $Pos) + (opposite-role $Player $Opponent) + (game-player-has-goal $_ $Player $Goal) + (eradicate-goal $Goal $Opponent $Type) + (eradicate-goal $Goal $Descr) + (dominate-targets $Descr $Targets $Pos)) ; -; - +; May want to take the particular effect into accout, as not as ; -; - +; serious if we possess the piece afterward. ; -; - +; Just checks if there is some threat to this piece, doesn't count ; -; - +; duplicates. ; -; - +; If black needs to kill N more white pieces to achieve his goal, the ; -; - +; value to white for having each of these pieces threatened is -1/N. ; -; - +; So when down to last vital piece, he scores -1 for having it threatened. ; -; - +; Thus by setting the parameter which uses this function to have high value, ; -; - +; it only kicks into effect when we get threatened, and can override all other ; -; - +; considerations. ; -; - +; Also, when there are multiple goals threatened, we take more seriously the ones ; -; - +; which are closer to achievement. ; ; - - (= - (threatened-vital-piece $Piece $Sq $Player $Goal $Value $Pos $Tables) - ( (opposite-role $Player $Opponent) - (vital-piece $Piece $Sq $Player $Goal $Weight $Pos $Tables) - (det-if-then - (capture-threat $PieceA $Opponent $SqA $SqT $Piece $Sq $Effect $Tables) True) - (negate-for-player $Opponent $Weight $Value))) -; - + (= (threatened-vital-piece $Piece $Sq $Player $Goal $Value $Pos $Tables) + (opposite-role $Player $Opponent) + (vital-piece $Piece $Sq $Player $Goal $Weight $Pos $Tables) + (det-if-then + (capture-threat $PieceA $Opponent $SqA $SqT $Piece $Sq $Effect $Tables) True) + (negate-for-player $Opponent $Weight $Value)) +; ; find_advice_tables_if(Tables), ; add_dynamic_tables_if(Pos,Tables), ; -; - +; If opponent to move and threatening our last piece, this is ; -; - +; absolutely terrible, so make value much more intense (override all else). ; -; - +; Otherwise use normal value. ; -; - +; Note this only applies after we've assigned all the pieces, as ; -; - - - (= - (threatened-vital-piece-value $Piece $Sq $Player $Goal $Value $Pos $Tables) - ( (not (still-assigning $Pos)) - (threatened-vital-piece $Piece $Sq $Player $Goal $Val1 $Pos $Tables) - (det-if-then-else - (or - (control $Player $Pos) - (< - (abs $Val1) 1)) - (= $Value $Val1) - (is $Value - (* 10000 $Val1))))) -; +; eradicate goals are not checked until then. + (= (threatened-vital-piece-value $Piece $Sq $Player $Goal $Value $Pos $Tables) + (not (still-assigning $Pos)) + (threatened-vital-piece $Piece $Sq $Player $Goal $Val1 $Pos $Tables) + (det-if-then-else + (or + (control $Player $Pos) + (< + (abs $Val1) 1)) + (= $Value $Val1) + (is $Value + (* 10000 $Val1)))) diff --git a/metagame/learning/global.metta b/metagame/learning/global.metta index cf888fd..7f4264b 100644 --- a/metagame/learning/global.metta +++ b/metagame/learning/global.metta @@ -1,200 +1,157 @@ +; (convert_to_metta_file global $_183060 metagame/learning/global.pl metagame/learning/global.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; +; ;; global.pl + (= (move-threat $Piece $Player $SqF $SqT $Tables) + (moving-table $Tables $MTable) + (member + (move $Piece $Player $SqF $SqT) $MTable)) +; /* Dealing with global analysis of threats and piece moves. This should build a table listing which squares each piece could move to (if present as feature) and which squares each piece could capture. Then we can analyze threats for player (to move) and opponent (next move). Player gets the max piece he is attacking, plus any special effects. One special effect is that if he threatens to achieve a goal and it is his move, he wins. Next mover gets 2nd max piece he is threatening. If only threatening 1 piece, gets a wee fraction of value for it. */ +; ;================================================================================ ; Moves and Captures using Dynamic Move-Tables ;================================================================================ ; Note these are the same as you would get using the position, but ; instead rely on the tables built from the position. ; However they don't include ones which lose an arrival goal immediately. ; Also, the capturing routines only accurate when just 1 piece would be ; captured, as they leave the rest on the board. - (= - (move-threat $Piece $Player $SqF $SqT $Tables) - ( (moving-table $Tables $MTable) (member (move $Piece $Player $SqF $SqT) $MTable))) -; - - - - (= - (capture-threat $PieceA $Player $SqA $SqT $PieceV $SqV $Effect $Tables) - ( (capturing-table $Tables $MTable) (member (threat $PieceA $Player $SqA $SqT $PieceV $SqV $Effect) $MTable))) -; + (= (capture-threat $PieceA $Player $SqA $SqT $PieceV $SqV $Effect $Tables) + (capturing-table $Tables $MTable) + (member + (threat $PieceA $Player $SqA $SqT $PieceV $SqV $Effect) $MTable)) ; -; +; These actually provide the new output state. - - (= - (done-move-threat $Piece $Player $SqF $SqT $Pos $PosOut $Tables) - ( (move-threat $Piece $Player $SqF $SqT $Tables) (do-move $Piece $SqF $SqT $Pos $PosOut))) -; + (= (done-move-threat $Piece $Player $SqF $SqT $Pos $PosOut $Tables) + (move-threat $Piece $Player $SqF $SqT $Tables) + (do-move $Piece $SqF $SqT $Pos $PosOut)) + (= (done-capture-threat $PieceA $Player $SqA $SqT $PieceV $SqV $Effect $Pos $PosOut $Tables) + (capture-threat $PieceA $Player $SqA $SqT $PieceV $SqV $Effect $Tables) + (do-capture $PieceA $SqA $SqT $PieceV $SqV $Pos $PosOut)) - (= - (done-capture-threat $PieceA $Player $SqA $SqT $PieceV $SqV $Effect $Pos $PosOut $Tables) - ( (capture-threat $PieceA $Player $SqA $SqT $PieceV $SqV $Effect $Tables) (do-capture $PieceA $SqA $SqT $PieceV $SqV $Pos $PosOut))) -; + (= (do-move $Piece $SqF $SqT $Pos $PosOut) + (lift-piece $Piece $SqF $Pos $Pos1) + (place-piece $Piece $SqT $Pos1 $PosOut)) - (= - (do-move $Piece $SqF $SqT $Pos $PosOut) - ( (lift-piece $Piece $SqF $Pos $Pos1) (place-piece $Piece $SqT $Pos1 $PosOut))) -; - - - - - (= - (do-capture $Piece $SqF $SqT $PieceV $SqV $Pos $PosOut) - ( (lift-piece $Piece $SqF $Pos $Pos1) - (det-if-then-else - (\== $SqV $SqT) - (lift-piece $PieceV $SqV $Pos1 $Pos2) - (= $Pos1 $Pos2)) - (place-piece $Piece $SqT $Pos2 $PosOut))) -; + (= (do-capture $Piece $SqF $SqT $PieceV $SqV $Pos $PosOut) + (lift-piece $Piece $SqF $Pos $Pos1) + (det-if-then-else + (\== $SqV $SqT) + (lift-piece $PieceV $SqV $Pos1 $Pos2) + (= $Pos1 $Pos2)) + (place-piece $Piece $SqT $Pos2 $PosOut)) ; -; - +; ================================================================================ ; -; - +; Global Captures ; -; - +; ================================================================================ ; -; - +; The unique set of capturing moves available in the ; -; - - - (= - (capture-table $Table $S) - ( (findall - (threat $PieceA $Player $SqA $SqT $PieceV $SqV $Effect) - (threatens $PieceA $Player $SqA $SqT $PieceV $SqV $Effect $S) $Table1) (remove-duplicates $Table1 $Table))) -; +; current position. + (= (capture-table $Table $S) + (findall + (threat $PieceA $Player $SqA $SqT $PieceV $SqV $Effect) + (threatens $PieceA $Player $SqA $SqT $PieceV $SqV $Effect $S) $Table1) + (remove-duplicates $Table1 $Table)) - (= - (unique-threats $Threats $Unique) - ( (findall - (target $Player $PieceV $SqV $Effect) - (member - (threat $PieceA $Player $SqA $SqT $PieceV $SqV $Effect) $Threats) $Squares) (remove-duplicates $Squares $Unique))) -; - + (= (unique-threats $Threats $Unique) + (findall + (target $Player $PieceV $SqV $Effect) + (member + (threat $PieceA $Player $SqA $SqT $PieceV $SqV $Effect) $Threats) $Squares) + (remove-duplicates $Squares $Unique)) ; -; - +; UNIQUE is the set of target ; -; - +; tuples for a given PLAYER, where he has some piece ; -; - +; which can capture PIECEV on SqV with effect Effect. ; -; - +; Uses the capture table already constructed. ; -; - +; Thus unlike player_threats/3 below, here we just collect ; -; - +; the unique victim/effect pairs, even if a victim could ; -; - - - (= - (unique-threats $Player $Threats $Unique) - ( (player-role $Player) - (findall - (target $Player $PieceV $SqV $Effect) - (member - (threat $PieceA $Player $SqA $SqT $PieceV $SqV $Effect) $Threats) $Squares) - (remove-duplicates $Squares $Unique))) -; +; be captured by multiple attackers. + (= (unique-threats $Player $Threats $Unique) + (player-role $Player) + (findall + (target $Player $PieceV $SqV $Effect) + (member + (threat $PieceA $Player $SqA $SqT $PieceV $SqV $Effect) $Threats) $Squares) + (remove-duplicates $Squares $Unique)) - (= - (player-threats $Player $Threats $PThreats) - ( (player-role $Player) (findall (threat $PieceA $Player $SqA $SqT $PieceV $SqV $Effect) (member (threat $PieceA $Player $SqA $SqT $PieceV $SqV $Effect) $Threats) $PThreats))) -; - + (= (player-threats $Player $Threats $PThreats) + (player-role $Player) + (findall + (threat $PieceA $Player $SqA $SqT $PieceV $SqV $Effect) + (member + (threat $PieceA $Player $SqA $SqT $PieceV $SqV $Effect) $Threats) $PThreats)) ; -; - +; We check destination square not excluded, as otherwise not a real ; -; - - - (= - (threatens $PieceA $Player $SqA $SqT $PieceV $SqV $Effect $S) - ( (on $PieceA $SqA $S) - (owns $PieceA $Player) - (put-control-if $Player $S $S1) - (captures $PieceA $Player $SqA $SqT $Effect $Captured $S1) - (not (excluded-to $PieceA $SqT)) - (captured-piece $PieceV $SqV $Captured))) -; +; threat. + (= (threatens $PieceA $Player $SqA $SqT $PieceV $SqV $Effect $S) + (on $PieceA $SqA $S) + (owns $PieceA $Player) + (put-control-if $Player $S $S1) + (captures $PieceA $Player $SqA $SqT $Effect $Captured $S1) + (not (excluded-to $PieceA $SqT)) + (captured-piece $PieceV $SqV $Captured)) ; -; - +; ================================================================================ ; -; - +; Global Threats ; -; - +; ================================================================================ - (= - (gthreat $Player $Value $Position $Tables) - ( (capturing-table $Tables $MTable) - (unique-threats $Player $MTable $Unique) - (\== $Unique Nil) - (eval-threats $Unique $Player $Evaled $Position $Tables) - (keysort-for-player $Player $Evaled $Ordered) - (threat-outcome $Player $Ordered $Value $Position $Tables))) -; + (= (gthreat $Player $Value $Position $Tables) + (capturing-table $Tables $MTable) + (unique-threats $Player $MTable $Unique) + (\== $Unique Nil) + (eval-threats $Unique $Player $Evaled $Position $Tables) + (keysort-for-player $Player $Evaled $Ordered) + (threat-outcome $Player $Ordered $Value $Position $Tables)) +; /* 1. If piece attacks > 1 target, value is 2nd max target value. 2. If 2 pieces attack 1 target, no clear value (they may not protect each other from defenders). 3. If 2 pieces attacks different targets, value is 2nd max value. Thus we don't need this local to each piece. Just count targets/effects, score each, take top 2, allow for defense of the first one, score (discounted?) value of 2nd one. If there was only one, give some annoyance credit based on its value, perhaps as we currently do. Actually, that whole analysis applies only to player not on move -- player on move can just take max-valued piece with no worries, and then position probably changes so much that other threats are irrelevant. So if you fork my knight and rook, and instead of moving one of them I attack your queen with a pawn, I gain some points for the queen attack, but know that I am going to lose the knight almost certainly. Note this whole analysis is based on assumption that player can only block 1 threat, and also that we can only execute 1 threat at a time. But suppose we capture by hopping over some whole row of pieces. Then if he moves 1 we may still be able to take the rest. Then again, what do you want for a heuristic anyway? */ - - (= - (eval-threats $Unique $Player $Evaled $Position $Tables) + (= (eval-threats $Unique $Player $Evaled $Position $Tables) (findall (- $Val $Threat) (, @@ -204,217 +161,146 @@ (effect-threat-evaluation $Effect $Player $PieceV $SqV $Val $Position $Tables) (tracing-anal-format gthreat "Threatened: <~p> can capture <~p> ~p (~p) [~p]~n" (:: $Player $PieceV $SqV $Effect $Val))) $Evaled)) -; - ; -; - +; Shutting down the threat feature to avoid nesting, ; -; - - - (= - (local-threat-evaluation $Victim $SqV $Val $S $Tables) - ( (shutdown-advisor threat $Tables) - (= $S1 $S) - (local-evaluation $Victim $SqV $Val $S1 $Tables))) -; +; which was too costly although it gave some finer discriminations. + (= (local-threat-evaluation $Victim $SqV $Val $S $Tables) + (shutdown-advisor threat $Tables) + (= $S1 $S) + (local-evaluation $Victim $SqV $Val $S1 $Tables)) ; -; - +; EFFECT_THREAT_EVALUATION(+Effect,+Player,+PieceV,+SqV,-Value,+Position,+Tables) ; ; - ; -; - +; The value of having a threat against a piece: ; ; - ; -; - +; 1. Piece has some value V on the board. ; -; - +; 2. Piece gets removed from board. This negates the value: -V. ; -; - +; 3. Piece may get possessed by some player. We then really want ; -; - +; possess_value(Possessor,Piece,PosVal) ; -; - +; Just as defined in possess routine when we really have it in hand. ; -; - +; but this seems too expensive to use in threats. ; -; - +; A simple approximation would be to use its static value, but we won't ; -; - +; always have computed that if it is not being used. ; -; - +; a. So instead, we could just say for now that if the same player ; -; - +; possesses it after as before, its original val gets added back: ; -; - +; PosVal = V. ; -; - +; In effect, this means there is no threat in capturing an opponent's ; -; - +; piece if he possesses it right back. ; -; - +; b. If the capturing player gets it, he in effect makes the value at ; -; - +; least twice negated: value: -2V; once for removing it, and once for ; -; - +; having it in his own hand. ; -; - +; 4. If this is not good for player in the end, we just fail, as no threat. ; ; - ; -; - +; Note that we must negate value on board here, as a threat for a player is the negative ; -; - +; of the value of the threatened piece. ; -; - +; Also, we ensure it would be favorable at all to player, else it is not a threat. ; -; - +; [** If must_capture, perhaps should consider even bad values we may have to take] ; ; - ; ; - ; -; - +; [More thoughts ...] ; -; - +; If a piece has a certain value to the opponent, and we are threatening ; -; - +; to capture it under some effect, what is the value to us? ; -; - +; a. Suppose we remove it. ; -; - +; - Removing it negates the value (ie eliminates that component from the position). ; -; - +; - If it was an eradicate target for us, that adds some value ; -; - +; (the more the closer to last it is?) ; -; - +; b. Suppose we possess it. ; -; - +; - Same as remove, but perhaps multiplied for giving us more options? ; -; - +; - Could give big bonus if we can place it on goal square. ; -; - +; c. Suppose opponent possess it. ; -; - +; - Could help to get rid of our pieces as they become opponent's. ; ; - ; ; - - (= - (effect-threat-evaluation $Effect $Player $PieceV $SqV $Value $Position $Tables) - ( (local-threat-evaluation $PieceV $SqV $LVal $Position $Tables) - (is $RemVal - (- $LVal)) - (effect-val $Effect $Player $PieceV $LVal $EVal $Position $Tables) - (is $Value - (+ $RemVal $EVal)) - (favorable-to-owner $Player $Value))) -; - + (= (effect-threat-evaluation $Effect $Player $PieceV $SqV $Value $Position $Tables) + (local-threat-evaluation $PieceV $SqV $LVal $Position $Tables) + (is $RemVal + (- $LVal)) + (effect-val $Effect $Player $PieceV $LVal $EVal $Position $Tables) + (is $Value + (+ $RemVal $EVal)) + (favorable-to-owner $Player $Value)) ; -; - +; Estimating possession value defined in possess.pl. ; -; - +; Mainly, a threat to give a piece back to its owner has no effect. ; -; - +; And swapping ownership doubles the threat value, as it first removes it from ; -; - +; the victim, and then gives it to the attacker. ; ; - - (= - (effect_val remove $Player $PieceV $Val 0 $Position $Tables) True) -; - - (= - (effect-val - (possess $Possessor) $Player $PieceV $LVal $EValue $Position $Tables) + (= (effect_val remove $Player $PieceV $Val 0 $Position $Tables) True) + (= (effect-val (possess $Possessor) $Player $PieceV $LVal $EValue $Position $Tables) (estimate-possess-value $Possessor $PieceV $LVal $EValue $Position $Tables)) -; - ; -; - +; If player in control, gets (discounted?) max threat value. ; -; - +; If player not: ; -; - +; If > 1 threat, gets (discounted?) 2nd max threat value. ; -; - +; If 1 threat only, gets (more discounted?) value of it?? ; -; - +; Could only use for case when >1 threats, and take only threat ; -; - +; as just capmobility?? - (= - (threat-outcome $Player $Ordered $Value $Position $Tables) + (= (threat-outcome $Player $Ordered $Value $Position $Tables) (det-if-then-else (control $Player $Position) (, @@ -436,227 +322,163 @@ (- $Val1 $Threat1) $Rest)) (favor-control $Player $Val1 $Val2 $Position) (favor-control $Player $Val2 $Value $Position)))))) -; - ; -; - +; ================================================================================ ; -; - +; Local Threats ; -; - +; ================================================================================ ; -; - +; The value of having a local threat on a piece is the amount which would be increased ; -; - +; for the threatener if that piece disappeared (or 0 if that is negative), ; -; - +; discounted by an offset based on whether the threat can be executed now or ; -; - +; if the victim gets a chance to defend. ; ; - ; -; - +; This advisor was generally replaced by the global threat (gthreat), ; -; - +; but is kept intact for comparison purposes. Perhaps in some game this would ; -; - +; be the better option. - (= - (local-threat-value $Piece $Square $PieceV $SqV $Value $Pos $Tables) - ( (owns $Piece $Player) - (capture-threat $Piece $Player $Square $SqT $PieceV $SqV $Effect $Tables) - (local-threat-value $Player $Piece $Square $SqT $PieceV $SqV $Effect $Value $Pos $Tables))) -; - + (= (local-threat-value $Piece $Square $PieceV $SqV $Value $Pos $Tables) + (owns $Piece $Player) + (capture-threat $Piece $Player $Square $SqT $PieceV $SqV $Effect $Tables) + (local-threat-value $Player $Piece $Square $SqT $PieceV $SqV $Effect $Value $Pos $Tables)) - (= - (local-threat-value $Player $Piece $Square $SqT $Victim $SqV $Effect $Value $S $Tables) - ( (effect-threat-evaluation $Effect $Player $Victim $SqV $Val $S $Tables) - (favor-control $Player $Val $Value $S) - (tracing-anal-format lthreat "<~p>: ~p -> ~p x ~p ~p (~p) [~p]~n" - (:: $Piece $Square $SqT $Victim $SqV $Effect $Value)))) -; - + (= (local-threat-value $Player $Piece $Square $SqT $Victim $SqV $Effect $Value $S $Tables) + (effect-threat-evaluation $Effect $Player $Victim $SqV $Val $S $Tables) + (favor-control $Player $Val $Value $S) + (tracing-anal-format lthreat "<~p>: ~p -> ~p x ~p ~p (~p) [~p]~n" + (:: $Piece $Square $SqT $Victim $SqV $Effect $Value))) ; -; - +; ================================================================================ ; -; - +; Global Moves ; -; - +; ================================================================================ - (= - (put-control-if $P $S $S1) + (= (put-control-if $P $S $S1) (det-if-then-else (control $P $S) (= $S $S1) (put-control $P $S $S1))) -; - ; -; - +; The unique set of non-capturing moves available in the ; -; - - - (= - (move-table $Table $S) - ( (findall - (move $PieceA $Player $SqA $SqT) - (could-move $PieceA $Player $SqA $SqT $S) $Table1) (remove-duplicates $Table1 $Table))) -; +; current position. + (= (move-table $Table $S) + (findall + (move $PieceA $Player $SqA $SqT) + (could-move $PieceA $Player $SqA $SqT $S) $Table1) + (remove-duplicates $Table1 $Table)) - (= - (unique-moves $Moves $Unique) - ( (findall - (target $Player $PieceA $SqA $SqT) - (member - (move $PieceA $Player $SqA $SqT) $Moves) $Squares) (remove-duplicates $Squares $Unique))) -; - + (= (unique-moves $Moves $Unique) + (findall + (target $Player $PieceA $SqA $SqT) + (member + (move $PieceA $Player $SqA $SqT) $Moves) $Squares) + (remove-duplicates $Squares $Unique)) ; -; - +; UNIQUE is the set of target ; -; - +; tuples for a given PLAYER, where he has a ; -; - +; PIECE move from SqF to SqT. ; -; - +; Uses the move table already constructed. ; ; - ; -; - +; Don't need to remove-dups here because the move-table ; -; - +; already has done this; we're just sorting through the ; -; +; ones which belong to a given player. + (= (unique-moves $Player $Moves $Targets) + (player-role $Player) + (unique-moves $Player $PieceA $SqA $SqT $Moves $Targets)) - (= - (unique-moves $Player $Moves $Targets) - ( (player-role $Player) (unique-moves $Player $PieceA $SqA $SqT $Moves $Targets))) -; - - - (= - (unique-moves $Player $PieceA $SqA $SqT $Moves $Targets) + (= (unique-moves $Player $PieceA $SqA $SqT $Moves $Targets) (findall (target $Player $PieceA $SqA $SqT) (member (move $PieceA $Player $SqA $SqT) $Moves) $Targets)) -; - ; -; - +; We check destination square not excluded, as otherwise not a real ; -; - - - (= - (could-move $PieceA $Player $SqA $SqT $S) - ( (on $PieceA $SqA $S) - (owns $PieceA $Player) - (put-control-if $Player $S $S1) - (moves $PieceA $Player $SqA $SqT $S1) - (not (excluded-to $PieceA $SqT)))) -; +; possibility. + (= (could-move $PieceA $Player $SqA $SqT $S) + (on $PieceA $SqA $S) + (owns $PieceA $Player) + (put-control-if $Player $S $S1) + (moves $PieceA $Player $SqA $SqT $S1) + (not (excluded-to $PieceA $SqT))) ; -; - +; ======================================================================== ; -; - +; Gmob counts the UNIQUE moving-moves a player has. ; -; - +; (ie if can move piece by 2 paths to target, doesn't ; -; +; increase mobility. - - (= - (gmobility $Player $Val $Position $Tables) - ( (moving-table $Tables $MTable) - (unique-moves $Player $MTable $Moves) - (length $Moves $Val))) -; - + (= (gmobility $Player $Val $Position $Tables) + (moving-table $Tables $MTable) + (unique-moves $Player $MTable $Moves) + (length $Moves $Val)) ; -; - +; Gcapmob counts all the threats, possibly counting ; -; - +; the same victim multiply when attacked by different ; -; - - - (= - (gcapmobility $Player $Val $Position $Tables) - ( (capturing-table $Tables $MTable) - (player-threats $Player $MTable $Moves) - (length $Moves $Val))) -; +; pieces, or under different effects. + (= (gcapmobility $Player $Val $Position $Tables) + (capturing-table $Tables $MTable) + (player-threats $Player $MTable $Moves) + (length $Moves $Val)) ; -; +; ======================================================================== - - (= - (add-dynamic-tables-if $S $Tables) + (= (add-dynamic-tables-if $S $Tables) (det-if-then-else (or (, @@ -666,25 +488,21 @@ (moving-table $Tables $Table) (var $Table))) (add-dynamic-tables $S $Tables) True)) -; - ; -; - - - (= - (add-dynamic-tables $S $Tables) - ( (det-if-then-else movtable - (add-moving-table-if $S $Tables) True) (det-if-then-else captable (add-capturing-table-if $S $Tables) True))) -; +; Should change some names here to avoid confusion! + (= (add-dynamic-tables $S $Tables) + (det-if-then-else movtable + (add-moving-table-if $S $Tables) True) + (det-if-then-else captable + (add-capturing-table-if $S $Tables) True)) +; ; tracing_anal_format(dynamic,"Building tables ...~n",[]), - (= - (add-capturing-table-if $S $Tables) + (= (add-capturing-table-if $S $Tables) (det-if-then-else (, (capturing-table $Tables $Table) @@ -693,13 +511,10 @@ (tracing-anal-format dynamic "Building table ...~n" Nil) (tracing-anal-timing dynamic (add-capturing-table $S $Tables))) True)) -; - - (= - (add-moving-table-if $S $Tables) + (= (add-moving-table-if $S $Tables) (det-if-then-else (, (moving-table $Tables $Table) @@ -708,22 +523,16 @@ (tracing-anal-format dynamic "Building table ...~n" Nil) (tracing-anal-timing dynamic (add-moving-table $S $Tables))) True)) -; + (= (add-moving-table $S $Tables) + (move-table $Table $S) + (moving-table $Tables $Table)) - (= - (add-moving-table $S $Tables) - ( (move-table $Table $S) (moving-table $Tables $Table))) -; - - - - (= - (add-capturing-table $S $Tables) - ( (capture-table $Table $S) (capturing-table $Tables $Table))) -; + (= (add-capturing-table $S $Tables) + (capture-table $Table $S) + (capturing-table $Tables $Table)) diff --git a/metagame/learning/group.metta b/metagame/learning/group.metta index 6bf6e8d..033c874 100644 --- a/metagame/learning/group.metta +++ b/metagame/learning/group.metta @@ -1,71 +1,40 @@ +; (convert_to_metta_file group $_444924 metagame/learning/group.pl metagame/learning/group.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; +; ============================================================ + (= (do-graph $P_Graph $S_Graph) + (sort $P_Graph $EdgeSet) + (do-vertices $EdgeSet $VertexBag) + (sort $VertexBag $VertexSet) + (do-group $VertexSet $EdgeSet $S_Graph)) - (= - (do-graph $P_Graph $S_Graph) - ( (sort $P_Graph $EdgeSet) - (do-vertices $EdgeSet $VertexBag) - (sort $VertexBag $VertexSet) - (do-group $VertexSet $EdgeSet $S_Graph))) -; - - - (= - (do-vertices Nil Nil) + (= (do-vertices Nil Nil) (set-det)) -; - - (= - (do-vertices - (Cons - (^ $A $Z) $Edges) - (Cons $A $Vertices)) + (= (do-vertices (Cons (^ $A $Z) $Edges) (Cons $A $Vertices)) (do-vertices $Edges $Vertices)) -; - - (= - (do-group Nil $_ Nil) + (= (do-group Nil $_ Nil) (set-det)) -; - - (= - (do-group - (Cons $Vertex $Vertices) $EdgeSet - (Cons - (- $Vertex $Neibs) $G)) - ( (do-group $EdgeSet $Vertex $Neibs $RestEdges) (do-group $Vertices $RestEdges $G))) -; - - - - (= - (do-group - (Cons - (^ $V $X) $Edges) $V - (Cons $X $Neibs) $RestEdges) - ( (set-det) (do-group $Edges $V $Neibs $RestEdges))) -; + (= (do-group (Cons $Vertex $Vertices) $EdgeSet (Cons (- $Vertex $Neibs) $G)) + (do-group $EdgeSet $Vertex $Neibs $RestEdges) + (do-group $Vertices $RestEdges $G)) - (= - (do_group $Edges $_ () $Edges) True) -; + (= (do-group (Cons (^ $V $X) $Edges) $V (Cons $X $Neibs) $RestEdges) + (set-det) + (do-group $Edges $V $Neibs $RestEdges)) + (= (do_group $Edges $_ () $Edges) True) diff --git a/metagame/learning/paths.metta b/metagame/learning/paths.metta index a4cff3c..7925de5 100644 --- a/metagame/learning/paths.metta +++ b/metagame/learning/paths.metta @@ -1,293 +1,201 @@ +; (convert_to_metta_file paths $_17564 metagame/learning/paths.pl metagame/learning/paths.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; paths.pl - (= - (path-dist $Piece $Player $SqF $SqT 0 0) + (= (path-dist $Piece $Player $SqF $SqT 0 0) (set-det)) -; - - (= - (path-dist $Piece $Player $SqF $SqT $Max $N) - ( (reaches $Piece $Player $SqF $SqT $In) (path-dist $Piece $Player $SqF $SqF 0 $S))) -; - - (= - (path-dist $Piece $Player $SqF $SqT $N $S) - ( (reaches $Piece $Player $SqF $Sq1 $S) - (path-dist $Piece $Player $Sq1 $SqT $N1 $S) - (is $N - (+ $N1 1)))) -; - + (= (path-dist $Piece $Player $SqF $SqT $Max $N) + (reaches $Piece $Player $SqF $SqT $In) + (path-dist $Piece $Player $SqF $SqF 0 $S)) + (= (path-dist $Piece $Player $SqF $SqT $N $S) + (reaches $Piece $Player $SqF $Sq1 $S) + (path-dist $Piece $Player $Sq1 $SqT $N1 $S) + (is $N + (+ $N1 1))) ; -; - +; ; PATH_DIST(Type,Player,SqF,SqT,Dist,Max,S0) ; -; - +; ; True if, in state , 's piece of could reach SqT from SqF on ; -; - +; ; current board in moves, each of which uses either a moving or ; -; - +; ; capturing power, where <= . ; -; - +; ; either a piece_type or piece_struct [king or ; -; - - - (= - (path-dist $Type $Player $SqF $SqT $Dist $Max $S0) - ( (det-if-then-else - (piece-struct $Type $T $Player) - (= $Piece $Type) - (piece-struct $Piece $Type $Player)) - (put-control $Player $S0 $S) - (path-dist0 $Piece $Player $SqF $SqT $Dist $Max $S) - (tracing-path-format squares "<~p>: ~p -> ~p in ~p moves~n" - (:: $Piece $SqF $SqT $Dist)))) -; +; ; piece(king,player)]. + (= (path-dist $Type $Player $SqF $SqT $Dist $Max $S0) + (det-if-then-else + (piece-struct $Type $T $Player) + (= $Piece $Type) + (piece-struct $Piece $Type $Player)) + (put-control $Player $S0 $S) + (path-dist0 $Piece $Player $SqF $SqT $Dist $Max $S) + (tracing-path-format squares "<~p>: ~p -> ~p in ~p moves~n" + (:: $Piece $SqF $SqT $Dist))) - (= - (path-dist0 $Piece $Player $SqF $SqT $N $Max $S) - ( (path-dist1 $Piece $Player $SqF $SqT $N $Max $S) (> $N 0))) -; + (= (path-dist0 $Piece $Player $SqF $SqT $N $Max $S) + (path-dist1 $Piece $Player $SqF $SqT $N $Max $S) + (> $N 0)) + (= (path_dist1 $Piece $Player $SqF $SqF 0 $Left $S) True) + (= (path-dist1 $Piece $Player $SqF $SqT $N $Max $S) + (> $Max 0) + (\== $SqF $SqT) + (reaches $Piece $Player $SqF $Sq1 $S) + (is $Max1 + (- $Max 1)) + (path-dist1 $Piece $Player $Sq1 $SqT $N1 $Max1 $S) + (is $N + (+ $N1 1))) - (= - (path_dist1 $Piece $Player $SqF $SqF 0 $Left $S) True) -; - (= - (path-dist1 $Piece $Player $SqF $SqT $N $Max $S) - ( (> $Max 0) - (\== $SqF $SqT) - (reaches $Piece $Player $SqF $Sq1 $S) - (is $Max1 - (- $Max 1)) - (path-dist1 $Piece $Player $Sq1 $SqT $N1 $Max1 $S) - (is $N - (+ $N1 1)))) -; - - - - - (= - (new-empty-state $S) - ( (new-state $S1) (make-empty-board $S1 $S))) -; + (= (new-empty-state $S) + (new-state $S1) + (make-empty-board $S1 $S)) - (= - (new-state-of-type empty $S) + (= (new-state-of-type empty $S) (new-empty-state $S)) -; - - (= - (new-state-of-type any $S) + (= (new-state-of-type any $S) (new-state $S)) -; + (= (piece-moves-empty $Piece $Sq $SqT) + (new-empty-state $State) + (piece-moves $Piece $Sq $SqT $State)) - (= - (piece-moves-empty $Piece $Sq $SqT) - ( (new-empty-state $State) (piece-moves $Piece $Sq $SqT $State))) -; + (= (piece-moves-any $Piece $Sq $SqT) + (new-state $State) + (piece-moves $Piece $Sq $SqT $State)) - (= - (piece-moves-any $Piece $Sq $SqT) - ( (new-state $State) (piece-moves $Piece $Sq $SqT $State))) -; - + (= (piece-moves $Piece $Sq $SqT $State) + (board-square $Sq) + (piece-index $Piece $_) + (moves $Piece $Player $Sq $SqT $State) + (tracing-path-format moves "<~p>: ~p -> ~p~n" + (:: $Piece $Sq $SqT))) - (= - (piece-moves $Piece $Sq $SqT $State) - ( (board-square $Sq) - (piece-index $Piece $_) - (moves $Piece $Player $Sq $SqT $State) - (tracing-path-format moves "<~p>: ~p -> ~p~n" - (:: $Piece $Sq $SqT)))) -; - - - - (= - (piece-move $Piece $Sq $SqT $MoveType $StateType) - ( (new-state-of-type $StateType $S) (piece-move-for-type $MoveType $Piece $Sq $SqT $S))) -; - + (= (piece-move $Piece $Sq $SqT $MoveType $StateType) + (new-state-of-type $StateType $S) + (piece-move-for-type $MoveType $Piece $Sq $SqT $S)) ; -; - +; Hacked the put_control to get the right definitions. ; -; - - - (= - (piece-move-for-type $MoveType $Piece $Sq $SqT $S) - ( (board-square $Sq) - (piece-index $Piece $_) - (owns $Piece $Player) - (put-control $Player $S $S1) - (move-for-type $MoveType $Piece $Sq $SqT $S1))) -; +; This should be fixed in legal. + (= (piece-move-for-type $MoveType $Piece $Sq $SqT $S) + (board-square $Sq) + (piece-index $Piece $_) + (owns $Piece $Player) + (put-control $Player $S $S1) + (move-for-type $MoveType $Piece $Sq $SqT $S1)) - (= - (move-for-type moving $Piece $Sq $SqT $State) - ( (moves $Piece $Player $Sq $SqT $State) (tracing-path-format moves "<~p>: ~p -> ~p~n" (:: $Piece $Sq $SqT)))) -; - - (= - (move-for-type capturing $Piece $Sq $SqT $State) - ( (captures $Piece $Player $Sq $SqT $State) (tracing-path-format moves "<~p>: ~p -> ~p~n" (:: $Piece $Sq $SqT)))) -; - - (= - (move-for-type capturing-specific $Piece $Sq $SqT $State) - ( (captures $Piece $Player $Sq $SqT $Effect $Captured $State) (tracing-path-format moves "<~p>: ~p -> ~p x ~p (~p)~n" (:: $Piece $Sq $SqT $Captured $Effect)))) -; - + (= (move-for-type moving $Piece $Sq $SqT $State) + (moves $Piece $Player $Sq $SqT $State) + (tracing-path-format moves "<~p>: ~p -> ~p~n" + (:: $Piece $Sq $SqT))) + (= (move-for-type capturing $Piece $Sq $SqT $State) + (captures $Piece $Player $Sq $SqT $State) + (tracing-path-format moves "<~p>: ~p -> ~p~n" + (:: $Piece $Sq $SqT))) + (= (move-for-type capturing-specific $Piece $Sq $SqT $State) + (captures $Piece $Player $Sq $SqT $Effect $Captured $State) + (tracing-path-format moves "<~p>: ~p -> ~p x ~p (~p)~n" + (:: $Piece $Sq $SqT $Captured $Effect))) ; -; - +; ================================================================================ ; -; - +; tracing execution of path-distance routines ; -; - +; ================================================================================ ; -; - +; The following tracing modules are used in this file: ; -; - +; squares: info on squares evaluation ; -; - +; mobility: info on piece mobility ; -; - +; Each module can be set on/off, using set_path_verbosity (see below), or ; -; - +; using trace_path_. ; ; - ; -; - +; All can be turned off with silent_path. !(my-ensure-loaded (library tracing)) -; - - (= - (tracing-path $Type $Call) + (= (tracing-path $Type $Call) (det-if-then-else (tracing (path $Type)) (call $Call) True)) -; - ; -; - +; Might cause trouble later when want to use streams also. - (= - (tracing-path-format $Type $String $Args) + (= (tracing-path-format $Type $String $Args) (det-if-then-else (tracing (path $Type)) (format $String $Args) True)) -; - - (= - (tracing-path-timing $Type $Call) + (= (tracing-path-timing $Type $Call) (trace-timing (path $Type) $Call)) -; - - (= - (set-path-verbosity $Level $Status) + (= (set-path-verbosity $Level $Status) (set-tracing (path $Level) $Status)) -; - - (= - (silent-path) - ( (set-path-verbosity ordering off) - (set-path-verbosity value off) - (set-path-verbosity resources off) - (set-path-verbosity timing off) - (set-path-verbosity iteration off))) -; + (= (silent-path) + (set-path-verbosity ordering off) + (set-path-verbosity value off) + (set-path-verbosity resources off) + (set-path-verbosity timing off) + (set-path-verbosity iteration off)) + (= (trace-path-squares) + (set-path-verbosity squares on)) - (= - (trace-path-squares) - (set-path-verbosity squares on)) -; - - - (= - (trace-path-ordering) - (set-path-verbosity ordering on)) -; - + (= (trace-path-ordering) + (set-path-verbosity ordering on)) !(silent-path *) -; - ; -; +; :- trace_path_squares. - -; - +; /*========================================================================= In^Out^( on(King,square(5,1),In), moves(King,player,square(2,4),SqT,In), print(SqT), fail ). In^Out^( on(King,square(5,1),In), moves(King,player,square(2,8),SqT,In), print(SqT), fail ). In^Out^( on(King,square(5,1),In), captures(King,player,square(2,8),SqT,In), print(SqT), fail ). In^Out^( on(King,square(5,1),In), reaches(King,player,square(2,8),SqT,In), print(SqT), fail ). In^Out^( on(King,square(5,1),In), reaches(King,player,square(2,7),SqT,In), print(SqT), fail ). In^Out^( on(King,square(5,1),In), reaches(King,player,square(2,7),Sq1,In), reaches(King,player,Sq1,SqT,In), print(SqT), fail ). In^Out^( on(King,square(5,1),In), reaches(King,player,square(2,7),Sq1,In), reaches(King,player,Sq1,Sq2,In), reaches(King,player,Sq1,Sq3,In), on(Piece,square(4,8),In), on(Piece,Sq3,In), print(Sq3), fail ). In^Out^( on(Piece,player,Sq,In), reaches(Piece,player,Sq,Sq1,In), reaches(Piece,player,Sq1,Sq2,In), reaches(Piece,player,Sq2,Sq3,In), on(PieceK,Sq3,In), piece_struct_name(PieceK,king), print(Sq3), write(:), print(Piece), print(from), print(Sq), nl, fail ). In^Out^( on(Piece,player,Sq,In), reaches(Piece,player,Sq,SqT,In), format("<~p>: ~p -> ~p in ~p moves~n",[Piece,Sq,SqT,1]), fail ). In^Out^( on(Piece,player,Sq,In), moves(Piece,player,Sq,SqT,In), format("<~p>: ~p -> ~p in ~p moves~n",[Piece,Sq,SqT,1]), fail ). In^Out^( on(Piece,player,Sq,In), captures(Piece,player,Sq,SqT,In), format("<~p>: ~p -> ~p in ~p moves~n",[Piece,Sq,SqT,1]), fail ). In^Out^( path_dist(queen,player,square(4,1),SqT,Dist,2,In), fail ). In^Out^( on(piece(king,opponent),SqT,In), on(Piece,player,Square,In), path_dist(Piece,player,Square,SqT,Dist,3,In) ). In^Out^( on(Piece,player,Sq,In), reaches(Piece,player,Sq,Sq1,In), reaches(Piece,player,Sq1,Sq2,In), reaches(Piece,player,Sq2,Sq3,In), on(PieceK,Sq3,In), piece_struct_name(PieceK,king), print(Sq3), write(:), print(Piece), print(from), print(Sq), nl, fail ). checkpoint(e3,In), on(piece(king,opponent),SqT,In), on(Piece,player,Square,In), path_dist(Piece,player,Square,SqT,Dist,3,In). ==================================================*/ diff --git a/metagame/learning/possess.metta b/metagame/learning/possess.metta index 68b882f..408236d 100644 --- a/metagame/learning/possess.metta +++ b/metagame/learning/possess.metta @@ -1,230 +1,159 @@ +; (convert_to_metta_file possess $_161576 metagame/learning/possess.pl metagame/learning/possess.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; possess.pl ; ; - ; -; - +; A possessed piece gets some amount of value based on ; -; - +; the value of each square it could possibly be placed ; -; - +; on. ; -; - +; Here we divide the potential value by the size of the board, ; -; - +; to roughly average the contributions from each square. ; -; - +; One consequence of this is that having a piece in hand is never ; -; - +; better than having it on the board on its best square. ; -; +; This is incorrect, but a start anyway. + (= (possess-value $Piece $Player (advice possess $Sq $Value) $Position $Tables) + (total-square-count $Total) + (empty $Sq $Position) + (local-evaluation $Piece $Sq $LVal $Position $Tables) + (is $Value + (/ $LVal $Total))) - (= - (possess-value $Piece $Player - (advice possess $Sq $Value) $Position $Tables) - ( (total-square-count $Total) - (empty $Sq $Position) - (local-evaluation $Piece $Sq $LVal $Position $Tables) - (is $Value - (/ $LVal $Total)))) -; + (= (initprom-value (advice initprom (best $OldPiece $NewPiece) $Value) $Position $Tables) + (opponent-promotes $OldPiece $Sq $Position) + (control $Player $Position) + (best-choice $OldPiece $Player $Sq $NewPiece $Value $Position $Tables)) - (= - (initprom-value - (advice initprom - (best $OldPiece $NewPiece) $Value) $Position $Tables) - ( (opponent-promotes $OldPiece $Sq $Position) - (control $Player $Position) - (best-choice $OldPiece $Player $Sq $NewPiece $Value $Position $Tables))) -; + (= (best-choice $OldPiece $Player $Sq $NewPiece $Value $Position $Tables) + (findall + (- $NewVal $NewPiece) + (initprom-value $OldPiece $Sq $Player $NewPiece $NewVal $Position $Tables) $Pairs) + (best-player-choice $Player $Pairs $NewPiece $Value)) - - (= - (best-choice $OldPiece $Player $Sq $NewPiece $Value $Position $Tables) - ( (findall - (- $NewVal $NewPiece) - (initprom-value $OldPiece $Sq $Player $NewPiece $NewVal $Position $Tables) $Pairs) (best-player-choice $Player $Pairs $NewPiece $Value))) -; - - - - (= - (best-player-choice $Player $Pairs $NewPiece $Value) - ( (keysort-for-player $Player $Pairs $Ordered) (= $Ordered (Cons (- $Value $NewPiece) $Rest)))) -; - + (= (best-player-choice $Player $Pairs $NewPiece $Value) + (keysort-for-player $Player $Pairs $Ordered) + (= $Ordered + (Cons + (- $Value $NewPiece) $Rest))) ; -; - +; Pairs is some list [v1-item1,...]. Ordered is a sorted ; -; - +; version, such that first new v1 is best choice for Player ; -; - - - (= - (keysort-for-player $Player $Pairs $Ordered) - ( (keysort $Pairs $Sorted) (reverse-for-player $Player $Sorted $Ordered))) -; +; (min if black, max if white). + (= (keysort-for-player $Player $Pairs $Ordered) + (keysort $Pairs $Sorted) + (reverse-for-player $Player $Sorted $Ordered)) ; -; - +; The sorted list gives the minimum node first. ; -; - +; We assume the black player is trying to minimize the evaluation, ; -; - +; so he just chooses this first (lowest) choice. ; -; - - - (= - (reverse_for_player opponent $Sorted $Sorted) True) -; +; The white player is maximizing, so he will choose the last (highest) choice. - (= - (reverse-for-player player $Sorted $Ordered) - (reverse $Sorted $Ordered)) -; - + (= (reverse_for_player opponent $Sorted $Sorted) True) + (= (reverse-for-player player $Sorted $Ordered) + (reverse $Sorted $Ordered)) ; -; - +; Init_promote_option is defined as part of the theory, legal.pl ; ; - - (= - (initprom-value $OldPiece $Sq $Player $NewPiece $NewVal $Position $Tables) - ( (init-promote-option $OldPiece $Player $NewPiece $Position) (local-evaluation $NewPiece $Sq $NewVal $Position $Tables))) -; - + (= (initprom-value $OldPiece $Sq $Player $NewPiece $NewVal $Position $Tables) + (init-promote-option $OldPiece $Player $NewPiece $Position) + (local-evaluation $NewPiece $Sq $NewVal $Position $Tables)) ; -; - +; ================================================================================ ; -; - +; Routines used to estimate effect of possessing a piece when ; -; - +; thinking about threats. ; -; - +; ================================================================================ ; -; - +; Predict a piece is N times as valuable possessed as it would be ; -; - +; on the board. ; -; - +; possess_offset(2). ; -; - +; Actually there is more to it than we use here. If we possess-capture ; -; - +; opponent's piece, it is - (= - (possess-offset $N) - (parameter possess-offset $N)) -; - + (= (possess-offset $N) + (parameter possess-offset $N)) - (= - (favor-possess $Player $Val1 $Value $Position) - ( (possess-offset $Offset) (is $Value (* $Val1 $Offset)))) -; - + (= (favor-possess $Player $Val1 $Value $Position) + (possess-offset $Offset) + (is $Value + (* $Val1 $Offset))) ; -; - +; ESTIMATE_POSSESS_VALUE(+Possessor,+Piece,+LVal,-EVal,+Position,+Tables). ; -; - +; EValue is the estimated value accrued to Possessor if he possesses ; -; - +; Piece, given that in Position, Piece was worth LVal. ; -; - +; We would like to use possess_value above, but that is too expensive ; -; - +; to use every time we need this estimate. ; ; - ; -; - +; Thus: if Possessor already owns piece, then say it is just worth the ; -; - +; original value it had on the board. ; -; - +; If not, there will be a change of possession, so say it is worth the ; -; - +; opposite of its current value. ; -; - +; We could use static value, value of special arrival squares, etc. ; ; - - (= - (estimate-possess-value $Possessor $Piece $LVal $EVal $Position $Tables) + (= (estimate-possess-value $Possessor $Piece $LVal $EVal $Position $Tables) (det-if-then-else (owns $Piece $Possessor) (= $EVal $LVal) (is $EVal - (- $LVal)))) -; - + (- $LVal)))) diff --git a/metagame/learning/potent.metta b/metagame/learning/potent.metta index 735d49f..a281ddf 100644 --- a/metagame/learning/potent.metta +++ b/metagame/learning/potent.metta @@ -1,204 +1,144 @@ +; (convert_to_metta_file potent $_272126 metagame/learning/potent.pl metagame/learning/potent.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ================================================================================ ; -; - +; Global Potent Threats ; -; - +; ================================================================================ ; -; - +; The global value of the player to move having potent threats is the ; -; - +; maximum of the value of all potent threats he has. ; -; - +; We could add value for the other player, but not nearly as clear how ; -; +; to determine this. - - (= - (pthreat $Player $Value $Pos $Tables) - ( (control $Player $Pos) - (potent-threats $Player $Evaled $Pos $Tables) - (pair-list $Vals $Threats $Evaled) - (max-for-player $Player $Vals $Value))) -; + (= (pthreat $Player $Value $Pos $Tables) + (control $Player $Pos) + (potent-threats $Player $Evaled $Pos $Tables) + (pair-list $Vals $Threats $Evaled) + (max-for-player $Player $Vals $Value)) - - (= - (potent-threats $Player $Evaled $Pos $Tables) + (= (potent-threats $Player $Evaled $Pos $Tables) (findall (- $Val $Threat) (, (potent-threat-mover $Player $Piece $Square $SqT $Victim $SqV $Effect $Val $Pos $Tables) (= $Threat (potent $Piece $Square $SqT $Victim $SqV $Effect $Val))) $Evaled)) -; - ; -; - +; ================================================================================ ; -; - +; Local Potent Threats ; -; - +; ================================================================================ ; -; - +; The value of having a potent threat on a piece is the amount which would be increased ; -; - +; for the threatener if that piece disappeared (or 0 if that is negative). ; -; - +; Perhaps discounted by an offset based on whether the threat can be executed now or ; -; - +; if the victim gets a chance to defend. ; -; - +; Threat is potent for mover if: ; -; - +; 1. Capturing target (under the effect) has favorable value (V) for mover, and ; -; - +; 2. Target undefended by non-mover (then V is net threat value) or ; -; - +; 3. Target defended, but TargV (V) - AttackV (on current square) > 0. ; -; - +; (then this diff is net value). ; -; - +; We are at present ignoring the effects (besides removal) that happen ; -; - - +; if opponent has a defense against our attacker. - (= - (potent-threat-mover $Piece $Square $PieceV $SqV $Value $Pos $Tables) - ( (blank-state-if $Pos) - (find-advice-tables-if $Tables) - (add-capturing-table-if $Pos $Tables) - (control $Player $Pos) - (potent-threat-mover $Player $Piece $Square $SqT $PieceV $SqV $Effect $Value $Pos $Tables))) -; + (= (potent-threat-mover $Piece $Square $PieceV $SqV $Value $Pos $Tables) + (blank-state-if $Pos) + (find-advice-tables-if $Tables) + (add-capturing-table-if $Pos $Tables) + (control $Player $Pos) + (potent-threat-mover $Player $Piece $Square $SqT $PieceV $SqV $Effect $Value $Pos $Tables)) +; ; ensures mover has threat ; on(Piece,Player,Square,Pos), ; -; - +; Weigh-by-effect ensures favorable to capture. ; -; - - (= - (potent-threat-mover $Player $Piece $Square $SqT $Victim $SqV $Effect $Value $S $Tables) - ( (capture-threat $Piece $Player $Square $SqT $Victim $SqV $Effect $Tables) - (effect-threat-evaluation $Effect $Player $Victim $SqV $Val $S $Tables) - (potency-value $Player $Piece $Square $SqT $Victim $SqV $Val $Value $S $Tables) - (tracing-anal-format pthreat "<~p>: ~p -> ~p x ~p ~p (~p) [~p]~n" - (:: $Piece $Square $SqT $Victim $SqV $Effect $Value)))) -; - +; Assumes Player is in control. + (= (potent-threat-mover $Player $Piece $Square $SqT $Victim $SqV $Effect $Value $S $Tables) + (capture-threat $Piece $Player $Square $SqT $Victim $SqV $Effect $Tables) + (effect-threat-evaluation $Effect $Player $Victim $SqV $Val $S $Tables) + (potency-value $Player $Piece $Square $SqT $Victim $SqV $Val $Value $S $Tables) + (tracing-anal-format pthreat "<~p>: ~p -> ~p x ~p ~p (~p) [~p]~n" + (:: $Piece $Square $SqT $Victim $SqV $Effect $Value))) ; -; - +; POTENCY_VALUE(Player,Piece,Square,SqT,Victim,SqV,ValV,Value,S,Tables) ; ; - ; -; - +; ValV is the value for capturing the victim if undefended. ; -; - +; If it is defended, player gets the net difference between the value ; -; - +; of the capture, and losing his own piece. If he wants to lose his piece ; -; - +; however, it is as if the piece was undefended anyway! ; ; - ; -; - +; Should really use effect_threat_evaluation, since opponent gets value for capturing ; -; - +; us back based on the effect of his recapture, given where our piece will be now. ; -; - +; For example, suppose we can remove-capture his bishop with our night, but he ; -; - +; defends it with a possess-capture piece. Then it would presently look like ; -; - +; we have a real threat (bishop-night value), but actually we don't, as this is ; -; - +; just a small increment for us, while he winds up possessing a night ; -; - +; after the transaction, putting him at least a piece up! ; ; - ; -; - +; For the moment, just assume he wants to do it as long as the effect isn't to ; -; - +; give it back to us. ; ; - ; -; - +; If use this, don't need this min-for-player ; -; - +; business, as it won't even be seen as a defense unless the enemy wins ; -; - +; something for recapturing us. ; ; - - (= - (potency-value $Player $Piece $Square $SqT $Victim $SqV $ValV $Value $S $Tables) + (= (potency-value $Player $Piece $Square $SqT $Victim $SqV $ValV $Value $S $Tables) (det-if-then-else (, (defended $Player $Piece $Square $SqT $Victim $SqV $Effect $S $Tables) @@ -212,300 +152,218 @@ (:: $ValV $Net) $Value) (favorable-to-owner $Player $Value)) (= $Value $ValV))) -; - ; -; - +; DEFENDED(Player,PieceA,SqA,SqT,PieceV,SqV,Effect,S,_Tables) ; -; - +; General routine to check if some considered attack is defended. ; -; - +; The attack PieceA @ SqA -> SqT x PieceV @ SqV must be known applicable already. ; -; - +; This threat is defended if there is some defender which could capture the ; -; - +; attacker if this considered capture were executed. ; ; - - (= - (defended $Player $PieceA $SqA $SqT $PieceV $SqV $Effect $S $Tables) - ( (opposite-role $Player $Opp) - (do-capture $PieceA $SqA $SqT $PieceV $SqV $S $PosOut) - (on $PieceD $Opp $SqD $PosOut) - (target-capture $PieceD $SqD $PieceA $SqT $Capture $Movement $Dir $Effect $PosOut $Tables))) -; - + (= (defended $Player $PieceA $SqA $SqT $PieceV $SqV $Effect $S $Tables) + (opposite-role $Player $Opp) + (do-capture $PieceA $SqA $SqT $PieceV $SqV $S $PosOut) + (on $PieceD $Opp $SqD $PosOut) + (target-capture $PieceD $SqD $PieceA $SqT $Capture $Movement $Dir $Effect $PosOut $Tables)) ; -; - +; TARGET_CAPTURE(PieceA,SqA,PieceV,SqV,Capture,Movement,Dir,Effect,Pos,_Tables) ; -; - +; ============== ; ; - ; -; - +; When the target piece is known, it is easier to check whether an attacker can ; -; - +; actually capture it in the present position. First check if it is even potentially ; -; - +; possible (when the target is the right piece type, and in the right capture line). ; -; - +; If so, check that that capturing movement in that direction really works to create a capture. ; ; - ; -; - - - (= - (target-capture $PieceA $SqA $PieceV $SqV $Capture $Movement $Dir $Effect $Pos $Tables) - ( (owns $PieceA $Player) - (potential-capture $PieceA $SqA $PieceV $SqV $Capture $Movement $Dir $Effect $Pos $Tables) - (capturing-movement-for-piece $PieceA $SqA $SqT $Player $Dir $Movement $Capture $Captured $Pos) - (captured-piece $PieceV $SqV $Captured))) -; +; This is a general routine, and can be very useful. + (= (target-capture $PieceA $SqA $PieceV $SqV $Capture $Movement $Dir $Effect $Pos $Tables) + (owns $PieceA $Player) + (potential-capture $PieceA $SqA $PieceV $SqV $Capture $Movement $Dir $Effect $Pos $Tables) + (capturing-movement-for-piece $PieceA $SqA $SqT $Player $Dir $Movement $Capture $Captured $Pos) + (captured-piece $PieceV $SqV $Captured)) ; -; - +; We have a potential capture if: ; -; - +; The piece can capture victims of that type with some capture power. ; -; - +; The effect is not to give it right back to oppenent. ; -; - +; That capture power has some movement which is aligned with the target. ; ; - ; -; - +; Could take account of factors like min-ride, max-ride, hoppers, etc. - (= - (potential-capture $PieceA $SqA $PieceT $SqT $Effect $Pos $Tables) + (= (potential-capture $PieceA $SqA $PieceT $SqT $Effect $Pos $Tables) (potential-capture $PieceA $SqA $PieceT $SqT $Capture $Movement $Dir $Effect $Pos $Tables)) -; - - (= - (potential-capture $PieceA $SqA $PieceT $SqT $Capture $Movement $Dir $Effect $Pos $Tables) - ( (threat-piece-victim $PieceA $Player $PieceT $VPlayer $Effect $Capture) - (opposite-role $Player $VPlayer) - (capture-has-movement $Capture $Movement) - (movement-sym-dir $Movement $Dir) - (capture-aligned $Capture $Movement $SqA $SqT $Dir))) -; + (= (potential-capture $PieceA $SqA $PieceT $SqT $Capture $Movement $Dir $Effect $Pos $Tables) + (threat-piece-victim $PieceA $Player $PieceT $VPlayer $Effect $Capture) + (opposite-role $Player $VPlayer) + (capture-has-movement $Capture $Movement) + (movement-sym-dir $Movement $Dir) + (capture-aligned $Capture $Movement $SqA $SqT $Dir)) - - (= - (capture-aligned $Capture $Movement $SqA $SqT $Dir) - ( (capture-has-method $Capture $Method) (det-if-then (method-aligned $Method $Movement $SqA $SqT $Dir) True))) -; - + (= (capture-aligned $Capture $Movement $SqA $SqT $Dir) + (capture-has-method $Capture $Method) + (det-if-then + (method-aligned $Method $Movement $SqA $SqT $Dir) True)) ; -; - +; For retrieve method, the attacker can move in a dir ; -; - +; away from the target if the target is one leap behind. ; -; - +; For now ignore Movement, but could make use of movement ; -; - +; constraints as well. - (= - (method-aligned clobber $Movement $SqA $SqT $Dir) + (= (method-aligned clobber $Movement $SqA $SqT $Dir) (aligned $SqA $SqT $Dir)) -; - - (= - (method-aligned hop $Movement $SqA $SqT $Dir) + (= (method-aligned hop $Movement $SqA $SqT $Dir) (aligned $SqA $SqT $Dir)) -; - - (= - (method-aligned retrieve $Movement $SqA $SqT $Dir) + (= (method-aligned retrieve $Movement $SqA $SqT $Dir) (connected $SqT $SqA $Dir)) -; - ; -; - +; ALIGNED(S1,S2,Dir) ; ; - ; -; - +; True if S2 is on the direction vector DIR from S1, given the ; -; - +; current board size and types. ; -; - +; This would be more complicated if both axes could wraparound, but since we ; -; - +; know Y doesn't we just find the # leaps there, then check that moving that ; -; - +; many leaps with wrapping along X brings us back to X square. ; -; - +; This of course checks that there is an integer, not fractional, number of leaps. ; -; - +; For example: ; -; - +; On vertical cylinder 5x6 board: ; -; - +; aligned(square(2,2),square(1,1),dir(-1,-1)). ; -; - +; aligned(square(1,5),square(1,3),dir(-5,-2)). ; -; - +; aligned(square(1,2),square(5,1),dir(-1,-1)). ; -; - +; But not: ; -; - +; * aligned(square(2,2),square(3,3),dir(-1,-1)). ; ; - - (= - (aligned $S1 $S2 $Dir) - ( (square $S1 $Xf $Yf) - (square $S2 $Xt $Yt) - (direction $Dir $DX $DY) - (current-board-type $T) - (x-given-y-leaps $T $Yf $Yt $DY $Xf $Xt $DX))) -; - + (= (aligned $S1 $S2 $Dir) + (square $S1 $Xf $Yf) + (square $S2 $Xt $Yt) + (direction $Dir $DX $DY) + (current-board-type $T) + (x-given-y-leaps $T $Yf $Yt $DY $Xf $Xt $DX)) - (= - (x-given-y-leaps $T $Yf $Yt $DY $Xf $Xt $DX) - ( (is $DiffY - (- $Yt $Yf)) - (same-sign $DiffY $DY) + (= (x-given-y-leaps $T $Yf $Yt $DY $Xf $Xt $DX) + (is $DiffY + (- $Yt $Yf)) + (same-sign $DiffY $DY) + (det-if-then-else + (\== $DY 0) + (, + (is 0 + (mod $DiffY + (abs $DY))) + (is $Leaps + (// $DiffY $DY)) + (is $XNew + (+ $Xf + (* $Leaps $DX))) + (align-for-type $T $XNew $Xt)) (det-if-then-else - (\== $DY 0) + (\== $T vertical-cylinder) (, + (is $DiffX + (- $Xt $Xf)) + (same-sign $DiffX $DX) (is 0 - (mod $DiffY - (abs $DY))) - (is $Leaps - (// $DiffY $DY)) - (is $XNew - (+ $Xf - (* $Leaps $DX))) - (align-for-type $T $XNew $Xt)) - (det-if-then-else - (\== $T vertical-cylinder) - (, - (is $DiffX - (- $Xt $Xf)) - (same-sign $DiffX $DX) - (is 0 - (mod - (- $Xt $Xf) - (abs $DX)))) - (, - (valid-max-dir $DX 0 $Max1) - (is $Max - (abs $Max1)) - (some-reaches $Max $T $DX $Xf $Xt)))))) -; - - - - (= - (some-reaches $Leaps $T $DX $Xf $Xt) - ( (> $Leaps 0) - (is $XNew - (+ $Xf - (* $Leaps $DX))) - (align-for-type $T $XNew $Xt))) -; + (mod + (- $Xt $Xf) + (abs $DX)))) + (, + (valid-max-dir $DX 0 $Max1) + (is $Max + (abs $Max1)) + (some-reaches $Max $T $DX $Xf $Xt))))) - (= - (some-reaches $Leaps $T $DX $Xf $Xt) - ( (> $Leaps 1) - (is $L1 - (- $Leaps 1)) - (some-reaches $L1 $T $DX $Xf $Xt))) -; + (= (some-reaches $Leaps $T $DX $Xf $Xt) + (> $Leaps 0) + (is $XNew + (+ $Xf + (* $Leaps $DX))) + (align-for-type $T $XNew $Xt)) + (= (some-reaches $Leaps $T $DX $Xf $Xt) + (> $Leaps 1) + (is $L1 + (- $Leaps 1)) + (some-reaches $L1 $T $DX $Xf $Xt)) - (= - (y-leaps $Yf $Yt $DY $Leaps) - ( (is $DiffY - (- $Yt $Yf)) - (same-sign $DiffY $DY) - (is 0 - (mod $DiffY - (abs $DY))) - (is $Leaps - (// $DiffY $DY)))) -; - + (= (y-leaps $Yf $Yt $DY $Leaps) + (is $DiffY + (- $Yt $Yf)) + (same-sign $DiffY $DY) + (is 0 + (mod $DiffY + (abs $DY))) + (is $Leaps + (// $DiffY $DY))) - (= - (align_for_type planar $X $X) True) -; - - (= - (align-for-type vertical-cylinder $X1 $X) - ( (current-board-size $XN $YN) (is $X (+ (mod (- (+ $X1 $XN) 1) $XN) 1)))) -; - + (= (align_for_type planar $X $X) True) + (= (align-for-type vertical-cylinder $X1 $X) + (current-board-size $XN $YN) + (is $X + (+ + (mod + (- + (+ $X1 $XN) 1) $XN) 1))) - (= - (sign $X $Sign) + (= (sign $X $Sign) (det-if-then-else (< $X 0) (= $Sign -1) @@ -514,35 +372,26 @@ (= $Sign 1) (det-if-then otherwise (= $Sign 0))))) -; - - (= - (same-sign $X1 $X2) - ( (sign $X1 $S) (sign $X2 $S))) -; + (= (same-sign $X1 $X2) + (sign $X1 $S) + (sign $X2 $S)) + (= (test-potential-capture $PieceA $SqA $PieceT $SqT $Capture $Movement $Dir $Effect $S $Tables) + (checkpoint init $S) + (on $PieceA $_ $SqA $S) + (on $PieceT $_ $SqT $S) + (potential-capture $PieceA $SqA $PieceT $SqT $Capture $Movement $Dir $Effect $Pos $Tables)) - (= - (test-potential-capture $PieceA $SqA $PieceT $SqT $Capture $Movement $Dir $Effect $S $Tables) - ( (checkpoint init $S) - (on $PieceA $_ $SqA $S) - (on $PieceT $_ $SqT $S) - (potential-capture $PieceA $SqA $PieceT $SqT $Capture $Movement $Dir $Effect $Pos $Tables))) -; - - - - (= - (test-target-capture $PieceA $SqA $PieceV $SqV $Capture $Movement $Dir $Effect $S $Tables) - ( (on $PieceA $_ $SqA $S) - (on $PieceV $_ $SqV $S) - (target-capture $PieceA $SqA $PieceV $SqV $Capture $Movement $Dir $Effect $S $Tables))) -; + (= (test-target-capture $PieceA $SqA $PieceV $SqV $Capture $Movement $Dir $Effect $S $Tables) + (on $PieceA $_ $SqA $S) + (on $PieceV $_ $SqV $S) + (target-capture $PieceA $SqA $PieceV $SqV $Capture $Movement $Dir $Effect $S $Tables)) +; ; checkpoint(init,S), diff --git a/metagame/learning/prom.metta b/metagame/learning/prom.metta index 6cdae91..72a33da 100644 --- a/metagame/learning/prom.metta +++ b/metagame/learning/prom.metta @@ -1,958 +1,692 @@ +; (convert_to_metta_file prom $_490622 metagame/learning/prom.pl metagame/learning/prom.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; prom.pl ; -; - +; PROMOTION Strategy ; -; - +; A portion of a piece's value on a square is its possibility ; -; - +; to move and promote into something else. ; -; - +; The value comes from the value derived by getting that promoted piece ; -; - +; on the promotion square, and then deriving whatever intrinsic ; -; - +; value such a piece would have there. ; -; - +; However, we don't actually get the intrinsic value immediately. ; -; - +; 1. Clear the promotion square (and a path to it, perhaps) ; -; - +; 2. Move the piece to the promotion square. ; -; - +; 3. Execute a number of moves in promotion region to create the ; -; - +; desired promoted piece (assuming we could do each in just ; -; - +; 1 move for now). ; ; - ; -; - +; Note that as promoting is usually optional, we should discard those ; -; - +; possibilities which would give the promoting player negative utility. ; ; - ; -; - +; The value of a piece to be promoted is the max value of anything we might ; -; - +; promote it into. This avoids the situation where we don't promote a piece ; -; - +; because we prefer the option of all possible promotions to any one, but then ; -; - +; we get a chess pawn sitting on the 7th rank enjoying its options! ; ; - ; -; - +; For the moment, we may ignore the possibility to promote into the opponent's ; -; - +; on a square which would win us the game, and instead consider only those ; -; - +; promotions which keep the piece in our control. ; -; - +; ==> No, now we even consider promoting to opponent's piece if that gives us ; -; - +; better value. ; ; - ; -; - +; Also, we choose the most accessible square, but independent of choice of ; -; - +; promotion piece. Thus, it may not be the best square for some piece which ; -; - +; would be our best choice piece on some other square. ; ; - - (= - (prom-value $Piece $Sq $SqT $Value $Pos $Tables) - ( (owns $Piece $Player) - (useful-promotes $Piece $Player $Tables) - (focussed-promsq-cost $Piece $Player $Sq $SqT $PathCost $Pos $Tables) - (best-promotion-choice-value $Piece $Player $SqT $PathCost $PieceT $Value $Pos $Tables))) -; - - + (= (prom-value $Piece $Sq $SqT $Value $Pos $Tables) + (owns $Piece $Player) + (useful-promotes $Piece $Player $Tables) + (focussed-promsq-cost $Piece $Player $Sq $SqT $PathCost $Pos $Tables) + (best-promotion-choice-value $Piece $Player $SqT $PathCost $PieceT $Value $Pos $Tables)) - (= - (best-promotion-choice-value $Piece $Player $SqT $PathCost $BestPiece $BestValue $Pos $Tables) - ( (findall - (- $Value $PieceT) - (promotion-choice-value $Piece $Player $SqT $PathCost $PieceT $Value $Pos $Tables) $Pairs) (best-player-choice $Player $Pairs $BestPiece $BestValue))) -; - + (= (best-promotion-choice-value $Piece $Player $SqT $PathCost $BestPiece $BestValue $Pos $Tables) + (findall + (- $Value $PieceT) + (promotion-choice-value $Piece $Player $SqT $PathCost $PieceT $Value $Pos $Tables) $Pairs) + (best-player-choice $Player $Pairs $BestPiece $BestValue)) - (= - (promotion-choice-value $Piece $Player $SqT $PathCost $PieceT $Value $Pos $Tables) - ( (piece-player-prom-distance $Piece $Player $PieceT $PromDist $Tables) - (\== $PieceT $Piece) - (intrinsic-value $PieceT $SqT $IVal $Pos $Tables) - (prom-likelihood $PromDist $PathCost $Prob) - (reasonable-likelihood $Prob) - (expected-value $Prob $IVal $Value) - (favorable-to-owner $Player $Value))) -; + (= (promotion-choice-value $Piece $Player $SqT $PathCost $PieceT $Value $Pos $Tables) + (piece-player-prom-distance $Piece $Player $PieceT $PromDist $Tables) + (\== $PieceT $Piece) + (intrinsic-value $PieceT $SqT $IVal $Pos $Tables) + (prom-likelihood $PromDist $PathCost $Prob) + (reasonable-likelihood $Prob) + (expected-value $Prob $IVal $Value) + (favorable-to-owner $Player $Value)) +; ; Ie PromDist > 0 - (= - (useful-promotes $Piece $Player $Tables) + (= (useful-promotes $Piece $Player $Tables) (det-if-then - (player-safe-new-prom $Piece $Player $PieceT $SqT $Tables) True)) -; - + (player-safe-new-prom $Piece $Player $PieceT $SqT $Tables) True)) ; -; - +; Player can promote Piece to PieceT on SqT. ; -; - - - (= - (player-safe-new-prom $Piece $Player $PieceT $SqT $Tables) - ( (piece-player-promotion $Piece $Player $PieceT $Tables) - (\== $Piece $PieceT) - (opposite-role $Player $Opp) - (player-promotion-square $Player $SqT) - (not (goal-square $PieceT $SqT $Opp $_)))) -; +; Backtracks over all SqT. + (= (player-safe-new-prom $Piece $Player $PieceT $SqT $Tables) + (piece-player-promotion $Piece $Player $PieceT $Tables) + (\== $Piece $PieceT) + (opposite-role $Player $Opp) + (player-promotion-square $Player $SqT) + (not (goal-square $PieceT $SqT $Opp $_))) ; -; - +; Of the nearest prom squares, choose the one most accessible ; -; - +; in the current position. ; -; - +; This is the one with the lowest cost to clear it. ; ; - ; -; - +; [ Technically we shouldn't choose among only the nearest, ; -; - +; as one may be farther but empty, and this would be preferable. ; -; - +; However, we don't want to search through all of promotion region ; -; +; and do this comparison if we can avoid it. ] - - (= - (focussed-promsq-cost $Piece $Player $Sq $SqT $Cost $Pos $Tables) - ( (square-index $Sq $SqI) - (piece-index $Piece $PieceI) - (square-piece-psqs $SqI $PieceI $SqTIs $Dist $Tables) - (cheapest-destination $Piece $Player $Sq $SqTIs $Dist $SqT $Cost $Pos $Tables))) -; - + (= (focussed-promsq-cost $Piece $Player $Sq $SqT $Cost $Pos $Tables) + (square-index $Sq $SqI) + (piece-index $Piece $PieceI) + (square-piece-psqs $SqI $PieceI $SqTIs $Dist $Tables) + (cheapest-destination $Piece $Player $Sq $SqTIs $Dist $SqT $Cost $Pos $Tables)) ; -; - +; More efficient if we store the target squares, instead of indices, ; -; - - - (= - (cheapest-destination $Piece $Player $Sq $SqTIs $Dist $SqT $Cost $Pos $Tables) - ( (findall - (- $Cost1 $SqT1) - (, - (member $SqTI1 $SqTIs) - (square-index $SqT1 $SqTI1) - (cost-to-promsq $Piece $Player $Sq $SqT1 $Dist $Cost1 $Pos $Tables)) $Dests) (sort $Dests (Cons (- $Cost $SqT) $_)))) -; +; in promsq matrix. + (= (cheapest-destination $Piece $Player $Sq $SqTIs $Dist $SqT $Cost $Pos $Tables) + (findall + (- $Cost1 $SqT1) + (, + (member $SqTI1 $SqTIs) + (square-index $SqT1 $SqTI1) + (cost-to-promsq $Piece $Player $Sq $SqT1 $Dist $Cost1 $Pos $Tables)) $Dests) + (sort $Dests + (Cons + (- $Cost $SqT) $_))) - (= - (cost-to-promsq $Piece $Player $Sq $SqT $SqDist $PathCost $Pos $Tables) + (= (cost-to-promsq $Piece $Player $Sq $SqT $SqDist $PathCost $Pos $Tables) (clear-path-cost $Piece $Player $Sq $SqT $SqDist $PathCost $Pos)) -; +; ; distance_to_promsq(Piece,Sq,SqT,SqDist,Tables), - - (= - (distance-to-promsq $Piece $Sq $SqT $SqDist $Tables) + (= (distance-to-promsq $Piece $Sq $SqT $SqDist $Tables) (square-piece-promsq $Sq $Piece $SqT $SqDist $Tables)) -; - ; -; - +; The likelihood of achieving the promotion decreases ; -; - +; exponentially with the number of moves required to ; -; - +; achieve it. ; -; - +; We subtract 1 from the total as if a piece promotes ; -; - +; immediately into another, the cost is just the path ; -; - - - (= - (prom-likelihood $PromDist $PathCost $Prob) - ( (is $MinMoves - (- - (+ $PromDist $PathCost) 1)) (distance-value $MinMoves $Prob))) -; +; distance. + (= (prom-likelihood $PromDist $PathCost $Prob) + (is $MinMoves + (- + (+ $PromDist $PathCost) 1)) + (distance-value $MinMoves $Prob)) ; -; - +; This must measure the value independent of promotions ; -; - +; this piece could make, as these will already be taken ; -; - +; into account. ; -; - +; Thus we shut down both the threat analysis and the ; -; - +; other promotions. ; -; - - - (= - (intrinsic-value $Piece $Sq $Val $Pos $Tables) - ( (shutdown-advisor threat $Tables) - (shutdown-advisor prom $Tables) - (shutdown-advisor dynamic-mobility $Tables) - (local-evaluation $Piece $Sq $Val $Pos $Tables))) -; +; Also shutdown dynamic-mob, to save time (if have more time, keep it). + (= (intrinsic-value $Piece $Sq $Val $Pos $Tables) + (shutdown-advisor threat $Tables) + (shutdown-advisor prom $Tables) + (shutdown-advisor dynamic-mobility $Tables) + (local-evaluation $Piece $Sq $Val $Pos $Tables)) - (= - (testp) - ( (checkpoint init $S) - (get-advices $A $S) - (ppl $A))) -; - + (= (testp) + (checkpoint init $S) + (get-advices $A $S) + (ppl $A)) ; -; - +; ============================================================================ ; -; - +; Tables for Promotion Goals ; -; - +; ============================================================================ ; -; - +; promotes_into(OrigPiece,PromPiece,Distance) ; -; - +; OrigPiece, if it could use its promotion power each turn, ; -; - +; could promote into PromPiece after Distance turns. ; ; - ; -; - +; We first make a graph, where each node is a piece(Player,Type) ; -; - +; for each type of piece in the game def. We add an edge from P1 to P2 ; -; - +; if P1 could promote directly into P2. ; -; - +; From this we can then answer several of these types of questions by ; -; - - +; standard graph algorithms. - (= - (promotes-into $Piece $PieceI $Prom $PromI $Player $Chooser) - ( (promotes-into $Piece $Prom $Player $Chooser) - (piece-index $Piece $PieceI) - (piece-index $Prom $PromI))) -; + (= (promotes-into $Piece $PieceI $Prom $PromI $Player $Chooser) + (promotes-into $Piece $Prom $Player $Chooser) + (piece-index $Piece $PieceI) + (piece-index $Prom $PromI)) - (= - (opponent-promotes $Piece) - ( (promotes-into $Piece $_ $Player $Chooser) (opposite-role $Player $Chooser))) -; - + (= (opponent-promotes $Piece) + (promotes-into $Piece $_ $Player $Chooser) + (opposite-role $Player $Chooser)) - (= - (promotes-into $OrigPiece $PromPiece $Player $Chooser) - ( (owns $OrigPiece $Player) - (current-game-for-player $Player $Game) - (game-piece-promoting $OrigPiece $Promoting $Game) - (promote-choice $Promoting $Player $Chooser $PromPiece))) -; - + (= (promotes-into $OrigPiece $PromPiece $Player $Chooser) + (owns $OrigPiece $Player) + (current-game-for-player $Player $Game) + (game-piece-promoting $OrigPiece $Promoting $Game) + (promote-choice $Promoting $Player $Chooser $PromPiece)) - (= - (promote-choice $Promoting $Player $Player $PromPiece) + (= (promote-choice $Promoting $Player $Player $PromPiece) (simple-promote $Promoting $Player $PromPiece)) -; - - (= - (promote-choice $Promoting $Player $Chooser $PromPiece) - ( (= $Promoting - (promote $Chooser $Descr)) (matches $Descr $PromPiece))) -; - + (= (promote-choice $Promoting $Player $Chooser $PromPiece) + (= $Promoting + (promote $Chooser $Descr)) + (matches $Descr $PromPiece)) - (= - (forced-promote $Player $PlI $Piece $PieceI $Prom $PromI) - ( (player-index $Player $PlI) (forced-promote $Player $Piece $PieceI $Prom $PromI))) -; + (= (forced-promote $Player $PlI $Piece $PieceI $Prom $PromI) + (player-index $Player $PlI) + (forced-promote $Player $Piece $PieceI $Prom $PromI)) - - (= - (forced-promote $Player $Piece $PieceI $Prom $PromI) + (= (forced-promote $Player $Piece $PieceI $Prom $PromI) (promotes-into $Piece $PieceI $Prom $PromI $Player $Player)) -; - +; ; player_role(Player), ; -; - +; ============================================================================== ; -; - +; Piece-Piece (Immediate Player_Promotion) Matrix ; -; - +; ============================================================================== - (= - (build-promotion-matrix $Matrix) + (= (build-promotion-matrix $Matrix) (map-player-table promotion-matrix Nil $Matrix)) -; - - (= - (print-promotion-matrix) + (= (print-promotion-matrix) (print-promotion-matrix $Piece $Player $PieceT)) -; - - - (= - (print-promotion-matrix $Piece $Player $PieceT) - ( (format "Player Piece Promotion Matrix:~n" Nil) (or (, (piece-player-promotion $Piece $Player $PieceT) (format "~p: ~p -> ~p~n" (:: $Player $Piece $PieceT)) (fail)) True))) -; + (= (print-promotion-matrix $Piece $Player $PieceT) + (format "Player Piece Promotion Matrix:~n" Nil) + (or + (, + (piece-player-promotion $Piece $Player $PieceT) + (format "~p: ~p -> ~p~n" + (:: $Player $Piece $PieceT)) + (fail)) True)) +; ; format("matrix[~p][~p] = ~p~n",[Piece,Player,PieceT]), - (= - (ppp $Player $Piece $PieceT) + (= (ppp $Player $Piece $PieceT) (piece-player-promotion $Piece $Player $PieceT)) -; - ; -; - +; PIECE_PLAYER_PROMOTION(?Piece,?Player,?PieceT) ; -; - +; Very nice table indicating when a player could ; -; - - - (= - (piece-player-promotion $Piece $Player $PieceT) - ( (advice-tables $Tables) (piece-player-promotion $Piece $Player $PieceT $Tables))) -; +; move directly from one piece to another on an empty board. + (= (piece-player-promotion $Piece $Player $PieceT) + (advice-tables $Tables) + (piece-player-promotion $Piece $Player $PieceT $Tables)) ; -; - +; PIECE_PLAYER_PROMOTION(?Piece,?Player,?PieceT,+Tables) ; -; - +; Very nice table indicating when a player could ; -; - - (= - (piece-player-promotion $Piece $Player $PieceT $Tables) +; move directly from one piece to another on an empty board. + (= (piece-player-promotion $Piece $Player $PieceT $Tables) (piece-player-promotion $Piece $PieceI $Player $PlayerI $PieceT $PieceTI $Tables)) -; - - - (= - (piece-player-promotion $Piece $PieceI $Player $PlayerI $PieceT $PieceTI $Tables) - ( (player-index $Player $PlayerI) - (piece-index $Piece $PieceI) - (piece-player-piece $PieceI $PlayerI $PieceTI $Tables) - (piece-index $PieceT $PieceTI))) -; - - - - (= - (piece-player-piece $PieceI $PlayerI $PieceTI $Tables) - ( (promotion-matrix $Tables $M) (piece-player-piece1 $PieceI $PlayerI $PieceTI $M))) -; + (= (piece-player-promotion $Piece $PieceI $Player $PlayerI $PieceT $PieceTI $Tables) + (player-index $Player $PlayerI) + (piece-index $Piece $PieceI) + (piece-player-piece $PieceI $PlayerI $PieceTI $Tables) + (piece-index $PieceT $PieceTI)) - (= - (piece-player-piece1 $PieceI $PlayerI $PieceTI $M) - ( (player-table-entry $_ $PlayerI $M $Entry) - (member1-pair - (- $PieceI $Ts) $Entry) - (member $PieceTI $Ts))) -; - + (= (piece-player-piece $PieceI $PlayerI $PieceTI $Tables) + (promotion-matrix $Tables $M) + (piece-player-piece1 $PieceI $PlayerI $PieceTI $M)) - (= - (piece-player-pieces $PieceI $PlayerI $TIs $Tables) - ( (promotion-matrix $Tables $M) (piece-player-pieces $PieceI $PlayerI $TIs $M))) -; + (= (piece-player-piece1 $PieceI $PlayerI $PieceTI $M) + (player-table-entry $_ $PlayerI $M $Entry) + (member1-pair + (- $PieceI $Ts) $Entry) + (member $PieceTI $Ts)) + (= (piece-player-pieces $PieceI $PlayerI $TIs $Tables) + (promotion-matrix $Tables $M) + (piece-player-pieces $PieceI $PlayerI $TIs $M)) - (= - (piece-player-pieces1 $PieceI $PlayerI $TIs $M) - ( (player-table-entry $_ $PlayerI $M $Entry) (member1-pair (- $PieceI $TIs) $Entry))) -; + (= (piece-player-pieces1 $PieceI $PlayerI $TIs $M) + (player-table-entry $_ $PlayerI $M $Entry) + (member1-pair + (- $PieceI $TIs) $Entry)) ; -; - +; Reversed order of args to use map table. ; -; - - - (= - (promotion-matrix $Player $PlIndex $Matrix) - ( (player-index $Player $PlIndex) - (setof - (- $PieceIndex $PieceTIndices) - (^ $Piece - (player-pieces $Player $PlIndex $Piece $PieceIndex $PieceTIndices)) $Matrix) - (tracing-anal-format tables "Built promotion matrix for <~p>~n" - (:: $Player)))) -; - +; promotion_matrix(Player,PlIndex,Matrix) :- + (= (promotion-matrix $Player $PlIndex $Matrix) + (player-index $Player $PlIndex) + (setof + (- $PieceIndex $PieceTIndices) + (^ $Piece + (player-pieces $Player $PlIndex $Piece $PieceIndex $PieceTIndices)) $Matrix) + (tracing-anal-format tables "Built promotion matrix for <~p>~n" + (:: $Player))) - (= - (player-pieces $Player $PlIndex $Piece $PieceIndex $PieceTIndices) - ( (piece-index $Piece $PieceIndex) (det-if-then-else (setof $PieceTIndex (^ $PieceT (player-piece-piece $Player $PlIndex $Piece $PieceIndex $PieceT $PieceTIndex)) $PieceTIndices) True (= $PieceTIndices Nil)))) -; + (= (player-pieces $Player $PlIndex $Piece $PieceIndex $PieceTIndices) + (piece-index $Piece $PieceIndex) + (det-if-then-else + (setof $PieceTIndex + (^ $PieceT + (player-piece-piece $Player $PlIndex $Piece $PieceIndex $PieceT $PieceTIndex)) $PieceTIndices) True + (= $PieceTIndices Nil))) - (= - (player-piece-piece $Player $Piece $PieceT) + (= (player-piece-piece $Player $Piece $PieceT) (player-piece-piece $Player $PlIndex $Piece $PieceIndex $PieceT $PieceTIndex)) -; - - (= - (player-piece-piece $Player $PlI $Piece $PieceI $PieceT $PieceTI) - ( (piece-index $Piece $PieceI) - (player-index $Player $PlI) - (forced-promote $Player $PlI $Piece $PieceI $PieceT $PieceTI) - (piece-index $PieceT $PieceTI) - (tracing-anal-format detailed "~p: ~p -> ~p~n" - (:: $Player $Piece $PieceT)))) -; - + (= (player-piece-piece $Player $PlI $Piece $PieceI $PieceT $PieceTI) + (piece-index $Piece $PieceI) + (player-index $Player $PlI) + (forced-promote $Player $PlI $Piece $PieceI $PieceT $PieceTI) + (piece-index $PieceT $PieceTI) + (tracing-anal-format detailed "~p: ~p -> ~p~n" + (:: $Player $Piece $PieceT))) ; -; - +; ============================================================================== ; -; - +; Promotion Distance Matrix ; -; - +; ============================================================================== ; -; - +; Requires transition-matrix (at the moment). - (= - (build-prom-distance-matrix $Trans $Matrix) + (= (build-prom-distance-matrix $Trans $Matrix) (map-player-table prom-distance-matrix (:: $Trans) $Matrix)) -; + (= (prom-distance-matrix $Player $PlayerIndex $Matrix) + (promotion-matrix $Trans) + (prom-distance-matrix $Player $PlayerIndex $Trans $Matrix)) - (= - (prom-distance-matrix $Player $PlayerIndex $Matrix) - ( (promotion-matrix $Trans) (prom-distance-matrix $Player $PlayerIndex $Trans $Matrix))) -; - + (= (prom-distance-matrix $Player $PlayerIndex $Trans $Matrix) + (player-table-entry $Player $PlayerIndex $Trans $Matrix1) + (s-floyd $Matrix1 $Matrix) + (tracing-anal-format tables "Built prom_distance matrix for <~p>~n" + (:: $Player))) - (= - (prom-distance-matrix $Player $PlayerIndex $Trans $Matrix) - ( (player-table-entry $Player $PlayerIndex $Trans $Matrix1) - (s-floyd $Matrix1 $Matrix) - (tracing-anal-format tables "Built prom_distance matrix for <~p>~n" - (:: $Player)))) -; - - - (= - (piece-player-list-dist $PieceI $PlayerI $PieceTI $Dist $Tables) - ( (prom-distance-matrix $Tables $Matrix) (piece-player-list-dist1 $PieceI $PlayerI $PieceTI $Matrix $Dist))) -; - + (= (piece-player-list-dist $PieceI $PlayerI $PieceTI $Dist $Tables) + (prom-distance-matrix $Tables $Matrix) + (piece-player-list-dist1 $PieceI $PlayerI $PieceTI $Matrix $Dist)) - (= - (piece-player-list-dist1 $PieceI $PlayerI $PieceTI $Table $Dist) - ( (player-table-entry $_ $PlayerI $Table $Entry) (piece-matrix-distance $PieceI $PieceTI $Entry $Dist))) -; - + (= (piece-player-list-dist1 $PieceI $PlayerI $PieceTI $Table $Dist) + (player-table-entry $_ $PlayerI $Table $Entry) + (piece-matrix-distance $PieceI $PieceTI $Entry $Dist)) - (= - (piece-player-list-prom-distance $PieceI $PlayerI $PieceTI $Dist $Tables) - ( (prom-distance-matrix $Tables $Matrix) (piece-player-list-prom-distance1 $PieceI $PlayerI $PieceTI $Matrix $Dist))) -; - + (= (piece-player-list-prom-distance $PieceI $PlayerI $PieceTI $Dist $Tables) + (prom-distance-matrix $Tables $Matrix) + (piece-player-list-prom-distance1 $PieceI $PlayerI $PieceTI $Matrix $Dist)) - (= - (piece-player-list-prom-distance1 $PieceI $PlayerI $PieceTI $Table $Dist) - ( (player-table-entry $_ $PlayerI $Table $Entry) (piece-matrix-distance $PieceI $PieceTI $Entry $Dist))) -; - + (= (piece-player-list-prom-distance1 $PieceI $PlayerI $PieceTI $Table $Dist) + (player-table-entry $_ $PlayerI $Table $Entry) + (piece-matrix-distance $PieceI $PieceTI $Entry $Dist)) - (= - (print-prom-distance-matrix) + (= (print-prom-distance-matrix) (print-prom-distance-matrix $_ $_ $_)) -; - - - (= - (print-prom-distance-matrix $Piece $Player $PieceT) - ( (format "Piece Player Prom_distance Matrix:~n" Nil) (or (, (piece-player-prom-distance $Piece $Player $PieceT $Dist) (format "~p: ~p -> ~p <~p>~n" (:: $Player $Piece $PieceT $Dist)) (fail)) True))) -; + (= (print-prom-distance-matrix $Piece $Player $PieceT) + (format "Piece Player Prom_distance Matrix:~n" Nil) + (or + (, + (piece-player-prom-distance $Piece $Player $PieceT $Dist) + (format "~p: ~p -> ~p <~p>~n" + (:: $Player $Piece $PieceT $Dist)) + (fail)) True)) +; ; format("matrix[~p][~p] = ~p~n",[Piece,Player,PieceT]), - (= - (ppd $P $Pl $PieceT $V) + (= (ppd $P $Pl $PieceT $V) (piece-player-prom-distance $P $Pl $PieceT $V)) -; - ; -; - +; PIECE_PLAYER_PROM_DISTANCE(?Piece,?Player,?PieceT,?Dist) ; -; - +; Very nice table indicating the minimum number of promotions ; -; - +; (prom_distance) a player would ; -; - - - (= - (piece-player-prom-distance $Piece $Player $PieceT $Dist) - ( (advice-tables $Tables) (piece-player-prom-distance $Piece $Player $PieceT $Dist $Tables))) -; +; take to move from one piece to another on an empty board. + (= (piece-player-prom-distance $Piece $Player $PieceT $Dist) + (advice-tables $Tables) + (piece-player-prom-distance $Piece $Player $PieceT $Dist $Tables)) ; -; - +; PIECE_PLAYER_PROM_DISTANCE(?Piece,?Player,?PieceT,?Dist,+Tables) ; -; - +; Very nice table indicating the minimum number of promotions ; -; - +; (prom_distance) a player would ; -; - - (= - (piece-player-prom-distance $Piece $Player $PieceT $Dist $Tables) - ( (player-index $Player $PlayerI) - (piece-index $Piece $PieceI) - (piece-index $PieceT $PieceTI) - (piece-player-list-prom-distance $PieceI $PlayerI $PieceTI $Dist $Tables))) -; - +; take to move from one piece to another on an empty board. + (= (piece-player-prom-distance $Piece $Player $PieceT $Dist $Tables) + (player-index $Player $PlayerI) + (piece-index $Piece $PieceI) + (piece-index $PieceT $PieceTI) + (piece-player-list-prom-distance $PieceI $PlayerI $PieceTI $Dist $Tables)) ; -; - +; ============================================================================== ; -; - +; Piece Promotion Square Distance (Promsq) Table ; -; - +; ============================================================================== ; -; - +; Requires distance table now. - (= - (build-promsq-matrix $Matrix) - ( (distance-table $DTable) (build-promsq-matrix $DTable $Matrix))) -; - + (= (build-promsq-matrix $Matrix) + (distance-table $DTable) + (build-promsq-matrix $DTable $Matrix)) ; -; - - (= - (build-promsq-matrix $DTable $Matrix) +; Uses saved distance-table. + (= (build-promsq-matrix $DTable $Matrix) (map-piece-table promsq-matrix (:: $DTable) $Matrix)) -; - - (= - (promsq-matrix $Piece $PieceIndex $Matrix) - ( (distance-table $DTable) (promsq-matrix $Piece $PieceIndex $DTable $Matrix))) -; - + (= (promsq-matrix $Piece $PieceIndex $Matrix) + (distance-table $DTable) + (promsq-matrix $Piece $PieceIndex $DTable $Matrix)) - (= - (promsq-matrix $Piece $PieceIndex $DTable $Matrix) - ( (piece-index $Piece $PieceIndex) - (map-square-table square-promsq - (:: $Piece $PieceIndex $DTable) $Matrix) - (tracing-anal-format tables "Built promsq table for <~p>~n" - (:: $Piece)))) -; - + (= (promsq-matrix $Piece $PieceIndex $DTable $Matrix) + (piece-index $Piece $PieceIndex) + (map-square-table square-promsq + (:: $Piece $PieceIndex $DTable) $Matrix) + (tracing-anal-format tables "Built promsq table for <~p>~n" + (:: $Piece))) ; -; - - - (= - (square-promsq $Sq $SqI $Piece $PieceI $DTable - (/ $SqTIs $Dist)) - ( (nearest-promotion-squares $Piece $PieceI $Player $Sq $SqI $SqTs $SqTIs $DTable $Dist) (set-det))) -; - - (= - (square_promsq $Sq $SqI $Piece $PieceI $DTable $Ignore) True) -; +; If nothing found, puts a variable in that entry. + (= (square-promsq $Sq $SqI $Piece $PieceI $DTable (/ $SqTIs $Dist)) + (nearest-promotion-squares $Piece $PieceI $Player $Sq $SqI $SqTs $SqTIs $DTable $Dist) + (set-det)) + (= (square_promsq $Sq $SqI $Piece $PieceI $DTable $Ignore) True) ; -; - - - (= - (square-piece-psqs $SqI $PieceI $SqTIs $Dist $Tables) - ( (promsq-matrix $Tables $M) - (pindex-table-entry $PieceI $M $Entry) - (slindex-table-entries $SqI $Entry $SqTIs $Dist))) -; +; Returns the list of SqTIs (all with the minimum Dist). + (= (square-piece-psqs $SqI $PieceI $SqTIs $Dist $Tables) + (promsq-matrix $Tables $M) + (pindex-table-entry $PieceI $M $Entry) + (slindex-table-entries $SqI $Entry $SqTIs $Dist)) ; -; - - - (= - (square-piece-psq $SqI $PieceI $SqTI $Dist $Tables) - ( (promsq-matrix $Tables $M) - (pindex-table-entry $PieceI $M $Entry) - (slindex-table-entry $SqI $Entry $SqTI $Dist))) -; +; Backtracks over each SqTI (all with the minimum Dist). + (= (square-piece-psq $SqI $PieceI $SqTI $Dist $Tables) + (promsq-matrix $Tables $M) + (pindex-table-entry $PieceI $M $Entry) + (slindex-table-entry $SqI $Entry $SqTI $Dist)) - (= - (spq $S $P $SqT $D) + (= (spq $S $P $SqT $D) (square-piece-promsq $S $P $SqT $D)) -; - ; -; - +; SQUARE_PIECE_PROMSQ(?Sq,?Piece,?SqT,?Dist) ; -; - +; Very nice table indicating for a piece on a square, ; -; - +; one of the nearest promotion squares SqT is Dist squares away. ; -; - - - (= - (square-piece-promsq $Sq $Piece $SqT $Dist) - ( (advice-tables $Tables) (square-piece-promsq $Sq $Piece $SqT $Dist $Tables))) -; +; Backtracks over all nearest squares. + (= (square-piece-promsq $Sq $Piece $SqT $Dist) + (advice-tables $Tables) + (square-piece-promsq $Sq $Piece $SqT $Dist $Tables)) ; -; - +; SQUARE_PIECE_PROMSQ(?Sq,?Piece,?SqT,?Dist,Tables) ; -; - +; Very nice table indicating for a piece on a square, ; -; - - (= - (square-piece-promsq $Sq $Piece $SqT $Dist $Tables) - ( (piece-index $Piece $PieceI) - (square-index $Sq $SqI) - (square-piece-psq $SqI $PieceI $SqTI $Dist $Tables) - (square-index $SqT $SqTI))) -; - +; one of the nearest promotion squares SqT is Dist squares away. + (= (square-piece-promsq $Sq $Piece $SqT $Dist $Tables) + (piece-index $Piece $PieceI) + (square-index $Sq $SqI) + (square-piece-psq $SqI $PieceI $SqTI $Dist $Tables) + (square-index $SqT $SqTI)) ; -; - +; Printing promsq matrix ; ; - - (= - (print-promsq-matrix) + (= (print-promsq-matrix) (print-promsq-matrix $_ $_)) -; - - - (= - (print-promsq-matrix $Sq $Piece) - ( (format "Square Piece Promsq Matrix:~n" Nil) (or (, (square-piece-promsq $Sq $Piece $SqT $Dist) (format "matrix[~p][~p] = ~p (~p)~n" (:: $Sq $Piece $SqT $Dist)) (fail)) True))) -; + (= (print-promsq-matrix $Sq $Piece) + (format "Square Piece Promsq Matrix:~n" Nil) + (or + (, + (square-piece-promsq $Sq $Piece $SqT $Dist) + (format "matrix[~p][~p] = ~p (~p)~n" + (:: $Sq $Piece $SqT $Dist)) + (fail)) True)) ; -; +; ============================================================================= - - (= - (nearest-promotion-squares $Piece $Player $Sq $SqTs $Dist) + (= (nearest-promotion-squares $Piece $Player $Sq $SqTs $Dist) (nearest-promotion-squares $Piece $PieceI $Player $Sq $SqI $SqTs $SqTIs $Dist)) -; - - - (= - (nearest-promotion-squares $Piece $PieceI $Player $Sq $SqI $SqTs $SqTIs $Dist) - ( (distance-table $DTable) (nearest-promotion-squares $Piece $PieceI $Player $Sq $SqI $SqTs $SqTIs $DTable $Dist))) -; +; /* Nearest promotion square/s: The closest square a piece could move to and promote (on an empty board). We could either use just the nearest one, or if there are ties the nearest maximizing some value, etc. */ +; ; NEAREST_PROMOTION_SQUARES(?Piece,?Player,?Sq,-SqTs,-Dist) ; SqTs are the nearest promotion square from Sq for Player's Piece, ; and getting to any of them would require Dist moves on an empty board. + (= (nearest-promotion-squares $Piece $PieceI $Player $Sq $SqI $SqTs $SqTIs $Dist) + (distance-table $DTable) + (nearest-promotion-squares $Piece $PieceI $Player $Sq $SqI $SqTs $SqTIs $DTable $Dist)) - (= - (nearest-promotion-squares $Piece $PieceI $Player $Sq $SqI $SqTs $SqTIs $DTable $Dist) - ( (piece-index $Piece $PieceI) - (square-index $Sq $SqI) - (owns $Piece $Player) - (prom-square-indices $Player $PromSquares) - (nearest-squares $PromSquares $PieceI $SqI $SqTs $SqTIs $DTable $Dist))) -; - + (= (nearest-promotion-squares $Piece $PieceI $Player $Sq $SqI $SqTs $SqTIs $DTable $Dist) + (piece-index $Piece $PieceI) + (square-index $Sq $SqI) + (owns $Piece $Player) + (prom-square-indices $Player $PromSquares) + (nearest-squares $PromSquares $PieceI $SqI $SqTs $SqTIs $DTable $Dist)) ; -; - +; NEAREST_SQUARES(Squares,PieceI,SqI,SqTs,SqTIs,DTable,Dist) :- ; -; - +; SqTIs are the indices of the nearest members SqTs of Squares (list of ; -; - +; indices) for piece index PieceI from SqI, and Dist is the ; -; - +; min distance. ; -; - +; If no reachable square was found, this fails. ; -; - - +; DTable is the distance table. - (= - (nearest-squares $Squares $PieceI $SqI $SqTs $SqTIs $DTable $Dist) - ( (square-distances $Squares $PieceI $SqI $DTable $AllDists) - (closest-dists $AllDists $Dist $SqTIs) - (maplist square-index $SqTs $SqTIs))) -; + (= (nearest-squares $Squares $PieceI $SqI $SqTs $SqTIs $DTable $Dist) + (square-distances $Squares $PieceI $SqI $DTable $AllDists) + (closest-dists $AllDists $Dist $SqTIs) + (maplist square-index $SqTs $SqTIs)) - (= - (square-distances $Squares $PieceI $SqI $DTable $AllDists) + (= (square-distances $Squares $PieceI $SqI $DTable $AllDists) (findall (- $Dist $SqTI) (, (member $SqTI $Squares) (\== $SqTI $SqI) - (square-piece-sq-dist1 $SqI $PieceI $SqTI $DTable $Dist)) $AllDists)) -; - + (square-piece-sq-dist1 $SqI $PieceI $SqTI $DTable $Dist)) $AllDists)) - (= - (closest-dists $AllDists $V $Es) - ( (p-to-s-graph $AllDists $Graph) (first-connected $Graph (- $V $Es)))) -; + (= (closest-dists $AllDists $V $Es) + (p-to-s-graph $AllDists $Graph) + (first-connected $Graph + (- $V $Es))) - - (= - (first-connected - (Cons $H $Rest) $First) + (= (first-connected (Cons $H $Rest) $First) (first1 $H $Rest $First)) -; - - (= - (first1 - (- $V $Es) $Rest $First) + (= (first1 (- $V $Es) $Rest $First) (det-if-then-else (= $Es Nil) (first-connected $Rest $First) (= $First (- $V $Es)))) -; - diff --git a/metagame/learning/step.metta b/metagame/learning/step.metta index 500db36..57a82ca 100644 --- a/metagame/learning/step.metta +++ b/metagame/learning/step.metta @@ -1,640 +1,423 @@ +; (convert_to_metta_file step $_322156 metagame/learning/step.pl metagame/learning/step.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; step.pl ; -; - +; -------------------------------------------------------------------------------- ; -; - +; Piece has independent static advice for each player. ; -; - +; -------------------------------------------------------------------------------- ; -; - +; ind_advice(Player,Piece,Advice,Tables) ; -; - +; -------------------------------------------------------------------------------- ; ; - ; -; - +; Nondeterm routine, tells us various sources of static advice accrued to Player ; -; - +; by having a piece on the board owned by him, independent of the board ; -; - +; and of possible interactions between Piece and other pieces. ; ; - ; -; - +; o Useful to have pieces which can capture many victims (including pieces of ; -; - +; his own). The more pieces, the better. (victims) ; -; - +; o Useful to have piece which cannot be captured by many enemy pieces. (immunity) ; -; - +; o Useful to have piece which can be captured by many of our own pieces (giveaway) ; -; - +; o Useful to have a piece with high max static mobility, or (max_static_mob) ; -; - +; high max eventual mobility. (max_eventual_mob) ; -; - +; o Useful to have a piece with high average static mobility, or (avg_static_mob) ; -; - +; high average eventual mobility. (avg_eventual_mob) ; -; - +; o Bad to have a piece when *we* have a goal to eradicate it. (Also converse) (eradicate) ; -; - +; o Bad to have a piece when goal is stalemate ourself. (Also converse) (stalemate) ; -; - +; o Good to have piece if we have an arrival goal for it, (arrive) ; -; - +; or if it can generate such a one by promotion. ; -; - +; -- In this case, the value of this as a target decreases with the number of intermediate proms ; -; - +; necessary to create a piece matching the arrive goal. (Also converse) ; -; - +; A separate rule does the opposite, when we generate a goal for the opponent, and ; -; - +; encourages us to stay away. ; -; - +; *. Also good to player-possess-capture a piece (owned by either player) for which we have ; -; - +; an arrive goal! Perhaps use generator fn to measure how good to capture. ; -; - +; Note: There is a recurrence here which says useful to capture enemy piece if it can capture ; -; - +; our piece which is useful to capture it. - (= - (ind-advice $Player $Piece - (advice victims $Piece $Value) $Tables) + (= (ind-advice $Player $Piece (advice victims $Piece $Value) $Tables) (victim-counts $Piece $Value)) -; - - (= - (ind-advice $Player $Piece - (advice immunity $Piece $Value) $Tables) + (= (ind-advice $Player $Piece (advice immunity $Piece $Value) $Tables) (immunity-value $Player $Piece $Value)) -; - - (= - (ind-advice $Player $Piece - (advice giveaway $Piece $Value) $Tables) + (= (ind-advice $Player $Piece (advice giveaway $Piece $Value) $Tables) (giveaway-value $Player $Piece $Value)) -; - - (= - (ind-advice $Player $Piece - (advice max-static-mob $Piece $Value) $Tables) + (= (ind-advice $Player $Piece (advice max-static-mob $Piece $Value) $Tables) (max-static-mob $Piece $Value $Tables)) -; - - (= - (ind-advice $Player $Piece - (advice max-eventual-mob $Piece $Value) $Tables) + (= (ind-advice $Player $Piece (advice max-eventual-mob $Piece $Value) $Tables) (max-eventual-mob $Piece $Value $Tables)) -; - - (= - (ind-advice $Player $Piece - (advice avg-static-mob $Piece $Value) $Tables) + (= (ind-advice $Player $Piece (advice avg-static-mob $Piece $Value) $Tables) (average-static-mob $Piece $Value $Tables)) -; - - (= - (ind-advice $Player $Piece - (advice avg-eventual-mob $Piece $Value) $Tables) + (= (ind-advice $Player $Piece (advice avg-eventual-mob $Piece $Value) $Tables) (average-eventual-mob $Piece $Value $Tables)) -; - - (= - (ind-advice $Player $Piece - (advice eradicate - (- $Player $Piece) $Value) $Tables) - ( (player-eradicate-target $Player $Piece) (= $Value -1))) -; - - (= - (ind-advice $Player $Piece - (advice eradicate - (- $Opp $Piece) $Value) $Tables) - ( (opposite-role $Player $Opp) - (player-eradicate-target $Opp $Piece) - (= $Value 1))) -; - - (= - (ind-advice $Player $Piece - (advice stalemate $Player $Value) $Tables) - ( (player-stalemate-target $Player $Piece) (= $Value -1))) -; - - (= - (ind-advice $Player $Piece - (advice stalemate $Opp $Value) $Tables) - ( (opposite-role $Player $Opp) - (player-stalemate-target $Opp $Piece) - (= $Value 1))) -; - - (= - (ind-advice $Player $Piece - (advice arrive - (- $Player $Piece) $Value) $Tables) - ( (player-arrive-generator $Player $Piece $Dist $Tables) (is $Value (/ 1 (+ 1 $Dist))))) -; - - (= - (ind-advice $Player $Piece - (advice arrive - (- - (- $Opp $Piece) $Dist) $Value) $Tables) - ( (opposite-role $Player $Opp) - (player-arrive-generator $Opp $Piece $Dist $Tables) - (is $Value - (/ -1 - (+ 1 $Dist))))) -; - + (= (ind-advice $Player $Piece (advice eradicate (- $Player $Piece) $Value) $Tables) + (player-eradicate-target $Player $Piece) + (= $Value -1)) + (= (ind-advice $Player $Piece (advice eradicate (- $Opp $Piece) $Value) $Tables) + (opposite-role $Player $Opp) + (player-eradicate-target $Opp $Piece) + (= $Value 1)) + (= (ind-advice $Player $Piece (advice stalemate $Player $Value) $Tables) + (player-stalemate-target $Player $Piece) + (= $Value -1)) + (= (ind-advice $Player $Piece (advice stalemate $Opp $Value) $Tables) + (opposite-role $Player $Opp) + (player-stalemate-target $Opp $Piece) + (= $Value 1)) + (= (ind-advice $Player $Piece (advice arrive (- $Player $Piece) $Value) $Tables) + (player-arrive-generator $Player $Piece $Dist $Tables) + (is $Value + (/ 1 + (+ 1 $Dist)))) + (= (ind-advice $Player $Piece (advice arrive (- (- $Opp $Piece) $Dist) $Value) $Tables) + (opposite-role $Player $Opp) + (player-arrive-generator $Opp $Piece $Dist $Tables) + (is $Value + (/ -1 + (+ 1 $Dist)))) - (= - (ind-advice $Player $Piece $Value) - ( (advice-tables $Tables) (ind-advice $Player $Piece $Value $Tables))) -; - - + (= (ind-advice $Player $Piece $Value) + (advice-tables $Tables) + (ind-advice $Player $Piece $Value $Tables)) - (= - (independent-advice $Player $Piece $Value $Tables) - ( (owns $Piece $Player) - (piece-index $Piece $_) - (ind-advice $Player $Piece $Val1 $Tables) - (negate-advice-for-player $Player $Val1 $Value))) -; - - (= - (independent-advice $Player $Piece $Value) - ( (advice-tables $Tables) (independent-advice $Player $Piece $Value $Tables))) -; + (= (independent-advice $Player $Piece $Value $Tables) + (owns $Piece $Player) + (piece-index $Piece $_) + (ind-advice $Player $Piece $Val1 $Tables) + (negate-advice-for-player $Player $Val1 $Value)) + (= (independent-advice $Player $Piece $Value) + (advice-tables $Tables) + (independent-advice $Player $Piece $Value $Tables)) ; -; - +; -------------------------------------------------------------------------------- ; -; - +; Mediating independent advice ; -; - +; -------------------------------------------------------------------------------- ; ; - ; -; - +; Just like the advice meditation done dynamically, but here applying only to the ; -; - +; static advisors. - (= - (static-evaluation $Piece $Sq $Value $Position $Tables) - ( (get-static-advices $Piece $Sq $Advice $Position $Tables) (mediate-advices $Advice $Value $Tables))) -; - + (= (static-evaluation $Piece $Sq $Value $Position $Tables) + (get-static-advices $Piece $Sq $Advice $Position $Tables) + (mediate-advices $Advice $Value $Tables)) - (= - (get-static-advices $Piece $Sq $Advices $Position $Tables) - ( (piece-index $Piece $_) (findall $Advice (independent-advice $Player $Piece $Advice $Tables) $Advices))) -; - + (= (get-static-advices $Piece $Sq $Advices $Position $Tables) + (piece-index $Piece $_) + (findall $Advice + (independent-advice $Player $Piece $Advice $Tables) $Advices)) - (= - (get-static-advices $Piece $Advices) - ( (find-advice-tables $Tables) (get-static-advices $Piece $Sq $Advices $Position $Tables))) -; + (= (get-static-advices $Piece $Advices) + (find-advice-tables $Tables) + (get-static-advices $Piece $Sq $Advices $Position $Tables)) - - (= - (show-static-advices $Piece) - ( (get-static-advices $Piece $As) (ppl $As))) -; + (= (show-static-advices $Piece) + (get-static-advices $Piece $As) + (ppl $As)) - - (= - (show-static-advices-total $Piece) - ( (get-static-advices $Piece $As) - (ppl $As) - (mediate-advices $As $Total $_) - (format "Total (Mediated) for <~p>: ~p~n" - (:: $Piece $Total)))) -; - + (= (show-static-advices-total $Piece) + (get-static-advices $Piece $As) + (ppl $As) + (mediate-advices $As $Total $_) + (format "Total (Mediated) for <~p>: ~p~n" + (:: $Piece $Total))) - (= - (advice-top $Color $Type) - ( (piece $Piece - (:: $Color $Type) Nil) (show-static-advices-total $Piece))) -; - - + (= (advice-top $Color $Type) + (piece $Piece + (:: $Color $Type) Nil) + (show-static-advices-total $Piece)) - (= - (adviceold-top $Color $Type) - ( (piece $Piece - (:: $Color $Type) Nil) (show-static-advices $Piece))) -; + (= (adviceold-top $Color $Type) + (piece $Piece + (:: $Color $Type) Nil) + (show-static-advices $Piece)) ; -; - +; -------------------------------------------------------------------------------- ; -; - +; Piece has relative static value for each player, based on the independent ; -; - +; values of pieces and certain possible relations between them. ; -; - +; One of these rels is capturing. ; ; - ; ; - ; -; - +; Giving points for pieces based on which other piece types they can capture, ; -; - +; perhaps with a measure of how effective they will be at making these ; -; - +; captures. ; -; - +; Value added to a piece for being able to capture a Victim. ; -; - +; This is a *static* measure, which can be computed before the game ; -; - +; ever starts! ; ; - ; -; - +; At moment we aren't conditioning on different possible effects of the capture, ; -; - +; which may be important. ; ; - - (= - (cap-value $Piece $Player $Victim $Value $Tables) - ( (find-advice-tables-if $Tables) - (piece-victim $Piece $Player $Victim $VPlayer $Effect) - (victim-value $Player $Victim $VPlayer $Value $Tables))) -; - + (= (cap-value $Piece $Player $Victim $Value $Tables) + (find-advice-tables-if $Tables) + (piece-victim $Piece $Player $Victim $VPlayer $Effect) + (victim-value $Player $Victim $VPlayer $Value $Tables)) - (= - (cap-value $Piece $Player $Victim $Value) - ( (advice-tables $Tables) (cap-value $Piece $Player $Victim $Value $Tables))) -; - + (= (cap-value $Piece $Player $Victim $Value) + (advice-tables $Tables) + (cap-value $Piece $Player $Victim $Value $Tables)) ; -; - +; How good for Player to be able to capture Piece owned by VPlayer. ; -; - +; If Piece has Pos val for VPlayer, and we remove it, we make ; -; - +; neg val for VPlayer. Then we negate again if VPLAYER \== PLAYER, ; -; - +; as the value will have been wrt the wrong perspective. ; ; - ; -; - +; If this is optional, we don't force the player to take unacceptable ; -; - - - (= - (victim-value $Player $Piece $VPlayer $Value $Tables) - ( (independent-advice $VPlayer $Piece $Advice $Tables) - (advice-victim-value $Advice $Val1 $Tables) - (remove-option-value $Player $VPlayer $Val1 $Value))) -; +; pieces. + (= (victim-value $Player $Piece $VPlayer $Value $Tables) + (independent-advice $VPlayer $Piece $Advice $Tables) + (advice-victim-value $Advice $Val1 $Tables) + (remove-option-value $Player $VPlayer $Val1 $Value)) - (= - (advice-victim-value $Advice $Val $Tables) + (= (advice-victim-value $Advice $Val $Tables) (weigh-advice $Advice $Val $Tables)) -; - ; -; - +; Removal may be optional or forced. When forced, he must accept ; -; - +; whatever the consequences. When optional, he can choose to accept ; -; - +; only the positive ones. - (= - (remove-option-value $Player $Owner $Val1 $Value) + (= (remove-option-value $Player $Owner $Val1 $Value) (det-if-then-else (forced-remove $Player $Owner) (forced-remove-value $Player $Val1 $Value) (optional-remove-value $Player $Val1 $Value))) -; - ; -; - +; Removal may be forced when the game has a global must_capture rule, ; -; - +; and the victim piece is owned by the enemy. This is becasue he may throw ; -; - - - (= - (forced-remove $Player $Owner) - ( (current-game-must-capture) (\== $Player $Owner))) -; +; his pieces at us and force us to absorb the value of them. + (= (forced-remove $Player $Owner) + (current-game-must-capture) + (\== $Player $Owner)) ; -; - +; In this case, the player has no choice but to accept the loss of material. - (= - (forced-remove-value $Player $Val1 $Value) + (= (forced-remove-value $Player $Val1 $Value) (is $Value (- $Val1))) -; - ; -; - +; Player has the option of removing Val1 points from the board. ; -; - +; When this is optional, WHITE prefers to take 0 points over ; -; - +; removing positive points, and BLACK prefers to take 0 points ; -; - +; over removing negative points. The result of this decision thus ; -; - +; gives only not-unfavorable points for Player for having this option. ; ; - - (= - (optional-remove-value $Player $Val1 $Value) - ( (is $RemoveVal - (- $Val1)) - (negate-for-player $Player $RemoveVal $PVal) - (max 0 $PVal $OptVal) - (negate-for-player $Player $OptVal $Value))) -; - + (= (optional-remove-value $Player $Val1 $Value) + (is $RemoveVal + (- $Val1)) + (negate-for-player $Player $RemoveVal $PVal) + (max 0 $PVal $OptVal) + (negate-for-player $Player $OptVal $Value)) - (= - (piece-victim $Piece $Victim) + (= (piece-victim $Piece $Victim) (piece-victim $Piece $Victim $Effect)) -; - - (= - (piece-victim $Piece $Victim $Effect) + (= (piece-victim $Piece $Victim $Effect) (piece-victim $Piece $Player $Victim $VPlayer $Effect)) -; - - (= - (piece-victim $Piece $Player $Victim $VPlayer $Effect) + (= (piece-victim $Piece $Player $Victim $VPlayer $Effect) (piece-victim $Piece $Player $Victim $VPlayer $Effect $Capture)) -; - - - (= - (piece-victim $Piece $Player $Victim $VPlayer $Effect $Capture) - ( (piece-index $Piece $PI) - (owns $Piece $Player) - (owns $Victim $VPlayer) - (current-game-for-player $Player $Game) - (game-piece-has-capture $Piece $Capture $Game) - (capture-type $Capture $Type) - (capture-effect $Capture $Effect) - (matches $Type $Victim))) -; + (= (piece-victim $Piece $Player $Victim $VPlayer $Effect $Capture) + (piece-index $Piece $PI) + (owns $Piece $Player) + (owns $Victim $VPlayer) + (current-game-for-player $Player $Game) + (game-piece-has-capture $Piece $Capture $Game) + (capture-type $Capture $Type) + (capture-effect $Capture $Effect) + (matches $Type $Victim)) ; -; +; True when the effect of capturing the victim is not opponent possesses. + (= (threat-piece-victim $Piece $Player $Victim $VPlayer $Effect $Capture) + (piece-victim $Piece $Player $Victim $VPlayer $Effect $Capture) + (not (, (opposite-role $Player $VPlayer) (= $Effect (possess $VPlayer))))) - (= - (threat-piece-victim $Piece $Player $Victim $VPlayer $Effect $Capture) - ( (piece-victim $Piece $Player $Victim $VPlayer $Effect $Capture) (not (, (opposite-role $Player $VPlayer) (= $Effect (possess $VPlayer)))))) -; - - - (= - (victim-counts $Piece $VCount) - ( (unique-victims $Piece $Unique) (length $Unique $VCount))) -; - + (= (victim-counts $Piece $VCount) + (unique-victims $Piece $Unique) + (length $Unique $VCount)) - (= - (unique-victims $Piece $Unique) + (= (unique-victims $Piece $Unique) (unique-victims $Piece $Player $Victim $VPlayer $Effect $Unique)) -; - - - (= - (unique-victims $Piece $Player $Victim $VPlayer $Effect $Unique) - ( (findall $Victim - (threat-piece-victim $Piece $Player $Victim $VPlayer $Effect $Cap) $Victims) (remove-duplicates $Victims $Unique))) -; + (= (unique-victims $Piece $Player $Victim $VPlayer $Effect $Unique) + (findall $Victim + (threat-piece-victim $Piece $Player $Victim $VPlayer $Effect $Cap) $Victims) + (remove-duplicates $Victims $Unique)) - (= - (unique-victimizers $Piece $Unique) + (= (unique-victimizers $Piece $Unique) (unique-victimizers $Piece $Player $Victim $VPlayer $Effect $Unique)) -; + (= (unique-victimizers $Piece $Player $Victim $VPlayer $Effect $Unique) + (findall $Piece + (threat-piece-victim $Piece $Player $Victim $VPlayer $Effect $Cap) $Victims) + (remove-duplicates $Victims $Unique)) - (= - (unique-victimizers $Piece $Player $Victim $VPlayer $Effect $Unique) - ( (findall $Piece - (threat-piece-victim $Piece $Player $Victim $VPlayer $Effect $Cap) $Victims) (remove-duplicates $Victims $Unique))) -; - - - (= - (giveaway-value $Player $Piece $Value) - ( (unique-victimizers $CapPiece $Player $Piece $Player $Effect $Unique) - (length $Unique $VCount) - (is $Value $VCount))) -; + (= (giveaway-value $Player $Piece $Value) + (unique-victimizers $CapPiece $Player $Piece $Player $Effect $Unique) + (length $Unique $VCount) + (is $Value $VCount)) +; ; piece_type_count(Count), - - (= - (immunity-value $Player $Piece $Value) - ( (piece-type-count $Count) - (opposite-role $Player $Opp) - (unique-victimizers $CapPiece $Opp $Piece $Player $Effect $Unique) - (length $Unique $VCount) - (is $Value - (- $Count $VCount)))) -; - + (= (immunity-value $Player $Piece $Value) + (piece-type-count $Count) + (opposite-role $Player $Opp) + (unique-victimizers $CapPiece $Opp $Piece $Player $Effect $Unique) + (length $Unique $VCount) + (is $Value + (- $Count $VCount))) ; -; - - - (= - (player-eradicate-target $Player $Piece) - ( (game-player-has-goal $_ $Player $Goal) - (eradicate-goal $Goal $Descr) - (matches $Descr $Piece))) -; +; True when Player has goal to eradicate piece Piece. + (= (player-eradicate-target $Player $Piece) + (game-player-has-goal $_ $Player $Goal) + (eradicate-goal $Goal $Descr) + (matches $Descr $Piece)) ; -; - +; True when Player has goal to eradicate piece Piece, ; -; - - - (= - (player-stalemate-target $Player $Piece) - ( (game-player-has-goal $_ $Player $Goal) - (stalemate-goal $Goal $Owner) - (owns $Piece $Owner))) -; +; because that helps him to stalemate its owner. + (= (player-stalemate-target $Player $Piece) + (game-player-has-goal $_ $Player $Goal) + (stalemate-goal $Goal $Owner) + (owns $Piece $Owner)) ; -; - +; True when Player has goal to arrive either Piece or something ; -; - - - (= - (player-arrive-generator $Player $Piece $Dist $Tables) - ( (game-player-has-goal $_ $Player $Goal) - (arrive-goal $Goal $Descr $Squares) - (piece-player-prom-distance $Piece $Player $PieceT $Dist $Tables) - (matches $Descr $PieceT))) -; +; Piece could promote into without changing ownership. + (= (player-arrive-generator $Player $Piece $Dist $Tables) + (game-player-has-goal $_ $Player $Goal) + (arrive-goal $Goal $Descr $Squares) + (piece-player-prom-distance $Piece $Player $PieceT $Dist $Tables) + (matches $Descr $PieceT)) @@ -642,216 +425,157 @@ - (= - (max-static-mob $Piece $Val $Tables) - ( (findall $Val1 - (square-piece-mobility $Sq $Piece $Val1 $Tables) $Mobs) (max $Mobs $Val))) -; - + (= (max-static-mob $Piece $Val $Tables) + (findall $Val1 + (square-piece-mobility $Sq $Piece $Val1 $Tables) $Mobs) + (max $Mobs $Val)) - (= - (max-eventual-mob $Piece $Val $Tables) - ( (findall $Val1 - (square-piece-reachability $Sq $Piece $Val1 $Tables) $Mobs) (max $Mobs $Val))) -; - + (= (max-eventual-mob $Piece $Val $Tables) + (findall $Val1 + (square-piece-reachability $Sq $Piece $Val1 $Tables) $Mobs) + (max $Mobs $Val)) - (= - (average-static-mob $Piece $Val $Tables) - ( (findall $Val1 - (square-piece-mobility $Sq $Piece $Val1 $Tables) $Mobs) (average $Mobs $Val))) -; - + (= (average-static-mob $Piece $Val $Tables) + (findall $Val1 + (square-piece-mobility $Sq $Piece $Val1 $Tables) $Mobs) + (average $Mobs $Val)) - (= - (average-eventual-mob $Piece $Val $Tables) - ( (findall $Val1 - (square-piece-reachability $Sq $Piece $Val1 $Tables) $Mobs) (average $Mobs $Val))) -; - + (= (average-eventual-mob $Piece $Val $Tables) + (findall $Val1 + (square-piece-reachability $Sq $Piece $Val1 $Tables) $Mobs) + (average $Mobs $Val)) ; -; - +; -------------------------------------------------------------------------------- ; -; - +; Mediating capture advice ; -; - +; -------------------------------------------------------------------------------- ; ; - ; -; - +; Just like the advice meditation done dynamically, but here applying only to the ; -; - - +; capture advisors. - (= - (capture-evaluation $Piece $Sq $Value $Position $Tables) - ( (get-capture-advices $Piece $Sq $Advice $Position $Tables) (mediate-capture-advices $Advice $Value $Tables))) -; + (= (capture-evaluation $Piece $Sq $Value $Position $Tables) + (get-capture-advices $Piece $Sq $Advice $Position $Tables) + (mediate-capture-advices $Advice $Value $Tables)) - (= - (mediate-capture-advices $Advice $Value $Tables) + (= (mediate-capture-advices $Advice $Value $Tables) (sumlist $Advice $Value)) -; - - - - (= - (get-capture-advices $Piece $Sq $Advices $Position $Tables) - ( (piece-index $Piece $_) (findall $Advice (cap-value $Piece $Player $Victim $Advice $Tables) $Advices))) -; - (= - (get-capture-advices $Piece $Advices) - ( (find-advice-tables $Tables) (get-capture-advices $Piece $Sq $Advices $Position $Tables))) -; + (= (get-capture-advices $Piece $Sq $Advices $Position $Tables) + (piece-index $Piece $_) + (findall $Advice + (cap-value $Piece $Player $Victim $Advice $Tables) $Advices)) + (= (get-capture-advices $Piece $Advices) + (find-advice-tables $Tables) + (get-capture-advices $Piece $Sq $Advices $Position $Tables)) - (= - (show-capture-advices $Piece) - ( (get-capture-advices $Piece $As) (ppl $As))) -; - + (= (show-capture-advices $Piece) + (get-capture-advices $Piece $As) + (ppl $As)) ; -; - +; ============================================================================== ; -; - +; INDEPENDENT PIECE VALUE MATRIX ; -; - +; ============================================================================== - (= - (build-static-matrix $Matrix) + (= (build-static-matrix $Matrix) (map-piece-table static-matrix Nil $Matrix)) -; - - (= - (build-static-matrix $Matrix $Tables) + (= (build-static-matrix $Matrix $Tables) (map-piece-table static-matrix (:: $Tables) $Matrix)) -; - - (= - (print-static-matrix) + (= (print-static-matrix) (print-static-matrix $Piece $Player $StatVal)) -; - - - (= - (print-static-matrix $Piece $Player $StatVal) - ( (format "Player Piece Static Matrix:~n" Nil) (or (, (piece-player-static $Piece $Player $StatVal) (format "~p: ~p -> ~p~n" (:: $Player $Piece $StatVal)) (fail)) True))) -; + (= (print-static-matrix $Piece $Player $StatVal) + (format "Player Piece Static Matrix:~n" Nil) + (or + (, + (piece-player-static $Piece $Player $StatVal) + (format "~p: ~p -> ~p~n" + (:: $Player $Piece $StatVal)) + (fail)) True)) - (= - (pps $Player $Piece $StatVal) + (= (pps $Player $Piece $StatVal) (piece-player-static $Piece $Player $StatVal)) -; - ; -; - +; PIECE_PLAYER_STATIC(?Piece,?Player,?StatVal) ; -; - - - (= - (piece-player-static $Piece $Player $StatVal) - ( (advice-tables $Tables) (piece-player-static $Piece $Player $StatVal $Tables))) -; +; Very nice table indicating static value for Piece owned by Player. + (= (piece-player-static $Piece $Player $StatVal) + (advice-tables $Tables) + (piece-player-static $Piece $Player $StatVal $Tables)) ; -; - +; PIECE_PLAYER_STATIC(?Piece,?Player,?StatVal,+Tables) ; -; - - (= - (piece-player-static $Piece $Player $StatVal $Tables) +; Very nice table indicating static value for Piece owned by Player. + (= (piece-player-static $Piece $Player $StatVal $Tables) (piece-player-static $Piece $PieceI $Player $PlayerI $StatVal $Tables)) -; - - (= - (piece-player-static $Piece $PieceI $Player $PlayerI $StatVal $Tables) - ( (piece-index $Piece $PieceI) - (owns $Piece $Player) - (piece-static-value $PieceI $StatVal $Tables))) -; + (= (piece-player-static $Piece $PieceI $Player $PlayerI $StatVal $Tables) + (piece-index $Piece $PieceI) + (owns $Piece $Player) + (piece-static-value $PieceI $StatVal $Tables)) - - (= - (piece-static-value $PieceI $StatVal $Tables) - ( (static-matrix $Tables $M) (piece-static-val1 $PieceI $StatVal $M))) -; + (= (piece-static-value $PieceI $StatVal $Tables) + (static-matrix $Tables $M) + (piece-static-val1 $PieceI $StatVal $M)) - - (= - (piece-static-val1 $PieceI $StatVal $M) + (= (piece-static-val1 $PieceI $StatVal $M) (pindex-table-entry $PieceI $M $StatVal)) -; - - (= - (static-matrix $Piece $PIndex $Value) - ( (find-advice-tables $Tables) (static-matrix $Piece $PIndex $Value $Tables))) -; - + (= (static-matrix $Piece $PIndex $Value) + (find-advice-tables $Tables) + (static-matrix $Piece $PIndex $Value $Tables)) ; -; - - (= - (static-matrix $Piece $PIndex $Tables $Value) - ( (piece-index $Piece $PIndex) - (static-evaluation $Piece $Sq $Value $Position $Tables) - (tracing-anal-format tables "Built independent matrix for <~p>~n" - (:: $Piece)))) -; - +; Tables not last so can be used with map_piece_table. + (= (static-matrix $Piece $PIndex $Tables $Value) + (piece-index $Piece $PIndex) + (static-evaluation $Piece $Sq $Value $Position $Tables) + (tracing-anal-format tables "Built independent matrix for <~p>~n" + (:: $Piece))) diff --git a/metagame/learning/struct.metta b/metagame/learning/struct.metta index 4b7ad78..2c59296 100644 --- a/metagame/learning/struct.metta +++ b/metagame/learning/struct.metta @@ -1,457 +1,304 @@ +; (convert_to_metta_file struct $_119626 metagame/learning/struct.pl metagame/learning/struct.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; building all tables. - (= - (build-tables) - ( (new-empty-state $State) (build-tables $State))) -; + (= (build-tables) + (new-empty-state $State) + (build-tables $State)) +; ; for testing - - (= - (build-tables $State) + (= (build-tables $State) (runtime (build-tables $State $Tables))) -; - - - (= - (build-tables $State $T) - ( (anal-table $T) - (promsq-matrix $T $PromSqMatrix) - (promotion-matrix $T $PromMatrix) - (prom-distance-matrix $T $PromDistMatrix) - (transition-matrix $T $TransMatrix) - (mobility-matrix $T $MobMatrix) - (eventual-matrix $T $EventualMatrix) - (distance-matrix $T $DistMatrix) - (distance-table $T $DistTable) - (active-advisor-table $T $Advisors) - (static-matrix $T $StatMatrix) - (compile-basic-tables) - (tracing-anal-format tables "Building tables ...~n" Nil) - (tracing-anal-timing tables - (build-advisor-table $Advisors)) - (tracing-anal-format tables "Building tables ...~n" Nil) - (tracing-anal-timing tables - (build-promotion-matrix $PromMatrix)) - (tracing-anal-format tables "Building tables ...~n" Nil) - (tracing-anal-timing tables - (build-prom-distance-matrix $PromMatrix $PromDistMatrix)) - (tracing-anal-format tables "Building tables ...~n" Nil) - (tracing-anal-timing tables - (build-transition-matrix $TransMatrix $State)) - (tracing-anal-format tables "Building tables ...~n" Nil) - (tracing-anal-timing tables - (build-mobility-matrix $TransMatrix $MobMatrix)) - (tracing-anal-format tables "Building matrices ...~n" Nil) - (tracing-anal-timing tables - (build-distance-matrix $TransMatrix $DistMatrix)) - (tracing-anal-format tables "Building tables ...~n" Nil) - (tracing-anal-timing tables - (build-distance-table $DistMatrix $DistTable)) - (tracing-anal-format tables "Building tables ...~n" Nil) - (tracing-anal-timing tables - (build-eventual-matrix $DistMatrix $EventualMatrix)) - (tracing-anal-format tables "Building tables ...~n" Nil) - (tracing-anal-timing tables - (build-promsq-matrix $DistTable $PromSqMatrix)) - (tracing-anal-format tables "Building tables ...~n" Nil) - (tracing-anal-timing tables - (build-static-matrix $StatMatrix $T)) - (tracing-anal-format tables "Tables completed!~n" Nil) - (save-tables $T))) -; - - - - - - - (= - (clear-tables) - (remove-all-symbols &self - (advice_tables $_))) -; - + (= (build-tables $State $T) + (anal-table $T) + (promsq-matrix $T $PromSqMatrix) + (promotion-matrix $T $PromMatrix) + (prom-distance-matrix $T $PromDistMatrix) + (transition-matrix $T $TransMatrix) + (mobility-matrix $T $MobMatrix) + (eventual-matrix $T $EventualMatrix) + (distance-matrix $T $DistMatrix) + (distance-table $T $DistTable) + (active-advisor-table $T $Advisors) + (static-matrix $T $StatMatrix) + (compile-basic-tables) + (tracing-anal-format tables "Building tables ...~n" Nil) + (tracing-anal-timing tables + (build-advisor-table $Advisors)) + (tracing-anal-format tables "Building tables ...~n" Nil) + (tracing-anal-timing tables + (build-promotion-matrix $PromMatrix)) + (tracing-anal-format tables "Building tables ...~n" Nil) + (tracing-anal-timing tables + (build-prom-distance-matrix $PromMatrix $PromDistMatrix)) + (tracing-anal-format tables "Building tables ...~n" Nil) + (tracing-anal-timing tables + (build-transition-matrix $TransMatrix $State)) + (tracing-anal-format tables "Building tables ...~n" Nil) + (tracing-anal-timing tables + (build-mobility-matrix $TransMatrix $MobMatrix)) + (tracing-anal-format tables "Building matrices ...~n" Nil) + (tracing-anal-timing tables + (build-distance-matrix $TransMatrix $DistMatrix)) + (tracing-anal-format tables "Building tables ...~n" Nil) + (tracing-anal-timing tables + (build-distance-table $DistMatrix $DistTable)) + (tracing-anal-format tables "Building tables ...~n" Nil) + (tracing-anal-timing tables + (build-eventual-matrix $DistMatrix $EventualMatrix)) + (tracing-anal-format tables "Building tables ...~n" Nil) + (tracing-anal-timing tables + (build-promsq-matrix $DistTable $PromSqMatrix)) + (tracing-anal-format tables "Building tables ...~n" Nil) + (tracing-anal-timing tables + (build-static-matrix $StatMatrix $T)) + (tracing-anal-format tables "Tables completed!~n" Nil) + (save-tables $T)) + + + + + + (= (clear-tables) + (remove-all-atoms &self + (advice_tables $_))) - (= - (save-tables $Tables) - ( (clear-tables) (add-symbol &self (advice_tables $Tables)))) -; + (= (save-tables $Tables) + ( (clear-tables) (add-is-symbol &self (advice_tables $Tables)))) - (= - (dump-tables $File) + (= (dump-tables $File) (with-output-file $File write dump-tables)) -; - - (= - (dump-tables) + (= (dump-tables) (listing (/ advice-tables 1))) -; - - (= - (load-tables) - ( (read (advice-tables $Tables)) (save-tables $Tables))) -; - + (= (load-tables) + (read (advice-tables $Tables)) + (save-tables $Tables)) - (= - (load-tables $File) - ( (see $File) - (load-tables) - (seen))) -; + (= (load-tables $File) + (see $File) + (load-tables) + (seen)) - - (= - (find-advice-tables-if $T) + (= (find-advice-tables-if $T) (det-if-then-else (var $T) (find-advice-tables $T) True)) -; - - (= - (find-advice-tables $T) + (= (find-advice-tables $T) (det-if-then-else (current-predicate advice-tables (advice-tables $_)) (advice-tables $T) (= $T none))) -; - ; -; - +; Stripped down version, when we just want the basic structure ; -; +; without the real analysis. - - (= - (build-dummy-tables) + (= (build-dummy-tables) (build-dummy-tables $State $Tables)) -; - - - (= - (build-dummy-tables $State $Tables) - ( (anal-table $T) - (active-advisor-table $T $Advisors) - (compile-basic-tables) - (tracing-anal-format tables "Building tables ...~n" Nil) - (tracing-anal-timing tables - (build-advisor-table $Advisors)) - (save-tables $T))) -; + (= (build-dummy-tables $State $Tables) + (anal-table $T) + (active-advisor-table $T $Advisors) + (compile-basic-tables) + (tracing-anal-format tables "Building tables ...~n" Nil) + (tracing-anal-timing tables + (build-advisor-table $Advisors)) + (save-tables $T)) ; -; - +; ============================================================================ ; -; - +; ANAL_TABLE data structure ; -; - +; ============================================================================ ; -; +; Contains a few extra slots for future development. - - (= - (anal-table $N) + (= (anal-table $N) (functor $N tables 15)) -; - - (= - (promsq-matrix $T $M) + (= (promsq-matrix $T $M) (arg 1 $T $M)) -; - - (= - (promotion-matrix $T $M) + (= (promotion-matrix $T $M) (arg 2 $T $M)) -; - - (= - (prom-distance-matrix $T $M) + (= (prom-distance-matrix $T $M) (arg 3 $T $M)) -; - - (= - (transition-matrix $T $M) + (= (transition-matrix $T $M) (arg 4 $T $M)) -; - - (= - (mobility-matrix $T $M) + (= (mobility-matrix $T $M) (arg 5 $T $M)) -; - - (= - (eventual-matrix $T $M) + (= (eventual-matrix $T $M) (arg 6 $T $M)) -; - - (= - (distance-matrix $T $M) + (= (distance-matrix $T $M) (arg 7 $T $M)) -; - - (= - (distance-table $T $M) + (= (distance-table $T $M) (arg 8 $T $M)) -; - - (= - (piece-value-table $T $M) + (= (piece-value-table $T $M) (arg 9 $T $M)) -; - - (= - (piece-square-table $T $M) + (= (piece-square-table $T $M) (arg 10 $T $M)) -; - - (= - (active-advisor-table $T $M) + (= (active-advisor-table $T $M) (arg 11 $T $M)) -; - - (= - (capturing-table $T $M) + (= (capturing-table $T $M) (arg 12 $T $M)) -; - - (= - (moving-table $T $M) + (= (moving-table $T $M) (arg 13 $T $M)) -; - - (= - (static-matrix $T $M) + (= (static-matrix $T $M) (arg 14 $T $M)) -; - - - - - - (= - (promsq-matrix $M) - ( (advice-tables $T) (promsq-matrix $T $M))) -; - - - (= - (promotion-matrix $M) - ( (advice-tables $T) (promotion-matrix $T $M))) -; - - - (= - (prom-distance-matrix $M) - ( (advice-tables $T) (prom-distance-matrix $T $M))) -; - - - (= - (transition-matrix $M) - ( (advice-tables $T) (transition-matrix $T $M))) -; - - - (= - (mobility-matrix $M) - ( (advice-tables $T) (mobility-matrix $T $M))) -; - (= - (eventual-matrix $M) - ( (advice-tables $T) (eventual-matrix $T $M))) -; - (= - (distance-matrix $M) - ( (advice-tables $T) (distance-matrix $T $M))) -; + (= (promsq-matrix $M) + (advice-tables $T) + (promsq-matrix $T $M)) + (= (promotion-matrix $M) + (advice-tables $T) + (promotion-matrix $T $M)) - (= - (distance-table $M) - ( (advice-tables $T) (distance-table $T $M))) -; + (= (prom-distance-matrix $M) + (advice-tables $T) + (prom-distance-matrix $T $M)) + (= (transition-matrix $M) + (advice-tables $T) + (transition-matrix $T $M)) + (= (mobility-matrix $M) + (advice-tables $T) + (mobility-matrix $T $M)) - (= - (piece-value-table $M) - ( (advice-tables $T) (piece-value-table $T $M))) -; + (= (eventual-matrix $M) + (advice-tables $T) + (eventual-matrix $T $M)) + (= (distance-matrix $M) + (advice-tables $T) + (distance-matrix $T $M)) - (= - (piece-square-table $M) - ( (advice-tables $T) (piece-square-table $T $M))) -; + (= (distance-table $M) + (advice-tables $T) + (distance-table $T $M)) - (= - (active-advisor-table $M) - ( (advice-tables $T) (active-advisor-table $T $M))) -; - + (= (piece-value-table $M) + (advice-tables $T) + (piece-value-table $T $M)) - (= - (static-matrix $M) - ( (advice-tables $T) (static-matrix $T $M))) -; + (= (piece-square-table $M) + (advice-tables $T) + (piece-square-table $T $M)) + (= (active-advisor-table $M) + (advice-tables $T) + (active-advisor-table $T $M)) + (= (static-matrix $M) + (advice-tables $T) + (static-matrix $T $M)) - (= - (add-portray-anal-table) - ( (anal-table $T) (add-symbol &self (:- (portray $T) (portray_anal_table $T))))) -; + (= (add-portray-anal-table) + ( (anal-table $T) (add-is-symbol &self (:- (portray $T) (portray_anal_table $T))))) - (= - (portray-anal-table $T) + (= (portray-anal-table $T) (format "" Nil)) -; - ; -; - +; ============================================================================ ; -; - +; ACTIVE_ADVISOR_TABLE data structure ; -; - - - - (= - (shutdown-advisor $Advisor $Table) - ( (active-advisor-table $Table $M) - (advisor-number $Advisor $Number) - (arg $Number $M off))) -; - - +; ============================================================================ - (= - (active-advisor $Advisor $Table) - ( (active-advisor-table $Table $M) - (advisor-number $Advisor $Number) - (arg $Number $M $Status) - (\== $Status off))) -; + (= (shutdown-advisor $Advisor $Table) + (active-advisor-table $Table $M) + (advisor-number $Advisor $Number) + (arg $Number $M off)) - (= - (advisor_number threat 1) True) -; + (= (active-advisor $Advisor $Table) + (active-advisor-table $Table $M) + (advisor-number $Advisor $Number) + (arg $Number $M $Status) + (\== $Status off)) - (= - (advisor_number prom 2) True) -; - (= - (advisor_number dynamic_mobility 3) True) -; + (= (advisor_number threat 1) True) + (= (advisor_number prom 2) True) + (= (advisor_number dynamic_mobility 3) True) + (= (number_of_advisors 3) True) - (= - (number_of_advisors 3) True) -; - - - - (= - (build-advisor-table $T) - ( (number-of-advisors $N) (functor $T active-advisors $N))) -; + (= (build-advisor-table $T) + (number-of-advisors $N) + (functor $T active-advisors $N)) ; -; - +; ================================================================================ ; -; - +; Interface ; -; - +; ================================================================================ - (= - (build-top) + (= (build-top) (build-tables)) -; - - (= - (showstatic-top) + (= (showstatic-top) (print-static-matrix)) -; - diff --git a/metagame/learning/tables.metta b/metagame/learning/tables.metta index a755646..d77ed06 100644 --- a/metagame/learning/tables.metta +++ b/metagame/learning/tables.metta @@ -1,1400 +1,931 @@ +; (convert_to_metta_file tables $_278996 metagame/learning/tables.pl metagame/learning/tables.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ============================================================================= ; -; - +; Converting square_tables to weighted digraph matrices. ; -; - +; ============================================================================= ; -; - +; At top level, certainly good to use a fixed structure, ; -; - +; as always have entries for those squares. ; -; - +; At second level, don't always have entries. ; -; - +; Could actually decide on best representation given ; -; - +; number of args to be mapped, where if small use list ; -; - +; and if large use array. ; -; - +; Accessing routines would have to check which is used, ; -; - - - - (= - (matrix-to-square-table Nil $A) - ( (set-det) (new-square-table $A))) -; - - (= - (matrix-to-square-table - (Cons - (- $V $E) $D) $A) - ( (matrix-to-square-table $D $A) - (pairs-to-square-table $E $A2) - (arg $V $A $A2))) -; - - - - (= - (pairs-to-square-table Nil $A) - ( (set-det) (new-square-table $A))) -; - - (= - (pairs-to-square-table - (Cons - (- $V $W) $D) $A) - ( (pairs-to-square-table $D $A) (arg $V $A $W))) -; +; but that's not hard. + (= (matrix-to-square-table Nil $A) + (set-det) + (new-square-table $A)) + (= (matrix-to-square-table (Cons (- $V $E) $D) $A) + (matrix-to-square-table $D $A) + (pairs-to-square-table $E $A2) + (arg $V $A $A2)) - (= - (square-table-to-matrix $A $D) - ( (square-table-to-list $A $List) (square-tables-to-matrix $List $D))) -; + (= (pairs-to-square-table Nil $A) + (set-det) + (new-square-table $A)) + (= (pairs-to-square-table (Cons (- $V $W) $D) $A) + (pairs-to-square-table $D $A) + (arg $V $A $W)) - (= - (square_tables_to_matrix () ()) True) -; + (= (square-table-to-matrix $A $D) + (square-table-to-list $A $List) + (square-tables-to-matrix $List $D)) - (= - (square-tables-to-matrix - (Cons - (- $I $A) $ARest) - (Cons - (- $I $D) $DRest)) - ( (square-table-to-list $A $D) (square-tables-to-matrix $ARest $DRest))) -; + (= (square_tables_to_matrix () ()) True) + (= (square-tables-to-matrix (Cons (- $I $A) $ARest) (Cons (- $I $D) $DRest)) + (square-table-to-list $A $D) + (square-tables-to-matrix $ARest $DRest)) ; -; - +; ============================================================================= ; -; - +; Converting weighted digraphs to logarithmic arrays (not used now) ; -; - - +; ============================================================================= - (= - (d-to-array Nil $A) - ( (set-det) (new-array $A))) -; - (= - (d-to-array - (Cons - (- $V $E) $D) $A) - ( (d-to-array $D $A1) - (pairs-to-array $E $A2) - (aset $V $A1 $A2 $A))) -; + (= (d-to-array Nil $A) + (set-det) + (new-array $A)) + (= (d-to-array (Cons (- $V $E) $D) $A) + (d-to-array $D $A1) + (pairs-to-array $E $A2) + (aset $V $A1 $A2 $A)) + (= (pairs-to-array Nil $A) + (set-det) + (new-array $A)) + (= (pairs-to-array (Cons (- $V $W) $D) $A) + (pairs-to-array $D $A1) + (aset $V $A1 $W $A)) - (= - (pairs-to-array Nil $A) - ( (set-det) (new-array $A))) -; - (= - (pairs-to-array - (Cons - (- $V $W) $D) $A) - ( (pairs-to-array $D $A1) (aset $V $A1 $W $A))) -; + (= (array-to-d $A $D) + (alist $A $List) + (arrays-to-d $List $D)) - - (= - (array-to-d $A $D) - ( (alist $A $List) (arrays-to-d $List $D))) -; - - - - (= - (arrays_to_d () ()) True) -; - - (= - (arrays-to-d - (Cons - (- $I $A) $ARest) - (Cons - (- $I $D) $DRest)) - ( (alist $A $D) (arrays-to-d $ARest $DRest))) -; - + (= (arrays_to_d () ()) True) + (= (arrays-to-d (Cons (- $I $A) $ARest) (Cons (- $I $D) $DRest)) + (alist $A $D) + (arrays-to-d $ARest $DRest)) ; -; - +; ================================================================================ ; -; - +; make_basic_tables ; -; - +; ================================================================================ ; -; - +; Do 'trace savetables' to keep these tables around, ; -; - +; otherwise they get cleaned up. ; -; - +; We use the temp file here to avoid several processes ; -; - +; writing to the same one at once. - (= - (compile-basic-tables) + (= (compile-basic-tables) (with-temp-file basic $File (, (compile-basic-tables-to-file $File) (compile $File)))) -; - - (= - (compile-basic-tables-to-file $File) - ( (format "~nCompiling Basic Tables to file: ~w~n" - (:: $File)) - (make-basic-tables) - (with-output-file $File write list-basic-tables))) -; - + (= (compile-basic-tables-to-file $File) + (format "~nCompiling Basic Tables to file: ~w~n" + (:: $File)) + (make-basic-tables) + (with-output-file $File write list-basic-tables)) - (= - (list-basic-tables) + (= (list-basic-tables) (whenever (basic-table-pred $Pred) (listing $Pred))) -; + (= (make-basic-tables) + (assert-square-indices) + (assert-piece-indices) + (assert-prom-square-indices)) - (= - (make-basic-tables) - ( (assert-square-indices) - (assert-piece-indices) - (assert-prom-square-indices))) -; + (= (basic_table_pred (/ opponent_prom_sq 1)) True) + (= (basic_table_pred (/ player_prom_sq 1)) True) + (= (basic_table_pred (/ prom_square_indices 2)) True) + (= (basic_table_pred (/ piece_type_index 2)) True) + (= (basic_table_pred (/ piece_type_count 1)) True) + (= (basic_table_pred (/ index_to_piece 2)) True) + (= (basic_table_pred (/ total_piece_count 1)) True) - (= - (basic_table_pred - (/ opponent_prom_sq 1)) True) -; - - (= - (basic_table_pred - (/ player_prom_sq 1)) True) -; - - (= - (basic_table_pred - (/ prom_square_indices 2)) True) -; - - - (= - (basic_table_pred - (/ piece_type_index 2)) True) -; - - (= - (basic_table_pred - (/ piece_type_count 1)) True) -; - - (= - (basic_table_pred - (/ index_to_piece 2)) True) -; - - (= - (basic_table_pred - (/ total_piece_count 1)) True) -; - - - (= - (basic_table_pred - (/ index_to_square 2)) True) -; - - (= - (basic_table_pred - (/ total_square_count 1)) True) -; - - (= - (basic_table_pred - (/ board_dim 1)) True) -; - + (= (basic_table_pred (/ index_to_square 2)) True) + (= (basic_table_pred (/ total_square_count 1)) True) + (= (basic_table_pred (/ board_dim 1)) True) ; -; - +; ================================================================================ ; -; - +; SQUARE_TABLE data structure ; -; - +; ================================================================================ - (= - (new-square-table $A) + (= (new-square-table $A) (square-table $A)) -; - - (= - (square-table-distance $Item1 $Item2 $Table $Distance) - ( (arg $Item1 $Table $Sub) - (arg $Item2 $Sub $Distance1) - (interpret-distance $Distance1 $Distance))) -; + (= (square-table-distance $Item1 $Item2 $Table $Distance) + (arg $Item1 $Table $Sub) + (arg $Item2 $Sub $Distance1) + (interpret-distance $Distance1 $Distance)) - - (= - (square-matrix-distance $Item1 $Item2 $Table $Distance) - ( (member1-pair - (- $Item1 $Sub) $Table) - (member1-pair - (- $Item2 $Distance1) $Sub) - (interpret-distance $Distance1 $Distance))) -; - + (= (square-matrix-distance $Item1 $Item2 $Table $Distance) + (member1-pair + (- $Item1 $Sub) $Table) + (member1-pair + (- $Item2 $Distance1) $Sub) + (interpret-distance $Distance1 $Distance)) ; -; - +; Could make clause for default distance when non-reachable. - (= - (interpret-distance $Distance $Distance) + (= (interpret-distance $Distance $Distance) (nonvar $Distance)) -; - - - (= - (square-table-to-list $A $List) - ( (functor $A square-table $N) (sqtl 1 $N $A $List))) -; - + (= (square-table-to-list $A $List) + (functor $A square-table $N) + (sqtl 1 $N $A $List)) - (= - (sqtl $N1 $N $A Nil) - ( (> $N1 $N) (set-det))) -; - - (= - (sqtl $N $Max $A - (Cons - (- $N $I) $In)) - ( (arg $N $A $I) - (is $N1 - (+ $N 1)) - (sqtl $N1 $Max $A $In))) -; + (= (sqtl $N1 $N $A Nil) + (> $N1 $N) + (set-det)) + (= (sqtl $N $Max $A (Cons (- $N $I) $In)) + (arg $N $A $I) + (is $N1 + (+ $N 1)) + (sqtl $N1 $Max $A $In)) - (= - (square-table $Table) - ( (total-square-count $Count) (functor $Table square-table $Count))) -; - + (= (square-table $Table) + (total-square-count $Count) + (functor $Table square-table $Count)) - (= - (sindex-table-entry $Index $Table $Entry) + (= (sindex-table-entry $Index $Table $Entry) (arg $Index $Table $Entry)) -; - ; -; - +; An sl_table is like a square table where each ; -; - - - (= - (slindex-table-entries $Index $Table $List $Data) - ( (arg $Index $Table $Val) - (nonvar $Val) - (= $Val - (/ $List $Data)))) -; +; element is a structure: List/Data, instead of a normal value. + (= (slindex-table-entries $Index $Table $List $Data) + (arg $Index $Table $Val) + (nonvar $Val) + (= $Val + (/ $List $Data))) ; -; - - - (= - (slindex-table-entry $Index $Table $Entry $Data) - ( (slindex-table-entries $Index $Table $List $Data) (member $Entry $List))) -; +; Like the above, but here backtrack over elements of that list. + (= (slindex-table-entry $Index $Table $Entry $Data) + (slindex-table-entries $Index $Table $List $Data) + (member $Entry $List)) - (= - (square-table-entry $Square $Index $Table $Entry) - ( (square-index $Square $Index) (sindex-table-entry $Index $Table $Entry))) -; - + (= (square-table-entry $Square $Index $Table $Entry) + (square-index $Square $Index) + (sindex-table-entry $Index $Table $Entry)) - (= - (square-indices $Is) + (= (square-indices $Is) (setof $I (^ $P (square-index $P $I)) $Is)) -; - ; -; - +; ================================================================================ ; -; - +; Mapping square tables ; -; - +; ================================================================================ ; -; - +; Example: ; -; - +; map_square_table(transition_table,Square,SIndex,[Matrix],Table) ; -; - +; Will call the predicate: ; -; - +; transition_table(Square,SIndex,Matrix,Entry) ; -; - +; With each Entry being the corresponding slot of the Square'th ; -; - +; entry in the final Table. ; -; - +; Here we're saying args must be insensitive to side-effects. ; -; - +; That is, we are using the same copy of the args each time. - (= - (map-square-table $Pred $Table) + (= (map-square-table $Pred $Table) (map-square-table $Pred Nil $Table)) -; - - - (= - (map-square-table $Pred $Args $Table) - ( (square-table $Table) - (square-indices $Indices) - (map-for-squares $Indices $Pred $Args $Table))) -; - - - - (= - (map_for_squares () $_ $_ $_) True) -; - - (= - (map-for-squares - (Cons $S $Ss) $Pred $Args $Table) - ( (square-table-entry $Square $S $Table $Entry) - (append - (Cons $Pred - (Cons $Square - (Cons $S $Args))) - (:: $Entry) $GoalList) - (=.. $Goal $GoalList) - (call $Goal) - (map-for-squares $Ss $Pred $Args $Table))) -; + (= (map-square-table $Pred $Args $Table) + (square-table $Table) + (square-indices $Indices) + (map-for-squares $Indices $Pred $Args $Table)) + + + (= (map_for_squares () $_ $_ $_) True) + (= (map-for-squares (Cons $S $Ss) $Pred $Args $Table) + (square-table-entry $Square $S $Table $Entry) + (append + (Cons $Pred + (Cons $Square + (Cons $S $Args))) + (:: $Entry) $GoalList) + (=.. $Goal $GoalList) + (call $Goal) + (map-for-squares $Ss $Pred $Args $Table)) ; -; - +; Maps a goal across to corresponding square tables. ; -; - +; maps_square_table(transition_table,Square,PIndex,[Matrix],Entry) ; -; - +; transition_table(Square,PIndex,Matrix,Entry) - (= - (maps-square-table $Pred $Table1 $Table2) + (= (maps-square-table $Pred $Table1 $Table2) (maps-square-table $Pred Nil $Table1 $Table2)) -; - - - (= - (maps-square-table $Pred $Args $Table1 $Table2) - ( (square-table $Table1) - (square-table $Table2) - (square-indices $Indices) - (maps-for-squares $Indices $Pred $Args $Table1 $Table2))) -; - - - - (= - (maps_for_squares () $_ $_ $_ $_) True) -; - - (= - (maps-for-squares - (Cons $S $Ss) $Pred $Args $Table1 $Table2) - ( (square-table-entry $Square $S $Table1 $Entry1) - (square-table-entry $Square $S $Table2 $Entry2) - (append - (Cons $Pred - (Cons $Square - (Cons $S $Args))) - (:: $Entry1 $Entry2) $GoalList) - (=.. $Goal $GoalList) - (call $Goal) - (maps-for-squares $Ss $Pred $Args $Table1 $Table2))) -; + (= (maps-square-table $Pred $Args $Table1 $Table2) + (square-table $Table1) + (square-table $Table2) + (square-indices $Indices) + (maps-for-squares $Indices $Pred $Args $Table1 $Table2)) + + + (= (maps_for_squares () $_ $_ $_ $_) True) + (= (maps-for-squares (Cons $S $Ss) $Pred $Args $Table1 $Table2) + (square-table-entry $Square $S $Table1 $Entry1) + (square-table-entry $Square $S $Table2 $Entry2) + (append + (Cons $Pred + (Cons $Square + (Cons $S $Args))) + (:: $Entry1 $Entry2) $GoalList) + (=.. $Goal $GoalList) + (call $Goal) + (maps-for-squares $Ss $Pred $Args $Table1 $Table2)) ; -; - +; Counts the number of square indices for ; -; - +; which Goal is true. ; -; - +; This is often an easy way to count some function ; -; +; across the whole board. - - (= - (count-bagof-squares $Sq $Goal $Squares) + (= (count-bagof-squares $Sq $Goal $Squares) (count-bagof $Sq (^ (, $X $Y) (, (square-to-index $X $Y $Sq) $Goal)) $Squares)) -; - - - (= - (add-portray-square-table) - ( (new-square-table $T) (add-symbol &self (:- (portray $T) (portray_square_table $T))))) -; + (= (add-portray-square-table) + ( (new-square-table $T) (add-is-symbol &self (:- (portray $T) (portray_square_table $T))))) - (= - (portray-square-table $T) + (= (portray-square-table $T) (format "" Nil)) -; - ; -; - +; ================================================================================ ; -; - +; PIECE_TABLE data structure ; -; +; ================================================================================ - - (= - (new-piece-table $A) + (= (new-piece-table $A) (piece-table $A)) -; + (= (piece-table $Table) + (total-piece-count $Count) + (functor $Table piece-table $Count)) - (= - (piece-table $Table) - ( (total-piece-count $Count) (functor $Table piece-table $Count))) -; - - - (= - (pindex-table-entry $Index $Table $Entry) + (= (pindex-table-entry $Index $Table $Entry) (arg $Index $Table $Entry)) -; - - (= - (piece-table-entry $Piece $Index $Table $Entry) - ( (piece-index $Piece $Index) (pindex-table-entry $Index $Table $Entry))) -; - + (= (piece-table-entry $Piece $Index $Table $Entry) + (piece-index $Piece $Index) + (pindex-table-entry $Index $Table $Entry)) - (= - (piece-matrix-distance $Item1 $Item2 $Table $Distance) - ( (member1-pair - (- $Item1 $Sub) $Table) - (member1-pair - (- $Item2 $Distance1) $Sub) - (interpret-distance $Distance1 $Distance))) -; - + (= (piece-matrix-distance $Item1 $Item2 $Table $Distance) + (member1-pair + (- $Item1 $Sub) $Table) + (member1-pair + (- $Item2 $Distance1) $Sub) + (interpret-distance $Distance1 $Distance)) - (= - (piece-indices $Is) + (= (piece-indices $Is) (setof $I (^ $P (piece-index $P $I)) $Is)) -; - - (= - (add-portray-piece-table) - ( (new-piece-table $T) (add-symbol &self (:- (portray $T) (portray_piece_table $T))))) -; - + (= (add-portray-piece-table) + ( (new-piece-table $T) (add-is-symbol &self (:- (portray $T) (portray_piece_table $T))))) - (= - (portray-piece-table $T) + (= (portray-piece-table $T) (format "" Nil)) -; - - - (= - (portray-tables) - ( (add-portray-piece-table) (add-portray-square-table))) -; + (= (portray-tables) + (add-portray-piece-table) + (add-portray-square-table)) ; -; - +; ================================================================================ ; -; - +; Mapping piece tables ; -; - +; ================================================================================ ; -; - +; Example: ; -; - +; map_piece_table(transition_table,Piece,PIndex,[Matrix],Table) ; -; - +; Will call the predicate: ; -; - +; transition_table(Piece,PIndex,Matrix,Entry) ; -; - +; With each Entry being the corresponding slot of the Piece'th ; -; - +; entry in the final Table. ; -; - +; Here we're saying args must be insensitive to side-effects. ; -; - +; That is, we are using the same copy of the args each time. - (= - (map-piece-table $Pred $Table) + (= (map-piece-table $Pred $Table) (map-piece-table $Pred Nil $Table)) -; - - - (= - (map-piece-table $Pred $Args $Table) - ( (piece-table $Table) - (piece-indices $Indices) - (map-for-pieces $Indices $Pred $Args $Table))) -; - - - - (= - (map_for_pieces () $_ $_ $_) True) -; - - (= - (map-for-pieces - (Cons $P $Ps) $Pred $Args $Table) - ( (piece-table-entry $Piece $P $Table $Entry) - (append - (Cons $Pred - (Cons $Piece - (Cons $P $Args))) - (:: $Entry) $GoalList) - (=.. $Goal $GoalList) - (call $Goal) - (map-for-pieces $Ps $Pred $Args $Table))) -; + (= (map-piece-table $Pred $Args $Table) + (piece-table $Table) + (piece-indices $Indices) + (map-for-pieces $Indices $Pred $Args $Table)) + + + (= (map_for_pieces () $_ $_ $_) True) + (= (map-for-pieces (Cons $P $Ps) $Pred $Args $Table) + (piece-table-entry $Piece $P $Table $Entry) + (append + (Cons $Pred + (Cons $Piece + (Cons $P $Args))) + (:: $Entry) $GoalList) + (=.. $Goal $GoalList) + (call $Goal) + (map-for-pieces $Ps $Pred $Args $Table)) ; -; - +; Maps a goal across to corresponding piece tables. ; -; - +; maps_piece_table(transition_table,Piece,PIndex,[Matrix],Entry) ; -; - +; transition_table(Piece,PIndex,Matrix,Entry) - (= - (maps-piece-table $Pred $Table1 $Table2) + (= (maps-piece-table $Pred $Table1 $Table2) (maps-piece-table $Pred Nil $Table1 $Table2)) -; - - - (= - (maps-piece-table $Pred $Args $Table1 $Table2) - ( (piece-table $Table1) - (piece-table $Table2) - (piece-indices $Indices) - (maps-for-pieces $Indices $Pred $Args $Table1 $Table2))) -; + (= (maps-piece-table $Pred $Args $Table1 $Table2) + (piece-table $Table1) + (piece-table $Table2) + (piece-indices $Indices) + (maps-for-pieces $Indices $Pred $Args $Table1 $Table2)) - (= - (maps_for_pieces () $_ $_ $_ $_) True) -; - - (= - (maps-for-pieces - (Cons $P $Ps) $Pred $Args $Table1 $Table2) - ( (piece-table-entry $Piece $P $Table1 $Entry1) - (piece-table-entry $Piece $P $Table2 $Entry2) - (append - (Cons $Pred - (Cons $Piece - (Cons $P $Args))) - (:: $Entry1 $Entry2) $GoalList) - (=.. $Goal $GoalList) - (call $Goal) - (maps-for-pieces $Ps $Pred $Args $Table1 $Table2))) -; - + (= (maps_for_pieces () $_ $_ $_ $_) True) + (= (maps-for-pieces (Cons $P $Ps) $Pred $Args $Table1 $Table2) + (piece-table-entry $Piece $P $Table1 $Entry1) + (piece-table-entry $Piece $P $Table2 $Entry2) + (append + (Cons $Pred + (Cons $Piece + (Cons $P $Args))) + (:: $Entry1 $Entry2) $GoalList) + (=.. $Goal $GoalList) + (call $Goal) + (maps-for-pieces $Ps $Pred $Args $Table1 $Table2)) ; -; - +; ============================================================================== ; -; - +; Making Square Index Table ; -; - +; ============================================================================== ; -; - +; SQUARE_INDEX(?Square,?Index) ; -; - +; True when square-struct SQUARE has the Index in the table. ; -; - +; This is Bidirectional, and gives indexing for both arguments. ; -; - +; If both args are unbound, will generate all squares and their indices ; -; - +; for the current game. ; -; - +; Square should be a square_struct: square(type,player). ; -; - +; This should only be used after the table has been created with ; -; - +; ASSERT_SQUARE_INDICES. ; ; - - (= - (square-index $Square $Index) + (= (square-index $Square $Index) (det-if-then-else (var $Index) (square-to-index $Square $Index) (index-to-square $Index $Square))) -; - - (= - (current-board-dim $Dim) + (= (current-board-dim $Dim) (current-board-size $Dim $Y)) -; - +; ; current_board_size(_X,Dim). ; -; - +; Makes available the pred: BOARD_DIM/1. - (= - (set-board-dim) + (= (set-board-dim) ( (abolish (/ board-dim 1)) (current-board-dim $Dim) - (add-symbol &self + (add-is-symbol &self (board_dim $Dim)))) -; - ; -; +; Makes available the pred: TOTAL_SQUARE_COUNT/1. - - (= - (set-square-count) + (= (set-square-count) ( (set-board-dim) (abolish (/ total-square-count 1)) (current-board-size $X $Y) (is $Total (* $X $Y)) - (add-symbol &self + (add-is-symbol &self (total_square_count $Total)))) -; - ; -; - - - (= - (assert-square-indices) - ( (abolish (/ index-to-square 2)) - (set-square-count) - (whenever - (square-to-index $Square $Key) - (assert-square-index $Square $Key)) - (tracing-anal index print-square-indices))) -; +; Makes a table mapping each index into a different square struct. + (= (assert-square-indices) + (abolish (/ index-to-square 2)) + (set-square-count) + (whenever + (square-to-index $Square $Key) + (assert-square-index $Square $Key)) + (tracing-anal index print-square-indices)) - (= - (assert-square-index $Square $Index) - (add-symbol &self + (= (assert-square-index $Square $Index) + (add-is-symbol &self (index_to_square $Index $Square))) -; - - - - (= - (print-square-indices) - ( (format "Square Index Table:~n" Nil) (or (, (index-to-square $I $P) (format "~p --> ~p~n" (:: $I $P)) (fail)) True))) -; - - (= - (square-to-index - (square $X $Y) $Index) - ( (board-square $X $Y) - (board-dim $Dim) - (is $Index - (+ - (* $Dim - (- $Y 1)) $X)))) -; + (= (print-square-indices) + (format "Square Index Table:~n" Nil) + (or + (, + (index-to-square $I $P) + (format "~p --> ~p~n" + (:: $I $P)) + (fail)) True)) - (= - (square-to-index $X $Y $Index) - ( (board-square $X $Y) - (board-dim $Dim) - (is $Index - (+ - (* $Dim - (- $Y 1)) $X)))) -; + (= (square-to-index (square $X $Y) $Index) + (board-square $X $Y) + (board-dim $Dim) + (is $Index + (+ + (* $Dim + (- $Y 1)) $X))) + (= (square-to-index $X $Y $Index) + (board-square $X $Y) + (board-dim $Dim) + (is $Index + (+ + (* $Dim + (- $Y 1)) $X))) - (= - (board-square (square $X $Y)) + (= (board-square (square $X $Y)) (board-square $X $Y)) -; - ; -; - - (= - (board-square $X $Y) - ( (current-board-size $XMax $YMax) - (between 1 $YMax $Y) - (between 1 $XMax $X))) -; +; Need board_square predicate. + (= (board-square $X $Y) + (current-board-size $XMax $YMax) + (between 1 $YMax $Y) + (between 1 $XMax $X)) - - (= - (piece-index $Piece $Index) + (= (piece-index $Piece $Index) (det-if-then-else (var $Index) (piece-to-index $Piece $Index) (index-to-piece $Index $Piece))) -; - +; /* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Piece-Type Index table looks like this: 1 --> firefly 2 --> slug 3 --> termite ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Piece Index table looks like this: 1 --> white firefly 2 --> white slug 3 --> white termite 4 --> black firefly 5 --> black slug 6 --> black termite ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; */ +; ; PIECE_INDEX(?Piece,?Index) ; True when piece-struct PIECE has the Index in the table. ; This is Bidirectional, and gives indexing for both arguments. ; If both args are unbound, will generate all pieces and their indices ; for the current game. ; Piece should be a piece_struct: piece(type,player). ; This should only be used after the table has been created with ; ASSERT_PIECE_INDICES. ; - (= - (current-game-piece-count $Count) - ( (player-current-game $Game) (game-piece-count $Count $Game))) -; - + (= (current-game-piece-count $Count) + (player-current-game $Game) + (game-piece-count $Count $Game)) - (= - (game-piece-count $Count $Game) - ( (game-piece-names $Game $Names) (length $Names $Count))) -; - + (= (game-piece-count $Count $Game) + (game-piece-names $Game $Names) + (length $Names $Count)) - (= - (nth-piece-name $N $P) - ( (player-current-game $G) - (game-piece-names $G $Names) - (nth $N $Names $P))) -; - + (= (nth-piece-name $N $P) + (player-current-game $G) + (game-piece-names $G $Names) + (nth $N $Names $P)) ; -; - - - (= - (assert-piece-indices) - ( (assert-piece-type-indices) - (abolish (/ index-to-piece 2)) - (whenever - (piece-to-index $Piece $Key) - (assert-piece-index $Piece $Key)) - (tracing-anal index print-piece-indices))) -; +; Makes a table mapping each index into a different piece struct. + (= (assert-piece-indices) + (assert-piece-type-indices) + (abolish (/ index-to-piece 2)) + (whenever + (piece-to-index $Piece $Key) + (assert-piece-index $Piece $Key)) + (tracing-anal index print-piece-indices)) - (= - (assert-piece-type-indices) - ( (abolish (/ piece-type-index 2)) - (set-piece-type-count) - (whenever - (nth-piece-name $N $P) - (assert-piece-type-index $P $N)))) -; - + (= (assert-piece-type-indices) + (abolish (/ piece-type-index 2)) + (set-piece-type-count) + (whenever + (nth-piece-name $N $P) + (assert-piece-type-index $P $N))) ; -; - +; Makes available the pred: piece_type_count/1. ; -; +; Also pred: total_piece_count/1 (just double the above). - - (= - (set-piece-type-count) + (= (set-piece-type-count) ( (abolish (/ piece-type-count 1)) (abolish (/ total-piece-count 1)) (current-game-piece-count $Count) - (add-symbol &self + (add-is-symbol &self (piece_type_count $Count)) (is $Total (* $Count 2)) - (add-symbol &self + (add-is-symbol &self (total_piece_count $Total)))) -; - - (= - (assert-piece-type-index $Piece $Index) - (add-symbol &self + (= (assert-piece-type-index $Piece $Index) + (add-is-symbol &self (piece_type_index $Piece $Index))) -; +; ; dir_key(Dir,Key), - - (= - (assert-piece-index $Piece $Index) - (add-symbol &self + (= (assert-piece-index $Piece $Index) + (add-is-symbol &self (index_to_piece $Index $Piece))) -; +; ; piece_key(Piece,Index), - - (= - (print-piece-type-indices) + (= (print-piece-type-indices) (or (, (piece-type-index $P $I) (format "~p --> ~p~n" (:: $I $P)) (fail)) True)) -; - - - - (= - (print-piece-indices) - ( (format "Piece Index Table:~n" Nil) (or (, (index-to-piece $I $P) (format "~p --> ~p~n" (:: $I $P)) (fail)) True))) -; + (= (print-piece-indices) + (format "Piece Index Table:~n" Nil) + (or + (, + (index-to-piece $I $P) + (format "~p --> ~p~n" + (:: $I $P)) + (fail)) True)) - (= - (piece-to-index - (piece $Name $Player) $Key) - ( (piece-player-mult $Player $Mult) - (piece-type-index $Name $Y) - (piece-type-count $Count) - (is $Key - (+ - (* $Count $Mult) $Y)))) -; + (= (piece-to-index (piece $Name $Player) $Key) + (piece-player-mult $Player $Mult) + (piece-type-index $Name $Y) + (piece-type-count $Count) + (is $Key + (+ + (* $Count $Mult) $Y))) - (= - (piece_player_mult player 0) True) -; - - (= - (piece_player_mult opponent 1) True) -; - + (= (piece_player_mult player 0) True) + (= (piece_player_mult opponent 1) True) ; -; - +; ================================================================================ ; -; - +; PLAYER_TABLE data structure ; -; +; ================================================================================ + (= (total_player_count 2) True) - (= - (total_player_count 2) True) -; + (= (player_index player 1) True) + (= (player_index opponent 2) True) - (= - (player_index player 1) True) -; - - (= - (player_index opponent 2) True) -; - - - - (= - (player-table $Table) - ( (total-player-count $Count) (functor $Table player-table $Count))) -; + (= (player-table $Table) + (total-player-count $Count) + (functor $Table player-table $Count)) - - (= - (player-table-entry $Player $Index $Table $Entry) - ( (player-index $Player $Index) (pindex-table-entry $Index $Table $Entry))) -; - + (= (player-table-entry $Player $Index $Table $Entry) + (player-index $Player $Index) + (pindex-table-entry $Index $Table $Entry)) - (= - (player-indices $Is) + (= (player-indices $Is) (setof $I (^ $P (player-index $P $I)) $Is)) -; - ; -; - +; ================================================================================ ; -; - +; Mapping player tables ; -; - +; ================================================================================ ; -; - +; Example: ; -; - +; map_player_table(transition_table,Player,PIndex,[Matrix],Table) ; -; - +; Will call the predicate: ; -; - +; transition_table(Player,PIndex,Matrix,Entry) ; -; - +; With each Entry being the corresponding slot of the Player'th ; -; - +; entry in the final Table. ; -; - +; Here we're saying args must be insensitive to side-effects. ; -; - +; That is, we are using the same copy of the args each time. - (= - (map-player-table $Pred $Table) + (= (map-player-table $Pred $Table) (map-player-table $Pred Nil $Table)) -; - - - (= - (map-player-table $Pred $Args $Table) - ( (player-table $Table) - (player-indices $Indices) - (map-for-players $Indices $Pred $Args $Table))) -; - - - - (= - (map_for_players () $_ $_ $_) True) -; - - (= - (map-for-players - (Cons $P $Ps) $Pred $Args $Table) - ( (player-table-entry $Player $P $Table $Entry) - (append - (Cons $Pred - (Cons $Player - (Cons $P $Args))) - (:: $Entry) $GoalList) - (=.. $Goal $GoalList) - (call $Goal) - (map-for-players $Ps $Pred $Args $Table))) -; + (= (map-player-table $Pred $Args $Table) + (player-table $Table) + (player-indices $Indices) + (map-for-players $Indices $Pred $Args $Table)) + + + (= (map_for_players () $_ $_ $_) True) + (= (map-for-players (Cons $P $Ps) $Pred $Args $Table) + (player-table-entry $Player $P $Table $Entry) + (append + (Cons $Pred + (Cons $Player + (Cons $P $Args))) + (:: $Entry) $GoalList) + (=.. $Goal $GoalList) + (call $Goal) + (map-for-players $Ps $Pred $Args $Table)) ; -; - +; Maps a goal across to corresponding player tables. ; -; - +; maps_player_table(transition_table,Player,PIndex,[Matrix],Entry) ; -; +; transition_table(Player,PIndex,Matrix,Entry) - - (= - (maps-player-table $Pred $Table1 $Table2) + (= (maps-player-table $Pred $Table1 $Table2) (maps-player-table $Pred Nil $Table1 $Table2)) -; - - - (= - (maps-player-table $Pred $Args $Table1 $Table2) - ( (player-table $Table1) - (player-table $Table2) - (player-indices $Indices) - (maps-for-players $Indices $Pred $Args $Table1 $Table2))) -; - + (= (maps-player-table $Pred $Args $Table1 $Table2) + (player-table $Table1) + (player-table $Table2) + (player-indices $Indices) + (maps-for-players $Indices $Pred $Args $Table1 $Table2)) - (= - (maps_for_players () $_ $_ $_ $_) True) -; - - (= - (maps-for-players - (Cons $P $Ps) $Pred $Args $Table1 $Table2) - ( (player-table-entry $Player $P $Table1 $Entry1) - (player-table-entry $Player $P $Table2 $Entry2) - (append - (Cons $Pred - (Cons $Player - (Cons $P $Args))) - (:: $Entry1 $Entry2) $GoalList) - (=.. $Goal $GoalList) - (call $Goal) - (maps-for-players $Ps $Pred $Args $Table1 $Table2))) -; + (= (maps_for_players () $_ $_ $_ $_) True) + (= (maps-for-players (Cons $P $Ps) $Pred $Args $Table1 $Table2) + (player-table-entry $Player $P $Table1 $Entry1) + (player-table-entry $Player $P $Table2 $Entry2) + (append + (Cons $Pred + (Cons $Player + (Cons $P $Args))) + (:: $Entry1 $Entry2) $GoalList) + (=.. $Goal $GoalList) + (call $Goal) + (maps-for-players $Ps $Pred $Args $Table1 $Table2)) ; -; - +; ============================================================================== ; -; - +; Making Promotion Square Index Table ; -; +; ============================================================================== - - (= - (assert-prom-square-indices) - ( (abolish (/ prom-square-indices 2)) - (assert-prom-square-indices player) - (assert-prom-square-indices opponent))) -; - + (= (assert-prom-square-indices) + (abolish (/ prom-square-indices 2)) + (assert-prom-square-indices player) + (assert-prom-square-indices opponent)) - (= - (assert-prom-square-indices $Player) + (= (assert-prom-square-indices $Player) ( (find-prom-square-indices $Player $SqIs) - (add-symbol &self + (add-is-symbol &self (prom_square_indices $Player $SqIs)) (assert-player-prom-sqs $Player $SqIs))) -; + (= (assert-player-prom-sqs player $SqIs) + (abolish (/ player-prom-sq 1)) + (whenever + (member $Sq $SqIs) + (add-is-symbol &self + (player_prom_sq $Sq)))) + (= (assert-player-prom-sqs opponent $SqIs) + (abolish (/ opponent-prom-sq 1)) + (whenever + (member $Sq $SqIs) + (add-is-symbol &self + (opponent_prom_sq $Sq)))) - (= - (assert-player-prom-sqs player $SqIs) - ( (abolish (/ player-prom-sq 1)) (whenever (member $Sq $SqIs) (add-symbol &self (player_prom_sq $Sq))))) -; - - (= - (assert-player-prom-sqs opponent $SqIs) - ( (abolish (/ opponent-prom-sq 1)) (whenever (member $Sq $SqIs) (add-symbol &self (opponent_prom_sq $Sq))))) -; - - - - (= - (player_prom_pred player $Sq - (player_prom_sq $Sq)) True) -; - - (= - (player_prom_pred opponent $Sq - (opponent_prom_sq $Sq)) True) -; + (= (player_prom_pred player $Sq (player_prom_sq $Sq)) True) + (= (player_prom_pred opponent $Sq (opponent_prom_sq $Sq)) True) - (= - (find-prom-square-indices $Player $SqIs) + (= (find-prom-square-indices $Player $SqIs) (prom-sqs $Player $_ $SqIs)) -; - ; -; - +; PLAYER_PROMOTION_SQUARE(?Player,?PlI,?Sq,?SqI) ; -; - +; True if Sq is a square in promotion region for Player, ; -; - +; both with their respective indices. ; -; - - - (= - (player-promotion-square $Player $PlI $Sq $SqI) - ( (player-index $Player $PlI) - (square-index $Sq $SqI) - (prom-square-for-player $Player $SqI))) -; +; This uses the constructed table and is thus very efficient. + (= (player-promotion-square $Player $PlI $Sq $SqI) + (player-index $Player $PlI) + (square-index $Sq $SqI) + (prom-square-for-player $Player $SqI)) - (= - (player-promotion-square $Player $Sq) + (= (player-promotion-square $Player $Sq) (player-promotion-square $Player $PlI $Sq $SqI)) -; - - (= - (prom-square-for-player player $Sq) + (= (prom-square-for-player player $Sq) (player-prom-sq $Sq)) -; - - (= - (prom-square-for-player opponent $Sq) + (= (prom-square-for-player opponent $Sq) (opponent-prom-sq $Sq)) -; - - (= - (in-promote-region $Sq $Player) + (= (in-promote-region $Sq $Player) (player-promotion-square $Player $Sq)) -; - ; -; - - - (= - (prom-sqs $Player $Sqs $SqIs) - ( (setof - (- $Sq $SqI) - (prom-sq $Player $Sq $SqI) $Pairs) (pair-list $Sqs $SqIs $Pairs))) -; +; Could make faster by tabulating. + (= (prom-sqs $Player $Sqs $SqIs) + (setof + (- $Sq $SqI) + (prom-sq $Player $Sq $SqI) $Pairs) + (pair-list $Sqs $SqIs $Pairs)) - (= - (prom-sq $Player $Sq $SqI) - ( (square-index $Sq $SqI) (prom-sq $Player $Sq))) -; - - - (= - (prom-sq $Player $Sq) - ( (current-game-for-player $Player $Game) - (game-promote-rank $Game $Rank) - (invert $Sq $Player $Sq1) - (square $Sq1 $X $Y) - (>= $Y $Rank))) -; + (= (prom-sq $Player $Sq $SqI) + (square-index $Sq $SqI) + (prom-sq $Player $Sq)) + (= (prom-sq $Player $Sq) + (current-game-for-player $Player $Game) + (game-promote-rank $Game $Rank) + (invert $Sq $Player $Sq1) + (square $Sq1 $X $Y) + (>= $Y $Rank)) -; - +; /* ; Random: Time is 0.367 sec. in_promote_region(Sq,Player,_) :- in_promote_region(Sq,Player). */ diff --git a/metagame/learning/tourney.metta b/metagame/learning/tourney.metta index a630aa5..5acc490 100644 --- a/metagame/learning/tourney.metta +++ b/metagame/learning/tourney.metta @@ -1,79 +1,59 @@ +; (convert_to_metta_file tourney $_154582 metagame/learning/tourney.pl metagame/learning/tourney.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; tourney.pl ; -; - +; ================================================================================ ; -; - +; Players for a tournament ; -; - +; ================================================================================ ; -; - +; HOSTTIME_RANDOMIZE ; -; - +; A hacky and expensive way to use the real time ; -; - +; and name of the host to initalize the random seed, ; -; - - - (= - (hosttime-randomize) - ( (hosttime-random-count-mod $X) (dotimes $X (not (, (random $_) (fail)))))) -; +; for when experiments are done on multiple machines. + (= (hosttime-randomize) + (hosttime-random-count-mod $X) + (dotimes $X + (not (, (random $_) (fail))))) - (= - (hosttime-random-count $Count) - ( (realtime-seconds $S) - (shell - (:: 'echo %%') $Process) - (is $Sum - (+ $S $Process)) - (random 1 $Sum $Count))) -; + (= (hosttime-random-count $Count) + (realtime-seconds $S) + (shell + (:: 'echo %%') $Process) + (is $Sum + (+ $S $Process)) + (random 1 $Sum $Count)) - - (= - (hosttime-random-count-mod $X) - ( (hosttime-random-count $Count) (is $X (mod $Count 200)))) -; - + (= (hosttime-random-count-mod $X) + (hosttime-random-count $Count) + (is $X + (mod $Count 200))) @@ -81,877 +61,337 @@ - (= - (do-tourney $Name $File) - ( (tourney-setting $Name $Set) (tourney-to-file $File $Set))) -; - + (= (do-tourney $Name $File) + (tourney-setting $Name $Set) + (tourney-to-file $File $Set)) ; -; - +; Start with a different random seed for each process running a tourney ; -; - - - (= - (tourney-to-file $File $GameMatches) - ( (hosttime-randomize) - (with-output-file $File append - (tourney $GameMatches $LogFile)) - (format "Tourney Done!~n" Nil))) -; +; to avoid duplication. + (= (tourney-to-file $File $GameMatches) + (hosttime-randomize) + (with-output-file $File append + (tourney $GameMatches $LogFile)) + (format "Tourney Done!~n" Nil)) ; -; - - - (= - (tourney Nil $_) - ( (format "Tourney done!~n" Nil) - (current-output $O) - (flush-output $O))) -; - - (= - (tourney - (Cons - (- $Game $Matches) $Rest) $File) - ( (game-matches $Game $Matches $File) (tourney $Rest $File))) -; +; File 2nd arg not used now. Perhaps for log file later. + (= (tourney Nil $_) + (format "Tourney done!~n" Nil) + (current-output $O) + (flush-output $O)) + (= (tourney (Cons (- $Game $Matches) $Rest) $File) + (game-matches $Game $Matches $File) + (tourney $Rest $File)) - (= - (game-matches $Game $Matches $File) - ( (setup-game $Game) (play-matches $Matches))) -; + (= (game-matches $Game $Matches $File) + (setup-game $Game) + (play-matches $Matches)) - - (= - (setup-game $Game) - ( (load-game $Game) - (evalfile-top static) - (build-tables))) -; - + (= (setup-game $Game) + (load-game $Game) + (evalfile-top static) + (build-tables)) - (= - (play_matches ()) True) -; - - (= - (play-matches (Cons $M $Matches)) - ( (play-match $M) (play-matches $Matches))) -; - + (= (play_matches ()) True) + (= (play-matches (Cons $M $Matches)) + (play-match $M) + (play-matches $Matches)) - (= - (play-match (match $White $Black $Number)) - ( (load-player player $White) - (load-player opponent $Black) - (dotimes $Number - (contest $White $Black)))) -; - + (= (play-match (match $White $Black $Number)) + (load-player player $White) + (load-player opponent $Black) + (dotimes $Number + (contest $White $Black))) ; -; - - - (= - (load-player $Role $Name) - ( (player-setting $Name $Search $Params) - (set-role-file $Role $Params) - (player-color $Role $Color) - (player-top $Color $Search))) -; +; Sets the params and search method for a numbered player. + (= (load-player $Role $Name) + (player-setting $Name $Search $Params) + (set-role-file $Role $Params) + (player-color $Role $Color) + (player-top $Color $Search)) - (= - (contest $White $Black) - ( (format "<~p> vs. <~p>~n" - (:: $White $Black)) - (record-seed) - (write-old-seed %%) - (start) - (process-contest-outcome $White $Black))) -; - - - - (= - (process-contest-outcome $White $Black) - ( (player-current-game $G) - (game-name $G $GameName) - (det-if-then-else - (recorded-game-outcome $Role) - (, - (process-contest-outcome $Role $White $Black $Outcome) - (format "Outcome of <~p> -- <~p> vs. <~p>: <~p>~n" - (:: $GameName $White $Black $Outcome))) + (= (contest $White $Black) + (format "<~p> vs. <~p>~n" + (:: $White $Black)) + (record-seed) + (write-old-seed %%) + (start) + (process-contest-outcome $White $Black)) + + + (= (process-contest-outcome $White $Black) + (player-current-game $G) + (game-name $G $GameName) + (det-if-then-else + (recorded-game-outcome $Role) + (, + (process-contest-outcome $Role $White $Black $Outcome) (format "Outcome of <~p> -- <~p> vs. <~p>: <~p>~n" - (:: $GameName $White $Black NOTHING))))) -; - - - (= - (process_contest_outcome player $White $Black $White) True) -; - - (= - (process_contest_outcome opponent $White $Black $Black) True) -; - - (= - (process_contest_outcome draw $_ $_ draw) True) -; + (:: $GameName $White $Black $Outcome))) + (format "Outcome of <~p> -- <~p> vs. <~p>: <~p>~n" + (:: $GameName $White $Black NOTHING)))) + (= (process_contest_outcome player $White $Black $White) True) + (= (process_contest_outcome opponent $White $Black $Black) True) + (= (process_contest_outcome draw $_ $_ draw) True) - (= - (tourney-test) - ( (tourney-setting test $Set) (tourney $Set))) -; - - - - - (= - (tourney_details g1 game1 thesis) True) -; - - (= - (tourney_details g2 game2 thesis) True) -; - - (= - (tourney_details g3 game3 thesis) True) -; - - (= - (tourney_details g4 game4 thesis) True) -; - - (= - (tourney_details g5 game5 thesis) True) -; - - - (= - (tourney_details g123 game1 23) True) -; - - (= - (tourney_details g124 game1 24) True) -; - - (= - (tourney_details g134 game1 34) True) -; - - - - (= - (tourney_details g101 game1 1) True) -; - - (= - (tourney_details g102 game1 2) True) -; - - (= - (tourney_details g103 game1 3) True) -; - - (= - (tourney_details g104 game1 4) True) -; - - - (= - (tourney_details g201 game2 1) True) -; - - (= - (tourney_details g202 game2 2) True) -; - - (= - (tourney_details g203 game2 3) True) -; - - (= - (tourney_details g204 game2 4) True) -; - - - (= - (tourney_details g301 game3 1) True) -; - - (= - (tourney_details g302 game3 2) True) -; - - (= - (tourney_details g303 game3 3) True) -; - - (= - (tourney_details g304 game3 4) True) -; - - - (= - (tourney_details g401 game4 1) True) -; - - (= - (tourney_details g402 game4 2) True) -; + (= (tourney-test) + (tourney-setting test $Set) + (tourney $Set)) - (= - (tourney_details g403 game4 3) True) -; - (= - (tourney_details g404 game4 4) True) -; + (= (tourney_details g1 game1 thesis) True) + (= (tourney_details g2 game2 thesis) True) + (= (tourney_details g3 game3 thesis) True) + (= (tourney_details g4 game4 thesis) True) + (= (tourney_details g5 game5 thesis) True) + (= (tourney_details g123 game1 23) True) + (= (tourney_details g124 game1 24) True) + (= (tourney_details g134 game1 34) True) - (= - (tourney_details g501 game5 1) True) -; - (= - (tourney_details g502 game5 2) True) -; + (= (tourney_details g101 game1 1) True) + (= (tourney_details g102 game1 2) True) + (= (tourney_details g103 game1 3) True) + (= (tourney_details g104 game1 4) True) - (= - (tourney_details g503 game5 3) True) -; + (= (tourney_details g201 game2 1) True) + (= (tourney_details g202 game2 2) True) + (= (tourney_details g203 game2 3) True) + (= (tourney_details g204 game2 4) True) - (= - (tourney_details g504 game5 4) True) -; + (= (tourney_details g301 game3 1) True) + (= (tourney_details g302 game3 2) True) + (= (tourney_details g303 game3 3) True) + (= (tourney_details g304 game3 4) True) + (= (tourney_details g401 game4 1) True) + (= (tourney_details g402 game4 2) True) + (= (tourney_details g403 game4 3) True) + (= (tourney_details g404 game4 4) True) + (= (tourney_details g501 game5 1) True) + (= (tourney_details g502 game5 2) True) + (= (tourney_details g503 game5 3) True) + (= (tourney_details g504 game5 4) True) - (= - (tourney_details g423 game4 23) True) -; - (= - (tourney_details g424 game4 24) True) -; - - (= - (tourney_details g434 game4 34) True) -; + (= (tourney_details g423 game4 23) True) + (= (tourney_details g424 game4 24) True) + (= (tourney_details g434 game4 34) True) ; -; - +; playing random player against everyone on every game ; -; - - (= - (tourney_details g1r0 game1 r0) True) -; - - (= - (tourney_details g1r1 game1 r1) True) -; - - (= - (tourney_details g1r2 game1 r2) True) -; - - (= - (tourney_details g1r3 game1 r3) True) -; - - (= - (tourney_details g1r4 game1 r4) True) -; - - - (= - (tourney_details g2r0 game2 r0) True) -; - - (= - (tourney_details g2r1 game2 r1) True) -; - - (= - (tourney_details g2r2 game2 r2) True) -; - - (= - (tourney_details g2r3 game2 r3) True) -; - - (= - (tourney_details g2r4 game2 r4) True) -; - - - (= - (tourney_details g3r0 game3 r0) True) -; - - (= - (tourney_details g3r1 game3 r1) True) -; - - (= - (tourney_details g3r2 game3 r2) True) -; - - (= - (tourney_details g3r3 game3 r3) True) -; - - (= - (tourney_details g3r4 game3 r4) True) -; - - - (= - (tourney_details g4r0 game4 r0) True) -; - - (= - (tourney_details g4r1 game4 r1) True) -; - - (= - (tourney_details g4r2 game4 r2) True) -; - - (= - (tourney_details g4r3 game4 r3) True) -; - - (= - (tourney_details g4r4 game4 r4) True) -; - - - (= - (tourney_details g5r0 game5 r0) True) -; - - (= - (tourney_details g5r1 game5 r1) True) -; - - (= - (tourney_details g5r2 game5 r2) True) -; - - (= - (tourney_details g5r3 game5 r3) True) -; - - (= - (tourney_details g5r4 game5 r4) True) -; - - - - (= - (tourney_details g1r0a game1 r0a) True) -; +; separately, 10 games each color. + (= (tourney_details g1r0 game1 r0) True) + (= (tourney_details g1r1 game1 r1) True) + (= (tourney_details g1r2 game1 r2) True) + (= (tourney_details g1r3 game1 r3) True) + (= (tourney_details g1r4 game1 r4) True) + (= (tourney_details g2r0 game2 r0) True) + (= (tourney_details g2r1 game2 r1) True) + (= (tourney_details g2r2 game2 r2) True) + (= (tourney_details g2r3 game2 r3) True) + (= (tourney_details g2r4 game2 r4) True) - (= - (tourney_details g1r1a game1 r1a) True) -; + (= (tourney_details g3r0 game3 r0) True) + (= (tourney_details g3r1 game3 r1) True) + (= (tourney_details g3r2 game3 r2) True) + (= (tourney_details g3r3 game3 r3) True) + (= (tourney_details g3r4 game3 r4) True) + (= (tourney_details g4r0 game4 r0) True) + (= (tourney_details g4r1 game4 r1) True) + (= (tourney_details g4r2 game4 r2) True) + (= (tourney_details g4r3 game4 r3) True) + (= (tourney_details g4r4 game4 r4) True) - (= - (tourney_details g1r2a game1 r2a) True) -; + (= (tourney_details g5r0 game5 r0) True) + (= (tourney_details g5r1 game5 r1) True) + (= (tourney_details g5r2 game5 r2) True) + (= (tourney_details g5r3 game5 r3) True) + (= (tourney_details g5r4 game5 r4) True) - (= - (tourney_details g1r3a game1 r3a) True) -; + (= (tourney_details g1r0a game1 r0a) True) + (= (tourney_details g1r1a game1 r1a) True) - (= - (tourney_details g1r4a game1 r4a) True) -; + (= (tourney_details g1r2a game1 r2a) True) + (= (tourney_details g1r3a game1 r3a) True) - (= - (tourney_details g2r02 game1 r02) True) -; + (= (tourney_details g1r4a game1 r4a) True) + (= (tourney_details g2r02 game1 r02) True) - (= - (tourney_details g3r4a game3 r4a) True) -; + (= (tourney_details g3r4a game3 r4a) True) + (= (tourney_details g5a game5 thesis2) True) - (= - (tourney_details g5a game5 thesis2) True) -; + (= (matches_for_setting r02 ((match r 0 2))) True) - (= - (matches_for_setting r02 - ( (match r 0 2))) True) -; + (= (matches_for_setting r0a ((match r 0 10))) True) + (= (matches_for_setting r1a ((match r 1 10))) True) + (= (matches_for_setting 1 ((match 0 1 10))) True) + (= (matches_for_setting 2 ((match 0 2 10))) True) + (= (matches_for_setting 3 ((match 0 3 10))) True) + (= (matches_for_setting 4 ((match 0 4 10))) True) - (= - (matches_for_setting r0a - ( (match r 0 10))) True) -; + (= (matches_for_setting r2a ((match r 2 10))) True) - (= - (matches_for_setting r1a - ( (match r 1 10))) True) -; + (= (matches_for_setting r3a ((match r 3 10))) True) - (= - (matches_for_setting 1 - ( (match 0 1 10))) True) -; - (= - (matches_for_setting 2 - ( (match 0 2 10))) True) -; + (= (matches_for_setting r4a ((match r 4 10))) True) - (= - (matches_for_setting 3 - ( (match 0 3 10))) True) -; - (= - (matches_for_setting 4 - ( (match 0 4 10))) True) -; + (= (matches_for_setting thesis ((match 0 1 1) (match 1 0 1) (match 0 2 1) (match 2 0 1) (match 0 3 1) (match 3 0 1) (match 0 4 1) (match 4 0 1) (match 1 2 1) (match 2 1 1) (match 1 3 1) (match 3 1 1) (match 1 4 1) (match 4 1 1) (match 2 3 1) (match 3 2 1) (match 2 4 1) (match 4 2 1) (match 3 4 1) (match 4 3 1) (match 0 0 2))) True) + (= (matches_for_setting thesis2 ((match 4 3 1) (match 3 4 1) (match 4 2 1) (match 2 4 1) (match 2 3 1) (match 3 2 1) (match 4 1 1) (match 1 4 1))) True) - (= - (matches_for_setting r2a - ( (match r 2 10))) True) -; + (= (matches_for_setting 23 ((match 2 3 2) (match 3 2 2))) True) + (= (matches_for_setting 24 ((match 2 4 2) (match 4 2 2))) True) - (= - (matches_for_setting r3a - ( (match r 3 10))) True) -; + (= (matches_for_setting 34 ((match 3 4 2) (match 4 3 2))) True) - (= - (matches_for_setting r4a - ( (match r 4 10))) True) -; + (= (matches_for_setting r0 ((match 0 r 10) (match r 0 10))) True) + (= (matches_for_setting r1 ((match 1 r 10) (match r 1 10))) True) + (= (matches_for_setting r2 ((match 2 r 10) (match r 2 10))) True) - (= - (matches_for_setting thesis - ( (match 0 1 1) - (match 1 0 1) - (match 0 2 1) - (match 2 0 1) - (match 0 3 1) - (match 3 0 1) - (match 0 4 1) - (match 4 0 1) - (match 1 2 1) - (match 2 1 1) - (match 1 3 1) - (match 3 1 1) - (match 1 4 1) - (match 4 1 1) - (match 2 3 1) - (match 3 2 1) - (match 2 4 1) - (match 4 2 1) - (match 3 4 1) - (match 4 3 1) - (match 0 0 2))) True) -; + (= (matches_for_setting r3 ((match 3 r 10) (match r 3 10))) True) + (= (matches_for_setting r4 ((match 4 r 10) (match r 4 10))) True) - (= - (matches_for_setting thesis2 - ( (match 4 3 1) - (match 3 4 1) - (match 4 2 1) - (match 2 4 1) - (match 2 3 1) - (match 3 2 1) - (match 4 1 1) - (match 1 4 1))) True) -; + (= (tourney-setting $Tourney (:: (- $Game $Matches))) + (tourney-details $Tourney $Game $MatchName) + (set-det) + (matches-for-setting $MatchName $Matches)) - (= - (matches_for_setting 23 - ( (match 2 3 2) (match 3 2 2))) True) -; + (= (tourney_setting test ((- checkers ((match 1 0 1) (match 0 0 1))) (- turncoat_chess ((match 0 0 1))))) True) - (= - (matches_for_setting 24 - ( (match 2 4 2) (match 4 2 2))) True) -; - - - - (= - (matches_for_setting 34 - ( (match 3 4 2) (match 4 3 2))) True) -; - - - - (= - (matches_for_setting r0 - ( (match 0 r 10) (match r 0 10))) True) -; - - - (= - (matches_for_setting r1 - ( (match 1 r 10) (match r 1 10))) True) -; - - - (= - (matches_for_setting r2 - ( (match 2 r 10) (match r 2 10))) True) -; - - - (= - (matches_for_setting r3 - ( (match 3 r 10) (match r 3 10))) True) -; - - - (= - (matches_for_setting r4 - ( (match 4 r 10) (match r 4 10))) True) -; - - - - - - (= - (tourney-setting $Tourney - (:: (- $Game $Matches))) - ( (tourney-details $Tourney $Game $MatchName) - (set-det) - (matches-for-setting $MatchName $Matches))) -; - - - (= - (tourney_setting test - ( (- checkers - ( (match 1 0 1) (match 0 0 1))) (- turncoat_chess ((match 0 0 1))))) True) -; +; +; Just a random player. + (= (player_setting r random ()) True) ; -; +; Just a random_aggressive player. + (= (player_setting 0 random_aggressive ()) True) - (= - (player_setting r random ()) True) -; +; +; Everything, and pthreat. + (= (player_setting 1 iterate ((- gmovmob 1) (- gcapmob 1) (- pthreat 1) (- gthreat 0) (- initprom 1) (- possess 1) (- arrive_distance 100) (- promote_distance 1) (- eventual_mobility 1) (- static 1) (- vital 1) (- max_static_mob 1) (- max_eventual_mob 1) (- eradicate 1) (- victims 1) (- immunity 1) (- giveaway 1) (- eradicate 1) (- stalemate 1) (- arrive 1))) True) +; ;; statics ; -; - - (= - (player_setting 0 random_aggressive ()) True) -; +; Just emob, promdist, arrivedist, and static. + (= (player_setting 2 iterate ((- gmovmob 0) (- gcapmob 0) (- pthreat 0) (- gthreat 0) (- lthreat 0) (- vital 0) (- initprom 1) (- possess 1) (- arrive_distance 100) (- promote_distance 1) (- eventual_mobility 1) (- static 1) (- max_static_mob 1) (- max_eventual_mob 1) (- eradicate 1) (- victims 1) (- immunity 1) (- giveaway 1) (- eradicate 1) (- stalemate 1) (- arrive 1))) True) +; ;; statics ; -; - - (= - (player_setting 1 iterate - ( (- gmovmob 1) - (- gcapmob 1) - (- pthreat 1) - (- gthreat 0) - (- initprom 1) - (- possess 1) - (- arrive_distance 100) - (- promote_distance 1) - (- eventual_mobility 1) - (- static 1) - (- vital 1) - (- max_static_mob 1) - (- max_eventual_mob 1) - (- eradicate 1) - (- victims 1) - (- immunity 1) - (- giveaway 1) - (- eradicate 1) - (- stalemate 1) - (- arrive 1))) True) -; - +; Just emob and static. + (= (player_setting 3 iterate ((- gmovmob 0) (- gcapmob 0) (- pthreat 0) (- gthreat 0) (- lthreat 0) (- vital 0) (- initprom 0) (- possess 0) (- arrive_distance 0) (- promote_distance 0) (- eventual_mobility 1) (- static 1) (- max_static_mob 1) (- max_eventual_mob 1) (- eradicate 1) (- victims 1) (- immunity 1) (- giveaway 1) (- eradicate 1) (- stalemate 1) (- arrive 1))) True) +; ;; statics ; -; - - (= - (player_setting 2 iterate - ( (- gmovmob 0) - (- gcapmob 0) - (- pthreat 0) - (- gthreat 0) - (- lthreat 0) - (- vital 0) - (- initprom 1) - (- possess 1) - (- arrive_distance 100) - (- promote_distance 1) - (- eventual_mobility 1) - (- static 1) - (- max_static_mob 1) - (- max_eventual_mob 1) - (- eradicate 1) - (- victims 1) - (- immunity 1) - (- giveaway 1) - (- eradicate 1) - (- stalemate 1) - (- arrive 1))) True) -; - +; Just promdist and arrivedist + (= (player_setting 4 iterate ((- gmovmob 0) (- gcapmob 0) (- pthreat 0) (- gthreat 0) (- lthreat 0) (- vital 0) (- initprom 0) (- possess 0) (- arrive_distance 100) (- promote_distance 1) (- eventual_mobility 0) (- static 0) (- max_static_mob 1) (- max_eventual_mob 1) (- eradicate 1) (- victims 1) (- immunity 1) (- giveaway 1) (- eradicate 1) (- stalemate 1) (- arrive 1))) True) +; ;; statics ; -; +; Just dynamic mobility. + (= (player_setting 5 iterate ((- gmovmob 1) (- gcapmob 0) (- pthreat 0) (- gthreat 0) (- lthreat 0) (- vital 0) (- initprom 0) (- possess 0) (- arrive_distance 0) (- promote_distance 0) (- eventual_mobility 0) (- static 0) (- max_static_mob 1) (- max_eventual_mob 1) (- eradicate 1) (- victims 1) (- immunity 1) (- giveaway 1) (- eradicate 1) (- stalemate 1) (- arrive 1))) True) +; ;; statics - (= - (player_setting 3 iterate - ( (- gmovmob 0) - (- gcapmob 0) - (- pthreat 0) - (- gthreat 0) - (- lthreat 0) - (- vital 0) - (- initprom 0) - (- possess 0) - (- arrive_distance 0) - (- promote_distance 0) - (- eventual_mobility 1) - (- static 1) - (- max_static_mob 1) - (- max_eventual_mob 1) - (- eradicate 1) - (- victims 1) - (- immunity 1) - (- giveaway 1) - (- eradicate 1) - (- stalemate 1) - (- arrive 1))) True) -; - - - - -; -; - - (= - (player_setting 4 iterate - ( (- gmovmob 0) - (- gcapmob 0) - (- pthreat 0) - (- gthreat 0) - (- lthreat 0) - (- vital 0) - (- initprom 0) - (- possess 0) - (- arrive_distance 100) - (- promote_distance 1) - (- eventual_mobility 0) - (- static 0) - (- max_static_mob 1) - (- max_eventual_mob 1) - (- eradicate 1) - (- victims 1) - (- immunity 1) - (- giveaway 1) - (- eradicate 1) - (- stalemate 1) - (- arrive 1))) True) -; - - - - -; -; - - (= - (player_setting 5 iterate - ( (- gmovmob 1) - (- gcapmob 0) - (- pthreat 0) - (- gthreat 0) - (- lthreat 0) - (- vital 0) - (- initprom 0) - (- possess 0) - (- arrive_distance 0) - (- promote_distance 0) - (- eventual_mobility 0) - (- static 0) - (- max_static_mob 1) - (- max_eventual_mob 1) - (- eradicate 1) - (- victims 1) - (- immunity 1) - (- giveaway 1) - (- eradicate 1) - (- stalemate 1) - (- arrive 1))) True) -; - - - - - -; -; - - (= - (player_setting 6 iterate - ( (- gmovmob 1) - (- gcapmob 1) - (- pthreat 0) - (- gthreat 1) - (- initprom 1) - (- possess 1) - (- arrive_distance 100) - (- promote_distance 1) - (- eventual_mobility 1) - (- static 1) - (- vital 1) - (- max_static_mob 1) - (- max_eventual_mob 1) - (- eradicate 1) - (- victims 1) - (- immunity 1) - (- giveaway 1) - (- eradicate 1) - (- stalemate 1) - (- arrive 1))) True) -; ; -; +; Everything, and gthreat. + (= (player_setting 6 iterate ((- gmovmob 1) (- gcapmob 1) (- pthreat 0) (- gthreat 1) (- initprom 1) (- possess 1) (- arrive_distance 100) (- promote_distance 1) (- eventual_mobility 1) (- static 1) (- vital 1) (- max_static_mob 1) (- max_eventual_mob 1) (- eradicate 1) (- victims 1) (- immunity 1) (- giveaway 1) (- eradicate 1) (- stalemate 1) (- arrive 1))) True) +; ;; statics - (= - (player_setting 7 iterate - ( (- gmovmob 1) - (- gcapmob 1) - (- pthreat 0) - (- gthreat 0) - (- lthreat 1) - (- initprom 1) - (- possess 1) - (- arrive_distance 100) - (- promote_distance 1) - (- eventual_mobility 1) - (- static 1) - (- vital 1) - (- max_static_mob 1) - (- max_eventual_mob 1) - (- eradicate 1) - (- victims 1) - (- immunity 1) - (- giveaway 1) - (- eradicate 1) - (- stalemate 1) - (- arrive 1))) True) -; +; +; Everything, and lthreat. + (= (player_setting 7 iterate ((- gmovmob 1) (- gcapmob 1) (- pthreat 0) (- gthreat 0) (- lthreat 1) (- initprom 1) (- possess 1) (- arrive_distance 100) (- promote_distance 1) (- eventual_mobility 1) (- static 1) (- vital 1) (- max_static_mob 1) (- max_eventual_mob 1) (- eradicate 1) (- victims 1) (- immunity 1) (- giveaway 1) (- eradicate 1) (- stalemate 1) (- arrive 1))) True) +; ;; statics ; -; - +; ============================================================================== ; -; - +; Interface ; -; +; ============================================================================== - - (= - (playernum-top $Color $Name) - ( (player-color $Role $Color) (load-player $Role $Name))) -; + (= (playernum-top $Color $Name) + (player-color $Role $Color) + (load-player $Role $Name)) - - (= - (playernums-top $Player $Opp) - ( (playernum-top white $Player) (playernum-top black $Opp))) -; - + (= (playernums-top $Player $Opp) + (playernum-top white $Player) + (playernum-top black $Opp)) diff --git a/metagame/misc/args.metta b/metagame/misc/args.metta index 5555fb9..8beb5b5 100644 --- a/metagame/misc/args.metta +++ b/metagame/misc/args.metta @@ -1,35 +1,26 @@ +; (convert_to_metta_file args $_348376 metagame/misc/args.pl metagame/misc/args.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; args.pl ; -; - +; ;; Some more general routines for term-manipulation ; -; - +; SAME_FUNCTOR(?T1,?T2) ; -; - +; Succeeds when T1 and T2 share the same functor. ; -; - +; Fails unless one of T1,T2 is non-var. - (= - (same-functor $T1 $T2) + (= (same-functor $T1 $T2) (det-if-then-else (nonvar $T1) (, @@ -43,26 +34,18 @@ (, (format "Error in same_functor: Both terms variables!~n" Nil) (fail))))) -; - ; -; - +; SAME_FUNCTOR(?T1,?T2,?A) ; -; - +; Succeeds when T1 and T2 share the same functor, ; -; - +; and both have arity A. ; -; - +; Fails unless one of T1,T2 is non-var. ; -; - - (= - (same-functor $T1 $T2 $A) +; (So not as general as Quintus's library pred. + (= (same-functor $T1 $T2 $A) (det-if-then-else (nonvar $T1) (, @@ -76,143 +59,98 @@ (, (format "Error in same_functor: Both terms variables!~n" Nil) (fail))))) -; - ; -; - +; SAME_ARG(+N,?T1,?T2) ; -; - - - (= - (same-arg $N $T1 $T2) - ( (arg $N $T1 $Item) (arg $N $T2 $Item))) -; +; Succeeds when T1 and T2, both non-var, have the same arg N. + (= (same-arg $N $T1 $T2) + (arg $N $T1 $Item) + (arg $N $T2 $Item)) ; -; - +; SAME_ARG(+N,?T1,?T2,+Item) ; -; - - (= - (same-arg $N $T1 $T2 $Item) - ( (arg $N $T1 $Item) (arg $N $T2 $Item))) -; - +; Succeeds when T1 and T2, both non-var, have the same Item as arg N. + (= (same-arg $N $T1 $T2 $Item) + (arg $N $T1 $Item) + (arg $N $T2 $Item)) ; -; - +; CORRESPONDING_ARG(N,T1,Item1,T2,Item2) ; -; - +; Item1 and Item2 are the Nth args in T1 and T2, ; -; - +; respectively. ; -; - - - (= - (corresponding-arg $N $T1 $Item1 $T2 $Item2) - ( (arg $N $T1 $Item1) (arg $N $T2 $Item2))) -; +; Not as general as in Quintus. + (= (corresponding-arg $N $T1 $Item1 $T2 $Item2) + (arg $N $T1 $Item1) + (arg $N $T2 $Item2)) ; -; - +; (The following routines were borroowed from Quintus) ; -; - +; genarg(?N, +Term, ?Item) ; -; - - - - (= - (genarg $N $Term $Arg) - ( (integer $N) - (nonvar $Term) - (set-det) - (arg $N $Term $Arg))) -; - - (= - (genarg $N $Term $Arg) - ( (var $N) - (nonvar $Term) - (set-det) - (functor $Term $_ $Arity) - (genarg $Arity $Term $Arg $N))) -; - +; like arg(N,Term,Item), but will generate N if necessary. - (= - (genarg 1 $Term $Arg 1) - ( (set-det) (arg 1 $Term $Arg))) -; - (= - (genarg $N $Term $Arg $N) + (= (genarg $N $Term $Arg) + (integer $N) + (nonvar $Term) + (set-det) (arg $N $Term $Arg)) -; - - (= - (genarg $K $Term $Arg $N) - ( (> $K 1) - (is $J - (- $K 1)) - (genarg $J $Term $Arg $N))) -; - + (= (genarg $N $Term $Arg) + (var $N) + (nonvar $Term) + (set-det) + (functor $Term $_ $Arity) + (genarg $Arity $Term $Arg $N)) + + (= (genarg 1 $Term $Arg 1) + (set-det) + (arg 1 $Term $Arg)) + (= (genarg $N $Term $Arg $N) + (arg $N $Term $Arg)) + (= (genarg $K $Term $Arg $N) + (> $K 1) + (is $J + (- $K 1)) + (genarg $J $Term $Arg $N)) ; -; - +; path_arg(Path, Term, SubTerm) ; -; - +; This routine replaces two predicates in the old Dec-10 MeTTa ; -; - +; library: patharg/3 and position/3. It does everything they did, ; -; +; and reports errors as well. - - (= - (path-arg $Path $Term $SubTerm) - ( (var $Term) - (set-det) + (= (path-arg $Path $Term $SubTerm) + (var $Term) + (set-det) + (det-if-then-else + (== $Path Nil) + (= $SubTerm $Term) (det-if-then-else - (== $Path Nil) - (= $SubTerm $Term) - (det-if-then-else - (not (= $Path (Cons $_ $_))) fail - (, - (format user-error '~N! Instantiation fault in argument ~w of ~q/~w~n! Goal: ~p~n' - (:: 2 path-arg 3 - (path-arg $Path $Term $SubTerm))) - (fail)))))) -; - - (= - (path_arg () $Term $Term) True) -; - - (= - (path-arg - (Cons $Head $Tail) $Term $SubTerm) + (not (= $Path (Cons $_ $_))) fail + (, + (format user-error '~N! Instantiation fault in argument ~w of ~q/~w~n! Goal: ~p~n' + (:: 2 path-arg 3 + (path-arg $Path $Term $SubTerm))) + (fail))))) + (= (path_arg () $Term $Term) True) + (= (path-arg (Cons $Head $Tail) $Term $SubTerm) (det-if-then-else (integer $Head) (, @@ -230,7 +168,6 @@ (path-arg (Cons $Head $Tail) $Term $SubTerm))) (fail))))) -; - +; /* otherwise */ diff --git a/metagame/misc/aux.metta b/metagame/misc/aux.metta index 73e171d..f357371 100644 --- a/metagame/misc/aux.metta +++ b/metagame/misc/aux.metta @@ -1,873 +1,520 @@ +; (convert_to_metta_file aux $_458836 metagame/misc/aux.pl metagame/misc/aux.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; ============================================================ ; ; - ; -; - +; Contains general utility predicates. ; -; - +; Adapted from shared code written by Fernando Pereira, ; -; - +; Martha Pollack, and Barney Pell. ; -; - +; Changes Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;;;;;;;;;;;;;;;;;;;; ; -; - +; ;;;; AUX ;;;;; ; -; - +; ;;;;;;;;;;;;;;;;;;;; !(my-use-module (library lists)) -; - !(use-module (library ordsets)) -; - ; -; - +; General auxiliary procedures ; -; - +; Contains: ; -; - +; append/3 ; -; - +; average/2 ; -; - +; between/3 ; -; - +; cgensym/2 ; -; - +; concat/3 ; -; - +; concat_list/2 ; -; - +; cons/3 ; -; - +; cull/4 ; -; - +; cull_funct/4 ; -; - +; extract/3 ; -; - +; findall/3 ; -; - +; f_cons/3 ; -; - +; flatten/2 ; -; - +; gensym/2 ; -; - +; get_nth/3 ; -; - +; increase_term_arity/3 ; -; - +; lastsuffix/2 ; -; - +; length/2 ; -; - +; maplist/3 ; -; - +; max/2, max/3 ; -; - +; min/2, min/3 ; -; - +; mesh/3 ; -; - +; member/2 ; -; - +; mnl/1 ; -; - +; nth/3 ; -; - +; nth_letter/2, nth_letter/3 ; -; - +; numlist/3 ; -; - +; pair_list/3 ; -; - +; percolate/3,perc2/4 ; -; - +; ppl/1,ppl/2 ; -; - +; remove_duplicates/2 ; -; - +; remove_test_duplicates/3 ; -; - +; reset_gensym/1, reset_gensym/2 ; -; - +; rev_append/3 ; -; - +; reverse/2,rev2/3 ; -; - +; snoc/3 ; -; - +; space/0,space/1 ; -; - +; split_list/4 ; -; - +; split_list_funct/4 ; -; - +; stable_sort/2 ; -; - +; subset/2 ; -; - +; verify/1 ; -; - +; whenever/2 ; -; - +; ynp/3 ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; +; Print mulitple line feeds (arg1 of them). - - (= - (mnl 1) + (= (mnl 1) (nl)) -; - - (= - (mnl $N) - ( (> $N 1) - (nl) - (is $N1 - (- $N 1)) - (mnl $N1))) -; - + (= (mnl $N) + (> $N 1) + (nl) + (is $N1 + (- $N 1)) + (mnl $N1)) ; -; - +; Pretty print the list arg1. ; -; +; Changed write to print. - - (= - (ppl $L) + (= (ppl $L) (ppl $L 3)) -; - - (= - (ppl () $Ind) True) -; - - (= + (= (ppl () $Ind) True) + (= (ppl (Cons (Cons $H $T) $L) $Ind) + (is $Ind1 + (+ $Ind 3)) (ppl - (Cons - (Cons $H $T) $L) $Ind) - ( (is $Ind1 - (+ $Ind 3)) - (ppl - (Cons $H $T) $Ind1) - (ppl $L $Ind) - (set-det))) -; - - (= - (ppl - (Cons $H $L) $Ind) - ( (space $Ind) - (print $H) - (nl) - (ppl $L $Ind) - (set-det))) -; - - (= - (ppl $A $Ind) - ( (space $Ind) - (print $A) - (nl))) -; - + (Cons $H $T) $Ind1) + (ppl $L $Ind) + (set-det)) + (= (ppl (Cons $H $L) $Ind) + (space $Ind) + (print $H) + (nl) + (ppl $L $Ind) + (set-det)) + (= (ppl $A $Ind) + (space $Ind) + (print $A) + (nl)) ; -; - +; Pretty print the list arg1. ; -; +; Changed write to print. - - (= - (pwl $L) + (= (pwl $L) (pwl $L 3)) -; - - (= - (pwl () $Ind) True) -; - - (= - (pwl - (Cons - (Cons $H $T) $L) $Ind) - ( (is $Ind1 - (+ $Ind 3)) - (pwl - (Cons $H $T) $Ind1) - (pwl $L $Ind) - (set-det))) -; - - (= + (= (pwl () $Ind) True) + (= (pwl (Cons (Cons $H $T) $L) $Ind) + (is $Ind1 + (+ $Ind 3)) (pwl - (Cons $H $L) $Ind) - ( (space $Ind) - (write $H) - (nl) - (pwl $L $Ind) - (set-det))) -; - - (= - (pwl $A $Ind) - ( (space $Ind) - (write $A) - (nl))) -; - + (Cons $H $T) $Ind1) + (pwl $L $Ind) + (set-det)) + (= (pwl (Cons $H $L) $Ind) + (space $Ind) + (write $H) + (nl) + (pwl $L $Ind) + (set-det)) + (= (pwl $A $Ind) + (space $Ind) + (write $A) + (nl)) ; -; - +; Print arg1 blank spaces. ; -; - +; Using the predicate name 'space' causes the compiler to crash --Barney - (= - (space) + (= (space) (write ' ')) -; - - (= - (space 0) True) -; - - (= - (space 1) + (= (space 0) True) + (= (space 1) (space)) -; - - (= - (space $N) - ( (> $N 1) - (space) - (is $N1 - (- $N 1)) - (space $N1))) -; - + (= (space $N) + (> $N 1) + (space) + (is $N1 + (- $N 1)) + (space $N1)) ; -; - - - - (= - (cons $E () - ($E)) True) -; +; Cons an element into a list. - (= - (cons $E - (Cons $H $T) - (Cons $E - (Cons $H $T))) True) -; + (= (cons $E () ($E)) True) + (= (cons $E (Cons $H $T) (Cons $E (Cons $H $T))) True) ; -; - +; "Snoc" an element into the end of a list. - (= - (snoc $E () - ($E)) True) -; - - (= - (snoc $E $L0 $L1) - ( (reverse $L0 $Lr) - (cons $E $Lr $Lr1) - (reverse $Lr1 $L1))) -; - + (= (snoc $E () ($E)) True) + (= (snoc $E $L0 $L1) + (reverse $L0 $Lr) + (cons $E $Lr $Lr1) + (reverse $Lr1 $L1)) ; -; - - - - (= - (f_cons () $L $L) True) -; +; Cons an element into a list, unless the element is itself a null list. - (= - (f_cons $E - (Cons $H $T) - (Cons $E - (Cons $H $T))) True) -; + (= (f_cons () $L $L) True) + (= (f_cons $E (Cons $H $T) (Cons $E (Cons $H $T))) True) ; -; +; Append the reverse of arg1 to arg2 to give arg3. - - (= - (rev_append () $L $L) True) -; - - (= - (rev-append - (Cons $H $T) $L $R) + (= (rev_append () $L $L) True) + (= (rev-append (Cons $H $T) $L $R) (rev-append $T (Cons $H $L) $R)) -; - ; -; - +; Extract arg1 from the list in arg2 to give arg3. ; -; +; Fails if arg1 is not a member of arg2. - - (= - (extract $Elt - (Cons $Elt $Tail) $Tail) True) -; - - (= - (extract $Elt - (Cons $Head $Tail) - (Cons $Head $List)) + (= (extract $Elt (Cons $Elt $Tail) $Tail) True) + (= (extract $Elt (Cons $Head $Tail) (Cons $Head $List)) (extract $Elt $Tail $List)) -; - ; -; - +; Cull all the members of arg2 that match the pattern in arg1. ; -; - +; Culled entities go into arg3; everything else goes into arg4. - (= - (cull $Pattern () () ()) True) -; - - (= - (cull $Pattern - (Cons $Pattern $T0) - (Cons $Pattern $T1) $R) + (= (cull $Pattern () () ()) True) + (= (cull $Pattern (Cons $Pattern $T0) (Cons $Pattern $T1) $R) (cull $Pattern $T0 $T1 $R)) -; - - (= - (cull $Pattern - (Cons $H $T0) $C - (Cons $H $T1)) + (= (cull $Pattern (Cons $H $T0) $C (Cons $H $T1)) (cull $Pattern $T0 $C $T1)) -; - ; -; - +; Cull all the members of arg2 whose functor is arg1. ; -; - - +; Culled entities go into arg3; everything else goes into arg4. - (= - (cull_funct $Funct () () ()) True) -; - - (= - (cull-funct $Funct - (Cons $H0 $T0) - (Cons $H0 $T1) $R) - ( (functor $H0 $Funct $_) (cull-funct $Funct $T0 $T1 $R))) -; - (= - (cull-funct $Funct - (Cons $H0 $T0) $C - (Cons $H0 $T1)) + (= (cull_funct $Funct () () ()) True) + (= (cull-funct $Funct (Cons $H0 $T0) (Cons $H0 $T1) $R) + (functor $H0 $Funct $_) + (cull-funct $Funct $T0 $T1 $R)) + (= (cull-funct $Funct (Cons $H0 $T0) $C (Cons $H0 $T1)) (cull-funct $Funct $T0 $C $T1)) -; - ; -; - +; Split_list finds arg1 in arg2, putting everything to the left into arg3 and ; -; - +; everything to the right in arg4. E.g.: ; -; - +; split_list(c,[a,b,c,d,e],[a,b],[d,e]). - (= - (split_list $Elt - (Cons $Elt $Tail) () $Tail) True) -; - - (= - (split-list $Elt - (Cons $Head $Tail0) - (Cons $Head $Tail1) $Tail) + (= (split_list $Elt (Cons $Elt $Tail) () $Tail) True) + (= (split-list $Elt (Cons $Head $Tail0) (Cons $Head $Tail1) $Tail) (split-list $Elt $Tail0 $Tail1 $Tail)) -; - ; -; - +; Split_list_funct finds the element with functor arg1 in arg2, putting ; -; - +; everything to the left into arg3 and everything to the right into arg4. - (= - (split-list-funct $Funct - (Cons $Elt $Tail) Nil $Tail) + (= (split-list-funct $Funct (Cons $Elt $Tail) Nil $Tail) (functor $Elt $Funct $_)) -; - - (= - (split-list-funct $Funct - (Cons $H0 $T0) - (Cons $H0 $T1) $T) + (= (split-list-funct $Funct (Cons $H0 $T0) (Cons $H0 $T1) $T) (split-list-funct $Funct $T0 $T1 $T)) -; - ; -; - - +; get_nth is like nth, but can be used with arg2 uninstantiated - (= - (get_nth 1 - (Cons $Head $_) $Head) True) -; - - (= - (get-nth $P - (Cons $_ $Tail) $Elt) - ( (get-nth $P1 $Tail $Elt) (is $P (+ $P1 1)))) -; + (= (get_nth 1 (Cons $Head $_) $Head) True) + (= (get-nth $P (Cons $_ $Tail) $Elt) + (get-nth $P1 $Tail $Elt) + (is $P + (+ $P1 1))) ; -; - - +; Letter is the Nth (lowercase) letter. - (= - (nth-letter $N $Letter) - ( (nth-letter-after $N a $Letter) - (> $N 0) - (=< $N 26))) -; + (= (nth-letter $N $Letter) + (nth-letter-after $N a $Letter) + (> $N 0) + (=< $N 26)) ; -; +; Letter is the Nth letter, starting at Letter0. - - (= - (nth-letter-after $N $Letter0 $Letter) - ( (atom $Letter) - (set-det) - (name $Letter0 - (:: $A)) - (name $Letter - (:: $L)) - (is $N - (+ - (- $L $A) 1)))) -; - - (= - (nth-letter-after $N $Letter0 $Letter) - ( (integer $N) - (name $Letter0 - (:: $A)) - (is $L - (- - (+ $N $A) 1)) - (name $Letter - (:: $L)))) -; - + (= (nth-letter-after $N $Letter0 $Letter) + (atom $Letter) + (set-det) + (name $Letter0 + (:: $A)) + (name $Letter + (:: $L)) + (is $N + (+ + (- $L $A) 1))) + (= (nth-letter-after $N $Letter0 $Letter) + (integer $N) + (name $Letter0 + (:: $A)) + (is $L + (- + (+ $N $A) 1)) + (name $Letter + (:: $L))) ; -; +; Percolate arg1 to the head of arg2 to give arg3. - - (= - (percolate $M $L1 $L2) + (= (percolate $M $L1 $L2) (perc2 $M $L1 Nil $L2)) -; - - (= - (perc2 $M - (Cons $M $Lt) $Lp - (Cons $M $L)) - ( (reverse $Lp $Lpr) (append $Lpr $Lt $L))) -; - - (= - (perc2 $M - (Cons $Lh $Lt) $Lp $L) + (= (perc2 $M (Cons $M $Lt) $Lp (Cons $M $L)) + (reverse $Lp $Lpr) + (append $Lpr $Lt $L)) + (= (perc2 $M (Cons $Lh $Lt) $Lp $L) (perc2 $M $Lt (Cons $Lh $Lp) $L)) -; - ; -; - +; Interleaving elements of arg1 and arg2, preserving order within each list ; -; +; gives arg3. - - (= - (mesh () $L $L) True) -; - - (= - (mesh $L () $L) True) -; - - (= - (mesh - (Cons $A $As) - (Cons $B $Bs) - (Cons $A $Rest)) + (= (mesh () $L $L) True) + (= (mesh $L () $L) True) + (= (mesh (Cons $A $As) (Cons $B $Bs) (Cons $A $Rest)) (mesh $As (Cons $B $Bs) $Rest)) -; - - (= - (mesh - (Cons $A $As) - (Cons $B $Bs) - (Cons $B $Rest)) + (= (mesh (Cons $A $As) (Cons $B $Bs) (Cons $B $Rest)) (mesh (Cons $A $As) $Bs $Rest)) -; - ; -; - +; flatten(Tree, List) ; -; - +; flattens a Tree of cons cells into a List. ; -; +; This from Quintus Library Flatten. - - (= - (flatten $Tree $List) + (= (flatten $Tree $List) (flatten $Tree $List Nil)) -; - - - - (= - (--> - (flatten ()) !) True) -; - (= - (--> - (flatten - (Cons $Head $Tail)) - (, ! - (, - (flatten $Head) - (flatten $Tail)))) True) -; - - (= - (--> - (flatten $Other) - ($Other)) True) -; + (= (--> (flatten ()) !) True) + (= (--> (flatten (Cons $Head $Tail)) (, ! (, (flatten $Head) (flatten $Tail)))) True) + (= (--> (flatten $Other) ($Other)) True) +; ; { Other ~= [], Other ~= [_|_] }, ; -; +; Generate in arg2 a new symbol with prefix arg1, and a unique suffix. - - (= - (gensym $Prefix $V) + (= (gensym $Prefix $V) ( (var $V) (atomic $Prefix) (lastsuffix $Prefix $M) (is $N (+ $M 1)) - (add-symbol &self + (add-is-symbol &self (flag (gensym $Prefix) $N)) (concat $Prefix $N $V) (set-det))) -; - ; -; - - +; Like gensym, but if V is instantiated it will be left alone. - (= - (cgensym $Prefix $V) - ( (var $V) - (set-det) - (gensym $Prefix $V))) -; - (= - (cgensym $_ $_) True) -; - + (= (cgensym $Prefix $V) + (var $V) + (set-det) + (gensym $Prefix $V)) + (= (cgensym $_ $_) True) - (= - (lastsuffix $Prefix $M) - ( (remove-symbol &self + (= (lastsuffix $Prefix $M) + ( (remove-is-symbol &self (flag (gensym $Prefix) $M)) (set-det))) -; - - (= - (lastsuffix $Prefix 0) True) -; - + (= (lastsuffix $Prefix 0) True) ; -; - +; Set all gensym suffixes back to 1. - (= - (reset-gensym) - (remove-all-symbols &self + (= (reset-gensym) + (remove-all-atoms &self (flag (gensym $Prefix) $M))) -; - - (= - (reset-gensym $Prefix) - (remove-all-symbols &self + (= (reset-gensym $Prefix) + (remove-all-atoms &self (flag (gensym $Prefix) $M))) -; - ; -; - +; BI_NAME(?Atom,?List) ; -; - +; A version of name/2 facilitating bidirectional programs, ; -; - +; where both args can be unbound at the time it is called, and they ; -; - +; will be frozen until one is bound. - (= - (bi-name $Atom $List) + (= (bi-name $Atom $List) (when (or (ground $Atom) (ground $List)) (name $Atom $List))) -; - ; -; - +; Form an atom in arg3 that is the concatenation of arg1 and arg2. - (= - (concat $N1 $N2 $N3) - ( (name $N1 $Ls1) - (name $N2 $Ls2) - (append $Ls1 $Ls2 $Ls3) - (name $N3 $Ls3))) -; - + (= (concat $N1 $N2 $N3) + (name $N1 $Ls1) + (name $N2 $Ls2) + (append $Ls1 $Ls2 $Ls3) + (name $N3 $Ls3)) - (= - (concat-list - (:: $A) $A) + (= (concat-list (:: $A) $A) (set-det)) -; - - (= - (concat-list - (Cons $A $Bs) $C) - ( (concat-list $Bs $Bconc) (concat $A $Bconc $C))) -; + (= (concat-list (Cons $A $Bs) $C) + (concat-list $Bs $Bconc) + (concat $A $Bconc $C)) - - (= - (append-list - (:: $A) $A) + (= (append-list (:: $A) $A) (set-det)) -; - - (= - (append-list - (Cons $A $Bs) $C) - ( (append-list $Bs $Bconc) (append $A $Bconc $C))) -; - + (= (append-list (Cons $A $Bs) $C) + (append-list $Bs $Bconc) + (append $A $Bconc $C)) ; -; - +; BI_CONCAT(?N1, ?N2, ?N3) ; -; - +; A bidirectional version of concat/3. ; -; - +; This is also provided in quintus string_append/3 procedure. - (= - (bi-concat $N1 $N2 $N3) + (= (bi-concat $N1 $N2 $N3) (det-if-then-else (atom $N3) (, @@ -881,780 +528,496 @@ (, (format "Error, uninstantiated args in bi_concat~n" Nil) (fail))))) -; - - (= - (bi-concat-list - (:: $A) $A) + (= (bi-concat-list (:: $A) $A) (set-det)) -; - - (= - (bi-concat-list - (Cons $A $Bs) $C) - ( (bi-concat-list $Bs $Bconc) (bi-concat $A $Bconc $C))) -; - +; /* This is sicstus-specific, so not used. bi_concat(N1, N2, N3) :- bi_name(N1, Ls1), bi_name(N2, Ls2), append(Ls1, Ls2, Ls3), bi_name(N3, Ls3). */ +; ; BI_CONCAT_LIST(List,Conc) ; Bi-directional verion of concat_list/3. + (= (bi-concat-list (Cons $A $Bs) $C) + (bi-concat-list $Bs $Bconc) + (bi-concat $A $Bconc $C)) ; -; +; Guarantee that a response designates either yes or no. - - (= - (ynp y y $Goal) + (= (ynp y y $Goal) (set-det)) -; - - (= - (ynp yes y $Goal) + (= (ynp yes y $Goal) (set-det)) -; - - (= - (ynp n n $Goal) + (= (ynp n n $Goal) (set-det)) -; - - (= - (ynp no n $Goal) + (= (ynp no n $Goal) (set-det)) -; - - (= - (ynp $Resp $RespVal $Goal) - ( (write 'Please respond with y or n.') - (nl) - (call $Goal))) -; - + (= (ynp $Resp $RespVal $Goal) + (write 'Please respond with y or n.') + (nl) + (call $Goal)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; count_bagof and count_setof ; -; - +; Measures the set returned by the base procedure. ; -; - +; Will not backtrack, so A,B, better instantiate all the variables ; -; - +; in needs! - (= - (count-bagof $A $B $C) + (= (count-bagof $A $B $C) (det-if-then-else (bagof $A $B $C1) (length $C1 $C) (= $C 0))) -; - - (= - (count-setof $A $B $C) + (= (count-setof $A $B $C) (det-if-then-else (setof $A $B $C1) (length $C1 $C) - (= $C 0))) -; - - - - (= - (count-findall $A $B $C) - ( (findall $A $B $C1) (length $C1 $C))) -; - - -; -; - -; -; - -; -; - -; -; - -; -; + (= $C 0))) + (= (count-findall $A $B $C) + (findall $A $B $C1) + (length $C1 $C)) - (= - (maplist $_ () ()) True) -; +; +; maplist(P,ListIn,ListOut). +; +; Apply the predicate P to each element of a list L to form a new list M. +; +; We assume that P has two arguments, where the first is the input, and the +; +; second the output. +; +; From CLOCKSIN & MELLISH, p. 173. - (= - (maplist $P - (Cons $X $L) - (Cons $Y $M)) - ( (=.. $Q - (:: $P $X $Y)) - (call $Q) - (maplist $P $L $M))) -; + (= (maplist $_ () ()) True) + (= (maplist $P (Cons $X $L) (Cons $Y $M)) + (=.. $Q + (:: $P $X $Y)) + (call $Q) + (maplist $P $L $M)) ; -; - +; For each instance of generator, call goal. - (= - (whenever $Generator $Goal) + (= (whenever $Generator $Goal) (or (, (call $Generator) (call $Goal) (fail)) True)) -; - - (= - (verify $Goal) + (= (verify $Goal) (not (not $Goal))) -; - - (= - (remove-test-duplicates $List $Test $Clean) + (= (remove-test-duplicates $List $Test $Clean) (remove-test-duplicates $List $Test Nil $Clean)) -; - - - (= - (remove_test_duplicates () $_ $_ ()) True) -; - - (= - (remove-test-duplicates - (Cons $H $T) $Test_Call $Seen $Clean) - ( (= $Test_Call - (test $Test $Pattern1 $Pattern2)) - (member $Pattern2 $Seen) - (= $H $Pattern1) - (call $Test) - (set-det) - (remove-test-duplicates $T $Test_Call $Seen $Clean))) -; - - (= - (remove-test-duplicates - (Cons $H $T) $Test_Call $Seen - (Cons $H $Clean)) +; /* In sicstus lists library, but not in Quintus, so now put in quintus-version. ; remove_duplicates(+List, ?Pruned) ; is true when Pruned is like List but with all *identical* duplicate ; elements removed. remove_duplicates([], []). remove_duplicates([Head|Tail1], [Head|Tail2]) :- delete(Tail1, Head, Residue), remove_duplicates(Residue, Tail2). */ +; ;;; remove_test_duplicates(List,Test,Clean) ;;; Test is of the form: ;;; test(CALL,Pat1,Pat2), ;;; where CALL uses Pat1 & 2.. ;;; ;;; EX: ;;; remove_test_duplicates([f(a,b),f(b,c),f(a,d),f(g,a),f(b,a)], ;;; test((Pat1 = f(A,_),Pat2 = f(A,_)),Pat1,Pat2),Clean). ;;; Pat1 = f(a,d), ;;; A = a, ;;; Pat2 = f(a,b), ;;; Clean = [f(a,b),f(b,c),f(g,a),f(b,a)] + + (= (remove_test_duplicates () $_ $_ ()) True) + (= (remove-test-duplicates (Cons $H $T) $Test_Call $Seen $Clean) + (= $Test_Call + (test $Test $Pattern1 $Pattern2)) + (member $Pattern2 $Seen) + (= $H $Pattern1) + (call $Test) + (set-det) + (remove-test-duplicates $T $Test_Call $Seen $Clean)) + (= (remove-test-duplicates (Cons $H $T) $Test_Call $Seen (Cons $H $Clean)) (remove-test-duplicates $T $Test_Call (Cons $H $Seen) $Clean)) -; - ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - - +; Arg2 is the average of Arg1, 0 if empty. - (= - (average $List $Avg) - ( (length $List $N) (det-if-then-else (> $N 0) (, (sum-list $List $Sum) (is $Avg (/ $Sum $N))) (= $Avg 0)))) -; + (= (average $List $Avg) + (length $List $N) + (det-if-then-else + (> $N 0) + (, + (sum-list $List $Sum) + (is $Avg + (/ $Sum $N))) + (= $Avg 0))) ; -; - +; Arg2 is the maximum number in Arg1. - (= - (max - (Cons $A $Rest) $Val) + (= (max (Cons $A $Rest) $Val) (max1 $Rest $A $Val)) -; - - (= - (max1 () $A $A) True) -; - - (= - (max1 - (Cons $H $T) $Old $Val) - ( (max $H $Old $New) (max1 $T $New $Val))) -; - + (= (max1 () $A $A) True) + (= (max1 (Cons $H $T) $Old $Val) + (max $H $Old $New) + (max1 $T $New $Val)) ; -; - - - (= - (max $A $B $A) - ( (> $A $B) (set-det))) -; - - (= - (max $A $B $B) True) -; +; Arg3 is the maximum of arg1 and arg2. + (= (max $A $B $A) + (> $A $B) + (set-det)) + (= (max $A $B $B) True) ; -; +; Arg2 is the minimum number in Arg1. - - (= - (min - (Cons $A $Rest) $Val) + (= (min (Cons $A $Rest) $Val) (min1 $Rest $A $Val)) -; - - - (= - (min1 () $A $A) True) -; - - (= - (min1 - (Cons $H $T) $Old $Val) - ( (min $H $Old $New) (min1 $T $New $Val))) -; + (= (min1 () $A $A) True) + (= (min1 (Cons $H $T) $Old $Val) + (min $H $Old $New) + (min1 $T $New $Val)) ; -; - - - (= - (min $A $B $A) - ( (< $A $B) (set-det))) -; - - (= - (min $A $B $B) True) -; +; Arg3 is the minimum of arg1 and arg2. + (= (min $A $B $A) + (< $A $B) + (set-det)) + (= (min $A $B $B) True) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (writeln $Arg) - ( (write $Arg) (nl))) -; - + (= (writeln $Arg) + (write $Arg) + (nl)) ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (= - (reduce-list - (Cons $A $B) $R) - ( (set-det) - (reduce-list $A $A1) - (reduce-list $B $B1) - (append $A1 $B1 $R))) -; - - (= - (reduce-list Nil Nil) + (= (reduce-list (Cons $A $B) $R) + (set-det) + (reduce-list $A $A1) + (reduce-list $B $B1) + (append $A1 $B1 $R)) + (= (reduce-list Nil Nil) (set-det)) -; - - (= - (reduce_list $X - ($X)) True) -; - + (= (reduce_list $X ($X)) True) ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (= - (increase-term-arity $TermIn $NewArg $TermOut) - ( (functor $TermIn $Func $N) - (is $N1 - (+ $N 1)) - (functor $TermOut $Func $N1) - (arg $N1 $TermOut $NewArg) - (copy-args $N $TermIn $TermOut))) -; - + (= (increase-term-arity $TermIn $NewArg $TermOut) + (functor $TermIn $Func $N) + (is $N1 + (+ $N 1)) + (functor $TermOut $Func $N1) + (arg $N1 $TermOut $NewArg) + (copy-args $N $TermIn $TermOut)) - (= - (copy-args 0 $TermIn $TermOut) + (= (copy-args 0 $TermIn $TermOut) (set-det)) -; - - (= - (copy-args $N $TermIn $TermOut) - ( (arg $N $TermIn $Arg) - (arg $N $TermOut $Arg) - (is $N1 - (- $N 1)) - (copy-args $N1 $TermIn $TermOut))) -; - + (= (copy-args $N $TermIn $TermOut) + (arg $N $TermIn $Arg) + (arg $N $TermOut $Arg) + (is $N1 + (- $N 1)) + (copy-args $N1 $TermIn $TermOut)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (portray-clauses $Clauses) + (= (portray-clauses $Clauses) (whenever (member $C $Clauses) (portray-clause $C))) -; - ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (dotimes 0 $_) + (= (dotimes 0 $_) (set-det)) -; - - (= - (dotimes $N $Call) + (= (dotimes $N $Call) ($Call (is $N1 (- $N 1)) (dotimes $N1 $Call))) -; - ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; STABLE_SORT(+In,?Out) ; -; - +; This is a stable version of built-in sort/2, which does ; -; - +; not merge duplicate entries. ; -; - +; It is based on the stable built-in keysort/2, so we first ; -; - +; convert the list into pairs. It would be nice if MeTTa ; -; - - - (= - (stable-sort $In $Out) - ( (pair-list $In $_ $Keyed) - (keysort $Keyed $SortKeyed) - (pair-list $Out $_ $SortKeyed))) -; +; provided this built-in also! + (= (stable-sort $In $Out) + (pair-list $In $_ $Keyed) + (keysort $Keyed $SortKeyed) + (pair-list $Out $_ $SortKeyed)) ; -; - +; PAIR_LIST(?A,?B,?C) ; -; - +; C is a list whose Nth member is A(N)-B(N). ; -; - - - (= - (pair_list () () ()) True) -; +; pair_list([1,2,3],[a,b,c],[1-a,2-b,3-c]) - (= - (pair-list - (Cons $A $As) - (Cons $B $Bs) - (Cons - (- $A $B) $Rest)) + (= (pair_list () () ()) True) + (= (pair-list (Cons $A $As) (Cons $B $Bs) (Cons (- $A $B) $Rest)) (pair-list $As $Bs $Rest)) -; - - (= - (rev_pair_list () ()) True) -; - - (= - (rev-pair-list - (Cons - (- $A $AV) $RestA) - (Cons - (- $AV $A) $RestB)) + (= (rev_pair_list () ()) True) + (= (rev-pair-list (Cons (- $A $AV) $RestA) (Cons (- $AV $A) $RestB)) (rev-pair-list $RestA $RestB)) -; - ; -; - +; ============================================================================ ; -; - +; String Pattern Matching ; -; - +; ============================================================================ ; -; - +; CONTAINS(Symbol,Text) :- con(Text, ([],Symbol)). ; -; - +; True if Symbol is contained in Text ; -; - +; Both are lists of characters. ; -; - +; Will backtrack over all possibilities. ; -; - +; From Sahlin's phd thesis. - (= - (contains $Symbol $Text) + (= (contains $Symbol $Text) (con $Text $Symbol)) -; - - (= - (con $_ - (, $_ ())) True) -; - - (= - (con - (Cons $C $Rtext) $SymbInfo) - ( (new $C $SymbInfo $SymbInfoNew) (con $Rtext $SymbInfoNew))) -; - + (= (con $_ (, $_ ())) True) + (= (con (Cons $C $Rtext) $SymbInfo) + (new $C $SymbInfo $SymbInfoNew) + (con $Rtext $SymbInfoNew)) - (= - (new $C - (, $Prefix $C $RestPostfix) - (, $PrefixNew $RestPostfix)) + (= (new $C (, $Prefix $C $RestPostfix) (, $PrefixNew $RestPostfix)) (append $Prefix (:: $C) $PrefixNew)) -; - - (= - (new $C - (, $Prefix $D $RestPostfix) - (, $PrefixNew $PostfixNew)) - ( (\== $C $D) - (append $Prefix - (:: $C) $H) - (append $PrefixNew $Rest $Prefix) - (append $_ $PrefixNew $H) - (append $Rest - (Cons $D $RestPostfix) $PostfixNew))) -; - + (= (new $C (, $Prefix $D $RestPostfix) (, $PrefixNew $PostfixNew)) + (\== $C $D) + (append $Prefix + (:: $C) $H) + (append $PrefixNew $Rest $Prefix) + (append $_ $PrefixNew $H) + (append $Rest + (Cons $D $RestPostfix) $PostfixNew)) ; -; - +; FOUND(Symbol) ; ; - ; -; - +; Read a sequence of chars until a pattern is found which matches each ; -; - +; char. Uses Sahlin's routines above. - (= - (found $Symbol) + (= (found $Symbol) (found1 $Symbol)) -; - - - - (= - (found1 - (, $_ ())) True) -; - (= - (found1 $SymbInfo) - ( (get0 $C) - (new $C $SymbInfo $SymbInfoNew) - (found1 $SymbInfoNew))) -; + (= (found1 (, $_ ())) True) + (= (found1 $SymbInfo) + (get0 $C) + (new $C $SymbInfo $SymbInfoNew) + (found1 $SymbInfoNew)) ; -; - +; ============================================================================ ; -; - +; between(+Lower, +Upper, ?Number) ; -; - +; is true when Lower, Upper, and Number are integers, ; -; - +; and Lower =< Number =< Upper. If Lower and Upper are given, ; -; - +; Number can be tested or enumerated. If either Lower or Upper ; -; - +; is absent, there is not enough information to find it, and an ; -; - +; error will be reported. ; -; - +; From shared code by Richard O'Keefe. - (= - (between $Lower $Upper $Point) - ( (integer $Lower) - (integer $Upper) - (or - (, - (integer $Point) - (set-det) - (=< $Lower $Point) - (=< $Point $Upper)) - (, - (var $Point) - (set-det) - (=< $Lower $Upper) - (between1 $Lower $Upper $Point))))) -; - + (= (between $Lower $Upper $Point) + (integer $Lower) + (integer $Upper) + (or + (, + (integer $Point) + (set-det) + (=< $Lower $Point) + (=< $Point $Upper)) + (, + (var $Point) + (set-det) + (=< $Lower $Upper) + (between1 $Lower $Upper $Point)))) +; ; These cuts must be cuts; +; ; they can't be arrows. ; -; - +; ; between1(Lower, Upper, Point) ; -; - +; enumerates values of Point satisfying Lower =< Point =< Upper, ; -; - +; where it is already known that Lower =< Upper and Point was a ; -; - +; variable. A purer version of this is left as a comment. - (= - (between1 $L $L $L) + (= (between1 $L $L $L) (set-det)) -; - - (= - (between1 $L $_ $L) True) -; - ; -; - - (= - (between1 $L $U $N) - ( (is $M - (+ $L 1)) (between1 $M $U $N))) -; - ; -; - + (= (between1 $L $_ $L) True) ; +; between1(L, U, L) :- L =< U. + (= (between1 $L $U $N) + (is $M + (+ $L 1)) + (between1 $M $U $N)) +; ; between1(L, U, N) :- L < U, +; ; M is L+1, ; +; between1(M, U, N). ; -; - +; ============================================================================ - (= - (numlist $Min $Max Nil) - ( (> $Min $Max) (set-det))) -; - - (= - (numlist $Min $Max - (Cons $Min $Rest)) - ( (is $Min1 - (+ $Min 1)) (numlist $Min1 $Max $Rest))) -; - + (= (numlist $Min $Max Nil) + (> $Min $Max) + (set-det)) + (= (numlist $Min $Max (Cons $Min $Rest)) + (is $Min1 + (+ $Min 1)) + (numlist $Min1 $Max $Rest)) ; -; - +; Suceeds on the unique occurrence for A if ; -; +; it is constant, otherwise backtracks over B. - - (= - (member1 $A $B) + (= (member1 $A $B) (det-if-then-else (var $A) (member $A $B) (memberchk $A $B))) -; - ; -; - +; ============================================================================ ; -; - +; Association Lists ; -; +; ============================================================================ - - (= - (member1-pair - (- $H $T) $B) + (= (member1-pair (- $H $T) $B) (det-if-then-else (var $H) (member (- $H $T) $B) (memberchk (- $H $T) $B))) -; - - (= - (assoc $List $Prop $Val) + (= (assoc $List $Prop $Val) (member1-pair (- $Prop $Val) $List)) -; - - - - (= - (set-assoc $List1 $Param $Val $New) - ( (ensure-list $List1 $List2) - (delete-all-assoc $Param $List2 $List) - (cons - (- $Param $Val) $List $New))) -; - - - - (= - (ensure-list $List1 $List1) - ( (is-list $List1) (set-det))) -; - (= - (ensure_list $_ ()) True) -; + (= (set-assoc $List1 $Param $Val $New) + (ensure-list $List1 $List2) + (delete-all-assoc $Param $List2 $List) + (cons + (- $Param $Val) $List $New)) - (= - (delete-all-assoc $P $L $L2) - ( (member - (- $P $V1) $L) - (set-det) - (delete $L - (- $P $V1) $L1) - (delete-all-assoc $P $L1 $L2))) -; + (= (ensure-list $List1 $List1) + (is-list $List1) + (set-det)) + (= (ensure_list $_ ()) True) - (= - (delete_all_assoc $_ $L $L) True) -; + (= (delete-all-assoc $P $L $L2) + (member + (- $P $V1) $L) + (set-det) + (delete $L + (- $P $V1) $L1) + (delete-all-assoc $P $L1 $L2)) + (= (delete_all_assoc $_ $L $L) True) ; -; - +; ============================================================================ ; -; - +; Regions ; -; - +; ============================================================================ ; -; +; in_region([a-0.7,b-0.2,c-0.1],0.89,Choice). - - (= - (in-region - (:: (- $Choice $Prob)) $_ $Choice) + (= (in-region (:: (- $Choice $Prob)) $_ $Choice) (set-det)) -; - - (= - (in-region - (Cons - (- $C $P) $Choices) $Prob $C) - ( (< $Prob $P) (set-det))) -; - - (= - (in-region - (Cons - (- $C $P) $Choices) $Prob $Choice) - ( (is $PRest - (- $Prob $P)) (in-region $Choices $PRest $Choice))) -; - + (= (in-region (Cons (- $C $P) $Choices) $Prob $C) + (< $Prob $P) + (set-det)) + (= (in-region (Cons (- $C $P) $Choices) $Prob $Choice) + (is $PRest + (- $Prob $P)) + (in-region $Choices $PRest $Choice)) diff --git a/metagame/misc/dynamic_load.metta b/metagame/misc/dynamic_load.metta index 5790c8b..7ae5519 100644 --- a/metagame/misc/dynamic_load.metta +++ b/metagame/misc/dynamic_load.metta @@ -1,70 +1,48 @@ +; (convert_to_metta_file dynamic_load $_355230 metagame/misc/dynamic_load.pl metagame/misc/dynamic_load.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; dynamic_load.pl ; -; +; ;; Loads a theory file. - - (= - (dl Nil) + (= (dl Nil) (set-det)) -; - - (= - (dl (Cons $F $Files)) - ( (set-det) - (dl $F) - (dl $Files))) -; - - (= - (dl $Filename) + (= (dl (Cons $F $Files)) + (set-det) + (dl $F) + (dl $Files)) + (= (dl $Filename) (dynamic-load $Filename)) -; - - (= - (dynamic-load $Filename) - ( (open $Filename read $Stream) - (format "Loading theory file: ~w~n" - (:: $Filename)) - (dynamic-load-stream $Stream) - (format " Finished loading Theory file: ~w~n" - (:: $Filename)) - (close $Stream))) -; + (= (dynamic-load $Filename) + (open $Filename read $Stream) + (format "Loading theory file: ~w~n" + (:: $Filename)) + (dynamic-load-stream $Stream) + (format " Finished loading Theory file: ~w~n" + (:: $Filename)) + (close $Stream)) - - (= - (dynamic-load-stream $Stream) + (= (dynamic-load-stream $Stream) (det-if-then-else (, (read $Stream $Term) @@ -72,17 +50,11 @@ (, (process-term $Term) (dynamic-load-stream $Stream)) True)) -; - ; -; +; process_term(Term) :- assert(Term). - - (= - (process-term $Term) + (= (process-term $Term) (theory-assert $Term)) -; - diff --git a/metagame/misc/floyd.metta b/metagame/misc/floyd.metta index 638b8da..2704833 100644 --- a/metagame/misc/floyd.metta +++ b/metagame/misc/floyd.metta @@ -1,325 +1,178 @@ +; (convert_to_metta_file floyd $_430894 metagame/misc/floyd.pl metagame/misc/floyd.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; floyd.pl ; -; - +; ;; Barney Pell ; -; - +; ;; University of Cambridge ; -; +; ;; 1992 - - (= - (s-to-d-graph Nil Nil) + (= (s-to-d-graph Nil Nil) (set-det)) -; - - (= - (s-to-d-graph - (Cons - (- $Vertex $Neibs1) $G) - (Cons - (- $Vertex $Neibs2) $D)) - ( (init-dists $Neibs1 $Neibs2) (s-to-d-graph $G $D))) -; +; /* From graphs.pl: The P-representation of a graph is a list of (from-to) vertex pairs, where the pairs can be in any old order. This form is convenient for input/output. The S-representation of a graph is a list of (vertex-neighbours) pairs, where the pairs are in standard order (as produced by keysort) and the neighbours of each vertex are also in standard order (as produced by sort). This form is convenient for many calculations. New addition: The D-representation of a weighted digraph is a list of (vertex-neighbours) pairs, where the pairs are in standard order (as produced by keysort) and the neighbours of each vertex are also in standard order (as produced by sort). Unlike the S-representation, though, each neighbour is a (vertex-weight) pair, which thus weights the edge from non-weighted S-representation of a graph. s_to_d_graph(SForm, Dform) converts an S-rep to a D-rep by giving each edge a weight of 1. d_to_s_graph(SForm, Dform) converts a D-rep to S-rep by dropping the weights. s_floyd(Graph,Closure) computes the reachability matrix for a graph in S-form, where the closure is in D-form. (NB: this is not the reflexive transitive closure). floyd(Graph,Closure) computes the all-pairs shortest-path distance matrix for a weighted digraph in D-form, with the closure also in D-form. (NB: this is not the reflexive transitive closure). */ + (= (s-to-d-graph (Cons (- $Vertex $Neibs1) $G) (Cons (- $Vertex $Neibs2) $D)) + (init-dists $Neibs1 $Neibs2) + (s-to-d-graph $G $D)) - - (= - (init_dists () ()) True) -; - - (= - (init-dists - (Cons $H $T) - (Cons - (- $H 1) $Ts)) + (= (init_dists () ()) True) + (= (init-dists (Cons $H $T) (Cons (- $H 1) $Ts)) (init-dists $T $Ts)) -; - - (= - (d-to-s-graph Nil Nil) + (= (d-to-s-graph Nil Nil) (set-det)) -; - - (= - (d-to-s-graph - (Cons - (- $Vertex $Neibs1) $G) - (Cons - (- $Vertex $Neibs2) $D)) - ( (strip-dists $Neibs1 $Neibs2) (d-to-s-graph $G $D))) -; + (= (d-to-s-graph (Cons (- $Vertex $Neibs1) $G) (Cons (- $Vertex $Neibs2) $D)) + (strip-dists $Neibs1 $Neibs2) + (d-to-s-graph $G $D)) - - (= - (strip_dists () ()) True) -; - - (= - (strip-dists - (Cons - (- $H $_) $T) - (Cons $H $Ts)) + (= (strip_dists () ()) True) + (= (strip-dists (Cons (- $H $_) $T) (Cons $H $Ts)) (strip-dists $T $Ts)) -; - - (= - (s-floyd $S_Graph $Closure) - ( (s-to-d-graph $S_Graph $Graph) (floyd $Graph $Closure))) -; - + (= (s-floyd $S_Graph $Closure) + (s-to-d-graph $S_Graph $Graph) + (floyd $Graph $Closure)) ; -; - +; Replaces all diagonal entries with 0. - (= - (zero-self-d-graph Nil Nil) + (= (zero-self-d-graph Nil Nil) (set-det)) -; - - (= - (zero-self-d-graph - (Cons - (- $Vertex $Neibs1) $G) - (Cons - (- $Vertex $Neibs2) $D)) - ( (ord-min-union - (:: (- $Vertex 0)) $Neibs1 $Neibs2) (zero-self-d-graph $G $D))) -; - + (= (zero-self-d-graph (Cons (- $Vertex $Neibs1) $G) (Cons (- $Vertex $Neibs2) $D)) + (ord-min-union + (:: (- $Vertex 0)) $Neibs1 $Neibs2) + (zero-self-d-graph $G $D)) ; -; - +; FLOYD(+Graph, -Closure) ; -; - +; ======================= ; -; - +; is true when Closure is the all-pairs-shortest-path solution ; -; - +; to the weighted digraph Graph. ; ; - ; -; - +; Graph is a weighted-digraph: ; -; - +; [V_1-Edges_1,...,V_n-Edges_n] ; -; - +; Each Edges is a list of weighted vertices: ; -; - +; EdgesI = [V_j-Weight_ij ; ; - ; ; - ; -; - +; Result is a new weighted-digraph, where W_ij is the ; -; - +; weight of the shortest path from V_i to V_j in the original ; -; - +; graph. ; ; - ; -; - +; This is O(N**3). ; -; - +; This was based on Richard O'Keefe's implementation of warshall/2, ; -; +; and the description of Floyd's algorithm given in AHO. + (= (floyd $Graph $Closure) + (zero-self-d-graph $Graph $Init) + (floyd $Init $Init $Closure)) - (= - (floyd $Graph $Closure) - ( (zero-self-d-graph $Graph $Init) (floyd $Init $Init $Closure))) -; - - - (= - (floyd Nil $Closure $Closure) + (= (floyd Nil $Closure $Closure) (set-det)) -; - - (= - (floyd - (Cons - (- $V $_) $G) $E $Closure) - ( (memberchk - (- $V $Y) $E) - (floyd $E $V $Y $NewE) - (floyd $G $NewE $Closure))) -; - + (= (floyd (Cons (- $V $_) $G) $E $Closure) + (memberchk + (- $V $Y) $E) + (floyd $E $V $Y $NewE) + (floyd $G $NewE $Closure)) +; ; Y := E(v) - (= - (floyd - (Cons - (- $X $Neibs) $G) $V $Y - (Cons - (- $X $NewNeibs) $NewG)) - ( (memberchk - (- $V $VDist) $Neibs) - (set-det) - (increment-dists $Y $VDist $YInc) - (ord-min-union $Neibs $YInc $NewNeibs) - (floyd $G $V $Y $NewG))) -; - - (= - (floyd - (Cons - (- $X $Neibs) $G) $V $Y - (Cons - (- $X $Neibs) $NewG)) - ( (set-det) (floyd $G $V $Y $NewG))) -; + (= (floyd (Cons (- $X $Neibs) $G) $V $Y (Cons (- $X $NewNeibs) $NewG)) + (memberchk + (- $V $VDist) $Neibs) + (set-det) + (increment-dists $Y $VDist $YInc) + (ord-min-union $Neibs $YInc $NewNeibs) + (floyd $G $V $Y $NewG)) + (= (floyd (Cons (- $X $Neibs) $G) $V $Y (Cons (- $X $Neibs) $NewG)) + (set-det) + (floyd $G $V $Y $NewG)) + (= (floyd () $_ $_ ()) True) - (= - (floyd () $_ $_ ()) True) -; - - - - (= - (increment_dists () $_ ()) True) -; - - (= - (increment-dists - (Cons - (- $H $D) $T) $N - (Cons - (- $H $D1) $T1)) - ( (is $D1 - (+ $D $N)) (increment-dists $T $N $T1))) -; + (= (increment_dists () $_ ()) True) + (= (increment-dists (Cons (- $H $D) $T) $N (Cons (- $H $D1) $T1)) + (is $D1 + (+ $D $N)) + (increment-dists $T $N $T1)) ; -; - +; ord_min_union(+Set1, +Set2, ?Union) ; ; - ; -; - +; just like ord_union, except our elements are Elt-Weight ; -; - +; pairs instead of just Elts. Then Union is like the ord_union ; -; - +; except when both sets of have two same Elt's with different ; -; - +; weights, the minimum weight is kept. - (= - (ord_min_union () $Set2 $Set2) True) -; - - (= - (ord-min-union - (Cons $Head1 $Tail1) $Set2 $Union) + (= (ord_min_union () $Set2 $Set2) True) + (= (ord-min-union (Cons $Head1 $Tail1) $Set2 $Union) (ord-min-union-1 $Set2 $Head1 $Tail1 $Union)) -; + (= (ord_min_union_1 () $Head1 $Tail1 (Cons $Head1 $Tail1)) True) + (= (ord-min-union-1 (Cons $Head2 $Tail2) $Head1 $Tail1 $Union) + (weighted-compare $Order $Head1 $Head2) + (ord-min-union-1 $Order $Head1 $Tail1 $Head2 $Tail2 $Union)) - (= - (ord_min_union_1 () $Head1 $Tail1 - (Cons $Head1 $Tail1)) True) -; - - (= - (ord-min-union-1 - (Cons $Head2 $Tail2) $Head1 $Tail1 $Union) - ( (weighted-compare $Order $Head1 $Head2) (ord-min-union-1 $Order $Head1 $Tail1 $Head2 $Tail2 $Union))) -; - - - (= - (ord-min-union-1 < $Head1 $Tail1 $Head2 $Tail2 - (Cons $Head1 $Union)) + (= (ord-min-union-1 < $Head1 $Tail1 $Head2 $Tail2 (Cons $Head1 $Union)) (ord-min-union-1 $Tail1 $Head2 $Tail2 $Union)) -; - - (= - (ord-min-union-1 > $Head1 $Tail1 $Head2 $Tail2 - (Cons $Head2 $Union)) + (= (ord-min-union-1 > $Head1 $Tail1 $Head2 $Tail2 (Cons $Head2 $Union)) (ord-min-union-1 $Tail2 $Head1 $Tail1 $Union)) -; - - (= - (ord-min-union-1 = - (- $Head1 $N1) $Tail1 - (- $Head1 $N2) $Tail2 - (Cons - (- $Head1 $N) $Union)) - ( (min $N1 $N2 $N) (ord-min-union $Tail1 $Tail2 $Union))) -; + (= (ord-min-union-1 = (- $Head1 $N1) $Tail1 (- $Head1 $N2) $Tail2 (Cons (- $Head1 $N) $Union)) + (min $N1 $N2 $N) + (ord-min-union $Tail1 $Tail2 $Union)) - - (= - (weighted-compare $Order - (- $Head1 $N1) - (- $Head2 $N2)) + (= (weighted-compare $Order (- $Head1 $N1) (- $Head2 $N2)) (compare $Order $Head1 $Head2)) -; - - (= - (time-floyd $P $N) - ( (random-graph $P $N $G) - (s-to-d-graph $G $Z) - (runtime (floyd $Z $ZLast)))) -; - + (= (time-floyd $P $N) + (random-graph $P $N $G) + (s-to-d-graph $G $Z) + (runtime (floyd $Z $ZLast))) +; /* Testing */ diff --git a/metagame/misc/menus.metta b/metagame/misc/menus.metta index 9b1a7ec..b1f0eda 100644 --- a/metagame/misc/menus.metta +++ b/metagame/misc/menus.metta @@ -1,74 +1,53 @@ +; (convert_to_metta_file menus $_63808 metagame/misc/menus.pl metagame/misc/menus.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; menus.pl !(my-ensure-loaded (library aux)) -; - ; -; - +; ====================================================================== ; -; - +; Generic menu constructors ; -; - +; ====================================================================== ; -; - +; PROCESS_COMMAND(+String,+Suffix,+Args) ; -; - +; Check if first word in command, appropriately suffixed, ; -; - +; is defined as a predicate. If so, call it with the args, ; -; - +; if not, fail. ; -; - +; Note: succeeds whether it finds a command or not. ; -; - +; However, calling routines can check the instantiation of the args ; -; - +; to determine whether it really changed anything. - (= - (process-command $String $Suffix $Args) + (= (process-command $String $Suffix $Args) (det-if-then (, (append @@ -82,135 +61,91 @@ (current-predicate $_ $Goal)) (det-if-then-else (call $Goal) True True))) -; - ; -; - +; MENU_COMMAND(FormatString,FormatArgsList,Suffix,MenuArgsList) ; ; - ; -; - +; First, output the format string, with its format args, to the user. ; -; - +; This should be a message indicating what choices are to be made, ; -; - +; possibly pointing to a help menu, etc. ; ; - ; -; - +; Then reads a sequence of words, which should be of the form: ; -; - +; command arg1 ... argn ; -; - +; The arg1..n are the args SPECIFIC to this command. ; -; - +; The MenuArgs are the names of arguments which will be provided to ; -; - +; EVERY command accessible via this menu, as the args before the ; -; - +; command specific args. ; -; - +; Suffix is an atom which will suffix the commands called, as they are ; -; - +; specific to this menu. ; ; - ; -; - +; Example: We might make a menu called: dentist. ; -; - +; The opening message of the menu might be: "Choose a dental operation" ; -; - +; Each operation in the menu might need to be sent following input/output variables: ; -; - +; patient ; -; - +; number_of_teeth ; -; - +; suggestion ; ; - ; -; - +; A specific operation selectable might be: ; -; - +; pull_teeth (requires additional parameter: date) ; ; - ; -; - +; Then the selector for this operation would be implemented as: ; ; - ; -; - +; pull_teeth_dentist(Patient,Number,Suggestion,Date) :- ... definition ; ; - ; -; - +; And the menu would be called as follows: ; ; - ; -; - +; :- menu_command("Choose a dental operation",[],dentist,[P,N,S]). ; ; - ; ; - ; -; +; Simpler versions of this pred. omit the formatting information. + (= (menu-command $FormatString $FormatArgs $Suffix $Args) + (format $FormatString $FormatArgs) + (menu-command $Suffix $Args)) - (= - (menu-command $FormatString $FormatArgs $Suffix $Args) - ( (format $FormatString $FormatArgs) (menu-command $Suffix $Args))) -; - - - (= - (menu-command $FormatString $Suffix $Args) + (= (menu-command $FormatString $Suffix $Args) (menu-command $FormatString Nil $Suffix $Args)) -; - - - (= - (menu-command $Suffix $Args) - ( (read-keyboard-tokens $String) (process-command $String $Suffix $Args))) -; + (= (menu-command $Suffix $Args) + (read-keyboard-tokens $String) + (process-command $String $Suffix $Args)) diff --git a/metagame/misc/mygraphs.metta b/metagame/misc/mygraphs.metta index 24e8f37..70ab72d 100644 --- a/metagame/misc/mygraphs.metta +++ b/metagame/misc/mygraphs.metta @@ -1,479 +1,270 @@ +; (convert_to_metta_file mygraphs $_153056 metagame/misc/mygraphs.pl metagame/misc/mygraphs.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; File : GRAPHS.PL ; -; - +; Author : R.A.O'Keefe ; -; - +; Updated: 20 March 1984 ; -; - +; Purpose: Graph-processing utilities. !(public (, (/ p-to-s-graph 2) (/ s-to-p-graph 2) (/ s-to-p-trans 2) (/ p-member 3) (/ s-member 3) (/ p-transpose 2) (/ s-transpose 2) (/ compose 3) (/ top-sort 2) (/ vertices 2) (/ warshall 2))) -; - +; /* The P-representation of a graph is a list of (from-to) vertex pairs, where the pairs can be in any old order. This form is convenient for input/output. The S-representation of a graph is a list of (vertex-neighbours) pairs, where the pairs are in standard order (as produced by keysort) and the neighbours of each vertex are also in standard order (as produced by sort). This form is convenient for many calculations. p_to_s_graph(Pform, Sform) converts a P- to an S- representation. s_to_p_graph(Sform, Pform) converts an S- to a P- representation. warshall(Graph, Closure) takes the transitive closure of a graph in S-form. (NB: this is not the reflexive transitive closure). s_to_p_trans(Sform, Pform) converts Sform to Pform, transposed. p_transpose transposes a graph in P-form, cost O(|E|). s_transpose transposes a graph in S-form, cost O(|V|^2). */ !(mode (, (vertices + -) (p-to-s-graph + -) (p-to-s-vertices + -) (p-to-s-group + + -) (p-to-s-group + + - -) (s-to-p-graph + -) (s-to-p-graph + + - -) (s-to-p-trans + -) (s-to-p-trans + + - -) (p-member ? ? +) (s-member ? ? +) (p-transpose + -) (s-transpose + -) (s-transpose + - ? -) (transpose-s + + + -) (compose + + -) (compose + + + -) (compose1 + + + -) (compose1 + + + + + + + -) (top-sort + -) (vertices-and-zeros + - ?) (count-edges + + + -) (incr-list + + + -) (select-zeros + + -) (top-sort + - + + +) (decr-list + + + - + -) (warshall + -) (warshall + + -) (warshall + + + -))) -; - ; -; - +; vertices(S_Graph, Vertices) ; -; - +; strips off the neighbours lists of an S-representation to produce ; -; - +; a list of the vertices of the graph. (It is a characteristic of ; -; - +; S-representations that *every* vertex appears, even if it has no ; -; - +; neighbours.) - (= - (vertices Nil Nil) + (= (vertices Nil Nil) (set-det)) -; - - (= - (vertices - (Cons - (- $Vertex $Neighbours) $Graph) - (Cons $Vertex $Vertices)) + (= (vertices (Cons (- $Vertex $Neighbours) $Graph) (Cons $Vertex $Vertices)) (vertices $Graph $Vertices)) -; - - - (= - (p-to-s-graph $P_Graph $S_Graph) - ( (sort $P_Graph $EdgeSet) - (p-to-s-vertices $EdgeSet $VertexBag) - (sort $VertexBag $VertexSet) - (p-to-s-group $VertexSet $EdgeSet $S_Graph))) -; + (= (p-to-s-graph $P_Graph $S_Graph) + (sort $P_Graph $EdgeSet) + (p-to-s-vertices $EdgeSet $VertexBag) + (sort $VertexBag $VertexSet) + (p-to-s-group $VertexSet $EdgeSet $S_Graph)) - (= - (p-to-s-vertices Nil Nil) + (= (p-to-s-vertices Nil Nil) (set-det)) -; - - (= - (p-to-s-vertices - (Cons - (- $A $Z) $Edges) - (Cons $A - (Cons $Z $Vertices))) + (= (p-to-s-vertices (Cons (- $A $Z) $Edges) (Cons $A (Cons $Z $Vertices))) (p-to-s-vertices $Edges $Vertices)) -; - - (= - (p-to-s-group Nil $_ Nil) + (= (p-to-s-group Nil $_ Nil) (set-det)) -; - - (= - (p-to-s-group - (Cons $Vertex $Vertices) $EdgeSet - (Cons - (- $Vertex $Neibs) $G)) - ( (p-to-s-group $EdgeSet $Vertex $Neibs $RestEdges) (p-to-s-group $Vertices $RestEdges $G))) -; + (= (p-to-s-group (Cons $Vertex $Vertices) $EdgeSet (Cons (- $Vertex $Neibs) $G)) + (p-to-s-group $EdgeSet $Vertex $Neibs $RestEdges) + (p-to-s-group $Vertices $RestEdges $G)) + (= (p-to-s-group (Cons (- $V $X) $Edges) $V (Cons $X $Neibs) $RestEdges) + (set-det) + (p-to-s-group $Edges $V $Neibs $RestEdges)) + (= (p_to_s_group $Edges $_ () $Edges) True) - (= - (p-to-s-group - (Cons - (- $V $X) $Edges) $V - (Cons $X $Neibs) $RestEdges) - ( (set-det) (p-to-s-group $Edges $V $Neibs $RestEdges))) -; - (= - (p_to_s_group $Edges $_ () $Edges) True) -; - - - - (= - (s-to-p-graph Nil Nil) + (= (s-to-p-graph Nil Nil) (set-det)) -; - - (= - (s-to-p-graph - (Cons - (- $Vertex $Neibs) $G) $P_Graph) - ( (s-to-p-graph $Neibs $Vertex $P_Graph $Rest_P_Graph) (s-to-p-graph $G $Rest_P_Graph))) -; - + (= (s-to-p-graph (Cons (- $Vertex $Neibs) $G) $P_Graph) + (s-to-p-graph $Neibs $Vertex $P_Graph $Rest_P_Graph) + (s-to-p-graph $G $Rest_P_Graph)) - (= - (s-to-p-graph Nil $_ $P_Graph $P_Graph) + (= (s-to-p-graph Nil $_ $P_Graph $P_Graph) (set-det)) -; - - (= - (s-to-p-graph - (Cons $Neib $Neibs) $Vertex - (Cons - (- $Vertex $Neib) $P) $Rest_P) + (= (s-to-p-graph (Cons $Neib $Neibs) $Vertex (Cons (- $Vertex $Neib) $P) $Rest_P) (s-to-p-graph $Neibs $Vertex $P $Rest_P)) -; - - (= - (s-to-p-trans Nil Nil) + (= (s-to-p-trans Nil Nil) (set-det)) -; - - (= - (s-to-p-trans - (Cons - (- $Vertex $Neibs) $G) $P_Graph) - ( (s-to-p-trans $Neibs $Vertex $P_Graph $Rest_P_Graph) (s-to-p-trans $G $Rest_P_Graph))) -; - + (= (s-to-p-trans (Cons (- $Vertex $Neibs) $G) $P_Graph) + (s-to-p-trans $Neibs $Vertex $P_Graph $Rest_P_Graph) + (s-to-p-trans $G $Rest_P_Graph)) - (= - (s-to-p-trans Nil $_ $P_Graph $P_Graph) + (= (s-to-p-trans Nil $_ $P_Graph $P_Graph) (set-det)) -; - - (= - (s-to-p-trans - (Cons $Neib $Neibs) $Vertex - (Cons - (- $Neib $Vertex) $P) $Rest_P) + (= (s-to-p-trans (Cons $Neib $Neibs) $Vertex (Cons (- $Neib $Vertex) $P) $Rest_P) (s-to-p-trans $Neibs $Vertex $P $Rest_P)) -; - - (= - (warshall $Graph $Closure) + (= (warshall $Graph $Closure) (warshall $Graph $Graph $Closure)) -; - - (= - (warshall Nil $Closure $Closure) + (= (warshall Nil $Closure $Closure) (set-det)) -; - - (= - (warshall - (Cons - (- $V $_) $G) $E $Closure) - ( (memberchk - (- $V $Y) $E) - (warshall $E $V $Y $NewE) - (warshall $G $NewE $Closure))) -; + (= (warshall (Cons (- $V $_) $G) $E $Closure) + (memberchk + (- $V $Y) $E) + (warshall $E $V $Y $NewE) + (warshall $G $NewE $Closure)) +; ; Y := E(v) - - (= - (warshall - (Cons - (- $X $Neibs) $G) $V $Y - (Cons - (- $X $NewNeibs) $NewG)) - ( (memberchk $V $Neibs) - (set-det) - (ord-union $Neibs $Y $NewNeibs) - (warshall $G $V $Y $NewG))) -; - - (= - (warshall - (Cons - (- $X $Neibs) $G) $V $Y - (Cons - (- $X $Neibs) $NewG)) - ( (set-det) (warshall $G $V $Y $NewG))) -; - - (= - (warshall () $_ $_ ()) True) -; + (= (warshall (Cons (- $X $Neibs) $G) $V $Y (Cons (- $X $NewNeibs) $NewG)) + (memberchk $V $Neibs) + (set-det) + (ord-union $Neibs $Y $NewNeibs) + (warshall $G $V $Y $NewG)) + (= (warshall (Cons (- $X $Neibs) $G) $V $Y (Cons (- $X $Neibs) $NewG)) + (set-det) + (warshall $G $V $Y $NewG)) + (= (warshall () $_ $_ ()) True) - - (= - (p-transpose Nil Nil) + (= (p-transpose Nil Nil) (set-det)) -; - - (= - (p-transpose - (Cons - (- $From $To) $Edges) - (Cons - (- $To $From) $Transpose)) + (= (p-transpose (Cons (- $From $To) $Edges) (Cons (- $To $From) $Transpose)) (p-transpose $Edges $Transpose)) -; - - (= - (s-transpose $S_Graph $Transpose) + (= (s-transpose $S_Graph $Transpose) (s-transpose $S_Graph $Base $Base $Transpose)) -; - - (= - (s-transpose Nil Nil $Base $Base) + (= (s-transpose Nil Nil $Base $Base) (set-det)) -; - - (= - (s-transpose - (Cons - (- $Vertex $Neibs) $Graph) - (Cons - (- $Vertex Nil) $RestBase) $Base $Transpose) - ( (s-transpose $Graph $RestBase $Base $SoFar) (transpose-s $SoFar $Neibs $Vertex $Transpose))) -; - - - - (= - (transpose-s - (Cons - (- $Neib $Trans) $SoFar) - (Cons $Neib $Neibs) $Vertex - (Cons - (- $Neib - (Cons $Vertex $Trans)) $Transpose)) - ( (set-det) (transpose-s $SoFar $Neibs $Vertex $Transpose))) -; - - (= - (transpose-s - (Cons $Head $SoFar) $Neibs $Vertex - (Cons $Head $Transpose)) - ( (set-det) (transpose-s $SoFar $Neibs $Vertex $Transpose))) -; + (= (s-transpose (Cons (- $Vertex $Neibs) $Graph) (Cons (- $Vertex Nil) $RestBase) $Base $Transpose) + (s-transpose $Graph $RestBase $Base $SoFar) + (transpose-s $SoFar $Neibs $Vertex $Transpose)) - (= - (transpose_s () () $_ ()) True) -; + (= (transpose-s (Cons (- $Neib $Trans) $SoFar) (Cons $Neib $Neibs) $Vertex (Cons (- $Neib (Cons $Vertex $Trans)) $Transpose)) + (set-det) + (transpose-s $SoFar $Neibs $Vertex $Transpose)) + (= (transpose-s (Cons $Head $SoFar) $Neibs $Vertex (Cons $Head $Transpose)) + (set-det) + (transpose-s $SoFar $Neibs $Vertex $Transpose)) + (= (transpose_s () () $_ ()) True) ; -; - +; p_member(X, Y, P_Graph) ; -; - +; tests whether the edge (X,Y) occurs in the graph. This always ; -; - +; costs O(|E|) time. Here, as in all the operations in this file, ; -; - +; vertex labels are assumed to be ground terms, or at least to be ; -; - - +; sufficiently instantiated that no two of them have a common instance. - (= - (p-member $X $Y $P_Graph) - ( (nonvar $X) - (nonvar $Y) - (set-det) - (memberchk - (- $X $Y) $P_Graph))) -; - (= - (p-member $X $Y $P_Graph) + (= (p-member $X $Y $P_Graph) + (nonvar $X) + (nonvar $Y) + (set-det) + (memberchk + (- $X $Y) $P_Graph)) + (= (p-member $X $Y $P_Graph) (member (- $X $Y) $P_Graph)) -; - ; -; - +; s_member(X, Y, S_Graph) ; -; - +; tests whether the edge (X,Y) occurs in the graph. If either ; -; - +; X or Y is instantiated, the check is order |V| rather than ; -; - - - - (= - (s-member $X $Y $S_Graph) - ( (var $X) - (var $Y) - (set-det) - (member - (- $X $Neibs) $S_Graph) - (member $Y $Neibs))) -; - - (= - (s-member $X $Y $S_Graph) - ( (var $X) - (set-det) - (member - (- $X $Neibs) $S_Graph) - (memberchk $Y $Neibs))) -; - - (= - (s-member $X $Y $S_Graph) - ( (var $Y) - (set-det) - (memberchk - (- $X $Neibs) $S_Graph) - (member $Y $Neibs))) -; - - (= - (s-member $X $Y $S_Graph) - ( (memberchk - (- $X $Neibs) $S_Graph) (memberchk $Y $Neibs))) -; +; order |E|. + (= (s-member $X $Y $S_Graph) + (var $X) + (var $Y) + (set-det) + (member + (- $X $Neibs) $S_Graph) + (member $Y $Neibs)) + (= (s-member $X $Y $S_Graph) + (var $X) + (set-det) + (member + (- $X $Neibs) $S_Graph) + (memberchk $Y $Neibs)) + (= (s-member $X $Y $S_Graph) + (var $Y) + (set-det) + (memberchk + (- $X $Neibs) $S_Graph) + (member $Y $Neibs)) + (= (s-member $X $Y $S_Graph) + (memberchk + (- $X $Neibs) $S_Graph) + (memberchk $Y $Neibs)) -; -; ; -; - +; compose(G1, G2, Composition) ; -; - - +; calculates the composition of two S-form graphs, which need not +; +; have the same set of vertices. - (= - (compose $G1 $G2 $Composition) - ( (vertices $G1 $V1) - (vertices $G2 $V2) - (ord-union $V1 $V2 $V) - (compose $V $G1 $G2 $Composition))) -; + (= (compose $G1 $G2 $Composition) + (vertices $G1 $V1) + (vertices $G2 $V2) + (ord-union $V1 $V2 $V) + (compose $V $G1 $G2 $Composition)) - (= - (compose Nil $_ $_ Nil) + (= (compose Nil $_ $_ Nil) (set-det)) -; - - (= - (compose - (Cons $Vertex $Vertices) - (Cons - (- $Vertex $Neibs) $G1) $G2 - (Cons - (- $Vertex $Comp) $Composition)) - ( (set-det) - (compose1 $Neibs $G2 Nil $Comp) - (compose $Vertices $G1 $G2 $Composition))) -; - - (= - (compose - (Cons $Vertex $Vertices) $G1 $G2 - (Cons - (- $Vertex Nil) $Composition)) + (= (compose (Cons $Vertex $Vertices) (Cons (- $Vertex $Neibs) $G1) $G2 (Cons (- $Vertex $Comp) $Composition)) + (set-det) + (compose1 $Neibs $G2 Nil $Comp) + (compose $Vertices $G1 $G2 $Composition)) + (= (compose (Cons $Vertex $Vertices) $G1 $G2 (Cons (- $Vertex Nil) $Composition)) (compose $Vertices $G1 $G2 $Composition)) -; - - - - - (= - (compose1 - (Cons $V1 $Vs1) - (Cons - (- $V2 $N2) $G2) $SoFar $Comp) - ( (compare $Rel $V1 $V2) - (set-det) - (compose1 $Rel $V1 $Vs1 $V2 $N2 $G2 $SoFar $Comp))) -; - - (= - (compose1 $_ $_ $Comp $Comp) True) -; - - (= - (compose1 < $_ $Vs1 $V2 $N2 $G2 $SoFar $Comp) - ( (set-det) (compose1 $Vs1 (Cons (- $V2 $N2) $G2) $SoFar $Comp))) -; - (= - (compose1 > $V1 $Vs1 $_ $_ $G2 $SoFar $Comp) - ( (set-det) (compose1 (Cons $V1 $Vs1) $G2 $SoFar $Comp))) -; + (= (compose1 (Cons $V1 $Vs1) (Cons (- $V2 $N2) $G2) $SoFar $Comp) + (compare $Rel $V1 $V2) + (set-det) + (compose1 $Rel $V1 $Vs1 $V2 $N2 $G2 $SoFar $Comp)) + (= (compose1 $_ $_ $Comp $Comp) True) - (= - (compose1 = $V1 $Vs1 $V1 $N2 $G2 $SoFar $Comp) - ( (ord-union $N2 $SoFar $Next) (compose1 $Vs1 $G2 $Next $Comp))) -; + (= (compose1 < $_ $Vs1 $V2 $N2 $G2 $SoFar $Comp) + (set-det) + (compose1 $Vs1 + (Cons + (- $V2 $N2) $G2) $SoFar $Comp)) + (= (compose1 > $V1 $Vs1 $_ $_ $G2 $SoFar $Comp) + (set-det) + (compose1 + (Cons $V1 $Vs1) $G2 $SoFar $Comp)) + (= (compose1 = $V1 $Vs1 $V1 $N2 $G2 $SoFar $Comp) + (ord-union $N2 $SoFar $Next) + (compose1 $Vs1 $G2 $Next $Comp)) ; (error ; (syntax_error end_of_file_in_block_comment) -; (stream (0x5562812ce500) 0 1 0)) +; (stream (0x55c987c85400) 0 1 0)) diff --git a/metagame/misc/randoms.metta b/metagame/misc/randoms.metta index 8f1f082..6dd6ab8 100644 --- a/metagame/misc/randoms.metta +++ b/metagame/misc/randoms.metta @@ -1,763 +1,495 @@ +; (convert_to_metta_file randoms $_458004 metagame/misc/randoms.pl metagame/misc/randoms.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; randoms.pl ; -; - +; ;; Provides pseudo-random numbers, using the interface to ; -; - +; ;; C provided by Sicstus. !(my-use-module (library random)) -; - !(dynamic (/ old-seed 1)) -; - - (= - (seed $S) + (= (seed $S) (getrand $S)) -; - ; -; - +; RESET_RANDOM(+S) ; -; - +; Resets the random state to a particular state. ; -; - +; Doesn't currently work with sicstus interface. - (= - (reset-random $S) + (= (reset-random $S) (setrand $S)) -; - ; -; - +; RESET_RANDOM ; -; - - (= - (reset-random) +; Ensures the random generator it is working. + (= (reset-random) (random $_)) -; - ; -; - +; ;; RECORD_SEED ; -; - +; ;; Records the random state, so a next run of the ; -; +; ;; system can be exactly the same as a previous run. - - (= - (record-seed) + (= (record-seed) ( (seed $S) - (remove-all-symbols &self + (remove-all-atoms &self (old_seed $_)) - (add-symbol &self + (add-is-symbol &self (old_seed $S)))) -; - ; -; - +; RECOVER_RANDOM ; -; - - - (= - (recover-random) - ( (old-seed $S) (reset-random $S))) -; +; Resets state to whichever was last recorded. + (= (recover-random) + (old-seed $S) + (reset-random $S)) ; -; - - - (= - (write-old-seed $CommentChar) - ( (old-seed $Seed) - (set-det) - (format "~n~w RANDOM SEED: ~w~n" - (:: $CommentChar $Seed)))) -; - - (= write_old_seed True) -; +; Writes a comment to a file that this seed was used. + (= (write-old-seed $CommentChar) + (old-seed $Seed) + (set-det) + (format "~n~w RANDOM SEED: ~w~n" + (:: $CommentChar $Seed))) + (= write_old_seed True) ; -; - +; random(-R) ; -; - +; binds R to a new random number in [0.0,1.0) ; -; - - +; In library(random). - (= - (random-include $L $U $R) - ( (integer $L) - (integer $U) - (set-det) - (is $U1 - (+ $U 1)) - (random $L $U1 $R))) -; - (= - (random-include $L $U $R) + (= (random-include $L $U $R) + (integer $L) + (integer $U) + (set-det) + (is $U1 + (+ $U 1)) + (random $L $U1 $R)) +; /* ; random(+L, +U, -R) ; binds R to a random integer in [L,U) when L and U are integers ; (note that U will NEVER be generated), or to a random floating ; number in [L,U] otherwise. ; In library(random). ; For now, I include a corrected version, until they fix a bug in ; sicstus random. random(L, U, R) :- integer(L), integer(U), random(X), !, R is L+integer(floor((U-L)*X)). random(L, U, R) :- number(L), number(U), random(X), !, R is L+((U-L)*X). */ +; ; random_include(+L, +U, -R) ; binds R to a random integer in [L,U] when L and U are integers ; or to a random floating number in [L,U] otherwise. + (= (random-include $L $U $R) (random $L $U $R)) -; - ; -; - +; ;; random(+R,-N) ; -; - - - (= - (random $R $N) - ( (is $R1 - (+ $R 1)) (random 1 $R1 $N))) -; +; ;; binds N to a random integer in [1,R]. + (= (random $R $N) + (is $R1 + (+ $R 1)) + (random 1 $R1 $N)) ; -; - +; ;; random_element(+Set,-Element) ; -; - - +; ;; Randomly returns an Element of Set (a list). - (= - (random-element $Set $Element) - ( (length $Set $Length) - (random $Length $R) - (nth $R $Set $Element))) -; + (= (random-element $Set $Element) + (length $Set $Length) + (random $Length $R) + (nth $R $Set $Element)) ; -; - +; sicstus-version.pl has random-select from the quintus ; -; - +; library. This is necessary for the metagame system. ; -; - +; random_select(?Elem, ?List, ?Rest) ; -; - +; unifies Elem with a random element of List and Rest with all the ; -; - +; other elements of List (in order). Either List or Rest should ; -; - +; be proper, and List should/will have one more element than Rest. ; -; - +; Takes O(N) time (average and best case). ; -; - +; random_permute(List1,List2). ; -; - +; Randomly permutes List1 into List2. ; -; - +; If random_select takes O(N) time, this routine takes ; -; - +; O(N^2) time. This could be improved to O(N) time ; -; - +; using arrays. - (= - (random-permute Nil Nil) + (= (random-permute Nil Nil) (set-det)) -; - - (= - (random-permute $List1 - (Cons $Item $Rest)) - ( (random-select $Item $List1 $List) (random-permute $List $Rest))) -; - + (= (random-permute $List1 (Cons $Item $Rest)) + (random-select $Item $List1 $List) + (random-permute $List $Rest)) ; -; - +; RANDOM_BAGOF/3 ; -; - +; RANDOM_SETOF/3 ; -; - +; RANDOM_FINDALL/3 ; -; - +; Like the non-random versions, but randomly ; -; - - - - (= - (random-bagof $A $B $C) - ( (bagof $A $B $C1) (random-permute $C1 $C))) -; +; permutes the resulting bag/set. + (= (random-bagof $A $B $C) + (bagof $A $B $C1) + (random-permute $C1 $C)) - (= - (random-setof $A $B $C) - ( (setof $A $B $C1) (random-permute $C1 $C))) -; + (= (random-setof $A $B $C) + (setof $A $B $C1) + (random-permute $C1 $C)) - (= - (random-findall $A $B $C) - ( (findall $A $B $C1) (random-permute $C1 $C))) -; - + (= (random-findall $A $B $C) + (findall $A $B $C1) + (random-permute $C1 $C)) ; -; - +; ;; random_arg(+Term,-Element) ; -; - +; ;; Randomly returns an Arg of a Term. ; -; - +; ;; Note: When only two args, because of the ; -; - +; ;; simple random function, it might alternate ; -; - - - (= - (random-arg $Term $Element) - ( (functor $Term $Args $Arity) - (random $Arity $R) - (arg $R $Term $Element))) -; +; ;; between the two. + (= (random-arg $Term $Element) + (functor $Term $Args $Arity) + (random $Arity $R) + (arg $R $Term $Element)) ; -; - +; random_success(+Call) ; -; - +; Succeeds, with equal probability, on any successful call of Call. ; -; - +; Should not be used if Call side-effects. - (= - (random-success $Call) - ( (bagof $Call - (^ $Call - (call $Call)) $Calls) (random-element $Calls $Call))) -; - + (= (random-success $Call) + (bagof $Call + (^ $Call + (call $Call)) $Calls) + (random-element $Calls $Call)) ; -; - +; ;; randomly_pair(+List1,+List2,-Pairings) ; -; - +; Maps each in Arg1 to one in Arg2. ; -; - +; If Arg2 smaller, maps as many as can. ; -; +; Duplicates matter. - - (= - (randomly-pair Nil $_ Nil) + (= (randomly-pair Nil $_ Nil) (set-det)) -; - - (= - (randomly-pair $_ Nil Nil) + (= (randomly-pair $_ Nil Nil) (set-det)) -; - - (= - (randomly-pair - (Cons $A $As) $Set - (Cons - (= $A $Elt) $Pairs)) - ( (random-element $Set $Elt) - (extract $Elt $Set $Set1) - (randomly-pair $As $Set1 $Pairs))) -; - + (= (randomly-pair (Cons $A $As) $Set (Cons (= $A $Elt) $Pairs)) + (random-element $Set $Elt) + (extract $Elt $Set $Set1) + (randomly-pair $As $Set1 $Pairs)) ; -; - +; ;; random_subsets(+Count+Size,+List,-Subset) ; -; +; ;; Returns Count sets of Size unique elements from List. - - (= - (random-subsets 0 $_ $_ Nil) + (= (random-subsets 0 $_ $_ Nil) (set-det)) -; - - (= - (random-subsets $N $Size $Set - (Cons $Elt $Rest)) - ( (random-subset $Size $Set $Elt) - (is $N1 - (- $N 1)) - (random-subsets $N1 $Size $Set $Rest))) -; - + (= (random-subsets $N $Size $Set (Cons $Elt $Rest)) + (random-subset $Size $Set $Elt) + (is $N1 + (- $N 1)) + (random-subsets $N1 $Size $Set $Rest)) ; -; - +; ;; random_subset(+Size,+List,-Subset) ; -; - +; ;; Returns a set of Size unique elements from List. - (= - (random-subset 0 $_ Nil) + (= (random-subset 0 $_ Nil) (set-det)) -; - - (= - (random-subset $Size $Set - (Cons $Elt $Rest)) - ( (random-element $Set $Elt) - (extract $Elt $Set $Set1) - (is $Size1 - (- $Size 1)) - (random-subset $Size1 $Set1 $Rest))) -; - + (= (random-subset $Size $Set (Cons $Elt $Rest)) + (random-element $Set $Elt) + (extract $Elt $Set $Set1) + (is $Size1 + (- $Size 1)) + (random-subset $Size1 $Set1 $Rest)) ; -; - +; ;; random_different_args(Term,Arg1,Arg2) ; -; - +; ;; Returns Arg1 and Arg2, two random different Args ; -; - +; ;; in Term. ; -; +; ;; + (= (random-different-args $Term $Arg1 $Arg2) + (random-arg $Term $Arg1) + (random-different-arg $Term $Arg1 $Arg2)) - (= - (random-different-args $Term $Arg1 $Arg2) - ( (random-arg $Term $Arg1) (random-different-arg $Term $Arg1 $Arg2))) -; - - - (= - (random-different-arg $Term $ArgA $ArgB) + (= (random-different-arg $Term $ArgA $ArgB) (random-different-arg $Term $ArgA $ArgA $ArgB)) -; - - - (= - (random-different-arg $Term $ArgA $ArgB $ArgB) - ( (\== $ArgA $ArgB) (set-det))) -; - - (= - (random-different-arg $Term $ArgA $ArgA $ArgB) - ( (random-arg $Term $Arg1) (random-different-arg $Term $ArgA $Arg1 $ArgB))) -; + (= (random-different-arg $Term $ArgA $ArgB $ArgB) + (\== $ArgA $ArgB) + (set-det)) + (= (random-different-arg $Term $ArgA $ArgA $ArgB) + (random-arg $Term $Arg1) + (random-different-arg $Term $ArgA $Arg1 $ArgB)) ; -; - +; RANDOM_TEST(+R,+N,-Ratio) ; -; - +; Counts ratio out of 100 times that N is the ; -; +; random integer between 1 and R. - - (= - (random-test $R $N $Ratio) + (= (random-test $R $N $Ratio) (random-test $R $N 0 0 100 $Ratio)) -; - ; -; - +; RANDOM_TEST(+R,+N,+SampleSize,-Ratio) ; -; - +; Repeatedly (SampleSize Times), chooses a random integer between ; -; - - (= - (random-test $R $N $SampleSize $Ratio) +; 1 and R. Counts fraction that integer N occurs. + (= (random-test $R $N $SampleSize $Ratio) (random-test $R $N 0 0 $SampleSize $Ratio)) -; - - - (= - (random-test $R $N $Tried $Found $Tried $Ratio) - ( (is $Ratio - (/ $Found $Tried)) (set-det))) -; - - (= - (random-test $R $N $Tried $Found $Total $Ratio) - ( (random $R $N1) - (det-if-then-else - (= $N $N1) - (is $Found1 - (+ $Found 1)) - (= $Found1 $Found)) - (is $Tried1 - (+ $Tried 1)) - (random-test $R $N $Tried1 $Found1 $Total $Ratio))) -; + (= (random-test $R $N $Tried $Found $Tried $Ratio) + (is $Ratio + (/ $Found $Tried)) + (set-det)) + (= (random-test $R $N $Tried $Found $Total $Ratio) + (random $R $N1) + (det-if-then-else + (= $N $N1) + (is $Found1 + (+ $Found 1)) + (= $Found1 $Found)) + (is $Tried1 + (+ $Tried 1)) + (random-test $R $N $Tried1 $Found1 $Total $Ratio)) - (= - (sample-from-distribution $Dist $Choice) - ( (distribution $Dist $Options) - (random $R) - (in-prob-region $Options $R $Choice1) - (= $Choice1 $Choice))) -; - + (= (sample-from-distribution $Dist $Choice) + (distribution $Dist $Options) + (random $R) + (in-prob-region $Options $R $Choice1) + (= $Choice1 $Choice)) +; /* test_sample :- repeat, sample_from_distribution(distribution([a=0.8,b=0.05,c=0.1]), Choice), write(Choice), nl, fail. */ +; ; Distribution looks like: ; distribution([choice1=p1,...,choiceN=pn])) ; Pis must sum to 1 (exhaustive). ; [Though pn isn't used, so it can be anything]. ; Chooses from this distribution subject to these ; probabilities. - (= - (distribution - (distribution $Choices) $Choices) True) -; - + (= (distribution (distribution $Choices) $Choices) True) ; -; - +; in_prob_region([a=0.7,b=0.2,c=0.1],0.89,Choice). - (= - (in-prob-region - (:: (= $Choice $Prob)) $_ $Choice) + (= (in-prob-region (:: (= $Choice $Prob)) $_ $Choice) (set-det)) -; - - (= - (in-prob-region - (Cons - (= $C $P) $Choices) $Prob $C) - ( (< $Prob $P) (set-det))) -; - - (= - (in-prob-region - (Cons - (= $C $P) $Choices) $Prob $Choice) - ( (is $PRest - (- $Prob $P)) (in-prob-region $Choices $PRest $Choice))) -; - + (= (in-prob-region (Cons (= $C $P) $Choices) $Prob $C) + (< $Prob $P) + (set-det)) + (= (in-prob-region (Cons (= $C $P) $Choices) $Prob $Choice) + (is $PRest + (- $Prob $P)) + (in-prob-region $Choices $PRest $Choice)) ; -; - +; Range looks like: ; -; - +; range(Lower,Upper) ; -; - +; Chooses a random number in the range [Lower,Upper], ; -; - - - (= - (sample-from-range $Range $Choice) - ( (range $Range $Min $Max) (random-include $Min $Max $Choice))) -; +; either integer or number, based on Lower and Upper. + (= (sample-from-range $Range $Choice) + (range $Range $Min $Max) + (random-include $Min $Max $Choice)) - (= - (range - (range $Min $Max) $Min $Max) True) -; - + (= (range (range $Min $Max) $Min $Max) True) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ; Sampling from distributions ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Here distributions are represented as assoc-lists, not ; -; - +; with = signs as above. ; -; - +; Distribution looks like: ; -; - +; [choice1-p1,...,choiceN-pn] ; -; - +; Pis can be any non-negative numbers. ; -; - +; Chooses from this distribution subject to relative ; -; - +; probabilities, each pi getting its proportion of ; -; - - - (= - (sample $Dist $Choice) - ( (pair-list $Choices $Weights $Dist) - (sum-list $Weights $Total) - (random 0.0 $Total $R) - (in-region $Dist $R $Choice1) - (= $Choice1 $Choice))) -; +; the total. + (= (sample $Dist $Choice) + (pair-list $Choices $Weights $Dist) + (sum-list $Weights $Total) + (random 0.0 $Total $R) + (in-region $Dist $R $Choice1) + (= $Choice1 $Choice)) ; -; - +; sample(N,Dist,Samples). ; -; - - (= - (sample 0 $_ Nil) +; Result is a list of N samples (with replacement) from a distribution. + (= (sample 0 $_ Nil) (set-det)) -; - - (= - (sample $N $Dist - (Cons $S $Samples)) - ( (> $N 0) - (is $N1 - (- $N 1)) - (sample $Dist $S) - (sample $N1 $Dist $Samples))) -; - + (= (sample $N $Dist (Cons $S $Samples)) + (> $N 0) + (is $N1 + (- $N 1)) + (sample $Dist $S) + (sample $N1 $Dist $Samples)) ; -; - +; ;; sample_subsets(+Count+Size,+List,-Subset) ; -; - +; ;; Returns Count sets of Size elements sampled from a ; -; +; ;; distribution. - - (= - (sample-subsets 0 $_ $_ Nil) + (= (sample-subsets 0 $_ $_ Nil) (set-det)) -; - - (= - (sample-subsets $N $Size $Dist - (Cons $Elt $Rest)) - ( (sample $Size $Dist $Elt) - (is $N1 - (- $N 1)) - (sample-subsets $N1 $Size $Dist $Rest))) -; - + (= (sample-subsets $N $Size $Dist (Cons $Elt $Rest)) + (sample $Size $Dist $Elt) + (is $N1 + (- $N 1)) + (sample-subsets $N1 $Size $Dist $Rest)) - (= - (test-sample) - ( (repeat) - (sample - (:: - (- a 5) - (- b 10) - (- d 15)) $Choice) - (write $Choice) - (nl) - (fail))) -; - + (= (test-sample) + (repeat) + (sample + (:: + (- a 5) + (- b 10) + (- d 15)) $Choice) + (write $Choice) + (nl) + (fail)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ; random seed setting ; -; - - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (randomize $N) - ( (format 'Using random seed #~p.~n' - (:: $N)) (randomize0 $N))) -; + (= (randomize $N) + (format 'Using random seed #~p.~n' + (:: $N)) + (randomize0 $N)) - (= - (randomize0 1) + (= (randomize0 1) (setrand (random 2260 5202 18078 -111865839))) -; - - (= - (randomize0 2) + (= (randomize0 2) (setrand (random 1676 2152 14938 -111865839))) -; - - (= - (randomize0 3) + (= (randomize0 3) (setrand (random 14918 9840 11226 -111865839))) -; - - (= - (randomize0 4) + (= (randomize0 4) (setrand (random 11477 9180 488 -111865839))) -; - - (= - (randomize0 5) + (= (randomize0 5) (setrand (random 27112 8989 12856 -111865839))) -; - - (= - (randomize0 6) + (= (randomize0 6) (setrand (random 27949 24755 16306 -111865839))) -; - - (= - (randomize0 7) + (= (randomize0 7) (setrand (random 3126 20129 24910 -111865839))) -; - - (= - (randomize0 8) + (= (randomize0 8) (setrand (random 21946 18049 2077 -111865839))) -; - - (= - (randomize0 9) + (= (randomize0 9) (setrand (random 26016 4946 13012 -111865839))) -; - - (= - (randomize0 10) + (= (randomize0 10) (setrand (random 18553 19429 25736 -111865839))) -; - - (= - (randomize0 test) + (= (randomize0 test) (setrand (random 1734 10872 10679 -111865839))) -; - diff --git a/metagame/misc/shells.metta b/metagame/misc/shells.metta index 753868f..217dd44 100644 --- a/metagame/misc/shells.metta +++ b/metagame/misc/shells.metta @@ -1,601 +1,390 @@ +; (convert_to_metta_file shells $_172758 metagame/misc/shells.pl metagame/misc/shells.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; shells.pl ; -; - +; ;; Useful routines for interacting with unix via MeTTa. !(ensure-loaded (library aux)) -; - ; -; - +; SHELL(+Tree) ; -; - +; Extremely useful command for interfacing with unix system. ; -; - +; Tree is a list of lists. ; -; - +; Flattens this tree into a list, treats each element of this list ; -; - +; (each atom) as a word in the command, which is then sent to unix. ; ; - - (= - (shell $Tree) - ( (command-from-args $Tree $Command) (unix (shell $Command)))) -; - + (= (shell $Tree) + (command-from-args $Tree $Command) + (unix (shell $Command))) ; -; - +; SHELL(+Tree,-Value) ; -; - +; Calls the command, and reads in the first term output ; -; - - (= - (shell $Command $Value) +; by that command as Value. + (= (shell $Command $Value) (shell $Command /tmp/shelltmp $Value)) -; - ; -; - +; SHELL(+Tree,+TmpFile,-Value) ; -; - +; Calls the command, outputs the result to a temp file TmpFile, ; -; - +; and reads in the first term from that file as Value, ; -; - +; then deletes TmpFile. ; -; - +; It would be much faster if we could use environmnet variables ; -; - +; to pass data back, but neither Quintus nor Sicstus let us ; -; - - (= - (shell $Command $TmpFile $Value) - ( (shell (:: $Command > $TmpFile ' ; echo ' . ' >> ' $TmpFile)) - (see $TmpFile) - (read $Value) - (seen) - (shell (:: rm $TmpFile)))) -; - +; change the variables of the shell in use. + (= (shell $Command $TmpFile $Value) + (shell (:: $Command > $TmpFile ' ; echo ' . ' >> ' $TmpFile)) + (see $TmpFile) + (read $Value) + (seen) + (shell (:: rm $TmpFile))) ; -; - +; SHELL_OUT(+Tree,+File) ; -; - +; Calls the command, outputs the result to File. - (= - (shell-out $Command $File) + (= (shell-out $Command $File) (shell (:: $Command > $File))) -; - ; -; - +; WRITEP(+Command,+File) ; -; - +; Echos the command to File. ; -; - +; Works with pipes. - (= - (writep $Command $File) + (= (writep $Command $File) (shell-out (:: echo $Command) $File)) -; - - (= - (command-from-args $Tree $Command) + (= (command-from-args $Tree $Command) (command-from-args $Tree ' ' $Command)) -; - - - (= - (command-from-args $Tree $Space $Command) - ( (flatten $Tree $List) - (interleave-list $List $Space $SpacedList) - (concat-list $SpacedList $Command))) -; + (= (command-from-args $Tree $Space $Command) + (flatten $Tree $List) + (interleave-list $List $Space $SpacedList) + (concat-list $SpacedList $Command)) - (= - (interleave-list Nil $_ Nil) + (= (interleave-list Nil $_ Nil) (set-det)) -; - - (= - (interleave-list - (:: $H) $_ - (:: $H)) + (= (interleave-list (:: $H) $_ (:: $H)) (set-det)) -; - - (= - (interleave-list - (Cons $H $T) $Sym - (Cons $H - (Cons $Sym $TT))) + (= (interleave-list (Cons $H $T) $Sym (Cons $H (Cons $Sym $TT))) (interleave-list $T $Sym $TT)) -; - - (= - (spacify_list () ()) True) -; - - (= - (spacify-list - (Cons $H $T) - (Cons $H - (Cons ' ' $TT))) + (= (spacify_list () ()) True) + (= (spacify-list (Cons $H $T) (Cons $H (Cons ' ' $TT))) (spacify-list $T $TT)) -; - ; -; - +; UNLOADED_HOST(Addr) ; -; - +; Calls a special command to find the name of an unloaded host ; -; - +; to use. If your system does not have such a program, ; -; - +; you must either write one or give specific host ; -; - +; names. - (= - (unloaded-host $Addr) + (= (unloaded-host $Addr) (shell (:: rsh ely /usr/etc/resman dbank) $Addr)) -; - ; -; - +; SHELL_RSH(+Program,+Args), ; -; - - - (= - (shell-rsh $Program $Args) - ( (current-host $Addr) (shell-rsh $Addr $Program $Args))) -; +; Runs Program with its Args as a shell on the current host. + (= (shell-rsh $Program $Args) + (current-host $Addr) + (shell-rsh $Addr $Program $Args)) ; -; - +; SHELL_RSH(+Addr,+Program,+Args) ; -; - +; Runs Program with its Args as a remote shell on host Addr, ; -; - +; defaulting the title as the name of the program. ; ; - ; -; +; If Addr=any, finds the least used host. - - (= - (shell-rsh any $Program $Args) - ( (set-det) - (unloaded-host $Addr) - (shell-rsh $Addr $Program $Args))) -; - - (= - (shell-rsh $Addr $Program $Args) + (= (shell-rsh any $Program $Args) + (set-det) + (unloaded-host $Addr) + (shell-rsh $Addr $Program $Args)) + (= (shell-rsh $Addr $Program $Args) (shell-rsh $Addr $Program $Args $Addr)) -; - ; -; - +; SHELL_RSH(+Addr,+Program,+Args,+Title) ; -; - +; Runs Program with its Args as a remote shell on host Addr. ; -; - +; As we use XRSH, we give the window a Title. ; ; - - (= - (shell-rsh any $Program $Args $Title) - ( (set-det) - (unloaded-host $Addr) - (shell-rsh $Addr $Program $Args $Title))) -; - - (= - (shell-rsh $Addr $Program $Args $Title) + (= (shell-rsh any $Program $Args $Title) + (set-det) + (unloaded-host $Addr) + (shell-rsh $Addr $Program $Args $Title)) + (= (shell-rsh $Addr $Program $Args $Title) (shell (:: %HOME/Bin/xrsh $Addr 'xterm ' -sb -name $Title -title $Title -e $Program $Args &))) -; - ; -; - +; START_SICSTUS_SHELL(+Host,+ArgsList) ; -; - +; Runs a sicstus shell on Host (could be ANY), ; -; - +; calling it with its list of args. - (= - (start-sicstus-shell $Host $Args) + (= (start-sicstus-shell $Host $Args) (shell-rsh $Host sicstus $Args)) -; - - (= - (start-sicstus-shell $Args) + (= (start-sicstus-shell $Args) (shell-rsh sicstus $Args)) -; - ; -; - +; FIND_ARCHITECTURE(-Arch) ; -; - +; enables the command: current_architecture(-Arch), ; -; - +; like current_host(-Host). - (= - (find-architecture $Arch) - ( (shell arch $Arch) (add-symbol &self (found_current_architecture $Arch)))) -; - - - - (= - (current-architecture $Arch) - ( (get-current-architecture $Arch1) (= $Arch $Arch1))) -; + (= (find-architecture $Arch) + ( (shell arch $Arch) (add-is-symbol &self (found_current_architecture $Arch)))) + (= (current-architecture $Arch) + (get-current-architecture $Arch1) + (= $Arch $Arch1)) - (= - (get-current-architecture $Arch) - ( (environment-variable %ARCH $Arch) (set-det))) -; - (= - (get-current-architecture $Arch) + (= (get-current-architecture $Arch) + (environment-variable %ARCH $Arch) + (set-det)) + (= (get-current-architecture $Arch) (det-if-then-else (current-predicate found-current-architecture $_) (found-current-architecture $Arch) (find-architecture $Arch))) -; - - (= - (bin-directory $D) - ( (current-architecture $Arch) (concat-list (:: ~/prolog/bin/ $Arch /) $D))) -; - + (= (bin-directory $D) + (current-architecture $Arch) + (concat-list + (:: ~/prolog/bin/ $Arch /) $D)) ; -; - +; Arch is a placeholder, to be inserted in Path, to make Name. ; -; - +; arch_path_name(Arch,['MeTTa/',Arch,'/newrandoms'],Dir). ; -; - +; Arch = sun4, ; -; - +; Name = 'MeTTa/sun4/newrandoms' ; ; - - (= - (arch-path-name $Arch $Path $Name) - ( (current-architecture $Arch) (concat-list $Path $Name))) -; - + (= (arch-path-name $Arch $Path $Name) + (current-architecture $Arch) + (concat-list $Path $Name)) - (= - (add-bin-library) - ( (bin-directory $D) (add-symbol &self (library_directory $D)))) -; - + (= (add-bin-library) + ( (bin-directory $D) (add-is-symbol &self (library_directory $D)))) - (= - (current-directory $X) + (= (current-directory $X) (absolute-file-name . $X)) -; - - (= - (file-exists $X) + (= (file-exists $X) (unix (access $X 0))) -; - ; -; - +; ENVIRONMENT_VARIABLE(+Name,?Value) ; -; - +; Name should be a unix environment variable, like: '$ARCH'. ; -; - +; Value will be its value, like: sun4. - (= - (environment-variable $Name $Value) + (= (environment-variable $Name $Value) (shell (:: echo $Name) $Value)) -; - ; -; - +; WITH_OUTPUT_FILE(+File,+Mode,+Goal) ; -; - +; Opens File for writing in Mode (write or append), ; -; - +; executes Goal with this output stream current, ; -; - - - (= - (with-output-file $File $Mode $Goal) - ( (switch-output-to-file $File $Mode $Old $New) - (call $Goal) - (close $New) - (set-output $Old))) -; +; then closes the stream and reverts to previous output. + (= (with-output-file $File $Mode $Goal) + (switch-output-to-file $File $Mode $Old $New) + (call $Goal) + (close $New) + (set-output $Old)) ; -; - +; WITH_INPUT_FILE(+File,+Goal) ; -; - +; Opens File for reading, ; -; - +; executes Goal with this input stream current, ; -; - - - (= - (with-input-file $File $Goal) - ( (switch-input-to-file $File $Old $New) - (call $Goal) - (close $New) - (set-input $Old))) -; +; then closes the stream and reverts to previous input. + (= (with-input-file $File $Goal) + (switch-input-to-file $File $Old $New) + (call $Goal) + (close $New) + (set-input $Old)) ; -; - +; SWITCH_OUTPUT_TO_FILE(+File,+Mode,-Old,-New) ; -; - +; Opens File for output in MODE (write or append). ; -; - +; NEW is returned as the new stream, and becomes the current output. ; -; - - - (= - (switch-output-to-file $File $Mode $Old $New) - ( (current-output $Old) - (open $File $Mode $New) - (set-output $New))) -; +; OLD is the previous output stream. + (= (switch-output-to-file $File $Mode $Old $New) + (current-output $Old) + (open $File $Mode $New) + (set-output $New)) ; -; - +; SWITCH_INPUT_TO_FILE(+File,-Old,-New) ; -; - +; Opens File for input, with NEW as the stream, ; -; - +; and sets it to current input. OLD is the previous input ; -; - - - (= - (switch-input-to-file $File $Old $New) - ( (current-input $Old) - (open $File read $New) - (set-input $New))) -; +; stream. + (= (switch-input-to-file $File $Old $New) + (current-input $Old) + (open $File read $New) + (set-input $New)) ; -; - +; WITH_TEMP_OUTFILE(+Template,-File,+Goal) ; -; - +; Gensyms as File a new filename in /tmp/, based on Template. ; -; - +; Then calls Goal, which should create File. ; -; - +; At the end, this deletes File ; -; - +; unless 'trace savetables' is on. ; ; - ; -; - +; mktemp only really works in sicstus MeTTa. ; -; - +; The file quintus-version defines it for quintus to ; -; - +; just use that filename, while sicstus generates a ; -; - - - (= - (with-temp-file $Template $File $Goal) - ( (gensym $Template $P) - (concat-list - (:: /tmp/ $P XXXXXX) $FullTemplate) - (mktemp $FullTemplate $File) - (call $Goal) - (det-if-then-else - (tracing savetables) True - (shell (:: rm $File))))) -; +; guaranteed unique version of that template. + (= (with-temp-file $Template $File $Goal) + (gensym $Template $P) + (concat-list + (:: /tmp/ $P XXXXXX) $FullTemplate) + (mktemp $FullTemplate $File) + (call $Goal) + (det-if-then-else + (tracing savetables) True + (shell (:: rm $File)))) ; -; - +; mktemp(File,File). ; -; - +; Some abbreviations - (= - (cd) + (= (cd) (unix cd)) -; - - (= - (cd $X) + (= (cd $X) (unix (cd $X))) -; - - (= - (ls) + (= (ls) (unix (shell ls))) -; - - (= - (lsa) + (= (lsa) (unix (shell 'ls -Al'))) -; - - (= - (pwd) + (= (pwd) (unix (shell pwd))) -; - diff --git a/metagame/misc/theoryl.metta b/metagame/misc/theoryl.metta index 5527ff8..1e2a869 100644 --- a/metagame/misc/theoryl.metta +++ b/metagame/misc/theoryl.metta @@ -1,308 +1,204 @@ +; (convert_to_metta_file theoryl $_338406 metagame/misc/theoryl.pl metagame/misc/theoryl.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; ; - ; -; - +; This file is thanks to William Cohen, who may reserve the ; -; - +; copyright. ; -; - +; ============================================================ ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ; theoryl.pl -- routines to manipulate the domain theory ; -; - +; ; ; -; - +; ; external routines: ; -; - +; ; theory_clause(?Head,?Body,?Id) :- like Quintus clause/3 ; -; - +; ; theory_assert(+Clause,-Id) :- like Quintus assert/2 ; -; - +; ; ; -; - +; ; syntax: domain theory is a set of labeled clauses of the form "tag::A:-B" ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ; syntax for theory clauses ; -; - +; :- current_op(P,T,(:-)),op(P,xfy,(::)). !(op 1200 xfy ::) -; - - (= - (theory-clause $G) + (= (theory-clause $G) (theory-clause $G True $Id)) -; - - (= - (theory-clause $G $H) + (= (theory-clause $G $H) (theory-clause $G $H $Id)) -; - ; -; - - - (= - (theory-clause $G $H $Id) - ( (var $Id) - (set-det) - (theory-clause0 $G $H $Id))) -; +; ; theory_clause(A,B,Id) :- clause A:-B with identifier Id is in the theory - (= - (theory-clause $G $H - (ith-converse $I $Id)) - ( (set-det) - (theory-clause0 $H $Gs $Id) - (ith-and-member $I $G $Gs))) -; - - (= - (theory-clause $G $H $Id) - ( (set-det) (theory-clause0 $G $H $Id))) -; + (= (theory-clause $G $H $Id) + (var $Id) + (set-det) + (theory-clause0 $G $H $Id)) + (= (theory-clause $G $H (ith-converse $I $Id)) + (set-det) + (theory-clause0 $H $Gs $Id) + (ith-and-member $I $G $Gs)) + (= (theory-clause $G $H $Id) + (set-det) + (theory-clause0 $G $H $Id)) + (= (theory-clause0 $A $B $Id) + (:: $Id $C) + (det-if-then-else + (= + (= $A $B) $C) True + (det-if-then otherwise + (= + (= $A $B) + (= $C True))))) - (= - (theory-clause0 $A $B $Id) - ( (:: $Id $C) (det-if-then-else (= (= $A $B) $C) True (det-if-then otherwise (= (= $A $B) (= $C True)))))) -; - - - (= - (ith-and-member 0 $A - (, $A $_)) + (= (ith-and-member 0 $A (, $A $_)) (set-det)) -; - - (= - (ith-and-member 0 $A $A) + (= (ith-and-member 0 $A $A) (set-det)) -; - - (= - (ith-and-member $I $A - (, $_ $B)) - ( (> $I 0) - (is $I1 - (- $I 1)) - (ith-and-member $I1 $A $B))) -; + (= (ith-and-member $I $A (, $_ $B)) + (> $I 0) + (is $I1 + (- $I 1)) + (ith-and-member $I1 $A $B)) - - (= - (system-predicate $Goal) - ( (functor $Goal $F $N) - (functor $PredSpec $F $N) - (not (theory-clause $PredSpec $_ $_)))) -; - + (= (system-predicate $Goal) + (functor $Goal $F $N) + (functor $PredSpec $F $N) + (not (theory-clause $PredSpec $_ $_))) ; -; - +; ; theory_assert(+Clause,?Id) :- create a new Horn clause ; -; - +; ; of the form (G:-H) and asign it id Idnew !(dynamic (/ next-clause-id 1)) -; - - - (= - (next_clause_id 0) True) -; + (= (next_clause_id 0) True) ; -; - +; Default to assertz. ; -; - +; theory_assert(Clause) :- theory_assert_az(Clause,_,z). - (= - (theory-assert $Clause) + (= (theory-assert $Clause) (theory-assert $Clause $_)) -; - ; -; - +; ; theory_assert[az](+Clause,?Id) :- create a new Horn clause ; -; +; ; of the form (G:-H) and asign it the id Idnew - - (= - (theory-assert $Clause - (new $N)) + (= (theory-assert $Clause (new $N)) ( (clause-parts $Clause $G $H) - (remove-symbol &self + (remove-is-symbol &self (next_clause_id $N)) (is $N1 (+ $N 1)) - (add-symbol &self + (add-is-symbol &self (next_clause_id $N1)) - (add-symbol &self + (add-is-symbol &self (:: (new $N) (:- $G $H))))) -; - ; -; - +; ; theory_assert_az(+Clause,?Id,AZ) :- create a new Horn clause ; -; - +; ; of the form (G:-H) and asign it the id Idnew ; -; - +; ; If AZ = a, asserta, if z, assertz. - (= - (theory-assert-az $Clause - (new $N) $AZ) + (= (theory-assert-az $Clause (new $N) $AZ) ( (clause-parts $Clause $G $H) - (remove-symbol &self + (remove-is-symbol &self (next_clause_id $N)) (is $N1 (+ $N 1)) - (add-symbol &self + (add-is-symbol &self (next_clause_id $N1)) (assertaz $AZ (:: (new $N) - (= $G $H))))) -; - - + (= $G $H))))) - (= - (assertaz a $C) - (add-symbol &self $C)) -; - - (= - (assertaz z $C) - (add-symbol &self $C)) -; + (= (assertaz a $C) + (add-is-symbol &self $C)) + (= (assertaz z $C) + (add-is-symbol &self $C)) - (= - (clause-parts - (= $G $H) $G $H) + (= (clause-parts (= $G $H) $G $H) (set-det)) -; - - (= - (clause-parts $G $G True) + (= (clause-parts $G $G True) (not (functor $G :- 2))) -; - ; -; - +; ; new_id(+Id) :- test if Id is recently asserted - (= - (new_id - (new $_)) True) -; - + (= (new_id (new $_)) True) ; -; - - +; ; theory_retract(?(G:-H)) :- retract a Horn clause - (= - (theory-retract $Clause $Id) - ( (clause-parts $Clause $G $H) (remove-symbol &self (:: $Id (:- $G $H))))) -; + (= (theory-retract $Clause $Id) + ( (clause-parts $Clause $G $H) (remove-is-symbol &self (:: $Id (:- $G $H))))) - (= - (theory-retract $Clause) + (= (theory-retract $Clause) (theory-retract $Clause $Id)) -; - - (= - (theory-clear) - (remove-all-symbols &self + (= (theory-clear) + (remove-all-atoms &self (:: $Id $Clause))) -; - - (= - (theory-listing) + (= (theory-listing) (whenever (theory-clause $C) (portray-clause $C))) -; - diff --git a/metagame/misc/timing.metta b/metagame/misc/timing.metta index b58ad10..0856f28 100644 --- a/metagame/misc/timing.metta +++ b/metagame/misc/timing.metta @@ -1,464 +1,316 @@ +; (convert_to_metta_file timing $_456020 metagame/misc/timing.pl metagame/misc/timing.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ; timing.pl ; -; - +; ; --------- ; -; - +; ; basic timing utilities ; -; - +; ; ; -; - +; ; runtime_once :- print the time to call a MeTTa goal the first time ; -; - +; ; realtime_once :- same for real time. ; -; - +; ; runtime :- print the time to solve a MeTTa goal (new times on backtracking) ; -; - +; ; realtime :- same for real time. ; -; - +; ; runtime_success :- returns the time to solve a MeTTa goal the first time. ; -; - +; ; fails if doesn't solve it. ; -; - +; ; realtime_success :- same for real time. ; -; - +; ; cumulative_time(+Tasks) :- print the cumulative time used to do the tasks ; -; - +; ; (in runtime). ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; !(ensure-loaded (library aux)) -; - !(ensure-loaded (library shells)) -; - ; -; - +; ----------------------------- ; -; - +; TIMING(G,Method,Time,Success) ; -; - +; ----------------------------- - (= - (timing $G $Method $Time $Success) - ( (time-stat $Method $T0) - (or - (, - (call $G) - (= $Success yes)) - (= $Success no)) - (time-stat $Method $T1) - (is $Time - (- $T1 $T0)))) -; - + (= (timing $G $Method $Time $Success) + (time-stat $Method $T0) + (or + (, + (call $G) + (= $Success yes)) + (= $Success no)) + (time-stat $Method $T1) + (is $Time + (- $T1 $T0))) ; -; - +; ------------------------ ; -; - +; TIMING(Goal,Method,Time) ; -; - +; ------------------------ ; -; - +; Succeeds only when Success=yes. ; -; - - (= - (timing $Goal $Method $Time) - ( (timing $Goal $Method $Time $Success) - (format "Success: ~w~n" - (:: $Success)) - (format 'Time is ~3d sec.~n' - (:: $Time)) - (= $Success yes))) -; - +; Formats result whether succeeds or not. + (= (timing $Goal $Method $Time) + (timing $Goal $Method $Time $Success) + (format "Success: ~w~n" + (:: $Success)) + (format 'Time is ~3d sec.~n' + (:: $Time)) + (= $Success yes)) - (= - (realtime $G) + (= (realtime $G) (timing $G realtime $_)) -; - - (= - (runtime $G) + (= (runtime $G) (timing $G runtime $_)) -; - - (= - (runtimes $N $G) + (= (runtimes $N $G) (runtime (dotimes $N $G))) -; - ; -; - +; -------------------------------- ; -; - +; TIMING_SUCCESS(Goal,Method,Time) ; -; - +; -------------------------------- - (= - (timing-success $Goal $Method $Time) - ( (time-stat $Method $T0) - (call $Goal) - (set-det) - (time-stat $Method $T1) - (is $Time - (- $T1 $T0)))) -; - + (= (timing-success $Goal $Method $Time) + (time-stat $Method $T0) + (call $Goal) + (set-det) + (time-stat $Method $T1) + (is $Time + (- $T1 $T0))) - (= - (runtime-success $Goal $Time) + (= (runtime-success $Goal $Time) (timing-success $Goal runtime $Time)) -; - - (= - (realtime-success $Goal $Time) + (= (realtime-success $Goal $Time) (timing-success $Goal realtime $Time)) -; - ; -; - +; TIMING_ONCE(Goal,Method,Time) ; -; - +; ----------------------------- ; -; - +; Times first call to goal and prints result. ; -; - +; Always succeeds. ; ; - - (= - (timing-once $Goal $Method $Time) - ( (timing $Goal $Method $Time $Success) - (set-det) - (format "Success: ~w~n" - (:: $Success)) - (format 'Time is ~3d sec.~n' - (:: $Time)))) -; - + (= (timing-once $Goal $Method $Time) + (timing $Goal $Method $Time $Success) + (set-det) + (format "Success: ~w~n" + (:: $Success)) + (format 'Time is ~3d sec.~n' + (:: $Time))) - (= - (runtime-once $G) + (= (runtime-once $G) (timing-once $G runtime $_)) -; - - (= - (realtime-once $G) + (= (realtime-once $G) (timing-once $G realtime $_)) -; - ; -; - +; TIME_STAT(Type,Time) ; -; - +; -------------------- ; -; - +; Type is either realtime or runtime. ; -; - +; Result is in millisecs. - (= - (time-stat realtime $Time) - (realtime-msec $Time)) -; - - (= - (time-stat runtime $Time) + (= (time-stat realtime $Time) + (realtime-msec $Time)) + (= (time-stat runtime $Time) (statistics runtime - (Cons $Time $_))) -; - + (Cons $Time $_))) ; -; - +; ---------------------------------------- ; -; - +; Getting real time ; -; - +; ---------------------------------------- ; -; - +; Returns current world Time in the format: ; -; - +; Hour-Minute-Second ; ; - ; -; - +; REAL_TIME(Time) ; -; - +; --------------- ; -; +; Returns the current time in real time. - - (= - (real-time $Time) + (= (real-time $Time) (shell (:: date +%H-%M-%S) $Time)) -; - - (= - (time-seconds - (- - (- $H $M) $S) $Sec) + (= (time-seconds (- (- $H $M) $S) $Sec) (is $Sec (+ (+ $S (* 60 $M)) (* 3600 $H)))) -; - - - - (= - (time-msec $T $MSec) - ( (time-seconds $T $Sec) (is $MSec (* 1000 $Sec)))) -; - - (= - (realtime-seconds $Sec) - ( (real-time $T) (time-seconds $T $Sec))) -; + (= (time-msec $T $MSec) + (time-seconds $T $Sec) + (is $MSec + (* 1000 $Sec))) + (= (realtime-seconds $Sec) + (real-time $T) + (time-seconds $T $Sec)) - (= - (realtime-msec $Sec) - ( (real-time $T) (time-msec $T $Sec))) -; + (= (realtime-msec $Sec) + (real-time $T) + (time-msec $T $Sec)) ; -; - +; REALTIME_RANDOMIZE ; -; - +; A hacky and expensive way to use the real time ; -; - - - (= - (realtime-randomize) - ( (realtime-seconds $S) - (random 10 $S $R) - (is $X - (mod $R 100)) - (or - (dotimes $X - (, - (random $_) - (fail))) True))) -; +; to initalize the random seed. + (= (realtime-randomize) + (realtime-seconds $S) + (random 10 $S $R) + (is $X + (mod $R 100)) + (or + (dotimes $X + (, + (random $_) + (fail))) True)) ; -; - +; ============================================================================= ; -; - +; Cumulative timing ; -; - - - - (= - (cumulative-time $Tasks) - ( (statistics runtime - (Cons $T0 $_)) (cumulative-time $Tasks $T0 1))) -; - +; ============================================================================= - (= - (cumulative_time () $_ $_) True) -; - - (= - (cumulative-time - (Cons $Task $Tasks) $T0 $N) - ( (det-if-then-else $Task - (= - (:: $Mark) " ") - (= - (:: $Mark) "*")) - (statistics runtime - (Cons $T $_)) - (is $CTime - (- $T $T0)) - (format ~p~8|~p~c~n - (:: $N $CTime $Mark)) - (is $N1 - (+ $N 1)) - (set-det) - (cumulative-time $Tasks $T0 $N1))) -; + (= (cumulative-time $Tasks) + (statistics runtime + (Cons $T0 $_)) + (cumulative-time $Tasks $T0 1)) + + (= (cumulative_time () $_ $_) True) + (= (cumulative-time (Cons $Task $Tasks) $T0 $N) + (det-if-then-else $Task + (= + (:: $Mark) " ") + (= + (:: $Mark) "*")) + (statistics runtime + (Cons $T $_)) + (is $CTime + (- $T $T0)) + (format ~p~8|~p~c~n + (:: $N $CTime $Mark)) + (is $N1 + (+ $N 1)) + (set-det) + (cumulative-time $Tasks $T0 $N1)) ; -; - +; ============================================================================= ; -; - +; Waiting ; -; - - - - (= - (wait-msecs $MSec) - ( (statistics runtime - (Cons $T0 $_)) - (is $T1 - (+ $T0 $MSec)) - (wait-till-time $T1))) -; +; ============================================================================= + (= (wait-msecs $MSec) + (statistics runtime + (Cons $T0 $_)) + (is $T1 + (+ $T0 $MSec)) + (wait-till-time $T1)) - (= - (wait-till-time $T1) - ( (statistics runtime - (Cons $TN $_)) (det-if-then-else (>= $TN $T1) True (wait-till-time $T1)))) -; + (= (wait-till-time $T1) + (statistics runtime + (Cons $TN $_)) + (det-if-then-else + (>= $TN $T1) True + (wait-till-time $T1))) ; -; - +; ============================================================================== ; -; - +; Turning on and off TIMING parameter. ; -; - +; ============================================================================== ; -; - +; Some routines call the predicate TIMING(Call) instead of call directly, ; -; - +; which means call normally when timing mode off, else call runtime(Call). ; -; +; These are only useful for routines who measure REAL-TIME. - - (= - (timing $Call) - ( (timing) - (set-det) - (runtime $Call))) -; - - (= - (timing $Call) + (= (timing $Call) + (timing) + (set-det) + (runtime $Call)) + (= (timing $Call) (call $Call)) -; - - (= - (timing) + (= (timing) (parameter timing on)) -; - - (= - (set-timing) + (= (set-timing) (set-parameter timing on)) -; - - (= - (unset-timing) + (= (unset-timing) (set-parameter timing off)) -; - diff --git a/metagame/misc/tracing.metta b/metagame/misc/tracing.metta index 4f39118..fa1e598 100644 --- a/metagame/misc/tracing.metta +++ b/metagame/misc/tracing.metta @@ -1,197 +1,129 @@ +; (convert_to_metta_file tracing $_98416 metagame/misc/tracing.pl metagame/misc/tracing.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; tracing.pl ; -; - +; Barney Pell ; ; - ; -; - +; Supports verbose tracing of modules for software development. !(dynamic (/ %tracing 2)) -; - ; -; - +; TRACING(+Module,+Call) ; -; - +; If tracing is turned on for Module (which might be a pattern), calls Call, ; -; +; otherwise succeeds without it. - - (= - (tracing $Module $Call) + (= (tracing $Module $Call) (det-if-then-else (tracing $Module) (call $Call) True)) -; - ; -; - +; TRACING_FORMAT(Module,String,Args) ; -; - +; Like format/2, but only when we're tracing Module. ; -; - +; Might cause trouble later when want to use streams also. - (= - (tracing-format $Module $String $Args) + (= (tracing-format $Module $String $Args) (det-if-then-else (tracing $Module) (format $String $Args) True)) -; - ; -; - +; SET_TRACING(Module,Status) ; -; - - - (= - (set-tracing $Module $Status) - ( (remove-all-symbols &self - ($tracing $Module $Status1)) (add-symbol &self ($tracing $Module $Status)))) -; +; Sets an individual module's status (usually on or off). + (= (set-tracing $Module $Status) + ( (remove-all-atoms &self + (%tracing $Module $Status1)) (add-is-symbol &self (%tracing $Module $Status)))) ; -; - +; SET_TRACING(Module,Component,Status) ; -; - +; Sets a component of an individual module to status (usually on or off). ; -; - - (= - (set-tracing $Mod $Component $Status) - ( (functor $Module $Mod 1) - (arg 1 $Module $Component) - (set-tracing $Module $Status))) -; - +; Example: set_tracing(ab,iterations,on). + (= (set-tracing $Mod $Component $Status) + (functor $Module $Mod 1) + (arg 1 $Module $Component) + (set-tracing $Module $Status)) ; -; - +; tracing(+Pattern) ; -; - +; Pattern is either an atomic module name, or conjunct of disjunct of patterns. ; ; - - (= - (tracing $M) - ( (var $M) - (set-det) - (format "~nError in tracing: Variable Module~n" Nil))) -; - - (= - (tracing (or $M1 $M2)) + (= (tracing $M) + (var $M) + (set-det) + (format "~nError in tracing: Variable Module~n" Nil)) + (= (tracing (or $M1 $M2)) (or (, (set-det) (tracing $M1)) (tracing $M2))) -; - - (= - (tracing (, $M1 $M2)) - ( (set-det) - (tracing $M1) - (tracing $M2))) -; - - (= - (tracing $Module) + (= (tracing (, $M1 $M2)) + (set-det) + (tracing $M1) + (tracing $M2)) + (= (tracing $Module) (tracing-module $Module)) -; - - (= - (tracing-module $Module) + (= (tracing-module $Module) ($tracing $Module on)) -; - - - (= - (traced-modules $Modules) - ( (setof $M - (tracing-module $M) $Modules) (set-det))) -; - - (= - (traced_modules ()) True) -; + (= (traced-modules $Modules) + (setof $M + (tracing-module $M) $Modules) + (set-det)) + (= (traced_modules ()) True) ; -; - +; ================================================================================ ; -; - +; TIMING WHEN TRACING ; -; - +; ================================================================================ ; -; - +; TRACE_TIMING(module,Call) ; -; - +; just calls Call, if tracing is off for the module, otherwise calls Call and ; -; - +; outputs the time used. ; -; +; Again Module can be a pattern. - - (= - (trace-timing $Module $Call) - ( (tracing $Module) - (set-det) - (runtime $Call))) -; - - (= - (trace-timing $_ $Call) + (= (trace-timing $Module $Call) + (tracing $Module) + (set-det) + (runtime $Call)) + (= (trace-timing $_ $Call) (call $Call)) -; - diff --git a/metagame/play/advisors.metta b/metagame/play/advisors.metta index b06e6fa..f8942a4 100644 --- a/metagame/play/advisors.metta +++ b/metagame/play/advisors.metta @@ -1,494 +1,339 @@ +; (convert_to_metta_file advisors $_188052 metagame/play/advisors.pl metagame/play/advisors.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; advisors.pl ; -; - +; ;; Provides move filters and corresponding choice methods (players). ; -; - +; ================================================================================ ; -; - +; Choice Methods ; -; - +; ================================================================================ ; -; - +; Here are a few built-in choice methods which can be called for different players. ; -; - +; See the file local.pl for how they are used with the local interface, ; -; - +; or the file randomist.pl for an example how they can serve as the basis for ; -; - +; remote players. ; ; - ; -; - +; The move generators (or filters) on which they are based are defined here also. ; -; - +; ================================ ; -; - +; HUMAN_CHOOSE(Player,Move,SIn,SOut) ; -; - +; ================================ ; -; - +; Calls the nice user a nice interface for selecting moves. ; ; - - (= - (human-choose $Player $Move $SIn $SOut) - ( (control $Player $SIn) (ask-move $Move $SIn $SOut))) -; - + (= (human-choose $Player $Move $SIn $SOut) + (control $Player $SIn) + (ask-move $Move $SIn $SOut)) ; -; - +; ================================ ; -; - +; THREATEN_CHOOSE(Player,Move,SIn,SOut) ; -; - +; ================================ ; -; - +; Choose randomly at start, as checking for stalemate ; -; - +; at start of game takes so long. ; -; - +; After start, play threats if have them, else random. ; ; - - (= - (threaten-choose $Role $Move $SIn $SOut) - ( (det-if-then - (move-count $N $SIn) - (=< $N 1)) - (set-det) - (random-choose $Role $Move $SIn $SOut))) -; - - (= - (threaten-choose $_ $Move $SIn $SOut) - ( (timing (threaten-move $Move $SIn $SOut)) - (set-det) - (print-choice $Move $SIn $SOut))) -; - - (= - (threaten-choose $Role $Move $SIn $SOut) + (= (threaten-choose $Role $Move $SIn $SOut) + (det-if-then + (move-count $N $SIn) + (=< $N 1)) + (set-det) + (random-choose $Role $Move $SIn $SOut)) + (= (threaten-choose $_ $Move $SIn $SOut) + (timing (threaten-move $Move $SIn $SOut)) + (set-det) + (print-choice $Move $SIn $SOut)) + (= (threaten-choose $Role $Move $SIn $SOut) (random-choose $Role $Move $SIn $SOut)) -; - ; -; - +; ================================ ; -; - +; INSTANT_CHOOSE(Player,Move,SIn,SOut) ; -; - - - (= - (instant-choose $Player $Move $SIn $SOut) - ( (control $Player $SIn) - (format "~nThe Instant Moves:~n" Nil) - (instant-move $Move $SIn $SOut) - (print-choice $Move $SIn $SOut))) -; +; ================================ + (= (instant-choose $Player $Move $SIn $SOut) + (control $Player $SIn) + (format "~nThe Instant Moves:~n" Nil) + (instant-move $Move $SIn $SOut) + (print-choice $Move $SIn $SOut)) ; -; - - - (= - (instant-move $Move $SIn $SOut) - ( (legal $Move $SIn $SOut) (set-det))) -; +; INSTANT_MOVE(Move,SIn,SOut) + (= (instant-move $Move $SIn $SOut) + (legal $Move $SIn $SOut) + (set-det)) ; -; - +; ======================================== ; -; - +; RANDOM_CHOOSE(Player,Move,SIn,SOut) ; -; - - - (= - (random-choose $Player $Move $SIn $SOut) - ( (control $Player $SIn) - (timing (random-move $Move $SIn $SOut)) - (set-det) - (print-choice $Move $SIn $SOut))) -; +; ======================================== + (= (random-choose $Player $Move $SIn $SOut) + (control $Player $SIn) + (timing (random-move $Move $SIn $SOut)) + (set-det) + (print-choice $Move $SIn $SOut)) ; -; - +; RANDOM_MOVE(M,SIn,SOut) - (= - (random-move $M $SIn $SOut) + (= (random-move $M $SIn $SOut) (random-success (legal $M $SIn $SOut))) -; - ; -; - +; ======================================== ; -; - +; CAUTIOUS_CHOOSE(Player,Move,SIn,SOut) ; -; - - - (= - (cautious-choose $Player $Move $SIn $SOut) - ( (timing (cautious-move $Move $SIn $SOut)) - (set-det) - (print-choice $Move $SIn $SOut))) -; +; ======================================== + (= (cautious-choose $Player $Move $SIn $SOut) + (timing (cautious-move $Move $SIn $SOut)) + (set-det) + (print-choice $Move $SIn $SOut)) ; -; - +; A CAUTIOUS_MOVE is one which does not lose immediately, ; -; +; and which does not allow a victor_move response. - - (= - (cautious-move $Move $SIn $SOut) - ( (safe-move $Move $SIn $SOut) (not (victor-move $M2 $SOut $_)))) -; - + (= (cautious-move $Move $SIn $SOut) + (safe-move $Move $SIn $SOut) + (not (victor-move $M2 $SOut $_))) ; -; - - +; A SAFE_MOVE is one which does not lose immediately. - (= - (safe-move $Move $SIn $SOut) - ( (control $Player $SIn) - (opposite-role $Player $Opponent) - (legal $Move $SIn $SOut) - (not (game-outcome $Opponent $SOut)))) -; + (= (safe-move $Move $SIn $SOut) + (control $Player $SIn) + (opposite-role $Player $Opponent) + (legal $Move $SIn $SOut) + (not (game-outcome $Opponent $SOut))) ; -; - +; Assumes legal already, just makes sure the player who ; -; - - - (= - (check-safe-move $Move $SIn $SOut) - ( (control $Player $SIn) - (opposite-role $Player $Opponent) - (not (game-outcome $Opponent $SOut)))) -; +; moved doesn't lose as a result. + (= (check-safe-move $Move $SIn $SOut) + (control $Player $SIn) + (opposite-role $Player $Opponent) + (not (game-outcome $Opponent $SOut))) ; -; - +; ======================================== ; -; - +; RANDOM_AGGRESSIVE_CHOOSE(Player,Move,SIn,SOut) ; -; - +; ======================================== ; -; - +; Wins immediately if possible, else plays a random move ; -; - +; which doesn't lose immediately or allow opponent to ; -; - +; win on the next move. If all moves can lose, ; -; +; plays any random move. - - (= - (random-aggressive-choose $Player $Move $SIn $SOut) - ( (timing (random-aggressive-move $Move $SIn $SOut)) - (set-det) - (print-choice $Move $SIn $SOut))) -; - + (= (random-aggressive-choose $Player $Move $SIn $SOut) + (timing (random-aggressive-move $Move $SIn $SOut)) + (set-det) + (print-choice $Move $SIn $SOut)) - (= - (random-aggressive-move $Move $SIn $SOut) - ( (victor-move $Move $SIn $SOut) (set-det))) -; - - (= - (random-aggressive-move $Move $SIn $SOut) + (= (random-aggressive-move $Move $SIn $SOut) + (victor-move $Move $SIn $SOut) + (set-det)) + (= (random-aggressive-move $Move $SIn $SOut) (random-cautious-move $Move $SIn $SOut)) -; - ; -; - +; ======================================== ; -; - +; RANDOM_CAUTIOUS_CHOOSE(Player,Move,SIn,SOut) ; -; - +; ======================================== ; -; - +; Plays a random move which doesn't lose immediately or allow opponent to ; -; - +; win on the next move. ; -; - +; If none available, plays any random move (really, should play ; -; - - - - (= - (random-cautious-choose $Player $Move $SIn $SOut) - ( (timing (random-cautious-move $Move $SIn $SOut)) - (set-det) - (print-choice $Move $SIn $SOut))) -; - +; one which doesn't cause a lose in preference to one which does ...). - (= - (random-cautious-move $Move $SIn $SOut) - ( (legal-moves $Moves $SIn) - (random-non-losing $Moves $Move $SIn $SOut) - (set-det))) -; + (= (random-cautious-choose $Player $Move $SIn $SOut) + (timing (random-cautious-move $Move $SIn $SOut)) + (set-det) + (print-choice $Move $SIn $SOut)) - (= - (random-cautious-move $Move $SIn $SOut) - ( (print-resign-notice) (random-move $Move $SIn $SOut))) -; + (= (random-cautious-move $Move $SIn $SOut) + (legal-moves $Moves $SIn) + (random-non-losing $Moves $Move $SIn $SOut) + (set-det)) + (= (random-cautious-move $Move $SIn $SOut) + (print-resign-notice) + (random-move $Move $SIn $SOut)) - (= - (print-resign-notice) + (= (print-resign-notice) (format "\nA cautious player would resign now ... \nbut perhaps my opponent won't see it!\n" Nil)) -; - - (= - (print-forced-notice) + (= (print-forced-notice) (format "Forced choice: only 1 legal move~n" Nil)) -; - - (= - (print-rushed-notice) + (= (print-rushed-notice) (format "Rushed choice: no time to think!~n" Nil)) -; - - (= - (print-forced-or-lost-notice) + (= (print-forced-or-lost-notice) (format "Forced choice: only 1 legal move (or all others lose!)~n" Nil)) -; + (= (random-non-losing (:: $Move) $Move $SIn $SOut) + (set-det) + (print-forced-or-lost-notice) + (legal $Move $SIn $SOut)) + (= (random-non-losing $Moves $Move $SIn $SOut) + (random-select $Move1 $Moves $RestMoves) + (nl-or-next $Move1 $RestMoves $Move $SIn $SOut)) - (= - (random-non-losing - (:: $Move) $Move $SIn $SOut) - ( (set-det) - (print-forced-or-lost-notice) - (legal $Move $SIn $SOut))) -; - - (= - (random-non-losing $Moves $Move $SIn $SOut) - ( (random-select $Move1 $Moves $RestMoves) (nl-or-next $Move1 $RestMoves $Move $SIn $SOut))) -; + (= (nl-or-next $Move $_ $Move $SIn $SOut) + (cautious-move $Move $SIn $SOut) + (set-det)) + (= (nl-or-next $_ $Moves $Move $SIn $SOut) + (random-non-losing $Moves $Move $SIn $SOut) + (set-det)) - (= - (nl-or-next $Move $_ $Move $SIn $SOut) - ( (cautious-move $Move $SIn $SOut) (set-det))) -; - - (= - (nl-or-next $_ $Moves $Move $SIn $SOut) - ( (random-non-losing $Moves $Move $SIn $SOut) (set-det))) -; - - - - (= - (legal-moves $Moves $SIn) + (= (legal-moves $Moves $SIn) (setof $Move (^ $S1 (legal $Move $SIn $S1)) $Moves)) -; - ; -; - +; ============================================================ ; -; - +; A PASS_MOVE isn't really a legal move, it just transfers the ; -; +; player on move. - - (= - (pass-move $SIn $SOut) - ( (control $P1 $SIn) - (transfer-control $_ $SIn $SOut) - (control $P2 $SOut) - (format "Passing, control has now transferred from ~p to ~p~n" - (:: $P1 $P2)))) -; - + (= (pass-move $SIn $SOut) + (control $P1 $SIn) + (transfer-control $_ $SIn $SOut) + (control $P2 $SOut) + (format "Passing, control has now transferred from ~p to ~p~n" + (:: $P1 $P2))) ; -; - - - (= - (victor-move $Move $SIn $SOut) - ( (control $Player $SIn) - (legal $Move $SIn $SOut) - (game-outcome $Player $SOut))) -; +; A VICTOR_MOVE is one which wins the game immediately. + (= (victor-move $Move $SIn $SOut) + (control $Player $SIn) + (legal $Move $SIn $SOut) + (game-outcome $Player $SOut)) ; -; - - - (= - (endgame-move $Move $SIn $SOut) - ( (legal $Move $SIn $SOut) (game-over $SOut))) -; +; An ENDGAME_MOVE is one which ends the game immediately. + (= (endgame-move $Move $SIn $SOut) + (legal $Move $SIn $SOut) + (game-over $SOut)) ; -; - +; A MATE_MOVE is one which does not allow a cautious_move response. ; -; - +; That is, either it ends the game immediately, or for all moves ; -; - - - (= - (mate-move $Move $SIn $SOut) - ( (legal $Move $SIn $SOut) (not (cautious-move $M2 $SOut $_)))) -; +; of the opponent, we have a victory move. + (= (mate-move $Move $SIn $SOut) + (legal $Move $SIn $SOut) + (not (cautious-move $M2 $SOut $_))) ; -; - +; A THREATEN_MOVE is one which threatens victory, if the opponent doesn't respond ; -; +; to stop it. (This is like a CHECK in chess). - - (= - (threaten-move $Move $SIn $SOut) - ( (legal $Move $SIn $SOut) (det-if-then (transfer-control $_ $SOut $S1) (victor-move $M2 $S1 $_)))) -; - + (= (threaten-move $Move $SIn $SOut) + (legal $Move $SIn $SOut) + (det-if-then + (transfer-control $_ $SOut $S1) + (victor-move $M2 $S1 $_))) ; -; - +; An ENOUGH_ROPE_MOVE is one which allows the opponent to play a move ; -; +; which allows us to win next. - - (= - (enough-rope-move $Move $SIn $SOut) - ( (legal $Move $SIn $SOut) - (legal $M2 $SOut $S1) - (victor-move $M3 $S1 $_))) -; - + (= (enough-rope-move $Move $SIn $SOut) + (legal $Move $SIn $SOut) + (legal $M2 $SOut $S1) + (victor-move $M3 $S1 $_)) diff --git a/metagame/play/alphabeta.metta b/metagame/play/alphabeta.metta index 3c17249..00fdce6 100644 --- a/metagame/play/alphabeta.metta +++ b/metagame/play/alphabeta.metta @@ -1,1352 +1,944 @@ +; (convert_to_metta_file alphabeta $_356316 metagame/play/alphabeta.pl metagame/play/alphabeta.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; alphabeta.pl ; -; - +; This is the hottest version yet: ; -; - +; 1. alpha-beta ; -; - +; 2. counts nodes evaluated ; -; - +; 3. time cutoffs, chooses best move up to cutoff. ; -; - +; 4. iterative deepening ; -; - +; 5. principal continuation heuristic ; -; - +; 6. plays forced moves immediately ; -; - +; 7. either default or random candidate move-ordering ; -; - +; 8. stops when forced win for a player (should do draws also) ; -; - +; - outputs win in N-ply message! ; ; - ; -; - +; Thus, there are no more (well, few) magic parameters here, and program ; -; - +; can now play lots of games very nicely! ; -; - +; ================================================================================ ; -; - +; IMPLEMENTED PLAYERS ; -; - +; ================================================================================ ; -; - +; The following players (x_choose) are selectable from the ; -; - +; interface as players in their own right (from the top-level menu). ; -; - +; They can also be called as move selectors (x_com) to assist a human in making ; -; - +; a move, from the move-menu. ; -; - +; The core routines supporting these procedures are called (x_move). ; -; - +; Full documentation is made with these core routines. ; -; - +; ======================================== ; -; - +; ALPHA_BETA_CHOOSE(Player,Move,SIn,SOut) ; -; - +; ======================================== ; -; - +; Plays move with highest minimaxed ; -; - +; value, using the current evaluation function. ; -; - +; Searches to a fixed depth determined by the parameter: DEPTH. ; ; - ; -; - +; Uses whatever move ordering parameter ORDERING is set to. - (= - (alpha-beta-choose $Player $Move $SIn $SOut) + (= (alpha-beta-choose $Player $Move $SIn $SOut) (toggle-weights-choose alpha-beta-move $Player $Move $SIn $SOut)) -; - ; -; - +; ======================================== ; -; - +; ITERATE_CHOOSE(Player,Move,SIn,SOut) ; -; - +; ======================================== ; -; - +; Plays move with highest iterated minimaxed ; -; - +; value, using the current evaluation function. ; -; - +; Uses whatever move ordering parameter is set to. - (= - (iterate-choose $Player $Move $SIn $SOut) + (= (iterate-choose $Player $Move $SIn $SOut) (toggle-weights-choose iterate-move $Player $Move $SIn $SOut)) -; - ; -; - +; ======================================== ; -; - +; ITERATE_RANDOM_CHOOSE(Player,Move,SIn,SOut) ; -; - +; ======================================== ; -; - +; Plays move with highest iterated minimaxed ; -; - +; value, using the current evaluation function. ; -; - +; Uses random move ordering heuristic. - (= - (iterate-random-choose $Player $Move $SIn $SOut) + (= (iterate-random-choose $Player $Move $SIn $SOut) (toggle-weights-choose iterate-random-move $Player $Move $SIn $SOut)) -; - ; -; - +; ======================================== ; -; - +; ITERATE_FIXED_CHOOSE(Player,Move,SIn,SOut) ; -; - +; ======================================== ; -; - +; Plays move with highest iterated minimaxed ; -; - +; value, using the current evaluation function. ; -; - +; Uses fixed move ordering heuristic (use order from generator). - (= - (iterate-fixed-choose $Player $Move $SIn $SOut) + (= (iterate-fixed-choose $Player $Move $SIn $SOut) (toggle-weights-choose iterate-fixed-move $Player $Move $SIn $SOut)) -; - ; -; - +; ================================================= ; -; - +; TOGGLE_WEIGHTS_CHOOSE(Type,Player,Move,SIn,SOut) ; -; - +; ================================================= ; -; - +; Sets alpha-beta parameters for Player (if any), ; -; - +; then calls the Type of search method with these weights, ; -; - +; finally (whether successful or not) sets them back to their original values. ; ; - ; -; - +; This is *not* a player in itself, just a support function for ; -; - +; players based on alpha-beta which use these weights. ; ; - - (= - (toggle-weights-choose $Type $Player $Move $SIn $SOut) - ( (=.. $Goal - (:: $Type $Move $SIn $SOut)) (det-if-then-else (toggle-alpha-beta-weights $Player $Old) (det-if-then-else (timing $Goal) (, (print-choice $Move $SIn $SOut) (set-parameter weights $Old)) (, (set-parameter weights $Old) (fail))) (det-if-then (timing $Goal) (print-choice $Move $SIn $SOut))))) -; - + (= (toggle-weights-choose $Type $Player $Move $SIn $SOut) + (=.. $Goal + (:: $Type $Move $SIn $SOut)) + (det-if-then-else + (toggle-alpha-beta-weights $Player $Old) + (det-if-then-else + (timing $Goal) + (, + (print-choice $Move $SIn $SOut) + (set-parameter weights $Old)) + (, + (set-parameter weights $Old) + (fail))) + (det-if-then + (timing $Goal) + (print-choice $Move $SIn $SOut)))) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Parameters ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (ab-depth $D) + (= (ab-depth $D) (parameter depth $D)) -; - ; -; - +; Not used. - (= - (bound $B) + (= (bound $B) (parameter bound $B)) -; - - (= - (move-time-limit $T) + (= (move-time-limit $T) (parameter move-time-limit $T)) -; - - (= - (move-horizon $T) + (= (move-horizon $T) (parameter move-horizon $T)) -; - ; -; - - - (= - (approx-window $A $B) - ( (value-of-outcome player $B) (value-of-outcome opponent $A))) -; +; Within what ranges we want our values. + (= (approx-window $A $B) + (value-of-outcome player $B) + (value-of-outcome opponent $A)) - (= - (reset-alpha-params) - ( (set-parameter depth 1) - (set-parameter move-time-limit 10000) - (set-parameter move-horizon 1) - (set-parameter ordering random))) -; - + (= (reset-alpha-params) + (set-parameter depth 1) + (set-parameter move-time-limit 10000) + (set-parameter move-horizon 1) + (set-parameter ordering random)) ; -; - +; initialize_weights. ; -; - +; ================================================================================ ; -; - +; Time Management ; -; - +; ================================================================================ ; -; - +; ============================================== ; -; - +; SEARCH_TIMEOUT_TIME(+StartTime,State,-EndTime) ; -; - +; StartTime is the time this search started. ; -; - +; State is the current position (in which P is the player to move) ; -; - +; EndTime is the time we will stop the current search. ; -; - +; ============================================== ; ; - ; -; - +; GAME_TIME_LEFT: The total amount of time remaining to play all our moves. ; -; - +; MOVE_TIME_LIMIT: The max amount of time we can spend on this move. ; -; - +; Can be infinite if no move-time-limit, or can give a suggested limit, ; -; - +; or an enforced limit if these are the rules of the tournament. ; -; - +; ESTIMATED_MOVES_REMAINING: An estimate of the number of moves we will ; -; - +; still need to play this game. This can be determined in several ways: ; -; - +; 1. If we are near the N-move-rule for ending the game, we can use this ; -; - +; number. ; -; - +; 2. We can assume there is always some K moves left to play (like 30 moves). ; -; - +; This leads to spending more time in the early moves and speeding up ; -; - +; later. ; -; - +; 3. This can be learned from past games, possibly context-dependent. ; -; - +; a. Just observe total game lengths, use that number for all positions. ; -; - +; b. Learn to estimate based on features of a position. ; ; - ; -; - +; The result of the whole function is as follows: ; -; - +; Allocates for this move the avg. amount of time needed ; -; - +; to survive the number of moves we will need to play this game. ; -; - +; If this time exceeds the move_time_limit, just uses that. ; ; + (= (search-timeout-time $StartTime $SIn $EndTime) + (control $P $SIn) + (game-time-left $P $GameLeft) + (move-time-limit $MoveLimit) + (estimated-moves-remaining $MovesLeft $SIn) + (search-timeout-time $StartTime $GameLeft $MovesLeft $MoveLimit $EndTime)) - (= - (search-timeout-time $StartTime $SIn $EndTime) - ( (control $P $SIn) - (game-time-left $P $GameLeft) - (move-time-limit $MoveLimit) - (estimated-moves-remaining $MovesLeft $SIn) - (search-timeout-time $StartTime $GameLeft $MovesLeft $MoveLimit $EndTime))) -; - - - (= - (search-timeout-time $StartTime $GameLeft $MovesLeft $MoveLimit $EndTime) - ( (is $Avg - (/ $GameLeft $MovesLeft)) - (is $TimeAvail - (min $MoveLimit $Avg)) - (is $EndTime - (+ $StartTime $TimeAvail)))) -; - + (= (search-timeout-time $StartTime $GameLeft $MovesLeft $MoveLimit $EndTime) + (is $Avg + (/ $GameLeft $MovesLeft)) + (is $TimeAvail + (min $MoveLimit $Avg)) + (is $EndTime + (+ $StartTime $TimeAvail))) ; -; - +; Could be a more complicated procedure. ; -; - +; For now use parameter: move_horizon. ; ; - ; -; - +; estimated_moves_remaining(30,_). - (= - (estimated-moves-remaining $Horizon $_) + (= (estimated-moves-remaining $Horizon $_) (move-horizon $Horizon)) -; - ; -; - +; Ensures End is a number. If not, time will not be checked. ; -; - - - (= - (timeout-for-node $Node $End) - ( (tracing-ab timing - (print-timeout-check $Node)) - (number $End) - (current-time $Time) - (>= $Time $End) - (is $Diff - (- $Time $End)) - (print-timeout-message $Diff))) -; +; This is a way to disable the time checking! + (= (timeout-for-node $Node $End) + (tracing-ab timing + (print-timeout-check $Node)) + (number $End) + (current-time $Time) + (>= $Time $End) + (is $Diff + (- $Time $End)) + (print-timeout-message $Diff)) +; ; primary_choice_node(Node), ; -; - +; timeout_for_node([],Node,_) :- ; -; - - (= - (timeout-for-node - (Cons $Node $Rest) $BestNode $End) +; tracing_ab_format("Called to check timeout, but no other nodes~n",[]). + (= (timeout-for-node (Cons $Node $Rest) $BestNode $End) (timeout-for-node $Node $End)) -; - - (= - (print-timeout-check $Node) - ( (format "Testing for timeout~n" Nil) - (node-move $Node $Move) - (print-move $Move))) -; - + (= (print-timeout-check $Node) + (format "Testing for timeout~n" Nil) + (node-move $Node $Move) + (print-move $Move)) - (= - (print-timeout-message $Diff) + (= (print-timeout-message $Diff) (tracing-ab-format timing "Out of Time by <~p> msec~n" - (:: $Diff))) -; - + (:: $Diff))) - (= - (current-time $T0) + (= (current-time $T0) (statistics runtime - (Cons $T0 $_))) -; - + (Cons $T0 $_))) ; -; - +; An old function which ignores the limit on total game time. - (= - (search-timeout-time $EndTime) - ( (move-time-limit $Limit) - (current-time $T0) - (is $EndTime - (+ $T0 $Limit)))) -; + (= (search-timeout-time $EndTime) + (move-time-limit $Limit) + (current-time $T0) + (is $EndTime + (+ $T0 $Limit))) +; +; ================================================================================ ; -; +; ================================== +; +; ITERATE_FIXED_MOVE(Move,SIn,SOut) +; +; ================================== +; +; Uses fixed move ordering as provided by move generator. + (= (iterate-fixed-move $Move $SIn $SOut) + (change-parameter ordering $Ord fixed) + (iterate-move $Move $SIn $SOut) + (change-parameter ordering $_ $Ord)) ; -; - +; ================================== ; -; - +; ITERATE_RANDOM_MOVE(Move,SIn,SOut) ; -; - +; ================================== ; -; - - - (= - (iterate-fixed-move $Move $SIn $SOut) - ( (change-parameter ordering $Ord fixed) - (iterate-move $Move $SIn $SOut) - (change-parameter ordering $_ $Ord))) -; - - +; Uses the random_ordering heuristic with iterate_move. ; ; -; -; + (= (iterate-random-move $Move $SIn $SOut) + (change-parameter ordering $Ord random) + (iterate-move $Move $SIn $SOut) + (change-parameter ordering $_ $Ord)) ; -; - +; =========================== ; -; - +; ITERATE_MOVE(Move,SIn,SOut) ; -; - - - (= - (iterate-random-move $Move $SIn $SOut) - ( (change-parameter ordering $Ord random) - (iterate-move $Move $SIn $SOut) - (change-parameter ordering $_ $Ord))) -; - - +; =========================== ; -; - +; If there is only one legal move, plays it immediately. ; -; - +; Else, does iterative deepening alpha-beta search until out of ; -; - +; time. Then plays the move selected, or the first move available ; -; - -; -; - -; -; - +; if the search had no time to find anything at all. ; ; - ; -; - -; -; - +; Uses whatever move ordering is currently set (parameter: ordering). - (= - (iterate-move $Move $SIn $SOut) - ( (current-time $StartTime) - (search-timeout-time $StartTime $SIn $EndTime) - (initialized-start-node $SIn $NodeIn) - (instant-move $M $SIn $SFirst) + (= (iterate-move $Move $SIn $SOut) + (current-time $StartTime) + (search-timeout-time $StartTime $SIn $EndTime) + (initialized-start-node $SIn $NodeIn) + (instant-move $M $SIn $SFirst) + (det-if-then-else + (forced-move $M $SIn) + (accept-forced-move $M $SFirst $Move $SOut) (det-if-then-else - (forced-move $M $SIn) - (accept-forced-move $M $SFirst $Move $SOut) - (det-if-then-else - (, - (timing (iterate 1 $StartTime $EndTime $NodeIn $NodeOut)) - (nonvar $NodeOut)) - (initialized-choice-node $SOut $NodeOut $Move) - (accept-rushed-move $M $SFirst $Move $SOut))))) -; - + (, + (timing (iterate 1 $StartTime $EndTime $NodeIn $NodeOut)) + (nonvar $NodeOut)) + (initialized-choice-node $SOut $NodeOut $Move) + (accept-rushed-move $M $SFirst $Move $SOut)))) +; ; in advisors.pl ; -; - +; Accepting a forced or rushed move means printing a notice to this effect, ; -; - - - (= - (accept-forced-move $M $S $M $S) - (print-forced-notice)) -; - ; -; - +; and equating the input and output moves and states. + (= (accept-forced-move $M $S $M $S) + (print-forced-notice)) ; +; in advisors.pl - (= - (accept-rushed-move $M $S $M $S) - (print-rushed-notice)) -; - ; -; + (= (accept-rushed-move $M $S $M $S) + (print-rushed-notice)) ; +; in advisors.pl ; -; - +; A move is forced if all legal moves are identical to it. - (= - (forced-move $Move $SIn) + (= (forced-move $Move $SIn) (not (, (legal $Move2 $SIn $S2) (not (= $Move $Move2))))) -; - ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Iterative-Deepening Alpha-Beta algorithm. ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ================================================ ; -; - +; ITERATE(Depth,StartTime,EndTime,NodeIn,NodeOut) ; -; - +; ================================================ ; -; - +; Calls alpha beta with the current max depth, then ; -; - +; considers whether to iterate deeper or return the ; -; +; best move found so far. + (= (iterate $Depth $StartTime $EndTime $NodeIn $NodeOut) + (find-advice-tables $Tables) + (iterate $Depth $StartTime $EndTime $NodeIn $NodeOut $Tables)) - (= - (iterate $Depth $StartTime $EndTime $NodeIn $NodeOut) - ( (find-advice-tables $Tables) (iterate $Depth $StartTime $EndTime $NodeIn $NodeOut $Tables))) -; - - - - (= - (iterate $Depth $StartTime $EndTime $NodeIn $NodeOut $Tables) - ( (approx-window $Alpha $Beta) - (tracing-ab-timing iteration - (alphabeta $Depth $Counts $EndTime $NodeIn $Alpha $Beta $Node1 $Val $_ $Tables)) - (tracing-ab-format value "Searching at depth <~p>: ~n" - (:: $Depth)) - (tracing-ab-format value "The best move found has a value of: ~p~n" - (:: $Val)) - (tracing-ab resources - (print-resource-consumption $Counts)) - (tracing-ab value - (print-pc-info $NodeIn)) - (iterate-deeper $Depth $StartTime $EndTime $Val $NodeIn $Node1 $NodeOut $Tables))) -; + (= (iterate $Depth $StartTime $EndTime $NodeIn $NodeOut $Tables) + (approx-window $Alpha $Beta) + (tracing-ab-timing iteration + (alphabeta $Depth $Counts $EndTime $NodeIn $Alpha $Beta $Node1 $Val $_ $Tables)) + (tracing-ab-format value "Searching at depth <~p>: ~n" + (:: $Depth)) + (tracing-ab-format value "The best move found has a value of: ~p~n" + (:: $Val)) + (tracing-ab resources + (print-resource-consumption $Counts)) + (tracing-ab value + (print-pc-info $NodeIn)) + (iterate-deeper $Depth $StartTime $EndTime $Val $NodeIn $Node1 $NodeOut $Tables)) +; ; timing(alphabeta(Depth,Counts,EndTime,NodeIn,Alpha,Beta,Node1,Val,_)), ; -; - +; ================================================================= ; -; - +; ITERATE_DEEPER(Depth,StartTime,EndTime,Val,NodeIn,Node1,NodeOut) ; -; - +; ================================================================= ; -; - +; If one player has a forced win, don't look any further. ; -; - +; If not enough time for another iteration, just use the ; -; - +; best move we've found on the prev. iteration. ; -; - +; If still enough time, use pc to start anouther depth. ; ; - ; -; - +; Would be nice to have a clause for draws, but can't tell if a draw ; -; - - - (= - (iterate-deeper $Depth $StartTime $EndTime $Val $NodeIn $Node1 $Node1 $Tables) - ( (win-detected $Val $Depth) (set-det))) -; - - (= - (iterate-deeper $Depth $StartTime $EndTime $_ $NodeIn $Node1 $Node1 $Tables) - ( (not-enough-time $Depth $StartTime $EndTime) (set-det))) -; - - (= - (iterate-deeper $Depth $StartTime $EndTime $_ $NodeIn $_ $NodeOut $Tables) - ( (node-cont $NodeIn $PC) - (node-state $NodeIn $SIn) - (pc-moves $PC $Moves) - (initialized-start-node $SIn $Node1) - (node-pc $Node1 $Moves) - (is $Depth1 - (+ $Depth 1)) - (iterate $Depth1 $StartTime $EndTime $Node1 $NodeOut $Tables))) -; - +; or even on an evaluation fn. + (= (iterate-deeper $Depth $StartTime $EndTime $Val $NodeIn $Node1 $Node1 $Tables) + (win-detected $Val $Depth) + (set-det)) + (= (iterate-deeper $Depth $StartTime $EndTime $_ $NodeIn $Node1 $Node1 $Tables) + (not-enough-time $Depth $StartTime $EndTime) + (set-det)) + (= (iterate-deeper $Depth $StartTime $EndTime $_ $NodeIn $_ $NodeOut $Tables) + (node-cont $NodeIn $PC) + (node-state $NodeIn $SIn) + (pc-moves $PC $Moves) + (initialized-start-node $SIn $Node1) + (node-pc $Node1 $Moves) + (is $Depth1 + (+ $Depth 1)) + (iterate $Depth1 $StartTime $EndTime $Node1 $NodeOut $Tables)) - (= - (win-detected $Val $Depth) - ( (var $Val) - (set-det) - (tracing-ab-format value "No useful info this iteration.~n" Nil))) -; - - (= - (win-detected $Val $Depth) - ( (player-role $Player) - (value-of-outcome $Player $Val) - (set-det) - (tracing-ab-format value "A win is detected for <~p> in <~p> ply!~n" - (:: $Player $Depth)))) -; + (= (win-detected $Val $Depth) + (var $Val) + (set-det) + (tracing-ab-format value "No useful info this iteration.~n" Nil)) + (= (win-detected $Val $Depth) + (player-role $Player) + (value-of-outcome $Player $Val) + (set-det) + (tracing-ab-format value "A win is detected for <~p> in <~p> ply!~n" + (:: $Player $Depth))) ; -; - +; Could use a more sophisticated version below, to avoid ; -; - +; even starting when there's clearly not enough time to ; -; - +; do a full ply. But with the PC heuristic, why not just ; -; - - - (= - (not-enough-time $Depth $StartTime $EndTime) - ( (current-time $Now) (>= $Now $EndTime))) -; +; keep on searching to see if we might have been wrong? + (= (not-enough-time $Depth $StartTime $EndTime) + (current-time $Now) + (>= $Now $EndTime)) ; -; - +; not_enough_time(_Depth,StartTime,EndTime) :- ; -; - +; current_time(Now), ; -; - +; TimeUsed is Now - StartTime, ; -; - +; TimeLeft is EndTime - Now, ; -; - +; TimeUsed > TimeLeft / 2. ; -; - +; ====================================== ; -; - +; ALPHA_BETA_MOVE(Move,SIn,SOut) ; -; - +; ====================================== ; -; +; Searches to a fixed depth, based on the parameter: AB_DEPTH. - - (= - (alpha-beta-move $Move $SIn $SOut) - ( (ab-depth $Depth) (alpha-beta-move $Depth $Move $SIn $SOut))) -; - + (= (alpha-beta-move $Move $SIn $SOut) + (ab-depth $Depth) + (alpha-beta-move $Depth $Move $SIn $SOut)) ; -; - +; ====================================== ; -; - +; ALPHA_BETA_MOVE(Depth,Move,SIn,SOut) ; -; - +; ====================================== ; ; - ; -; - +; Plays move with highest alpha_beta minimaxed ; -; - +; value, using the current evaluation function. ; -; - +; Searches according to the following parameters: ; ; - ; -; - +; BOUND (approx_window): least optimistic value s.t. we take any move ; -; - +; which is better than this for the player to move. ; -; - +; (This is currently not used as a parameter, instead the bound is ; -; - +; just win and loss values). ; ; - ; -; - +; DEPTH: depth of tree at which we evaluate statically. ; ; - ; -; - +; If there is only one legal move, plays it immediately. ; -; - +; Else, does alpha-beta search until reaches DEPTH or out of time. ; -; - +; Then plays the move selected, or the first move available ; -; - +; if the search had no time to find anything at all. ; ; - ; -; - +; Uses whatever move ordering is currently set (parameter: ordering). ; ; - - (= - (alpha-beta-move $Depth $Move $SIn $SOut) - ( (current-time $StartTime) - (search-timeout-time $StartTime $SIn $EndTime) - (initialized-start-node $SIn $NodeIn) - (instant-move $M $SIn $SFirst) + (= (alpha-beta-move $Depth $Move $SIn $SOut) + (current-time $StartTime) + (search-timeout-time $StartTime $SIn $EndTime) + (initialized-start-node $SIn $NodeIn) + (instant-move $M $SIn $SFirst) + (det-if-then-else + (forced-move $M $SIn) + (accept-forced-move $M $SFirst $Move $SOut) (det-if-then-else - (forced-move $M $SIn) - (accept-forced-move $M $SFirst $Move $SOut) - (det-if-then-else - (, - (timing (alpha-beta-iterate $Depth $StartTime $EndTime $NodeIn $NodeOut)) - (nonvar $NodeOut)) - (initialized-choice-node $SOut $NodeOut $Move) - (accept-rushed-move $M $SFirst $Move $SOut))))) -; - - + (, + (timing (alpha-beta-iterate $Depth $StartTime $EndTime $NodeIn $NodeOut)) + (nonvar $NodeOut)) + (initialized-choice-node $SOut $NodeOut $Move) + (accept-rushed-move $M $SFirst $Move $SOut)))) +; ; in advisors.pl - (= - (alpha-beta-iterate $Depth $StartTime $EndTime $NodeIn $NodeOut) - ( (approx-window $Alpha $Beta) - (tracing-ab-timing iteration - (alphabeta $Depth $Counts $EndTime $NodeIn $Alpha $Beta $NodeOut $Val $_)) - (tracing-ab-format value "Searching at depth <~p>: ~n" - (:: $Depth)) - (tracing-ab-format value "The best move found has a value of: ~p~n" - (:: $Val)) - (tracing-ab resources - (print-resource-consumption $Counts)) - (tracing-ab value - (print-pc-info $NodeIn)))) -; + (= (alpha-beta-iterate $Depth $StartTime $EndTime $NodeIn $NodeOut) + (approx-window $Alpha $Beta) + (tracing-ab-timing iteration + (alphabeta $Depth $Counts $EndTime $NodeIn $Alpha $Beta $NodeOut $Val $_)) + (tracing-ab-format value "Searching at depth <~p>: ~n" + (:: $Depth)) + (tracing-ab-format value "The best move found has a value of: ~p~n" + (:: $Val)) + (tracing-ab resources + (print-resource-consumption $Counts)) + (tracing-ab value + (print-pc-info $NodeIn))) - (= - (pc-moves Nil Nil) + (= (pc-moves Nil Nil) (set-det)) -; - - (= - (pc-moves $Node - (Cons $Move $RestMoves)) - ( (node-move $Node $Move) - (node-cont $Node $Rest) - (pc-moves $Rest $RestMoves))) -; - +; /* alpha_beta_move(Depth,Move,SIn,SOut) :- current_time(StartTime), search_timeout_time(StartTime,SIn,EndTime), approx_window(Alpha,Beta), initialized_search_nodes(Move,SIn,NodeIn,SOut,NodeOut), tracing_ab_timing(iteration, alphabeta(Depth,Counts,EndTime,NodeIn,Alpha,Beta,NodeOut,Val,_)), tracing_ab_format(value,"Searching at depth <~p>: ~n",[Depth]), tracing_ab_format(value,"The best move found has a value of: ~p~n",[Val]), tracing_ab(resources,print_resource_consumption(Counts)), tracing_ab(value,print_pc_info(NodeIn)). */ + (= (pc-moves $Node (Cons $Move $RestMoves)) + (node-move $Node $Move) + (node-cont $Node $Rest) + (pc-moves $Rest $RestMoves)) ; -; - +; If want to print continuation INCLUDING this node, delete first line. ; -; - +; PC is thus a sequence of positions which follow down to DEPTH, ; -; - - - - (= - (print-pc-info $Node) - ( (node-cont $Node $PC) - (pc-moves $PC $Moves) - (format "The principal continuation here is: ~n" Nil) - (print-moves $Moves) - (nl))) -; +; or just the current move with its value if this is a terminal position. + (= (print-pc-info $Node) + (node-cont $Node $PC) + (pc-moves $PC $Moves) + (format "The principal continuation here is: ~n" Nil) + (print-moves $Moves) + (nl)) - (= - (print_moves ()) True) -; - - (= - (print-moves (Cons $M $Moves)) - ( (print-move $M) (print-moves $Moves))) -; + (= (print_moves ()) True) + (= (print-moves (Cons $M $Moves)) + (print-move $M) + (print-moves $Moves)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Core Alpha-Beta algorithm. ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; - ; -; - +; Based on algorithm in Bratko, p. 366. ; -; - +; Start the search at depth 0, as the top position is the root. ; ; - ; -; - +; Uses the advice tables constructed already, as information for the evaluation ; -; - +; function. If players using different info are both using this shell, ; -; - +; their respective tables should be passed in to the procedure which uses ; -; - - - (= - (alphabeta $MaxDepth $Counts $EndTime $Node $Alpha $Beta $GoodNode $Val $Complete) - ( (find-advice-tables $Tables) (alphabeta $MaxDepth $Counts $EndTime $Node $Alpha $Beta $GoodNode $Val $Complete $Tables))) -; +; tables explicitly. + (= (alphabeta $MaxDepth $Counts $EndTime $Node $Alpha $Beta $GoodNode $Val $Complete) + (find-advice-tables $Tables) + (alphabeta $MaxDepth $Counts $EndTime $Node $Alpha $Beta $GoodNode $Val $Complete $Tables)) - (= - (alphabeta $MaxDepth $Counts $EndTime $Node $Alpha $Beta $GoodNode $Val $Complete $Tables) + (= (alphabeta $MaxDepth $Counts $EndTime $Node $Alpha $Beta $GoodNode $Val $Complete $Tables) (alphabeta 0 $MaxDepth $Counts $EndTime $Node $Alpha $Beta $GoodNode $Val $Complete $Tables)) -; - ; -; - +; alphabeta(Depth,MaxDepth,Counts,EndTime,Node, Alpha, Beta, GoodNode, Val,Complete,Tables) ; -; - +; Depth is the current depth in the search (where the root position depth=0). ; -; - +; MaxDepth is the maximum depth to search down to (where static eval positions). ; -; - +; Node is a search tree node representing a position. ; -; - +; Best move from Node leads to a node GoodNode, with minimax ; -; - +; value Val. ; -; - +; Complete is yes if Node was complete, no otherwise. ; -; - +; Search stops when one of the following is true: ; -; - +; 1. The node is a terminal position. ; -; - +; 2. We have gone down Depth ply, so the current depth counter is 0. ; -; - +; 3. We are out of time. ; -; - +; When we evaluate, we'll here do so always from perspective of ; -; - +; PLAYER. Thus, player likes positions where this is maximized, ; -; - +; opponent likes these minimized. ; ; - ; -; - +; Note that when we check min_to_move(Pos), this tells us ; -; - +; that the MAX player is the parent, who is thus making the ; -; - +; choice. So this could be rewritten: choice_for_max(Pos). ; ; - ; -; - +; From now on, a POS is a NODE data structure, which contains ; -; - +; a state and more info. So all the procedures which here ; -; - +; operator on POS's will now operate on these structures. ; ; - ; -; - +; If run out of time before can find a value for this node, ; -; - +; GoodNode=_Var, Val=_Var, Complete=no. ; -; +; And node_complete(Node,Complete). + (= (alphabeta $_ $_ $Counts $End $Node $Alpha $Beta $GoodNode $Val no $_) + (timeout-for-node $Node $End) + (set-det) + (node-complete $Node no) + (zero-counts $Counts)) +; ; ran out of time. - (= - (alphabeta $_ $_ $Counts $End $Node $Alpha $Beta $GoodNode $Val no $_) - ( (timeout-for-node $Node $End) - (set-det) - (node-complete $Node no) - (zero-counts $Counts))) -; - - - (= - (alphabeta $_ $_ $Counts $End $Node $Alpha $Beta $GoodNode $Val yes $Tables) - ( (terminal-node $Node $Val $Tables) - (set-det) - (node-complete $Node yes) - (node-cont $Node Nil) - (terminal-counts $Counts))) -; - + (= (alphabeta $_ $_ $Counts $End $Node $Alpha $Beta $GoodNode $Val yes $Tables) + (terminal-node $Node $Val $Tables) + (set-det) + (node-complete $Node yes) + (node-cont $Node Nil) + (terminal-counts $Counts)) - (= - (alphabeta $Max $Max $Counts $End $Node $Alpha $Beta $GoodNode $Val yes $Tables) - ( (set-det) - (eval-node $Node $Val $Tables) - (node-complete $Node yes) - (static-counts $Counts))) -; - + (= (alphabeta $Max $Max $Counts $End $Node $Alpha $Beta $GoodNode $Val yes $Tables) + (set-det) + (eval-node $Node $Val $Tables) + (node-complete $Node yes) + (static-counts $Counts)) +; ; At max depth, evaluate ; -; - +; So here we are not at a terminal Node. ; -; - +; And not out of time. ; -; - - (= - (alphabeta $Depth $MaxDepth $Counts $EndTime $Node $Alpha $Beta $GoodNode $Val $Complete $Tables) - ( (< $Depth $MaxDepth) - (is $Depth1 - (+ $Depth 1)) - (expand-node $Node $NodeList $Tables) - (node-cont $Node $GoodNode) - (boundedbest $Depth1 $MaxDepth $Counts1 $EndTime $NodeList $Alpha $Beta $GoodNode $Val $Complete $Tables) - (close-node $Node $GoodNode $Val $Complete) - (node-complete $Node $Complete) - (add-expansion-counts $Counts1 $Counts))) -; - +; Find the best of the available moves at the next depth. + (= (alphabeta $Depth $MaxDepth $Counts $EndTime $Node $Alpha $Beta $GoodNode $Val $Complete $Tables) + (< $Depth $MaxDepth) + (is $Depth1 + (+ $Depth 1)) + (expand-node $Node $NodeList $Tables) + (node-cont $Node $GoodNode) + (boundedbest $Depth1 $MaxDepth $Counts1 $EndTime $NodeList $Alpha $Beta $GoodNode $Val $Complete $Tables) + (close-node $Node $GoodNode $Val $Complete) + (node-complete $Node $Complete) + (add-expansion-counts $Counts1 $Counts)) +; ; Use heuristics to find ordered moves +; ; format("Calling bbest from ab~n",[]), ; -; - +; ============ ; -; - +; BOUNDEDBEST ; -; - - - (= - (boundedbest $Depth $Max $Counts $EndTime - (Cons $Node $NodeList) $Alpha $Beta $GoodNode $GoodVal $Complete $Tables) - ( (alphabeta $Depth $Max $Counts1 $EndTime $Node $Alpha $Beta $_ $Val $Comp1 $Tables) - (goodenough $Depth $Max $Counts2 $EndTime $NodeList $Alpha $Beta $Node $Val $GoodNode $GoodVal $Comp1 $Complete $Tables) - (sum-resource-counts $Counts1 $Counts2 $Counts))) -; +; ============ + (= (boundedbest $Depth $Max $Counts $EndTime (Cons $Node $NodeList) $Alpha $Beta $GoodNode $GoodVal $Complete $Tables) + (alphabeta $Depth $Max $Counts1 $EndTime $Node $Alpha $Beta $_ $Val $Comp1 $Tables) + (goodenough $Depth $Max $Counts2 $EndTime $NodeList $Alpha $Beta $Node $Val $GoodNode $GoodVal $Comp1 $Complete $Tables) + (sum-resource-counts $Counts1 $Counts2 $Counts)) +; ; format("Callng ab from bbest~n",[]), +; ; format("About to call goodenough from bbest~n",[]), ; -; - +; =========== ; -; - +; GOODENOUGH ; -; - +; =========== ; -; - +; Finds a good enough position out of Poslist, in order ; -; - +; to approximate the value of the parent. ; -; - +; If the best value we've seen is already outside the alpha-beta ; -; - +; window, we don't need consider any of these moves further, ; -; - +; as they certainly will not be on the principal continuation. ; -; - +; Otherwise, consider the moves successively (so long as we are ; -; - +; still in the window), revise the window as necessary, and ; -; - +; choose the best move. ; ; - ; -; - +; I think the timeout check really has to come first here. ; -; - +; Otherwise we might mistakenly use an incomplete value. - (= - (goodenough $_ $_ $Counts $End $NodeList $Alpha $Beta $Node $Val $GoodNode $GoodVal $Comp $Comp $Tables) - ( (seen-enough $NodeList $Alpha $Beta $Node $Val $GoodNode $GoodVal $Comp) - (set-det) - (zero-counts $Counts))) -; - - (= - (goodenough $Depth $Max $Counts $End $NodeList $Alpha $Beta $Node $Val $GoodNode $GoodVal yes $Complete $Tables) - ( (newbounds-node $Alpha $Beta $Node $Val $NewAlpha $NewBeta) - (boundedbest $Depth $Max $Counts $End $NodeList $NewAlpha $NewBeta $Node1 $Val1 $Complete $Tables) - (betterof-node $Complete $Depth $Max $Node $Val $Node1 $Val1 $GoodNode $GoodVal))) -; - + (= (goodenough $_ $_ $Counts $End $NodeList $Alpha $Beta $Node $Val $GoodNode $GoodVal $Comp $Comp $Tables) + (seen-enough $NodeList $Alpha $Beta $Node $Val $GoodNode $GoodVal $Comp) + (set-det) + (zero-counts $Counts)) + (= (goodenough $Depth $Max $Counts $End $NodeList $Alpha $Beta $Node $Val $GoodNode $GoodVal yes $Complete $Tables) + (newbounds-node $Alpha $Beta $Node $Val $NewAlpha $NewBeta) + (boundedbest $Depth $Max $Counts $End $NodeList $NewAlpha $NewBeta $Node1 $Val1 $Complete $Tables) + (betterof-node $Complete $Depth $Max $Node $Val $Node1 $Val1 $GoodNode $GoodVal)) +; ; refine bounds ; format("Calling bbest from goodenough~n",[]), ; -; - +; SEEN_ENOUGH ; -; - +; We've seen enough if there is nothing left to see, we're out of time, ; -; - +; or the moves definitely not on the principal continuation. - (= - (seen-enough Nil $_ $_ $Node $Val $Node $Val $Comp) - (set-det)) -; - ; -; - - (= - (seen-enough $NodeList $_ $_ $Node $Val $Node $Val no) + (= (seen-enough Nil $_ $_ $Node $Val $Node $Val $Comp) + (set-det)) ; +; no other candidate + (= (seen-enough $NodeList $_ $_ $Node $Val $Node $Val no) + (set-det)) ; +; out of time + (= (seen-enough $NodeList $Alpha $Beta $Node $Val $Node $Val yes) + (or + (, + (min-to-move-node $Node) + (>= $Val $Beta)) + (, + (max-to-move-node $Node) + (=< $Val $Alpha))) (set-det)) -; - ; -; - - (= - (seen-enough $NodeList $Alpha $Beta $Node $Val $Node $Val yes) - ( (or - (, - (min-to-move-node $Node) - (>= $Val $Beta)) - (, - (max-to-move-node $Node) - (=< $Val $Alpha))) (set-det))) -; - +; ; maximizer attained upper bound +; ; minimizer attained lower bound - (= - (newbounds-node $Alpha $Beta $Node $Val $NewAlpha $NewBeta) - ( (node-state $Node $Pos) (newbounds $Alpha $Beta $Pos $Val $NewAlpha $NewBeta))) -; - + (= (newbounds-node $Alpha $Beta $Node $Val $NewAlpha $NewBeta) + (node-state $Node $Pos) + (newbounds $Alpha $Beta $Pos $Val $NewAlpha $NewBeta)) ; -; - +; Could modify here to store those moves whose val was eq ; -; - - - (= - (newbounds $Alpha $Beta $Pos $Val $Val $Beta) - ( (min-to-move $Pos) - (> $Val $Alpha) - (set-det))) -; - ; -; - - (= - (newbounds $Alpha $Beta $Pos $Val $Alpha $Val) - ( (max-to-move $Pos) - (< $Val $Beta) - (set-det))) -; - ; -; - - (= - (newbounds $Alpha $Beta $_ $_ $Alpha $Beta) True) -; +; to alpha or beta, to get set of moves of = val. + (= (newbounds $Alpha $Beta $Pos $Val $Val $Beta) + (min-to-move $Pos) + (> $Val $Alpha) + (set-det)) ; +; maximizer increased lower bound + (= (newbounds $Alpha $Beta $Pos $Val $Alpha $Val) + (max-to-move $Pos) + (< $Val $Beta) + (set-det)) ; +; minimizer decreased upper bound + (= (newbounds $Alpha $Beta $_ $_ $Alpha $Beta) True) ; -; - +; BETTEROF_NODE(Complete,Depth,Max,Node,Val,Node1,Val1,NodeB,ValB) ; -; - +; ================================================================ ; -; - +; If we didn't get a useful estimate for the second node, ; -; - +; throw it away and just return the first node immediately. ; -; - +; To be useful, all the node's children must have been completed. ; -; - +; This was a new change, and finally got rid of all the bugs ; -; - +; resulting from misusing or notusing incomplete searches. ; ; - - (= - (betterof-node no $Depth $Max $Node $Val $Node1 $Val1 $Node $Val) - ( (node-complete $Node1 no) (set-det))) -; - - (= - (betterof-node $Complete $Depth $Max $Node $Val $Node1 $Val1 $NodeB $ValB) + (= (betterof-node no $Depth $Max $Node $Val $Node1 $Val1 $Node $Val) + (node-complete $Node1 no) + (set-det)) + (= (betterof-node $Complete $Depth $Max $Node $Val $Node1 $Val1 $NodeB $ValB) (betterof-node $Node $Val $Node1 $Val1 $NodeB $ValB)) -; - - (= - (betterof-node $Node $Val $Node1 $Val1 $Node $Val) + (= (betterof-node $Node $Val $Node1 $Val1 $Node $Val) (or (, (min-to-move-node $Node) @@ -1356,136 +948,98 @@ (max-to-move-node $Node) (=< $Val $Val1) (set-det)))) -; - - (= - (betterof_node $_ $_ $Node1 $Val1 $Node1 $Val1) True) -; - - - - (= - (max-to-move-node $Node) - ( (node-state $Node $Pos) (max-to-move $Pos))) -; + (= (betterof_node $_ $_ $Node1 $Val1 $Node1 $Val1) True) - (= - (min-to-move-node $Node) - ( (node-state $Node $Pos) (min-to-move $Pos))) -; + (= (max-to-move-node $Node) + (node-state $Node $Pos) + (max-to-move $Pos)) + (= (min-to-move-node $Node) + (node-state $Node $Pos) + (min-to-move $Pos)) - (= - (max-to-move $Pos) + (= (max-to-move $Pos) (control player $Pos)) -; - - (= - (min-to-move $Pos) + (= (min-to-move $Pos) (control opponent $Pos)) -; - ; -; - +; ================================================================================ ; -; - +; Expanding and Closing Search Nodes ; -; - +; ================================================================================ ; -; +; Use heuristics to find ordered moves - - (= - (expand-node $Node $NodeList $Tables) - ( (tracing-ab expand - (, - (format " node from move: " Nil) - (node-move $Node $Move) - (print-move $Move))) (ordered-moves $Node $NodeList $Tables))) -; - + (= (expand-node $Node $NodeList $Tables) + (tracing-ab expand + (, + (format " node from move: " Nil) + (node-move $Node $Move) + (print-move $Move))) + (ordered-moves $Node $NodeList $Tables)) ; -; - +; Instead of returning a NodeList, could attach the pc to ; -; - +; the Node which will here get ordered first. Then won't ; -; - +; have to look in successor positions to see if they're on the ; -; - +; pc. ; -; - +; Now doing this: Take the successor node who's move is the move ; -; +; on the PC, if any, give it the rest of the PC and order it first. - - (= - (ordered-moves $Node $NodeList $Tables) - ( (successor-nodes $Node $NodeList1 $Tables) - (node-pc $Node $PC) - (det-if-then-else - (, - (nonvar $PC) - (= $PC - (Cons $M $Moves))) - (, - (tracing-ab ordering - (, - (format "Ordering PC highest~n" Nil) - (print-moves $PC))) - (search-node $PCNode) - (node-pc $PCNode $Moves) - (node-move $PCNode $M) - (select $PCNode $NodeList1 $NodeList2) - (= $NodeList - (Cons $PCNode $NodeList2))) - (= $NodeList $NodeList1)))) -; - + (= (ordered-moves $Node $NodeList $Tables) + (successor-nodes $Node $NodeList1 $Tables) + (node-pc $Node $PC) + (det-if-then-else + (, + (nonvar $PC) + (= $PC + (Cons $M $Moves))) + (, + (tracing-ab ordering + (, + (format "Ordering PC highest~n" Nil) + (print-moves $PC))) + (search-node $PCNode) + (node-pc $PCNode $Moves) + (node-move $PCNode $M) + (select $PCNode $NodeList1 $NodeList2) + (= $NodeList + (Cons $PCNode $NodeList2))) + (= $NodeList $NodeList1))) +; ; legal moves in Node produce Nodelist ; -; - +; =================================== ; -; - +; SUCCESSOR_NODES(Node,Nodes,Tables) ; -; - +; =================================== ; -; - +; Nodes is a list of legal successor nodes (containing possible moves). ; -; - +; The order is based on the parameter: ORDERING, as follows: ; -; - +; a. random ==> randomly permute the list order ; -; - +; b. fixed ==> use the list as initially generated. ; ; - - (= - (successor-nodes $Node $Nodes $Tables) + (= (successor-nodes $Node $Nodes $Tables) (det-if-then-else (parameter ordering random) (random-findall $Node2 @@ -1498,62 +1052,45 @@ (, (format "Error in successor_nodes/3: Invalid ordering parameter!!~n") (fail)))))) -; - - - (= - (successor-node $Node $Node2 $Tables) - ( (node-state $Node $State) - (successor-pos $Move $State $State2 $Tables) - (search-node $Node2) - (node-state $Node2 $State2) - (node-move $Node2 $Move) - (node-parent $Node2 $Node))) -; + (= (successor-node $Node $Node2 $Tables) + (node-state $Node $State) + (successor-pos $Move $State $State2 $Tables) + (search-node $Node2) + (node-state $Node2 $State2) + (node-move $Node2 $Move) + (node-parent $Node2 $Node)) ; -; - +; ---------------------------------------- ; -; - +; SUCCESSOR_POS(Move,State,State2,Tables) ; -; - +; ---------------------------------------- ; -; - +; External predicate, backtracks over all successor ; -; - +; STATE2 reachable from STATE. ; -; - +; Uses evaluation tables. ; -; - +; Move should be a unique name of this transition. ; -; +; Not used here anymore. - - (= - (moves $State $States) + (= (moves $State $States) (bagof $State2 (^ $Move (legal $Move $State $State2)) $States)) -; - - (= - (close-node $Node $GoodNode $Val $Complete) + (= (close-node $Node $GoodNode $Val $Complete) (tracing-ab expand (, (format " node from move: " Nil) @@ -1564,635 +1101,425 @@ (node-move $GoodNode $GoodMove) (print-move $GoodMove) (nl)))) -; - ; -; - +; ================================================================================ ; -; - +; Static evaluation and terminal position detection ; -; - - - - (= - (terminal-node $Node $Val $Tables) - ( (node-state $Node $Pos) - (terminal-pos-value $Pos $Val $Tables) - (tracing-ab eval - (print-eval-info $Node $Val)))) -; +; ================================================================================ + (= (terminal-node $Node $Val $Tables) + (node-state $Node $Pos) + (terminal-pos-value $Pos $Val $Tables) + (tracing-ab eval + (print-eval-info $Node $Val))) - (= - (eval-node $Node $Val $Tables) - ( (node-state $Node $Pos) - (staticval $Pos $Val $Tables) - (tracing-ab eval - (print-eval-info $Node $Val)) - (tracing-ab state - (print-state $Pos)) - (tracing-ab advice - (show-advices $Pos $Tables)))) -; + (= (eval-node $Node $Val $Tables) + (node-state $Node $Pos) + (staticval $Pos $Val $Tables) + (tracing-ab eval + (print-eval-info $Node $Val)) + (tracing-ab state + (print-state $Pos)) + (tracing-ab advice + (show-advices $Pos $Tables))) - (= - (print-eval-info $Node $Val) - ( (node-move $Node $Move) - (format "Evaluation <~p> for move: " - (:: $Val)) - (print-move $Move) - (nl))) -; - + (= (print-eval-info $Node $Val) + (node-move $Node $Move) + (format "Evaluation <~p> for move: " + (:: $Val)) + (print-move $Move) + (nl)) ; -; - +; ----------------------------------- ; -; - +; TERMINAL_POS_VALUE(Pos,Val,Tables) ; -; - +; ----------------------------------- ; -; - +; External predicate. Returns a Val for a Pos if it ; -; - +; is terminal. ; -; - +; This defined in value.pl ; -; - +; terminal_game_outcome(Pos,Val) :- ; -; - +; game_outcome(Outcome,Pos), ; -; - +; value_of_outcome(Outcome,Val), !. ; -; - +; VALUE_OF_OUTCOME(Winner,Value) ; ; - - (= - (value_of_outcome draw 0) True) -; - - (= - (value_of_outcome player 100000) True) -; - - (= - (value_of_outcome opponent -100000) True) -; - + (= (value_of_outcome draw 0) True) + (= (value_of_outcome player 100000) True) + (= (value_of_outcome opponent -100000) True) ; -; - +; ------------------------- ; -; - +; STATICVAL(Pos,Val,Tables) ; -; - +; ------------------------- ; -; - +; Must be defined by external file, determines what ; -; - +; evaluation procedure will be used! ; -; - +; ================================================================================ ; -; - +; NODE data structure ; -; - +; ================================================================================ ; -; - +; ======================================== ; -; - +; Managing Search Nodes ; -; - - - - (= - (primary-choice-node $Node) - ( (node-parent $Node $Parent) (node-parent $Parent Nil))) -; - - - - (= - (initialized-search-nodes $Move $SIn $NodeIn $SOut $NodeOut) - ( (search-node $NodeIn) - (node-state $NodeIn $SIn) - (node-parent $NodeIn Nil) - (search-node $NodeOut) - (node-state $NodeOut $SOut) - (node-move $NodeOut $Move))) -; +; ======================================== + (= (primary-choice-node $Node) + (node-parent $Node $Parent) + (node-parent $Parent Nil)) - (= - (initialized-start-node $SIn $NodeIn) - ( (search-node $NodeIn) - (node-state $NodeIn $SIn) - (node-parent $NodeIn Nil))) -; - ; -; + (= (initialized-search-nodes $Move $SIn $NodeIn $SOut $NodeOut) + (search-node $NodeIn) + (node-state $NodeIn $SIn) + (node-parent $NodeIn Nil) + (search-node $NodeOut) + (node-state $NodeOut $SOut) + (node-move $NodeOut $Move)) +; ; Set to be root node of tree - (= - (initialized-choice-node $SOut $NodeOut $Move) - ( (search-node $NodeOut) - (node-state $NodeOut $SOut) - (node-move $NodeOut $Move))) -; + (= (initialized-start-node $SIn $NodeIn) + (search-node $NodeIn) + (node-state $NodeIn $SIn) + (node-parent $NodeIn Nil)) ; +; Set to be root node of tree + (= (initialized-choice-node $SOut $NodeOut $Move) + (search-node $NodeOut) + (node-state $NodeOut $SOut) + (node-move $NodeOut $Move)) - (= - (portray-node (node $State $Parent $Move $Cont $PC)) - ( (format "~n" Nil))) -; + (= (portray-node (node $State $Parent $Move $Cont $PC)) + (format "~n" Nil)) ; -; - +; :- add_portray(portray_node). ; -; +; Low-level node implementation. - - (= - (search_node - (node $State $Parent $Move $Cont $PC $Comp) $State $Parent $Move $Cont $PC $Comp) True) -; - - (= - (search-node $N) + (= (search_node (node $State $Parent $Move $Cont $PC $Comp) $State $Parent $Move $Cont $PC $Comp) True) + (= (search-node $N) (functor $N node 6)) -; - - (= - (node-state $N $A) + (= (node-state $N $A) (arg 1 $N $A)) -; - - (= - (node-parent $N $A) + (= (node-parent $N $A) (arg 2 $N $A)) -; - - (= - (node-move $N $A) + (= (node-move $N $A) (arg 3 $N $A)) -; - - (= - (node-cont $N $A) + (= (node-cont $N $A) (arg 4 $N $A)) -; - - (= - (node-pc $N $A) + (= (node-pc $N $A) (arg 5 $N $A)) -; - - (= - (node-complete $N $A) + (= (node-complete $N $A) (arg 6 $N $A)) -; - ; -; - +; ================================================================================ ; -; - +; RESOURCE data structure ; -; +; ================================================================================ - - (= - (search-resource $N) + (= (search-resource $N) (functor $N resource 3)) -; - - (= - (resource-expansions $N $A) + (= (resource-expansions $N $A) (arg 1 $N $A)) -; - - (= - (resource-statics $N $A) + (= (resource-statics $N $A) (arg 2 $N $A)) -; - - (= - (resource-terminals $N $A) + (= (resource-terminals $N $A) (arg 3 $N $A)) -; - - - - - (= - (zero-counts $Counts) - ( (search-resource $Counts) - (resource-expansions $Counts 0) - (resource-statics $Counts 0) - (resource-terminals $Counts 0))) -; - - (= - (terminal-counts $Counts) - ( (search-resource $Counts) - (resource-expansions $Counts 0) - (resource-statics $Counts 0) - (resource-terminals $Counts 1))) -; - + (= (zero-counts $Counts) + (search-resource $Counts) + (resource-expansions $Counts 0) + (resource-statics $Counts 0) + (resource-terminals $Counts 0)) - (= - (static-counts $Counts) - ( (search-resource $Counts) - (resource-expansions $Counts 0) - (resource-statics $Counts 1) - (resource-terminals $Counts 0))) -; + (= (terminal-counts $Counts) + (search-resource $Counts) + (resource-expansions $Counts 0) + (resource-statics $Counts 0) + (resource-terminals $Counts 1)) - (= - (expansion-counts $Counts) - ( (search-resource $Counts) - (resource-expansions $Counts 1) - (resource-statics $Counts 0) - (resource-terminals $Counts 0))) -; + (= (static-counts $Counts) + (search-resource $Counts) + (resource-expansions $Counts 0) + (resource-statics $Counts 1) + (resource-terminals $Counts 0)) + (= (expansion-counts $Counts) + (search-resource $Counts) + (resource-expansions $Counts 1) + (resource-statics $Counts 0) + (resource-terminals $Counts 0)) - (= - (add-expansion-counts $Counts1 $Counts) - ( (expansion-counts $Counts0) (sum-resource-counts $Counts0 $Counts1 $Counts))) -; + (= (add-expansion-counts $Counts1 $Counts) + (expansion-counts $Counts0) + (sum-resource-counts $Counts0 $Counts1 $Counts)) - (= - (sum-resource-counts $Counts1 $Counts2 $Counts) - ( (resource-expansions $Counts1 $Exp1) - (resource-statics $Counts1 $Stat1) - (resource-terminals $Counts1 $Term1) - (resource-expansions $Counts2 $Exp2) - (resource-statics $Counts2 $Stat2) - (resource-terminals $Counts2 $Term2) - (is $Exp - (+ $Exp1 $Exp2)) - (is $Stat - (+ $Stat1 $Stat2)) - (is $Term - (+ $Term1 $Term2)) - (search-resource $Counts) - (resource-expansions $Counts $Exp) - (resource-statics $Counts $Stat) - (resource-terminals $Counts $Term))) -; - - - - (= - (print-resource-consumption $Counts) - ( (resource-expansions $Counts $Exp) - (resource-statics $Counts $Stat) - (resource-terminals $Counts $Term) - (is $Total - (+ - (+ $Exp $Stat) $Term)) - (format "Number of nodes expanded: <~p>~n" - (:: $Exp)) - (format "Number of nodes statically evaluated: <~p>~n" - (:: $Stat)) - (format "Number of terminal nodes encountered: <~p>~n" - (:: $Term)) - (format "Number of terminal node tests: <~p>~n" - (:: $Total)))) -; - - - -; -; - -; -; - -; -; - - - - (= - (search-limit $N) + (= (sum-resource-counts $Counts1 $Counts2 $Counts) + (resource-expansions $Counts1 $Exp1) + (resource-statics $Counts1 $Stat1) + (resource-terminals $Counts1 $Term1) + (resource-expansions $Counts2 $Exp2) + (resource-statics $Counts2 $Stat2) + (resource-terminals $Counts2 $Term2) + (is $Exp + (+ $Exp1 $Exp2)) + (is $Stat + (+ $Stat1 $Stat2)) + (is $Term + (+ $Term1 $Term2)) + (search-resource $Counts) + (resource-expansions $Counts $Exp) + (resource-statics $Counts $Stat) + (resource-terminals $Counts $Term)) + + + (= (print-resource-consumption $Counts) + (resource-expansions $Counts $Exp) + (resource-statics $Counts $Stat) + (resource-terminals $Counts $Term) + (is $Total + (+ + (+ $Exp $Stat) $Term)) + (format "Number of nodes expanded: <~p>~n" + (:: $Exp)) + (format "Number of nodes statically evaluated: <~p>~n" + (:: $Stat)) + (format "Number of terminal nodes encountered: <~p>~n" + (:: $Term)) + (format "Number of terminal node tests: <~p>~n" + (:: $Total))) + + +; +; ================================================================================ +; +; LIMIT data structure +; +; ================================================================================ + + + (= (search-limit $N) (functor $N limit 4)) -; - - - (= - (limit-depth $N $A) - ( (search-limit $N) (arg 1 $N $A))) -; - - - (= - (limit-count $N $A) - ( (search-limit $N) (arg 2 $N $A))) -; - - (= - (limit-timeused $N $A) - ( (search-limit $N) (arg 3 $N $A))) -; + (= (limit-depth $N $A) + (search-limit $N) + (arg 1 $N $A)) + (= (limit-count $N $A) + (search-limit $N) + (arg 2 $N $A)) - (= - (limit-timeleft $N $A) - ( (search-limit $N) (arg 4 $N $A))) -; + (= (limit-timeused $N $A) + (search-limit $N) + (arg 3 $N $A)) + (= (limit-timeleft $N $A) + (search-limit $N) + (arg 4 $N $A)) ; -; - +; ================================================================================ ; -; - +; tracing execution of alphabeta routines ; -; - +; ================================================================================ ; -; - +; The following tracing modules are used in this file: ; -; - +; ordering: info regarding move ordering heuristics ; -; - +; value: info regarding value of moves found during search ; -; - +; also traces principal continuations ; -; - +; resources: info regarding resource consumption during search ; -; - +; timing: info on timeout checks during search ; -; - +; iteration: info on each iteration of the search (currently just how long they took) ; ; - ; -; - +; Each module can be set on/off, using set_ab_verbosity (see below), or ; -; - +; using trace_ab_. ; ; - ; -; - +; All can be turned off with silent_ab. !(my-ensure-loaded (library tracing)) -; - - (= - (tracing-ab $Type $Call) + (= (tracing-ab $Type $Call) (det-if-then-else (tracing (ab $Type)) (call $Call) True)) -; - ; -; - +; Might cause trouble later when want to use streams also. - (= - (tracing-ab-format $Type $String $Args) + (= (tracing-ab-format $Type $String $Args) (det-if-then-else (tracing (ab $Type)) (format $String $Args) True)) -; - - (= - (tracing-ab-timing $Type $Call) + (= (tracing-ab-timing $Type $Call) (trace-timing (ab $Type) $Call)) -; - - (= - (set-ab-verbosity $Level $Status) + (= (set-ab-verbosity $Level $Status) (set-tracing (ab $Level) $Status)) -; - - (= - (silent-ab) + (= (silent-ab) (all-ab off)) -; - - (= - (loud-ab) + (= (loud-ab) (all-ab on)) -; - - (= - (all-ab $Status) - ( (set-ab-verbosity ordering $Status) - (set-ab-verbosity value $Status) - (set-ab-verbosity eval $Status) - (set-ab-verbosity expand $Status) - (set-ab-verbosity resources $Status) - (set-ab-verbosity timing $Status) - (set-ab-verbosity iteration $Status))) -; - + (= (all-ab $Status) + (set-ab-verbosity ordering $Status) + (set-ab-verbosity value $Status) + (set-ab-verbosity eval $Status) + (set-ab-verbosity expand $Status) + (set-ab-verbosity resources $Status) + (set-ab-verbosity timing $Status) + (set-ab-verbosity iteration $Status)) - (= - (trace-ab-expand) - (set-ab-verbosity expand on)) -; - + (= (trace-ab-expand) + (set-ab-verbosity expand on)) - (= - (trace-ab-eval) - (set-ab-verbosity eval on)) -; - + (= (trace-ab-eval) + (set-ab-verbosity eval on)) - (= - (trace-ab-value) - (set-ab-verbosity value on)) -; - + (= (trace-ab-value) + (set-ab-verbosity value on)) - (= - (trace-ab-ordering) - (set-ab-verbosity ordering on)) -; - + (= (trace-ab-ordering) + (set-ab-verbosity ordering on)) - (= - (trace-ab-resources) - (set-ab-verbosity resources on)) -; - + (= (trace-ab-resources) + (set-ab-verbosity resources on)) - (= - (trace-ab-timing) - (set-ab-verbosity timing on)) -; - + (= (trace-ab-timing) + (set-ab-verbosity timing on)) - (= - (trace-ab-iterations) + (= (trace-ab-iterations) (set-ab-verbosity iteration on)) -; - ; -; - +; :- trace_ab_value. ; -; - +; :- silent_ab. ; -; - +; ================================================================================ ; -; - +; Interface ; -; - +; ================================================================================ - (= - (alpha-beta-com $Move $SIn $SOut) - ( (timing (alpha-beta-move $Move $SIn $SOut)) (select-move $Move $SIn $SOut))) -; - + (= (alpha-beta-com $Move $SIn $SOut) + (timing (alpha-beta-move $Move $SIn $SOut)) + (select-move $Move $SIn $SOut)) - (= - (alpha-beta-com $Move $SIn $SOut $Depth) - ( (timing (alpha-beta-move $Depth $Move $SIn $SOut)) (select-move $Move $SIn $SOut))) -; - - - - (= - (iterate-com $Move $SIn $SOut) - ( (timing (iterate-move $Move $SIn $SOut)) (select-move $Move $SIn $SOut))) -; - + (= (alpha-beta-com $Move $SIn $SOut $Depth) + (timing (alpha-beta-move $Depth $Move $SIn $SOut)) + (select-move $Move $SIn $SOut)) - (= - (iterate-random-com $Move $SIn $SOut) - ( (timing (iterate-random-move $Move $SIn $SOut)) (select-move $Move $SIn $SOut))) -; + (= (iterate-com $Move $SIn $SOut) + (timing (iterate-move $Move $SIn $SOut)) + (select-move $Move $SIn $SOut)) + (= (iterate-random-com $Move $SIn $SOut) + (timing (iterate-random-move $Move $SIn $SOut)) + (select-move $Move $SIn $SOut)) - (= - (iterate-fixed-com $Move $SIn $SOut) - ( (timing (iterate-fixed-move $Move $SIn $SOut)) (select-move $Move $SIn $SOut))) -; + (= (iterate-fixed-com $Move $SIn $SOut) + (timing (iterate-fixed-move $Move $SIn $SOut)) + (select-move $Move $SIn $SOut)) diff --git a/metagame/play/controller.metta b/metagame/play/controller.metta index aa0ee04..188102b 100644 --- a/metagame/play/controller.metta +++ b/metagame/play/controller.metta @@ -1,1003 +1,685 @@ +; (convert_to_metta_file controller $_422396 metagame/play/controller.pl metagame/play/controller.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; controller.pl ; -; - +; ================================================================================ ; -; - +; ======================================== ; -; - +; GET_CURRENT_GAME ; -; - +; ======================================== ; -; - +; External hook, which should (at least) ; -; - +; ensure that the internal representation of the current game ; -; - +; to be played is saved in the predicates: ; -; - +; player_current_game/1 ; -; - +; opponent_current_game/1 ; -; - +; This can be achieved by calling the predicate: ; -; - +; file_make_test_game/1 ; -; - +; with a file in which a game is stored. ; -; - +; ======================================== ; -; - +; GET_PLAYERS(-White,-Black) ; -; - +; ======================================== ; -; - +; An external hook, which returns names attached ; -; - +; to the two players. ; -; - +; ======================================== ; -; - +; GET_RANDOM_ASSIGNMENT(-Assignments) ; -; - +; ======================================== ; -; - +; External hook to determine random assignments ; -; - +; when necessary. ; -; - +; ================================================================================ ; -; - +; CHOOSE(+Name,+Role,+SIn,-SOut) ; -; - +; ================================================================================ ; -; - +; Contains a clause for each named decision method (or player), ; -; - +; when playing in a particular role (player or opponent), ; -; - +; to update the present state by selecting a move. ; -; - +; ================================================================================ ; -; - +; SHOULD_CONTINUE(+State) ; -; - +; ================================================================================ ; -; - +; External hook to determine whether to continue ; -; - +; controlling the game. ; -; - +; Should return true if the player wants to continue. ; -; - +; ================================================================================ ; -; - +; TERMINATE_GAME(+FinalState) ; -; - +; ================================================================================ ; -; - +; Hook to call to determine what to do when the game has ended. ; -; - +; ================================================================================ ; -; - +; GET_IF_RANDOM_ASSIGNMENT ; -; - +; If the game requires a random setup, ; -; - +; then call the HOOK: get_random_assignment(A) ; -; - - - (= - (get-if-random-assignment) - ( (current-random-setup-game) - (set-det) - (get-random-assignment $Assignment) - (set-random-assignment $Assignment))) -; - - (= get_if_random_assignment True) -; +; to get an assignment, and record it. + (= (get-if-random-assignment) + (current-random-setup-game) + (set-det) + (get-random-assignment $Assignment) + (set-random-assignment $Assignment)) + (= get_if_random_assignment True) ; -; - - - (= - (set-random-assignment $Assignment) - ( (remove-all-symbols &self - (random_assignment $_)) (add-symbol &self (random_assignment $Assignment)))) -; +; Used by file parse.pl + (= (set-random-assignment $Assignment) + ( (remove-all-atoms &self + (random_assignment $_)) (add-is-symbol &self (random_assignment $Assignment)))) ; -; - +; ================== ; -; - +; START_CONTROLLER ; -; - +; ================== ; -; - +; Decide what game will be played, and who will play each color. ; -; - +; Then start the controller with those players played their colors. ; -; - +; This is top level for playing a particular contest ; -; +; of a particular game. - - (= - (start) + (= (start) (start-controller)) -; - - (= - (start-top $PosName) - ( (checkpoint $PosName $SIn) - (set-current-pos-name $PosName) - (start-controller $SIn))) -; + (= (start-top $PosName) + (checkpoint $PosName $SIn) + (set-current-pos-name $PosName) + (start-controller $SIn)) + (= (start-controller) + (get-current-game) + (get-initial-state $SIn) + (initialize-history $SIn) + (start-controller $SIn)) - (= - (start-controller) - ( (get-current-game) - (get-initial-state $SIn) - (initialize-history $SIn) - (start-controller $SIn))) -; - - - - (= - (get-initial-state $SIn) - ( (get-if-random-assignment) (start-game $SIn))) -; + (= (get-initial-state $SIn) + (get-if-random-assignment) + (start-game $SIn)) ; -; - +; ================================== ; -; - +; START_CONTROLLER(SIn) ; -; - +; ================================== ; -; - +; Resets the clock at the start of each game. ; -; - +; Starts the game (initialize board, etc), ; -; - +; then has the players play it in the main control loop. ; -; - +; Finds out which game it is playing. ; -; - - - (= - (start-controller $SIn) - ( (format "~nInitial Position:~n" Nil) - (print-state $SIn) - (linebreak) - (reset-clock) - (controller $SIn $_) - (set-det))) -; - +; Gets a random assignment if necessary for that game. + (= (start-controller $SIn) + (format "~nInitial Position:~n" Nil) + (print-state $SIn) + (linebreak) + (reset-clock) + (controller $SIn $_) + (set-det)) +; ; initialize_checkpoints(SIn), +; ; new - (= - (start-game $Init) - ( (new-state $State) (start-game $State $Init))) -; + (= (start-game $Init) + (new-state $State) + (start-game $State $Init)) ; -; - +; CONTROLLER(SIn,SOut) ; -; - +; Either the game ends, or we have the current player ; -; - +; make a move, and then continue. ; ; - ; -; - +; The clock is only printed if tracing(play(clock)). ; -; - +; To (un)set this, use: '(un)trace play clock'. - (= - (controller $SIn $SIn) - ( (game-ends-in-outcome $SIn $Outcome) - (set-det) - (record-game-outcome $Outcome) - (checkpoint-state final $SIn))) -; - - (= - (controller $SIn $SOut) - ( (tracing-play clock print-clock) - (play-in-control $SIn $S1) - (should-continue $S1) - (set-det) - (cleanup-state $S1 $S2) - (controller $S2 $SOut))) -; - - (= - (controller $SIn $SIn) + (= (controller $SIn $SIn) + (game-ends-in-outcome $SIn $Outcome) + (set-det) + (record-game-outcome $Outcome) + (checkpoint-state final $SIn)) + (= (controller $SIn $SOut) + (tracing-play clock print-clock) + (play-in-control $SIn $S1) + (should-continue $S1) + (set-det) + (cleanup-state $S1 $S2) + (controller $S2 $SOut)) +; ; new hook + (= (controller $SIn $SIn) (format "The game has been halted prematurely!!" Nil)) -; - ; -; - +; PLAY_IN_CONTROL(SIn,SOut) ; -; - +; Initialize parameters for the player to move, ; -; - +; and call the appropriate choice method. ; ; - - (= - (play-in-control $SIn $SOut) - ( (control $Role $SIn) - (initialize-player-move $Role) - (role-chooser $Role $Chooser) - (choose-or-resign $Chooser $Role $SIn $SOut))) -; - + (= (play-in-control $SIn $SOut) + (control $Role $SIn) + (initialize-player-move $Role) + (role-chooser $Role $Chooser) + (choose-or-resign $Chooser $Role $SIn $SOut)) +; ; ; -; - +; CHOOSE_OR_RESIGN(Chooser,Role,SIn,-SOut) ; ; - ; -; - +; Possibly add resignation as a kind of move later. ; -; - +; For now, failing to choose a legal move is resignation. ; -; - +; Now uses real-time instead of runtime. This means human ; -; - - - (= - (choose-or-resign $Chooser $Role $SIn $SOut) - ( (realtime-success - (choose $Chooser $Role $Move $SIn $SOut) $Time) - (set-det) - (adjust-player-clock $Role $Time) - (add-state-to-history $Move $SOut) - (restore-parameters))) -; - - (= - (choose-or-resign $Chooser $Role $SIn $_) - ( (opposite-role $Role $OppRole) - (role-chooser $OppRole $OppChooser) - (format "~n~p, as ~p, failed to select a legal move.~nThus, ~p, as ~p, is declared the Winner!~n" - (:: $Chooser $Role $OppChooser $OppRole)) - (checkpoint-state final $SIn) - (restore-parameters) - (fail))) -; +; players get timed correctly also! + (= (choose-or-resign $Chooser $Role $SIn $SOut) + (realtime-success + (choose $Chooser $Role $Move $SIn $SOut) $Time) + (set-det) + (adjust-player-clock $Role $Time) + (add-state-to-history $Move $SOut) + (restore-parameters)) +; ; realtime_success(choose(Chooser,Role,SIn,SOut),Time), !, + (= (choose-or-resign $Chooser $Role $SIn $_) + (opposite-role $Role $OppRole) + (role-chooser $OppRole $OppChooser) + (format "~n~p, as ~p, failed to select a legal move.~nThus, ~p, as ~p, is declared the Winner!~n" + (:: $Chooser $Role $OppChooser $OppRole)) + (checkpoint-state final $SIn) + (restore-parameters) + (fail)) ; -; - +; ================================================================================ ; -; - +; SHOULD_CONTINUE ; -; - +; ================================================================================ ; -; - +; A hook to controller. ; -; - +; Should return true if the player wants to continue the game. ; -; - +; Querying is disabled when parameter CONTINUOUS = yes. - (= - (continuous) + (= (continuous) (parameter continuous yes)) -; - - (= - (set-continuous) + (= (set-continuous) (set-parameter continuous yes)) -; - - (= - (set-stepping) + (= (set-stepping) (set-parameter continuous no)) -; - - (= - (should-continue $SIn) - ( (continuous) (set-det))) -; - - (= - (should-continue $SIn) + (= (should-continue $SIn) + (continuous) + (set-det)) + (= (should-continue $SIn) (ask-continue y)) -; - - (= - (ask-continue $Answer) - ( (ask-ynp Continue $Answer1) - (set-det) - (= $Answer1 $Answer))) -; + (= (ask-continue $Answer) + (ask-ynp Continue $Answer1) + (set-det) + (= $Answer1 $Answer)) - - (= - (ask-ynp $Query $Answer) - ( (format "~a? (y or n)~n" - (:: $Query)) - (read $Answer1) - (ynp $Answer1 $Answer - (ask-ynp $Query $Answer)))) -; - + (= (ask-ynp $Query $Answer) + (format "~a? (y or n)~n" + (:: $Query)) + (read $Answer1) + (ynp $Answer1 $Answer + (ask-ynp $Query $Answer))) ; -; - +; ============================================================================= ; -; - +; PRE-MOVE INITIALIZATION ; -; - +; ----------------------- ; ; - ; -; - +; role_chooser(Role,Chooser): ; -; - +; Moves for player role Role (player, opponent) ; -; - +; are chosen by choice method Chooser. This is set by the ; -; - +; "player chooser" command from the interface. ; ; - ; -; - +; role_file(Role,File): ; -; - +; File contains info about pre-move initiliazations for Role. ; -; - +; File is either , a filename to be loaded, or a list of ; -; - +; parameters. This list can be modified using the command template: ; -; - +; "set ". ; ; - ; -; - +; INITIALIZE_PLAYER_MOVE(Role) ; -; - +; Either load the initialization file for Player, ; -; - +; or override to the player-specific parameters. ; -; - +; If there is no info, do nothing. ; -; - +; Before changing parameters, the old version is saved, ; -; - +; and will be restored at the end of this move. ; -; - +; This ensures that no player can modify the parameters ; -; - - - (= - (initialize-player-move $Role) - ( (save-parameters) - (role-file $Role $File) - (det-if-then-else - (member $File - (:: none Nil)) True - (load-player-eval $File)))) -; +; for the opponent. + (= (initialize-player-move $Role) + (save-parameters) + (role-file $Role $File) + (det-if-then-else + (member $File + (:: none Nil)) True + (load-player-eval $File))) ; -; - +; Assert a list of parameters only if that's what is defined for ; -; - +; player_file. - (= - (load-player-eval (Cons $P $Ps)) - ( (set-det) (restore-parameters (Cons $P $Ps)))) -; - - (= - (load-player-eval $Name) + (= (load-player-eval (Cons $P $Ps)) + (set-det) + (restore-parameters (Cons $P $Ps))) + (= (load-player-eval $Name) (load-player-eval-file $Name)) -; - - (= - (set-com $_ $_ $_ $C $P $V) + (= (set-com $_ $_ $_ $C $P $V) (set-color-parameter $C $P $V)) -; - - (= - (set-top $C $P $V) + (= (set-top $C $P $V) (set-color-parameter $C $P $V)) -; - - - - (= - (unset-top $C) - ( (color-player $C $Role) (clear-player-parameters $Role))) -; + (= (unset-top $C) + (color-player $C $Role) + (clear-player-parameters $Role)) - (= - (set-color-parameter $Color $P $V) - ( (color-player $Color $Role) (set-player-parameter $Role $P $V))) -; + (= (set-color-parameter $Color $P $V) + (color-player $Color $Role) + (set-player-parameter $Role $P $V)) - (= - (set-player-parameter $Role $Param $Val) - ( (role-file $Role $List1) - (set-assoc $List1 $Param $Val $New) - (set-role-file $Role $New))) -; - + (= (set-player-parameter $Role $Param $Val) + (role-file $Role $List1) + (set-assoc $List1 $Param $Val $New) + (set-role-file $Role $New)) - (= - (clear-player-parameters $Role) + (= (clear-player-parameters $Role) (set-role-file $Role none)) -; - - (= - (load-player-eval-file $Name) - ( (find-eval-file $Name $File) - (save-parameters) - (compile $File))) -; - + (= (load-player-eval-file $Name) + (find-eval-file $Name $File) + (save-parameters) + (compile $File)) ; -; +; ------------------------------------------------------------------------- + (= (role-chooser $Role $Chooser) + (player-method-parameter $Role $Param) + (parameter $Param $Chooser)) - (= - (role-chooser $Role $Chooser) - ( (player-method-parameter $Role $Param) (parameter $Param $Chooser))) -; + (= (player_method_parameter player player_method) True) + (= (player_method_parameter opponent opponent_method) True) - (= - (player_method_parameter player player_method) True) -; + (= (role-file $Role $File) + (player-file-parameter $Role $Param) + (parameter $Param $File)) - (= - (player_method_parameter opponent opponent_method) True) -; + (= (set-role-file $Role $File) + (player-file-parameter $Role $Param) + (set-parameter $Param $File)) - (= - (role-file $Role $File) - ( (player-file-parameter $Role $Param) (parameter $Param $File))) -; - - - - (= - (set-role-file $Role $File) - ( (player-file-parameter $Role $Param) (set-parameter $Param $File))) -; - - - - - (= - (player_file_parameter player player_file) True) -; - - (= - (player_file_parameter opponent opponent_file) True) -; + (= (player_file_parameter player player_file) True) + (= (player_file_parameter opponent opponent_file) True) ; -; - +; Human mode is operative when one of the players is a human ; -; - +; chooser. This hook determines when questions and confirmations ; -; - +; should be made from the local console. Otherwise the controller ; -; - +; assumes it has the correct information to begin with. - (= - (human-mode) + (= (human-mode) (det-if-then - (role-chooser $Role human) True)) -; - + (role-chooser $Role human) True)) ; -; - +; ============================================================================ ; -; - +; Game Clock Routines ; -; - +; ------------------- ; -; - +; adjust_player_clock: increments time player has used this game ; -; - +; reset_clock: resets time used by each player to 0. ; -; - +; print_clock: prints time used and remaining for each player. ; -; - +; game_time_left: returns time left for a player in this game. ; -; - +; time_out_outcome: returns game outcome if timeout for at least one player. ; -; - +; ============================================================================ ; -; - +; ADJUST_PLAYER_CLOCK(+Player,+Time) ; -; - +; Adds Time units to players total elapsed time this game. ; -; - +; This makes available the predicate: ; ; - ; -; - +; time_used(?Player,?T) : Player has used T units of time this game. ; ; - - (= - (adjust-player-clock $Player $Time) - ( (remove-symbol &self + (= (adjust-player-clock $Player $Time) + ( (remove-is-symbol &self (time_used $Player $TOld)) (is $TNew (+ $TOld $Time)) - (add-symbol &self + (add-is-symbol &self (time_used $Player $TNew)))) -; - ; -; - +; RESET_CLOCK ; -; +; Sets both players' elapsed times to 0 (to be used at the start of each game). + (= (reset-clock) + (reset-player-clock player) + (reset-player-clock opponent)) - (= - (reset-clock) - ( (reset-player-clock player) (reset-player-clock opponent))) -; - - - - (= - (reset-player-clock $Player) - ( (remove-all-symbols &self - (time_used $Player $_)) (add-symbol &self (time_used $Player 0)))) -; + (= (reset-player-clock $Player) + ( (remove-all-atoms &self + (time_used $Player $_)) (add-is-symbol &self (time_used $Player 0)))) ; -; - +; PRINT_CLOCK ; -; - - - (= - (print-clock) - ( (format "~*c~n" - (:: 40 45)) - (format "Clock times (in seconds):~n" Nil) - (print-player-clock player) - (print-player-clock opponent) - (format "~*c~n" - (:: 40 45)))) -; +; Prints time used and left for each player. + (= (print-clock) + (format "~*c~n" + (:: 40 45)) + (format "Clock times (in seconds):~n" Nil) + (print-player-clock player) + (print-player-clock opponent) + (format "~*c~n" + (:: 40 45))) - (= - (print-player-clock $Player) - ( (time-used $Player $Used) - (game-time-left $Player $Left) - (format "<~p>: \t~3d used, \t~3d left~n" - (:: $Player $Used $Left)))) -; - + (= (print-player-clock $Player) + (time-used $Player $Used) + (game-time-left $Player $Left) + (format "<~p>: \t~3d used, \t~3d left~n" + (:: $Player $Used $Left))) ; -; - +; TIME_OUT_OUTCOME(?Outcome) ; -; - +; Outcome is DRAW if both players out of time, the player ; -; - +; who still has time left if only one is out, and fails ; -; - +; if both still have time. - (= - (time-out-outcome $Outcome) - ( (player-time-out player $PTime) - (player-time-out opponent $OTime) - (time-out-outcome $PTime $OTime $Outcome))) -; - - - (= - (time-out-outcome yes yes draw) - ( (set-det) (format "Both players are out of time!~n" Nil))) -; - - (= - (time-out-outcome no yes player) - ( (set-det) (format "<~p> is out of time~n" (:: opponent)))) -; - - (= - (time-out-outcome yes no opponent) - ( (set-det) (format "<~p> is out of time~n" (:: player)))) -; + (= (time-out-outcome $Outcome) + (player-time-out player $PTime) + (player-time-out opponent $OTime) + (time-out-outcome $PTime $OTime $Outcome)) + (= (time-out-outcome yes yes draw) + (set-det) + (format "Both players are out of time!~n" Nil)) + (= (time-out-outcome no yes player) + (set-det) + (format "<~p> is out of time~n" + (:: opponent))) + (= (time-out-outcome yes no opponent) + (set-det) + (format "<~p> is out of time~n" + (:: player))) ; -; - +; PLAYER_TIME_OUT(Player,Out) ; ; - ; -; - - - (= - (player-time-out $Player $Out) - ( (game-time-left $Player $Time) (det-if-then-else (=< $Time 0) (= $Out yes) (= $Out no)))) -; +; A player is out of time if he has no time remaining. + (= (player-time-out $Player $Out) + (game-time-left $Player $Time) + (det-if-then-else + (=< $Time 0) + (= $Out yes) + (= $Out no))) ; -; - +; GAME_TIME_LEFT(?Player,-Time) ; -; - - - (= - (game-time-left $Player $Time) - ( (game-time-limit $Limit) - (time-used $Player $Used) - (is $Time - (max - (- $Limit $Used) 0)))) -; +; Time is the amount of time Player has left in the current game. + (= (game-time-left $Player $Time) + (game-time-limit $Limit) + (time-used $Player $Used) + (is $Time + (max + (- $Limit $Used) 0))) - (= - (game-time-limit $Limit) + (= (game-time-limit $Limit) (parameter game-time-limit $Limit)) -; - ; -; - - - (= - (clock-unlimit) - ( (set-parameter game-time-limit 99999999) - (set-parameter move-time-limit 99999999) - (set-parameter move-horizon 1) - (reset-clock))) -; +; Nullify time limits for both players. + (= (clock-unlimit) + (set-parameter game-time-limit 99999999) + (set-parameter move-time-limit 99999999) + (set-parameter move-horizon 1) + (reset-clock)) ; -; - +; ============================================================================= - (= - (game-ends-in-outcome $SIn $Outcome) - ( (game-over $SIn) - (set-det) - (game-outcome $Outcome $SIn))) -; - - (= - (game-ends-in-outcome $SIn $Outcome) + (= (game-ends-in-outcome $SIn $Outcome) + (game-over $SIn) + (set-det) + (game-outcome $Outcome $SIn)) + (= (game-ends-in-outcome $SIn $Outcome) (time-out-outcome $Outcome)) -; - ; -; - +; game_over and game_outcome gets compiled to have 2 args, as it ; -; +; thinks the check for no legal moves actually might affect state. - - (= - (game-over $SIn) + (= (game-over $SIn) (game-over $SIn $_)) -; - - (= - (game-outcome $O $S) + (= (game-outcome $O $S) (game-outcome $O $S $_)) -; - !(dynamic (/ recorded-game-outcome 1)) -; - ; -; - +; ======================================== ; -; - +; RECORDED_GAME_OUTCOME(?Outcome) ; -; - +; ======================================== ; -; - +; The last game ended in Outcome (player, opponent, or draw) ; ; - ; -; - +; RECORD_GAME_OUTCOME(O) ; -; - +; Prints the outcome of the game. ; -; - +; Makes available the predicate: ; -; - +; recorded_game_outcome/1. - (= - (record-game-outcome $O) - ( (remove-all-symbols &self + (= (record-game-outcome $O) + ( (remove-all-atoms &self (recorded_game_outcome $O)) - (add-symbol &self + (add-is-symbol &self (recorded_game_outcome $O)) (write-outcome $O))) -; - - (= - (write-outcome draw) - ( (format "~n~nThe game is over. Ends in a draw!~n" Nil) (set-det))) -; - - (= - (write-outcome $Player) + (= (write-outcome draw) + (format "~n~nThe game is over. Ends in a draw!~n" Nil) + (set-det)) + (= (write-outcome $Player) (format "~n~nThe game is over. ~p wins!~n" (:: $Player))) -; - ; -; - +; cleanup_state(Old,New) ; -; - +; This provides a hook for different state representations ; -; - - - (= - (cleanup_state $S $S) True) -; +; to purge temporary data from their state, if necessary. + (= (cleanup_state $S $S) True) diff --git a/metagame/play/gen_menu.metta b/metagame/play/gen_menu.metta index 0679465..f5da798 100644 --- a/metagame/play/gen_menu.metta +++ b/metagame/play/gen_menu.metta @@ -1,318 +1,192 @@ +; (convert_to_metta_file gen_menu $_161002 metagame/play/gen_menu.pl metagame/play/gen_menu.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; gen_menu.pl ; -; - +; This menu is accessible from the top-level menu. - (= - (gen-top) + (= (gen-top) (generate)) -; - ; -; - +; ====================================================================== ; -; - +; Game Generation Menu ; -; - - - - (= - (generate) - ( (menu-command "~nEnter command ('help.' gives more information)~n" gen Nil) - (set-det) - (continue-generate))) -; +; ====================================================================== - (= - (generate) - ( (format "~nI did not understand your command. Please try again!~n" Nil) (generate))) -; + (= (generate) + (menu-command "~nEnter command ('help.' gives more information)~n" gen Nil) + (set-det) + (continue-generate)) + (= (generate) + (format "~nI did not understand your command. Please try again!~n" Nil) + (generate)) ; -; - +; CONTINUE_GENERATE. ; -; - +; Here we always continue from this menu. ; -; - +; The only way to get out is to use the 'done' command, ; -; - +; which just calls metagame again. - (= - (continue-generate) + (= (continue-generate) (generate)) -; - ; -; - +; ---------------------------------------- ; -; - +; GENERATE menu commands ; -; - - +; ---------------------------------------- - (= - (help-gen) - ( (help-gen1) (help-gen2))) -; + (= (help-gen) + (help-gen1) + (help-gen2)) - (= - (help-gen1) + (= (help-gen1) (format "\nGenerating a Game:\n------------------------------\ngames_library. => show games in library\ngenerate . => generate (and load) random game, save as .game\ngame . => loads .game as the current game\ncompile {on/off}. => set whether to compile symmetries when loading a game.\nquick. => short form to turn of compiling symmetries. \ndone. => return to top-level menu\n" Nil)) -; - - (= - (help-gen2) + (= (help-gen2) (format "\nExamining Game and Changing System State\n-----------------------------------------\npieces. => show the names of the pieces in the current game\ndefine . => print the definition of in the current game\ngoals. => print the goals of the current game\nboard. => print board definition of the current game\nrules. => print the full rules of the current game\nset

. => set generator parameter

to value \nset

. => set generator parameter

('help set.')\nset. => show generator parameter settings\nrandomize => use random seed # (N = 1..10)\n(un)trace {options} => trace some system behavior ('help trace.') \ncd

. => change current directory to ('help cd.')\npwd. => show current directory name\nls. => show contents of current directory\nprolog. (abort) => abort to prolog\nquit. => exit session (back to shell)\n" Nil)) -; - - (= - (done-gen) + (= (done-gen) (metagame)) -; - - (= - (set-gen $P $V) + (= (set-gen $P $V) (set-gen-parameter $P $V)) -; - - (= - (set-gen $P) + (= (set-gen $P) (change-gen-param $P)) -; - - (= - (set-gen) + (= (set-gen) (show-gen-parameters)) -; - - (= - (randomize-gen $N) + (= (randomize-gen $N) (randomize $N)) -; - - (= - (generate-gen $File) + (= (generate-gen $File) (generate-and-load $File)) -; - - (= - (generate-gen) + (= (generate-gen) (generate-and-load random)) -; - - (= - (game-gen $File) + (= (game-gen $File) (load-game $File)) -; - - (= - (games-library-gen) + (= (games-library-gen) (games-library)) -; - - (= - (cd-gen $Dir) + (= (cd-gen $Dir) (cd-print $Dir)) -; - - (= - (pwd-gen) + (= (pwd-gen) (pwd-print)) -; - - (= - (ls-gen) + (= (ls-gen) (ls)) -; - - (= - (define-gen $PieceName) + (= (define-gen $PieceName) (show-piece-definition $PieceName)) -; - - (= - (goals-gen) + (= (goals-gen) (show-game-goals)) -; - - (= - (rules-gen) + (= (rules-gen) (show-rules)) -; - - (= - (pieces-gen) + (= (pieces-gen) (show-piece-names)) -; - - (= - (board-gen) + (= (board-gen) (show-board)) -; - - (= - (quick-gen) + (= (quick-gen) (set-parameter compile-symmetries off)) -; - - (= - (compile-gen $OnOff) + (= (compile-gen $OnOff) (set-parameter compile-symmetries $OnOff)) -; - - - (= - (restart-gen) - ( (format "~nRestarting ...~n" Nil) (metagame))) -; + (= (restart-gen) + (format "~nRestarting ...~n" Nil) + (metagame)) - (= - (quit-gen) + (= (quit-gen) (print-quit)) -; - - (= - (prolog-gen) + (= (prolog-gen) (print-abort)) -; - - (= - (abort-gen) + (= (abort-gen) (print-abort)) -; - - (= - (verbose-gen) + (= (verbose-gen) (set-verbose)) -; - - (= - (quiet-gen) + (= (quiet-gen) (set-quiet)) -; - ; -; - +; ----------------------------------------------------------------- ; -; - +; Tracing ; -; - +; ----------------------------------------------------------------- - (= - (trace-gen $Module) + (= (trace-gen $Module) (set-tracing $Module on)) -; - - (= - (trace-gen $Module $Component) + (= (trace-gen $Module $Component) (set-tracing $Module $Component on)) -; - - (= - (untrace-gen $Module) + (= (untrace-gen $Module) (set-tracing $Module off)) -; - - (= - (untrace-gen $Module $Component) + (= (untrace-gen $Module $Component) (set-tracing $Module $Component off)) -; - - (= - (list-tracing-gen) + (= (list-tracing-gen) (list-tracing)) -; - diff --git a/metagame/play/help.metta b/metagame/play/help.metta index 7b800f6..0877db0 100644 --- a/metagame/play/help.metta +++ b/metagame/play/help.metta @@ -1,518 +1,299 @@ +; (convert_to_metta_file help $_257118 metagame/play/help.pl metagame/play/help.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; help.pl ; -; - +; Help menus ; -; - +; ---------------------------------------- ; -; - +; Help from top menu ; -; - - - - - (= - (help-top) - ( (help-top-general) - (help-tables) - (help-system))) -; +; ---------------------------------------- - (= - (help-top $F) - ( (help-top-entry $F $G) (call $G))) -; + (= (help-top) + (help-top-general) + (help-tables) + (help-system)) - (= - (help-top help) - ( (help-top-topics $Topics) - (format "To select a topic, type 'help .'~n" Nil) - (format "Help in this menu is available on the following topics:~n" Nil) - (pwl $Topics))) -; + (= (help-top $F) + (help-top-entry $F $G) + (call $G)) + (= (help-top help) + (help-top-topics $Topics) + (format "To select a topic, type 'help .'~n" Nil) + (format "Help in this menu is available on the following topics:~n" Nil) + (pwl $Topics)) - (= - (help-top-topics $Topics) - ( (findall $Topic - (help-top-entry $Topic $_) $AllTopics) (sort $AllTopics $Topics))) -; - + (= (help-top-topics $Topics) + (findall $Topic + (help-top-entry $Topic $_) $AllTopics) + (sort $AllTopics $Topics)) ; -; - +; Just add new entries here, and define their fns, ; -; - - - (= - (help_top_entry player help_player) True) -; - - (= - (help_top_entry show help_show) True) -; - - (= - (help_top_entry trace help_trace) True) -; - - (= - (help_top_entry cd help_cd) True) -; - - (= - (help_top_entry iterate help_iterate) True) -; - - (= - (help_top_entry weights help_weights) True) -; - - (= - (help_top_entry eval_fn help_eval_fn) True) -; - - (= - (help_top_entry evalfile help_evalfile) True) -; - - (= - (help_top_entry history help_history) True) -; - - (= - (help_top_entry clock help_clock) True) -; - - (= - (help_top_entry tables help_tables) True) -; - - (= - (help_top_entry advisors help_advisors) True) -; - - (= - (help_top_entry playernum help_playernum) True) -; - +; to hook them into help menu at top level. + + (= (help_top_entry player help_player) True) + (= (help_top_entry show help_show) True) + (= (help_top_entry trace help_trace) True) + (= (help_top_entry cd help_cd) True) + (= (help_top_entry iterate help_iterate) True) + (= (help_top_entry weights help_weights) True) + (= (help_top_entry eval_fn help_eval_fn) True) + (= (help_top_entry evalfile help_evalfile) True) + (= (help_top_entry history help_history) True) + (= (help_top_entry clock help_clock) True) + (= (help_top_entry tables help_tables) True) + (= (help_top_entry advisors help_advisors) True) + (= (help_top_entry playernum help_playernum) True) ; -; +; generate . => generate (and load) a random game and save as .game - - (= - (help-top-general) + (= (help-top-general) (format "\nGenerating and Playing a Game:\n------------------------------\ngen. => enters menu for generating random games.\ngames_library. => show games in library\ngame . => loads .game as the current game\nevalfile . => loads .eval as eval tables for current game\nplayer

. => set player

to play color ('help player.')\nplayers . => set player as white, as black.\nplayers. => shows current players. \nstart. => start playing current game from initial position\nstart . => start playing current game from saved position \n\t ('help history')\nclock. => prints current game clock (help clock)\n" Nil)) -; - - (= - (help-tables) + (= (help-tables) (format "\nConstructing and Using Analysis Tables\n--------------------------------------\nbuild. => builds tables using current advisors. \nshowstatic. => shows the static table values for all pieces.\nadvice

. => shows static advice for piece

of color .\nalladvisors. => shows current weights for all advisors.\nactive. => shows weights for only non-zero weighted advisors\nplayernum . => set numbered player to play color ('help playernum.')\nplayernums . => set numbered player as white, as black.\nhelp advisors. => more info on the advisors and what they do. \n" Nil)) -; - - (= - (help-system) - ( (help-game) (help-state))) -; + (= (help-system) + (help-game) + (help-state)) - - (= - (help-game) + (= (help-game) (format "\nExamining Game\n--------------\npieces. => show the names of the pieces in the current game\ndefine . => print the definition of in the current game\ngoals. => print the goals of the current game\nboard. => print board definition of the current game\nrules. => print the full rules of the current game\n" Nil)) -; - - (= - (help-state) + (= (help-state) (format "\t\nChanging System State\n---------------------\nset

. => set parameter

to value (set global default)\nset

. => set parameter

to value , for player only\nunset => clears params specific to player \nset. => show parameter settings\nrandomize => use random seed # (N = 1..10)\nshow {options} => show configuration data ('help show.') \n(un)trace {options} => trace some system behavior ('help trace.') \ncd

. => change current directory to ('help cd.')\npwd. => show current directory name\nls. => show contents of current directory\nprolog. (abort) => abort to prolog\nquit. => exit session (back to shell)\nhelp help. => list of all additional help topics. \n" Nil)) -; + (= (help-playernum) + (format "See the file learning/tourney.pl for more info.~n" Nil)) - (= - (help-playernum) - (format "See the file learning/tourney.pl for more info.~n" Nil)) -; - - - - (= - (help-player) - ( (help-player-color) - (help-player-options) - (help-player-example))) -; + (= (help-player) + (help-player-color) + (help-player-options) + (help-player-example)) - (= - (help-player-color) + (= (help-player-color) (format "\nplayer .\n------------------------\nTells the system how the moves will be chosen for color .\n\n must be one of the following:\n\nwhite => the first player.\nblack => the second player.\n" Nil)) -; + (= (help-player-options) + (help-player-options-simple) + (help-player-options-search)) - (= - (help-player-options) - ( (help-player-options-simple) (help-player-options-search))) -; - - - (= - (help-player-options-simple) + (= (help-player-options-simple) (format "\n must be one of the following:\n\nSimple Players\n--------------\nhuman => chosen by a human using this interface.\nrandom => play a random legal move.\ninstant => play first legal move available (faster)\ncautious => plays first non-losing move available (faster)\nrandom_cautious => play random non-losing move \nrandom_aggressive => wins if can, else plays cautiously\n" Nil)) -; - - (= - (help-player-options-search) + (= (help-player-options-search) (format "\nSearching Players\n-----------------\nalpha_beta => does alpha_beta search down to a fixed depth \n (specified by parameter). \n uses principal continuation heuristic.\n Bounded by same time limits and move ordering as\n iterate player.\niterate => iterative deepening alpha-beta search.\n uses either fixed or random ordering based on \n parameter.\n ('help iterate' for more info on this)\niterate_random => iterate player with random move ordering when all equal.\n ('help iterate' for more info on this)\niterate_fixed => iterate player with fixed ordering.\n" Nil)) -; - - (= - (help-player-example) + (= (help-player-example) (format "\nExample:\n\n player white human.\n player black random_aggressive.\n\nBoth players can be specified at once by the command:\n player .\n\n" Nil)) -; - - (= - (help-cd) + (= (help-cd) (format "\ncd . => change current directory to \n---------\n\n must be an atom or between single quotes:\nExample:\n\n cd mygames.\n cd '~~/metagame/games/'.\n" Nil)) -; - ; -; - +; ---------------------------------------- ; -; - +; Help from move menu ; -; +; ---------------------------------------- - - (= - (help-com $_ $_ $_) + (= (help-com $_ $_ $_) (help-commands)) -; - - - (= - (help-com $_ $_ $_ $F) - ( (help-com-entry $F $G) (call $G))) -; - - (= - (help-com $_ $_ $_ help) - ( (help-com-topics $Topics) - (format "To select a topic, type 'help .'~n" Nil) - (format "Help in this menu is available on the following topics:~n" Nil) - (pwl $Topics))) -; + (= (help-com $_ $_ $_ $F) + (help-com-entry $F $G) + (call $G)) + (= (help-com $_ $_ $_ help) + (help-com-topics $Topics) + (format "To select a topic, type 'help .'~n" Nil) + (format "Help in this menu is available on the following topics:~n" Nil) + (pwl $Topics)) - (= - (help-com-topics $Topics) - ( (findall $Topic - (help-com-entry $Topic $_) $AllTopics) (sort $AllTopics $Topics))) -; - - - - (= - (help_com_entry notation help_move) True) -; - - (= - (help_com_entry move help_move) True) -; - - (= - (help_com_entry clock help_clock) True) -; - - (= - (help_com_entry query help_query) True) -; - - (= - (help_com_entry show help_show) True) -; + (= (help-com-topics $Topics) + (findall $Topic + (help-com-entry $Topic $_) $AllTopics) + (sort $AllTopics $Topics)) - (= - (help_com_entry trace help_trace) True) -; - (= - (help_com_entry cd help_cd) True) -; + (= (help_com_entry notation help_move) True) + (= (help_com_entry move help_move) True) + (= (help_com_entry clock help_clock) True) + (= (help_com_entry query help_query) True) + (= (help_com_entry show help_show) True) + (= (help_com_entry trace help_trace) True) + (= (help_com_entry cd help_cd) True) + (= (help_com_entry iterate_random help_iterate) True) + (= (help_com_entry iterate help_iterate) True) + (= (help_com_entry advice help_advice) True) + (= (help_com_entry advisors help_advisors) True) + (= (help_com_entry weights help_weights) True) + (= (help_com_entry eval_fn help_eval_fn) True) + (= (help_com_entry evalfile help_evalfile) True) + (= (help_com_entry history help_history) True) - (= - (help_com_entry iterate_random help_iterate) True) -; - (= - (help_com_entry iterate help_iterate) True) -; - (= - (help_com_entry advice help_advice) True) -; - (= - (help_com_entry advisors help_advisors) True) -; + (= (help-commands) + (help-com-entry) + (help-com-selecting) + (help-system) + (help-com-state) + (help-syntax)) +; ; help_com_eval, - (= - (help_com_entry weights help_weights) True) -; - (= - (help_com_entry eval_fn help_eval_fn) True) -; - - (= - (help_com_entry evalfile help_evalfile) True) -; - - (= - (help_com_entry history help_history) True) -; - - - - - - (= - (help-commands) - ( (help-com-entry) - (help-com-selecting) - (help-system) - (help-com-state) - (help-syntax))) -; - - - - (= - (help-com-selecting) + (= (help-com-selecting) (format "\nSPECIAL MOVE SELECTION METHODS:\n-------------------------------\nselect. => backtrack through available moves\nrandom. => play a random legal move\nrandom_aggressive => play a winning, or random non-losing move, in that order\nvictor. => play a move which wins immediately\nendgame. => play a move which ends the game immediately\ncautious. => play a move which blocks opponent's victory, if threatened\nmate. => play a move which forces a win in 2-ply\nthreaten. => play a move which threatens victory next move\ninstant. => play the first move generated (doesn't ask)\nalpha_beta {}. => does n-ply alpha-beta search (or DEPTH parameter if no n)\niterate. => does iterative-deepening search until timeout. \nadvice. => shows comments used in eval fn on current position (help)\nadvice => shows local advice for piece now at (x,y)\nevaluate. => evaluate current position using current parameters. \n" Nil)) -; - - (= - (help-com-state) + (= (help-com-state) (format "\nEXAMINING AND MODIFYING STATE OF GAME\n-------------------------------------\ndisplay. => print current state\nclock. => prints current game clock (help clock)\nquery. => computes some function on the current position (help query)\nsetup. => enters menu for setting up board positions\npass. => transfer control to the other player (ie null move)\naccess. => access state from a command level\ncheckpoint . => record current state under name (for debugging)\nrestore . => sets current state to that checkpointed as name \nrestart. => abandon current game, choose new game and players\nevalfile .=> loads .eval as eval tables for current game\n (help evalfile)\nnext (prev) => goto next (or previous) th position (help history)\n" Nil)) -; - - (= - (help-com-entry) + (= (help-com-entry) (format "\nBASIC MOVE ENTRY: \n-----------------\n => plays move ('help notation' for more information)\n" Nil)) -; - - (= - (help-syntax) + (= (help-syntax) (format "\nNote that all keyboard input can contain newlines, and that a period\nsignals the end of the input/command.\n" Nil)) -; - - (= - (help-move) - ( (help-move-basic) (help-move-completion))) -; + (= (help-move) + (help-move-basic) + (help-move-completion)) - - (= - (help-move-basic) + (= (help-move-basic) (format "\nBASIC MOVE ENTRY: \n-----------------\nThis follows the grammatical notation for moves, \nillustrated as follows:\n\nBasic Movements, eg:\n white king (5,1) -> (5,2). \n\nBasic Movements with a removal capture, eg:\n white king (5,1) -> (5,2) x black rook (4,1).\n\nPossession captures indicate player who will possess:\n white king (5,1) -> (5,2) x black rook (4,1) (white).\n\nMultiple Captures, eg: (if bug captures <-1,0> by {retrieve clobber})\n white bug (4,1) -> (3,1) x white fish (3,1) black bug (5,1).\n\nContinued Captures, eg:\n white checker (3,3) -> (5,5) x black checker (4,4);\n white checker (5,5) -> (3,7) x black king (4,6).\n\nPlacing a piece from a player's hand, eg:\n white king (white) -> (5,1).\n\nPromoting a piece which moved to or past the promote_rank.\n If player promotes, this happens at end of his turn:\n white pawn (2,7) -> (2,8); promote (2,8) white queen.\n If opponent promotes, this happens at start of his turn:\n promote (2,8) black queen; black queen (2,8) -> (2,5).\n\n" Nil)) -; - - (= - (help-move-completion) + (= (help-move-completion) (format "\nMOVE COMPLETION: (when COMPLETIONS parameter is ON)\n----------------\nInstead of the full grammatical move notation, you can enter\na sequence of words which occurs in the complete move notation.\nThis will match all moves containing those words in that order,\npossibly with other words in-between.\n\nUnlike the mode for entry of full grammatical move notations,\nsquares are here refered to in a more convenient form:\n\t(X,Y)\nwhere X is the letter for that column, and Y is the number for the row.\n\nSome examples of moves to be completed are:\n\npawn. => completes to moves involving a pawn.\nwhite (c,3) ->. => completes to moves moving a white piece from (c,3).\nx. => completes to moves which capture something.\nx rook. => completes to moves which capture a rook.\npromote. => completes to moves which enter promotion zone.\n. => completes to any legal moves.\n" Nil)) -; - - (= - (help-advice) + (= (help-advice) (format "\nadvice\n------\nPrints the advice regarding the current position, from all active\nadvisors. This advice will be weighted according to the values of the\nparamters to determine the overall evaluation of the position. \n\nadvice \n------------------\nGives only the local advice for the piece at in the current\nposition. \n\nExample:\n\tadvice f 4. ==> Will give local advice for whatever piece is there.\n advice. ==> Gives all advice, including global advice. \n\nhelp advisors ==> Gives more info on what advisors do. \n" Nil)) -; - - (= - (help-query) + (= (help-query) (format "\nquery .\n------------------------\nCalls a querying function on its arguments.\n\n must be one of the following:\n\nmobility => prints number of moves available for each player\nmaterial => prints number of pieces on board for each player\ngoal => prints whether a goal has been achieved \n\nThese functions have an optional argument, a :\n\nplayer => returns value for white only\nopponent => returns value for black only\n\nExample:\n\n query mobility player.\n query material opponent.\n query goal.\n ~n" Nil)) -; - - (= - (help-show) + (= (help-show) (format "\nshow .\n----------------------------\nCalls a showing function on its arguments.\n\n must be one of the following:\n\nweights => prints weight vectors for eval fns\nweights => prints weight vector for eval fn for \n is {player, opponent, or default}\n\nExample:\n\n show weights.\t\n show weights player.\n show weights default.\n ~n" Nil)) -; - - (= - (help-weights) + (= (help-weights) (format "\nAccessing Evaluation Function Weights\n-------------------------------------\nThe weights used by a particular player can be changed by the\ncommand:\n\tweight

MATERIAL MOBILITY. (negative values must be quoted)\nExample:\n\tweight player 5 1.\n\tweight opponent '-1' 0.\nWould make player value pieces and moves positively, \nwith pieces worth five times the value of each move,\nand would make opponent prefer losing material, and not \ncare about mobility. \n\nNote that if a weight is set to 0, no time is spent in counting\nthat feature in a position.\n\nTo view the weights: \n\tshow weights. ==> shows weights or both players\n\tshow weights . ==> shows weights for \n" Nil)) -; - - (= - (help-eval-fn) + (= (help-eval-fn) (format "\nEVALUATION FUNCTION\n--------------------\nThe default evaluation function is based on\nmaterial difference and mobility difference between the two \nplayers, where PLAYER (white) prefers positive differences,\nand OPPONENT (black) prefers negative differences.\n\nThe function is: \n\tEVAL = EVAL(PLAYER) - EVAL(OPPONENT)\nwhere\n\tEVAL(P) = WEIGHT(P,MATERIAL)*MATERIAL(P)\n - WEIGHT(P,MOBILITY)*MOBILITY(P)\nand\n\tMATERIAL(P) = Number of pieces P has on board\n\tMOBILITY(P) = Number of legal moves P has on board\n\nFor info on viewing and modifying these weights, (help weights)\n" Nil)) -; - - (= - (help-evalfile) + (= (help-evalfile) (format "\nEVALUATION FUNCTION TABLES\n--------------------------\nevalfile . => loads .eval as eval tables for current game\n\nSome example tables are found in:\n 'Metagame/games/chess.eval'\n 'Metagame/games/turncoat.eval'\n \nIf you create your own for a specific game, these can be loaded\nin either before starting a game (top-level menu), or\nwhen it is the human's turn to make a move (move command menu).\n\nThe searching players ('help player') make use of whichever table file\nis currently loaded. \n\nThe following parameters are useful with evaluation tables:\n : relative weight to give piece-square tables \n : relative weight to give specific material tables\n : relative weight to give a player for having\n each piece of his color on the board.\n : (not implemented)\n : (not implemented)\n" Nil)) -; - - (= - (help-iterate) + (= (help-iterate) (format "\nThe player\n---------------------------\nThis player performs an iterative deepening alpha-beta search.\nIt uses the principal continuation heuristic. \nMove ordering is determined by the paramer ORDERING:\n\trandom: choose a random move when all evaluated equal.\n fixed: choose the first move found when all evaluated equal. \n\nThe iterative searcher will end the search after it has run out\nof time, based on the parameter: .\nFor example, the command:\n\tset move_time_limit 20000. \nwill force it to stop its search after 20 seconds (20,000 msec).\n\nNote that a player loses the game if it uses more than \nmsecs, so set this with the command:\n\tset game_time_limit 3600000. (for 1 hour time-limit)\n\nMore info is available about the current eval fn (help eval_fn).\n\nSome tracing information is available on this player, (help trace). \n ~n" Nil)) -; - - - (= - (help-trace) - ( (help-trace-general) - (help-trace-play) - (help-trace-ab) - (help-trace-gen))) -; + (= (help-trace) + (help-trace-general) + (help-trace-play) + (help-trace-ab) + (help-trace-gen)) - (= - (help-trace-general) + (= (help-trace-general) (format "\ntrace {}.\nuntrace {}.\n-------------------------------\nEnables or disables tracing some component of a module.\nIf the module does not have any components, no component\nis needed here.\n\nListing traced Modules\n----------------------\nTo list the modules which are currently being traced, do:\n\tlist_tracing.\n\nTraceable Modules\n-----------------\nCurrently, the following tracing modules might be useful:\n ~n" Nil)) -; - - (= - (help-trace-play) + (= (help-trace-play) (format "\nVerbosity when playing games (play) \n-----------------------------------\n\tstate: print state as moves are chosen by players.\n move: print move as moves are chosen by players. \n clock: print the clock as moves are played. \n\nThese are all set to ON by default whenever a \nhuman is playing. \n\nExample: \n\ttrace play state. => turns this on\n\tuntrace play clock. => turns this off\n\n" Nil)) -; - - (= - (help-trace-ab) + (= (help-trace-ab) (format "\nTracing Alphabeta (ab) Search\n-----------------------------\n\tordering: info regarding move ordering heuristics\n\tvalue: info regarding value of moves found during search\n also traces principal continuations \n\tresources: info regarding resource consumption during search\n timing: info on timeout checks during search\n\titeration: info on time taken by each iteration of the search\n eval: show evaluation of each node evaluated.\n expand: show each node as it is expanded. \n advice: show influence on evals for each node evaluated.\n state: print each state visited. \n\nExample: \n\ttrace ab ordering. => turns this on\n\tuntrace ab value. => turns this off\n\n" Nil)) -; - - (= - (help-trace-gen) + (= (help-trace-gen) (format "\nTracing Game Generation (gen) \n-----------------------------\n\tgoals: info goal generation\n\tsimplify: info on goal simplification\n subsume: info on goal redundancy checking and elimination\n\tpieces: info on piece generation.\n\nExample: \n\ttrace gen pieces. => turns this on\n\tuntrace gen subsume. => turns this off\n" Nil)) -; - ; -; - +; ---------------------------------------- ; -; - +; Help from accept_move menu ; -; +; ---------------------------------------- - - (= - (help-accept) + (= (help-accept) (format "\nYou can accept this choice, backtrack, or abort:\n\nyes. (y) => accept this choice\nnext. (n,no) => reject this choice and consider next (if any)\nabort. => accept no choices, go back to menu\nhelp. => show this list\n" Nil)) -; - diff --git a/metagame/play/help_advisors.metta b/metagame/play/help_advisors.metta index 0dc8188..092282d 100644 --- a/metagame/play/help_advisors.metta +++ b/metagame/play/help_advisors.metta @@ -1,204 +1,99 @@ +; (convert_to_metta_file help_advisors $_378488 metagame/play/help_advisors.pl metagame/play/help_advisors.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; +; ============================================================ - - (= - (help-advisors) + (= (help-advisors) (print-advisors)) -; - - (= - (print-advisors) - ( (advisor-herald $H) - (format "~s~n" - (:: $H)) - (whenever - (print-advisor $A) - (format "~n~n" Nil)))) -; - + (= (print-advisors) + (advisor-herald $H) + (format "~s~n" + (:: $H)) + (whenever + (print-advisor $A) + (format "~n~n" Nil))) - (= - (advisor_herald "Explanation of ADVISORS\n-----------------------\nFollowing is the list of all advisors with a brief explanation.\nAlso shown (in parens) is the current value for each advisor.\nFor more information, consult the papers or source-code.\n") True) -; - - - - (= - (print-advisor $A) - ( (advisor-weight $A $W) - (advhelp $A $Help) - (format "<~p> (~p) ~n~s" - (:: $A $W $Help)))) -; - - - - - (= - (advhelp gen_material "Gives 1 point for each white piece, -1 for black.") True) -; - - - (= - (advhelp material "Uses user-defined material function if available (help evalfile).") True) -; - - - (= - (advhelp square "Uses user-defined piece-square table if available (help evalfile).") True) -; - - - (= - (advhelp lthreat "Gives points for each enemy piece a piece can capture.") True) -; + (= (advisor_herald "Explanation of ADVISORS\n-----------------------\nFollowing is the list of all advisors with a brief explanation.\nAlso shown (in parens) is the current value for each advisor.\nFor more information, consult the papers or source-code.\n") True) - (= - (advhelp potent "Like lthreat, but reduces each threat value if defended.") True) -; + (= (print-advisor $A) + (advisor-weight $A $W) + (advhelp $A $Help) + (format "<~p> (~p) ~n~s" + (:: $A $W $Help))) - (= - (advhelp gthreat "Value only for best of all lthreats.") True) -; + (= (advhelp gen_material "Gives 1 point for each white piece, -1 for black.") True) - (= - (advhelp pthreat "Value only for best of all potent threats.") True) -; + (= (advhelp material "Uses user-defined material function if available (help evalfile).") True) + (= (advhelp square "Uses user-defined piece-square table if available (help evalfile).") True) - (= - (advhelp vital "Doesn't like leaving pieces attacked when enemy achieves goal \nby removing them. Only sensitive when there are VITAL_NUMBER pieces left.") True) -; + (= (advhelp lthreat "Gives points for each enemy piece a piece can capture.") True) + (= (advhelp potent "Like lthreat, but reduces each threat value if defended.") True) - (= - (advhelp dynamic_mobility "1 point for each move piece makes in current position.") True) -; + (= (advhelp gthreat "Value only for best of all lthreats.") True) + (= (advhelp pthreat "Value only for best of all potent threats.") True) - (= - (advhelp static_mobility "1 point each move piece makes from square on empty board.") True) -; + (= (advhelp vital "Doesn't like leaving pieces attacked when enemy achieves goal \nby removing them. Only sensitive when there are VITAL_NUMBER pieces left.") True) + (= (advhelp dynamic_mobility "1 point for each move piece makes in current position.") True) - (= - (advhelp eventual_mobility "Points for each square piece can ever reach from square on empty board,\ndiscounted by how many moves it takes piece to get there from square. The discount\nfunction is controlled by DISCOUNT parameter, either INVERSE or EXPONENT.") True) -; + (= (advhelp static_mobility "1 point each move piece makes from square on empty board.") True) + (= (advhelp eventual_mobility "Points for each square piece can ever reach from square on empty board,\ndiscounted by how many moves it takes piece to get there from square. The discount\nfunction is controlled by DISCOUNT parameter, either INVERSE or EXPONENT.") True) - (= - (advhelp gmovmob "Sum of dynamic_mobility for all player's pieces.") True) -; + (= (advhelp gmovmob "Sum of dynamic_mobility for all player's pieces.") True) + (= (advhelp gcapmob "1 point for each capturing-move in current position.") True) - (= - (advhelp gcapmob "1 point for each capturing-move in current position.") True) -; + (= (advhelp arrive_distance "Favors pieces on squares close to achieving arrival goals.") True) + (= (advhelp promote_distance "Favors getting pieces close to promotion. \nValue based on cost to get to promotion square, and value of best piece the piece\ncan eventually promote into.") True) - (= - (advhelp arrive_distance "Favors pieces on squares close to achieving arrival goals.") True) -; - - - (= - (advhelp promote_distance "Favors getting pieces close to promotion. \nValue based on cost to get to promotion square, and value of best piece the piece\ncan eventually promote into.") True) -; - - - (= - (advhelp possess "Points for each piece player has in hand. Generally the value\nis the average or max of the values it would have when placed on the board.") True) -; - + (= (advhelp possess "Points for each piece player has in hand. Generally the value\nis the average or max of the values it would have when placed on the board.") True) - (= - (advhelp initprom "Anticipates points which will follow when player init-promotes a piece\nnext turn. Value will be value of best choice that player can make.") True) -; - - - (= - (advhelp random "Adds a random noise to position value, in range [RANDOM_MIN,RANDOM_MAX].\nNote that this value will be multiplied by the weight \nattached to this advisor [as is the case for all advisors.]") True) -; - - - - (= - (advhelp static "The following advisors are used to build the static tables for each piece. \nThis advisor determines how much to weigh the static values vs. other advisors.") True) -; - - - (= - (advhelp victims "Point for each piece this piece could someday capture.") True) -; - - - (= - (advhelp immunity "Points for each enemy piece which cannot someday capture this piece.") True) -; - - - (= - (advhelp giveaway "Points for each piece we own which can someday capture this piece.") True) -; - - - (= - (advhelp eradicate "Points for pieces which enemy would like to eradicate.") True) -; - + (= (advhelp initprom "Anticipates points which will follow when player init-promotes a piece\nnext turn. Value will be value of best choice that player can make.") True) - (= - (advhelp stalemate "Degree to which piece might contribute to stalemate goals.") True) -; + (= (advhelp random "Adds a random noise to position value, in range [RANDOM_MIN,RANDOM_MAX].\nNote that this value will be multiplied by the weight \nattached to this advisor [as is the case for all advisors.]") True) - (= - (advhelp arrive "Degree to which piece might contribute to arrive goals.") True) -; + (= (advhelp static "The following advisors are used to build the static tables for each piece. \nThis advisor determines how much to weigh the static values vs. other advisors.") True) + (= (advhelp victims "Point for each piece this piece could someday capture.") True) - (= - (advhelp max_static_mob "Maximum static mobility piece has.") True) -; + (= (advhelp immunity "Points for each enemy piece which cannot someday capture this piece.") True) + (= (advhelp giveaway "Points for each piece we own which can someday capture this piece.") True) - (= - (advhelp max_eventual_mob "Maximum eventual mobility piece has.") True) -; + (= (advhelp eradicate "Points for pieces which enemy would like to eradicate.") True) + (= (advhelp stalemate "Degree to which piece might contribute to stalemate goals.") True) - (= - (advhelp avg_static_mob "Average static mobility piece has.") True) -; + (= (advhelp arrive "Degree to which piece might contribute to arrive goals.") True) + (= (advhelp max_static_mob "Maximum static mobility piece has.") True) - (= - (advhelp avg_eventual_mob "Average eventual mobility piece has.") True) -; + (= (advhelp max_eventual_mob "Maximum eventual mobility piece has.") True) + (= (advhelp avg_static_mob "Average static mobility piece has.") True) - (= - (advhelp dominate "Not used.") True) -; + (= (advhelp avg_eventual_mob "Average eventual mobility piece has.") True) + (= (advhelp dominate "Not used.") True) diff --git a/metagame/play/history.metta b/metagame/play/history.metta index fae9a69..7005ad4 100644 --- a/metagame/play/history.metta +++ b/metagame/play/history.metta @@ -1,352 +1,232 @@ +; (convert_to_metta_file history $_462230 metagame/play/history.pl metagame/play/history.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; history.pl ; -; - +; ;; ; -; - +; ;; Interface routines: ; -; - +; ;; ------------------- ; -; - +; ;; From top menu: ; -; - +; ;; start : Start game in pos checkpointed as ; -; - +; ;; save : Save record of current game as .rec ; -; - +; ;; load : Load record of game .rec ; -; - +; ;; ; -; - +; ;; From move menu: ; -; - +; ;; next : Advance positions in current game history. ; -; - +; ;; prev : Regress positions in current game history. ; -; - +; ;; next: next 1. ; -; - +; ;; prev: prev 1. ; -; - - +; ;; clear history: Delete *all* history entries and saved positions. - (= - (help-history) - ( (help-history-overview) - (help-history-top) - (help-history-com))) -; + (= (help-history) + (help-history-overview) + (help-history-top) + (help-history-com)) - (= - (help-history-overview) + (= (help-history-overview) (format "\nGame History Management\n-----------------------\nThese routines allow you to review the history of the current\ngame. To use them, you must set the white player to be human,\notherwise the program will begin playing from the chosen position\nand there will be no chance to review the past game. \n\nIn addition, see the menu: EXAMINING AND MODIFYING STATE OF GAME,\nwhich allows you to save and restore important positions even when in\nthe middle of a game. Note however that these positions will not\nnecessarily be hooked into the history mechanisms discussed here. \n" Nil)) -; - - (= - (help-history-top) + (= (help-history-top) (format "\nFrom top menu:\nsave : Save record of current game as .rec\nload : Load record of game .rec as current history. \nstart : Start game in pos checkpointed as \n" Nil)) -; - - (= - (help-history-com) + (= (help-history-com) (format "\nFrom move menu: \nnext : Advance positions in current game history.\nprev : Regress positions in current game history.\nnext: next 1.\nprev: prev 1.\nclear history: Delete *all* history entries and saved positions.\n\nNote the playing a new move erases whatever moves may have come after \nin the present game record. \n" Nil)) -; - - (= - (next-com $M $SIn $SOut) + (= (next-com $M $SIn $SOut) (forward-hist 1 $SOut)) -; - - (= - (next-com $M $SIn $SOut $N) + (= (next-com $M $SIn $SOut $N) (forward-hist $N $SOut)) -; - - (= - (prev-com $M $SIn $SOut) + (= (prev-com $M $SIn $SOut) (reverse-hist 1 $SOut)) -; - - (= - (prev-com $M $SIn $SOut $N) + (= (prev-com $M $SIn $SOut $N) (reverse-hist $N $SOut)) -; - - (= - (clear-com $_ $_ $_ history) + (= (clear-com $_ $_ $_ history) (clear-history)) -; - ; -; - +; Saving and loading games - (= - (save-top $Game) + (= (save-top $Game) (print-game-record-to-file $Game)) -; - - (= - (save-com $_ $_ $_ $Game) + (= (save-com $_ $_ $_ $Game) (print-game-record-to-file $Game)) -; - - (= - (load-top $Game) + (= (load-top $Game) (read-game-record-from-file $Game)) -; - - (= - (load-com $_ $_ $_ $Game) + (= (load-com $_ $_ $_ $Game) (read-game-record-from-file $Game)) -; - ; -; - +; ================================================================================ !(dynamic (, (/ follows 3) (/ current-pos-name 1))) -; + (= (forward-hist $N $SOut) + (current-pos-name $NameIn) + (forward-name $N $NameIn $NameOut) + (checkpoint $NameOut $SOut) + (set-current-pos-name $NameOut) + (print-state $SOut) + (last-move $LastMove) + (print-notation $LastMove)) - (= - (forward-hist $N $SOut) - ( (current-pos-name $NameIn) - (forward-name $N $NameIn $NameOut) - (checkpoint $NameOut $SOut) - (set-current-pos-name $NameOut) - (print-state $SOut) - (last-move $LastMove) - (print-notation $LastMove))) -; + (= (reverse-hist $N $SOut) + (current-pos-name $NameIn) + (forward-name $N $NameOut $NameIn) + (checkpoint $NameOut $SOut) + (set-current-pos-name $NameOut) + (print-state $SOut) + (last-move $LastMove) + (print-notation $LastMove)) - (= - (reverse-hist $N $SOut) - ( (current-pos-name $NameIn) - (forward-name $N $NameOut $NameIn) - (checkpoint $NameOut $SOut) - (set-current-pos-name $NameOut) - (print-state $SOut) - (last-move $LastMove) - (print-notation $LastMove))) -; + (= (forward_name 0 $NameIn $NameIn) True) + (= (forward-name $N $NameIn $NameOut) + (> $N 0) + (is $N1 + (- $N 1)) + (follows-history $NameIn $Name1) + (forward-name $N1 $Name1 $NameOut)) - - (= - (forward_name 0 $NameIn $NameIn) True) -; - - (= - (forward-name $N $NameIn $NameOut) - ( (> $N 0) - (is $N1 - (- $N 1)) - (follows-history $NameIn $Name1) - (forward-name $N1 $Name1 $NameOut))) -; - - - - (= - (follows-history $N1 $N2) - (follows $N1 $_ $N2)) -; - - - (= - (follows-history $N1 $Move $N2) - (follows $N1 $Move $N2)) -; + (= (follows-history $N1 $N2) + (follows $N1 $_ $N2)) + (= (follows-history $N1 $Move $N2) + (follows $N1 $Move $N2)) - (= - (initialize-history $SIn) - ( (checkpoint-state init $SIn) (set-current-pos-name init))) -; - + (= (initialize-history $SIn) + (checkpoint-state init $SIn) + (set-current-pos-name init)) ; -; - +; CURRENT_POSITION(-Pos) ; -; - - - (= - (current-position $Pos) - ( (current-pos-name $Name) (checkpoint $Name $Pos))) -; +; Pos is the current position in the history. + (= (current-position $Pos) + (current-pos-name $Name) + (checkpoint $Name $Pos)) ; -; - +; LAST_MOVE(-Move) ; -; - +; Returns the internal representation (if any) of the move made prior ; -; - - - (= - (last-move $Move) - ( (current-pos-name $Name) (follows-history $_ $Move $Name))) -; - - - - - (= - (set-current-pos-name $Name) - ( (remove-all-symbols &self - (current_pos_name $_)) (add-symbol &self (current_pos_name $Name)))) -; +; to this one in the current position. + (= (last-move $Move) + (current-pos-name $Name) + (follows-history $_ $Move $Name)) - (= - (change-current-pos-name $Name $Next) - ( (remove-symbol &self - (current_pos_name $Name)) (add-symbol &self (current_pos_name $Next)))) -; - + (= (set-current-pos-name $Name) + ( (remove-all-atoms &self + (current_pos_name $_)) (add-is-symbol &self (current_pos_name $Name)))) - (= - (set-follows-history $Name $Move $Next) - ( (clear-history-after $Name) (add-symbol &self (follows $Name $Move $Next)))) -; + (= (change-current-pos-name $Name $Next) + ( (remove-is-symbol &self + (current_pos_name $Name)) (add-is-symbol &self (current_pos_name $Next)))) - (= - (add-state-to-history $Move $State) - ( (checkpoint-state-gensym $State $Next) (update-history $Move $Next))) -; + (= (set-follows-history $Name $Move $Next) + ( (clear-history-after $Name) (add-is-symbol &self (follows $Name $Move $Next)))) + (= (add-state-to-history $Move $State) + (checkpoint-state-gensym $State $Next) + (update-history $Move $Next)) - (= - (update-history $Move $Next) - ( (change-current-pos-name $Name $Next) (set-follows-history $Name $Move $Next))) -; + (= (update-history $Move $Next) + (change-current-pos-name $Name $Next) + (set-follows-history $Name $Move $Next)) - (= - (clear-history) - ( (remove-all-symbols &self - (checkpoint $_ $_)) (remove-all-symbols &self (follows $_ $_ $_)))) -; - + (= (clear-history) + ( (remove-all-atoms &self + (checkpoint $_ $_)) (remove-all-atoms &self (follows $_ $_ $_)))) - (= - (clear-history-visible) + (= (clear-history-visible) (or (, (clear-history-after $Name) (fail)) True)) -; - - (= - (clear-history-after $Name) + (= (clear-history-after $Name) (det-if-then-else - (remove-symbol &self + (remove-is-symbol &self (follows $Name $_ $Next)) (, - (remove-symbol &self + (remove-is-symbol &self (checkpoint $Next $_)) (clear-history-after $Next)) True)) -; - ; -; - +; Unifies State with each state occuring in the current game ; -; - +; order. - (= - (history-state $State) + (= (history-state $State) (checkpoint init $State)) -; - - (= - (history-state $State) - ( (follows-history $Name1 $Name2) (checkpoint $Name2 $State))) -; + (= (history-state $State) + (follows-history $Name1 $Name2) + (checkpoint $Name2 $State)) - - (= - (restore-state $N $State) + (= (restore-state $N $State) (det-if-then-else (, (current-predicate checkpoint $_) @@ -357,189 +237,134 @@ (:: $N))) (format "~nError: No state: <~w> has been is checkpointed~n" (:: $N)))) -; - - (= - (checkpoint-state $State) + (= (checkpoint-state $State) (checkpoint-state-gensym $State $Name)) -; - - - (= - (checkpoint-state-gensym $State $Name) - ( (gensym checkpoint $Name) (checkpoint-state $Name $State))) -; + (= (checkpoint-state-gensym $State $Name) + (gensym checkpoint $Name) + (checkpoint-state $Name $State)) - (= - (checkpoint-state $Name $State) - ( (remove-all-symbols &self + (= (checkpoint-state $Name $State) + ( (remove-all-atoms &self (checkpoint $Name $_)) - (add-symbol &self + (add-is-symbol &self (checkpoint $Name $State)) (format "~nState checkpointed under index: <~w>~n" (:: $Name)))) -; - ; -; - +; ================================================================================ ; -; - +; Saving and loading game records ; -; - +; ================================================================================ ; -; - +; Game Record file format: ; -; - +; A saved game record consists of a sequence of grammatical move descriptions, ; -; - +; POSSIBLY ABBREVIATED (so long as they are unambiguous). This format is ; -; - +; just what would have been read from a keyboard to enter the moves from the ; -; - +; human interface. ; -; - +; The file may also contain arbitrary comments, prefaced as usual by ';'. ; -; - +; The ability to abbreviate game records makes this format extremely flexible. ; ; - ; -; - +; One caution: The program replays the game in order to save or load the file, ; -; - +; thus if move generation for a given game is slow this takes noticeable time. ; -; - +; If MoveString is instantiated, will backtrack over moves ; -; - +; in the game which are completions of MoveString. - (= - (move-string $Move $MoveString) - ( (follows-history $Name1 $Name2) - (checkpoint $Name1 $State1) - (checkpoint $Name2 $State2) - (det-if-then - (completed-move $MoveString $Move $State1 $State2) True))) -; - - - - (= - (print-next-move $MoveString) - ( (move-string $Move $MoveString) - (print-tokens $MoveString) - (nl))) -; + (= (move-string $Move $MoveString) + (follows-history $Name1 $Name2) + (checkpoint $Name1 $State1) + (checkpoint $Name2 $State2) + (det-if-then + (completed-move $MoveString $Move $State1 $State2) True)) + (= (print-next-move $MoveString) + (move-string $Move $MoveString) + (print-tokens $MoveString) + (nl)) - (= - (read-next-move $MoveString) - ( (read-keyboard-tokens $MoveString) - (current-position $State1) - (det-if-then - (completed-move $MoveString $Move $State1 $State2) True) - (add-state-to-history $Move $State2))) -; + (= (read-next-move $MoveString) + (read-keyboard-tokens $MoveString) + (current-position $State1) + (det-if-then + (completed-move $MoveString $Move $State1 $State2) True) + (add-state-to-history $Move $State2)) - (= - (print-game-record) + (= (print-game-record) (or (, (print-next-move $_) - (fail)) True)) -; - - - - (= - (get-initialize-history $In) - ( (get-initial-state $In) (initialize-history $In))) -; + (fail)) True)) - - - (= - (read-game-record) - ( (get-initialize-history $In) (read-record-moves))) -; + (= (get-initialize-history $In) + (get-initial-state $In) + (initialize-history $In)) - (= - (read-record-moves) - ( (read-next-move $_) - (set-det) - (read-record-moves))) -; + (= (read-game-record) + (get-initialize-history $In) + (read-record-moves)) - (= read_record_moves True) -; + (= (read-record-moves) + (read-next-move $_) + (set-det) + (read-record-moves)) + (= read_record_moves True) ; -; - +; PRINT_GAME_RECORD_TO_FILE(+File) ; -; - - - (= - (print-game-record-to-file $File) - ( (sys-suffixed-filename $File record $GameFile) - (format "~nWriting game record to file: ~w~n" - (:: $GameFile)) - (with-output-file $GameFile append print-game-record))) -; +; Outputs a game to file File.rec. + (= (print-game-record-to-file $File) + (sys-suffixed-filename $File record $GameFile) + (format "~nWriting game record to file: ~w~n" + (:: $GameFile)) + (with-output-file $GameFile append print-game-record)) ; -; - +; PRINT_GAME_RECORD_TO_FILE(+File) ; -; - - - (= - (read-game-record-from-file $File) - ( (sys-suffixed-filename $File record $GameFile) - (format "~nReading game record from file: ~w~n" - (:: $GameFile)) - (see $GameFile) - (read-game-record) - (seen))) -; +; Outputs a game to file File.rec. + (= (read-game-record-from-file $File) + (sys-suffixed-filename $File record $GameFile) + (format "~nReading game record from file: ~w~n" + (:: $GameFile)) + (see $GameFile) + (read-game-record) + (seen)) +; ; write_old_seed, diff --git a/metagame/play/interface.metta b/metagame/play/interface.metta index 765e492..7dc58aa 100644 --- a/metagame/play/interface.metta +++ b/metagame/play/interface.metta @@ -1,1289 +1,865 @@ +; (convert_to_metta_file interface $_116354 metagame/play/interface.pl metagame/play/interface.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; interface.pl !(my-ensure-loaded (library shells)) -; - !(my-ensure-loaded (library menus)) -; - ; -; - +; ASK_MOVE(-Move,+SIn,-SOut) ; -; - +; Top level menu. Process moves and commands from user. ; -; - - - (= - (ask-move $Move $SIn $SOut) - ( (format "~nEnter a move or command (help gives more information)~n" Nil) - (read-keyboard-tokens $String) - (process-move-or-command $String $Move $SIn $S1) - (set-det) - (really-get-move $Move $SIn $S1 $SOut))) -; - - (= - (ask-move $Move $SIn $SOut) - ( (control $Player $SIn) - (format "~n~p failed to select a legal move. Please try again!~n" - (:: $Player)) - (format "~n ('display.' to redisplay board)~n" Nil) - (ask-move $Move $SIn $SOut))) -; +; Loops until the user has chosen a legal move. + (= (ask-move $Move $SIn $SOut) + (format "~nEnter a move or command (help gives more information)~n" Nil) + (read-keyboard-tokens $String) + (process-move-or-command $String $Move $SIn $S1) + (set-det) + (really-get-move $Move $SIn $S1 $SOut)) + (= (ask-move $Move $SIn $SOut) + (control $Player $SIn) + (format "~n~p failed to select a legal move. Please try again!~n" + (:: $Player)) + (format "~n ('display.' to redisplay board)~n" Nil) + (ask-move $Move $SIn $SOut)) ; -; - +; REALLY_GET_MOVE(?Move,+SIn,+S1,-SOut). ; -; - +; Ensure that a move has been chosen, else back to the menu. ; -; - +; If Move and S1 are bound, we accept S1 as the result. ; -; - +; If only S1 is bound, we accept this as a new current state, ; -; - +; and use it to get the final move. ; -; - +; If neither, then some other command didn't do any work, ; -; - +; and we start again from our original state to get the move. ; ; - - (= - (really-get-move $Move $SIn $S1 $S1) - ( (nonvar $Move) - (nonvar $S1) - (set-det))) -; - - (= - (really-get-move $Move $SIn $S1 $SOut) - ( (nonvar $S1) - (set-det) - (ask-move $Move $S1 $SOut))) -; - - (= - (really-get-move $Move $SIn $S1 $SOut) + (= (really-get-move $Move $SIn $S1 $S1) + (nonvar $Move) + (nonvar $S1) + (set-det)) + (= (really-get-move $Move $SIn $S1 $SOut) + (nonvar $S1) + (set-det) + (ask-move $Move $S1 $SOut)) + (= (really-get-move $Move $SIn $S1 $SOut) (ask-move $Move $SIn $SOut)) -; - ; -; - +; PROCESS_MOVE_OR_COMMAND(MoveString,Move,SIn,SOut) ; -; - +; If the string is a legal command for this menu, call it. ; -; - +; If it is a complete move notation, offer to select that move. ; -; - +; If it is an incomplete move notation, complete it and offer it ; -; - +; (only when COMPLETETIONS parameter is ON. ; ; - - (= - (process-move-or-command $MoveString $Move $SIn $SOut) + (= (process-move-or-command $MoveString $Move $SIn $SOut) (process-command $MoveString com (:: $Move $SIn $SOut))) -; - - (= - (process-move-or-command $MoveString $Move $SIn $SOut) - ( (nl) - (set-parsing-mode) - (move-notation $Move $MoveString) - (set-det) - (verbosely-format "~nTrying Move: ~p~n" - (:: $Move)) - (select-move $Move $SIn $SOut))) -; - - (= - (process-move-or-command $MoveString $Move $SIn $SOut) - ( (format "Attempting to find a completion for move: " Nil) - (print-tokens $MoveString) - (nl) - (parameter completions on) - (choose-completed-move $MoveString $Move $SIn $SOut))) -; - + (= (process-move-or-command $MoveString $Move $SIn $SOut) + (nl) + (set-parsing-mode) + (move-notation $Move $MoveString) + (set-det) + (verbosely-format "~nTrying Move: ~p~n" + (:: $Move)) + (select-move $Move $SIn $SOut)) + (= (process-move-or-command $MoveString $Move $SIn $SOut) + (format "Attempting to find a completion for move: " Nil) + (print-tokens $MoveString) + (nl) + (parameter completions on) + (choose-completed-move $MoveString $Move $SIn $SOut)) ; -; - +; SELECT_MOVE(Move,SIn,SOut) ; -; - - - (= - (select-move $Move $SIn $SOut) - ( (legal $Move $SIn $SOut) - (format "~nAfter:~n" Nil) - (print-state $SOut) - (print-notation $Move) - (ask-accept-choice $Answer) - (det-if-then-else - (= $Answer abort) - (, - (set-det) - (fail)) - (= $Answer yes)))) -; +; Backtrack over possible legal moves until one is selected. + (= (select-move $Move $SIn $SOut) + (legal $Move $SIn $SOut) + (format "~nAfter:~n" Nil) + (print-state $SOut) + (print-notation $Move) + (ask-accept-choice $Answer) + (det-if-then-else + (= $Answer abort) + (, + (set-det) + (fail)) + (= $Answer yes))) +; ; format("~nBefore:~n",[]), ; print_state(SIn), ; -; - +; PRINTING_CHOOSE(Method,Move,SIn,SOut) ; -; - +; Method is the functor of a procedure which generates moves on backtracking. ; -; - +; Here we call this procedure, timing it, and offer the user the generated moves, ; -; - +; in order. ; ; - ; -; - +; Ex: random_move(Move,SIn,SOut) generates random moves ; -; - +; Call: printing_choose(random_move,Move,SIn,SOut) ; ; - - (= - (printing-choose $Method $Move $SIn $SOut) - ( (=.. $Chooser - (:: $Method $Move $SIn $SOut)) (selecting-choice (, (timing $Chooser) (format "~nAfter:~n" Nil) (print-state $SOut) (print-notation $Move))))) -; - + (= (printing-choose $Method $Move $SIn $SOut) + (=.. $Chooser + (:: $Method $Move $SIn $SOut)) + (selecting-choice (, (timing $Chooser) (format "~nAfter:~n" Nil) (print-state $SOut) (print-notation $Move)))) ; -; - +; RANDOM_PRINTING_CHOOSE(Method,Move,SIn,SOut) ; -; - +; Like printing_choose, but offers user only a randomly chosen ; -; - - - (= - (random-printing-choose $Method $Move $SIn $SOut) - ( (=.. $Chooser - (:: $Method $Move $SIn $SOut)) (selecting-choice (, (timing (random-success $Chooser)) (format "~nAfter:~n" Nil) (print-state $SOut) (print-notation $Move))))) -; +; generated move. + (= (random-printing-choose $Method $Move $SIn $SOut) + (=.. $Chooser + (:: $Method $Move $SIn $SOut)) + (selecting-choice (, (timing (random-success $Chooser)) (format "~nAfter:~n" Nil) (print-state $SOut) (print-notation $Move)))) ; -; - +; =========================================================================== ; -; - +; Move Completion ; -; - +; =========================================================================== ; -; - +; COMPATIBLE(Op,Tokens) ; -; - +; (Described in help menu) ; -; - +; Note that in the human-friendly abbreviated move notation, ; -; - +; only the (letter,number) = (column,row) notation is used for ; -; - +; denoting squares. ; -; - +; When the parameter SAFETY is ON, this will only complete to ; -; - +; moves which do not immediately lose for the moving player. ; -; - +; (So if you can not make any moves but you aren't stalemated, you might ; -; - +; have to turn safety off to make your last losing move ...) - (= - (compatible $Op $Tokens) - ( (with-alpha-squares (, (move-notation $Op $FullToks) (mesh $Completion $Tokens $FullToks))) (verbosely-format "~nTokens: ~w~nCompletion: ~w~nFull: ~w~n" (:: $Tokens $Completion $FullToks)))) -; - - + (= (compatible $Op $Tokens) + (with-alpha-squares (, (move-notation $Op $FullToks) (mesh $Completion $Tokens $FullToks))) + (verbosely-format "~nTokens: ~w~nCompletion: ~w~nFull: ~w~n" + (:: $Tokens $Completion $FullToks))) - (= - (completed-move $Tokens $Move $SIn $SOut) - ( (legal $Move $SIn $SOut) - (compatible $Move $Tokens) - (acceptable $Move $SIn $SOut))) -; + (= (completed-move $Tokens $Move $SIn $SOut) + (legal $Move $SIn $SOut) + (compatible $Move $Tokens) + (acceptable $Move $SIn $SOut)) - (= - (acceptable $Move $SIn $SOut) + (= (acceptable $Move $SIn $SOut) (det-if-then-else (parameter safety on) (check-safe-move $Move $SIn $SOut) True)) -; - - (= - (choose-completed-move $Tokens $Move $SIn $SOut) - ( (= $Chooser - (completed-move $Tokens $Move $SIn $SOut)) (selecting-choice (, (timing $Chooser) (format "~nAfter:~n" Nil) (print-choice $Move $SIn $SOut))))) -; - + (= (choose-completed-move $Tokens $Move $SIn $SOut) + (= $Chooser + (completed-move $Tokens $Move $SIn $SOut)) + (selecting-choice (, (timing $Chooser) (format "~nAfter:~n" Nil) (print-choice $Move $SIn $SOut)))) ; -; - +; Added a flush so we always have updated record when ; -; - +; writing to files. ; -; - +; Can set printing of states and moves with ; -; - +; '(un)trace play state' and '(un)trace play move'. ; ; - - (= - (print-choice $Move $SIn $SOut) - ( (current-output $O) - (flush-output $O) - (tracing-play state - (print-state $SOut)) - (tracing-play move - (print-notation $Move)) - (linebreak))) -; - + (= (print-choice $Move $SIn $SOut) + (current-output $O) + (flush-output $O) + (tracing-play state + (print-state $SOut)) + (tracing-play move + (print-notation $Move)) + (linebreak)) - (= - (linebreak) + (= (linebreak) (format "\n===============================================================\n" Nil)) -; - - (= - (print-notation $Op) - ( (set-printing-mode) - (with-alpha-squares (move-notation $Op $Notate)) - (set-det) - (format "Notated Move played: ~n" Nil) - (print-tokens $Notate) - (nl) - (nl) - (verbosely-format "~n~nFull Move played: ~p~n" - (:: $Op)))) -; - - (= - (print-notation $Op) + (= (print-notation $Op) + (set-printing-mode) + (with-alpha-squares (move-notation $Op $Notate)) + (set-det) + (format "Notated Move played: ~n" Nil) + (print-tokens $Notate) + (nl) + (nl) + (verbosely-format "~n~nFull Move played: ~p~n" + (:: $Op))) + (= (print-notation $Op) (format "Move played: ~p~n" (:: $Op))) -; - - (= - (print-move $Move) - ( (set-printing-mode) - (with-alpha-squares (move-notation $Move $Notate)) - (set-det) - (print-tokens $Notate) - (nl))) -; - - (= - (print-move $Move) + (= (print-move $Move) + (set-printing-mode) + (with-alpha-squares (move-notation $Move $Notate)) + (set-det) + (print-tokens $Notate) + (nl)) + (= (print-move $Move) (format "Move: ~p~n" (:: $Move))) -; - ; -; - +; ====================================================================== ; -; - +; Offering and Accepting Choices ; -; - +; ====================================================================== ; -; - +; SELECTING_CHOICE(+Goal) ; -; - +; Backtrack over possible choices until one is selected, ; -; - - - (= - (selecting-choice $Goal) - ( (call $Goal) - (ask-accept-choice $Answer) - (det-if-then-else - (= $Answer abort) - (, - (set-det) - (fail)) - (, - (= $Answer yes) - (set-det))))) -; - - +; or user wishes to abort. + (= (selecting-choice $Goal) + (call $Goal) + (ask-accept-choice $Answer) + (det-if-then-else + (= $Answer abort) + (, + (set-det) + (fail)) + (, + (= $Answer yes) + (set-det)))) - (= - (ask-accept-choice yes) - ( (parameter confirm-choices off) (set-det))) -; - (= - (ask-accept-choice $Answer) - ( (menu-command "~nAccept this choice? (yes, next, abort, help)~n" accept - (:: $Answer)) (set-det))) -; - - (= - (ask-accept-choice $Answer) - ( (format "~n~p failed to answer appropriately. Please try again!~n" - (:: You)) (ask-accept-choice $Answer))) -; + (= (ask-accept-choice yes) + (parameter confirm-choices off) + (set-det)) + (= (ask-accept-choice $Answer) + (menu-command "~nAccept this choice? (yes, next, abort, help)~n" accept + (:: $Answer)) + (set-det)) + (= (ask-accept-choice $Answer) + (format "~n~p failed to answer appropriately. Please try again!~n" + (:: You)) + (ask-accept-choice $Answer)) ; -; - +; ---------------------------------------- ; -; - +; Accept menu commands ; -; - +; ---------------------------------------- - (= - (yes-accept yes) + (= (yes-accept yes) (format "~nChoice accepted.~n" Nil)) -; - - (= - (y-accept yes) + (= (y-accept yes) (yes-accept yes)) -; - - (= - (next-accept next) + (= (next-accept next) (format "~nTrying next choice.~n" Nil)) -; - - (= - (no-accept next) + (= (no-accept next) (next-accept next)) -; - - (= - (n-accept next) + (= (n-accept next) (next-accept next)) -; - - (= - (abort-accept abort) + (= (abort-accept abort) (format "~nAttempt aborted!~n" Nil)) -; - - (= - (help-accept $Answer) - ( (help-accept) (ask-accept-choice $Answer))) -; - + (= (help-accept $Answer) + (help-accept) + (ask-accept-choice $Answer)) ; -; - +; =============================================================================== ; -; - +; Top level (_com) Menu ; -; - +; =============================================================================== ; -; - +; ---------------------------------------- ; -; - +; Help from move menu ; -; - +; ---------------------------------------- ; -; - +; See file help.pl ; -; - +; ---------------------------------------- ; -; - +; Options from move menu ; -; - +; ---------------------------------------- - (= - (select-com $Move $SIn $SOut) + (= (select-com $Move $SIn $SOut) (select-move $Move $SIn $SOut)) -; - - (= - (display-com $Move $SIn $_) - ( (format "~nCurrent State: ~n" Nil) (print-state $SIn))) -; + (= (display-com $Move $SIn $_) + (format "~nCurrent State: ~n" Nil) + (print-state $SIn)) + (= (restart-com $_ $_ $_) + (format "~nRestarting ...~n" Nil) + (metagame)) - (= - (restart-com $_ $_ $_) - ( (format "~nRestarting ...~n" Nil) (metagame))) -; - - - (= - (quit-com $_ $_ $_) + (= (quit-com $_ $_ $_) (print-quit)) -; - - (= - (prolog-com $_ $_ $_) + (= (prolog-com $_ $_ $_) (print-abort)) -; - - (= - (abort-com $_ $_ $_) + (= (abort-com $_ $_ $_) (print-abort)) -; - - (= - (verbose-com $_ $_ $_) + (= (verbose-com $_ $_ $_) (set-verbose)) -; - - (= - (quiet-com $_ $_ $_) + (= (quiet-com $_ $_ $_) (set-quiet)) -; - - (= - (break-com $_ $_ $_) + (= (break-com $_ $_ $_) (format "~nBreak command not implemented." Nil)) -; - - (= - (set-com $_ $_ $_ $P $V) + (= (set-com $_ $_ $_ $P $V) (set-parameter $P $V)) -; - - (= - (set-com $_ $_ $_) + (= (set-com $_ $_ $_) (show-parameters)) -; - ; -; - +; Setting globals. - (= - (setg-com $_ $_ $_ $P $V) + (= (setg-com $_ $_ $_ $P $V) (add-global $P $V)) -; - - (= - (showg-com $_ $_ $_) + (= (showg-com $_ $_ $_) (showg)) -; - - (= - (randomize-com $_ $_ $_ $N) + (= (randomize-com $_ $_ $_ $N) (randomize $N)) -; - - (= - (pieces-com $_ $_ $_) + (= (pieces-com $_ $_ $_) (show-piece-names)) -; - - (= - (show-piece-names) - ( (player-current-game $Game) - (game-piece-names $Game $Names) - (format "\nThe current game has the following pieces: \n~p\nNote that pieces are displayed on the board by the their first letter. \n" - (:: $Names)))) -; + (= (show-piece-names) + (player-current-game $Game) + (game-piece-names $Game $Names) + (format "\nThe current game has the following pieces: \n~p\nNote that pieces are displayed on the board by the their first letter. \n" + (:: $Names))) - - (= - (game-piece-names $Game $Names) + (= (game-piece-names $Game $Names) (setof $Name (game-piece-name $Game $Name) $Names)) -; - - (= - (define-com $_ $_ $_ $PieceName) + (= (define-com $_ $_ $_ $PieceName) (show-piece-definition $PieceName)) -; - - (= - (show-piece-definition $PieceName) - ( (player-current-game $G) - (game-piece-def $G $PieceName $Def) - (set-det) - (set-printing-mode) - (piece-def $Def $String Nil) - (set-parsing-mode) - (format "~nPiece <~p> is defined as follows: ~n~n" - (:: $PieceName)) - (print-tokens $String) - (nl) - (nl))) -; - - (= - (show-piece-definition $PieceName) + (= (show-piece-definition $PieceName) + (player-current-game $G) + (game-piece-def $G $PieceName $Def) + (set-det) + (set-printing-mode) + (piece-def $Def $String Nil) + (set-parsing-mode) + (format "~nPiece <~p> is defined as follows: ~n~n" + (:: $PieceName)) + (print-tokens $String) + (nl) + (nl)) + (= (show-piece-definition $PieceName) (format "~nSorry, Piece <~p> is not defined in this game.~n~n" (:: $PieceName))) -; - - (= - (rules-com $_ $_ $_) + (= (rules-com $_ $_ $_) (show-rules)) -; - - (= - (board-com $_ $_ $_) + (= (board-com $_ $_ $_) (show-board)) -; - - (= - (goals-com $_ $_ $_) + (= (goals-com $_ $_ $_) (show-game-goals)) -; - - (= - (cd-com $_ $_ $_ $Dir) + (= (cd-com $_ $_ $_ $Dir) (cd-print $Dir)) -; - - (= - (pwd-com $_ $_ $_) + (= (pwd-com $_ $_ $_) (pwd-print)) -; - - (= - (ls-com $_ $_ $_) + (= (ls-com $_ $_ $_) (ls)) -; - ; -; - +; ----------------------------------------------------------- ; -; - +; Accessing state from the interface ; -; - +; ----------------------------------------------------------- ; -; - - - (= - (access-com $Move $SIn $SOut) - ( (format "\nEnter a goal of the form:\n\tSIn^SOut^goal(...,SIn,...,SOut).\nCalling this goal will bind the current state to SOut,\nand return you to the move selection menu.\nTo accept the current state as your move, use the command: accept.\n\n" Nil) - (read (^ $SIn (^ $SOut $Goal))) - (call $Goal))) -; +; ACCESS + (= (access-com $Move $SIn $SOut) + (format "\nEnter a goal of the form:\n\tSIn^SOut^goal(...,SIn,...,SOut).\nCalling this goal will bind the current state to SOut,\nand return you to the move selection menu.\nTo accept the current state as your move, use the command: accept.\n\n" Nil) + (read (^ $SIn (^ $SOut $Goal))) + (call $Goal)) ; -; - +; CALL ; -; +; Could be merged with ACCESS. - - (= - (call-com $_ $SIn $SOut) - ( (get-state-goal $Goal) (call-state-goal $Goal $SIn $SOut))) -; + (= (call-com $_ $SIn $SOut) + (get-state-goal $Goal) + (call-state-goal $Goal $SIn $SOut)) + (= (get-state-goal $Goal) + (format "\nEntering a goal of the form:\n\tgoal(a,b,...)\nWill result in the following 'statified' goal being called:\n\tgoal(a,b,...,SIn,SOut)\nIf successful, this goal will bind the current state to SOut,\nand return you to the move selection menu.\nTo accept the current state as your move, use the command: accept.\n\n" Nil) + (read $Goal)) - (= - (get-state-goal $Goal) - ( (format "\nEntering a goal of the form:\n\tgoal(a,b,...)\nWill result in the following 'statified' goal being called:\n\tgoal(a,b,...,SIn,SOut)\nIf successful, this goal will bind the current state to SOut,\nand return you to the move selection menu.\nTo accept the current state as your move, use the command: accept.\n\n" Nil) (read $Goal))) -; - - - - (= - (call-state-goal $Goal $SIn $SOut) - ( (=.. $Goal - (Cons $H $Args)) - (append $Args - (:: $SIn $SOut) $NewArgs) - (=.. $SGoal - (Cons $H $NewArgs)) - (det-if-then-else - (current-predicate $_ $SGoal) - (call $SGoal) - (, - (format "*** Unknown_goal: ~w~n" - (:: $SGoal)) - (fail))))) -; + (= (call-state-goal $Goal $SIn $SOut) + (=.. $Goal + (Cons $H $Args)) + (append $Args + (:: $SIn $SOut) $NewArgs) + (=.. $SGoal + (Cons $H $NewArgs)) + (det-if-then-else + (current-predicate $_ $SGoal) + (call $SGoal) + (, + (format "*** Unknown_goal: ~w~n" + (:: $SGoal)) + (fail)))) ; -; - +; RESTORE ; -; - +; Set current state to be a previously named checkpoint state. - (= - (restore-com $_ $SIn $SOut $Name) + (= (restore-com $_ $SIn $SOut $Name) (restore-state $Name $SOut)) -; - ; -; - +; ACCEPT - (= - (accept-com accept $SIn $SIn) + (= (accept-com accept $SIn $SIn) (format "Current state accepted as chosen move.~n" Nil)) -; - ; -; +; CHECKPOINT - - (= - (checkpoint-com $_ $SIn $_) + (= (checkpoint-com $_ $SIn $_) (checkpoint-state $SIn)) -; - ; -; - - (= - (checkpoint-com $_ $SIn $_ $Name) +; CHECKPOINT + (= (checkpoint-com $_ $SIn $_ $Name) (checkpoint-state $Name $SIn)) -; - ; -; - +; ----------------------------------------------------------------- ; -; - +; Queries ; -; - +; ----------------------------------------------------------------- ; -; - +; query goal (Player), ; -; - +; Check if a goal has been achieved (ie the game is over here) ; -; - +; query mobility (Player) ; -; - +; Counts mobility for both (or just Player) ; -; - +; query material (Player) ; -; - +; Counts material for both (or just Player) - (= - (query-com $_ $SIn $_ goal) + (= (query-com $_ $SIn $_ goal) (query-goal $SIn)) -; - - (= - (query-com $_ $SIn $_ material) + (= (query-com $_ $SIn $_ material) (query-material $SIn)) -; - - (= - (query-com $_ $SIn $_ mobility) + (= (query-com $_ $SIn $_ mobility) (query-mobility $SIn)) -; - - (= - (query-com $_ $SIn $_ goal $Player) + (= (query-com $_ $SIn $_ goal $Player) (query-goal $SIn $Player)) -; - - (= - (query-com $_ $SIn $_ material $Player) + (= (query-com $_ $SIn $_ material $Player) (query-material $SIn $Player)) -; - - (= - (query-com $_ $SIn $_ mobility $Player) + (= (query-com $_ $SIn $_ mobility $Player) (query-mobility $SIn $Player)) -; + (= (query-goal $SIn) + (format "Checking goals ...~n" Nil) + (det-if-then-else + (timing (game-outcome $O $SIn)) + (format "Outcome is ~p~n" + (:: $O)) + (format "Game is not over yet.~n" Nil))) - (= - (query-goal $SIn) - ( (format "Checking goals ...~n" Nil) (det-if-then-else (timing (game-outcome $O $SIn)) (format "Outcome is ~p~n" (:: $O)) (format "Game is not over yet.~n" Nil)))) -; - - - - (= - (query-goal $SIn $Player) - ( (format "Checking goals for <~p> ...~n" - (:: $Player)) (det-if-then-else (timing (goal-achieved $Player $SIn)) (format "<~p> has achieved a goal!~n" (:: $Player)) (format "<~p> has not achieved a goal.~n" (:: $Player))))) -; + (= (query-goal $SIn $Player) + (format "Checking goals for <~p> ...~n" + (:: $Player)) + (det-if-then-else + (timing (goal-achieved $Player $SIn)) + (format "<~p> has achieved a goal!~n" + (:: $Player)) + (format "<~p> has not achieved a goal.~n" + (:: $Player)))) ; -; +; Dummy. - - (= - (goal-achieved $P $S) + (= (goal-achieved $P $S) (goal-achieved $P $_ $S $_)) -; - - (= - (query-goal-slow-com $_ $SIn $_) + (= (query-goal-slow-com $_ $SIn $_) (query-goal-slow $SIn)) -; - - - (= - (query-goal-slow $SIn) - ( (format "Checking goals ...~n" Nil) (det-if-then-else (timing (game-outcome player $SIn)) (format "<~p> has achieved a goal!~n" (:: player)) (format "Player has not won yet.~n" Nil)))) -; - - - - - (= - (query-material $SIn) - ( (query-material $SIn player) (query-material $SIn opponent))) -; + (= (query-goal-slow $SIn) + (format "Checking goals ...~n" Nil) + (det-if-then-else + (timing (game-outcome player $SIn)) + (format "<~p> has achieved a goal!~n" + (:: player)) + (format "Player has not won yet.~n" Nil))) - (= - (query-material $S $Player) - ( (format "Counting material for <~p> ...~n" - (:: $Player)) - (timing (material $Player $S $Mat)) - (format "<~p> has material count of ~p~n" - (:: $Player $Mat)))) -; + (= (query-material $SIn) + (query-material $SIn player) + (query-material $SIn opponent)) + (= (query-material $S $Player) + (format "Counting material for <~p> ...~n" + (:: $Player)) + (timing (material $Player $S $Mat)) + (format "<~p> has material count of ~p~n" + (:: $Player $Mat))) - (= - (query-mobility $SIn) - ( (query-mobility $SIn player) (query-mobility $SIn opponent))) -; - (= - (query-mobility $S $Player) - ( (format "Counting mobility for <~p> ...~n" - (:: $Player)) - (timing (mobility $Player $S $Mat)) - (format "<~p> has mobility count of ~p~n" - (:: $Player $Mat)))) -; + (= (query-mobility $SIn) + (query-mobility $SIn player) + (query-mobility $SIn opponent)) + (= (query-mobility $S $Player) + (format "Counting mobility for <~p> ...~n" + (:: $Player)) + (timing (mobility $Player $S $Mat)) + (format "<~p> has mobility count of ~p~n" + (:: $Player $Mat))) ; -; - +; ----------------------------------------------------------------- ; -; - +; Tracing ; -; - +; ----------------------------------------------------------------- - (= - (trace-com $_ $_ $_ $Module) + (= (trace-com $_ $_ $_ $Module) (set-tracing $Module on)) -; - - (= - (trace-com $_ $_ $_ $Module $Component) + (= (trace-com $_ $_ $_ $Module $Component) (set-tracing $Module $Component on)) -; - - (= - (untrace-com $_ $_ $_ $Module) + (= (untrace-com $_ $_ $_ $Module) (set-tracing $Module off)) -; - - (= - (untrace-com $_ $_ $_ $Module $Component) + (= (untrace-com $_ $_ $_ $Module $Component) (set-tracing $Module $Component off)) -; - - (= - (list-tracing-com $_ $_ $_) + (= (list-tracing-com $_ $_ $_) (list-tracing)) -; - - (= - (list-tracing) - ( (traced-modules $M) (format "The following modules are being traced: ~n~p~n" (:: $M)))) -; - + (= (list-tracing) + (traced-modules $M) + (format "The following modules are being traced: ~n~p~n" + (:: $M))) ; -; - +; ---------------------------------------- ; -; - +; Special Move selection methods (Advisors) ; -; - +; ---------------------------------------- ; -; - +; The individual move methods are defined in file advisors.pl - (= - (pass-com pass $SIn $SOut) + (= (pass-com pass $SIn $SOut) (pass-move $SIn $SOut)) -; - - (= - (random-com $Move $SIn $SOut) + (= (random-com $Move $SIn $SOut) (printing-choose random-move $Move $SIn $SOut)) -; - - (= - (random1-com $Move $SIn $SOut) + (= (random1-com $Move $SIn $SOut) (random-printing-choose legal $Move $SIn $SOut)) -; - - (= - (instant-com $Move $SIn $SOut) + (= (instant-com $Move $SIn $SOut) (printing-choose instant-move $Move $SIn $SOut)) -; - - (= - (victor-com $Move $SIn $SOut) + (= (victor-com $Move $SIn $SOut) (printing-choose victor-move $Move $SIn $SOut)) -; - - (= - (endgame-com $Move $SIn $SOut) - ( (timing (endgame-move $Move $SIn $SOut)) (select-move $Move $SIn $SOut))) -; - + (= (endgame-com $Move $SIn $SOut) + (timing (endgame-move $Move $SIn $SOut)) + (select-move $Move $SIn $SOut)) - (= - (cautious-com $Move $SIn $SOut) + (= (cautious-com $Move $SIn $SOut) (printing-choose cautious-move $Move $SIn $SOut)) -; - - (= - (random-aggressive-com $Move $SIn $SOut) + (= (random-aggressive-com $Move $SIn $SOut) (printing-choose random-aggressive-move $Move $SIn $SOut)) -; - - - - - (= - (mate-com $Move $SIn $SOut) - ( (timing (mate-move $Move $SIn $SOut)) (select-move $Move $SIn $SOut))) -; - (= - (threaten-com $Move $SIn $SOut) - ( (timing (threaten-move $Move $SIn $SOut)) (select-move $Move $SIn $SOut))) -; + (= (mate-com $Move $SIn $SOut) + (timing (mate-move $Move $SIn $SOut)) + (select-move $Move $SIn $SOut)) + (= (threaten-com $Move $SIn $SOut) + (timing (threaten-move $Move $SIn $SOut)) + (select-move $Move $SIn $SOut)) - (= - (enough-rope-com $Move $SIn $SOut) - ( (timing (enough-rope-move $Move $SIn $SOut)) (select-move $Move $SIn $SOut))) -; + (= (enough-rope-com $Move $SIn $SOut) + (timing (enough-rope-move $Move $SIn $SOut)) + (select-move $Move $SIn $SOut)) - (= - (help-clock) + (= (help-clock) (format "\n============================================================================\nGame Clock Routines\n-------------------\nclock adjust : increments time player has used this game\nclock reset: resets time used by each player to 0.\nclock print: prints time used and remaining for each player.\nclock unlimit: disables the clock by giving both players unlimited time.\n\nclock: short form for clock print. \n\nExample:\n clock adjust white 2000. : adds 2 secs to time white used.\n clock adjust black '-2500'. : subtracts 2.5 secs from time black used.\n============================================================================\n" Nil)) -; + (= (clock-com $_ $_ $_ adjust $Color $Time) + (player-color $Player $Color) + (adjust-player-clock $Player $Time)) - (= - (clock-com $_ $_ $_ adjust $Color $Time) - ( (player-color $Player $Color) (adjust-player-clock $Player $Time))) -; - - - (= - (clock-com $_ $_ $_) + (= (clock-com $_ $_ $_) (print-clock)) -; - - (= - (clock-com $_ $_ $_ print) + (= (clock-com $_ $_ $_ print) (print-clock)) -; - - (= - (clock-com $_ $_ $_ reset) + (= (clock-com $_ $_ $_ reset) (reset-clock)) -; - - (= - (clock-com $_ $_ $_ unlimit) + (= (clock-com $_ $_ $_ unlimit) (clock-unlimit)) -; - ; -; - +; ================================================================================ ; -; - +; TRACING execution of analysis routines ; -; - +; ================================================================================ ; -; - +; This main tracing module is called: play. ; -; - +; The following tracing modules are used in this file: ; -; - +; state: print state as moves are chosen by players. ; -; - +; move: print move as moves are chosen by players. ; -; - +; clock: print the clock as moves are played. ; -; - +; Each module can be set on/off, using set_play_verbosity (see below), or ; -; - +; using trace_play_. ; ; - ; -; - +; All can be turned off with silent_play. !(my-ensure-loaded (library tracing)) -; - - (= - (tracing-play $Type $Call) + (= (tracing-play $Type $Call) (det-if-then-else (tracing (play $Type)) (call $Call) True)) -; - ; -; +; Might cause trouble later when want to use streams also. - - (= - (tracing-play-format $Type $String $Args) + (= (tracing-play-format $Type $String $Args) (det-if-then-else (tracing (play $Type)) (format $String $Args) True)) -; - - (= - (tracing-play-timing $Type $Call) + (= (tracing-play-timing $Type $Call) (trace-timing (play $Type) $Call)) -; - - (= - (set-play-verbosity $Level $Status) + (= (set-play-verbosity $Level $Status) (set-tracing (play $Level) $Status)) -; - - (= - (silent-play) + (= (silent-play) (all-play off)) -; - - (= - (loud-play) + (= (loud-play) (all-play on)) -; - - (= - (all-play $Status) - ( (set-play-verbosity state $Status) - (set-play-verbosity move $Status) - (set-play-verbosity clock $Status))) -; - + (= (all-play $Status) + (set-play-verbosity state $Status) + (set-play-verbosity move $Status) + (set-play-verbosity clock $Status)) - (= - (trace-play-state) - (set-play-verbosity state on)) -; - + (= (trace-play-state) + (set-play-verbosity state on)) - (= - (trace-play-move) - (set-play-verbosity move on)) -; - + (= (trace-play-move) + (set-play-verbosity move on)) - (= - (trace-play-clock) - (set-play-verbosity clock on)) -; - + (= (trace-play-clock) + (set-play-verbosity clock on)) !(loud-play *) -; - ; -; - +; :- silent_play. diff --git a/metagame/play/local.metta b/metagame/play/local.metta index fad9e8b..a0dc450 100644 --- a/metagame/play/local.metta +++ b/metagame/play/local.metta @@ -1,286 +1,202 @@ +; (convert_to_metta_file local $_435814 metagame/play/local.pl metagame/play/local.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; local.pl ; -; - +; ;; Control hooks for using the console to play two humans or programs against ; -; - +; ;; each other locally (i.e. without using internet communication). ; -; - +; ;; ; -; - +; ;; This file contains the parts of the interface which are specific to this ; -; - +; ;; mode of play only. Thus, for a local match, we find the players and the game ; -; - +; ;; by querying the user, whereas in a remote match, each player receives this ; -; - +; ;; info from the referee, and the referee sends it. ; -; - +; ======================================== ; -; - +; GET_PLAYERS(White,Black) ; -; - +; ======================================== ; -; - +; If already have a game to play, use it. ; -; - - +; Else query user. - (= - (get-players $White $Black) - ( (get-player-color player $White) - (get-player-color opponent $Black) - (query-accept-players $White $Black) - (set-det))) -; - - (= - (get-players $_ $_) - ( (format "\nPlease use 'player' to select the players.\n'help player' gives more info, and a list of available players.\n" Nil) (fail))) -; + (= (get-players $White $Black) + (get-player-color player $White) + (get-player-color opponent $Black) + (query-accept-players $White $Black) + (set-det)) + (= (get-players $_ $_) + (format "\nPlease use 'player' to select the players.\n'help player' gives more info, and a list of available players.\n" Nil) + (fail)) - (= - (get-player-color $Color $Player) - ( (player-method-parameter $Color $Param) (parameter $Param $Player))) -; + (= (get-player-color $Color $Player) + (player-method-parameter $Color $Param) + (parameter $Param $Player)) - - (= - (query-accept-players $White $Black) - ( (human-mode) - (set-det) - (format "\n~p as ~p vs. ~p as ~p?\n(y to accept, n to select new players): " - (:: $White player $Black opponent)) - (read $Answer) - (= $Answer y))) -; - - (= - (query-accept-players $White $Black) + (= (query-accept-players $White $Black) + (human-mode) + (set-det) + (format "\n~p as ~p vs. ~p as ~p?\n(y to accept, n to select new players): " + (:: $White player $Black opponent)) + (read $Answer) + (= $Answer y)) + (= (query-accept-players $White $Black) (format "Playing ~p as ~p vs. ~p as ~p?" (:: $White player $Black opponent))) -; - ; -; - +; ======================================== ; -; - +; GET_CURRENT_GAME ; -; - +; ======================================== ; -; - +; Provides external hook, storing the internal representation ; -; - +; of the current game (after choosing it) ; -; - +; in the predicates: ; -; - +; player_current_game/1 ; -; - +; opponent_current_game/1 ; -; - +; If already have a game to play, use it. ; -; - - - (= - (get-current-game) - ( (player-current-game $Game) - (query-use-current-game $Game) - (set-det))) -; - - (= - (get-current-game) - ( (format "\nPlease use 'game' to select a game.\n'games_library' will show you a list of available games.\n'generate will generate a new game as .game.\n" Nil) (fail))) -; +; Else query user. + (= (get-current-game) + (player-current-game $Game) + (query-use-current-game $Game) + (set-det)) + (= (get-current-game) + (format "\nPlease use 'game' to select a game.\n'games_library' will show you a list of available games.\n'generate will generate a new game as .game.\n" Nil) + (fail)) ; -; - - - (= - (query-use-current-game $Game) - ( (human-mode) - (set-det) - (game-name $Game $Name) - (format "~nPlay game ~w? (y to play, n to choose another): " - (:: $Name)) - (read $Answer) - (= $Answer y))) -; - - (= - (query-use-current-game $Game) - ( (game-name $Game $Name) (format "~nPlaying game ~w" (:: $Name)))) -; +; File saved as [path/]GameName.game + (= (query-use-current-game $Game) + (human-mode) + (set-det) + (game-name $Game $Name) + (format "~nPlay game ~w? (y to play, n to choose another): " + (:: $Name)) + (read $Answer) + (= $Answer y)) + (= (query-use-current-game $Game) + (game-name $Game $Name) + (format "~nPlaying game ~w" + (:: $Name))) ; -; - +; ======================================== ; -; - +; GET_RANDOM_ASSIGNMENT(Assignments) ; -; - +; ======================================== ; -; - +; By default, generates a random assignment. ; -; +; If assignment_method(ask), then queries user. - - (= - (get-random-assignment $Assignment) - ( (game-assignments $Game $As) - (assignment-decision $As random $PieceNames $Squares) - (produce-assignment $PieceNames $Squares $Assignment))) -; + (= (get-random-assignment $Assignment) + (game-assignments $Game $As) + (assignment-decision $As random $PieceNames $Squares) + (produce-assignment $PieceNames $Squares $Assignment)) - - (= - (produce-assignment $PieceNames $Squares $Assignment) - ( (parameter assignment-method ask) - (set-det) - (ask-random-assignment $PieceNames $Squares $Assignment))) -; - - (= - (produce-assignment $PieceNames $Squares $Assignment) + (= (produce-assignment $PieceNames $Squares $Assignment) + (parameter assignment-method ask) + (set-det) + (ask-random-assignment $PieceNames $Squares $Assignment)) + (= (produce-assignment $PieceNames $Squares $Assignment) (generate-random-assignment $PieceNames $Squares $Assignment)) -; - - (= - (generate-random-assignment $PieceNames $Squares $Assignment) - ( (format "~nGenerating Random Assignment~n" Nil) (assign-pieces-to-squares $PieceNames $Squares $Assignment))) -; - ; -; - + (= (generate-random-assignment $PieceNames $Squares $Assignment) + (format "~nGenerating Random Assignment~n" Nil) + (assign-pieces-to-squares $PieceNames $Squares $Assignment)) ; +; defined in generator ; -; - +; The ['.'|Rest] is because the assignment_defs doesn't end in a period, ; -; - +; while the end of string requires it. ; ; + (= (ask-random-assignment $PieceNames $Squares $Assignment) + (format "~nPlease assign ~w to ~w~nExample syntax: piece1 at {(1,1)} piece2 at {(2,2) (3,3)}.~n(C-d on new line to end)~n|: " + (:: $PieceNames $Squares)) + (read-tokens $AssignmentString) + (nl) + (set-parsing-mode) + (assignments $Assignment $AssignmentString + (Cons . $Rest))) - (= - (ask-random-assignment $PieceNames $Squares $Assignment) - ( (format "~nPlease assign ~w to ~w~nExample syntax: piece1 at {(1,1)} piece2 at {(2,2) (3,3)}.~n(C-d on new line to end)~n|: " - (:: $PieceNames $Squares)) - (read-tokens $AssignmentString) - (nl) - (set-parsing-mode) - (assignments $Assignment $AssignmentString - (Cons . $Rest)))) -; - + (= (ask-random-assignment $PieceNames $Squares $Assignment) + (format "~nPlease assign ~w to ~w~n('.' for help)~n|: " + (:: $PieceNames $Squares)) + (read-keyboard-tokens $AssignmentString) + (help-or-process-assign $AssignmentString $PieceNames $Squares $Assignment)) - (= - (ask-random-assignment $PieceNames $Squares $Assignment) - ( (format "~nPlease assign ~w to ~w~n('.' for help)~n|: " - (:: $PieceNames $Squares)) - (read-keyboard-tokens $AssignmentString) - (help-or-process-assign $AssignmentString $PieceNames $Squares $Assignment))) -; + (= (help-or-process-assign (:: .) $PieceNames $Squares $Assignment) + (format "~nExample syntax:~npiece1 at {(1,1)} piece2 at {(2,2) (3,3)}.~n" Nil) + (ask-random-assignment $PieceNames $Squares $Assignment)) - - (= - (help-or-process-assign - (:: .) $PieceNames $Squares $Assignment) - ( (format "~nExample syntax:~npiece1 at {(1,1)} piece2 at {(2,2) (3,3)}.~n" Nil) (ask-random-assignment $PieceNames $Squares $Assignment))) -; - - - (= - (help-or-process-assign $AssignmentString $_ $_ $Assignment) - ( (nl) - (set-parsing-mode) - (assignments $Assignment $AssignmentString - (Cons . $Rest)))) -; - + (= (help-or-process-assign $AssignmentString $_ $_ $Assignment) + (nl) + (set-parsing-mode) + (assignments $Assignment $AssignmentString + (Cons . $Rest))) - (= - (choose $Name $Role $Move $SIn $SOut) - ( (concat $Name -choose $NameChoose) - (=.. $Goal - (:: $NameChoose $Role $Move $SIn $SOut)) - (call $Goal))) -; - - + (= (choose $Name $Role $Move $SIn $SOut) + (concat $Name -choose $NameChoose) + (=.. $Goal + (:: $NameChoose $Role $Move $SIn $SOut)) + (call $Goal)) +; /* ;================================================================================ ; TERMINATE_GAME(SIn) ;================================================================================ ; Saves final state for debugging purposes. ; May not want to print checkpoint info every time. terminate_game(SIn) :- ask_ynp('Would you like to play another game',Answer), !, play_again_if(Answer). play_again_if(y) :- !, metagame. play_again_if(_). */ +; ;================================================================================ ; Move Selection methods ;================================================================================ +; ; CHOOSE(Chooser,Role,Move,SIn,SOut) ; CHOOSER is an atom. ; Calls the procedure CHOOSER_choose(Role,Move,SIn,SOut). ; ; Currently define choice methods are: ; HUMAN ; INSTANT ; RANDOM ; THREATEN ; CAUTIOUS ; QUICK_CAUTIOUS ; VARIABLE ; SMARTER ; RANDOM_AGGRESSIVE - (= - (variable-choose $Role $Move $SIn $SOut) - ( (player-method-parameter $Role $Param) - (parameter $Param $Chooser) - (choose $Chooser $Role $Move $SIn $SOut))) -; + (= (variable-choose $Role $Move $SIn $SOut) + (player-method-parameter $Role $Param) + (parameter $Param $Chooser) + (choose $Chooser $Role $Move $SIn $SOut)) diff --git a/metagame/play/mobility.metta b/metagame/play/mobility.metta index 5a25ca5..9c41383 100644 --- a/metagame/play/mobility.metta +++ b/metagame/play/mobility.metta @@ -1,460 +1,310 @@ +; (convert_to_metta_file mobility $_50336 metagame/play/mobility.pl metagame/play/mobility.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; mobility.pl ; -; - +; ;; Defines a basic evaluation used by some players ; -; - +; ;; (like alpha_beta or evaluating player). ; -; - +; ;; Features are mobility and material (piece_count). ; -; - +; ======================================== ; -; - +; EVALUATING_CHOOSE(Player,Move,SIn,SOut) ; -; - +; ======================================== ; -; - +; Wins immediately if possible, else plays a random move ; -; - +; among those with highest value. ; -; - +; Note doesn't search any more, so this might leave it ; -; - +; open for a loss. Also semantics not clear if this move ; -; - +; ends the game for either player. - (= - (evaluating-choose $Player $Move $SIn $SOut) - ( (timing (evaluating-move $Move $SIn $SOut)) - (set-det) - (print-choice $Move $SIn $SOut))) -; + (= (evaluating-choose $Player $Move $SIn $SOut) + (timing (evaluating-move $Move $SIn $SOut)) + (set-det) + (print-choice $Move $SIn $SOut)) - - (= - (evaluating-move $Move $SIn $SOut) - ( (victor-move $Move $SIn $SOut) (set-det))) -; - - (= - (evaluating-move $Move $SIn $SOut) + (= (evaluating-move $Move $SIn $SOut) + (victor-move $Move $SIn $SOut) + (set-det)) + (= (evaluating-move $Move $SIn $SOut) (max-value-move $Move $SIn $SOut)) -; - ; -; - +; Evaluates position relative to player who is to move. ; -; - +; First choices have lower value, therefore WORSE for player to ; -; - +; move. ; -; - +; Thus, a player evaluating all possible successors will choose the ; -; - - +; lowest valued one, as this is the worst one for his opponent. - (= - (evaluated-move $Move $Val $SIn) - ( (legal $Move $SIn $S1) (evaluate $S1 $Val))) -; + (= (evaluated-move $Move $Val $SIn) + (legal $Move $SIn $S1) + (evaluate $S1 $Val)) - (= - (max-value-move $Move $SIn $SOut) - ( (setof - (- $Val $Move) - (evaluated-move $Move $Val $SIn) $Pairs) - (random-best - (- $Val $Move) $Pairs) - (format "The best move found has a value of: ~p~n" - (:: $Val)) - (legal $Move $SIn $SOut))) -; - + (= (max-value-move $Move $SIn $SOut) + (setof + (- $Val $Move) + (evaluated-move $Move $Val $SIn) $Pairs) + (random-best + (- $Val $Move) $Pairs) + (format "The best move found has a value of: ~p~n" + (:: $Val)) + (legal $Move $SIn $SOut)) - (= - (random-best $Best $L) - ( (collect-init $L $BestFew) (random-element $BestFew $Best))) -; - + (= (random-best $Best $L) + (collect-init $L $BestFew) + (random-element $BestFew $Best)) - (= - (collect-init - (Cons - (- $V $M) $Rest) - (Cons - (- $V $M) $BestFew)) + (= (collect-init (Cons (- $V $M) $Rest) (Cons (- $V $M) $BestFew)) (collect-init $Rest $V $BestFew)) -; - - - (= - (collect_init () $V1 ()) True) -; - - (= - (collect-init - (Cons - (- $V2 $_) $_) $V1 Nil) - ( (< $V1 $V2) (set-det))) -; - (= - (collect-init - (Cons $Pair $Rest) $Threshold - (Cons $Pair $R1)) + (= (collect_init () $V1 ()) True) + (= (collect-init (Cons (- $V2 $_) $_) $V1 Nil) + (< $V1 $V2) + (set-det)) + (= (collect-init (Cons $Pair $Rest) $Threshold (Cons $Pair $R1)) (collect-init $Rest $Threshold $R1)) -; - - - - - (= - (evaluate-com $Move $SIn $_) - ( (timing (evaluate $SIn $Value)) (format "Position's value for player to move: ~p~n" (:: $Value)))) -; + (= (evaluate-com $Move $SIn $_) + (timing (evaluate $SIn $Value)) + (format "Position's value for player to move: ~p~n" + (:: $Value))) - (= - (evaluate $S $Value) - ( (control $P $S) - (opposite-role $O $P) - (evaluate $P $S $PVal) - (evaluate $O $S $OVal) - (is $Value - (- $PVal $OVal)))) -; + (= (evaluate $S $Value) + (control $P $S) + (opposite-role $O $P) + (evaluate $P $S $PVal) + (evaluate $O $S $OVal) + (is $Value + (- $PVal $OVal))) - (= - (evaluate $Player $S $Value) - ( (weight-vector $Weights) - (material-weight $Weights $MatW) - (mobility-weight $Weights $MobW) - (weighted-mobility $MobW $Player $S $WMob) - (weighted-material $MatW $Player $S $WMat) - (is $Value - (+ $WMob $WMat)))) -; + (= (evaluate $Player $S $Value) + (weight-vector $Weights) + (material-weight $Weights $MatW) + (mobility-weight $Weights $MobW) + (weighted-mobility $MobW $Player $S $WMob) + (weighted-material $MatW $Player $S $WMat) + (is $Value + (+ $WMob $WMat))) +; /* evaluate(Player,S,Value) :- weight_vector(Weights), material_weight(Weights,WMat), mobility_weight(Weights,WMob), mobility(Player,S,Mob), material(Player,S,Mat), Value is Mob*WMob + Mat*WMat. */ - (= - (weighted-mobility 0 $_ $_ 0) + (= (weighted-mobility 0 $_ $_ 0) (set-det)) -; + (= (weighted-mobility $MobW $Player $S $WMob) + (mobility $Player $S $Mob) + (is $WMob + (* $MobW $Mob))) - (= - (weighted-mobility $MobW $Player $S $WMob) - ( (mobility $Player $S $Mob) (is $WMob (* $MobW $Mob)))) -; - - - (= - (weighted-material 0 $_ $_ 0) + (= (weighted-material 0 $_ $_ 0) (set-det)) -; - - (= - (weighted-material $MatW $Player $S $WMat) - ( (material $Player $S $Mat) (is $WMat (* $MatW $Mat)))) -; - - + (= (weighted-material $MatW $Player $S $WMat) + (material $Player $S $Mat) + (is $WMat + (* $MatW $Mat))) - (= - (mobility $Player $S $M) - ( (put-control $Player $S $S1) (count-bagof $Move (^ $S2 (legal-move $Move $Player $S1 $S2)) $M))) -; + (= (mobility $Player $S $M) + (put-control $Player $S $S1) + (count-bagof $Move + (^ $S2 + (legal-move $Move $Player $S1 $S2)) $M)) - (= - (material $Player $S $M) + (= (material $Player $S $M) (count-bagof $Piece (^ $Sq (on (piece $Piece $Player) $Sq $S)) $M)) -; - ; -; - +; EVALUATE2 ; -; - +; Only considers opponent's mobility, and player's material, ; -; - - - (= - (evaluate2 $S $Value) - ( (control $P $S) - (opposite-role $O $P) - (evaluate2 $P $O $S $Value))) -; +; in a future position. Not very good, or even that much faster. + (= (evaluate2 $S $Value) + (control $P $S) + (opposite-role $O $P) + (evaluate2 $P $O $S $Value)) - (= - (evaluate2 $Player $Opponent $S $Value) - ( (mobility $Opponent $S $Mob) - (material $Player $S $Mat) - (weight material $WMat) - (weight mobility $WMob) - (is $Value - (- - (* $Mat $WMat) - (* $Mob $WMob))))) -; - + (= (evaluate2 $Player $Opponent $S $Value) + (mobility $Opponent $S $Mob) + (material $Player $S $Mat) + (weight material $WMat) + (weight mobility $WMob) + (is $Value + (- + (* $Mat $WMat) + (* $Mob $WMob)))) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Manipulating weights ; -; - - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (toggle-alpha-beta-weights $Player $Old) - ( (weight-vector $Player $Weights) (change-parameter weights $Old $Weights))) -; + (= (toggle-alpha-beta-weights $Player $Old) + (weight-vector $Player $Weights) + (change-parameter weights $Old $Weights)) - (= - (weight-vector $Player $Weights) + (= (weight-vector $Player $Weights) (parameter (weights $Player) $Weights)) -; - - (= - (weight-vector $Weights) + (= (weight-vector $Weights) (parameter weights $Weights)) -; - - - (= - (initialize-weights) - ( (default-alpha-weights $W) (add-parameter weights $W))) -; + (= (initialize-weights) + (default-alpha-weights $W) + (add-parameter weights $W)) - (= - (default-alpha-weights (weights $Mat $Mob)) - ( (default-weight material $Mat) (default-weight mobility $Mob))) -; - + (= (default-alpha-weights (weights $Mat $Mob)) + (default-weight material $Mat) + (default-weight mobility $Mob)) ; -; - - - (= - (default_weight material 4) True) -; - - (= - (default_weight mobility 1) True) -; +; General function, preferring mobility and material. + (= (default_weight material 4) True) + (= (default_weight mobility 1) True) ; -; - +; Anti-material function, perferring mobility but not material. ; -; - +; default_weight(material,-10). ; -; - +; default_weight(mobility,1). ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Interface ; -; - - - - (= - (material_weight - (weights $Mat $Mob) $Mat) True) -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (mobility_weight - (weights $Mat $Mob) $Mob) True) -; + (= (material_weight (weights $Mat $Mob) $Mat) True) + (= (mobility_weight (weights $Mat $Mob) $Mob) True) - (= - (set-player-weights $Player $Mat $Mob) - ( (material-weight $W $Mat) - (mobility-weight $W $Mob) - (det-if-then-else - (= $Player default) - (add-parameter weights $W) - (add-parameter - (weights $Player) $W)))) -; + (= (set-player-weights $Player $Mat $Mob) + (material-weight $W $Mat) + (mobility-weight $W $Mob) + (det-if-then-else + (= $Player default) + (add-parameter weights $W) + (add-parameter + (weights $Player) $W))) + (= (show-player-weights) + (show-player-weights player) + (show-player-weights opponent)) - (= - (show-player-weights) - ( (show-player-weights player) (show-player-weights opponent))) -; - - - (= - (show-player-weights $Player) - ( (det-if-then-else - (weight-vector $Player $W) - (= $Default '') - (, - (weight-vector $W) - (= $Default '(by default)'))) - (material-weight $W $Mat) - (mobility-weight $W $Mob) - (format "\n<~p>'s weights are ~w:\n material: ~p\n mobility: ~p\n" - (:: $Player $Default $Mat $Mob)))) -; - + (= (show-player-weights $Player) + (det-if-then-else + (weight-vector $Player $W) + (= $Default '') + (, + (weight-vector $W) + (= $Default '(by default)'))) + (material-weight $W $Mat) + (mobility-weight $W $Mob) + (format "\n<~p>'s weights are ~w:\n material: ~p\n mobility: ~p\n" + (:: $Player $Default $Mat $Mob))) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Menus ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; WEIGHT: Allows command: "weight {player, opponent, default} Mat Mob" - (= - (weight-com $_ $_ $_ $Player $Mat $Mob) + (= (weight-com $_ $_ $_ $Player $Mat $Mob) (set-player-weights $Player $Mat $Mob)) -; - - (= - (weight-top $Player $Mat $Mob) + (= (weight-top $Player $Mat $Mob) (set-player-weights $Player $Mat $Mob)) -; - - (= - (show-com $_ $_ $_ weights $Player) + (= (show-com $_ $_ $_ weights $Player) (show-player-weights $Player)) -; - - (= - (show-com $_ $_ $_ weights) + (= (show-com $_ $_ $_ weights) (show-player-weights)) -; - - (= - (show-top weights $Player) + (= (show-top weights $Player) (show-player-weights $Player)) -; - - (= - (show-top weights) + (= (show-top weights) (show-player-weights)) -; - ; -; +; toggle player ==> sets default weights to be those of player. - - (= - (toggle-com $_ $_ $_ $Player) + (= (toggle-com $_ $_ $_ $Player) (toggle-alpha-beta-weights $Player $Old)) -; - diff --git a/metagame/play/notation.metta b/metagame/play/notation.metta index 8fd10ac..9aeb287 100644 --- a/metagame/play/notation.metta +++ b/metagame/play/notation.metta @@ -1,672 +1,287 @@ +; (convert_to_metta_file notation $_214764 metagame/play/notation.pl metagame/play/notation.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; Notation.pl ; ; - ; -; - +; This defines the MOVE GRAMMAR for symmetric ; -; - +; chess-like games. ; ; - ; -; - +; Note that the notation for a move, like that for ; -; - +; a game, ends in a period. !(my-ensure-loaded (library tokenizer)) -; - !(my-ensure-loaded (library grammar)) -; - ; -; - - - (= - (move-notation $ComplexMove $Notation) - ( (det-if-then-else - (var $ComplexMove) set-parsing-mode True) (move-notation $ComplexMove $Notation Nil))) -; +; Ensures parsing mode if really parsing, as otherwise get strange bugs. + (= (move-notation $ComplexMove $Notation) + (det-if-then-else + (var $ComplexMove) set-parsing-mode True) + (move-notation $ComplexMove $Notation Nil)) ; -; - - - (= - (--> - (move_notation $M) - (, - (prelims $M $Pre) - (, - (main $Pre ()) period))) True) -; +; MOVE_NOTATION + (= (--> (move_notation $M) (, (prelims $M $Pre) (, (main $Pre ()) period))) True) ; -; - +; PRELIMS - covers ending assignments and init promotes. ; -; - - (= - (--> - (prelims - (Cons $P $Out) $Out) - (init_promote $P)) True) -; - - (= - (--> - (prelims - (Cons end_assign $Rest) $Rest) ()) True) -; - - (= - (--> - (prelims $Rest $Rest) ()) True) -; - +; Can also be bypassed (thus nothing) if last move was a placement. + (= (--> (prelims (Cons $P $Out) $Out) (init_promote $P)) True) + (= (--> (prelims (Cons end_assign $Rest) $Rest) ()) True) + (= (--> (prelims $Rest $Rest) ()) True) ; -; - +; INIT_PROMOTE ; -; - +; init_promote(opponent_promote(square(5,1),piece(piece2,player),piece(piece3,player)),S,[]). ; -; - - (= - (--> - (init_promote - (opponent_promote () () ())) ()) True) -; - - (= - (--> - (init_promote - (opponent_promote $Sq $OldPiece $NewPiece)) - (, - (promote) - (, - (gsquare $Sq) - (, - (piece $NewPiece) - (, - (;) line))))) True) -; - +; S = [promote,'(',5,',',1,')',white,piece3] ? + (= (--> (init_promote (opponent_promote () () ())) ()) True) + (= (--> (init_promote (opponent_promote $Sq $OldPiece $NewPiece)) (, (promote) (, (gsquare $Sq) (, (piece $NewPiece) (, (;) line))))) True) ; -; - - (= - (--> - (consider_promote - (Cons $T $Sel) $Rest) - (, - (attempt_promote $T) - (select_promote $Sel $Rest))) True) -; - - - (= - (--> - (select_promote - (Cons - (promote_select $Square $OldPiece $OldPiece) $Rest) $Rest) ()) True) -; - - (= - (--> - (select_promote - (Cons - (promote_select $Square $OldPiece $NewPiece) $Rest) $Rest) - (, - (;) - (, line - (, - (promote) - (, - (gsquare $Square) - (piece $NewPiece)))))) True) -; - - (= - (--> - (select_promote $Rest $Rest) ()) True) -; +; CONSIDER_PROMOTE + (= (--> (consider_promote (Cons $T $Sel) $Rest) (, (attempt_promote $T) (select_promote $Sel $Rest))) True) + (= (--> (select_promote (Cons (promote_select $Square $OldPiece $OldPiece) $Rest) $Rest) ()) True) + (= (--> (select_promote (Cons (promote_select $Square $OldPiece $NewPiece) $Rest) $Rest) (, (;) (, line (, (promote) (, (gsquare $Square) (piece $NewPiece)))))) True) + (= (--> (select_promote $Rest $Rest) ()) True) ; -; - +; ATTEMPT_PROMOTE ; -; - +; attempt_promote(try_promote(square(5,1),piece(piece2,player),piece(piece3,player))) ; -; - +; --> [promote,'(',5,',',1,')',white,piece3,';'] ; -; - +; If it couldn't promote at all, don't mention it. ; -; - +; If it promotes to same piece, mention is optional. ; -; - +; Thus if promotion isn't mentioned but it should promote, assume it chooses ; -; - - (= - (--> - (attempt_promote - (try_promote $Square $OldPiece ())) ()) True) -; - - (= - (--> - (attempt_promote - (try_promote $Square $OldPiece $OldPiece)) ()) True) -; - +; same piece. + (= (--> (attempt_promote (try_promote $Square $OldPiece ())) ()) True) + (= (--> (attempt_promote (try_promote $Square $OldPiece $OldPiece)) ()) True) ; -; - - (= - (--> - (attempt_promote - (try_promote $Square $OldPiece $NewPiece)) - (, - (;) - (, - (promote) - (, - (gsquare $Square) - (piece $NewPiece))))) True) -; - +; attempt_promote(try_promote(_Square,_OldPiece,NewPiece)) --> {var(NewPiece)}, []. + (= (--> (attempt_promote (try_promote $Square $OldPiece $NewPiece)) (, (;) (, (promote) (, (gsquare $Square) (piece $NewPiece))))) True) ; -; - +; MAIN ; -; - - (= - (--> - (main - (Cons $P $Out) $Out) - (placing $P)) True) -; - - (= - (--> - (main $In $Out) - (, - (transfers $In $T) - (consider_promote $T $Out))) True) -; - +; Repeated Transfers, followed by possible player promotion. + (= (--> (main (Cons $P $Out) $Out) (placing $P)) True) + (= (--> (main $In $Out) (, (transfers $In $T) (consider_promote $T $Out))) True) ; -; - - (= - (--> - (transfers $In $Out) - (, - (transfer $In $T) - (continued_transfers $T $Out))) True) -; - +; TRANSFERS + (= (--> (transfers $In $Out) (, (transfer $In $T) (continued_transfers $T $Out))) True) ; -; - +; CONTINUED_TRANSFERS ; -; - +; Either no more transfers, or ';' and more transfers. ; -; - - (= - (--> - (continued_transfers $In $In) ()) True) -; - - (= - (--> - (continued_transfers - (Cons end_continues $Rest) $Rest) ()) True) -; - - (= - (--> - (continued_transfers $In $Out) - (, - (;) - (, line - (transfers $In $Out)))) True) -; - +; Could tighten this rule: can't continue unless did a movement. + (= (--> (continued_transfers $In $In) ()) True) + (= (--> (continued_transfers (Cons end_continues $Rest) $Rest) ()) True) + (= (--> (continued_transfers $In $Out) (, (;) (, line (transfers $In $Out)))) True) ; -; - +; TRANSFER : [move(piece(piece6,player),player,square(5,1),square(4,1)), ; -; - +; remove(piece(piece6,player),square(4,1))] ; -; - +; --> [white,piece6,'(',5,',',1,')',->,'(',4,',',1,')',x,'(',4,',',1,')'] ; ; - - (= - (--> - (transfer - (Cons $Move $Capture) $Rest) - (, - (moving $Move) - (capture $Capture $Rest))) True) -; + (= (--> (transfer (Cons $Move $Capture) $Rest) (, (moving $Move) (capture $Capture $Rest))) True) - - (= - (--> - (placing $M) - (, - { (= $M - (place $Piece $Player $Sq)) } - (, - (piece $Piece) - (, - (paren_color_player $Player) - (, - (->) - (gsquare $Sq)))))) True) -; - - (= - (--> - (placing $M) - (, - { (= $M - (assign $Piece $Player $Sq)) } - (, - (piece $Piece) - (, - (paren_color_player $Player) - (, - (->) - (gsquare $Sq)))))) True) -; - + (= (--> (placing $M) (, {(= $M + (place $Piece $Player $Sq)) } (, (piece $Piece) (, (paren_color_player $Player) (, (->) (gsquare $Sq)))))) True) + (= (--> (placing $M) (, {(= $M + (assign $Piece $Player $Sq)) } (, (piece $Piece) (, (paren_color_player $Player) (, (->) (gsquare $Sq)))))) True) ; -; - +; MOVING ; -; - +; moving(move(piece(piece1,opponent),opponent,square(1,6),square(2,4)),S,[]). ; -; - - (= - (--> - (moving - (move $Piece $Player $From $To)) - (, - (piece $Piece) - (, - (gsquare $From) - (, - (->) - (gsquare $To))))) True) -; - - - (= - (--> - (capture $In $Out) - (null_capture $In $Out)) True) -; +; S = [black,piece1,'(',1,',',6,')',->,'(',2,',',4,')'] + (= (--> (moving (move $Piece $Player $From $To)) (, (piece $Piece) (, (gsquare $From) (, (->) (gsquare $To))))) True) - (= - (--> - (capture $In $Out) - (real_capture $In $Out)) True) -; - - - (= - (--> - (null_capture $X $X) ()) True) -; + (= (--> (capture $In $Out) (null_capture $In $Out)) True) + (= (--> (capture $In $Out) (real_capture $In $Out)) True) + (= (--> (null_capture $X $X) ()) True) - (= - (--> - (real_capture - (Cons $C $Cs) $Rest) - (, - (x) - (, - (simp_capture $C) - (capture $Cs $Rest)))) True) -; - - - (= - (--> - (simp_capture $M) - (remove $M)) True) -; - - (= - (--> - (simp_capture $M) - (possess $M)) True) -; + (= (--> (real_capture (Cons $C $Cs) $Rest) (, (x) (, (simp_capture $C) (capture $Cs $Rest)))) True) + (= (--> (simp_capture $M) (remove $M)) True) + (= (--> (simp_capture $M) (possess $M)) True) ; -; - - (= - (--> - (remove - (capture remove $Caps)) - (capture_effects_list $Caps)) True) -; - +; REMOVE + (= (--> (remove (capture remove $Caps)) (capture_effects_list $Caps)) True) ; -; - - (= - (--> - (possess - (capture - (possess $Player) $Caps)) - (, - (capture_effects_list $Caps) - (, - (/) - (paren_color_player $Player)))) True) -; - - - (= - (--> - (capture_effects_list ()) ()) True) -; - - (= - (--> - (capture_effects_list - (Cons $C $Caps)) - (, - (capture_effect $C) - (capture_effects_list $Caps))) True) -; +; POSSESS + (= (--> (possess (capture (possess $Player) $Caps)) (, (capture_effects_list $Caps) (, (/) (paren_color_player $Player)))) True) + (= (--> (capture_effects_list ()) ()) True) + (= (--> (capture_effects_list (Cons $C $Caps)) (, (capture_effect $C) (capture_effects_list $Caps))) True) ; -; - +; Capture effects are of the form: piece square, like: white king (d,2) ; -; - - (= - (--> - (capture_effect $C) - (, - { (captured $C $Piece $Square) } - (, - (piece $Piece) - (gsquare $Square)))) True) -; - +; capture_effect(C) --> {captured(C,_Piece,Square)}, gsquare(Square). + (= (--> (capture_effect $C) (, {(captured $C $Piece $Square) } (, (piece $Piece) (gsquare $Square)))) True) ; -; - +; A PIECE has both an owner and a name, like [white,bishop]. ; -; - +; A PIECE_NAME has just the name (as defined in grammar.pl ; ; - ; -; - +; piece(piece(bishop,player)) --> [white,bishop] ; -; - +; Interesting idea: Allow variables here, or omitted components, ; -; - - (= - (--> - (piece $P) - (, - { (, - (piece_struct_name $P $Name) - (piece_struct_owner $P $O)) } - (, - (color_player $O) - (piece_name $Name)))) True) -; - +; for pattern-matching move notation. + (= (--> (piece $P) (, {(, (piece_struct_name $P $Name) (piece_struct_owner $P $O)) } (, (color_player $O) (piece_name $Name)))) True) ; -; - +; PAREN_COLOR_PLAYER ; -; - - (= - (--> - (paren_color_player $P) - (, - (() - (, - (color_player $P) - ())))) True) -; - - - (= - (--> - (color_player player) - (white)) True) -; - - (= - (--> - (color_player opponent) - (black)) True) -; +; Maps a player into the corresponding color, wrapped in parens. + (= (--> (paren_color_player $P) (, (() (, (color_player $P) ())))) True) + (= (--> (color_player player) (white)) True) + (= (--> (color_player opponent) (black)) True) ; -; - +; color_player(player,white). ; -; +; color_player(opponent,black). + (= (color_player white player) True) + (= (color_player black opponent) True) - (= - (color_player white player) True) -; - - (= - (color_player black opponent) True) -; - - - - (= - (player_color player white) True) -; - - (= - (player_color opponent black) True) -; + (= (player_color player white) True) + (= (player_color opponent black) True) ; -; - +; ================================================================================ ; -; - +; Reading moves from files and strings, printing back. ; -; - +; ================================================================================ ; -; - +; ;; Read from pascal-like MOVE NOTATION, into list. ; -; - +; ;; Reading is CASE-INSENSITIVE: all alpha characters ; -; - +; ;; are converted to lower case when read in. ; -; - +; ;; Also ignores extra blanks, tabs, and linefeeds. ; -; - +; ;; Comments occur from some point in a line started by ;, ; -; - +; ;; and will be ignored to end of line. ; -; - +; ;; Can read games without spaces between operators and atoms, ; -; - +; ;; so squares can be written (X,Y) instead of ( X , Y ). ; -; - +; ;; ; -; - +; Notated Move played: [white,piece6,(,5,,,1,),->,(,4,,,1,),x,(,4,,,1,),;, ; -; - +; white,piece6,(,4,,,1,),->,(,3,,,1,),x,(,3,,,1,),;, ; -; - +; white,piece6,(,3,,,1,),->,(,2,,,1,),x,(,2,,,1,),;, ; -; - +; white,piece6,(,2,,,1,),->,(,1,,,1,),x,(,1,,,1,),'.'] ; -; - +; Stored in /generator/test_read.move ; -; - +; print_read_move(File) ; -; +; Note print - - (= - (print-read-move-from-file $File) - ( (format "~nReading move from file~n" Nil) - (read-move-from-file-to-list $File $Move) - (format "~nRead move from file~n" Nil) - (set-parsing-mode) - (format "~nParsing move in parse mode~n" Nil) - (move-notation $ComplexMove $Move Nil) - (set-printing-mode) - (format "~nParsing move in print mode~n" Nil) - (move-notation $ComplexMove $Move1 Nil) - (format "~nPrinting move~n" Nil) - (print-tokens $Move1))) -; + (= (print-read-move-from-file $File) + (format "~nReading move from file~n" Nil) + (read-move-from-file-to-list $File $Move) + (format "~nRead move from file~n" Nil) + (set-parsing-mode) + (format "~nParsing move in parse mode~n" Nil) + (move-notation $ComplexMove $Move Nil) + (set-printing-mode) + (format "~nParsing move in print mode~n" Nil) + (move-notation $ComplexMove $Move1 Nil) + (format "~nPrinting move~n" Nil) + (print-tokens $Move1)) - - (= - (read-move-from-file-to-list $File $Move) + (= (read-move-from-file-to-list $File $Move) (read-tokens-from-file $File $Move)) -; - ; -; - +; MOVE_NOTATION_STRING(?Move,?String) ; -; - +; Converts between an internal move notation and ; -; - - - (= - (move-notation-string $Move $String) - ( (var $String) - (set-det) - (move-notation $Move $Tokens) - (print-tokens-to-string $Tokens $String))) -; - - (= - (move-notation-string $Move $String) - ( (var $Move) - (read-tokens-from-string $String $Tokens) - (move-notation $Move $Tokens))) -; +; a string of (ascii) characters. + (= (move-notation-string $Move $String) + (var $String) + (set-det) + (move-notation $Move $Tokens) + (print-tokens-to-string $Tokens $String)) + (= (move-notation-string $Move $String) + (var $Move) + (read-tokens-from-string $String $Tokens) + (move-notation $Move $Tokens)) diff --git a/metagame/play/ops.metta b/metagame/play/ops.metta index b2bfa2a..bdb2ebd 100644 --- a/metagame/play/ops.metta +++ b/metagame/play/ops.metta @@ -1,24 +1,18 @@ +; (convert_to_metta_file ops $_355000 metagame/play/ops.pl metagame/play/ops.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; ops.pl !(op 700 xfx @) -; - diff --git a/metagame/play/param.metta b/metagame/play/param.metta index 02a60f6..224afd2 100644 --- a/metagame/play/param.metta +++ b/metagame/play/param.metta @@ -1,643 +1,410 @@ +; (convert_to_metta_file param $_408480 metagame/play/param.pl metagame/play/param.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ; param.pl -- default parameter values, and documentation ; -; - +; ; (set for local interface) ; -; - +; ; ; -; - +; ; external routines: ; -; - +; ; parameter(+Name,-Value) :- retrieve a parameter value ; -; - +; ; ; -; - +; ; Note: the parameters for the generator are in gen_parameters.pl ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ; parameters used by the workbench ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ; dynamic so that this can be listed and changed !(dynamic (/ parameter 2)) -; - ; -; - +; ; value: 0 = off, >0 = more verbose. ; -; - +; ; description: how verbose to be in tracing system ; -; - +; ; used in: interface.pl, many other files. - (= - (parameter verbosity 0) True) -; - + (= (parameter verbosity 0) True) ; -; - +; ; value: {off, on} ; -; - +; ; description: whether to display timing information ; -; - - - (= - (parameter timing on) True) -; +; ; used in: interface.pl + (= (parameter timing on) True) ; -; - +; ; value: {ask,offer} ; -; - +; ; description: determines how a human will select moves. ; -; - +; ; ask: ask human to enter moves in grammatical notation ; -; - +; ; offer: backtrack through possible moves, until human accepts one. ; -; - - - (= - (parameter selection_method ask) True) -; +; ; used in: interface.pl + (= (parameter selection_method ask) True) ; -; - +; ; value: {ask,random} ; -; - +; ; description: determines how random positions will be set up. ; -; - +; ; ask: ask human to enter assignment in grammatical notation. ; -; - +; ; random: generate a random assignment. ; -; - - - (= - (parameter assignment_method random) True) -; +; ; used in: local.pl + (= (parameter assignment_method random) True) ; -; - +; ; value: {yes,no} ; -; - +; ; description: whether to pause between moves when using local interface. ; -; - +; ; yes: ask human whether to continue after each move ; -; - +; ; no: continue play without pausing. ; -; - - - (= - (parameter continuous yes) True) -; +; ; used in: local.pl + (= (parameter continuous yes) True) ; -; - +; ; values: {human,} ; -; - +; ; description: move selection method for PLAYER ; -; - - - (= - (parameter player_method human) True) -; +; ; used in: interface.pl + (= (parameter player_method human) True) ; -; - +; ; values: {human,} ; -; - +; ; description: move selection method for OPPONENT ; -; - - - (= - (parameter opponent_method human) True) -; +; ; used in: interface.pl + (= (parameter opponent_method human) True) ; -; - +; ; values: {none,} ; -; - +; ; description: pre-move initialization file for PLAYER ; -; - - - (= - (parameter player_file none) True) -; +; ; used in: controller.pl + (= (parameter player_file none) True) ; -; - +; ; values: {none,} ; -; - +; ; description: pre-move initialization file for OPPONENT ; -; - - - (= - (parameter opponent_file none) True) -; +; ; used in: controller.pl + (= (parameter opponent_file none) True) ; -; - +; ; values: {on,off} ; -; - +; ; description: whether to be verbose when finding interpretation ; -; - +; ; of communicated move strings in remote matches. ; -; - - - (= - (parameter verbose_interp on) True) -; +; ; used in: interface.pl + (= (parameter verbose_interp on) True) ; -; - +; ; values: {parsing,printing} ; -; - +; ; description: whether parsing pure or for pretty-printing ; -; - +; ; parsing: pure parsing and generating ; -; - +; ; printing: just before generating strings which will ; -; - +; ; then be pretty-printed. ; -; - - - (= - (parameter parsing_mode parsing) True) -; +; ; used in: grammar.pl, notation.pl, interface.pl + (= (parameter parsing_mode parsing) True) ; -; - +; ; values: {on,off} ; -; - +; ; description: whether can use (a,1) notation to denote ; -; - +; ; squares in move and game grammars ; -; - +; ; on: use (a,1) notation ; -; - +; ; off: use (1,1) notation ; -; - +; ; used in: grammar.pl, notation.pl, interface.pl, tokenizer.pl ; -; - +; ; In general, this param is off, except for humans ; -; - +; ; entering moves requiring completion. It could be ; -; - +; ; used to generate pretty initial assignments for games, ; -; - +; ; but CAUTION, it will not parse games or moves in the ; -; - - - (= - (parameter alpha_squares_mode off) True) -; +; ; other mode. + (= (parameter alpha_squares_mode off) True) ; -; - +; ; values: {on,off} ; -; - +; ; description: whether to ask the user to confirm choices ; -; - +; ; (generally during move selection). ; -; - +; ; on: ask user to accept choice, consider next, or backtrack ; -; - +; ; off: don't ask, just assume first choice is acceptable. ; -; - - - (= - (parameter confirm_choices on) True) -; +; ; used in: interface.pl + (= (parameter confirm_choices on) True) ; -; - +; ; values: {on,off} ; -; - +; ; description: whether to try completing entered moves. ; -; - +; ; on: try completing ; -; - +; ; off: only accept completely grammatical moves. ; -; - +; ; note: this can considerably slow down the interface. ; -; - - - (= - (parameter completions on) True) -; +; ; used in: interface.pl + (= (parameter completions on) True) ; -; - +; ; values: {on,off} ; -; - +; ; description: whether to check safety of completed moves. ; -; - +; ; on: check safety ; -; - +; ; off: allow any matching move. ; -; - +; ; note: this can considerably slow down the interface. ; -; - - - (= - (parameter safety off) True) -; +; ; used in: interface.pl + (= (parameter safety off) True) ; -; - +; ; values: {on,off} ; -; - +; ; description: whether to ask the user to confirm choices ; -; - +; ; (generally during move selection). ; -; - +; ; on: compile symmetries when loading a game. ; -; - +; ; off: don't compile symmetries when loading a game. ; -; - - - (= - (parameter compile_symmetries on) True) -; +; ; used in: parse1.pl + (= (parameter compile_symmetries on) True) ; -; - +; Some parameters for remote communications. ; -; - +; Not used at the moment. ; -; - +; parameter(player1_name,undefined). ; -; - +; parameter(player2_name,undefined). ; -; - +; parameter(player1_info,undefined). ; -; - +; parameter(player2_info,undefined). ; -; - +; parameter(server_name,undefined). ; -; - +; parameter(server_port,undefined). ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ; parameters used by search engines ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ; When using the RANDOM advisor, these determine ; -; - +; ; the range within which random evaluations are assigned, ; -; - +; ; when the RANDOM advisor is active. ; -; - +; ; If the values are integers, only integers in the range will be chosen. ; -; - - - (= - (parameter random_min -1.0) True) -; - - (= - (parameter random_max 1.0) True) -; +; ; used in: value.pl + (= (parameter random_min -1.0) True) + (= (parameter random_max 1.0) True) ; -; - +; ; value: {Integer} ; -; - +; ; description: For the alpha_beta player, sets fixed depth for search. ; -; - - - (= - (parameter depth 1) True) -; +; ; used in: alphabeta.pl + (= (parameter depth 1) True) ; -; - +; ; value: {Integer} ; -; - +; ; description: Time for each player to play entire game ; -; - +; ; (in milliseconds). ; -; - +; ; used in: controller.pl, alphabeta.pl ; -; - - (= - (parameter game_time_limit 99999999) True) -; - +; parameter(game_time_limit,180000). + (= (parameter game_time_limit 99999999) True) ; -; - +; ; value: {Integer} ; -; - +; ; description: Time for each player to play single move ; -; - +; ; (in milliseconds). ; -; - +; ; ; -; - +; ; This is not an enforced constraint, but is used by players which ; -; - +; ; take note of it (like alpha-beta, iterate). ; -; - - - (= - (parameter move_time_limit 10000) True) -; +; ; used in: alphabeta.pl + (= (parameter move_time_limit 10000) True) ; -; - +; ; value: {Integer} ; -; - +; ; description: Number of moves a player should think it still has to ; -; - +; ; make in a given game, for time allocation purposes. ; -; - +; ; Setting value to 1 means: assume this is the only move we have to make, ; -; - +; ; so use as much time as is available. ; -; - +; ; ; -; - +; ; This is not an enforced constraint, but is used by players which ; -; - +; ; take note of it (like alpha-beta, iterate). ; -; - - - (= - (parameter move_horizon 1) True) -; +; ; used in: alphabeta.pl + (= (parameter move_horizon 1) True) ; -; - +; ; value: {random,fixed} ; -; - +; ; description: How to order successor moves for node expansion. ; -; - +; ; random: order them randomly. ; -; - - - (= - (parameter ordering random) True) -; +; ; fixed: order them as produced by the move generator. + (= (parameter ordering random) True) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ; parameters used by strategic evaluation function ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; See also the advisors defined in value.pl ; -; - +; How to discount goals as a function of number of abstract ; -; - +; moves needed to achieve them. ; -; - +; inverse: Val(Dist) = 1/(1+Dist) ; -; - - - (= - (parameter discount exponent) True) -; +; exponent: Val(Dist) = 1/(2^Dist) + (= (parameter discount exponent) True) ; -; - +; Max number of eradicate targets left before we consider each ; -; - +; remaining one to be vital. ; -; +; integer - - (= - (parameter vital_number 2) True) -; - + (= (parameter vital_number 2) True) ; -; - +; Predict a piece would be N times as valuable when possessed as it would be ; -; - +; on the board. ; -; - +; For example, in shogi we capture by possession, this must be more valuable ; -; - +; than just removing the piece, as in chess. - (= - (parameter possess_offset 2) True) -; - + (= (parameter possess_offset 2) True) diff --git a/metagame/play/player_files.metta b/metagame/play/player_files.metta index c4caf76..91cdcff 100644 --- a/metagame/play/player_files.metta +++ b/metagame/play/player_files.metta @@ -1,55 +1,30 @@ +; (convert_to_metta_file player_files $_40856 metagame/play/player_files.pl metagame/play/player_files.metta) ; -; +; player_files.pl + (= (system_files play (param ops parse1 parse2 controller history help help_advisors interface setup gen_menu start_menu local invert matches notation stat thread statify_theory efficient_state compile_syms mobility alphabeta value advisors)) True) +; ; comms, +; ; experiment, - (= - (system_files play - (param ops parse1 parse2 controller history help help_advisors interface setup gen_menu start_menu local invert matches notation stat thread statify_theory efficient_state compile_syms mobility alphabeta value advisors)) True) -; - - - (= - (system_files fullplay - (param ops parse1 parse2 controller menus interface start_menu local comms invert matches notation stat compile_state compile_syms index_preds)) True) -; - + (= (system_files fullplay (param ops parse1 parse2 controller menus interface start_menu local comms invert matches notation stat compile_state compile_syms index_preds)) True) ; -; - - - (= - (system_files generator - (genstructs piece_names gen tokenizer grammar gen_parameters)) True) -; +; Files defined by generator system + (= (system_files generator (genstructs piece_names gen tokenizer grammar gen_parameters)) True) - (= - (system_files library - (aux tracing timing dynamic_load shells args randoms theoryl menus)) True) -; - - - (= - (system_files analysis - (struct paths analysis mygraphs floyd tables arrive prom possess exclude dominate group step flight global potent tourney)) True) -; + (= (system_files library (aux tracing timing dynamic_load shells args randoms theoryl menus)) True) + (= (system_files analysis (struct paths analysis mygraphs floyd tables arrive prom possess exclude dominate group step flight global potent tourney)) True) ; -; - +; ---------------------------------------- ; -; - - +; The following are used in statify_theory.pl: - (= - (theory_files - (dynamic_preds parse boards print_boards legal goals)) True) -; + (= (theory_files (dynamic_preds parse boards print_boards legal goals)) True) diff --git a/metagame/play/setup.metta b/metagame/play/setup.metta index f6efe6e..0ab1ba7 100644 --- a/metagame/play/setup.metta +++ b/metagame/play/setup.metta @@ -1,340 +1,224 @@ +; (convert_to_metta_file setup $_109322 metagame/play/setup.pl metagame/play/setup.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; setup.pl ; -; - +; An interface for setting up the board as we choose. ; -; - +; We could modify a game file, but this would not allow ; -; - - +; other than symmetric games. - (= - (setup-position empty $Squares $SIn $SOut) - ( (set-det) (make-empty $Squares $SIn $SOut))) -; - (= - (setup-position $Player $Assignments $SIn $SOut) + (= (setup-position empty $Squares $SIn $SOut) + (set-det) + (make-empty $Squares $SIn $SOut)) + (= (setup-position $Player $Assignments $SIn $SOut) (place-pieces-on-squares $Assignments $Player $SIn $SOut)) -; - - (= - (setup-com $_ $SIn $SOut) + (= (setup-com $_ $SIn $SOut) (setup $SIn $SOut)) -; - ; -; - +; ====================================================================== ; -; - +; Setting up a position ; -; - - - - (= - (setup $SIn $SOut) - ( (menu-command "~nEnter command ('help.' gives more information)~n" setup - (:: $Done $SIn $S1)) - (set-det) - (continue-setup $Done $SIn $S1 $SOut))) -; +; ====================================================================== - (= - (setup $SIn $SOut) - ( (format "~nI did not understand your command. Please try again!~n" Nil) (setup $SIn $SOut))) -; + (= (setup $SIn $SOut) + (menu-command "~nEnter command ('help.' gives more information)~n" setup + (:: $Done $SIn $S1)) + (set-det) + (continue-setup $Done $SIn $S1 $SOut)) + (= (setup $SIn $SOut) + (format "~nI did not understand your command. Please try again!~n" Nil) + (setup $SIn $SOut)) ; -; - +; CONTINUE_SETUP(?Move,+SIn,+S1,-SOut). ; -; - +; Ensure that we are done setting up, else back to the menu. ; -; - +; If Move and S1 are bound, we accept S1 as the result. ; -; - +; If only S1 is bound, we accept this as a new current state, ; -; - +; and use it to get the final move. ; -; - +; If neither, then some other command didn't do any work, ; -; - +; and we start again from our original state to get the move. ; ; - - (= - (continue-setup $Move $SIn $S1 $S1) - ( (nonvar $Move) - (= $Move done) - (set-det))) -; - - (= - (continue-setup $Move $SIn $S1 $Nothing) - ( (nonvar $Move) - (= $Move abort) - (set-det))) -; - - (= - (continue-setup $Move $SIn $S1 $S1) - ( (nonvar $Move) - (nonvar $S1) - (set-det))) -; - - (= - (continue-setup $Move $SIn $S1 $SOut) - ( (nonvar $S1) - (set-det) - (setup $S1 $SOut))) -; - - (= - (continue-setup $Move $SIn $S1 $SOut) + (= (continue-setup $Move $SIn $S1 $S1) + (nonvar $Move) + (= $Move done) + (set-det)) + (= (continue-setup $Move $SIn $S1 $Nothing) + (nonvar $Move) + (= $Move abort) + (set-det)) + (= (continue-setup $Move $SIn $S1 $S1) + (nonvar $Move) + (nonvar $S1) + (set-det)) + (= (continue-setup $Move $SIn $S1 $SOut) + (nonvar $S1) + (set-det) + (setup $S1 $SOut)) + (= (continue-setup $Move $SIn $S1 $SOut) (setup $SIn $SOut)) -; - ; -; - +; ---------------------------------------- ; -; - +; SETUP menu commands ; -; - +; ---------------------------------------- ; -; - - - (= - (put-setup $_ $SIn $SOut $Row $Col $Color $Type) - ( (piece $Piece - (:: $Color $Type) Nil) - (with-alpha-squares (gsquare $Square (:: ( $Row , $Col )) Nil)) - (place-piece $Piece $Square $SIn $SOut))) -; +; put e 2 black bishop + (= (put-setup $_ $SIn $SOut $Row $Col $Color $Type) + (piece $Piece + (:: $Color $Type) Nil) + (with-alpha-squares (gsquare $Square (:: ( $Row , $Col )) Nil)) + (place-piece $Piece $Square $SIn $SOut)) ; -; - - - (= - (initprom-setup $_ $SIn $SOut $Row $Col $Color $Type) - ( (piece $Piece - (:: $Color $Type) Nil) - (with-alpha-squares (gsquare $Square (:: ( $Row , $Col )) Nil)) - (put-stage init-promote $SIn $S1) - (add-in - (opponent-promotes $Piece $Square) $S1 $SOut))) -; +; initprom e 2 black bishop + (= (initprom-setup $_ $SIn $SOut $Row $Col $Color $Type) + (piece $Piece + (:: $Color $Type) Nil) + (with-alpha-squares (gsquare $Square (:: ( $Row , $Col )) Nil)) + (put-stage init-promote $SIn $S1) + (add-in + (opponent-promotes $Piece $Square) $S1 $SOut)) ; -; - - - (= - (hand-setup $_ $SIn $SOut $HandColor $Color $Type) - ( (piece $Piece - (:: $Color $Type) Nil) - (player-color $Player $HandColor) - (put-in-hand $Piece $Player $SIn $SOut))) -; +; hand white white queen + (= (hand-setup $_ $SIn $SOut $HandColor $Color $Type) + (piece $Piece + (:: $Color $Type) Nil) + (player-color $Player $HandColor) + (put-in-hand $Piece $Player $SIn $SOut)) ; -; - - - (= - (empty-setup $_ $SIn $SOut $Row $Col) - ( (with-alpha-squares (gsquare $Square (:: ( $Row , $Col )) Nil)) (set-empty $Square $SIn $SOut))) -; +; empty e 5 + (= (empty-setup $_ $SIn $SOut $Row $Col) + (with-alpha-squares (gsquare $Square (:: ( $Row , $Col )) Nil)) + (set-empty $Square $SIn $SOut)) ; -; - - - (= - (move-setup $_ $SIn $SOut $Row1 $Col1 $Row2 $Col2) - ( (with-alpha-squares (, (gsquare $Square1 (:: ( $Row1 , $Col1 )) Nil) (gsquare $Square2 (:: ( $Row2 , $Col2 )) Nil))) (move-piece $_ $Square1 $Square2 $SIn $SOut))) -; +; move e 2 e 4 + (= (move-setup $_ $SIn $SOut $Row1 $Col1 $Row2 $Col2) + (with-alpha-squares (, (gsquare $Square1 (:: ( $Row1 , $Col1 )) Nil) (gsquare $Square2 (:: ( $Row2 , $Col2 )) Nil))) + (move-piece $_ $Square1 $Square2 $SIn $SOut)) ; -; - +; stage assign - (= - (stage-setup $_ $SIn $SOut $Stage) + (= (stage-setup $_ $SIn $SOut $Stage) (put-stage $Stage $SIn $SOut)) -; - ; -; - - - (= - (control-setup $_ $SIn $SOut $Color) - ( (player-color $Player $Color) (put-control $Player $SIn $SOut))) -; +; control black + (= (control-setup $_ $SIn $SOut $Color) + (player-color $Player $Color) + (put-control $Player $SIn $SOut)) ; -; +; clear - - (= - (clear-setup $_ $SIn $SOut) + (= (clear-setup $_ $SIn $SOut) (make-empty-board $SIn $SOut)) -; - ; -; - - - (= - (add-setup $_ $SIn $SOut) - ( (format "Enter a property to be added: ~n" Nil) - (read $Prop) - (add-in $Prop $SIn $SOut))) -; +; add + (= (add-setup $_ $SIn $SOut) + (format "Enter a property to be added: ~n" Nil) + (read $Prop) + (add-in $Prop $SIn $SOut)) ; -; - - - (= - (del-setup $_ $SIn $SOut) - ( (format "Enter a property to be deleted: ~n" Nil) - (read $Prop) - (del-in $Prop $SIn $SOut))) -; +; del + (= (del-setup $_ $SIn $SOut) + (format "Enter a property to be deleted: ~n" Nil) + (read $Prop) + (del-in $Prop $SIn $SOut)) ; -; - +; RESTORE ; -; - +; Set current state to be a previously named checkpoint state. - (= - (restore-setup $_ $SIn $SOut $Name) + (= (restore-setup $_ $SIn $SOut $Name) (restore-state $Name $SOut)) -; - ; -; - +; CHECKPOINT - (= - (checkpoint-setup $_ $SIn $_) + (= (checkpoint-setup $_ $SIn $_) (checkpoint-state $SIn)) -; - ; -; - - (= - (checkpoint-setup $_ $SIn $_ $Name) +; CHECKPOINT + (= (checkpoint-setup $_ $SIn $_ $Name) (checkpoint-state $Name $SIn)) -; - ; -; - - - (= - (done_setup done $SIn $SIn) True) -; +; done + (= (done_setup done $SIn $SIn) True) ; -; - - - (= - (abort_setup abort $SIn $_) True) -; +; abort: abandon changes and back to move menu. + (= (abort_setup abort $SIn $_) True) ; -; - - - (= - (display-setup $Move $SIn $_) - ( (format "~nCurrent State: ~n" Nil) (print-state $SIn))) -; +; display + (= (display-setup $Move $SIn $_) + (format "~nCurrent State: ~n" Nil) + (print-state $SIn)) - (= - (help-setup $_ $_ $_) + (= (help-setup $_ $_ $_) (help-setup)) -; - - (= - (help-setup) + (= (help-setup) (format "\nModifying Board Setup\n---------------------\nmove => transfer piece to different square\nput => put a piece on square (,)\ninitprom => opponent must promote piece on square\nempty \t\t => empty square (,)\nhand => put piece in 's hand\nclear\t\t\t\t => makes all the square empty\ncontrol \t\t\t => puts player in control\nstage \t\t\t => sets current stage to \nadd/del\t\t\t\t => add or delete a property from state\ndisplay\t\t\t\t => prints the board\ndone\t\t\t\t => exits setup stage with current setup\nabort\t\t\t\t => exits setup stage, abandon changes\ncheckpoint . => record state under name \nrestore . => set state to that checkpointed as \n\nExamples:\n\nmove e 2 e 4.\nput e 2 white king.\nhand white black queen.\ncontrol white.\nstage assign.\ninitprom e 2 black bishop. \ndone.\n" Nil)) -; - diff --git a/metagame/play/start_menu.metta b/metagame/play/start_menu.metta index a75fdca..eccf297 100644 --- a/metagame/play/start_menu.metta +++ b/metagame/play/start_menu.metta @@ -1,461 +1,308 @@ +; (convert_to_metta_file start_menu $_241898 metagame/play/start_menu.pl metagame/play/start_menu.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; start_menu.pl ; -; - +; Top level menu before playing a game. ; -; - +; Process commands from user. ; -; - +; When user has chosen to play a game finally, then starts controller. ; -; - +; After game has ended, controller releases control back here, and ; -; +; we continue! - - (= - (metagame) - ( (recover-metagame-state) - (menu-command "~nEnter a command ('help.' gives more information)~n" top Nil) - (set-det) - (metagame))) -; - - (= - (metagame) - ( (format "~nI did not understand your command. Please try again!~n" Nil) (metagame))) -; - + (= (metagame) + (recover-metagame-state) + (menu-command "~nEnter a command ('help.' gives more information)~n" top Nil) + (set-det) + (metagame)) + (= (metagame) + (format "~nI did not understand your command. Please try again!~n" Nil) + (metagame)) ; -; +; Clean up any errors left from possibly aborted programs. + (= (recover-metagame-state) + (restore-parameters) + (recover-grammar)) - (= - (recover-metagame-state) - ( (restore-parameters) (recover-grammar))) -; - - - (= - (game-top $File) + (= (game-top $File) (load-game $File)) -; - - (= - (player-top white $Player) - ( (format "~p moves will now be chosen by: ~p~n" - (:: white $Player)) (set-parameter player-method $Player))) -; + (= (player-top white $Player) + (format "~p moves will now be chosen by: ~p~n" + (:: white $Player)) + (set-parameter player-method $Player)) + (= (player-top black $Player) + (set-parameter opponent-method $Player) + (format "~p moves will now be chosen by: ~p~n" + (:: black $Player))) - (= - (player-top black $Player) - ( (set-parameter opponent-method $Player) (format "~p moves will now be chosen by: ~p~n" (:: black $Player)))) -; - - - - (= - (players-top $Player $Opp) - ( (player-top white $Player) (player-top black $Opp))) -; - - (= - (players-top) - ( (get-player-color player $White) - (get-player-color opponent $Black) - (format "Playing ~p as ~p vs. ~p as ~p.~n" - (:: $White player $Black opponent)))) -; + (= (players-top $Player $Opp) + (player-top white $Player) + (player-top black $Opp)) + (= (players-top) + (get-player-color player $White) + (get-player-color opponent $Black) + (format "Playing ~p as ~p vs. ~p as ~p.~n" + (:: $White player $Black opponent))) - (= - (show-players-top) + (= (show-players-top) (get-players $_ $_)) -; - - (= - (games-library-top) + (= (games-library-top) (games-library)) -; - - - (= - (games-library) - ( (games-library-directory $D) (games-library $D))) -; - + (= (games-library) + (games-library-directory $D) + (games-library $D)) - (= - (games-library $D) - ( (current-directory $Current) - (absolute-file-name $D $AbsD) - (cd $AbsD) - (= $Games *.game) - (format "~nThe following games are available in directory <~p>:~n~n" - (:: $AbsD)) - (shell (:: ls $Games)) - (cd $Current))) -; + (= (games-library $D) + (current-directory $Current) + (absolute-file-name $D $AbsD) + (cd $AbsD) + (= $Games *.game) + (format "~nThe following games are available in directory <~p>:~n~n" + (:: $AbsD)) + (shell (:: ls $Games)) + (cd $Current)) - (= - (games-in-directory $D) + (= (games-in-directory $D) (games-library $D)) -; - - (= - (cd-top $Dir) + (= (cd-top $Dir) (cd-print $Dir)) -; - - (= - (cd-print $Dir) - ( (format "~nChanging current directory to: ~p~n~n" - (:: $Dir)) (cd $Dir))) -; + (= (cd-print $Dir) + (format "~nChanging current directory to: ~p~n~n" + (:: $Dir)) + (cd $Dir)) - - (= - (pwd-top) + (= (pwd-top) (pwd-print)) -; - - (= - (ls-top) + (= (ls-top) (ls)) -; + (= (pwd-print) + (current-directory $D) + (format "~nCurrent directory is: ~p~n~n" + (:: $D))) - (= - (pwd-print) - ( (current-directory $D) (format "~nCurrent directory is: ~p~n~n" (:: $D)))) -; - - - (= - (define-top $PieceName) + (= (define-top $PieceName) (show-piece-definition $PieceName)) -; - - (= - (goals-top) + (= (goals-top) (show-game-goals)) -; - - - (= - (show-game-goals) - ( (player-current-game $G) - (game-name $G $GameName) - (game-goal $G $Def) - (set-printing-mode) - (with-alpha-squares (goal-defs $Def $String Nil)) - (set-parsing-mode) - (format "~nGame <~p> has the following goals: ~n~n" - (:: $GameName)) - (print-tokens $String) - (nl) - (nl))) -; + (= (show-game-goals) + (player-current-game $G) + (game-name $G $GameName) + (game-goal $G $Def) + (set-printing-mode) + (with-alpha-squares (goal-defs $Def $String Nil)) + (set-parsing-mode) + (format "~nGame <~p> has the following goals: ~n~n" + (:: $GameName)) + (print-tokens $String) + (nl) + (nl)) - (= - (rules-top) + (= (rules-top) (show-rules)) -; + (= (show-rules) + (player-current-game $G) + (game-name $G $GameName) + (format "~nGame <~p> is defined as follows: ~n~n" + (:: $GameName)) + (with-alpha-squares (print-game-struct $G)) + (nl) + (nl)) - (= - (show-rules) - ( (player-current-game $G) - (game-name $G $GameName) - (format "~nGame <~p> is defined as follows: ~n~n" - (:: $GameName)) - (with-alpha-squares (print-game-struct $G)) - (nl) - (nl))) -; - - - (= - (pieces-top) + (= (pieces-top) (show-piece-names)) -; - - (= - (board-top) + (= (board-top) (show-board)) -; - - (= - (show-board) - ( (player-current-game $G) - (game-name $G $GameName) - (game-board $G $Def) - (set-printing-mode) - (with-alpha-squares (board $Def $String Nil)) - (set-parsing-mode) - (format "~nGame <~p> has the board information: ~n~n" - (:: $GameName)) - (print-tokens $String) - (nl) - (nl))) -; + (= (show-board) + (player-current-game $G) + (game-name $G $GameName) + (game-board $G $Def) + (set-printing-mode) + (with-alpha-squares (board $Def $String Nil)) + (set-parsing-mode) + (format "~nGame <~p> has the board information: ~n~n" + (:: $GameName)) + (print-tokens $String) + (nl) + (nl)) - - (= - (set-top $P $V) + (= (set-top $P $V) (set-parameter $P $V)) -; - - (= - (set-top) + (= (set-top) (show-parameters)) -; - ; -; - +; Setting Globals ; -; - +; (Don't need to document for now) - (= - (setg-top $P $V) + (= (setg-top $P $V) (add-global $P $V)) -; - - (= - (showg-top) + (= (showg-top) (showg)) -; - - (= - (randomize-top $N) + (= (randomize-top $N) (randomize $N)) -; - - (= - (quit-top) + (= (quit-top) (print-quit)) -; - - (= - (print-quit) - ( (format "~nBye!~n" Nil) (halt))) -; + (= (print-quit) + (format "~nBye!~n" Nil) + (halt)) - - (= - (abort-top) + (= (abort-top) (print-abort)) -; - - (= - (prolog-top) + (= (prolog-top) (print-abort)) -; - - (= - (print-abort) - ( (format "~nTo return to METAGAME, type: 'metagame.'~n" Nil) (abort))) -; + (= (print-abort) + (format "~nTo return to METAGAME, type: 'metagame.'~n" Nil) + (abort)) - - (= - (play-top) + (= (play-top) (start)) -; - - (= - (start-top) + (= (start-top) (start)) -; - - (= - (generate-top $File) + (= (generate-top $File) (generate-and-load $File)) -; - +; ; random_game_to_file(File). - (= - (generate-top) + (= (generate-top) (generate-and-load random)) -; - +; ; random_game_to_file(random). ; -; - +; ============================================================================ ; -; - +; Game Clock Routines ; -; - +; ------------------- ; -; - +; Documented in interface.pl ; -; +; ============================================================================ - - (= - (clock-top) + (= (clock-top) (print-clock)) -; - - (= - (clock-top unlimit) + (= (clock-top unlimit) (clock-unlimit)) -; - - (= - (clock-top print) + (= (clock-top print) (print-clock)) -; - - (= - (clock-top reset) + (= (clock-top reset) (reset-clock)) -; - - - (= - (clock-top adjust $Color $Time) - ( (player-color $Player $Color) (adjust-player-clock $Player $Time))) -; + (= (clock-top adjust $Color $Time) + (player-color $Player $Color) + (adjust-player-clock $Player $Time)) ; -; - +; ----------------------------------------------------------------- ; -; - +; Tracing ; -; +; ----------------------------------------------------------------- - - (= - (trace-top $Module) + (= (trace-top $Module) (set-tracing $Module on)) -; - - (= - (trace-top $Module $Component) + (= (trace-top $Module $Component) (set-tracing $Module $Component on)) -; - - (= - (untrace-top $Module) + (= (untrace-top $Module) (set-tracing $Module off)) -; - - (= - (untrace-top $Module $Component) + (= (untrace-top $Module $Component) (set-tracing $Module $Component off)) -; - - - (= - (list-tracing-top) - ( (traced-modules $M) (format "The following modules are being traced: ~n~p~n" (:: $M)))) -; + (= (list-tracing-top) + (traced-modules $M) + (format "The following modules are being traced: ~n~p~n" + (:: $M))) diff --git a/metagame/play/sysdev.metta b/metagame/play/sysdev.metta index da76396..66ba8c3 100644 --- a/metagame/play/sysdev.metta +++ b/metagame/play/sysdev.metta @@ -1,194 +1,135 @@ +; (convert_to_metta_file sysdev $_374758 metagame/play/sysdev.pl metagame/play/sysdev.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ; sysdev.pl --- misc utilities used for debugging or developing the system ; -; - +; ; ; -; - +; ; external routines: practically everything (this is a utilty file); BUT, ; -; - +; ; none of these routines should be called by the system proper -- it's ; -; - +; ; all "researcher support" ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (my_absolute_file_name $N $N) True) -; - + (= (my_absolute_file_name $N $N) True) ; -; - +; is_profiling/0 defined differently for MeTTa versions, ; -; +; in file -version - - (= - (my-use-module $M) + (= (my-use-module $M) (det-if-then-else is-profiling (profiling-load $M) (use-module $M))) -; - - (= - (my-ensure-loaded $M) + (= (my-ensure-loaded $M) (det-if-then-else is-profiling (profiling-load $M) (ensure-loaded $M))) -; - - (= - (profiling-load $M) + (= (profiling-load $M) (compile $M)) -; - +; ; current_predicate( ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; !(my-ensure-loaded ../misc/aux) -; - - (= - (make-library-directory $Path) - ( (my-absolute-file-name $Path $D) (add-symbol &self (library_directory $D)))) -; - + (= (make-library-directory $Path) + ( (my-absolute-file-name $Path $D) (add-is-symbol &self (library_directory $D)))) ; -; - +; METAGAME_DIRECTORY(Metagame) ; -; - +; This is usually asserted into the system during a build by ; -; - +; the makefile. The directory name should be the logical name, ; -; - +; insensitive to automounting, otherwise trouble arises ; -; - +; for automounted systems when later invocations can't find the ; -; - +; absolute file name saved eariler. ; -; - +; An example of a good name is: ; -; - - +; assert(metagame_directory('~bdp/Metagame')). - (= - (metagame-subpath $Path $Dir) - ( (metagame-directory $Metagame) - (concat $Metagame / $Sub1) - (concat $Sub1 $Path $SubDir) - (my-absolute-file-name $SubDir $Dir))) -; + (= (metagame-subpath $Path $Dir) + (metagame-directory $Metagame) + (concat $Metagame / $Sub1) + (concat $Sub1 $Path $SubDir) + (my-absolute-file-name $SubDir $Dir)) - (= - (make-metagame-subpath $Path) - ( (metagame-subpath $Path $Dir) (make-library-directory $Dir))) -; + (= (make-metagame-subpath $Path) + (metagame-subpath $Path $Dir) + (make-library-directory $Dir)) - - (= - (find-index-preds-file) + (= (find-index-preds-file) ( (metagame-subpath state/index-preds.pl $F) (abolish (/ index-preds-file 1)) - (add-symbol &self + (add-is-symbol &self (index_preds_file $F)))) -; - - (= - (find-games-library) + (= (find-games-library) ( (metagame-subpath games $D) (abolish (/ games-library-directory 1)) - (add-symbol &self + (add-is-symbol &self (games_library_directory $D)))) -; - - (= - (find-theory-directory) + (= (find-theory-directory) ( (metagame-subpath theory $D) (abolish (/ theory-directory 1)) - (add-symbol &self + (add-is-symbol &self (theory_directory $D)))) -; - - (= - (find-dynamic-preds-file) + (= (find-dynamic-preds-file) ( (metagame-subpath theory/dynamic-preds.pl $F) (abolish (/ dynamic-preds-file 1)) - (add-symbol &self + (add-is-symbol &self (dynamic_preds_file $F)))) -; - - (= - (bind-environment-paths) + (= (bind-environment-paths) ( (make-metagame-subpath generator) (make-metagame-subpath misc) (make-metagame-subpath play) @@ -203,575 +144,398 @@ (find-index-preds-file) (find-games-library) (find-theory-directory) - (add-symbol &self + (add-is-symbol &self (library_directory .)))) -; - ; -; - - - - (= - (sys_filename_suffix prolog .pl) True) -; +; Metagame System Filenames - (= - (sys_filename_suffix state_compile _stat) True) -; - (= - (sys_filename_suffix game .game) True) -; + (= (sys_filename_suffix prolog .pl) True) + (= (sys_filename_suffix state_compile _stat) True) + (= (sys_filename_suffix game .game) True) + (= (sys_filename_suffix eval .eval) True) + (= (sys_filename_suffix record .rec) True) - (= - (sys_filename_suffix eval .eval) True) -; - (= - (sys_filename_suffix record .rec) True) -; - - - - - (= - (sys-suffixed-filename $File $Sys $Name) - ( (sys-filename-suffix $Sys $Suf) (suffixed-filename $File $Suf $Name))) -; + (= (sys-suffixed-filename $File $Sys $Name) + (sys-filename-suffix $Sys $Suf) + (suffixed-filename $File $Suf $Name)) - (= - (suffixed-filename $File $Suf $Name) + (= (suffixed-filename $File $Suf $Name) (bi-concat $File $Suf $Name)) -; - - (= - (find-suffixed-library-file $Name $Suffix $File) - ( (nofileerrors) - (sys-suffixed-filename $Name $Suffix $File1) - (exists-absolute-file-name - (library $File1) $File) - (set-det) - (fileerrors))) -; - - (= - (find-suffixed-library-file $Name $Suffix $File) - ( (fileerrors) - (format "~nError: Couldn't find file ~w.~p~n" - (:: $Name $Suffix)) - (fail))) -; - + (= (find-suffixed-library-file $Name $Suffix $File) + (nofileerrors) + (sys-suffixed-filename $Name $Suffix $File1) + (exists-absolute-file-name + (library $File1) $File) + (set-det) + (fileerrors)) + (= (find-suffixed-library-file $Name $Suffix $File) + (fileerrors) + (format "~nError: Couldn't find file ~w.~p~n" + (:: $Name $Suffix)) + (fail)) ; -; - +; ---------------------------------------- ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ; loading parts of the system ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Files defined by player system ; -; - +; and other systems, are ; -; - +; now in player_files.pl - (= - (load-main-system-files) + (= (load-main-system-files) (compile (library player-files))) -; - ; -; - +; LOAD_METAGAME ; -; - +; This should be called from the directory in which the ; -; - - - (= - (load-metagame) - ( (bind-environment-paths) - (load-main-system-files) - (load-system library) - (load-system generator) - (load-system play) - (load-system analysis) - (compile-and-load-player) - (add-system-portrayals))) -; - +; player files reside. + (= (load-metagame) + (bind-environment-paths) + (load-main-system-files) + (load-system library) + (load-system generator) + (load-system play) + (load-system analysis) + (compile-and-load-player) + (add-system-portrayals)) - (= - (load-system $System) - ( (system-files $System $Files) (whenever (member $F $Files) (compile (library $F))))) -; + (= (load-system $System) + (system-files $System $Files) + (whenever + (member $F $Files) + (compile (library $F)))) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ; Saving system ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; SAVE_METAGAME ; -; - +; Defined differently for different MeTTa versions, ; -; - +; see the respective files. - (= - (enter-metagame) - ( (metagame-version $V) - (format '~nMETAGAME Game-Playing Workbench ~p~n' - (:: $V)) - (format 'Copyright (c) 1992 Barney D. Pell~n~n' Nil) - (unix (argv $Argv)) - (process-commands $Argv) - (metagame))) -; + (= (enter-metagame) + (metagame-version $V) + (format '~nMETAGAME Game-Playing Workbench ~p~n' + (:: $V)) + (format 'Copyright (c) 1992 Barney D. Pell~n~n' Nil) + (unix (argv $Argv)) + (process-commands $Argv) + (metagame)) - - (= - (process-commands $Argv) - ( (det-if-then-else - (append $_ - (Cons seed - (Cons $N $_)) $Argv) - (randomize $N) True) - (whenever - (, - (append $_ - (Cons $P - (Cons $V $_)) $Argv) - (parameter $P $_)) - (set-parameter $P $V)) - (whenever + (= (process-commands $Argv) + (det-if-then-else + (append $_ + (Cons seed + (Cons $N $_)) $Argv) + (randomize $N) True) + (whenever + (, (append $_ - (Cons file - (Cons $D $_)) $Argv) - (compile $D)))) -; - + (Cons $P + (Cons $V $_)) $Argv) + (parameter $P $_)) + (set-parameter $P $V)) + (whenever + (append $_ + (Cons file + (Cons $D $_)) $Argv) + (compile $D))) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ; modifying parameters ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (= - (set-parameter $P $V) + (= (set-parameter $P $V) (det-if-then-else - (remove-symbol &self + (remove-is-symbol &self (parameter $P $_)) - (add-symbol &self + (add-is-symbol &self (parameter $P $V)) (det-if-then otherwise (format 'Unknown parameter <~p>!~n' (:: $P))))) -; - - (= - (setp $P $V) + (= (setp $P $V) (set-parameter $P $V)) -; - ; -; - +; Adds a new parameter P, with initial value V. - (= - (add-parameter $P $V) - ( (remove-all-symbols &self - (parameter $P $_)) (add-symbol &self (parameter $P $V)))) -; - + (= (add-parameter $P $V) + ( (remove-all-atoms &self + (parameter $P $_)) (add-is-symbol &self (parameter $P $V)))) - (= - (change-parameter $P $Old $V) + (= (change-parameter $P $Old $V) (det-if-then-else - (remove-symbol &self + (remove-is-symbol &self (parameter $P $Old)) - (add-symbol &self + (add-is-symbol &self (parameter $P $V)) (det-if-then otherwise (format 'Unknown parameter <~p>!~n' (:: $P))))) -; - - (= - (show) + (= (show) (show-parameters)) -; + (= (show-parameters) + (listing parameter) + (getrand $R) + (format '~nrandom seed = ~p~n' + (:: $R))) - (= - (show-parameters) - ( (listing parameter) - (getrand $R) - (format '~nrandom seed = ~p~n' - (:: $R)))) -; - - - (= - (save-parameters) + (= (save-parameters) ( (findall (- $P $V) (parameter $P $V) $Params) - (remove-all-symbols &self + (remove-all-atoms &self (saved_parameters $_)) - (add-symbol &self + (add-is-symbol &self (saved_parameters $Params)))) -; - - (= - (restore-parameters) + (= (restore-parameters) (det-if-then-else - (remove-symbol &self + (remove-is-symbol &self (saved_parameters $Params)) (restore-parameters $Params) True)) -; - - - (= - (restore_parameters ()) True) -; - - (= - (restore-parameters (Cons (- $P $V) $Rest)) - ( (set-parameter $P $V) (restore-parameters $Rest))) -; + (= (restore_parameters ()) True) + (= (restore-parameters (Cons (- $P $V) $Rest)) + (set-parameter $P $V) + (restore-parameters $Rest)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ; modifying globals ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (= - (set-global $P $V) + (= (set-global $P $V) (det-if-then-else - (remove-symbol &self + (remove-is-symbol &self (global $P $_)) - (add-symbol &self + (add-is-symbol &self (global $P $V)) (det-if-then otherwise (format 'Unknown global <~p>!~n' (:: $P))))) -; - ; -; +; Adds a new global P, with initial value V. - - (= - (add-global $P $V) - ( (remove-all-symbols &self - (global $P $_)) (add-symbol &self (global $P $V)))) -; - + (= (add-global $P $V) + ( (remove-all-atoms &self + (global $P $_)) (add-is-symbol &self (global $P $V)))) - (= - (change-global $P $Old $V) + (= (change-global $P $Old $V) (det-if-then-else - (remove-symbol &self + (remove-is-symbol &self (global $P $Old)) - (add-symbol &self + (add-is-symbol &self (global $P $V)) (det-if-then otherwise (format 'Unknown global <~p>!~n' (:: $P))))) -; - - (= - (setg $P $V) - (set-global $P $V)) -; - + (= (setg $P $V) + (set-global $P $V)) - (= - (showg) + (= (showg) (show-globals)) -; - - - (= - (show-globals) - ( (listing global) - (getrand $R) - (format '~nrandom seed = ~p~n' - (:: $R)))) -; + (= (show-globals) + (listing global) + (getrand $R) + (format '~nrandom seed = ~p~n' + (:: $R))) - (= - (save-globals) + (= (save-globals) ( (findall (- $P $V) (global $P $V) $Params) - (remove-all-symbols &self + (remove-all-atoms &self (saved_globals $_)) - (add-symbol &self + (add-is-symbol &self (saved_globals $Params)))) -; - - (= - (restore-globals) + (= (restore-globals) (det-if-then-else - (remove-symbol &self + (remove-is-symbol &self (saved_globals $Params)) (restore-globals $Params) True)) -; - - - (= - (restore_globals ()) True) -; - - (= - (restore-globals (Cons (- $P $V) $Rest)) - ( (set-global $P $V) (restore-globals $Rest))) -; + (= (restore_globals ()) True) + (= (restore-globals (Cons (- $P $V) $Rest)) + (set-global $P $V) + (restore-globals $Rest)) ; -; - +; ================================================================================ ; -; - +; Verbosity ; -; - +; ================================================================================ ; -; - +; Some routines call the predicate VERBOSELY(Call) instead of call directly, ; -; +; which means only call when tracing mode set to verbose. - - (= - (verbosely $Call) + (= (verbosely $Call) (det-if-then-else verbose (call $Call) True)) -; - ; -; +; Might cause trouble later when want to use streams also. - - (= - (verbosely-format $String $Args) + (= (verbosely-format $String $Args) (verbosely (format $String $Args))) -; - - (= - (verbose) - ( (parameter verbosity $X) (> $X 0))) -; + (= (verbose) + (parameter verbosity $X) + (> $X 0)) - - (= - (set-verbose) + (= (set-verbose) (set-parameter verbosity 1)) -; - - (= - (set-quiet) + (= (set-quiet) (set-parameter verbosity 0)) -; - ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ; portrayals ; -; - - - - (= - (portray-conj (, $X $Y)) - ( (print $X) - (write ,) - (print $Y))) -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (portray-disj (or $X $Y)) - ( (print $X) - (write ; ) - (print $Y))) -; + (= (portray-conj (, $X $Y)) + (print $X) + (write ,) + (print $Y)) + (= (portray-disj (or $X $Y)) + (print $X) + (write ; ) + (print $Y)) - (= - (portray-if (= $X $Y)) - ( (write () - (writeq $X) - (write :-) - (print $Y) - (write )))) -; - - - (= - (portray-var $N) - ( (put 124) (write $N))) -; + (= (portray-if (= $X $Y)) + (write () + (writeq $X) + (write :-) + (print $Y) + (write ))) + (= (portray-var $N) + (put 124) + (write $N)) ; -; - +; portray square, player, piece, moving, game ; -; - +; defined in grammar.pl ; -; - +; Careful, if this is just an array but not a state, could really cause problems. ; -; - +; Thus, we should check this. So, we check that a player is in control. ; -; - - +; This could be cleaned up if we wrap a STATE around our states. - (= - (portray-state (state $S)) - ( (format "~n" Nil))) -; + (= (portray-state (state $S)) + (format "~n" Nil)) - (= - (add-portray $Func) + (= (add-portray $Func) ( (functor $Goal $Func 1) (arg 1 $Goal $Term) - (add-symbol &self + (add-is-symbol &self (:- (portray $Term) $Goal)))) -; + (= (system_portrayals (portray_conj portray_disj portray_if portray_var portray_piece portray_player portray_square portray_moving portray_game portray_state)) True) - (= - (system_portrayals - (portray_conj portray_disj portray_if portray_var portray_piece portray_player portray_square portray_moving portray_game portray_state)) True) -; + (= (add-system-portrayals) + (system-portrayals $Ps) + (add-portrayals $Ps)) - (= - (add-system-portrayals) - ( (system-portrayals $Ps) (add-portrayals $Ps))) -; - - - - (= - (add-portrayals $Ps) + (= (add-portrayals $Ps) (whenever (member $P $Ps) (add-portray $P))) -; - diff --git a/metagame/play/value.metta b/metagame/play/value.metta index e447657..f5c186c 100644 --- a/metagame/play/value.metta +++ b/metagame/play/value.metta @@ -1,1381 +1,868 @@ +; (convert_to_metta_file value $_70984 metagame/play/value.pl metagame/play/value.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; value.pl ; -; - +; ============================================================================= ; -; - +; Loading evaluation files ; -; - +; ============================================================================= ; -; - +; LOAD_EVAL(+GameName) ; -; - +; Finds a file GameName.eval in a library directory. ; -; +; Then loads this file as the current evaluation function. - - (= - (load-eval $Name) - ( (find-eval-file $Name $File) (file-make-test-eval $File))) -; + (= (load-eval $Name) + (find-eval-file $Name $File) + (file-make-test-eval $File)) - - (= - (find-eval-file $Name $File) + (= (find-eval-file $Name $File) (find-suffixed-library-file $Name eval $File)) -; - ; -; - +; Maybe abolishing these is a bit strict, should ; -; - - - (= - (file-make-test-eval $File) - ( (abolish (/ piece-value 2)) - (abolish (/ piece-square-value 2)) - (compile $File))) -; +; just turn off redefinitions ... + (= (file-make-test-eval $File) + (abolish (/ piece-value 2)) + (abolish (/ piece-square-value 2)) + (compile $File)) ; -; - +; ============================================================================= ; -; - +; Search-Specific Predicates used in search engine ; -; - +; ============================================================================= ; -; - +; --------------------------------------- ; -; - +; SUCCESSOR_POS(Move,State,State2,Tables) ; -; - +; --------------------------------------- ; -; - +; External predicate used by alphabeta search engine. ; -; - +; Backtracks over all successor STATE2 reachable from STATE. ; -; - +; Move should be a unique name of this transition. ; -; +; Uses evaluation tables. - - (= - (successor-pos $Move $State $State2 $Tables) + (= (successor-pos $Move $State $State2 $Tables) (legal $Move $State $State2)) -; - ; -; - +; ----------------------------------- ; -; - +; TERMINAL_POS_VALUE(Pos,Val,Tables) ; -; - +; ----------------------------------- ; -; - +; External predicate for alphabeta code. ; -; - +; Returns a Val for a Pos if it is terminal, fails otherwise. ; ; - - (= - (terminal-pos-value $Pos $Val $Tables) + (= (terminal-pos-value $Pos $Val $Tables) (terminal-game-outcome $Pos $Val)) -; - ; -; - +; value-of-outcome defined in alphabeta.pl ; ; - - (= - (terminal-game-outcome $Pos $Val) - ( (game-outcome $Outcome $Pos) - (value-of-outcome $Outcome $Val) - (set-det))) -; - + (= (terminal-game-outcome $Pos $Val) + (game-outcome $Outcome $Pos) + (value-of-outcome $Outcome $Val) + (set-det)) ; -; - +; ------------------------- ; -; - +; STATICVAL(Pos,Val,Tables) ; -; - +; ------------------------- ; -; - +; This defines the external predicate for search engine. ; -; - +; Determines what evaluation procedure will be used. ; ; - - (= - (staticval $Pos $Val $Tables) + (= (staticval $Pos $Val $Tables) (evaluation $Val $Pos $Tables)) -; - ; -; - +; ------------------ ; -; - +; staticval(Pos,Val) ; -; - - (= - (staticval $Pos $Val) +; ------------------ + (= (staticval $Pos $Val) (evaluation $Val $Pos)) -; - ; -; - +; ============================================================================= ; -; - +; Defining value function for Symmetric Chess-Like Games ; -; - +; ============================================================================= ; -; - +; Each advisor is a separate rule making a comment about a position. ; -; - +; They all contribute their advice to the position. ; -; - +; These advices are then weighed appropriately (by the mediation routine), ; -; - +; and then summed to give the final value of the position. ; -; - +; [Note: the term "advices" is due to: ; -; - +; Professor Professor H. J. van den Herik. ; -; +; This may or may not be an official word in the English language.] + (= (evaluation $Value $Position) + (find-advice-tables $Tables) + (evaluation $Value $Position $Tables)) - (= - (evaluation $Value $Position) - ( (find-advice-tables $Tables) (evaluation $Value $Position $Tables))) -; - - - (= - (evaluation $Value $Position $Tables) - ( (get-advices $Advice $Position $Tables) (mediate-advices $Advice $Value $Tables))) -; - + (= (evaluation $Value $Position $Tables) + (get-advices $Advice $Position $Tables) + (mediate-advices $Advice $Value $Tables)) ; -; - +; Like the global version, but just considers the evaluation if ; -; - +; Piece were to be on Sq in the Position. ; -; - +; It might be worth actually pretending to put the piece there ; -; - - - (= - (local-evaluation $Piece $Sq $Value $Position $Tables) - ( (get-local-advices $Piece $Sq $Advice $Position $Tables) (mediate-advices $Advice $Value $Tables))) -; +; to be more accurate, but that is somewhat more costly. + (= (local-evaluation $Piece $Sq $Value $Position $Tables) + (get-local-advices $Piece $Sq $Advice $Position $Tables) + (mediate-advices $Advice $Value $Tables)) - (= - (get-advices $Advices $Position) - ( (find-advice-tables $Tables) (get-advices $Advices $Position $Tables))) -; - + (= (get-advices $Advices $Position) + (find-advice-tables $Tables) + (get-advices $Advices $Position $Tables)) - (= - (get-advices $Advices $Position $Tables) + (= (get-advices $Advices $Position $Tables) (findall $Advice (, (add-dynamic-tables $Position $Tables) (value $Advice $Position $Tables)) $Advices)) -; - - (= - (get-local-advices $Piece $Sq $Advices $Position $Tables) + (= (get-local-advices $Piece $Sq $Advices $Position $Tables) (findall $Advice (value $Piece $Sq $Advice $Position $Tables) $Advices)) -; +; ; bagof(Advice, + (= (show-advices-name $PosName) + (checkpoint $PosName $Pos) + (show-advices $Pos)) - (= - (show-advices-name $PosName) - ( (checkpoint $PosName $Pos) (show-advices $Pos))) -; + (= (show-advices $Pos) + (get-advices $As $Pos) + (ppl $As)) + (= (show-advices $Pos $Tables) + (get-advices $As $Pos $Tables) + (ppl $As)) - (= - (show-advices $Pos) - ( (get-advices $As $Pos) (ppl $As))) -; - (= - (show-advices $Pos $Tables) - ( (get-advices $As $Pos $Tables) (ppl $As))) -; - - - - - (= - (show-local-advices $Piece $Sq $Pos) - ( (find-advice-tables $Tables) (show-local-advices $Piece $Sq $Pos $Tables))) -; - - - - (= - (show-local-advices $Piece $Sq $Pos $Tables) - ( (on $Piece $Sq $Pos) - (get-local-advices $Piece $Sq $Advices $Pos $Tables) - (ppl $Advices))) -; - + (= (show-local-advices $Piece $Sq $Pos) + (find-advice-tables $Tables) + (show-local-advices $Piece $Sq $Pos $Tables)) + (= (show-local-advices $Piece $Sq $Pos $Tables) + (on $Piece $Sq $Pos) + (get-local-advices $Piece $Sq $Advices $Pos $Tables) + (ppl $Advices)) - (= - (mediate-advices $Advices $Value $Tables) - ( (weigh-advices $Advices $Vals $Tables) (sumlist $Vals $Value))) -; - - (= - (weigh_advices () () $_) True) -; + (= (mediate-advices $Advices $Value $Tables) + (weigh-advices $Advices $Vals $Tables) + (sumlist $Vals $Value)) - (= - (weigh-advices - (Cons $A $As) - (Cons $V $Vals) $Tables) - ( (weigh-advice $A $V $Tables) (weigh-advices $As $Vals $Tables))) -; + (= (weigh_advices () () $_) True) + (= (weigh-advices (Cons $A $As) (Cons $V $Vals) $Tables) + (weigh-advice $A $V $Tables) + (weigh-advices $As $Vals $Tables)) - (= - (weigh-advice - (advice $Advisor $Comment $V) $Val $Tables) - ( (advisor-weight $Advisor $Weight $Tables) (is $Val (* $V $Weight)))) -; - + (= (weigh-advice (advice $Advisor $Comment $V) $Val $Tables) + (advisor-weight $Advisor $Weight $Tables) + (is $Val + (* $V $Weight))) ; -; +; Change this to use tables explicitly. - - (= - (advisor-weight $Advisor $Weight $Tables) + (= (advisor-weight $Advisor $Weight $Tables) (parameter $Advisor $Weight)) -; - - (= - (advisor $A $B) + (= (advisor $A $B) (dynamic-advisor $A $B)) -; - - (= - (advisor $A $B) + (= (advisor $A $B) (static-advisor $A $B)) -; - - - - - (= - (dynamic_advisor gen_material 0) True) -; - - (= - (dynamic_advisor material 0) True) -; - - (= - (dynamic_advisor square 0) True) -; - - (= - (dynamic_advisor lthreat 0) True) -; - - (= - (dynamic_advisor potent 0) True) -; - - (= - (dynamic_advisor dynamic_mobility 0) True) -; - - - (= - (dynamic_advisor gmovmob 0) True) -; - - (= - (dynamic_advisor gcapmob 0) True) -; - - (= - (dynamic_advisor gthreat 0) True) -; - - (= - (dynamic_advisor pthreat 0) True) -; - - - (= - (dynamic_advisor static_mobility 0) True) -; - - (= - (dynamic_advisor eventual_mobility 0) True) -; - - (= - (dynamic_advisor arrive_distance 0) True) -; - - (= - (dynamic_advisor promote_distance 0) True) -; - - (= - (dynamic_advisor possess 0) True) -; - - (= - (dynamic_advisor initprom 0) True) -; - -; -; - - (= - (dynamic_advisor eradicate 0) True) -; - - (= - (dynamic_advisor vital 0) True) -; - - - - (= - (static_advisor random 0) True) -; - - (= - (static_advisor static 0) True) -; - - (= - (static_advisor victims 0) True) -; - - (= - (static_advisor max_static_mob 0) True) -; - - (= - (static_advisor max_eventual_mob 0) True) -; - - (= - (static_advisor avg_static_mob 0) True) -; - - (= - (static_advisor avg_eventual_mob 0) True) -; - - (= - (static_advisor eradicate 0) True) -; - - (= - (static_advisor stalemate 0) True) -; - - (= - (static_advisor arrive 0) True) -; - - (= - (static_advisor giveaway 0) True) -; - - (= - (static_advisor immunity 0) True) -; - -; -; - - - - - (= - (initialize-advisors) - ( (whenever - (advisor $Name $Default) - (add-parameter $Name $Default)) (add-symbol &self initialized_advisors))) -; - - - - (= - (active-parameter $P) - ( (advisor $P $_) - (parameter $P $Val) - (\== $Val 0))) -; - - - - !(det-if-then-else - (current-predicate initialized-advisors $_) True initialize-advisors) -; - - - -; -; - -; -; - -; -; - - - - (= - (movtable) - (det-if-then - (, - (needs-movtable $Param) - (active-parameter $Param)) True)) -; - - - - (= - (needs_movtable dynamic_mobility) True) -; - - (= - (needs_movtable gmovmob) True) -; - - - - - (= - (captable) - (det-if-then - (, - (needs-captable $Param) - (active-parameter $Param)) True)) -; - - -; -; - - - (= - (needs_captable gcapmob) True) -; - - (= - (needs_captable vital) True) -; - - (= - (needs_captable gthreat) True) -; - - (= - (needs_captable pthreat) True) -; - - (= - (needs_captable lthreat) True) -; - - (= - (needs_captable gcapmob) True) -; - - (= - (needs_captable eradicate) True) -; - - (= - (needs_captable potent) True) -; - - - -; -; - -; -; - -; -; -; -; - - - (= - (value - (advice gmovmob $Player $Value) $Position $Tables) - ( (active-parameter gmovmob) - (gmobility $Player $Val $Position $Tables) - (negate-for-player $Player $Val $Value))) -; - - - -; -; - - (= - (value - (advice gcapmob $Player $Value) $Position $Tables) - ( (active-parameter gcapmob) - (gcapmobility $Player $Val1 $Position $Tables) - (favor-control $Player $Val1 $Val $Position) - (negate-for-player $Player $Val $Value))) -; - - -; -; - - (= - (value - (advice gthreat $Player $Value) $Position $Tables) - ( (active-parameter gthreat) (gthreat $Player $Value $Position $Tables))) -; - - -; -; - - (= - (value - (advice pthreat $Player $Value) $Position $Tables) - ( (active-parameter pthreat) (pthreat $Player $Value $Position $Tables))) -; - - - -; -; - - (= - (value $Value $Position $Tables) - ( (active-parameter possess) - (in-hand $Piece $Player $Position) - (not (still-assigning $Position)) - (current-predicate possess-value - (possess-value $_ $_ $_ $_ $_)) - (possess-value $Piece $Player $Value $Position $Tables))) -; - - -; -; - -; -; - - (= - (value $Value $Position $Tables) - ( (active-parameter initprom) - (current-predicate initprom-value - (initprom-value $Value $Position $Tables)) - (initprom-value $Value $Position $Tables))) -; - - -; -; + (= (dynamic_advisor gen_material 0) True) + (= (dynamic_advisor material 0) True) + (= (dynamic_advisor square 0) True) + (= (dynamic_advisor lthreat 0) True) + (= (dynamic_advisor potent 0) True) + (= (dynamic_advisor dynamic_mobility 0) True) -; -; + (= (dynamic_advisor gmovmob 0) True) + (= (dynamic_advisor gcapmob 0) True) + (= (dynamic_advisor gthreat 0) True) + (= (dynamic_advisor pthreat 0) True) + (= (dynamic_advisor static_mobility 0) True) + (= (dynamic_advisor eventual_mobility 0) True) + (= (dynamic_advisor arrive_distance 0) True) + (= (dynamic_advisor promote_distance 0) True) + (= (dynamic_advisor possess 0) True) + (= (dynamic_advisor initprom 0) True) ; -; +; dynamic_advisor(dominate,0). + (= (dynamic_advisor eradicate 0) True) + (= (dynamic_advisor vital 0) True) - (= - (value - (advice vital - (, $Goal - (@ $Piece $Square)) $Value) $Position $Tables) - ( (active-parameter vital) (threatened-vital-piece-value $Piece $Square $Player $Goal $Value $Position $Tables))) -; + (= (static_advisor random 0) True) + (= (static_advisor static 0) True) + (= (static_advisor victims 0) True) + (= (static_advisor max_static_mob 0) True) + (= (static_advisor max_eventual_mob 0) True) + (= (static_advisor avg_static_mob 0) True) + (= (static_advisor avg_eventual_mob 0) True) + (= (static_advisor eradicate 0) True) + (= (static_advisor stalemate 0) True) + (= (static_advisor arrive 0) True) + (= (static_advisor giveaway 0) True) + (= (static_advisor immunity 0) True) +; +; advisor(,0). -; -; + (= (initialize-advisors) + ( (whenever + (advisor $Name $Default) + (add-parameter $Name $Default)) (add-is-symbol &self initialized_advisors))) -; -; -; -; + (= (active-parameter $P) + (advisor $P $_) + (parameter $P $Val) + (\== $Val 0)) - (= - (value - (advice random - (range $Min $Max) $Value) $Position $Tables) - ( (active-parameter random) (random-eval $Min $Max $Value))) -; + !(det-if-then-else + (current-predicate initialized-advisors $_) True initialize-advisors) ; -; - +; ---------------------------------------- ; -; +; Advisor requirements +; +; ---------------------------------------- - (= - (value $Value $Position $Tables) - ( (on $Piece $Player $Square $Position) (value $Piece $Square $Value $Position $Tables))) -; + (= (movtable) + (det-if-then + (, + (needs-movtable $Param) + (active-parameter $Param)) True)) + (= (needs_movtable dynamic_mobility) True) + (= (needs_movtable gmovmob) True) -; -; -; -; + (= (captable) + (det-if-then + (, + (needs-captable $Param) + (active-parameter $Param)) True)) ; -; +; needs_captable(threat). + (= (needs_captable gcapmob) True) + (= (needs_captable vital) True) + (= (needs_captable gthreat) True) + (= (needs_captable pthreat) True) + (= (needs_captable lthreat) True) + (= (needs_captable gcapmob) True) + (= (needs_captable eradicate) True) + (= (needs_captable potent) True) -; -; ; -; - +; ---------------------------------------- ; -; - +; VALUE/3 ; -; - - (= - (value $Piece $Sq - (advice gen-material $Type $Val) $Position $Tables) - ( (active-parameter gen-material) (gen-material-value $Piece $Player $Type $Val))) -; +; ---------------------------------------- +; +; Global moving mobility + (= (value (advice gmovmob $Player $Value) $Position $Tables) + (active-parameter gmovmob) + (gmobility $Player $Val $Position $Tables) + (negate-for-player $Player $Val $Value)) + ; -; +; Global capturing mobility + (= (value (advice gcapmob $Player $Value) $Position $Tables) + (active-parameter gcapmob) + (gcapmobility $Player $Val1 $Position $Tables) + (favor-control $Player $Val1 $Val $Position) + (negate-for-player $Player $Val $Value)) ; -; +; Global Threats + (= (value (advice gthreat $Player $Value) $Position $Tables) + (active-parameter gthreat) + (gthreat $Player $Value $Position $Tables)) ; -; - - (= - (value $Piece $Square - (advice static $Piece $Value) $Pos $Tables) - ( (active-parameter static) (piece-player-static $Piece $Player $Value $Tables))) -; - +; Best Potent Threat + (= (value (advice pthreat $Player $Value) $Position $Tables) + (active-parameter pthreat) + (pthreat $Player $Value $Position $Tables)) ; -; - - (= - (value $Piece $Square - (advice dynamic-mobility - (@ $Piece $Square) $Value) $Position $Tables) - ( (active-parameter dynamic-mobility) - (active-advisor dynamic-mobility $Tables) - (dynamic-piece-mobility $Piece $Square $Value $Position $Tables))) -; +; One source of value comes from POSSESSING a piece. + (= (value $Value $Position $Tables) + (active-parameter possess) + (in-hand $Piece $Player $Position) + (not (still-assigning $Position)) + (current-predicate possess-value + (possess-value $_ $_ $_ $_ $_)) + (possess-value $Piece $Player $Value $Position $Tables)) +; +; One source of value comes from being able to +; +; OPPONENT-PROMOTE a piece. + (= (value $Value $Position $Tables) + (active-parameter initprom) + (current-predicate initprom-value + (initprom-value $Value $Position $Tables)) + (initprom-value $Value $Position $Tables)) ; -; +; VITAL +; +; Losing points when our vital pieces (those enemy wants to remove and is near +; +; to achieving) are threatened. + (= (value (advice vital (, $Goal (@ $Piece $Square)) $Value) $Position $Tables) + (active-parameter vital) + (threatened-vital-piece-value $Piece $Square $Player $Goal $Value $Position $Tables)) - (= - (value $Piece $Square - (advice static-mobility - (@ $Piece $Square) $Value) $Position $Tables) - ( (active-parameter static-mobility) (static-piece-mobility $Piece $Square $Value $Position $Tables))) -; ; -; - - (= - (value $Piece $Square - (advice eventual-mobility - (@ $Piece $Square) $Value) $Position $Tables) - ( (active-parameter eventual-mobility) (eventual-piece-mobility $Piece $Square $Value $Position $Tables))) -; +; RANDOM +; +; Augments a position's evaluation by a random number in the range +; +; [MIN,MAX] as set by the parameters RANDOM_MIN and RANDOM_MAX. + (= (value (advice random (range $Min $Max) $Value) $Position $Tables) + (active-parameter random) + (random-eval $Min $Max $Value)) ; -; - +; One source of value comes from having a piece on a square. ; -; +; Using on/4 here ensures it is a piece struct instead of empty. + (= (value $Value $Position $Tables) + (on $Piece $Player $Square $Position) + (value $Piece $Square $Value $Position $Tables)) - (= - (value $Piece $Square - (advice lthreat - (captures - (@ $Piece $Square) - (@ $PieceV $SqV)) $Value) $Position $Tables) - ( (active-parameter lthreat) - (active-advisor threat $Tables) - (local-threat-value $Piece $Square $PieceV $SqV $Value $Position $Tables))) -; ; -; +; ---------------------------------------- +; +; VALUE/5 +; +; ---------------------------------------- - (= - (value $Piece $Square - (advice potent - (captures - (@ $Piece $Square) - (@ $PieceV $SqV)) $Value) $Position $Tables) - ( (active-parameter potent) - (active-advisor threat $Tables) - (potent-threat-mover $Piece $Square $PieceV $SqV $Value $Position $Tables))) +; +; General material: 1 point for player's piece, -1 for opponents. +; +; value(piece(Type,player),_Square,advice(gen_material,Type,1),_Position,_Tables). +; +; value(piece(Type,opponent),_Square,advice(gen_material,Type,-1),_Position,_Tables). +; ; - - + (= (value $Piece $Sq (advice gen-material $Type $Val) $Position $Tables) + (active-parameter gen-material) + (gen-material-value $Piece $Player $Type $Val)) ; -; +; INDEPENDENT STATIC PIECE VALUE +; +; This isn't the right way to do this (use table instead), but for now +; +; will cut down on extra eval stuff. + (= (value $Piece $Square (advice static $Piece $Value) $Pos $Tables) + (active-parameter static) + (piece-player-static $Piece $Player $Value $Tables)) +; ; independent_advice(_Player,Piece,Advice). - (= - (value $Piece $Square - (advice arrive-distance - (, $Goal - (@ $Piece $Square) $SqT) $Value) $Position $Tables) - ( (active-parameter arrive-distance) (arrive-value $Piece $Square $SqT $Goal $Value $Position $Tables))) -; +; +; Dynamic Piece mobility + (= (value $Piece $Square (advice dynamic-mobility (@ $Piece $Square) $Value) $Position $Tables) + (active-parameter dynamic-mobility) + (active-advisor dynamic-mobility $Tables) + (dynamic-piece-mobility $Piece $Square $Value $Position $Tables)) ; -; +; Static piece mobility + (= (value $Piece $Square (advice static-mobility (@ $Piece $Square) $Value) $Position $Tables) + (active-parameter static-mobility) + (static-piece-mobility $Piece $Square $Value $Position $Tables)) - (= - (value $Piece $Square - (advice promote-distance - (, - (@ $Piece $Square) $SqT) $Value) $Position $Tables) - ( (active-parameter promote-distance) - (active-advisor prom $Tables) - (prom-value $Piece $Square $SqT $Value $Position $Tables))) -; +; +; Eventual piece mobility + (= (value $Piece $Square (advice eventual-mobility (@ $Piece $Square) $Value) $Position $Tables) + (active-parameter eventual-mobility) + (eventual-piece-mobility $Piece $Square $Value $Position $Tables)) +; ; current_predicate(eventual_piece_mobility,_), +; +; Piece attacks +; +; Now *requires* that the opponent have the tables constructed. + (= (value $Piece $Square (advice lthreat (captures (@ $Piece $Square) (@ $PieceV $SqV)) $Value) $Position $Tables) + (active-parameter lthreat) + (active-advisor threat $Tables) + (local-threat-value $Piece $Square $PieceV $SqV $Value $Position $Tables)) ; -; +; Potent Threats + (= (value $Piece $Square (advice potent (captures (@ $Piece $Square) (@ $PieceV $SqV)) $Value) $Position $Tables) + (active-parameter potent) + (active-advisor threat $Tables) + (potent-threat-mover $Piece $Square $PieceV $SqV $Value $Position $Tables)) - (= - (value $Piece $Square - (advice dominate - (, $Goal - (@ $Piece $Square) - (@ $PieceV $SqV)) $Value) $Position $Tables) - ( (active-parameter dominate) (dominate-value $Piece $Square $PieceV $SqV $Goal $Value $Position $Tables))) -; ; -; +; Arrive Distance + (= (value $Piece $Square (advice arrive-distance (, $Goal (@ $Piece $Square) $SqT) $Value) $Position $Tables) + (active-parameter arrive-distance) + (arrive-value $Piece $Square $SqT $Goal $Value $Position $Tables)) +; ; current_predicate(_,arrive_value(_,_,_,_,_,_)), ; -; - - (= - (value $Piece $Square - (advice dominate - (, $Goal - (@ $Piece $Square)) $Value) $Position $Tables) - ( (active-parameter dominate) (eradicate-safety $Player $Piece $Square $Goal $Value $Position $Tables))) -; - +; Promotion Distance + (= (value $Piece $Square (advice promote-distance (, (@ $Piece $Square) $SqT) $Value) $Position $Tables) + (active-parameter promote-distance) + (active-advisor prom $Tables) + (prom-value $Piece $Square $SqT $Value $Position $Tables)) +; ; current_predicate(_,prom_value(_,_,_,_,_)), ; -; +; Domination Value (not supported) + (= (value $Piece $Square (advice dominate (, $Goal (@ $Piece $Square) (@ $PieceV $SqV)) $Value) $Position $Tables) + (active-parameter dominate) + (dominate-value $Piece $Square $PieceV $SqV $Goal $Value $Position $Tables)) +; ; current_predicate(_,dominate_value(_,_,_,_,_,_,_)), - (= - (value $Piece $Square - (advice material $Piece $Value) $Position $Tables) - ( (active-parameter material) - (current-predicate $_ - (piece-value $_ $_)) - (piece-value $Piece $Value))) -; +; +; Eradicating enemy pieces +; +; Call this dominate advisor here, as we use static eradicate in step.pl + (= (value $Piece $Square (advice dominate (, $Goal (@ $Piece $Square)) $Value) $Position $Tables) + (active-parameter dominate) + (eradicate-safety $Player $Piece $Square $Goal $Value $Position $Tables)) +; ; active_advisor(prom,Tables), ; current_predicate(_,prom_value(_,_,_,_,_)), ; -; +; Specific material: refers to table. + (= (value $Piece $Square (advice material $Piece $Value) $Position $Tables) + (active-parameter material) + (current-predicate $_ + (piece-value $_ $_)) + (piece-value $Piece $Value)) - (= - (value $Piece $Square - (advice square - (@ $Piece $Square) $Value) $Position $Tables) - ( (active-parameter square) (piece-square-value $Piece $Square $Value $Tables))) -; +; +; Piece-Square tables + (= (value $Piece $Square (advice square (@ $Piece $Square) $Value) $Position $Tables) + (active-parameter square) + (piece-square-value $Piece $Square $Value $Tables)) +; ; current_predicate(_,piece_square_value(_,_,_)), ; -; - +; ============================================================================ ; -; - +; Specific Piece-value tables ; -; - +; ============================================================================ ; -; - +; To change this for another game, make a new file containing just ; -; - +; facts like these but with piece names specialized for your new game. ; -; - +; Then load this file separately. ; -; - +; Examples files are games/chess.eval, and games/turncoat.eval - (= - (random-eval $Min $Max $Value) - ( (parameter random-min $Min) - (parameter random-max $Max) - (random $Min $Max $Value))) -; - + (= (random-eval $Min $Max $Value) + (parameter random-min $Min) + (parameter random-max $Max) + (random $Min $Max $Value)) +; /* piece_value(piece(king,player),15). piece_value(piece(king,opponent),-15). piece_value(piece(queen,player),9). piece_value(piece(queen,opponent),-9). piece_value(piece(rook,player),5). piece_value(piece(rook,opponent),-5). piece_value(piece(night,player),3). piece_value(piece(night,opponent),-3). piece_value(piece(bishop,player),3.25). piece_value(piece(bishop,opponent),-3.25). piece_value(piece(pawn,player),1). piece_value(piece(pawn,opponent),-1). */ +; ;============================================================================ ; Piece-Square tables ;============================================================================ ; This model is again for chess. Make a separate file containing ; just rules of these types for your game, and load it. ; This could of course be the same file at that used for specific ; piece material values above. +; /* ; Piece-Square tables piece_square_value(piece(night,player),square(4,4),2). piece_square_value(piece(night,player),square(1,1),-5). ; Pawns given value as they move closer to their promotion ; rank. piece_square_value(piece(pawn,player),square(_X,Y),Val) :- Val is (Y-1)/6. piece_square_value(piece(pawn,opponent),square(_X,Y),Val) :- Val is (Y-8)/6. */ +; ;-------------------------------------------------------------------------------- ; Support routines ;-------------------------------------------------------------------------------- +; ; RANDOM_EVAL ; Augments a position's evaluation by a random number in the range ; [MIN,MAX] as set by the parameters RANDOM_MIN and RANDOM_MAX. ; -; - - - (= - (gen-material-value $Piece $Player $Type $Val) - ( (owns $Piece $Player) - (piece-name $Piece $Type) - (negate-for-player $Player 1 $Val))) -; +; +1 if piece owned by white, -1 if owned by black. + (= (gen-material-value $Piece $Player $Type $Val) + (owns $Piece $Player) + (piece-name $Piece $Type) + (negate-for-player $Player 1 $Val)) ; -; - +; Dynamic Piece Mobility ; -; - +; Only returns advice for pieces with non-0 value. ; -; - - - (= - (dynamic-piece-mobility $Piece $Square $Value $Position $Tables) - ( (owns $Piece $Player) - (dynamic-piece-mob $Piece $Player $Square $Val $Position $Tables) - (> $Val 0) - (negate-for-player $Player $Val $Value))) -; +; To just count the moves a piece has, use dynamic_piece_mob. + (= (dynamic-piece-mobility $Piece $Square $Value $Position $Tables) + (owns $Piece $Player) + (dynamic-piece-mob $Piece $Player $Square $Val $Position $Tables) + (> $Val 0) + (negate-for-player $Player $Val $Value)) ; -; - +; Note: this currently uses dynamic moving tables. It will ; -; - +; thus only return values for pieces actually on the board. ; -; - +; (We know the tables exist by this point, because of the requires ; -; - +; statement declaring that this advisor needs moving tables. ; ; - ; -; - +; What we should really do is: ; -; - +; 1. Check if tables exist, and piece in current position, whenever call ; -; - +; things which might be used locally. ; -; - +; 2. If either not true, compute it ourself. ; ; - ; -; - +; However, this is not a problem in the current architecture, because: ; -; - +; a. local eval only used in threat and promotion analysis. ; -; - +; b. In threat anal, we know the piece is on the square already. ; -; - +; c. In prom analysis, we shutdown dynamic mob, because don't have time! ; -; - +; So, if we ever change this for prom analysis, we must incorporate the ; -; - +; change above. This is easy, but slows things down a little bit. ; ; - - (= - (dynamic-piece-mob $Piece $Player $Square $Count $Position $Tables) - ( (moving-table $Tables $Moves) - (unique-moves $Player $Piece $Square $SqT $Moves $Targets) - (length $Targets $Count) - (tracing-path-format moves "Dynamic: <~p>: ~p -> ~p~n" - (:: $Piece $Square $Count)))) -; - + (= (dynamic-piece-mob $Piece $Player $Square $Count $Position $Tables) + (moving-table $Tables $Moves) + (unique-moves $Player $Piece $Square $SqT $Moves $Targets) + (length $Targets $Count) + (tracing-path-format moves "Dynamic: <~p>: ~p -> ~p~n" + (:: $Piece $Square $Count))) ; -; - - - (= - (static-piece-mobility $Piece $Square $Value $Position $Tables) - ( (owns $Piece $Player) - (static-piece-mob $Piece $Player $Square $Val $Position $Tables) - (negate-for-player $Player $Val $Value))) -; +; Static Piece Mobility + (= (static-piece-mobility $Piece $Square $Value $Position $Tables) + (owns $Piece $Player) + (static-piece-mob $Piece $Player $Square $Val $Position $Tables) + (negate-for-player $Player $Val $Value)) - (= - (static-piece-mob $Piece $Player $Square $Value $Position $Tables) - ( (square-piece-mobility $Square $Piece $Value $Tables) (tracing-path-format static "In 1: <~p>: ~p -> ~p~n" (:: $Piece $Square $Value)))) -; - + (= (static-piece-mob $Piece $Player $Square $Value $Position $Tables) + (square-piece-mobility $Square $Piece $Value $Tables) + (tracing-path-format static "In 1: <~p>: ~p -> ~p~n" + (:: $Piece $Square $Value))) ; -; - - - (= - (eventual-piece-mobility $Piece $Square $Value $Position $Tables) - ( (owns $Piece $Player) - (eventual-piece-mob $Piece $Player $Square $Val $Position $Tables) - (negate-for-player $Player $Val $Value))) -; +; Eventual Piece Mobility + (= (eventual-piece-mobility $Piece $Square $Value $Position $Tables) + (owns $Piece $Player) + (eventual-piece-mob $Piece $Player $Square $Val $Position $Tables) + (negate-for-player $Player $Val $Value)) - (= - (eventual-piece-mob $Piece $Player $Square $Value $Position $Tables) - ( (square-piece-reachability $Square $Piece $Value $Tables) (tracing-path-format eventual "In 4: <~p>: ~p -> ~p~n" (:: $Piece $Square $Value)))) -; - + (= (eventual-piece-mob $Piece $Player $Square $Value $Position $Tables) + (square-piece-reachability $Square $Piece $Value $Tables) + (tracing-path-format eventual "In 4: <~p>: ~p -> ~p~n" + (:: $Piece $Square $Value))) ; -; - +; ================================================================================ ; -; - +; Generic 2-player-game Support Predicates ; -; - +; ================================================================================ - (= - (initiative-offset $Control $Player $Offset) + (= (initiative-offset $Control $Player $Offset) (det-if-then-else (= $Control $Player) (= $Offset 0.9) (= $Offset 0.7))) -; - - (= - (favor-control $Player $Val1 $Value $Position) - ( (control $Control $Position) - (initiative-offset $Control $Player $Offset) - (is $Value - (* $Val1 $Offset)))) -; - + (= (favor-control $Player $Val1 $Value $Position) + (control $Control $Position) + (initiative-offset $Control $Player $Offset) + (is $Value + (* $Val1 $Offset))) ; -; - +; The player will only execute the threat if doing so might net ; -; +; him an increase in value. - - (= - (favorable-to-owner player $Val) + (= (favorable-to-owner player $Val) (> $Val 0)) -; - - (= - (favorable-to-owner opponent $Val) + (= (favorable-to-owner opponent $Val) (< $Val 0)) -; - ; -; - +; How many moves extra it costs a player before it is his turn to ; -; - - - (= - (control-cost $Player $Cost $Position) - ( (control $Control $Position) (det-if-then-else (= $Control $Player) (= $Cost 0) (= $Cost 1)))) -; +; move. In 2-player game, just 0 or 1, of course. + (= (control-cost $Player $Cost $Position) + (control $Control $Position) + (det-if-then-else + (= $Control $Player) + (= $Cost 0) + (= $Cost 1))) - (= - (negate-if-same $Player1 $Player2 $Val1 $Val) + (= (negate-if-same $Player1 $Player2 $Val1 $Val) (det-if-then-else (\== $Player1 $Player2) (= $Val1 $Val) (is $Val (- $Val1)))) -; - - (= - (negate-if-different $Player1 $Player2 $Val1 $Val) + (= (negate-if-different $Player1 $Player2 $Val1 $Val) (det-if-then-else (= $Player1 $Player2) (= $Val1 $Val) (is $Val (- $Val1)))) -; - - - (= - (negate_for_player player $Val $Val) True) -; - (= - (negate-for-player opponent $Val $Val1) + (= (negate_for_player player $Val $Val) True) + (= (negate-for-player opponent $Val $Val1) (is $Val1 (- $Val))) -; - - (= - (negate-advice-for-player $Player - (advice $A $C $V) - (advice $A $C $V1)) + (= (negate-advice-for-player $Player (advice $A $C $V) (advice $A $C $V1)) (negate-for-player $Player $V $V1)) -; - ; -; +; Of some list of values, PLAYER wants the max, OPPONENT wants the min. - - (= - (max-for-player player $List $Best) + (= (max-for-player player $List $Best) (max $List $Best)) -; - - (= - (max-for-player opponent $List $Best) + (= (max-for-player opponent $List $Best) (min $List $Best)) -; - ; -; +; Of some list of values, PLAYER wants the min, OPPONENT wants the max. - - (= - (min-for-player player $List $Best) + (= (min-for-player player $List $Best) (min $List $Best)) -; - - (= - (min-for-player opponent $List $Best) + (= (min-for-player opponent $List $Best) (max $List $Best)) -; - ; -; - +; ================================================================================ ; -; - +; Interface ; -; +; ================================================================================ - - (= - (evalfile-top $Game) + (= (evalfile-top $Game) (load-eval $Game)) -; - - (= - (evalfile-com $_ $_ $_ $Game) + (= (evalfile-com $_ $_ $_ $Game) (load-eval $Game)) -; - - - - (= - (evaluate-com $Move $SIn $_) - ( (timing (evaluation $Value $SIn)) (format "Position's value (positive favors white): ~p~n" (:: $Value)))) -; + (= (evaluate-com $Move $SIn $_) + (timing (evaluation $Value $SIn)) + (format "Position's value (positive favors white): ~p~n" + (:: $Value))) - (= - (advice-com $Move $SIn $_) - ( (timing (get-advices $As $SIn)) (ppl $As))) -; - + (= (advice-com $Move $SIn $_) + (timing (get-advices $As $SIn)) + (ppl $As)) - (= - (advice-com $_ $SIn $SOut $Row $Col) - ( (with-alpha-squares (gsquare $Square (:: ( $Row , $Col )) Nil)) (timing (show-local-advices $Piece $Square $SIn)))) -; + (= (advice-com $_ $SIn $SOut $Row $Col) + (with-alpha-squares (gsquare $Square (:: ( $Row , $Col )) Nil)) + (timing (show-local-advices $Piece $Square $SIn))) - (= - (advisor-weight $Adv $Weight) - ( (advisor $Adv $_) (advisor-weight $Adv $Weight $_))) -; - - + (= (advisor-weight $Adv $Weight) + (advisor $Adv $_) + (advisor-weight $Adv $Weight $_)) - (= - (show-advisors) - ( (format "Advisors: ~n" Nil) (whenever (advisor-weight $Adv $Weight) (format "<~p>: ~p~n" (:: $Adv $Weight))))) -; + (= (show-advisors) + (format "Advisors: ~n" Nil) + (whenever + (advisor-weight $Adv $Weight) + (format "<~p>: ~p~n" + (:: $Adv $Weight)))) - (= - (alladvisors-com $_ $_ $_) + (= (alladvisors-com $_ $_ $_) (show-advisors)) -; - - (= - (alladvisors-top) + (= (alladvisors-top) (show-advisors)) -; - - (= - (seta-com $_ $_ $_) + (= (seta-com $_ $_ $_) (show-active-advisors)) -; - - (= - (seta-top) + (= (seta-top) (show-active-advisors)) -; - - (= - (active-com $_ $_ $_) + (= (active-com $_ $_ $_) (show-active-advisors)) -; - - (= - (active-top) + (= (active-top) (show-active-advisors)) -; - - (= - (show-active-advisors) - ( (format "Active Advisors: ~n" Nil) (whenever (, (advisor-weight $Adv $Weight) (\== $Weight 0)) (format "<~p>: ~p~n" (:: $Adv $Weight))))) -; - + (= (show-active-advisors) + (format "Active Advisors: ~n" Nil) + (whenever + (, + (advisor-weight $Adv $Weight) + (\== $Weight 0)) + (format "<~p>: ~p~n" + (:: $Adv $Weight)))) diff --git a/metagame/state/compile_syms.metta b/metagame/state/compile_syms.metta index 5d831fd..1bc81b1 100644 --- a/metagame/state/compile_syms.metta +++ b/metagame/state/compile_syms.metta @@ -1,182 +1,112 @@ +; (convert_to_metta_file compile_syms $_439786 metagame/state/compile_syms.pl metagame/state/compile_syms.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; compile_syms.pl ; -; - +; ; Compiling out symmetries and game definition to improve efficiency. ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Symmetries ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Computing closures of some set under a set of transformations. ; ; - ; -; - +; Agenda: List of items still to close. ; -; - +; Table: Those items already closed. ; -; - +; Begin with full agenda and empty table. ; -; - +; Repeat: ; -; - +; Take first item from agenda. ; -; - +; Apply Transforms to first item on agenda. ; -; - +; For each result not already in the table: ; -; - +; Add to table. ; -; - +; Add to agenda. ; -; - +; Until empty agenda. ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Symmetries ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (= - (sym-dir $Dir $Syms $DirOut) + (= (sym-dir $Dir $Syms $DirOut) (in-symmetric-closure $Dir $Syms $DirOut)) -; - +; /* The key property of symmetric closure: Init. current_dirs: [dir]. New_Current_dirs1 := Apply all syms to current_dirs. If new_dirs = current_dirs then done. Else loop. Result -> new_dirs. */ +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; IN_SYMMETRIC_CLOSURE(+Dir,+Syms,-DirOut) ; -; - - - (= - (in-symmetric-closure $Dir $Syms $DirOut) - ( (closure - (:: $Dir) $Syms $Dirs) (member $DirOut $Dirs))) -; +; DirOut is in the symmetric closure of Dir under Syms. + (= (in-symmetric-closure $Dir $Syms $DirOut) + (closure + (:: $Dir) $Syms $Dirs) + (member $DirOut $Dirs)) - (= - (closure $Set $Transforms $Closure) + (= (closure $Set $Transforms $Closure) (close1 $Set $Transforms $Set $Closure)) -; - - - - (= - (close1 () $_ $T $T) True) -; - - (= - (close1 - (Cons $A $As) $Ts $Table $Close) - ( (close-item $Ts $A $As $Table $NewAs $NewTable) (close1 $NewAs $Ts $NewTable $Close))) -; - - - (= - (close_item () $_ $As $T $As $T) True) -; - (= - (close-item - (Cons $T $Ts) $A $As $TIn $NewAs $TOut) - ( (transform-item $A $T $ATrans) - (schedule-if $ATrans $As $TIn $NewAs1 $T1) - (close-item $Ts $A $NewAs1 $T1 $NewAs $TOut))) -; + (= (close1 () $_ $T $T) True) + (= (close1 (Cons $A $As) $Ts $Table $Close) + (close-item $Ts $A $As $Table $NewAs $NewTable) + (close1 $NewAs $Ts $NewTable $Close)) + (= (close_item () $_ $As $T $As $T) True) + (= (close-item (Cons $T $Ts) $A $As $TIn $NewAs $TOut) + (transform-item $A $T $ATrans) + (schedule-if $ATrans $As $TIn $NewAs1 $T1) + (close-item $Ts $A $NewAs1 $T1 $NewAs $TOut)) - (= - (schedule-if $Item $As $Table $As $Table) - ( (member $Item $Table) (set-det))) -; - - (= - (schedule_if $Item $As $Table - (Cons $Item $As) - (Cons $Item $Table)) True) -; + (= (schedule-if $Item $As $Table $As $Table) + (member $Item $Table) + (set-det)) + (= (schedule_if $Item $As $Table (Cons $Item $As) (Cons $Item $Table)) True) - (= - (transform-item $Dir $Sym $NewDir) + (= (transform-item $Dir $Sym $NewDir) (symmetry $Sym $Dir $NewDir)) -; - - (= - (symmetry forward - (dir $X $Y) - (dir $X $Y1)) + (= (symmetry forward (dir $X $Y) (dir $X $Y1)) (negates $Y $Y1)) -; - - (= - (symmetry side - (dir $X $Y) - (dir $X1 $Y)) + (= (symmetry side (dir $X $Y) (dir $X1 $Y)) (negates $X $X1)) -; - - (= - (symmetry rotation - (dir $X $Y) - (dir $Y $X)) True) -; + (= (symmetry rotation (dir $X $Y) (dir $Y $X)) True) - - (= - (negates $N $N1) + (= (negates $N $N1) (| (det-if-then (var $N) @@ -185,62 +115,44 @@ (det-if-then otherwise (is $N1 (* $N -1))))) -; - ; -; - +; Interesting idea: Given move descriptions, locate symmetries, ; -; - +; by seeing if legality is invariant under these transformations! ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Compiling symmetries for a particular game ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (= - (game-movement $Game $Movement) - ( (game-piece-def $Game $_ $Def) (piece-defines-movement $Def $Movement))) -; + (= (game-movement $Game $Movement) + (game-piece-def $Game $_ $Def) + (piece-defines-movement $Def $Movement)) + (= (piece-defines-movement $Def $Movement) + (piece-movement $Def $CompMovement) + (movement-component $CompMovement $Movement)) + (= (piece-defines-movement $Def $M) + (piece-capture $Def $CompCapture) + (capture-component $CompCapture $Capture) + (capture-has-movement $Capture $M)) - (= - (piece-defines-movement $Def $Movement) - ( (piece-movement $Def $CompMovement) (movement-component $CompMovement $Movement))) -; - (= - (piece-defines-movement $Def $M) - ( (piece-capture $Def $CompCapture) - (capture-component $CompCapture $Capture) - (capture-has-movement $Capture $M))) -; + (= (game-syms-dir $Game $Syms $Dir) + (game-movement $Game $M) + (movement-dir $M $Dir) + (movement-syms $M $Syms)) - - (= - (game-syms-dir $Game $Syms $Dir) - ( (game-movement $Game $M) - (movement-dir $M $Dir) - (movement-syms $M $Syms))) -; - - - - (= - (unique-sym-dirs $SymDirs) + (= (unique-sym-dirs $SymDirs) (setof (- (- $Dir $Syms) $Sym) @@ -248,190 +160,135 @@ (, (some-player-game $Game) (game-sym-dir $Game $Dir $Syms $Sym))) $SymDirs)) -; - - (= - (game-sym-dir $Game $Dir $Syms $Sym) - ( (game-syms-dir $Game $Syms $Dir) (in-symmetric-closure $Dir $Syms $Sym))) -; - + (= (game-sym-dir $Game $Dir $Syms $Sym) + (game-syms-dir $Game $Syms $Dir) + (in-symmetric-closure $Dir $Syms $Sym)) - (= - (some-player-game $Game) + (= (some-player-game $Game) (or (player-current-game $Game) (opponent-current-game $Game))) -; - - (= - (index-sym-dirs) + (= (index-sym-dirs) (with-temp-file syms $File (, (index-sym-dirs-to-file $File) (compile $File)))) -; - - - - (= - (index-sym-dirs-to-file $File) - ( (format "~nIndexing Symmetries to file: ~w~n" - (:: $File)) - (assert-sym-indices) - (with-output-file $File write - (, - (print-sym-overwrite) - (listing sym-index) - (overwrite-game))) - (abolish (/ sym-index 3)))) -; - - - (= - (assert-sym-indices) - ( (abolish (/ sym-index 3)) - (unique-sym-dirs $Dirs) - (whenever - (member - (- - (- $Dir $Syms) $Sym) $Dirs) - (assert-sym-index $Dir $Syms $Sym)))) -; - - - - (= - (assert-sym-index $Dir $Syms $Sym) - ( (dir-key $Dir $Key) (add-symbol &self (sym_index $Key $Syms $Sym)))) -; - + (= (index-sym-dirs-to-file $File) + (format "~nIndexing Symmetries to file: ~w~n" + (:: $File)) + (assert-sym-indices) + (with-output-file $File write + (, + (print-sym-overwrite) + (listing sym-index) + (overwrite-game))) + (abolish (/ sym-index 3))) - (= - (print-all-syms) - ( (unique-sym-dirs $L) + (= (assert-sym-indices) + (abolish (/ sym-index 3)) + (unique-sym-dirs $Dirs) + (whenever (member (- - (- $Dir $_) $Sym) $L) - (format "~p --> ~p~n" - (:: $Dir $Sym)) - (fail))) -; + (- $Dir $Syms) $Sym) $Dirs) + (assert-sym-index $Dir $Syms $Sym))) + (= (assert-sym-index $Dir $Syms $Sym) + ( (dir-key $Dir $Key) (add-is-symbol &self (sym_index $Key $Syms $Sym)))) - (= - (indexed-sym-dir $Dir $Syms $Sym) - ( (dir-key $Dir $Key) (sym-index $Key $Syms $Sym))) -; + (= (print-all-syms) + (unique-sym-dirs $L) + (member + (- + (- $Dir $_) $Sym) $L) + (format "~p --> ~p~n" + (:: $Dir $Sym)) + (fail)) - (= - (print-sym-overwrite) - (format "\n% Compiled Symmetry File\n\n:- abolish(sym_dir/3).\n\nsym_dir(Dir,Syms,Sym) :- \n\tindexed_sym_dir(Dir,Syms,Sym).\n\n" Nil)) -; + (= (indexed-sym-dir $Dir $Syms $Sym) + (dir-key $Dir $Key) + (sym-index $Key $Syms $Sym)) + (= (print-sym-overwrite) + (format "\n% Compiled Symmetry File\n\n:- abolish(sym_dir/3).\n\nsym_dir(Dir,Syms,Sym) :- \n\tindexed_sym_dir(Dir,Syms,Sym).\n\n" Nil)) - (= - (overwrite-game) - ( (print-game-overwrite) - (listing player-current-game) - (listing opponent-current-game))) -; + (= (overwrite-game) + (print-game-overwrite) + (listing player-current-game) + (listing opponent-current-game)) - (= - (print-game-overwrite) - (format "\n% Compiled Game File\n\n:- abolish(player_current_game/1).\n:- abolish(opponent_current_game/1).\n\n" Nil)) -; + (= (print-game-overwrite) + (format "\n% Compiled Game File\n\n:- abolish(player_current_game/1).\n:- abolish(opponent_current_game/1).\n\n" Nil)) - (= - (dir-key - (dir $X $Y) $Key) + (= (dir-key (dir $X $Y) $Key) (is $Key (+ (* 1000 $X) $Y))) -; - - (= - (square-key - (square $X $Y) $Key) + (= (square-key (square $X $Y) $Key) (is $Key (+ (* 1000 $X) $Y))) -; - ; -; - +; ============================================================================= ; -; - - +; Testing - (= - (time1) - ( (timing (fastsyms $FastS)) - (nl) - (print $FastS) - (timing (slowsyms $SlowS)) - (nl) - (print $SlowS))) -; - + (= (time1) + (timing (fastsyms $FastS)) + (nl) + (print $FastS) + (timing (slowsyms $SlowS)) + (nl) + (print $SlowS)) - (= - (time-sym $N) - ( (timing (dotimes $N (fastsyms $_))) (timing (dotimes $N (slowsyms $_))))) -; + (= (time-sym $N) + (timing (dotimes $N (fastsyms $_))) + (timing (dotimes $N (slowsyms $_)))) - (= - (fastsyms $SS) + (= (fastsyms $SS) (setof $S (indexed-sym-dir (dir 2 1) (:: forward side rotation) $S) $SS)) -; - - (= - (slowsyms $SS) + (= (slowsyms $SS) (setof $S (in-symmetric-closure (dir 2 1) (:: forward side rotation) $S) $SS)) -; - -; - +; /* Using compile_syms and index_syms, on indexed chinese-chess, making 4 random moves. Data = [(user:time_sym/1)-0,(user:slowsyms/1)-0,(user:time1/0)-0,(user:fastsyms/ 1)-0,(user:indexed_sym_dir/3)-70,(user:dotimes/2)-0,(user:game_syms_dir/3)-0,(us er:dir_key/2)-70,(user:unique_sym_dirs/1)-0,(user:print_all_syms/0)-0,(user:asse rt_sym_index/3)-0,(user:print_sym_overwrite/0)-0,(user:some_player_game/1)-0,(us er:piece_defines_movement/2)-0,(user:assert_sym_indices/0)-0,(user:index_sym_dir s_to_file/1)-0,(user:game_sym_dir/4)-0,(user:game_movement/2)-0,(user:index_sym_ dirs/0)-0,(user:sym_index/3)-387,(user:sym_dir/3)-28], Selec = execution_time ? ; ;;; Using compile_syms and index_syms, on indexed chinese-chess, but re-written back to use boardsstat (old symmetry), making 4 random moves. Data = [(user:time_sym/1)-0,(user:slowsyms/1)-0,(user:time1/0)-0,(user:fastsyms/ 1)-0,(user:indexed_sym_dir/3)-0,(user:dotimes/2)-0,(user:game_syms_dir/3)-0,(use r:dir_key/2)-0,(user:unique_sym_dirs/1)-0,(user:print_all_syms/0)-0,(user:assert _sym_index/3)-0,(user:print_sym_overwrite/0)-0,(user:some_player_game/1)-0,(user :piece_defines_movement/2)-0,(user:assert_sym_indices/0)-0,(user:index_sym_dirs_ to_file/1)-0,(user:game_sym_dir/4)-0,(user:game_movement/2)-0,(user:index_sym_di rs/0)-0,(user:sym_index/3)-0,(user:transform_item/3)-403,(user:close1/4)-398,(us er:symmetry/3)-567,(user:place_pieces_on_squares/4)-5,(user:close_item/6)-1422,( user:closure/3)-40,(user:gcf/3)-0,(user:wrap_leaps/3)-0,(user:on_board/1)-350,(u ser:conn_cyl/3)-0,(user:conn_for_type/4)-106,(user:place_piece_in_hand/5)-0,(use r:do_assignments_for_player/6)-0,(user:schedule_if/5)-1549,(user:valid_max/3)-87 ,(user:wl/3)-0,(user:max_leaps/4)-12,(user:valid_max_dir/3)-66,(user:legal_locat ion/1)-65,(user:conn/3)-766,(user:connected/3)-364,(user:uncollapse/3)-4,(user:a ssign_piece_to_square/4)-5,(user:uncollect/2)-1,(user:place_pieces_in_hand/5)-0, (user:place_pieces_on_squares/3)-0,(user:arbitrary_assignment/1)-0,(user:create_ initial_setup/3)-0,(user:legal_location_cyl/2)-0,(user:make_assignable_squares/2 )-0,(user:make_empty/3)-16,(user:make_empty_board/2)-0,(user:initialize_board/3) -0,(user:valid_min/2)-29,(user:do_assignments/3)-0,(user:set_initial_move_count/ 2)-0,(user:in_symmetric_closure/3)-87,(user:start_game/3)-0,(user:sym_dir/3)-28, (user:negates/2)-1153,(user:start_game/2)-0,(user:assignment_decision/4)-0], Selec = execution_time ? */ diff --git a/metagame/state/efficient_state.metta b/metagame/state/efficient_state.metta index 95104f7..fef6c0d 100644 --- a/metagame/state/efficient_state.metta +++ b/metagame/state/efficient_state.metta @@ -1,834 +1,543 @@ +; (convert_to_metta_file efficient_state $_110400 metagame/state/efficient_state.pl metagame/state/efficient_state.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; - ; -; - +; efficient_state.pl ; ; - ; -; - +; The naive representation of state just maintains the state as a list ; -; - +; of all the preds true in it. ; ; - ; -; - +; The following routines create an indexed structure for representing game state, ; -; - +; where predicates are indexed according to functor/arity. Thus, when finding which ; -; - +; player is in control, we need not search past descriptors dealing with square occupancy, ; -; - +; etc. ; ; - ; -; - +; Within the entry for each predicate, the preds of that type currently true can ; -; - +; also be impemented in a variety of ways, the most naive of which using a list ; -; - +; representation. ; -; - +; Here we are a bit more efficient, and index first on the functor of the predicate, ; -; - +; and second on the particular arguments of it. The method of indexing on arguments ; -; - +; varies from predicate to predicate. In particular, ON is represented as ; -; - +; an array. ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; !(my-ensure-loaded (library aux)) -; - ; -; - +; ---------------------------------------- ; -; - +; The following are defined in sysdev.pl ; -; - +; DYNAMIC_PREDS_FILE(File) ; -; - +; INDEX_PREDS_FILE(File) ; -; - +; ---------------------------------------- ; -; - +; ================================================================================ ; -; - +; Using state in predicates. ; -; - +; ================================================================================ ; -; - +; Efficient representation indexes state as a list of predicate entries, ; -; - +; each of which is individually optimized. ; -; - +; STATE Abstract Data Type. ; -; - +; Supports following operations: ; ; - ; -; - +; new_state(-State) -- State is a new (empty) state, in which nothing is true. ; ; - ; -; - +; is_state(+State) -- True when State is a state. ; ; - ; -; - +; true_in(?Pred,+State) -- Pred is true in State. ; ; - ; -; - +; add_in(+Pred,+StateIn,-StateOut) -- StateOut is like StateIn, ; -; - +; with the addition of Pred (which must be ground). ; ; - ; -; - +; del_in(+Pred,+StateIn,-StateOut) -- StateOut is like StateIn, ; -; - +; except that Pred (which must have been true in StateIn) is ; -; - +; not true in StateOut. ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; db indexing ADT ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (new-state (state $S)) + (= (new-state (state $S)) (initialize-state Nil $S)) -; - ; -; - - - (= - (initialize-state $SIn $SOut) - ( (setof - (- $P $I) - (pred-index $P $I) $Indices) (initialize-state-indices $Indices $SIn $SOut))) -; +; ;; INITIALIZE_STATE(+SIn,-SOut) + (= (initialize-state $SIn $SOut) + (setof + (- $P $I) + (pred-index $P $I) $Indices) + (initialize-state-indices $Indices $SIn $SOut)) - (= - (initialize_state_indices () $SIn $SIn) True) -; - - (= - (initialize-state-indices - (Cons - (- $P $I) $Is) $SIn $SOut) - ( (initialize-state-index $P $I $SIn $S1) (initialize-state-indices $Is $S1 $SOut))) -; - + (= (initialize_state_indices () $SIn $SIn) True) + (= (initialize-state-indices (Cons (- $P $I) $Is) $SIn $SOut) + (initialize-state-index $P $I $SIn $S1) + (initialize-state-indices $Is $S1 $SOut)) ; -; - +; ;; INITIALIZE_STATE_INDEX(Pred,Index,SIn,S1) :- ; -; - +; ;; ensures that all the labels have initially empty lists, ; -; - +; ;; so that we can always be sure there is a list there ; -; - +; ;; when we find a label. ; -; - +; initialize_state_index(_P,_I,SIn,[[]|SIn]). - (= - (initialize-state-index $P $I $SIn - (Cons $Bucket $SIn)) + (= (initialize-state-index $P $I $SIn (Cons $Bucket $SIn)) (init-bucket $P $Bucket)) -; - - (= - (is_state - (state $_)) True) -; + (= (is_state (state $_)) True) - - (= - (true-in $Pred - (state $State)) + (= (true-in $Pred (state $State)) (db-true $Pred $State)) -; - - (= - (add-in $Pred - (state $SIn) - (state $SOut)) + (= (add-in $Pred (state $SIn) (state $SOut)) (db-add $Pred $SIn $SOut)) -; - - (= - (del-in $Pred - (state $SIn) - (state $SOut)) + (= (del-in $Pred (state $SIn) (state $SOut)) (db-del $Pred $SIn $SOut)) -; - ; -; - +; Could optimize add/del key, by having ; -; - +; find_bucket return a difference list and the ; -; - +; rest of the list, so we can just replace here. ; -; - +; This would save N traversals, where N is the ; -; +; pred_index of P (which bucket it is in). - - (= - (db-true $P $SIn) - ( (db-key $P $Key) (in-key $Key $P $SIn))) -; - + (= (db-true $P $SIn) + (db-key $P $Key) + (in-key $Key $P $SIn)) - (= - (db-add $P $SIn $SOut) - ( (db-key $P $Key) (add-key $Key $P $SIn $SOut))) -; - + (= (db-add $P $SIn $SOut) + (db-key $P $Key) + (add-key $Key $P $SIn $SOut)) ; -; - - - (= - (db-del $P $SIn $SOut) - ( (db-key $P $Key) (del-key $Key $P $SIn $SOut))) -; +; Ensure already inserted before deleting? + (= (db-del $P $SIn $SOut) + (db-key $P $Key) + (del-key $Key $P $SIn $SOut)) - (= - (db-key $P $Key) + (= (db-key $P $Key) (pred-index $P $Key)) -; + (= (in-key $Key $P $SIn) + (find-bucket $Key $SIn $Bucket) + (in-bucket $P $Bucket)) - (= - (in-key $Key $P $SIn) - ( (find-bucket $Key $SIn $Bucket) (in-bucket $P $Bucket))) -; + (= (add-key $Key $P $SIn $SOut) + (find-bucket $Key $SIn $Bucket) + (add-bucket $P $Bucket $Bucket1) + (set-bucket $Key $SIn $Bucket1 $SOut)) - (= - (add-key $Key $P $SIn $SOut) - ( (find-bucket $Key $SIn $Bucket) - (add-bucket $P $Bucket $Bucket1) - (set-bucket $Key $SIn $Bucket1 $SOut))) -; + (= (del-key $Key $P $SIn $SOut) + (find-bucket $Key $SIn $Bucket) + (del-bucket $P $Bucket $Bucket1) + (set-bucket $Key $SIn $Bucket1 $SOut)) - - (= - (del-key $Key $P $SIn $SOut) - ( (find-bucket $Key $SIn $Bucket) - (del-bucket $P $Bucket $Bucket1) - (set-bucket $Key $SIn $Bucket1 $SOut))) -; - - - - (= - (find-bucket $Index $State $Bucket) + (= (find-bucket $Index $State $Bucket) (nth-element $Index $State $Bucket)) -; - - (= - (set-bucket $Index $SIn $Bucket $SOut) + (= (set-bucket $Index $SIn $Bucket $SOut) (set-nth-element $Index $SIn $Bucket $SOut)) -; - ; -; - +; in_bucket(P,Bucket) :- ; -; - +; member_bag(P,Bucket). ; -; - +; add_bucket(P,Bucket,Bucket1) :- ; -; - +; add_bag(P,Bucket,Bucket1). ; -; - +; del_bucket(P,Bucket,Bucket1) :- ; -; - +; del_bag(P,Bucket,Bucket1). ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Using nested-term-arrays to represent the board ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - - - - (= - (init-bucket - (on $_ $_) $Bucket) - ( (set-det) (new-game-board $Bucket))) -; - - (= - (init_bucket $_ ()) True) -; +; INIT_BUCKET + (= (init-bucket (on $_ $_) $Bucket) + (set-det) + (new-game-board $Bucket)) + (= (init_bucket $_ ()) True) - (= - (empty-row $X $Term) - ( (functor $Term1 row $X) (empty-elements $X $Term1 $Term))) -; + (= (empty-row $X $Term) + (functor $Term1 row $X) + (empty-elements $X $Term1 $Term)) - (= - (empty-elements 0 $Board $Board) + (= (empty-elements 0 $Board $Board) (set-det)) -; - - (= - (empty-elements $N $Board1 $Board) - ( (>= $N 1) - (emptify $N $Board1 $Board2) - (is $N1 - (- $N 1)) - (empty-elements $N1 $Board2 $Board))) -; - + (= (empty-elements $N $Board1 $Board) + (>= $N 1) + (emptify $N $Board1 $Board2) + (is $N1 + (- $N 1)) + (empty-elements $N1 $Board2 $Board)) - (= - (emptify $N $Board1 $Board2) - ( (empty-filler $E) - (arg $N $Board1 $E) - (= $Board1 $Board2))) -; - + (= (emptify $N $Board1 $Board2) + (empty-filler $E) + (arg $N $Board1 $E) + (= $Board1 $Board2)) ; -; - +; For a generic, unspecified state, all squares should ; -; - +; be unbound. A program to set up the board should thus ; -; - +; either add them as empty or not. ; ; - ; -; - - - (= - (empty_filler $_) True) -; +; empty_filler(empty). + (= (empty_filler $_) True) ; -; - +; emptify(N,Board1,Board2) :- ; -; - +; arg(N,Board1,empty), ; -; - - +; Board1 = Board2. - (= - (empty-board $X $Y $Term) - ( (functor $Term1 gameboard $Y) (empty-rows $Y $X $Term1 $Term))) -; + (= (empty-board $X $Y $Term) + (functor $Term1 gameboard $Y) + (empty-rows $Y $X $Term1 $Term)) - (= - (empty-rows 0 $X $Board $Board) + (= (empty-rows 0 $X $Board $Board) (set-det)) -; - - (= - (empty-rows $N $X $Board1 $Board) - ( (>= $N 1) - (emptify-row $N $X $Board1 $Board2) - (is $N1 - (- $N 1)) - (empty-rows $N1 $X $Board2 $Board))) -; - - - - (= - (emptify-row $N $X $Board1 $Board2) - ( (empty-row $X $Row) - (arg $N $Board1 $Row) - (= $Board1 $Board2))) -; + (= (empty-rows $N $X $Board1 $Board) + (>= $N 1) + (emptify-row $N $X $Board1 $Board2) + (is $N1 + (- $N 1)) + (empty-rows $N1 $X $Board2 $Board)) + (= (emptify-row $N $X $Board1 $Board2) + (empty-row $X $Row) + (arg $N $Board1 $Row) + (= $Board1 $Board2)) - (= - (new-game-board $Board) - ( (current-board-size $X $Y) (empty-board $X $Y $Board))) -; + (= (new-game-board $Board) + (current-board-size $X $Y) + (empty-board $X $Y $Board)) ; -; - - +; ;; IN_BUCKET - (= - (in-bucket - (on $Piece - (square $X $Y)) $Board) - ( (set-det) (piece-on-square $X $Y $Board $Piece))) -; - (= - (in-bucket $P $Bucket) + (= (in-bucket (on $Piece (square $X $Y)) $Board) + (set-det) + (piece-on-square $X $Y $Board $Piece)) +; ; path_arg([Y,X],Board,Piece). + (= (in-bucket $P $Bucket) (member-bag $P $Bucket)) -; - ; -; - +; ;; ADD_BUCKET - (= - (add-bucket - (on $Piece - (square $X $Y)) $A $A1) - ( (set-det) (change-piece-on-square $X $Y $Piece $A $A1))) -; + (= (add-bucket (on $Piece (square $X $Y)) $A $A1) + (set-det) + (change-piece-on-square $X $Y $Piece $A $A1)) +; ; change_path_arg([Y,X],A,A1,Piece). - - (= - (add-bucket $P $A $A1) + (= (add-bucket $P $A $A1) (add-bag $P $A $A1)) -; - - (= - (del-bucket - (on $Piece $Sq) $E $E1) - ( (set-det) (= $E $E1))) -; - - (= - (del-bucket $P $E $E1) - ( (set-det) (del-bag $P $E $E1))) -; - + (= (del-bucket (on $Piece $Sq) $E $E1) + (set-det) + (= $E $E1)) +; ; Don't need to do anything here, since will always +; ; set it to something on next step! + (= (del-bucket $P $E $E1) + (set-det) + (del-bag $P $E $E1)) ; -; - +; ---------------------------------------------------------------------- ; -; - +; Low-level board accessing ; -; - +; ---------------------------------------------------------------------- ; -; - +; :- assert(library_directory('/usr/groups/ailanguages/quintus3.1.1/generic/qplib3.1.1/library/')). ; -; - +; :- my_use_module(library(changearg)). ; -; - +; :- my_use_module(library(arg)). !(my-use-module (library args)) -; - - (= - (piece-on-square $X $Y $Board $Piece) + (= (piece-on-square $X $Y $Board $Piece) (path-arg (:: $Y $X) $Board $Piece)) -; - - (= - (change-piece-on-square $X $Y $Piece $Board1 $Board2) - ( (same-functor $Board1 $Board2 $YMax) (change-item-in-column $YMax $Y $X $Board1 $Piece $Board2))) -; - - - - (= - (change-item-in-column $Curr $Curr $X $Board1 $Item $Board2) - ( (set-det) - (corresponding-arg $Curr $Board1 $Row1 $Board2 $Row2) - (same-functor $Row1 $Row2 $XMax) - (change-item-in-row $XMax $X $Row1 $Item $Row2) - (is $Curr1 - (- $Curr 1)) - (copy-columns $Curr1 $Board1 $Board2))) -; - - (= - (change-item-in-column $Curr $Y $X $Board1 $Item $Board2) - ( (same-arg $Curr $Board1 $Board2) - (is $Curr1 - (- $Curr 1)) - (change-item-in-column $Curr1 $Y $X $Board1 $Item $Board2))) -; - + (= (change-piece-on-square $X $Y $Piece $Board1 $Board2) + (same-functor $Board1 $Board2 $YMax) + (change-item-in-column $YMax $Y $X $Board1 $Piece $Board2)) + + + (= (change-item-in-column $Curr $Curr $X $Board1 $Item $Board2) + (set-det) + (corresponding-arg $Curr $Board1 $Row1 $Board2 $Row2) + (same-functor $Row1 $Row2 $XMax) + (change-item-in-row $XMax $X $Row1 $Item $Row2) + (is $Curr1 + (- $Curr 1)) + (copy-columns $Curr1 $Board1 $Board2)) + (= (change-item-in-column $Curr $Y $X $Board1 $Item $Board2) + (same-arg $Curr $Board1 $Board2) + (is $Curr1 + (- $Curr 1)) + (change-item-in-column $Curr1 $Y $X $Board1 $Item $Board2)) - (= - (copy-columns 0 $Board1 $Board2) + (= (copy-columns 0 $Board1 $Board2) (set-det)) -; - - (= - (copy-columns $Curr $Board1 $Board2) - ( (same-arg $Curr $Board1 $Board2) - (is $Curr1 - (- $Curr 1)) - (copy-columns $Curr1 $Board1 $Board2))) -; - + (= (copy-columns $Curr $Board1 $Board2) + (same-arg $Curr $Board1 $Board2) + (is $Curr1 + (- $Curr 1)) + (copy-columns $Curr1 $Board1 $Board2)) - (= - (change-item-in-row $Curr $Curr $Row1 $Item $Row2) - ( (set-det) - (corresponding-arg $Curr $Row1 $Old $Row2 $Item) - (is $Curr1 - (- $Curr 1)) - (copy-rows $Curr1 $Row1 $Row2))) -; - - (= - (change-item-in-row $Curr $X $Row1 $Item $Row2) - ( (same-arg $Curr $Row1 $Row2) - (is $Curr1 - (- $Curr 1)) - (change-item-in-row $Curr1 $X $Row1 $Item $Row2))) -; - + (= (change-item-in-row $Curr $Curr $Row1 $Item $Row2) + (set-det) + (corresponding-arg $Curr $Row1 $Old $Row2 $Item) + (is $Curr1 + (- $Curr 1)) + (copy-rows $Curr1 $Row1 $Row2)) + (= (change-item-in-row $Curr $X $Row1 $Item $Row2) + (same-arg $Curr $Row1 $Row2) + (is $Curr1 + (- $Curr 1)) + (change-item-in-row $Curr1 $X $Row1 $Item $Row2)) - (= - (copy-rows 0 $Row1 $Row2) + (= (copy-rows 0 $Row1 $Row2) (set-det)) -; - - (= - (copy-rows $Curr $Row1 $Row2) - ( (same-arg $Curr $Row1 $Row2) - (is $Curr1 - (- $Curr 1)) - (copy-rows $Curr1 $Row1 $Row2))) -; - + (= (copy-rows $Curr $Row1 $Row2) + (same-arg $Curr $Row1 $Row2) + (is $Curr1 + (- $Curr 1)) + (copy-rows $Curr1 $Row1 $Row2)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; List implementation of arrays ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; nth_element(N,List,Elt): rewrite of nth/3 ; -; - +; set_nth_element(N,List,Val,NewList) - (= - (nth-element 1 - (Cons $H $T) $H) + (= (nth-element 1 (Cons $H $T) $H) (set-det)) -; - - (= - (nth-element $N - (Cons $H $T) $Nth) - ( (is $Next - (- $N 1)) (nth-element $Next $T $Nth))) -; + (= (nth-element $N (Cons $H $T) $Nth) + (is $Next + (- $N 1)) + (nth-element $Next $T $Nth)) - - (= - (nth-element-between $G $G - (Cons $H $Rest) Nil $H $Rest) + (= (nth-element-between $G $G (Cons $H $Rest) Nil $H $Rest) (set-det)) -; - - (= - (nth-element-between $Goal $Current - (Cons $H $T) - (Cons $H $Before) $Nth $Rest) - ( (is $Next - (+ $Current 1)) (nth-element-between $Goal $Next $T $Before $Nth $Rest))) -; - + (= (nth-element-between $Goal $Current (Cons $H $T) (Cons $H $Before) $Nth $Rest) + (is $Next + (+ $Current 1)) + (nth-element-between $Goal $Next $T $Before $Nth $Rest)) ; -; - +; set_nth_element(N,LIn,Val,LOut) ; -; - +; LOut is a list LIn, with the Nth element replaced ; -; - +; by Val. - (= - (set-nth-element 1 - (Cons $H $Rest) $Val - (Cons $Val $Rest)) + (= (set-nth-element 1 (Cons $H $Rest) $Val (Cons $Val $Rest)) (set-det)) -; - - (= - (set-nth-element $N - (Cons $H $T) $Nth - (Cons $H $Rest)) - ( (is $Next - (- $N 1)) (set-nth-element $Next $T $Nth $Rest))) -; - + (= (set-nth-element $N (Cons $H $T) $Nth (Cons $H $Rest)) + (is $Next + (- $N 1)) + (set-nth-element $Next $T $Nth $Rest)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; BAG Abstract Data Type ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; member_bag(Elem, Bag) - (= - (member_bag $Elem - (Cons $Elem $Bag)) True) -; - - (= - (member-bag $Elem - (Cons $_ $Rest)) + (= (member_bag $Elem (Cons $Elem $Bag)) True) + (= (member-bag $Elem (Cons $_ $Rest)) (member-bag $Elem $Rest)) -; - ; -; - +; add_bag(Elem, Bag1, Bag2) ; -; - +; is true when Bag1 and Bag2 are bags represented as unordered lists, ; -; - +; and Bag2 = Bag1 U {Elem}. It may only be used to calculate Bag2 ; -; - +; given Elem and Bag1. However, if Bag1 is a list with a variable at ; -; +; the end, it may still be used, and will add new elements at the end. - - (= - (add_bag $Elem $Bag - (Cons $Elem $Bag)) True) -; - + (= (add_bag $Elem $Bag (Cons $Elem $Bag)) True) ; -; - +; del_bag(Elem, Bag1, Bag2) ; -; - +; is true when Bag1 and Bag2 are bags represented as unordered lists, ; -; - +; and Bag2 = Bag1 \ {Elem}. It may only be used to calculate Bag2 ; -; - +; given Elem and Bag1. If Bag1 does not contain Elem, this fails. ; -; - +; If Set1 is not an unordered list, but contains more than one copy of Elem, ; -; - +; only the first will be removed. ; -; - +; del_bag(Elem, [Elem|Bag2], Bag2) :- !. ; -; - +; del_bag(Elem, [X|Bag1], [X|Bag2]) :- !, ; -; - +; del_bag(Elem, Bag1, Bag2). - (= - (del-bag $Elem - (Cons $H $T) $Rest) + (= (del-bag $Elem (Cons $H $T) $Rest) (det-if-then-else (= $Elem $H) (= $Rest $T) @@ -836,75 +545,55 @@ (= $Rest (Cons $H $Rest1)) (del-bag $Elem $T $Rest1)))) -; - ; -; - +; ================================================================================ ; -; - +; Indexing Dynamic Predicates. ; -; - +; ================================================================================ ; -; - +; Here we precompute a unique integer index for each dynamic predicate. ; -; - +; This relies on the domain theory not changing after we've done this ; -; +; optimization. - - (= - (index-dynamic-preds) - ( (index-preds-file $File) - (index-dynamic-preds-to-file $File) - (compile $File))) -; - + (= (index-dynamic-preds) + (index-preds-file $File) + (index-dynamic-preds-to-file $File) + (compile $File)) - (= - (index-dynamic-preds-to-file $File) + (= (index-dynamic-preds-to-file $File) ( (format "~nIndexing Dynamic Predicates to file: ~w~n" (:: $File)) (assert-pred-indices) (tell $File) (listing pred-index) (told) - (remove-all-symbols &self + (remove-all-atoms &self (pred_index $_ $_)))) -; - - (= - (assert-pred-indices) + (= (assert-pred-indices) (or (, (abolish (/ pred-index 2)) (pred-index-slow $Pred $Index) - (add-symbol &self + (add-is-symbol &self (pred_index $Pred $Index)) (fail)) True)) -; - ; -; - - - (= - (pred-index-slow $Pred $Index) - ( (dynamic-predicates $Preds) (nth $Index $Preds $Pred))) -; +; This is the predicate we partially execute to form an indexed table. + (= (pred-index-slow $Pred $Index) + (dynamic-predicates $Preds) + (nth $Index $Preds $Pred)) diff --git a/metagame/state/stat.metta b/metagame/state/stat.metta index a64bb51..e2583f2 100644 --- a/metagame/state/stat.metta +++ b/metagame/state/stat.metta @@ -1,454 +1,299 @@ +; (convert_to_metta_file stat $_381116 metagame/state/stat.pl metagame/state/stat.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; stat.pl ; ; - ; -; - +; Main procedures: ; ; - ; -; - +; STAT(GIn,State_Req) ; -; - +; tells us whether the Goal GIn requires 0, 1, or 2 extra args ; -; - +; for explicit passing of state variables. ; -; - +; 0: if G is independent of state. ; -; - +; 1: if G has a subgoal which might test state, but no subgoal changes state. ; -; - +; 2: if G has a subgoal which might change state. ; ; - ; -; - +; STATIVITY_ANALYSIS ; -; - +; Performs an abstract interpretation over the loaded domain theory. ; -; - +; This proceeds as follows: ; ; - ; -; - +; Assume all predicates have stativity 0 (ie we know nothing about their ; -; - +; stativity). ; -; - +; At each iteration I+1, update our assumptions on stativity for each predicate based ; -; - +; on the current assumptions: ; -; - +; 1. Compute stativity based on current assumptions. ; -; - +; 2. If new stativity for this pred is different, save it, and note ; -; - +; something changed. ; -; - +; [When we update an assumption, we can immediately change its entry in ; -; - +; the table to use on subsequence steps within the same iteration.] ; ; - ; -; - +; If nothing changed, then we've reached a fixedpoint, so our ; -; - +; assumptions are now correct (at least we'll gain no more knowledge by ; -; - +; repeating this analysis). ; -; - +; Otherwise, do another loop. ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; !(my-ensure-loaded (library tracing)) -; - !(dynamic (/ stativity 2)) -; - - - - - (= - (stat $A 0) - ( (var $A) - (write "~n Warning: Error in Stat routine, Variable!") - (nl) - (set-det))) -; - - - (= - (stat - (, $A $B) $S) - ( (set-det) - (stat $A $StatA) - (stat $B $StatB) - (max $StatA $StatB $S))) -; - - - (= - (stat - (or $A $B) $S) - ( (set-det) - (stat $A $StatA) - (stat $B $StatB) - (max $StatA $StatB $S))) -; - - - (= - (stat - (if $Cond $Then $Else) $S) - ( (set-det) - (stat $Cond $CondS) - (stat $Then $ThenS) - (stat $Else $ElseS) - (max - (:: $CondS $ThenS $ElseS) $S))) -; - - (= - (stat - (det-if-then-else $Cond $Then $Else) $S) - ( (set-det) - (stat $Cond $CondS) - (stat $Then $ThenS) - (stat $Else $ElseS) - (max - (:: $CondS $ThenS $ElseS) $S))) -; - (= - (stat - (det-if-then $Cond $Then) $S) - ( (set-det) - (stat $Cond $CondS) - (stat $Then $ThenS) - (max - (:: $CondS $ThenS) $S))) -; - - - (= - (stat - (call $Call) $S) - ( (set-det) (stat $Call $S))) -; - - - (= - (stat - (not $Call) $S) - ( (set-det) (stat $Call $S))) -; - - -; -; - -; -; - - (= - (stat - (setof $X $Test $Xs) $S) - ( (set-det) - (stat $Test $TestS) - (min - (:: $TestS 1) $S))) -; - - - (= - (stat - (bagof $X $Test $Xs) $S) - ( (set-det) - (stat $Test $TestS) - (min - (:: $TestS 1) $S))) -; - - - (= - (stat - (^ $X $Test) $Is) - ( (set-det) (stat $Test $Is))) -; - - - (= - (stat $GIn 1) - ( (test-goal $GIn) (set-det))) -; - - - (= - (stat $GIn 2) - ( (change-goal $GIn) (set-det))) -; - - - (= - (stat $GIn $S) - ( (stativity $GIn $S) (set-det))) -; - - - (= - (stat $_ 0) True) -; - + (= (stat $A 0) + (var $A) + (write "~n Warning: Error in Stat routine, Variable!") + (nl) + (set-det)) + + (= (stat (, $A $B) $S) + (set-det) + (stat $A $StatA) + (stat $B $StatB) + (max $StatA $StatB $S)) + + (= (stat (or $A $B) $S) + (set-det) + (stat $A $StatA) + (stat $B $StatB) + (max $StatA $StatB $S)) + + (= (stat (if $Cond $Then $Else) $S) + (set-det) + (stat $Cond $CondS) + (stat $Then $ThenS) + (stat $Else $ElseS) + (max + (:: $CondS $ThenS $ElseS) $S)) + + (= (stat (det-if-then-else $Cond $Then $Else) $S) + (set-det) + (stat $Cond $CondS) + (stat $Then $ThenS) + (stat $Else $ElseS) + (max + (:: $CondS $ThenS $ElseS) $S)) + + (= (stat (det-if-then $Cond $Then) $S) + (set-det) + (stat $Cond $CondS) + (stat $Then $ThenS) + (max + (:: $CondS $ThenS) $S)) + + (= (stat (call $Call) $S) + (set-det) + (stat $Call $S)) + + (= (stat (not $Call) $S) + (set-det) + (stat $Call $S)) + +; +; Setof and bagof are logical, so the may depend on +; +; state (possibly) but not change it. + (= (stat (setof $X $Test $Xs) $S) + (set-det) + (stat $Test $TestS) + (min + (:: $TestS 1) $S)) + + (= (stat (bagof $X $Test $Xs) $S) + (set-det) + (stat $Test $TestS) + (min + (:: $TestS 1) $S)) + + (= (stat (^ $X $Test) $Is) + (set-det) + (stat $Test $Is)) + + (= (stat $GIn 1) + (test-goal $GIn) + (set-det)) + + (= (stat $GIn 2) + (change-goal $GIn) + (set-det)) + + (= (stat $GIn $S) + (stativity $GIn $S) + (set-det)) + + (= (stat $_ 0) True) - (= - (change_goal - (add $Pred)) True) -; - - (= - (change_goal - (del $Pred)) True) -; - - + (= (change_goal (add $Pred)) True) + (= (change_goal (del $Pred)) True) - (= - (test_goal - (true $Pred)) True) -; + (= (test_goal (true $Pred)) True) ; -; - +; ============================================================ ; -; +; Stativity Analysis - - (= - (stativity-analysis) - ( (initialize-stats 0) (interpret-stativity))) -; - + (= (stativity-analysis) + (initialize-stats 0) + (interpret-stativity)) ; -; - +; Changed will fail unless something really changed. !(dynamic (/ changed 0)) -; - - (= - (initialize-stats $InitVal) - ( (reset-stat) - (theory-clause $GIn $Body) - (variablized-goal $GIn $VGIn) + (= (initialize-stats $InitVal) + (reset-stat) + (theory-clause $GIn $Body) + (variablized-goal $GIn $VGIn) + (det-if-then-else + (stativity $VGIn $Stat) (det-if-then-else - (stativity $VGIn $Stat) - (det-if-then-else - (= $Stat $InitVal) True - (format "Error: Some stat entry not reset properly~n" Nil)) - (add-symbol &self - (stativity $VGIn $InitVal))) - (fail))) -; - - (= - (initialize_stats $_) True) -; - + (= $Stat $InitVal) True + (format "Error: Some stat entry not reset properly~n" Nil)) + (add-is-symbol &self + (stativity $VGIn $InitVal))) + (fail)) + (= (initialize_stats $_) True) - (= - (interpret-stativity) - ( (tracing-format - (stat 1) "Starting an iteration of stativity interpretation~n" Nil) - (do-analysis) - (loop-if-changed))) -; - + (= (interpret-stativity) + (tracing-format + (stat 1) "Starting an iteration of stativity interpretation~n" Nil) + (do-analysis) + (loop-if-changed)) - (= - (loop-if-changed) - ( (remove-symbol &self changed) + (= (loop-if-changed) + ( (remove-is-symbol &self changed) (set-det) (interpret-stativity))) -; - - (= - (loop-if-changed) + (= (loop-if-changed) (tracing-format (stat 1) "Reached fixed point, interpretation has ended.~n" Nil)) -; - - (= - (do-analysis) - ( (clear-changed) (or (, (analysis-item $Item) (analyze-item $Item) (fail)) True))) -; - + (= (do-analysis) + (clear-changed) + (or + (, + (analysis-item $Item) + (analyze-item $Item) + (fail)) True)) - (= - (analysis-item (= $Goal $Body)) + (= (analysis-item (= $Goal $Body)) (theory-clause $Goal $Body)) -; - - (= - (analyze-item (= $Goal $Body)) - ( (stat $Body $Stat) (update-assumption $Goal $Stat))) -; - + (= (analyze-item (= $Goal $Body)) + (stat $Body $Stat) + (update-assumption $Goal $Stat)) ; -; - - - (= - (update-assumption $P $Stat) - ( (stativity $P $StatOld) - (=< $Stat $StatOld) - (set-det))) -; +; Only update assumptions to values higher in the lattice. - (= - (update-assumption $P $Stat) + (= (update-assumption $P $Stat) + (stativity $P $StatOld) + (=< $Stat $StatOld) + (set-det)) + (= (update-assumption $P $Stat) ( (variablized-goal $P $VP) - (remove-symbol &self + (remove-is-symbol &self (stativity $VP $StatOld)) - (add-symbol &self + (add-is-symbol &self (stativity $VP $Stat)) (tracing-format (stat 2) "Procedure <~p> changed stativity from <~p> to <~p>~n" (:: $P $StatOld $Stat)) (note-changed))) -; - - (= - (note-changed) - ( (changed) (set-det))) -; - - (= - (note-changed) + (= (note-changed) + (changed) + (set-det)) + (= (note-changed) ( (tracing-format - (stat 2) "Initial stativity changed this iteration~n" Nil) (add-symbol &self changed))) -; - - + (stat 2) "Initial stativity changed this iteration~n" Nil) (add-is-symbol &self changed))) - (= - (clear-changed) - (remove-all-symbols &self changed)) -; + (= (clear-changed) + (remove-all-atoms &self changed)) - (= - (reset-stat) - (remove-all-symbols &self + (= (reset-stat) + (remove-all-atoms &self (stativity $_ $_))) -; - - (= - (variablized-goal $GoalIn $GoalOut) - ( (functor $GoalIn $F $A) (functor $GoalOut $F $A))) -; - + (= (variablized-goal $GoalIn $GoalOut) + (functor $GoalIn $F $A) + (functor $GoalOut $F $A)) ; -; - +; ================================================================================ ; -; - +; tracing execution - (= - (set-stat-verbosity $Level $Status) + (= (set-stat-verbosity $Level $Status) (set-tracing (stat $Level) $Status)) -; - - (= - (silent-stat) - ( (set-stat-verbosity 1 off) (set-stat-verbosity 2 off))) -; - + (= (silent-stat) + (set-stat-verbosity 1 off) + (set-stat-verbosity 2 off)) !(set-stat-verbosity 1 on) -; - diff --git a/metagame/state/statify_theory.metta b/metagame/state/statify_theory.metta index 66837b0..64aafcf 100644 --- a/metagame/state/statify_theory.metta +++ b/metagame/state/statify_theory.metta @@ -1,241 +1,183 @@ +; (convert_to_metta_file statify_theory $_22470 metagame/state/statify_theory.pl metagame/state/statify_theory.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; statify_theory.pl ; -; - +; ;; To transform a domain theory with true, add, and del statements ; -; - +; ;; into one with a threaded StateIn, and StateOut pair. !(my-ensure-loaded (library aux)) -; - !(my-ensure-loaded (library stat)) -; - ; -; - +; ---------------------------------------- ; -; - +; The following are defined in sysdev.pl ; -; - +; THEORY_FILES(Files) ; -; - +; DYNAMIC_PREDS_FILE(File) ; -; - +; ---------------------------------------- ; -; - +; COMPILE_AND_LOAD_PLAYER ; -; - +; This command does the state compilation on all the player theory files, ; -; - +; and then loads them. ; -; - +; Not nec. to call: load_compiled_play_theory/0 here, ; -; - +; as we compile-load each file immediately after writing it. ; ; - - (= - (compile-and-load-player) + (= (compile-and-load-player) (state-compile-player)) -; - ; -; - +; STATE_COMPILE_PLAYER ; -; - +; Compile the dynamic pred declarations into a theory file. ; -; - +; Then index them for efficient state representation. ; -; - +; Then load all theory files as data, and perform the ; -; - +; state compilation on the theory. ; -; - +; Finally, clear the loaded theory files, as after this ; -; - +; we'll only use the compiled MeTTa versions. ; -; - +; (Systems which want the theory around after that should load ; -; - +; it again.) ; ; - - (= - (state-compile-player) - ( (compile-dynamic-preds) - (index-dynamic-preds) - (player-theory-load) - (player-theory-compile) - (theory-clear))) -; - - - - (= - (player-theory-load) - ( (format "Loading Theory: MetaGame~n" Nil) - (theory-clear) - (player-theory-files $Files) - (dl $Files))) -; - + (= (state-compile-player) + (compile-dynamic-preds) + (index-dynamic-preds) + (player-theory-load) + (player-theory-compile) + (theory-clear)) - (= - (player-theory-compile) - ( (format "Compiling Theory: MetaGame~n" Nil) - (stativity-analysis) - (compile-player-files))) -; + (= (player-theory-load) + (format "Loading Theory: MetaGame~n" Nil) + (theory-clear) + (player-theory-files $Files) + (dl $Files)) + (= (player-theory-compile) + (format "Compiling Theory: MetaGame~n" Nil) + (stativity-analysis) + (compile-player-files)) - (= - (compile-player-files) - ( (theory-files $Files) (whenever (member $File $Files) (thcomp $File)))) -; + (= (compile-player-files) + (theory-files $Files) + (whenever + (member $File $Files) + (thcomp $File))) - (= - (player-compiled-files $CompFiles) - ( (theory-files $Files) (bagof $CompFile (^ $File (, (member $File $Files) (theory-statname $File $CompFile))) $CompFiles))) -; - + (= (player-compiled-files $CompFiles) + (theory-files $Files) + (bagof $CompFile + (^ $File + (, + (member $File $Files) + (theory-statname $File $CompFile))) $CompFiles)) - (= - (player-theory-files $CompFiles) - ( (theory-files $Files) (bagof $CompFile (^ $File (, (member $File $Files) (theory-filename $File $CompFile))) $CompFiles))) -; - + (= (player-theory-files $CompFiles) + (theory-files $Files) + (bagof $CompFile + (^ $File + (, + (member $File $Files) + (theory-filename $File $CompFile))) $CompFiles)) ; -; - +; LOAD_COMPILED_PLAY_THEORY ; -; - +; Loads all the compiled player theory files. ; -; - +; If they have been state_compiled already, and none have changed, ; -; - +; this is the only call nec. to load them. ; -; - +; (Thus, someone just using the player need only know this command ; -; - +; once he has compiled the first time. ; ; + (= (load-compiled-play-theory) + (player-compiled-files $Fs) + (whenever + (member $F $Fs) + (compile $F))) - (= - (load-compiled-play-theory) - ( (player-compiled-files $Fs) (whenever (member $F $Fs) (compile $F)))) -; + (= (theory-filename $FileRoot $CompFileName) + (sys-suffixed-filename $FileRoot prolog $File) + (theory-directory $TheoryDir) + (concat-list + (:: $TheoryDir / $File) $CompFileName)) - (= - (theory-filename $FileRoot $CompFileName) - ( (sys-suffixed-filename $FileRoot prolog $File) - (theory-directory $TheoryDir) - (concat-list - (:: $TheoryDir / $File) $CompFileName))) -; + (= (theory-statname $FileRoot $CompFileName) + (sys-suffixed-filename $FileRoot state-compile $File) + (theory-directory $TheoryDir) + (concat-list + (:: $TheoryDir / $File) $CompFileName)) - (= - (theory-statname $FileRoot $CompFileName) - ( (sys-suffixed-filename $FileRoot state-compile $File) - (theory-directory $TheoryDir) - (concat-list - (:: $TheoryDir / $File) $CompFileName))) -; - - + (= (thcomp $FileRoot) + (theory-filename $FileRoot $FileIn) + (theory-statname $FileRoot $FileOut) + (state-compile-file $FileIn $FileOut) + (compile $FileOut)) - (= - (thcomp $FileRoot) - ( (theory-filename $FileRoot $FileIn) - (theory-statname $FileRoot $FileOut) - (state-compile-file $FileIn $FileOut) - (compile $FileOut))) -; - - - - (= - (state-compile-file $FileIn $FileOut) - ( (format "Compiling theory file: ~w~n" - (:: $FileIn)) - (see $FileIn) - (tell $FileOut) - (compile-clauses) - (set-det) - (seen) - (told) - (format "Wrote compiled file: ~w~n" - (:: $FileOut)))) -; - + (= (state-compile-file $FileIn $FileOut) + (format "Compiling theory file: ~w~n" + (:: $FileIn)) + (see $FileIn) + (tell $FileOut) + (compile-clauses) + (set-det) + (seen) + (told) + (format "Wrote compiled file: ~w~n" + (:: $FileOut))) +; ; don't know where nondet is. - (= - (compile-clauses) + (= (compile-clauses) (det-if-then-else (, (read $ClauseIn) @@ -244,163 +186,106 @@ (compile-clause $ClauseIn $ClauseOut) (portray-clause $ClauseOut) (compile-clauses)) True)) -; - - (= - (compile-clause $CIn $COut) - ( (clause-parts $CIn $HIn $BIn) (thread-clause $HIn $BIn $COut))) -; + (= (compile-clause $CIn $COut) + (clause-parts $CIn $HIn $BIn) + (thread-clause $HIn $BIn $COut)) - - (= - (thread-clause $HeadIn $BodyIn $ClauseOut) - ( (add-state $HeadIn $SIn $SOut $HeadOut) - (thread $BodyIn $SIn $SOut $BodyOut) - (clause-parts $ClauseOut $HeadOut $BodyOut))) -; + (= (thread-clause $HeadIn $BodyIn $ClauseOut) + (add-state $HeadIn $SIn $SOut $HeadOut) + (thread $BodyIn $SIn $SOut $BodyOut) + (clause-parts $ClauseOut $HeadOut $BodyOut)) - - (= - (add-state $GoalIn $Stativity $GoalOut) + (= (add-state $GoalIn $Stativity $GoalOut) (add-state $GoalIn $SIn $SOut $Stativity $GoalOut)) -; - - - (= - (add-state $GoalIn $SIn $SOut $GoalOut) - ( (stat $GoalIn $Stat) (add-state $GoalIn $SIn $SOut $Stat $GoalOut))) -; +; /* A goal G should be threaded with SIn/SOut if: a. It is an Add/DEL literal (thread SIn,SOut). b. It is a True literal (thread SIn). c. There is an interpreted pred: G :- Body, and the body should be threaded. A body B1,B2, ... should be threaded if one of its Bi should be. */ + (= (add-state $GoalIn $SIn $SOut $GoalOut) + (stat $GoalIn $Stat) + (add-state $GoalIn $SIn $SOut $Stat $GoalOut)) ; -; - +; ADD_STATE(Goalin,SIn,SOut,Stativity,GoalOut) ; -; - +; add_state(foo(a,b),A,B,0,GoalOut) --> GoalOut = foo(a,b). ; -; - +; add_state(foo(a,b),A,B,1,GoalOut) --> GoalOut = foo(a,b,A). ; -; - - (= - (add_state $GoalIn $SIn $SIn 0 $GoalIn) True) -; - - (= - (add-state $GoalIn $SIn $SIn 1 $GoalOut) +; add_state(foo(a,b),A,B,2,GoalOut) --> GoalOut = foo(a,b,A,B). + (= (add_state $GoalIn $SIn $SIn 0 $GoalIn) True) + (= (add-state $GoalIn $SIn $SIn 1 $GoalOut) (thread-in-state $GoalIn $SIn $GoalOut)) -; - - (= - (add-state $GoalIn $SIn $SOut 2 $GoalOut) - ( (thread-in-state $GoalIn $SIn $G1) (thread-in-state $G1 $SOut $GoalOut))) -; + (= (add-state $GoalIn $SIn $SOut 2 $GoalOut) + (thread-in-state $GoalIn $SIn $G1) + (thread-in-state $G1 $SOut $GoalOut)) - - (= - (thread-in-state $GoalIn $SIn $GoalOut) + (= (thread-in-state $GoalIn $SIn $GoalOut) (increase-term-arity $GoalIn $SIn $GoalOut)) -; - ; -; - +; ================================================================================ ; -; - +; Compiling Dynamic Predicates. ; -; - +; ================================================================================ ; -; - +; Declarations of dynamic predicates. ; -; - +; These are as they appear in the game theory definitions. ; ; - ; -; - +; Ex.: move_count(L) ==> move_count(L,S) :- true_in(move_count(L),S). ; ; - - (= - (dynamic_predicates - ( (control $Player) - (on $Piece $Square) - (moved_onto $Piece $Sq) - (move_count $L) - (stage $Stage) - (effects $Effect $Captures) - (in_hand $Piece $Player) - (opponent_promotes $OldPiece $Sq))) True) -; - - - - - (= - (compile-dynamic-preds) - ( (dynamic-preds-file $F) (compile-dynamics $F))) -; - + (= (dynamic_predicates ((control $Player) (on $Piece $Square) (moved_onto $Piece $Sq) (move_count $L) (stage $Stage) (effects $Effect $Captures) (in_hand $Piece $Player) (opponent_promotes $OldPiece $Sq))) True) +; ; empty(_Square), +; ; effect(_Effect), +; ; captured(_Piece,_Sq), ; opponent_displaces, - (= - (compile-dynamics $Dest) - ( (format "~nCompiling Dynamic Predicates to theory file: ~w~n" - (:: $Dest)) - (tell $Dest) - (dynamic-predicates $Preds) - (compile-preds $Preds) - (told))) -; + (= (compile-dynamic-preds) + (dynamic-preds-file $F) + (compile-dynamics $F)) - (= - (compile_preds ()) True) -; + (= (compile-dynamics $Dest) + (format "~nCompiling Dynamic Predicates to theory file: ~w~n" + (:: $Dest)) + (tell $Dest) + (dynamic-predicates $Preds) + (compile-preds $Preds) + (told)) - (= - (compile-preds (Cons $H $T)) - ( (make-state $H) (compile-preds $T))) -; + (= (compile_preds ()) True) + (= (compile-preds (Cons $H $T)) + (make-state $H) + (compile-preds $T)) - (= - (make-state $Pred) - ( (statify $Pred $Clause) (portray-clause $Clause))) -; - + (= (make-state $Pred) + (statify $Pred $Clause) + (portray-clause $Clause)) - (= - (statify $PredIn $Clause) + (= (statify $PredIn $Clause) (= $Clause - (= $PredIn + (= $PredIn (true $PredIn)))) -; - diff --git a/metagame/state/thread.metta b/metagame/state/thread.metta index 5593750..06247aa 100644 --- a/metagame/state/thread.metta +++ b/metagame/state/thread.metta @@ -1,202 +1,146 @@ +; (convert_to_metta_file thread $_170834 metagame/state/thread.pl metagame/state/thread.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ================================================================================ ; -; - +; THREAD(GoalsIn,SIn,SOut,ThreadedGoals) ; -; - - - - (= - (thread - (det-if-then-else $Cond $Then $Else) $SIn $SOut $Answer) - ( (set-det) - (thread $Cond $SIn $S1 $CondOut) - (thread $Then $S1 $S2 $ThenOut) - (thread $Else $SIn $S3 $ElseOut) - (= $Answer - (det-if-then-else $CondOut - (, $ThenOut - (= $SOut $S2)) - (, $ElseOut - (= $SOut $S3)))))) -; - - - (= - (thread - (det-if-then $Cond $Then) $SIn $SOut $Answer) - ( (set-det) - (thread $Cond $SIn $S1 $CondOut) - (thread $Then $S1 $S2 $ThenOut) - (= $Answer - (det-if-then $CondOut - (, $ThenOut - (= $SOut $S2)))))) -; - - - (= - (thread - (if $Cond $Then $Else) $SIn $SOut $Answer) - ( (set-det) - (thread $Cond $SIn $S1 $CondOut) - (thread $Then $S1 $S2 $ThenOut) - (thread $Else $SIn $S3 $ElseOut) - (= $Answer - (if $CondOut - (, $ThenOut - (= $SOut $S2)) - (, $ElseOut - (= $SOut $S3)))))) -; - - - (= - (thread - (, $A $B) $SIn $SOut $Answer) - ( (set-det) - (thread $A $SIn $S1 $AOut) - (thread $B $S1 $SOut $BOut) - (= $Answer - (, $AOut $BOut)))) -; - - - (= - (thread - (or $A $B) $SIn $SOut $Answer) - ( (set-det) - (thread $A $SIn $S1 $AOut) - (thread $B $SIn $S2 $BOut) - (= $Answer - (or - (, $AOut - (= $SOut $S1)) - (, $BOut - (= $SOut $S2)))))) -; - +; ================================================================================ + + + (= (thread (det-if-then-else $Cond $Then $Else) $SIn $SOut $Answer) + (set-det) + (thread $Cond $SIn $S1 $CondOut) + (thread $Then $S1 $S2 $ThenOut) + (thread $Else $SIn $S3 $ElseOut) + (= $Answer + (det-if-then-else $CondOut + (, $ThenOut + (= $SOut $S2)) + (, $ElseOut + (= $SOut $S3))))) + + (= (thread (det-if-then $Cond $Then) $SIn $SOut $Answer) + (set-det) + (thread $Cond $SIn $S1 $CondOut) + (thread $Then $S1 $S2 $ThenOut) + (= $Answer + (det-if-then $CondOut + (, $ThenOut + (= $SOut $S2))))) + + (= (thread (if $Cond $Then $Else) $SIn $SOut $Answer) + (set-det) + (thread $Cond $SIn $S1 $CondOut) + (thread $Then $S1 $S2 $ThenOut) + (thread $Else $SIn $S3 $ElseOut) + (= $Answer + (if $CondOut + (, $ThenOut + (= $SOut $S2)) + (, $ElseOut + (= $SOut $S3))))) + + (= (thread (, $A $B) $SIn $SOut $Answer) + (set-det) + (thread $A $SIn $S1 $AOut) + (thread $B $S1 $SOut $BOut) + (= $Answer + (, $AOut $BOut))) + + (= (thread (or $A $B) $SIn $SOut $Answer) + (set-det) + (thread $A $SIn $S1 $AOut) + (thread $B $SIn $S2 $BOut) + (= $Answer + (or + (, $AOut + (= $SOut $S1)) + (, $BOut + (= $SOut $S2))))) ; -; - - (= - (thread - (call $Call) $SIn $SOut $Answer) - ( (set-det) (det-if-then-else (var $Call) (, (= $Answer (call $Call)) (= $SIn $SOut)) (, (thread $Call $SIn $SOut $CallOut) (= $Answer (call $CallOut)))))) -; - - - (= - (thread - (not $Call) $SIn $SOut $Answer) - ( (set-det) - (thread $Call $SIn $S1 $CallOut) - (= $Answer - (, - (not $CallOut) - (= $SIn $SOut))))) -; - - - (= - (thread - (setof $X $Test $Xs) $SIn $SIn $Answer) - ( (set-det) - (thread $Test $SIn $S1 $TestOut) - (= $Answer - (setof $X - (^ $S1 $TestOut) $Xs)))) -; - - - (= - (thread - (bagof $X $Test $Xs) $SIn $SIn $Answer) - ( (set-det) - (thread $Test $SIn $S1 $TestOut) - (= $Answer - (bagof $X - (^ $S1 $TestOut) $Xs)))) -; - - - (= - (thread - (^ $X $Test) $SIn $SOut $Answer) - ( (set-det) - (thread $Test $SIn $SOut $TestOut) - (= $Answer - (^ $X $TestOut)))) -; - - - - (= - (thread - !$B $SIn $SOut $Answer) - ( (set-det) - (thread $B $SIn $SOut $BOut) - (= $Answer - !$BOut))) -; - - - (= - (thread - (= $H $B) $SIn $SOut $Answer) - ( (set-det) - (thread $H $SIn $SOut $HOut) - (thread $B $SIn $SOut $BOut) - (= $Answer - (= $HOut $BOut)))) -; - +; If call is variable, won't thread right if requires state. + (= (thread (call $Call) $SIn $SOut $Answer) + (set-det) + (det-if-then-else + (var $Call) + (, + (= $Answer + (call $Call)) + (= $SIn $SOut)) + (, + (thread $Call $SIn $SOut $CallOut) + (= $Answer + (call $CallOut))))) + + (= (thread (not $Call) $SIn $SOut $Answer) + (set-det) + (thread $Call $SIn $S1 $CallOut) + (= $Answer + (, + (not $CallOut) + (= $SIn $SOut)))) + + (= (thread (setof $X $Test $Xs) $SIn $SIn $Answer) + (set-det) + (thread $Test $SIn $S1 $TestOut) + (= $Answer + (setof $X + (^ $S1 $TestOut) $Xs))) + + (= (thread (bagof $X $Test $Xs) $SIn $SIn $Answer) + (set-det) + (thread $Test $SIn $S1 $TestOut) + (= $Answer + (bagof $X + (^ $S1 $TestOut) $Xs))) + + (= (thread (^ $X $Test) $SIn $SOut $Answer) + (set-det) + (thread $Test $SIn $SOut $TestOut) + (= $Answer + (^ $X $TestOut))) + + + (= (thread !$B $SIn $SOut $Answer) + (set-det) + (thread $B $SIn $SOut $BOut) + (= $Answer + !$BOut)) + + (= (thread (= $H $B) $SIn $SOut $Answer) + (set-det) + (thread $H $SIn $SOut $HOut) + (thread $B $SIn $SOut $BOut) + (= $Answer + (= $HOut $BOut))) - (= - (thread - (true $GIn) $SIn $SOut $Answer) - ( (set-det) - (= $SIn $SOut) - (= $Answer - (true-in $GIn $SIn)))) -; - - - (= - (thread - (add $GIn) $SIn $SOut $Answer) - ( (set-det) (= $Answer (add-in $GIn $SIn $SOut)))) -; - - - (= - (thread - (del $GIn) $SIn $SOut $Answer) - ( (set-det) (= $Answer (del-in $GIn $SIn $SOut)))) -; - - - (= - (thread $GIn $SIn $SOut $GOut) + (= (thread (true $GIn) $SIn $SOut $Answer) + (set-det) + (= $SIn $SOut) + (= $Answer + (true-in $GIn $SIn))) + + (= (thread (add $GIn) $SIn $SOut $Answer) + (set-det) + (= $Answer + (add-in $GIn $SIn $SOut))) + + (= (thread (del $GIn) $SIn $SOut $Answer) + (set-det) + (= $Answer + (del-in $GIn $SIn $SOut))) + + (= (thread $GIn $SIn $SOut $GOut) (add-state $GIn $SIn $SOut $GOut)) -; - diff --git a/metagame/theory/boards.metta b/metagame/theory/boards.metta index 0ff473d..aa3ce91 100644 --- a/metagame/theory/boards.metta +++ b/metagame/theory/boards.metta @@ -1,459 +1,301 @@ +; (convert_to_metta_file boards $_299632 metagame/theory/boards.pl metagame/theory/boards.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ; boards.pl ; -; - +; ================================================================================ ; -; - +; Starting Game ; -; - +; ================================================================================ ; -; - +; Initialize the board (create all the empty squares), ; -; - +; set the initial stage to be assign, which will terminate ; -; - +; if there is no assignment stage for the game. ; -; - +; The game starts with PLAYER in control, and MOVE_COUNT = 0. ; -; - +; The initial setup is determined, possibly using a random ; -; - +; setup as returned from the hook: random_assignments(Assignments). ; -; - +; (See parse.pl) ; -; - +; ---------- ; -; - +; START_GAME ; -; - +; ---------- ; -; - +; Passes a dummy variable to start_game/1, as for now the current ; -; - +; game is passed through the asserted procedures: ; -; - +; player_current_game/1 ; -; - +; opponent_current_game/1 ; ; - ; -; - +; This is usually achieved earlier by calling the predicate: ; -; - +; file_make_test_game/1 ; -; - +; with a file in which a game is stored. ; -; - +; A cleaner verion would pass the game as a variable too, and the dummy ; -; - +; variable reminds us of this! - (= - (start-game) + (= (start-game) (start-game $Game)) -; + (= (start-game $Game) + (initialize-state-properties) + (create-board-and-setup $Game)) - (= - (start-game $Game) - ( (initialize-state-properties) (create-board-and-setup $Game))) -; + (= (default_init_move_count 0) True) + (= (default_init_stage assign) True) - (= - (default_init_move_count 0) True) -; - - - (= - (default_init_stage assign) True) -; - - - (= - (default_init_control player) True) -; - + (= (default_init_control player) True) ; -; - +; initialize_state_properties :- ; -; - +; put_stage(assign), ; -; - +; put_control(player), ; -; - - - - (= - (initialize-state-properties) - ( (default-init-stage $Stage) - (default-init-control $Player) - (default-init-move-count $Count) - (initialize-state-properties $Stage $Player $Count))) -; - - - (= - (initialize-state-properties $Stage $Player $Count) - ( (put-stage $Stage) - (put-control $Player) - (add (move-count $Count)))) -; +; set_initial_move_count. + (= (initialize-state-properties) + (default-init-stage $Stage) + (default-init-control $Player) + (default-init-move-count $Count) + (initialize-state-properties $Stage $Player $Count)) + (= (initialize-state-properties $Stage $Player $Count) + (put-stage $Stage) + (put-control $Player) + (add (move-count $Count))) - (= - (create-board-and-setup $Game) - ( (initialize-board $Game) (create-initial-setup $Game))) -; + (= (create-board-and-setup $Game) + (initialize-board $Game) + (create-initial-setup $Game)) - (= - (create-initial-setup $Game) - ( (game-has-assignments $Game $Ass) (do-assignments $Ass))) -; + (= (create-initial-setup $Game) + (game-has-assignments $Game $Ass) + (do-assignments $Ass)) ; -; - +; ================================================================================ ; -; - +; Initial Generation of Board ; -; - +; ================================================================================ ; -; - +; A board is a set of squares, initially empty, and a connectivity ; -; - +; relation between them. - (= - (initialize-board $Game) + (= (initialize-board $Game) (make-empty-board)) -; - - - - (= - (make-empty-board) - ( (current-board $B) - (board-size $B $X $Y) - (array-squares $X $Y $Squares) - (make-empty $Squares))) -; + (= (make-empty-board) + (current-board $B) + (board-size $B $X $Y) + (array-squares $X $Y $Squares) + (make-empty $Squares)) - (= - (make_empty ()) True) -; - - (= - (make-empty (Cons $Sq $Rest)) - ( (set-empty $Sq) (make-empty $Rest))) -; + (= (make_empty ()) True) + (= (make-empty (Cons $Sq $Rest)) + (set-empty $Sq) + (make-empty $Rest)) ; -; - +; ================================================================================ ; -; - +; Determining initial setup: ; -; - +; ================================================================================ ; -; - +; a. arbitrary, put the pieces on the squares. ; -; - +; b. (player) assigns: Put the pieces in player's hands, ; -; - +; and assert that player can assign to the specified squares. ; -; - +; (c. random: by this point, the initial assignment is already determined by ; -; - +; an external source. It will thus look like an arbitrary assignment, ; -; +; so we need no special case.) + (= (do-assignments $As) + (arbitrary-assignment $As) + (set-det) + (do-arbitrary-assignment $As)) + (= (do-assignments $As) + (assignment-decision $As $Assigner $PieceNames $Squares) + (player $Assigner) + (set-det) + (invert + (= $Assigner $Squares) opponent + (= $OppAssigner $OppSquares)) + (do-assignments-for-player player $Assigner $PieceNames $Squares) + (do-assignments-for-player opponent $OppAssigner $PieceNames $OppSquares)) - (= - (do-assignments $As) - ( (arbitrary-assignment $As) - (set-det) - (do-arbitrary-assignment $As))) -; - - (= - (do-assignments $As) - ( (assignment-decision $As $Assigner $PieceNames $Squares) - (player $Assigner) - (set-det) - (invert - (= $Assigner $Squares) opponent - (= $OppAssigner $OppSquares)) - (do-assignments-for-player player $Assigner $PieceNames $Squares) - (do-assignments-for-player opponent $OppAssigner $PieceNames $OppSquares))) -; - - - (= - (assignment-decision $As $Assigner $PieceNames $Squares) + (= (assignment-decision $As $Assigner $PieceNames $Squares) (decision $As $Assigner $PieceNames $Squares)) -; - - - (= - (do-assignments-for-player $Owner $Placer $PieceNames $Squares) - ( (make-assignable-squares $Placer $Squares) (place-pieces-in-hand $PieceNames $Owner $Placer))) -; + (= (do-assignments-for-player $Owner $Placer $PieceNames $Squares) + (make-assignable-squares $Placer $Squares) + (place-pieces-in-hand $PieceNames $Owner $Placer)) - (= - (make-assignable-squares $Player $Squares) + (= (make-assignable-squares $Player $Squares) ( (det-if-then-else - (remove-symbol &self - (assignable_squares $Player $_)) True True) (add-symbol &self (assignable_squares $Player $Squares)))) -; - + (remove-is-symbol &self + (assignable_squares $Player $_)) True True) (add-is-symbol &self (assignable_squares $Player $Squares)))) ; -; - +; Arbitary can be: ; -; - +; 1. a list of assignments of pieces to squares. ; -; - +; This is the general case for symmetric opening games. ; -; - +; 2. a structure assign(A1,A2), where A1 is an assignment ; -; - +; for player, and A2 for opponent. ; -; - +; This is only used for interface setup, at the moment. ; -; - - - (= - (arbitrary_assignment - (Cons $_ $_)) True) -; +; (Actually, we don't use this at all yet). + (= (arbitrary_assignment (Cons $_ $_)) True) ; -; +; arbitrary_assignment(assign(A1,A2)). - - (= - (do-arbitrary-assignment $As) + (= (do-arbitrary-assignment $As) (place-pieces-on-squares $As)) -; + (= (place-pieces-on-squares $Assign) + (uncollect $Assign $As) + (place-pieces-on-squares $As player) + (invert $As opponent $IAs) + (place-pieces-on-squares $IAs opponent)) +; ; from generator/gen.pl - (= - (place-pieces-on-squares $Assign) - ( (uncollect $Assign $As) - (place-pieces-on-squares $As player) - (invert $As opponent $IAs) - (place-pieces-on-squares $IAs opponent))) -; + (= (place_pieces_on_squares () $_) True) + (= (place-pieces-on-squares (Cons $A $As) $Player) + (assign-piece-to-square $A $Player) + (place-pieces-on-squares $As $Player)) - (= - (place_pieces_on_squares () $_) True) -; - - (= - (place-pieces-on-squares - (Cons $A $As) $Player) - ( (assign-piece-to-square $A $Player) (place-pieces-on-squares $As $Player))) -; - - - - (= - (assign-piece-to-square - (= $P $Sq) $Player) - ( (piece-struct $Piece $P $Player) (place-piece $Piece $Sq))) -; - + (= (assign-piece-to-square (= $P $Sq) $Player) + (piece-struct $Piece $P $Player) + (place-piece $Piece $Sq)) ; -; - +; place_pieces_in_hand(P,Player,Hand) ; -; - +; Player owns the pieces. ; -; - - - - (= - (place_pieces_in_hand () $Player $Hand) True) -; +; Hand will assign them. - (= - (place-pieces-in-hand - (Cons $P $Ps) $Player $Hand) - ( (place-piece-in-hand $P $Player $Hand) (place-pieces-in-hand $Ps $Player $Hand))) -; + (= (place_pieces_in_hand () $Player $Hand) True) + (= (place-pieces-in-hand (Cons $P $Ps) $Player $Hand) + (place-piece-in-hand $P $Player $Hand) + (place-pieces-in-hand $Ps $Player $Hand)) - (= - (place-piece-in-hand $P $Player $Hand) - ( (piece-struct-name $Piece $P) - (owns $Piece $Player) - (put-in-hand $Piece $Hand))) -; - + (= (place-piece-in-hand $P $Player $Hand) + (piece-struct-name $Piece $P) + (owns $Piece $Player) + (put-in-hand $Piece $Hand)) ; -; - +; ================================================================================ ; -; - +; Board Connectivity ; -; - +; ================================================================================ ; -; - +; Convert squares and directions as generated to simple ordered pairs. ; -; - - - (= - (connected $S1 $S2 $Dir) - ( (square $S1 $Xf $Yf) - (square $S2 $Xt $Yt) - (direction $Dir $DX $DY) - (current-board-type $T) - (conn-for-type $T - (, $Xf $Yf) - (, $Xt $Yt) - (, $DX $DY)))) -; +; Really need Game as an arg here, to decide vertical and board size. + (= (connected $S1 $S2 $Dir) + (square $S1 $Xf $Yf) + (square $S2 $Xt $Yt) + (direction $Dir $DX $DY) + (current-board-type $T) + (conn-for-type $T + (, $Xf $Yf) + (, $Xt $Yt) + (, $DX $DY))) - (= - (conn-for-type planar $From $To $Dir) + (= (conn-for-type planar $From $To $Dir) (conn $From $To $Dir)) -; - - (= - (conn-for-type vertical-cylinder $From $To $Dir) + (= (conn-for-type vertical-cylinder $From $To $Dir) (conn-cyl $From $To $Dir)) -; - ; -; - +; The structure of the board is represented by the connected relation that ; -; - +; defines how each location (Xf,Yf) on the board is connected to each ; -; - +; other location (Xt,Yt) via a vector (Dx,Dy) defined as: ; -; - +; Xt = Xf + Dx, ; -; - +; Yt = Yf + Dy ; -; - +; Note: this is intended to be an ``operational'' predicate: ; -; - +; This predicate is used for all generated games. ; -; - +; (Thanks to Nick Flann for this predicate). - (= - (conn - (, $Xf $Yf) - (, $Xt $Yt) - (, $Dx $Dy)) + (= (conn (, $Xf $Yf) (, $Xt $Yt) (, $Dx $Dy)) (| (det-if-then (, @@ -492,55 +334,37 @@ (- $Xt $Dx)) (is $Yf (- $Yt $Dy)))))))) -; - ; -; - +; This pred. is instantiated for the board dimensions chosen ; -; - +; in the game. ; -; - +; Make max and min specific constants. - (= - (legal-location $Sq) + (= (legal-location $Sq) (on-board $Sq)) -; - - (= - (on-board (, $X $Y)) - ( (current-board-size $XMax $YMax) - (>= $X 1) - (=< $X $XMax) - (>= $Y 1) - (=< $Y $YMax))) -; - + (= (on-board (, $X $Y)) + (current-board-size $XMax $YMax) + (>= $X 1) + (=< $X $XMax) + (>= $Y 1) + (=< $Y $YMax)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Cylindrical Boards ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (conn-cyl - (, $Xf $Yf) - (, $Xt $Yt) - (, $Dx $Dy)) + (= (conn-cyl (, $Xf $Yf) (, $Xt $Yt) (, $Dx $Dy)) (| (det-if-then (, @@ -586,226 +410,152 @@ (legal-location-cyl (, $Xf1 $Yf1) (, $Xf $Yf)))))))) -; - ; -; - +; This pred. is instantiated for the board dimensions chosen ; -; - +; in the game. ; -; - +; This won't work backwards to generate a from square. ; -; - - - (= - (legal-location-cyl - (, $X1 $Y1) - (, $X $Y)) - ( (current-board-size $XN $YN) - (is $X - (+ - (mod - (- - (+ $X1 $XN) 1) $XN) 1)) - (= $Y $Y1) - (on-board (, $X $Y)))) -; +; Add an XN to cover 1 negative wrap, as mod undef for X<0. + (= (legal-location-cyl (, $X1 $Y1) (, $X $Y)) + (current-board-size $XN $YN) + (is $X + (+ + (mod + (- + (+ $X1 $XN) 1) $XN) 1)) + (= $Y $Y1) + (on-board (, $X $Y))) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Scaling # leaps to until it is off the board or wraps ; -; - +; back to original square (for vertical cylinder boards). ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (= - (valid-min $N $N) - ( (number $N) (set-det))) -; - - (= - (valid_min $_ 1) True) -; - + (= (valid-min $N $N) + (number $N) + (set-det)) + (= (valid_min $_ 1) True) ; -; - +; VALID_MAX(Constraint,Dir,Max) ; -; - +; If Constraint already a number, return it. ; -; - +; Otherwise, find the constraint based on the ; -; - - - (= - (valid-max $N $_ $N) - ( (number $N) (set-det))) -; - - (= - (valid-max $_ $Dir $Max) - ( (direction $Dir $Dx $Dy) - (is $XMag - (abs $Dx)) - (is $YMag - (abs $Dy)) - (valid-max-dir $XMag $YMag $Max))) -; +; direction and the board. + (= (valid-max $N $_ $N) + (number $N) + (set-det)) + (= (valid-max $_ $Dir $Max) + (direction $Dir $Dx $Dy) + (is $XMag + (abs $Dx)) + (is $YMag + (abs $Dy)) + (valid-max-dir $XMag $YMag $Max)) ; -; - +; VALID_MAX_DIR(+XMag,+YMag,-Max) ; -; - +; Given a magnitude for X and Y offsets ; -; - +; of each leap, MAX is the number of ; -; - +; leaps which need be considered on the board. ; ; - ; -; - +; If both are 0, only 1 leap is necessary, max! ; -; - +; If X is 0, it's just the number of leaps to ; -; - +; cross the board to last rank. ; -; - +; If Y is 0, use the max leaps to cross the ; -; - +; X axis, which varies on the type of board. ; -; - +; If neither 0 but on a cylinder board, the Y axis ; -; - +; is the constraint. ; -; - +; Else, the max is the min of the maxes on both axes. - (= - (valid-max-dir 0 0 1) + (= (valid-max-dir 0 0 1) (set-det)) -; - - (= - (valid-max-dir 0 $Dy $Max) - ( (set-det) - (current-board-size $XMax $YMax) - (is $Max - (// $YMax $Dy)))) -; - - (= - (valid-max-dir $Dx 0 $Max) - ( (set-det) - (current-board-type $Type) - (current-board-size $XMax $YMax) - (max-leaps $Type $XMax $Dx $Max))) -; - - (= - (valid-max-dir $Dx $Dy $Max) - ( (current-board-type vertical-cylinder) - (set-det) - (current-board-size $XMax $YMax) - (is $Max - (// $YMax $Dy)))) -; - - (= - (valid-max-dir $Dx $Dy $Max) - ( (current-board-size $Bx $By) - (is $XMax - (// $Bx $Dx)) - (is $YMax - (// $By $Dy)) - (min $XMax $YMax $Max))) -; - - - - - (= - (max-leaps planar $BMax $Delta $Max) - ( (set-det) (is $Max (// $BMax $Delta)))) -; - - (= - (max-leaps vertical-cylinder $BMax $Delta $Max) + (= (valid-max-dir 0 $Dy $Max) + (set-det) + (current-board-size $XMax $YMax) + (is $Max + (// $YMax $Dy))) + (= (valid-max-dir $Dx 0 $Max) + (set-det) + (current-board-type $Type) + (current-board-size $XMax $YMax) + (max-leaps $Type $XMax $Dx $Max)) + (= (valid-max-dir $Dx $Dy $Max) + (current-board-type vertical-cylinder) + (set-det) + (current-board-size $XMax $YMax) + (is $Max + (// $YMax $Dy))) + (= (valid-max-dir $Dx $Dy $Max) + (current-board-size $Bx $By) + (is $XMax + (// $Bx $Dx)) + (is $YMax + (// $By $Dy)) + (min $XMax $YMax $Max)) + + + + (= (max-leaps planar $BMax $Delta $Max) + (set-det) + (is $Max + (// $BMax $Delta))) + (= (max-leaps vertical-cylinder $BMax $Delta $Max) (wrap-leaps $BMax $Delta $Max)) -; - - (= - (wl $A $B $C) + (= (wl $A $B $C) (wrap-leaps $A $B $C)) -; - - (= - (wrap-leaps $Board $D $Max) - ( (gcf $Board $D $F) - (max $Board $D $M) - (is $Max - (// $M $F)))) -; - + (= (wrap-leaps $Board $D $Max) + (gcf $Board $D $F) + (max $Board $D $M) + (is $Max + (// $M $F))) ; -; - +; gcf(HighestCurrentFactor,CurrentRemainder,GCF). ; -; - +; This is the Euclidan algorithm. - (= - (gcf $A 0 $A) + (= (gcf $A 0 $A) (set-det)) -; - - (= - (gcf $A $B $F) - ( (is $M - (mod $A $B)) (gcf $B $M $F))) -; - + (= (gcf $A $B $F) + (is $M + (mod $A $B)) + (gcf $B $M $F)) diff --git a/metagame/theory/goals.metta b/metagame/theory/goals.metta index 5489c7a..afa20e4 100644 --- a/metagame/theory/goals.metta +++ b/metagame/theory/goals.metta @@ -1,417 +1,272 @@ +; (convert_to_metta_file goals $_46672 metagame/theory/goals.pl metagame/theory/goals.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; goals.pl ; -; - +; Representation of goal achievement and complete legal moves ; -; - +; for symmetric chess-like games. ; -; - +; These routines form the skeleton of the game definition, ; -; - +; providing three components: ; ; - ; -; - +; 1. legal(Move,Player,StateIn,StateOut) ; -; - +; True when Move is legal for Player in StateIn, and Produces StateOut. ; ; - ; -; - +; 2. game_over(State,_) ; -; - +; True when the game in StateIn has ended. (Second var is dummy). ; ; - ; -; - +; 3. game_outcome(FinalState,Outcome) ; -; - +; Outcome is the final outcome of Game, which ends in FinalState. ; -; - +; Outcome is either PLAYER, OPPONENT, or DRAW. ; ; - ; -; - +; Any 2-player game must provide exactly these three procedures, ; -; - +; and an interface which relies on these three is thus fully ; -; - +; general to cover 2-player games. ; ; - ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Goals ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; The GAME IS OVER when ANY of the following is true: ; -; - +; 1. some player has achieved a goal ; -; - +; 2. the maximum number of moves have been played. ; -; - +; 3. the position has repeated a certain number of times. ; -; - +; (REPETITION IS NOT IMPLEMENTED YET, maybe never!). - (= - (game-over) + (= (game-over) (goal-achieved $Player $Game)) -; - - (= - (game-over) + (= (game-over) (exceeded-move-limit $Game)) -; - - (= - (game-over) + (= (game-over) (too-many-repetitions $Game)) -; - ; -; - +; ======================================== ; -; - +; K-Move Rule ; -; +; ======================================== - - (= - (exceeded-move-limit $Game) - ( (game-move-limit $Game $L) (move-count $L))) -; - + (= (exceeded-move-limit $Game) + (game-move-limit $Game $L) + (move-count $L)) ; -; - +; GAME_MOVE_LIMIT(+Game,Number). ; -; - +; Could be generated differently with each game, ; -; - +; or set arbitrarily. ; -; - - - (= - (game_move_limit $Game 200) True) -; +; Here we just set it for all games. + (= (game_move_limit $Game 200) True) ; -; - +; MOVE_LIMIT_OUTCOME(+Game,-Outcome). ; -; - +; If the game ended by exceeding the move limit, ; -; - +; each game could decide what the outcome is (who wins). ; -; - - - (= - (move_limit_outcome $Game draw) True) -; +; Here we say it is a draw for all games. + (= (move_limit_outcome $Game draw) True) ; -; - +; ======================================== ; -; - +; Repetition Rule ; -; - +; ======================================== ; -; - +; THIS IS NOT IMPLEMENTED! Hooks are placed here in case we ; -; - +; do implement it sometime. ; -; - +; GAME_REPETITIONS(+Game,Number). ; -; - +; Could be generated differently with each game, or set arbitrarily. ; -; - - - (= - (game_repetitions $Game 3) True) -; +; Here we just say a game ends if a position repeats 3 times. + (= (game_repetitions $Game 3) True) ; -; - +; REPETITION_OUTCOME(+Game,-Outcome). ; -; - +; If the game ended by too many repetitions, ; -; - +; each game could decide what the outcome is (who wins). ; -; - - - (= - (repetition_outcome $Game draw) True) -; +; Here we say it is a draw for all games. + (= (repetition_outcome $Game draw) True) ; -; - +; TOO_MANY_REPETITIONS ; -; - +; There are too many repetitions when the present position ; -; - +; repeats a previous one a number of times. ; ; - - (= - (too_many_repetitions $Game) + (= (too_many_repetitions $Game) (empty)) -; - ; -; - +; GAME_OUTCOME(?Outcome) ; -; - +; There is a game outcome only when the game is over. ; -; - +; Determines the outcome based on which players have achieved one of their goals, ; -; - +; or on the game-specific outcome in case of exceeding the move limit or ; -; - - - (= - (game-outcome $Outcome) - ( (too-many-repetitions $Game) - (set-det) - (repetition-outcome $Game $Outcome))) -; - - (= - (game-outcome $Outcome) - ( (exceeded-move-limit $Game) - (set-det) - (move-limit-outcome $Game $Outcome))) -; - - (= - (game-outcome $Outcome) - ( (player-outcome player $WinP) - (player-outcome opponent $WinO) - (outcome $WinP $WinO $Outcome))) -; +; excess-repetition. + (= (game-outcome $Outcome) + (too-many-repetitions $Game) + (set-det) + (repetition-outcome $Game $Outcome)) + (= (game-outcome $Outcome) + (exceeded-move-limit $Game) + (set-det) + (move-limit-outcome $Game $Outcome)) + (= (game-outcome $Outcome) + (player-outcome player $WinP) + (player-outcome opponent $WinO) + (outcome $WinP $WinO $Outcome)) ; -; - +; PLAYER_OUTCOME(+Player,?Yes/No) - (= - (player-outcome $Player $Outcome) + (= (player-outcome $Player $Outcome) (det-if-then-else (goal-achieved $Player $Game) (= $Outcome yes) (= $Outcome no))) -; - ; -; - +; OUTCOME(Player1_Outcome,Player2_Outcome,Outcome). ; -; - +; Outcome is the player who achieved the goal, ; -; - - - (= - (outcome yes yes draw) True) -; - - (= - (outcome yes no player) True) -; - - (= - (outcome no yes opponent) True) -; +; or draw if both. + (= (outcome yes yes draw) True) + (= (outcome yes no player) True) + (= (outcome no yes opponent) True) ; -; - +; GOAL_ACHIEVED(Player,Game) ; -; - - - (= - (goal-achieved $Player $Game) - ( (game-player-has-goal $Game $Player $Goal) - (goal-true $Goal) - (verbosely-format "Goal achieved: ~p achieved goal ~p~n" - (:: $Player $Goal)))) -; +; Player is one of the players, and has achieved one of his goals in Game. + (= (goal-achieved $Player $Game) + (game-player-has-goal $Game $Player $Goal) + (goal-true $Goal) + (verbosely-format "Goal achieved: ~p achieved goal ~p~n" + (:: $Player $Goal))) ; -; - +; An ARRIVAL goal has been achieved when a piece matching Description ; -; - - - (= - (goal-true (arrive $Descr $Squares)) - ( (member $Sq $Squares) - (on $Piece $Sq) - (matches $Descr $Piece))) -; +; has arrived on one of the Squares. + (= (goal-true (arrive $Descr $Squares)) + (member $Sq $Squares) + (on $Piece $Sq) + (matches $Descr $Piece)) ; -; - +; An ERADICATE goal has been achieved when there are no pieces ; -; - +; *on the board* matching a description, when players are no longer assigning pieces. ; -; - +; (Else these goals would be satisfied immediately and trivially). ; -; - - (= - (goal-true (eradicate $Descr)) - ( (not still-assigning) (not (exists $Descr)))) -; - +; still_assigning defined in legal.pl + (= (goal-true (eradicate $Descr)) + (not still-assigning) + (not (exists $Descr))) ; -; - +; A player is STALEMATED when it is his turn to move, ; -; - - (= - (goal-true (stalemate $Player)) - ( (control $Player) (not (legal-move $M $Player)))) -; - +; but he can't make any legal moves. + (= (goal-true (stalemate $Player)) + (control $Player) + (not (legal-move $M $Player))) ; -; - +; A Description exists when a piece on a square matches it. ; -; - +; There is an efficiency tradeoff here. ; -; - +; 1. We could examine each piece on the board, to see if it matches the ; -; - +; description. ; -; - +; 2. We could consider any piece which could match the description, ; -; - +; and see if it is on the board. ; ; - ; -; - +; The second case is much better if we have indexing to see if ; -; +; specific pieces are on the board. - - (= - (exists $Descr) - ( (on $Piece $Sq) (matches $Descr $Piece))) -; - + (= (exists $Descr) + (on $Piece $Sq) + (matches $Descr $Piece)) diff --git a/metagame/theory/invert.metta b/metagame/theory/invert.metta index 61bf866..8b3e7e2 100644 --- a/metagame/theory/invert.metta +++ b/metagame/theory/invert.metta @@ -1,157 +1,105 @@ +; (convert_to_metta_file invert $_168502 metagame/theory/invert.pl metagame/theory/invert.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; invert.pl ; -; - +; ;; How to invert game component defs from perspective of ; -; - +; ;; other player. ; -; - +; invert(Term,Player,InvertedTerm). ; -; - +; If inverting for player, do nothing, otherwise flip. - (= - (invert $Term $Player $Term2) + (= (invert $Term $Player $Term2) (det-if-then-else (= $Player player) (= $Term $Term2) (invert $Term $Term2))) -; - - (= - (invert opponent player) + (= (invert opponent player) (set-det)) -; - - (= - (invert player opponent) + (= (invert player opponent) (set-det)) -; - - (= - (invert $Term $Term2) + (= (invert $Term $Term2) (det-if-then-else (atom $Term) (= $Term $Term2) (invert-struct $Term $Term2))) -; - ; -; - - - (= - (invert-struct - (square $X1 $Y1) $Sq) - ( (set-det) (invert-square (square $X1 $Y1) $Sq))) -; - - (= - (invert-struct - (dir $X1 $Y1) $Dir) - ( (set-det) (invert-dir (dir $X1 $Y1) $Dir))) -; - - (= - (invert-struct $Pred $PredOut) - ( (functor $Pred $F $N) - (functor $PredOut $F $N) - (invert-args $N $Pred $PredOut))) -; - +; invert_struct(square(X1,Y1),square(X2,Y2)) :- !, + + (= (invert-struct (square $X1 $Y1) $Sq) + (set-det) + (invert-square + (square $X1 $Y1) $Sq)) + (= (invert-struct (dir $X1 $Y1) $Dir) + (set-det) + (invert-dir + (dir $X1 $Y1) $Dir)) + (= (invert-struct $Pred $PredOut) + (functor $Pred $F $N) + (functor $PredOut $F $N) + (invert-args $N $Pred $PredOut)) - (= - (invert-args 0 $_ $_) + (= (invert-args 0 $_ $_) (set-det)) -; - - (= - (invert-args $N $Pred $PredOut) - ( (arg $N $Pred $A) - (invert $A $A1) - (arg $N $PredOut $A1) - (is $N1 - (- $N 1)) - (invert-args $N1 $Pred $PredOut))) -; - + (= (invert-args $N $Pred $PredOut) + (arg $N $Pred $A) + (invert $A $A1) + (arg $N $PredOut $A1) + (is $N1 + (- $N 1)) + (invert-args $N1 $Pred $PredOut)) - (= - (invert-square $Sq1 $Sq) - ( (current-board-size $XN $YN) - (current-board-inversion $Inv) - (invert-square-dim $Inv $XN $YN $Sq1 $Sq))) -; + (= (invert-square $Sq1 $Sq) + (current-board-size $XN $YN) + (current-board-inversion $Inv) + (invert-square-dim $Inv $XN $YN $Sq1 $Sq)) + (= (invert-square-dim diagonal $XN $YN (square $X1 $Y1) (square $X2 $Y2)) + (is $X2 + (+ + (- $XN $X1) 1)) + (is $Y2 + (+ + (- $YN $Y1) 1))) + (= (invert-square-dim forward $XN $YN (square $X1 $Y1) (square $X2 $Y2)) + (= $X1 $X2) + (is $Y2 + (+ + (- $YN $Y1) 1))) - (= - (invert-square-dim diagonal $XN $YN - (square $X1 $Y1) - (square $X2 $Y2)) - ( (is $X2 - (+ - (- $XN $X1) 1)) (is $Y2 (+ (- $YN $Y1) 1)))) -; - (= - (invert-square-dim forward $XN $YN - (square $X1 $Y1) - (square $X2 $Y2)) - ( (= $X1 $X2) (is $Y2 (+ (- $YN $Y1) 1)))) -; + (= (invert-dir (dir $X1 $Y1) (dir $X2 $Y2)) + (current-board-inversion $Inv) + (inv-negate-dir $Inv x $X1 $X2) + (inv-negate-dir $Inv y $Y1 $Y2)) - - (= - (invert-dir - (dir $X1 $Y1) - (dir $X2 $Y2)) - ( (current-board-inversion $Inv) - (inv-negate-dir $Inv x $X1 $X2) - (inv-negate-dir $Inv y $Y1 $Y2))) -; - - - - (= - (inv-negate-dir diagonal $Axis $X $XNeg) + (= (inv-negate-dir diagonal $Axis $X $XNeg) (negates $X $XNeg)) -; - - (= - (inv-negate-dir forward $Axis $X1 $X2) + (= (inv-negate-dir forward $Axis $X1 $X2) (det-if-then-else (= $Axis y) (negates $X1 $X2) - (= $X1 $X2))) -; - + (= $X1 $X2))) diff --git a/metagame/theory/legal.metta b/metagame/theory/legal.metta index e50b8ff..21f6d29 100644 --- a/metagame/theory/legal.metta +++ b/metagame/theory/legal.metta @@ -1,1004 +1,672 @@ +; (convert_to_metta_file legal $_267288 metagame/theory/legal.pl metagame/theory/legal.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; legal.pl ; -; - +; Rep. class in control and stages framework ; -; - +; /*================================================================================ ; -; - +; Basic Move Sequence ; ; - ; -; - +; 0. Prelims/carry-overs: ; -; - +; 0a. If opponent_promotes(Piece)), then promote piece. ; ; - ; -; - +; 1. Decide to place or move a piece. ; -; - +; 1a. If more pieces to be initially assigned, make an assignment and ; -; - +; goto 7. ; -; - +; 1b. If a player has a piece in_hand (i.e. one he possessed earlier), ; -; - +; he can either (i) place this and goto 7, or (ii) goto 2. ; -; - +; 1c. Note we bypass promotion for placed pieces, and the opponent ; -; - +; can start directly in the MOVE stage. ; -; - +; 2. Move a piece ; -; - +; 2a. If the game has a global MUST_CAPTURE constraint: ; -; - +; Then: if some capturing moves are available, then make one of them. ; -; - +; Else, (no captures available) make a non-capturing move. ; -; - +; 2b. If a piece is moved which MUST_CAPTURE if it can, and it can ; -; - +; make a capturing move, then these are the only moves it can do. ; -; - +; 2c. Else, it can capture or move. ; -; - +; 2d. If it captured, goto 3, else goto 6. ; -; - +; 3. Remove all captured pieces from the board (before executing effects) ; -; - +; 4. Execute capture effects: ; -; - +; 4a. Removed pieces just disappear. ; -; - +; 4b. Possessed pieces go to hand (and color) of possessing player. ; -; - +; 5. If piece can CONTINUE_CAPTURING, goto 2 (but only if this really captures) ; -; - +; 5a. Can't continue unless captured something ; -; - +; 5b. If can continue and this piece MUST_CONTINUE, then do so, ; -; - +; otherwise this is optional. ; -; - +; 6. Promote if in promotion territory ; -; - +; 6a. If PLAYER PROMOTES, decide on promoted piece. ; -; - +; 6b. If OPPONENT PROMOTES, add this effect (so opponent will promote ; -; - +; this piece during stage 0b. of his next turn) ; -; - +; 7. Transfer control ; ; - ; -; - +; ================================================================================ ; -; - +; */ ; -; - +; LEGAL(?MOVE) ; -; - +; A move begins with one of the players being in control, ; -; - +; after which a sequence of sub-moves is made, which ends ; -; - +; in transfer of control to the other player. ; -; +; A move_count is tracked throughout the game. - - (= - (legal $M) - ( (control $Player) (legal-move $M $Player))) -; - + (= (legal $M) + (control $Player) + (legal-move $M $Player)) ; -; - - - (= - (legal-move $Move $Player) - ( (stage $Stage) (legal-move $Move $Stage $Player))) -; +; LEGAL_MOVE(Move,Player) + (= (legal-move $Move $Player) + (stage $Stage) + (legal-move $Move $Stage $Player)) ; -; - +; Unlike the pseudo_moves, legal finally transfers ; -; - - - (= - (legal-move $M $Stage $Player) - ( (increment-move-count) - (legal-move $M $Stage $Player $StageOut $_) - (transfer-stage $Stage $StageOut))) -; - +; stage in the state representation. + (= (legal-move $M $Stage $Player) + (increment-move-count) + (legal-move $M $Stage $Player $StageOut $_) + (transfer-stage $Stage $StageOut)) - (= - (legal-move - (Cons $M $Rest) $StageIn $PlayerIn $StageOut $PlayerOut) - ( (pseudo-op $StageIn $M $PlayerIn $Stage1 $Player1) (det-if-then-else (\== $PlayerIn $Player1) (, (= $Player1 $PlayerOut) (= $Stage1 $StageOut)) (legal-move $Rest $Stage1 $Player1 $StageOut $PlayerOut)))) -; + (= (legal-move (Cons $M $Rest) $StageIn $PlayerIn $StageOut $PlayerOut) + (pseudo-op $StageIn $M $PlayerIn $Stage1 $Player1) + (det-if-then-else + (\== $PlayerIn $Player1) + (, + (= $Player1 $PlayerOut) + (= $Stage1 $StageOut)) + (legal-move $Rest $Stage1 $Player1 $StageOut $PlayerOut))) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Basics ; -; - - - - (= - (player_role player) True) -; - - (= - (player_role opponent) True) -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (= - (opposite_role player opponent) True) -; - - (= - (opposite_role opponent player) True) -; + (= (player_role player) True) + (= (player_role opponent) True) + (= (opposite_role player opponent) True) + (= (opposite_role opponent player) True) - (= - (change $P1 $P2) - ( (del $P1) (add $P2))) -; + (= (change $P1 $P2) + (del $P1) + (add $P2)) ; -; - +; Here's where we state the rel between empty and on: ; -; +; empty(Sq) :- \+ on(P,Sq). - - (= - (empty $Sq) + (= (empty $Sq) (on empty $Sq)) -; - - (= - (set-empty $Sq) + (= (set-empty $Sq) (add (on empty $Sq))) -; - ; -; - - - (= - (on $PieceStruct $Player $Square) - ( (piece-struct-owner $PieceStruct $Player) (on $PieceStruct $Square))) -; +; Piece_struct is owned by Player and on Square. + (= (on $PieceStruct $Player $Square) + (piece-struct-owner $PieceStruct $Player) + (on $PieceStruct $Square)) ; -; - - - (= - (piece_struct_name - (piece $Name $Owner) $Name) True) -; - - - (= - (piece_struct_owner - (piece $Name $Owner) $Owner) True) -; +; Kill these later, to use pieces from Gen? + (= (piece_struct_name (piece $Name $Owner) $Name) True) + (= (piece_struct_owner (piece $Name $Owner) $Owner) True) - (= - (piece_struct - (piece $Name $Owner) $Name $Owner) True) -; + (= (piece_struct (piece $Name $Owner) $Name $Owner) True) - (= - (owns $Piece $Owner) + (= (owns $Piece $Owner) (piece-struct-owner $Piece $Owner)) -; - - (= - (add-to-board $Piece $Square) + (= (add-to-board $Piece $Square) (place-piece $Piece $Square)) -; - - (= - (put-in-hand $Piece $Player) + (= (put-in-hand $Piece $Player) (add (in-hand $Piece $Player))) -; - - - (= - (place-piece-from-hand $Piece $Player $Square) - ( (del (in-hand $Piece $Player)) (place-piece $Piece $Square))) -; + (= (place-piece-from-hand $Piece $Player $Square) + (del (in-hand $Piece $Player)) + (place-piece $Piece $Square)) ; -; - +; These two are opposites, naturally. ; -; - +; Removed the empty changes from both. - (= - (lift-piece $Piece $Square) + (= (lift-piece $Piece $Square) (change (on $Piece $Square) (on empty $Square))) -; - - (= - (place-piece $Piece $Square) + (= (place-piece $Piece $Square) (change (on empty $Square) (on $Piece $Square))) -; - - (= - (remove-piece $Taken $TakenSq) + (= (remove-piece $Taken $TakenSq) (lift-piece $Taken $TakenSq)) -; - - (= - (put-control $Player) - ( (det-if-then-else - (control $P) - (del (control $P)) True) (add (control $Player)))) -; - + (= (put-control $Player) + (det-if-then-else + (control $P) + (del (control $P)) True) + (add (control $Player))) ; -; +; Gives away control from Player to his Opponent. - - (= - (transfer-control $Player) + (= (transfer-control $Player) (transfer-control $Player $Opp)) -; - - - (= - (transfer-control $Player $Opp) - ( (opposite-role $Player $Opp) (change (control $Player) (control $Opp)))) -; + (= (transfer-control $Player $Opp) + (opposite-role $Player $Opp) + (change + (control $Player) + (control $Opp))) ; -; - +; Effects of moving a piece. ; -; - - - (= - (move-piece-record $Piece $SqF $SqT) - ( (move-piece $Piece $SqF $SqT) (add (moved-onto $Piece $SqT)))) -; +; Records that this piece moved. + (= (move-piece-record $Piece $SqF $SqT) + (move-piece $Piece $SqF $SqT) + (add (moved-onto $Piece $SqT))) - (= - (place-piece-record $Piece $SqT) + (= (place-piece-record $Piece $SqT) (add (moved-onto $Piece $SqT))) -; - +; ; place_piece(Piece,SqT), ; -; - - - (= - (move-piece $Piece $SqF $SqT) - ( (on $Piece $SqF) - (lift-piece $Piece $SqF) - (place-piece $Piece $SqT))) -; - +; This isn't used by anybody right now. + (= (move-piece $Piece $SqF $SqT) + (on $Piece $SqF) + (lift-piece $Piece $SqF) + (place-piece $Piece $SqT)) +; ; new line - (= - (set-effect $Effect $Captured) - (add (effects $Effect $Captured))) -; - + (= (set-effect $Effect $Captured) + (add (effects $Effect $Captured))) - (= - (del-effect $Effect $Captured) - (del (effects $Effect $Captured))) -; - + (= (del-effect $Effect $Captured) + (del (effects $Effect $Captured))) - (= - (set-effect $Effect) - (add (effect $Effect))) -; - + (= (set-effect $Effect) + (add (effect $Effect))) - (= - (del-effect $Effect) - (del (effect $Effect))) -; - + (= (del-effect $Effect) + (del (effect $Effect))) - (= - (transfer-stage $Stage) - ( (stage $OldStage) (transfer-stage $OldStage $Stage))) -; + (= (transfer-stage $Stage) + (stage $OldStage) + (transfer-stage $OldStage $Stage)) - (= - (transfer-stage $Old $New) + (= (transfer-stage $Old $New) (change (stage $Old) (stage $New))) -; - - - (= - (put-stage $Stage) - ( (det-if-then-else - (stage $OldStage) - (del (stage $OldStage)) True) (add (stage $Stage)))) -; + (= (put-stage $Stage) + (det-if-then-else + (stage $OldStage) + (del (stage $OldStage)) True) + (add (stage $Stage))) - (= - (capture-piece $Taken $TakenSq) + (= (capture-piece $Taken $TakenSq) (remove-piece $Taken $TakenSq)) -; - ; -; - +; replace_piece(Old,New,Sq) :- ; -; - +; change(on(Old,Sq),(on(New,Sq)). - (= - (replace-piece $Old $New $Sq) + (= (replace-piece $Old $New $Sq) (det-if-then-else (= $Old $New) True (change (on $Old $Sq) (on $New $Sq)))) -; - ; -; - +; Here we lifted the piece long ago, and now we decide ; -; - +; to place it down, possibly promoted, somewhere. ; -; - +; Thus we don't need to actually remove the old piece, as it ; -; - +; was removed earlier. - (= - (replace-piece-record $Old $New $Sq) + (= (replace-piece-record $Old $New $Sq) (place-piece $New $Sq)) -; - - (= - (increment-move-count) - ( (move-count $M) - (is $M1 - (+ $M 1)) - (change - (move-count $M) - (move-count $M1)))) -; - + (= (increment-move-count) + (move-count $M) + (is $M1 + (+ $M 1)) + (change + (move-count $M) + (move-count $M1))) ; -; - - - (= - (assignable $Square $Player) - ( (assignable-squares $Player $Squares) (member $Square $Squares))) -; +; Could peval to speed up. + (= (assignable $Square $Player) + (assignable-squares $Player $Squares) + (member $Square $Squares)) ; -; - +; True if at least one of the players is ; -; - - - (= - (still-assigning) - ( (stage assign) (in-hand $Piece $Player))) -; +; still assigning pieces in the initial stage. + (= (still-assigning) + (stage assign) + (in-hand $Piece $Player)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Pseudo-Operators ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ======================================== ; -; - +; ;; Ops during ASSIGN stage: ; -; - +; Assigning pieces at start of game ; -; - +; Game interpreter places initial pieces in the ; -; - +; correct player's hands before this. ; ; - ; -; - +; ASSIGN: Place a piece on an assignable square. ; -; - +; Opponent will start next turn still in assign stage. ; ; - ; -; - +; END_ASSIGN: Nothing to place, so proceed to move stage. ; -; - +; ======================================== - (= - (pseudo-op assign - (assign $Piece $Player $Square) $Player assign $Opponent) - ( (assign $Piece $Player $Square) (transfer-control $Player $Opponent))) -; - - (= - (pseudo-op assign end-assign $Player move $Player) + (= (pseudo-op assign (assign $Piece $Player $Square) $Player assign $Opponent) + (assign $Piece $Player $Square) + (transfer-control $Player $Opponent)) + (= (pseudo-op assign end-assign $Player move $Player) (end-assign)) -; - ; -; - +; ======================================== ; -; - +; Stage init_promote ; -; - +; Op: opponent_promote(Sq,OldPiece,NewPiece) ; -; - +; Stage out: move ; -; - +; When a piece, owned by a player, has finished a move by ; -; - +; moving into that player's promotion region, the player designated in the ; -; - +; piece's definition gets to promote it to some piece matching the defined ; -; - +; description. ; -; - +; ======================================== - (= - (pseudo-op init-promote - (opponent-promote $Sq $OldPiece $NewPiece) $Player move $Player) + (= (pseudo-op init-promote (opponent-promote $Sq $OldPiece $NewPiece) $Player move $Player) (opponent-promote $Sq $OldPiece $NewPiece $Player)) -; - ; -; - +; ;; Ops during MOVE stage: ; -; - +; ======================================== ; -; - +; PLACE Operator ; -; - +; Stage In: Move ; -; - +; Stage Out: Move ; -; - - (= - (pseudo-op move - (place $Piece $Player $Square) $Player move $Opponent) +; ======================================== + (= (pseudo-op move (place $Piece $Player $Square) $Player move $Opponent) (place-op $Piece $Player $Square $Opponent)) -; - ; -; - +; ======================================== ; -; - +; MOVE Operator: ; -; - +; Piece must be moveable. ; -; - +; If must and can capture, then do so. ; -; - +; Otherwise, either capture or move. ; -; - +; Piece will not be placed after this movement, ; -; - +; nor will captured pieces be removed. ; -; - +; However, we will note that this piece has moved, by place_piece_record(Piece,SqT). ; -; - +; Also we will note the capture effects (in capture code). ; -; - +; ======================================== - (= - (pseudo-op move - (move $Piece $Player $SqF $SqT) $Player $Stage $Player) + (= (pseudo-op move (move $Piece $Player $SqF $SqT) $Player $Stage $Player) (global-or-local-move $Piece $Player $SqF $SqT $Stage)) -; - ; -; - +; ======================================== ; -; - +; Operator during the CAPTURE stage: ; ; - ; -; - +; CAPTURE(Effect,Captured_Pieces) ; -; - +; Effect will be either: ; -; - +; a. REMOVE ; -; - +; b. POSSESS(Owner) ; -; - +; Captured will be a list of piece@square pairs. ; ; - ; -; - +; New Stage will be: continue, when piece might try continuing ; -; - +; if it can. ; -; - +; ======================================== - (= - (pseudo-op capture - (capture $Effect $Captured) $Player continue $Player) + (= (pseudo-op capture (capture $Effect $Captured) $Player continue $Player) (capture-op $Effect $Captured $Player)) -; - ; -; - +; ======================================== ; -; - +; Contining or ending CAPTURE EFFECTS: ; -; - +; Ends processing the captured pieces, for both ; -; - +; possess and remove powers. ; ; - ; -; - +; Stages ; -; - +; In: continue ; -; - +; Out: capture/promote ; -; +; ======================================== - - (= - (pseudo-op continue $Move $Player $Stage $Player) + (= (pseudo-op continue $Move $Player $Stage $Player) (try-continue-or-end $Move $Player $Stage)) -; - ; -; - +; ======================================== ; -; - +; PROMOTION ; -; - +; Op: try_promote(Square,OldPiece,NewPiece) ; -; - +; Stages: ; -; - +; In: promote ; -; - +; Out: a. promote_select (If some promoting options), else ; -; - +; b. end_move (i.e. transfer control). ; -; - +; ======================================== ; ; - ; -; - +; When a piece, owned by a player, has moved into that player's ; -; - +; promotion region, the player designated in the piece's definition ; -; - +; gets to promote it to some piece matching the defined description. - (= - (pseudo-op promote - (try-promote $Square $OldPiece $NewPiece) $Player $Stage $Player2) + (= (pseudo-op promote (try-promote $Square $OldPiece $NewPiece) $Player $Stage $Player2) (try-promote $Square $OldPiece $NewPiece $Player $Stage $Player2)) -; - ; -; - +; ======================================== ; -; - +; Stage: promote_select ; -; - +; Op: promote_select(Sq,OldPiece,NewPiece) ; -; - +; This always ends a player's turn. ; -; - +; Stage Out: ; -; - +; If promotion was done by player, opponent's turn starts in MOVE stage. ; -; - +; If promotion to be done by opponent, stage -> init_promote. ; -; - +; ======================================== - (= - (pseudo-op promote-select - (promote-select $Sq $OldPiece $NewPiece) $Player $Stage $Player2) + (= (pseudo-op promote-select (promote-select $Sq $OldPiece $NewPiece) $Player $Stage $Player2) (promote-select $Sq $OldPiece $NewPiece $Player $Stage $Player2)) -; - ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Operator Definitions ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Assigning and placing Pieces ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ASSIGN: Place a piece on an assignable square. ; -; - +; Opponent will start next turn still in assign stage. ; ; - ; -; - +; END_ASSIGN: Nothing to place, so proceed to move stage. ; -; - - - (= - (assign $Piece $Player $Square) - ( (placeable $Piece $Player $Square) - (assignable $Square $Player) - (place-piece-from-hand $Piece $Player $Square))) -; +; Assign + (= (assign $Piece $Player $Square) + (placeable $Piece $Player $Square) + (assignable $Square $Player) + (place-piece-from-hand $Piece $Player $Square)) - (= - (end-assign) + (= (end-assign) (not (in-hand $Piece $Player))) -; - ; -; - +; PLACING: Unlike the assignment stage, ; -; - +; a player can PLACE a piece in his possession ; -; - - - (= - (place-op $Piece $Player $Square $Opponent) - ( (placeable $Piece $Player $Square) - (place-piece-from-hand $Piece $Player $Square) - (transfer-control $Player $Opponent))) -; - +; on any empty square. This ends his move. + (= (place-op $Piece $Player $Square $Opponent) + (placeable $Piece $Player $Square) + (place-piece-from-hand $Piece $Player $Square) + (transfer-control $Player $Opponent)) - (= - (placeable $Piece $Player $Square) - ( (bagof $Piece - (in-hand $Piece $Player) $AllPieces) - (remove-duplicates $AllPieces $Pieces) - (member $Piece $Pieces) - (empty $Square))) -; + (= (placeable $Piece $Player $Square) + (bagof $Piece + (in-hand $Piece $Player) $AllPieces) + (remove-duplicates $AllPieces $Pieces) + (member $Piece $Pieces) + (empty $Square)) +; /* placeable(Piece,Player,Square) :- in_hand(Piece,Player), empty(Square). */ +; ; Computes just once for each TYPE of piece in our hand. ; Doing for each token is redundant as we can only place ; one type. ; ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Moving Pieces ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; MOVE Operator: ; -; - +; Piece must be moveable. ; -; - +; If must and can capture, then do so. ; -; - +; Otherwise, either capture or move. ; -; - +; Piece will not be placed after this movement, ; -; - +; nor will captured pieces be removed. ; -; - +; However, we will note that this piece has moved, by place_piece_record(Piece,SqT). ; -; +; Also we will note the capture effects (in capture code). - - (= - (global-or-local-move $Piece $Player $SqF $SqT $Stage) + (= (global-or-local-move $Piece $Player $SqF $SqT $Stage) (det-if-then-else current-game-must-capture (global-prefer-capture $Piece $Player $SqF $SqT $Stage) (local-move $Piece $Player $SqF $SqT $Stage))) -; - - (= - (global-prefer-capture $Piece $Player $SqF $SqT $Stage) - ( (global-prefer-capture1 $Piece1 $Player $SqF1 $SqT1 $Stage1) - (= $Piece1 $Piece) - (= $SqF1 $SqF) - (= $SqT1 $SqT) - (= $Stage $Stage1))) -; + (= (global-prefer-capture $Piece $Player $SqF $SqT $Stage) + (global-prefer-capture1 $Piece1 $Player $SqF1 $SqT1 $Stage1) + (= $Piece1 $Piece) + (= $SqF1 $SqF) + (= $SqT1 $SqT) + (= $Stage $Stage1)) - - (= - (global-prefer-capture1 $Piece $Player $SqF $SqT $Stage) + (= (global-prefer-capture1 $Piece $Player $SqF $SqT $Stage) (if (, (moveable $Piece $Player $SqF) @@ -1008,42 +676,30 @@ (moveable $Piece $Player $SqF) (moving $Piece $Player $SqF $SqT) (= $Stage promote)))) -; - - (= - (local-move $Piece $Player $SqF $SqT $Stage) - ( (moveable $Piece $Player $SqF) (local-could-move $Piece $Player $SqF $SqT $Stage))) -; - + (= (local-move $Piece $Player $SqF $SqT $Stage) + (moveable $Piece $Player $SqF) + (local-could-move $Piece $Player $SqF $SqT $Stage)) ; -; - +; This can be used to check a piece movement without actually ; -; - +; having that piece on the square to start with ; -; - +; That is: IF SqF is empty, this will tell you which SqT it could ; -; +; legally move to. - - (= - (local-could-move $Piece $Player $SqF $SqT $Stage) + (= (local-could-move $Piece $Player $SqF $SqT $Stage) (det-if-then-else (must-capture $Piece) (local-prefer-capture $Piece $Player $SqF $SqT $Stage) (general-moving $Piece $Player $SqF $SqT $Stage))) -; - - (= - (local-prefer-capture $Piece $Player $SqF $SqT $Stage) + (= (local-prefer-capture $Piece $Player $SqF $SqT $Stage) (if (capturing $Piece $Player $SqF $Sq1) (, @@ -1052,773 +708,523 @@ (, (moving $Piece $Player $SqF $SqT) (= $Stage promote)))) -; - - (= - (general-moving $Piece $Player $SqF $SqT capture) + (= (general-moving $Piece $Player $SqF $SqT capture) (capturing $Piece $Player $SqF $SqT)) -; - - (= - (general-moving $Piece $Player $SqF $SqT promote) + (= (general-moving $Piece $Player $SqF $SqT promote) (moving $Piece $Player $SqF $SqT)) -; - - (= - (must-capture $Piece) - (game--piece-must $Piece)) -; - + (= (must-capture $Piece) + (game--piece-must $Piece)) ; -; - +; REACHES(Piece,Player,SqF,SqT) ; -; - +; True if Player's Piece could reach SqT from SqF, ; -; - +; with the board exactly as it currently is. ; -; +; No side effects. - - (= - (reaches $Piece $Player $SqF $SqT) + (= (reaches $Piece $Player $SqF $SqT) (moves $Piece $Player $SqF $SqT)) -; - - (= - (reaches $Piece $Player $SqF $SqT) + (= (reaches $Piece $Player $SqF $SqT) (captures $Piece $Player $SqF $SqT)) -; - ; -; - +; MOVING ; -; - +; Piece is a piece structure piece(name,player), not just the name. ; -; - +; moveable should already have been checked. ; -; +; Thus By now piece has already been lifted off its start square. - - (= - (moving $Piece $Player $SqF $SqT) - ( (game--piece-has-movement $Piece $Move) - (moving-movement-for-piece $Piece $SqF $SqT $Player $Move $Dir $Hop) - (place-piece-record $Piece $SqT))) -; + (= (moving $Piece $Player $SqF $SqT) + (game--piece-has-movement $Piece $Move) + (moving-movement-for-piece $Piece $SqF $SqT $Player $Move $Dir $Hop) + (place-piece-record $Piece $SqT)) +; ; moveable(Piece,Player,SqF), - - (= - (moves $Piece $Player $SqF $SqT) - ( (game--piece-has-movement $Piece $Move) (moving-movement-for-piece $Piece $SqF $SqT $Player $Move $Dir $Hop))) -; - + (= (moves $Piece $Player $SqF $SqT) + (game--piece-has-movement $Piece $Move) + (moving-movement-for-piece $Piece $SqF $SqT $Player $Move $Dir $Hop)) ; -; - +; If LONGEST and on a planar board, constrained to longest movement. ; -; - +; Otherwise, any movement is ok. ; -; - - - (= - (moving-movement-for-piece $Piece $SqF $SqT $Player $Movement $Dir $Hop) - ( (if - (, - (ride $Movement $Dir $Min $Max $Longest) - (longest $Longest) - (current-board-type planar)) - (longest-moving-ride $SqF $Dir $Min $Max $SqT) - (movement-for-piece $Piece $SqF $SqT $Player $Movement $Dir $Hop)) (valid-movement $SqT))) -; +; Game-implicit + (= (moving-movement-for-piece $Piece $SqF $SqT $Player $Movement $Dir $Hop) + (if + (, + (ride $Movement $Dir $Min $Max $Longest) + (longest $Longest) + (current-board-type planar)) + (longest-moving-ride $SqF $Dir $Min $Max $SqT) + (movement-for-piece $Piece $SqF $SqT $Player $Movement $Dir $Hop)) + (valid-movement $SqT)) ; -; - +; The movement is valid if the final square is empty. - (= - (valid-movement $SqT) + (= (valid-movement $SqT) (empty $SqT)) -; - ; -; - +; Added lift_piece, which means: now we lift the piece up ; -; - +; while considering where to move it. This is nec. for ; -; - +; cylinder boards. ; -; - +; But also dangerous, as makes a change which requires real ; -; - +; backtracking. ; -; - +; Shouldn't be too expensive, as only do 1 time per moving each ; -; - - - (= - (moveable $Piece $Player $SqF) - ( (on $Piece $Player $SqF) (lift-piece $Piece $SqF))) -; +; piece. + (= (moveable $Piece $Player $SqF) + (on $Piece $Player $SqF) + (lift-piece $Piece $SqF)) ; -; - +; ================================================================================ ; -; - +; Piece Movements ; -; - +; ================================================================================ ; -; - +; Leaping move ; -; - - - (= - (movement-for-piece $Piece $SqF $SqT $Player $Movement $Dir Nil) - ( (leap $Movement $Dir) (connected $SqF $SqT $Dir))) -; +; A leap is equivalent to a ride of distance 1 (min=max=1). + (= (movement-for-piece $Piece $SqF $SqT $Player $Movement $Dir Nil) + (leap $Movement $Dir) + (connected $SqF $SqT $Dir)) +; ; already computed syms ; -; - +; The RIDE movement: We traverse 0 or more empties from our current square, ; -; - +; then leap one further to the final square (which need not be empty). ; ; - ; -; - - (= - (movement-for-piece $Piece $SqF $SqT $Player $Movement $Dir Nil) - ( (ride $Movement $Dir $Min $Max $Longest) (open-line $SqF $Dir $Min $Max empty $Squares $SqT))) -; - +; Here we don't check the longest restriction (checked elsewhere already). + (= (movement-for-piece $Piece $SqF $SqT $Player $Movement $Dir Nil) + (ride $Movement $Dir $Min $Max $Longest) + (open-line $SqF $Dir $Min $Max empty $Squares $SqT)) ; -; - +; Hopping move ; ; - ; -; - +; We can traverse B empties, then O occupied, then A empties, ; -; - +; then leap one further to a final square (which need not be empty). ; ; - ; -; - +; leap through B empty squares, BMIN<=B<=BMAX ; -; - +; ending on init + BMAX emptysquares ; -; - +; (thus, init if B=0, else an empty square) ; -; - +; hop over O pieces [OMIN,OMAX] ; -; - +; ending on last OMAXth piece ; -; - +; (thus, init if O=0, else a piece) ; -; - +; leap through A empty squares [AMIN,AMAX] ; -; - +; end on AMAXth empty square ; -; - +; (thus, init if A=0, else an empty square) ; -; - +; final leap to last square ; -; - +; end on last square ; -; - +; (thus, can be empty or not, whatever, ; -; - +; but makes at least 1 total leap). ; ; - ; -; - +; Collects squares with hopped over pieces. ; -; - +; Row hopped over (the O pieces) must be squares such that the piece on them ; -; - - - (= - (movement-for-piece $Piece $SqF $SqT $Player $Movement $Dir $Hopped) - ( (hop $Movement $Dir $Before $Over $After $Description) (hoplines $SqF $SqT $Dir $Before $Over $After $Description $Hopped))) -; +; matches the description for the hopper. + (= (movement-for-piece $Piece $SqF $SqT $Player $Movement $Dir $Hopped) + (hop $Movement $Dir $Before $Over $After $Description) + (hoplines $SqF $SqT $Dir $Before $Over $After $Description $Hopped)) - (= - (hoplines $SqF $SqT $Dir $Before $Over $After $Description $Hopped) + (= (hoplines $SqF $SqT $Dir $Before $Over $After $Description $Hopped) (det-if-then-else (var $SqF) (hoplines-rev $SqF $SqT $Dir $Before $Over $After $Description $Hopped) (hoplines-fwd $SqF $SqT $Dir $Before $Over $After $Description $Hopped))) -; - - - - (= - (hoplines-fwd $SqF $SqT $Dir $Before $Over $After $Description $Hopped) - ( (hopline $SqF $Before $Dir empty $_ $SqB) - (hopline $SqB $Over $Dir $Description $Hopped $SqO) - (hopline $SqO $After $Dir empty $_ $SqL) - (connected $SqL $SqT $Dir))) -; - - (= - (hoplines-rev $SqF $SqT $Dir $Before $Over $After $Description $Hopped) - ( (connected $SqL $SqT $Dir) - (hopline $SqO $After $Dir empty $_ $SqL) - (hopline $SqB $Over $Dir $Description $Hopped $SqO) - (hopline $SqF $Before $Dir empty $_ $SqB))) -; + (= (hoplines-fwd $SqF $SqT $Dir $Before $Over $After $Description $Hopped) + (hopline $SqF $Before $Dir empty $_ $SqB) + (hopline $SqB $Over $Dir $Description $Hopped $SqO) + (hopline $SqO $After $Dir empty $_ $SqL) + (connected $SqL $SqT $Dir)) + (= (hoplines-rev $SqF $SqT $Dir $Before $Over $After $Description $Hopped) + (connected $SqL $SqT $Dir) + (hopline $SqO $After $Dir empty $_ $SqL) + (hopline $SqB $Over $Dir $Description $Hopped $SqO) + (hopline $SqF $Before $Dir empty $_ $SqB)) - (= - (hopline $SqF $Range $Dir $Descr $Squares $SqT) - ( (comparative-interval $Range $Dir $MinB $MaxB) (constrained-line $SqF $Dir $MinB $MaxB $Descr $Squares $SqT))) -; + (= (hopline $SqF $Range $Dir $Descr $Squares $SqT) + (comparative-interval $Range $Dir $MinB $MaxB) + (constrained-line $SqF $Dir $MinB $MaxB $Descr $Squares $SqT)) ; -; - +; comparative_interval(comparison(geq,N),Dir,N,MaxLeaps) :- ; -; - +; valid_max(_,Dir,MaxLeaps). ; -; - +; comparative_interval(comparison(eq,N),_,N,N). ; -; - +; comparative_interval(comparison(leq,N),_,0,N). ; -; - +; Unfolding here to eliminate choicepoints. - (= - (comparative-interval - (comparison $Comp $X) $Dir $N $MaxLeaps) + (= (comparative-interval (comparison $Comp $X) $Dir $N $MaxLeaps) (comparative-interval $Comp $X $Dir $N $MaxLeaps)) -; - - (= - (comparative-interval geq $N $Dir $N $MaxLeaps) + (= (comparative-interval geq $N $Dir $N $MaxLeaps) (valid-max $_ $Dir $MaxLeaps)) -; - - (= - (comparative_interval eq $N $_ $N $N) True) -; - - (= - (comparative_interval leq $N $_ 0 $N) True) -; - + (= (comparative_interval eq $N $_ $N $N) True) + (= (comparative_interval leq $N $_ 0 $N) True) ; -; - +; ================================================================================ ; -; - +; Riding and Hopping LINES ; -; - +; ================================================================================ ; -; - +; OPEN_LINE(SqF,Dir,Min,Max,Cond,Squares,SqT) ; ; - ; -; - +; Traverse between Min-1 and Max-1 leaps along Dir, ; -; - +; starting after SqF, where each such square traversed ; -; - +; satisfies COND (either 'empty' or a piece description). ; -; - +; Then take one more leap, which brings us to (not nec. empty) SqT. ; ; - ; -; - +; Difference betwn open and constrained line (below): open finishes with a ; -; - +; step, so we first decrement the min and max counters, as we know ; -; - +; we will take one leap at the end. - (= - (open-line $SqF $Dir $Min $Max $Cond $Squares $SqT) + (= (open-line $SqF $Dir $Min $Max $Cond $Squares $SqT) (det-if-then-else (var $SqF) (open-line-rev $SqF $Dir $Min $Max $Cond $Squares $SqT) (open-line-fwd $SqF $Dir $Min $Max $Cond $Squares $SqT))) -; - - (= - (open-line-fwd $SqF $Dir $Min $Max $Cond $Squares $SqT) - ( (is $Min1 - (- $Min 1)) - (is $Max1 - (- $Max 1)) - (constrained-line-fwd $SqF $Dir $Min1 $Max1 $Cond $Squares $Sq1) - (connected $Sq1 $SqT $Dir))) -; - + (= (open-line-fwd $SqF $Dir $Min $Max $Cond $Squares $SqT) + (is $Min1 + (- $Min 1)) + (is $Max1 + (- $Max 1)) + (constrained-line-fwd $SqF $Dir $Min1 $Max1 $Cond $Squares $Sq1) + (connected $Sq1 $SqT $Dir)) ; -; - +; CONSTRAINED_LINE_fwd(SqF,Dir,Min,Max,Cond,Squares,SqT) ; -; - +; N Squares, starting with square after SqF, satisfy Cond, ; -; - +; where Min <= N <= Max. ; ; - ; -; - +; If SqF is S_0, and conn(S_i,Dir) = S_i+1, then ; -; - +; true if: S_1, ..., S_i, S_i+1, ..., S_N ; -; - +; all satisfy COND, ; -; - +; where SqT is S_N. ; ; - ; -; - +; Note that for i=0, SqF = SqT. ; ; - - (= - (constrained-line $SqF $Dir $Min $Max $Cond $Squares $SqT) + (= (constrained-line $SqF $Dir $Min $Max $Cond $Squares $SqT) (det-if-then-else (var $SqF) (constrained-line-rev $SqF $Dir $Min $Max $Cond $Squares $SqT) (constrained-line-fwd $SqF $Dir $Min $Max $Cond $Squares $SqT))) -; - - (= - (constrained-line-fwd $SqF $Dir $Min $Max $Cond $Squares $SqT) + (= (constrained-line-fwd $SqF $Dir $Min $Max $Cond $Squares $SqT) (all-sat-fwd $SqF $Dir $Cond 0 $Min $Max $Squares $SqT)) -; - - (= - (all-sat-fwd $SqF $Dir $Cond $Count $Min $Max Nil $SqF) - ( (>= $Count $Min) (=< $Count $Max))) -; - - (= - (all-sat-fwd $SqF $Dir $Cond $Count $Min $Max - (Cons $Sq1 $Squares) $SqT) - ( (< $Count $Max) - (connected $SqF $Sq1 $Dir) - (crossable $Cond $Sq1) - (is $Count1 - (+ $Count 1)) - (all-sat-fwd $Sq1 $Dir $Cond $Count1 $Min $Max $Squares $SqT))) -; - + (= (all-sat-fwd $SqF $Dir $Cond $Count $Min $Max Nil $SqF) + (>= $Count $Min) + (=< $Count $Max)) + (= (all-sat-fwd $SqF $Dir $Cond $Count $Min $Max (Cons $Sq1 $Squares) $SqT) + (< $Count $Max) + (connected $SqF $Sq1 $Dir) + (crossable $Cond $Sq1) + (is $Count1 + (+ $Count 1)) + (all-sat-fwd $Sq1 $Dir $Cond $Count1 $Min $Max $Squares $SqT)) ; -; - +; ================================================================================ ; -; - +; Riding and Hopping LINES : Reverse ; -; - +; ================================================================================ ; -; - +; OPEN_LINE_REV(SqF,Dir,Min,Max,Cond,Squares,SqT) ; ; - ; -; - +; Traverse between Min-1 and Max-1 leaps along Dir, ; -; - +; starting after SqF, where each such square traversed ; -; - +; satisfies COND (either 'empty' or a piece description). ; -; - +; Then take one more leap, which brings us to (not nec. empty) SqT. ; ; - ; -; - +; Difference betwn open and constrained line (below): open finishes with a ; -; - +; step, so we first decrement the min and max counters, as we know ; -; - +; we will take one leap at the end. - (= - (open-line-rev $SqF $Dir $Min $Max $Cond $Squares $SqT) - ( (is $Min1 - (- $Min 1)) - (is $Max1 - (- $Max 1)) - (connected $Sq1 $SqT $Dir) - (constrained-line-rev $SqF $Dir $Min1 $Max1 $Cond $Squares $Sq1))) -; - + (= (open-line-rev $SqF $Dir $Min $Max $Cond $Squares $SqT) + (is $Min1 + (- $Min 1)) + (is $Max1 + (- $Max 1)) + (connected $Sq1 $SqT $Dir) + (constrained-line-rev $SqF $Dir $Min1 $Max1 $Cond $Squares $Sq1)) ; -; - +; CONSTRAINED_LINE_REV(SqF,Dir,Min,Max,Cond,Squares,SqT) ; -; - +; N Squares, starting with square after SqF, satisfy Cond, ; -; - +; where Min <= N <= Max. ; ; - ; -; - +; If SqF is S_0, and conn(S_i,Dir) = S_i+1, then ; -; - +; true if: S_1, ..., S_i, S_i+1, ..., S_N ; -; - +; all satisfy COND, ; -; - +; where SqT is S_N. ; ; - ; -; - +; Note that for i=0, SqF = SqT. ; ; - - (= - (constrained-line-rev $SqF $Dir $Min $Max $Cond $Squares $SqT) + (= (constrained-line-rev $SqF $Dir $Min $Max $Cond $Squares $SqT) (all-sat-rev $SqF $Dir $Cond 0 $Min $Max $Squares $SqT)) -; - - (= - (all-sat-rev $SqF $Dir $Cond $Count $Min $Max Nil $SqF) - ( (>= $Count $Min) (=< $Count $Max))) -; - - (= - (all-sat-rev $SqF $Dir $Cond $Count $Min $Max - (Cons $SqT $Squares) $SqT) - ( (< $Count $Max) - (connected $Sq1 $SqT $Dir) - (crossable $Cond $SqT) - (is $Count1 - (+ $Count 1)) - (all-sat-rev $SqF $Dir $Cond $Count1 $Min $Max $Squares $Sq1))) -; - + (= (all-sat-rev $SqF $Dir $Cond $Count $Min $Max Nil $SqF) + (>= $Count $Min) + (=< $Count $Max)) + (= (all-sat-rev $SqF $Dir $Cond $Count $Min $Max (Cons $SqT $Squares) $SqT) + (< $Count $Max) + (connected $Sq1 $SqT $Dir) + (crossable $Cond $SqT) + (is $Count1 + (+ $Count 1)) + (all-sat-rev $SqF $Dir $Cond $Count1 $Min $Max $Squares $Sq1)) ; -; - +; crossable(+Descr,?Sq) ; -; - +; If Descr is Empty, then true if square is empty. ; -; - +; Or a piece description, then true if piece on square matches. ; ; - ; -; - +; crossable(empty,Sq) :- empty(Sq), !. ; -; - +; crossable(Descr,Sq) :- on(P,Sq), matches(Descr,P). - (= - (crossable $Descr $Sq) + (= (crossable $Descr $Sq) (det-if-then-else (= $Descr empty) (empty $Sq) (, (on $P $Sq) (matches $Descr $P)))) -; - ; -; - +; ====================================================================== ; -; - +; CAPTURING ; -; - +; Now collects hopped squares. ; -; - +; Only legal if something is captured. ; -; - +; Capturing using a particular capture power, and a particular movement within this power. ; -; - +; Records the capture effect corresponding to this use of power, so we'll know what to change later. ; -; - +; Don't need to track captures list anymore, as effects taken care of. ; -; - +; Finds way for Player to use Piece to capture, from SqF, to SqT. ; -; - +; Move set_effect below captures. Else, when succ. 2 ways, if clear ; -; - +; between don't get this effect. ; -; - +; By now piece has been lifted (when checked moveable), so now just note that ; -; - +; it should be on a new square at end, don't actually place it. ; -; - +; Sets the capture effect information, saying which pieces were captured and what ; -; +; the effect will be. - - (= - (capturing $Piece $Player $SqF $SqT) - ( (captures $Piece $Player $SqF $SqT $Effect $Captured) - (place-piece-record $Piece $SqT) - (set-effect $Effect $Captured))) -; - + (= (capturing $Piece $Player $SqF $SqT) + (captures $Piece $Player $SqF $SqT $Effect $Captured) + (place-piece-record $Piece $SqT) + (set-effect $Effect $Captured)) ; -; - +; CAPTURES(Piece,Player,SqF,SqT) ; -; - +; Like capturing, but determines if the piece could move ; -; - +; without actually changing state. - (= - (captures $Piece $Player $SqF $SqT) + (= (captures $Piece $Player $SqF $SqT) (captures $Piece $Player $SqF $SqT $Effect $Captured)) -; - ; -; - +; CAPTURES(Piece,Player,SqF,SqT,Effect,Captured) ; -; - +; True when Piece, from SqF, could use a capture power to ; -; - +; move to SqT, making the set of captures in Captured, ; -; - +; with capture effect Effect. ; -; - - (= - (captures $Piece $Player $SqF $SqT $Effect $Captured) - ( (game--piece-has-capture $Piece $Capture) - (capture-has-movement $Capture $Movement) - (capture-effect $Capture $Effect) - (capturing-movement-for-piece $Piece $SqF $SqT $Player $Movement $Capture $Captured))) -; - +; This is non-side-effecting. + (= (captures $Piece $Player $SqF $SqT $Effect $Captured) + (game--piece-has-capture $Piece $Capture) + (capture-has-movement $Capture $Movement) + (capture-effect $Capture $Effect) + (capturing-movement-for-piece $Piece $SqF $SqT $Player $Movement $Capture $Captured)) ; -; - +; CAPTURING_MOVEMENT_FOR_PIECE(+Piece,+SqF,SqT,+Player,?Movement,+Capture,-Captured) ; -; - +; Longest riders must make the longest capturing ride. ; -; - +; Otherwise, makes a movement (same way as normal move), ; -; - +; but then exercises the capture effects, then legal if something got ; -; - +; captured and the final square is empty. ; ; - ; -; - +; One way to think of the rel. between normal movements and captures: ; -; - +; A moving_movement: ; -; - +; finds a SqT s.t. the path is appropriate for the movement def ; -; - +; this is legal if SqT is empty. ; -; - +; A capturing_movement: ; -; - +; finds a SqT s.t. the path is appropriate for the capturing_movement def. ; -; - +; executes the capture effects, based on this path. ; -; - +; this is legal if something was captured, and after this SqT is empty. ; ; - - (= - (capturing-movement-for-piece $Piece $SqF $SqT $Player $Movement $Capture $Captured) + (= (capturing-movement-for-piece $Piece $SqF $SqT $Player $Movement $Capture $Captured) (capturing-movement-for-piece $Piece $SqF $SqT $Player $Dir $Movement $Capture $Captured)) -; - ; -; - - (= - (capturing-movement-for-piece $Piece $SqF $SqT $Player $Dir $Movement $Capture $Captured) +; Like above, but has direction of capture as explicit argument. + (= (capturing-movement-for-piece $Piece $SqF $SqT $Player $Dir $Movement $Capture $Captured) (if (, (ride $Movement $Dir $Min $Max $Longest) @@ -1828,325 +1234,223 @@ (, (movement-for-piece $Piece $SqF $SqT $Player $Movement $Dir $Hopped) (captured-pieces $SqF $SqT $Capture $Dir $Hopped $Captured)))) -; - ; -; - +; ======================================== ; -; - +; Longest rides ; -; - +; ======================================== ; -; - +; Try riding the max distance. ; -; - +; If can't, 1 ride less, and so on. ; -; - +; If already failed at the minimum, give up. ; ; - ; -; +; LONGEST MOVING - - (= - (longest-moving-ride $SqF $Dir $Min $Max $SqT) - ( (> $Min $Max) - (set-det) - (fail))) -; - - (= - (longest-moving-ride $SqF $Dir $Min $Max $SqT) - ( (open-line $SqF $Dir $Max $Max empty $Squares $SqT) - (empty $SqT) - (set-det))) -; - - (= - (longest-moving-ride $SqF $Dir $Min $Max $SqT) - ( (is $Max1 - (- $Max 1)) (longest-moving-ride $SqF $Dir $Min $Max1 $SqT))) -; - + (= (longest-moving-ride $SqF $Dir $Min $Max $SqT) + (> $Min $Max) + (set-det) + (fail)) + (= (longest-moving-ride $SqF $Dir $Min $Max $SqT) + (open-line $SqF $Dir $Max $Max empty $Squares $SqT) + (empty $SqT) + (set-det)) + (= (longest-moving-ride $SqF $Dir $Min $Max $SqT) + (is $Max1 + (- $Max 1)) + (longest-moving-ride $SqF $Dir $Min $Max1 $SqT)) ; -; - - - - (= - (longest-capturing-ride $SqF $Dir $Min $Max $SqT $Capture $_) - ( (> $Min $Max) - (set-det) - (fail))) -; - - (= - (longest-capturing-ride $SqF $Dir $Min $Max $SqT $Capture $Captured) - ( (open-line $SqF $Dir $Max $Max empty $Squares $SqT) - (captured-pieces $SqF $SqT $Capture $Dir Nil $Captured) - (set-det))) -; +; LONGEST CAPTURING - (= - (longest-capturing-ride $SqF $Dir $Min $Max $SqT $Capture $Captured) - ( (is $Max1 - (- $Max 1)) (longest-capturing-ride $SqF $Dir $Min $Max1 $SqT $Capture $Captured))) -; + (= (longest-capturing-ride $SqF $Dir $Min $Max $SqT $Capture $_) + (> $Min $Max) + (set-det) + (fail)) + (= (longest-capturing-ride $SqF $Dir $Min $Max $SqT $Capture $Captured) + (open-line $SqF $Dir $Max $Max empty $Squares $SqT) + (captured-pieces $SqF $SqT $Capture $Dir Nil $Captured) + (set-det)) + (= (longest-capturing-ride $SqF $Dir $Min $Max $SqT $Capture $Captured) + (is $Max1 + (- $Max 1)) + (longest-capturing-ride $SqF $Dir $Min $Max1 $SqT $Capture $Captured)) ; -; - - - - (= - (captured-pieces $SqF $SqT $Capturing $Dir $Hopped $Captures) - ( (capture-type $Capturing $Type) - (if - (clobbers $SqT $Capturing $Type $Clobs) True - (= $Clobs Nil)) - (if - (retrieves $SqF $Dir $Capturing $Type $Retrs) True - (= $Retrs Nil)) - (det-if-then-else - (hops $Hopped $Capturing $Type $Hops) True - (= $Hops Nil)) - (append $Retrs $Clobs $L1) - (append $Hops $L1 $Captures) - (valid-capture $SqT $Captures))) -; +; ---------------------------------------- -; -; - -; -; + (= (captured-pieces $SqF $SqT $Capturing $Dir $Hopped $Captures) + (capture-type $Capturing $Type) + (if + (clobbers $SqT $Capturing $Type $Clobs) True + (= $Clobs Nil)) + (if + (retrieves $SqF $Dir $Capturing $Type $Retrs) True + (= $Retrs Nil)) + (det-if-then-else + (hops $Hopped $Capturing $Type $Hops) True + (= $Hops Nil)) + (append $Retrs $Clobs $L1) + (append $Hops $L1 $Captures) + (valid-capture $SqT $Captures)) +; /* CAPTURING --------- o consider a capture definition, and a movement within this. o compute a path given this movement, saving significant squares. o for the given capture methods and types, see which significant squares should be captured. o ensure that something would get captured. o ensure that the final square would be empty - empty already, or one of the list to be captured o execute effects: remove pieces which should be captured (after remove-dups). */ +; ; Deletes effect, as this is the last place we need it. ; +; ; CAPTURED PIECES ; Captures will be the set of Piece@Square which will be captured, ; given the effects of this capturing power, and the descriptions ; of pieces which it can capture. ; Could simplify by getting method and type first, call method routine ; like clobbers to check if matches, then capture piece if nec. ; ; Made if's instead of local cuts for bidirectionality. ; Don't need one for hoppers, since this already done in hopper code. ; -; - - - (= - (valid-capture $Final $Captured) - ( (something-captured $Captured) (will-be-empty $Final $Captured))) -; - - +; VALID_CAPTURE(+FinalSquare,+CapturedList) ; -; +; In order to be a valid capture, something must actually get captured, +; +; and the final square must become empty. + (= (valid-capture $Final $Captured) + (something-captured $Captured) + (will-be-empty $Final $Captured)) - (= - (something_captured - (Cons $_ $_)) True) -; +; +; Something will be captured if the capture list is not empty. + (= (something_captured (Cons $_ $_)) True) ; -; - +; A square will be empty if it is already empty, or if it will be captured. - (= - (will-be-empty $Sq $Captured) + (= (will-be-empty $Sq $Captured) (det-if-then-else (captured-piece $Piece $Sq $Captured) True (empty $Sq))) -; - - - - (= - (captured-piece $Victim $SqV $Captured) - ( (captured $Cap $Victim $SqV) (member $Cap $Captured))) -; - - - (= - (clobbers $Sq $Capturing $Type - (:: (@ $Piece $Sq))) - ( (capture-has-method $Capturing clobber) - (on $Piece $Sq) - (matches $Type $Piece))) -; + (= (captured-piece $Victim $SqV $Captured) + (captured $Cap $Victim $SqV) + (member $Cap $Captured)) - (= - (retrieves $SqF $Dir $Capturing $Type - (:: (@ $Piece $Sq1))) - ( (capture-has-method $Capturing retrieve) - (connected $Sq1 $SqF $Dir) - (on $Piece $Sq1) - (matches $Type $Piece))) -; + (= (clobbers $Sq $Capturing $Type (:: (@ $Piece $Sq))) + (capture-has-method $Capturing clobber) + (on $Piece $Sq) + (matches $Type $Piece)) + (= (retrieves $SqF $Dir $Capturing $Type (:: (@ $Piece $Sq1))) + (capture-has-method $Capturing retrieve) + (connected $Sq1 $SqF $Dir) + (on $Piece $Sq1) + (matches $Type $Piece)) - (= - (hops $Hopped $Capturing $Type $Hops) - ( (capture-has-method $Capturing hop) (matchers-on-squares $Hopped $Type $Hops))) -; + (= (hops $Hopped $Capturing $Type $Hops) + (capture-has-method $Capturing hop) + (matchers-on-squares $Hopped $Type $Hops)) ; -; - +; MATCHERS_ON_SQUARES(+Hopped,+Type,-Matchers). ; -; - +; Matchers contains those Hopped-over pieces which match Type, ; -; - +; and should thus be captured. ; -; - - - (= - (matchers_on_squares () $_ ()) True) -; - - (= - (matchers-on-squares - (Cons $H $Hs) $Type $Caps) - ( (on $P $H) - (det-if-then-else - (matches $Type $P) - (= $Caps - (Cons - (@ $P $H) $Rest)) - (= $Caps $Rest)) - (matchers-on-squares $Hs $Type $Rest))) -; +; Each elt of matchers is of the form: Piece@Square. + (= (matchers_on_squares () $_ ()) True) + (= (matchers-on-squares (Cons $H $Hs) $Type $Caps) + (on $P $H) + (det-if-then-else + (matches $Type $P) + (= $Caps + (Cons + (@ $P $H) $Rest)) + (= $Caps $Rest)) + (matchers-on-squares $Hs $Type $Rest)) ; -; - +; Operator during the CAPTURE stage: ; ; - ; -; - +; CAPTURE(Effect,Captured_Pieces) ; -; - +; Effect will be either: ; -; - +; a. REMOVE ; -; - +; b. POSSESS(Owner) ; -; - +; Captured will be a list of piece@square pairs. ; ; - ; ; - ; -; - - - - (= - (capture-op $Effect $Captured $Player) - ( (del-effect $Effect $Captured) (effect-captures $Captured $Effect))) -; - - - +; New Stage will be either: continue (if more captures), or promote. - (= - (effect_captures () $_) True) -; - (= - (effect-captures - (Cons $Cap $Caps) $Effect) - ( (effect-capture $Effect $Cap) (effect-captures $Caps $Effect))) -; + (= (capture-op $Effect $Captured $Player) + (del-effect $Effect $Captured) + (effect-captures $Captured $Effect)) +; ; effect(Effect,Captured), + (= (effect_captures () $_) True) + (= (effect-captures (Cons $Cap $Caps) $Effect) + (effect-capture $Effect $Cap) + (effect-captures $Caps $Effect)) - (= - (effect-capture remove $Cap) - ( (captured $Cap $Piece $Sq) (lift-piece $Piece $Sq))) -; - - (= - (effect-capture - (possess $Owner) $Cap) - ( (captured $Cap $Piece $Sq) - (lift-piece $Piece $Sq) - (piece-struct $Piece $Type $Player) - (piece-struct $NewPiece $Type $Owner) - (put-in-hand $NewPiece $Owner))) -; + (= (effect-capture remove $Cap) + (captured $Cap $Piece $Sq) + (lift-piece $Piece $Sq)) + (= (effect-capture (possess $Owner) $Cap) + (captured $Cap $Piece $Sq) + (lift-piece $Piece $Sq) + (piece-struct $Piece $Type $Player) + (piece-struct $NewPiece $Type $Owner) + (put-in-hand $NewPiece $Owner)) - (= - (captured - (@ $Piece $Sq) $Piece $Sq) True) -; + (= (captured (@ $Piece $Sq) $Piece $Sq) True) ; -; - +; ========================================= ; -; - +; Continuing captures ; -; - +; ========================================= ; -; - +; After processed capture effects, may continue capturing in some cases. ; -; - +; If so, then those which must continue must do so (**), ; -; - +; and the rest decide whether to try continuing or to end. ; -; - +; If continuing not an option, just end the move right away. ; ; - ; -; - +; Keep on continuing, until done, then goto PROMOTE stage. - (= - (try-continue-or-end $Move $Player $Stage) + (= (try-continue-or-end $Move $Player $Stage) (if (may-continue $Piece $Sq) (if @@ -2154,67 +1458,45 @@ (continue-captures $Piece $Player $Sq $SqT $Move $Stage) (continue-or-end $Piece $Player $Sq $SqT $Move $Stage)) (discontinue $Move $Stage))) -; - - (= - (must-continue $Piece) + (= (must-continue $Piece) (game--piece-must $Piece)) -; - - - - (= - (may-continue $Piece $Sq) - ( (moved-onto $Piece $Sq) (game--piece-continues $Piece))) -; + (= (may-continue $Piece $Sq) + (moved-onto $Piece $Sq) + (game--piece-continues $Piece)) - (= - (continue-or-end $Piece $Player $Sq $SqT - (move $Piece $Player $Sq $SqT) capture) - ( (del (moved-onto $Piece $Sq)) (capturing $Piece $Player $Sq $SqT))) -; - (= - (continue-or-end $_ $_ $_ $_ $Move $Stage) + (= (continue-or-end $Piece $Player $Sq $SqT (move $Piece $Player $Sq $SqT) capture) + (del (moved-onto $Piece $Sq)) + (capturing $Piece $Player $Sq $SqT)) +; ; lift_piece(Piece,Sq), + (= (continue-or-end $_ $_ $_ $_ $Move $Stage) (discontinue $Move $Stage)) -; - ; -; - +; Here we're committed to capturing if we can. ; -; - +; Otherwise we end movements here. ; -; - +; Since not checking moveable here, must lift the piece up ; -; - +; again, otherwise it will still be there when capturing is ; -; - +; checked. ; ; - ; -; - +; Not any more, now not placing the piece down officially ; -; - +; until the very end of the move (promotion stage). ; -; +; But must delete moved_onto. - - (= - (continue-captures $Piece $Player $Sq $SqT $Move $Stage) + (= (continue-captures $Piece $Player $Sq $SqT $Move $Stage) (if (, (= $Move @@ -2223,304 +1505,220 @@ (capturing $Piece $Player $Sq $SqT)) (= $Stage capture) (discontinue $Move $Stage))) -; - - +; ; lift_piece(Piece,Sq), - (= - (discontinue end_continues promote) True) -; + (= (discontinue end_continues promote) True) ; -; - +; ================================================================================ ; -; - +; Promoting ; -; - +; ================================================================================ ; -; - +; ======================================== ; -; - +; Stages: ; -; - +; In: promote ; -; - +; Out: promote_select (If some promoting options) ; -; - +; Else end_move (i.e. transfer control). ; -; - +; ======================================== ; ; - ; -; - +; When a piece, owned by a player, has moved into that player's ; -; - +; promotion region, the player designated in the piece's definition ; -; - - - +; gets to promote it to some piece matching the defined description. - (= - (try-promote $Sq $OldPiece $NewPiece $Player $Stage $Player2) - ( (moved-onto $OldPiece $Sq) - (verbosely (format "Checking for promotion~n" Nil)) - (promote-if $OldPiece $Player $Sq $NewPiece $Stage $Player2))) -; + (= (try-promote $Sq $OldPiece $NewPiece $Player $Stage $Player2) + (moved-onto $OldPiece $Sq) + (verbosely (format "Checking for promotion~n" Nil)) + (promote-if $OldPiece $Player $Sq $NewPiece $Stage $Player2)) +; ; dynamic pred - (= - (promote-if $OldPiece $Player1 $Sq $NewPiece $Stage $Player2) - ( (in-promote-region $Sq $Player1) - (set-det) - (game--piece-promoting $OldPiece $Promoting) - (promote-if1 $OldPiece $Promoting $Player1 $Sq $NewPiece $Stage $Player2))) -; + (= (promote-if $OldPiece $Player1 $Sq $NewPiece $Stage $Player2) + (in-promote-region $Sq $Player1) + (set-det) + (game--piece-promoting $OldPiece $Promoting) + (promote-if1 $OldPiece $Promoting $Player1 $Sq $NewPiece $Stage $Player2)) ; -; - +; If we don't promote the piece, then we have to put the old piece ; -; - +; down on the final square (before we had just noted that it should have ; -; - - (= - (promote-if $OldPiece $Player1 $Sq Nil $Stage $Player2) - ( (del (moved-onto $OldPiece $Sq)) - (verbosely (format "~n~p is not in promotion territory for ~p~n" (:: $OldPiece $Player1))) - (place-piece $OldPiece $Sq) - (end-promote $Player1 $Stage $Player2))) -; - +; moved_onto to that square, but didn't really place it. + (= (promote-if $OldPiece $Player1 $Sq Nil $Stage $Player2) + (del (moved-onto $OldPiece $Sq)) + (verbosely (format "~n~p is not in promotion territory for ~p~n" (:: $OldPiece $Player1))) + (place-piece $OldPiece $Sq) + (end-promote $Player1 $Stage $Player2)) +; ; \+ in_promote_region(Sq,Player1) - (= - (promote-if1 $OldPiece $Promoting $Player1 $Sq $NewPiece $Stage $Player2) - ( (simple-promote $Promoting $Player1 $NewPiece) - (verbosely (format "Promoting: ~p on ~p --> ~p~n" (:: $OldPiece $Sq $NewPiece))) - (replace-piece-record $OldPiece $NewPiece $Sq) - (del (moved-onto $OldPiece $Sq)) - (end-promote $Player1 $Stage $Player2))) -; - + (= (promote-if1 $OldPiece $Promoting $Player1 $Sq $NewPiece $Stage $Player2) + (simple-promote $Promoting $Player1 $NewPiece) + (verbosely (format "Promoting: ~p on ~p --> ~p~n" (:: $OldPiece $Sq $NewPiece))) + (replace-piece-record $OldPiece $NewPiece $Sq) + (del (moved-onto $OldPiece $Sq)) + (end-promote $Player1 $Stage $Player2)) +; ; replace_piece(OldPiece,NewPiece,Sq), - (= - (promote-if1 $OldPiece $Promoting $Player1 $Sq $NewPiece $Stage $Player2) - ( (promoter $Promoting $Player1 $Promoter) (promote-role $Promoter $Player1 $OldPiece $Sq $Stage $Player2))) -; - + (= (promote-if1 $OldPiece $Promoting $Player1 $Sq $NewPiece $Stage $Player2) + (promoter $Promoting $Player1 $Promoter) + (promote-role $Promoter $Player1 $OldPiece $Sq $Stage $Player2)) ; -; - +; If player promotes, transfer to promote_select stage. ; -; - - - (= - (promote_role $Player $Player $_ $_ promote_select $Player) True) -; +; If opponent does, then add this fact, and end the move. - (= - (promote-role $Opponent $Player $OldPiece $Sq $Stage $Player2) - ( (opposite-role $Player $Opponent) - (add (opponent-promotes $OldPiece $Sq)) - (del (moved-onto $OldPiece $Sq)) - (end-promote $Player $Stage $Player2))) -; - + (= (promote_role $Player $Player $_ $_ promote_select $Player) True) + (= (promote-role $Opponent $Player $OldPiece $Sq $Stage $Player2) + (opposite-role $Player $Opponent) + (add (opponent-promotes $OldPiece $Sq)) + (del (moved-onto $OldPiece $Sq)) + (end-promote $Player $Stage $Player2)) - (= - (simple-promote $Promoting $Player $NewPiece) - ( (promoting-info $Promoting - (promote $Type)) (piece-struct $NewPiece $Type $Player))) -; - + (= (simple-promote $Promoting $Player $NewPiece) + (promoting-info $Promoting + (promote $Type)) + (piece-struct $NewPiece $Type $Player)) - (= - (promoter $Promoting $Player $Promoter) + (= (promoter $Promoting $Player $Promoter) (= $Promoting (promote $Promoter $Descr))) -; - ; -; - +; IN_PROMOTE_REGION(Sq,Player) ; -; - +; Square is in the promotion region for Player, according to the ; -; - +; rules of Game. ; ; - ; -; - +; Careful, this assumes that the promote rank is not ; -; - +; already inverted. As invert only inverts squares, ; -; - +; not numbers, we are ok. ; -; - +; If it did invert promote rank, then don't invert square here (*) ; -; - +; *** Could clean up by invert promote ranks automatically. ; -; - - - (= - (in-promote-region $Sq $Player) - ( (game--promote-rank $Rank) - (invert $Sq $Player $Sq1) - (square $Sq1 $X $Y) - (>= $Y $Rank))) -; +; !! Took out game argument. + (= (in-promote-region $Sq $Player) + (game--promote-rank $Rank) + (invert $Sq $Player $Sq1) + (square $Sq1 $X $Y) + (>= $Y $Rank)) ; -; - +; ======================================== ; -; - +; Stage: promote_select ; -; +; ======================================== - - (= - (promote-select $Sq $OldPiece $NewPiece $Player $Stage $Player2) - ( (moved-onto $OldPiece $Sq) - (verbosely-format "~p decides on promotion for ~p on ~p~n" - (:: $Player $OldPiece $Sq)) - (game--piece-promoting $OldPiece $Promoting) - (promoting-options $Promoting $Player $Descr) - (matches $Descr $NewPiece) - (replace-piece-record $OldPiece $NewPiece $Sq) - (del (moved-onto $OldPiece $Sq)) - (end-promote $Player $Stage $Player2))) -; - + (= (promote-select $Sq $OldPiece $NewPiece $Player $Stage $Player2) + (moved-onto $OldPiece $Sq) + (verbosely-format "~p decides on promotion for ~p on ~p~n" + (:: $Player $OldPiece $Sq)) + (game--piece-promoting $OldPiece $Promoting) + (promoting-options $Promoting $Player $Descr) + (matches $Descr $NewPiece) + (replace-piece-record $OldPiece $NewPiece $Sq) + (del (moved-onto $OldPiece $Sq)) + (end-promote $Player $Stage $Player2)) +; ; dynamic pred +; ; Careful here: Must not invert perspective twice (*) +; ; replace_piece(OldPiece,NewPiece,Sq), ; -; - +; ======================================== ; -; - +; END_PROMOTE ; -; - +; After player promotes, end_move. ; -; +; ======================================== - - (= - (end-promote $Player $Stage $Player2) + (= (end-promote $Player $Stage $Player2) (end-move $Player $Stage $Player2)) -; - ; -; - +; Since opponent_promotes option puts opponent in contol, ; -; - +; he will have inverted the promoting definition. So, check for this ; -; - +; case (when actor has opposite role of player), then ; -; - +; invert description back again if so. ; ; - ; -; - - - (= - (promoting-options $Promoting $Player $Descr) - ( (= $Promoting - (promote $Actor $Descr1)) (det-if-then-else (opposite-role $Player $Actor) (invert $Descr1 opponent $Descr) (= $Descr $Descr1)))) -; +; Cleaner clause here (like invert to perspective?). + (= (promoting-options $Promoting $Player $Descr) + (= $Promoting + (promote $Actor $Descr1)) + (det-if-then-else + (opposite-role $Player $Actor) + (invert $Descr1 opponent $Descr) + (= $Descr $Descr1))) ; -; - +; ================================================================================ ; -; - +; Opponent_Promoting ; -; - +; ================================================================================ ; -; - +; ======================================== ; -; - +; Stages ; -; - +; In: init_promote ; -; - +; Out: move ; -; - +; ======================================== ; -; - +; When a piece, owned by a player, has finished a move by moving into that player's ; -; - +; promotion region, the player designated in the piece's definition ; -; - +; gets to promote it to some piece matching the defined description. - (= - (opponent-promote $Sq $OldPiece $NewPiece $Player) + (= (opponent-promote $Sq $OldPiece $NewPiece $Player) (det-if-then-else (opponent-promotes $OldPiece $Sq) (, @@ -2533,53 +1731,38 @@ (= $Sq Nil) (= $OldPiece Nil) (= $NewPiece Nil)))) -; - +; ; replace_piece(OldPiece,NewPiece,Sq) ; -; - +; Careful here: Don't want to invert perspective again (*). - (= - (init-promote-option $OldPiece $Player $NewPiece) - ( (game--piece-promoting $OldPiece $Promoting) - (promoting-options $Promoting $Player $Descr) - (matches $Descr $NewPiece))) -; - + (= (init-promote-option $OldPiece $Player $NewPiece) + (game--piece-promoting $OldPiece $Promoting) + (promoting-options $Promoting $Player $Descr) + (matches $Descr $NewPiece)) ; -; - +; ======================================== ; -; - +; END_MOVE ; -; - +; ======================================== ; -; - +; After possibly promoting a piece, the move ; -; - +; ends here, and control is transferred to the ; -; - +; other player. ; -; - +; The next stage will be INIT_PROMOTE for opponent. ; ; - - (= - (end-move $Player init-promote $Opponent) - ( (verbosely-format "~p finished moving~n" - (:: $Player)) (transfer-control $Player $Opponent))) -; - + (= (end-move $Player init-promote $Opponent) + (verbosely-format "~p finished moving~n" + (:: $Player)) + (transfer-control $Player $Opponent)) diff --git a/metagame/theory/matches.metta b/metagame/theory/matches.metta index 79a92bb..a136756 100644 --- a/metagame/theory/matches.metta +++ b/metagame/theory/matches.metta @@ -1,94 +1,59 @@ +; (convert_to_metta_file matches $_432756 metagame/theory/matches.pl metagame/theory/matches.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; matches.pl ; -; - +; MATCHES(?Descr,?Piece) ; -; - +; A Piece matches a Descr if both the player and type in ; -; - +; the description are at least as general as those of the ; -; - +; piece. ; ; - ; -; - +; piece_struct(P,guppy,player),piece_description(T,any_player,[guppy,frog]), ; -; - - - (= - (matches $Descr $Piece) - ( (piece-description $Descr $Player_Gen $Piece_Gen) - (piece-struct $Piece $Name $Player) - (matches-player $Player_Gen $Player) - (matches-name $Piece_Gen $Name))) -; +; matches(T,P). + (= (matches $Descr $Piece) + (piece-description $Descr $Player_Gen $Piece_Gen) + (piece-struct $Piece $Name $Player) + (matches-player $Player_Gen $Player) + (matches-name $Piece_Gen $Name)) - (= - (matches-player any-player $Player) + (= (matches-player any-player $Player) (player-role $Player)) -; - - (= - (matches_player player player) True) -; - - (= - (matches_player opponent opponent) True) -; - + (= (matches_player player player) True) + (= (matches_player opponent opponent) True) ; -; - +; Note a type must be either any_piece or a LIST, not singletons. ; -; - +; Really should peval to get all piece names, instead of ref. back ; -; - +; to game each time. ; -; - +; Note also second clause should really check piece is a current ; -; - +; game piece (peval also won't work without this!). - (= - (matches-name any-piece $Name) + (= (matches-name any-piece $Name) (current-game-piece-name $Name)) -; - - (= - (matches-name - (Cons $H $T) $Name) + (= (matches-name (Cons $H $T) $Name) (member $Name - (Cons $H $T))) -; - + (Cons $H $T))) diff --git a/metagame/theory/parse.metta b/metagame/theory/parse.metta index b2d470a..ec77e86 100644 --- a/metagame/theory/parse.metta +++ b/metagame/theory/parse.metta @@ -1,389 +1,273 @@ +; (convert_to_metta_file parse $_504968 metagame/theory/parse.pl metagame/theory/parse.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; parse.pl ; -; - +; For now, avoid explicit inversion in the legal rules by producing an ; -; - +; entire inverted game from each player's perspective, used when ; -; - +; they are in control. ; -; - +; Then interpreter can always assume PLAYER is to move! ; ; - ; -; - +; Changed to eliminate choice points. ; -; - +; current_game(Game) :- ; -; - +; control(opponent), !, ; -; - +; opponent_current_game(Game). ; -; - +; current_game(Game) :- ; -; +; player_current_game(Game). - - (= - (current-game $Game) + (= (current-game $Game) (det-if-then-else (control $Player) (current-game-for-player $Player $Game) (player-current-game $Game))) -; - ; -; - +; ; Goals ; -; - +; GAME_PLAYER_HAS_GOAL(?Game,+Player,-Goal) :- ; -; - +; If Player is in control, then already using a properly inverted game ; -; - +; so don't need to invert it to check his goals. ; -; +; Otherwise, we're not using it from his perspective, so invert it. - - (= - (game-player-has-goal $Game $Player $Goal) - ( (current-game-for-player $Player $Game) (game-has-goal $Game $Goal))) -; - + (= (game-player-has-goal $Game $Player $Goal) + (current-game-for-player $Player $Game) + (game-has-goal $Game $Goal)) ; -; +; ; Initial Setup + (= (current-board $B) + (current-game $G) + (game-board $G $B)) - (= - (current-board $B) - ( (current-game $G) (game-board $G $B))) -; + (= (current-board-size $X $Y) + (player-current-game $G) + (game-board $G $B) + (board-size $B $X $Y)) - (= - (current-board-size $X $Y) - ( (player-current-game $G) - (game-board $G $B) - (board-size $B $X $Y))) -; + (= (current-board-type $Type) + (player-current-game $G) + (game-board $G $B) + (board-type $B $Type)) - - (= - (current-board-type $Type) - ( (player-current-game $G) - (game-board $G $B) - (board-type $B $Type))) -; - - - - (= - (current-board-inversion $Type) - ( (player-current-game $G) - (game-board $G $B) - (board-inversion $B $Type))) -; - + (= (current-board-inversion $Type) + (player-current-game $G) + (game-board $G $B) + (board-inversion $B $Type)) ; -; - +; GAME_ASSIGNMENTS(+Game,-Assign) ; -; - - - (= - (game-assignments $Game $Assign) - ( (player-current-game $Game) - (game-board $Game $Board) - (board-assignments $Board $Assign))) -; +; The game has the initial piece assignments. + (= (game-assignments $Game $Assign) + (player-current-game $Game) + (game-board $Game $Board) + (board-assignments $Board $Assign)) ; -; - +; GAME_HAS_ASSIGNMENTS(+Game,-Assign) ; -; - +; The game has the initial piece assignments. ; -; - +; If the game is defined to have a random setup, ; -; - +; the setup used for this contest must already have been determined, ; -; - +; and stored as: ; -; - +; current_random_assignments(Assignments). ; ; - ; -; - - - - (= - (game-has-assignments $Game $Assign) - ( (game-assignments $Game $Assign1) (full-assignment-if-random $Assign1 $Assign))) -; +; Otherwise, just use the fully-specified assignments as generated. + (= (game-has-assignments $Game $Assign) + (game-assignments $Game $Assign1) + (full-assignment-if-random $Assign1 $Assign)) - (= - (full-assignment-if-random $As $Assignments) - ( (random-assignment-decision $As) - (set-det) - (random-assignment $Assignments))) -; - - (= - (full_assignment_if_random $As $As) True) -; + (= (full-assignment-if-random $As $Assignments) + (random-assignment-decision $As) + (set-det) + (random-assignment $Assignments)) + (= (full_assignment_if_random $As $As) True) ; -; - +; CURRENT_RANDOM_SETUP_GAME(+Game) ; -; - - - (= - (current-random-setup-game) - ( (player-current-game $Game) (random-setup-game $Game))) -; +; True if current game starts with a random setup. + (= (current-random-setup-game) + (player-current-game $Game) + (random-setup-game $Game)) ; -; - +; RANDOM_SETUP_GAME(+Game) ; -; - +; True if game starts with a random setup. - (= - (random-setup-game $Game) - ( (game-assignments $Game $Assign) (random-assignment-decision $Assign))) -; + (= (random-setup-game $Game) + (game-assignments $Game $Assign) + (random-assignment-decision $Assign)) - - (= - (random-assignment-decision $AssignmentDef) - ( (assignment-decision $AssignmentDef $Assigner $PieceNames $Squares) (= $Assigner random))) -; - + (= (random-assignment-decision $AssignmentDef) + (assignment-decision $AssignmentDef $Assigner $PieceNames $Squares) + (= $Assigner random)) ; -; - +; ;; random_assignment(Assignments) ; -; - +; ;; If this is a random game, the assignments for this contest ; -; - +; ;; must already have been determined externally, ; -; - +; ;; such that this call succeeds. ; -; - +; ;; The result must be an assignment list, ; -; - +; ;; the result of parsing the arbitrary_assignment part of the ; -; - +; ;; game definition in grammar.pl, of the following form: ; -; - +; ;; Assignments = [piece1=[square1,..],...]. ; -; - +; ;; For example: ; -; - +; ;; [piece1=[square(2,1)],piece2=[square(1,2),square(3,1)]] ; -; - +; ; Pieces ; -; - +; Moved to parse2.pl, use player_current_game instead! ; -; - +; current_game_piece_name(Name) :- ; -; - +; current_game(Game), ; -; - - - - (= - (current-game-piece-struct-def $PieceStruct $Def) - ( (piece-struct-name $PieceStruct $Name) (current-game-piece-def $Game $Name $Def))) -; +; game_piece_def(Game,Name,_). + (= (current-game-piece-struct-def $PieceStruct $Def) + (piece-struct-name $PieceStruct $Name) + (current-game-piece-def $Game $Name $Def)) - (= - (current-game-piece-def $Name $Def) - ( (current-game $Game) (game-piece-def $Game $Name $Def))) -; + (= (current-game-piece-def $Name $Def) + (current-game $Game) + (game-piece-def $Game $Name $Def)) - (= - (game--piece-has-movement $Piece $Movement) - ( (current-game $Game) (game-piece-has-movement $Piece $Movement $Game))) -; + (= (game--piece-has-movement $Piece $Movement) + (current-game $Game) + (game-piece-has-movement $Piece $Movement $Game)) + (= (game--piece-has-capture $Piece $Capture) + (current-game $Game) + (game-piece-has-capture $Piece $Capture $Game)) - (= - (game--piece-has-capture $Piece $Capture) - ( (current-game $Game) (game-piece-has-capture $Piece $Capture $Game))) -; - - - - (= - (game--piece-has-constraint $Piece $Constraint) - ( (player-current-game $Game) (game-piece-has-constraint $Piece $Constraint $Game))) -; + (= (game--piece-has-constraint $Piece $Constraint) + (player-current-game $Game) + (game-piece-has-constraint $Piece $Constraint $Game)) ; -; +; Whether a piece continues capturing. + (= (game--piece-continues $Piece) + (constraint-continue-captures $Con) + (game--piece-has-constraint $Piece $Con)) - (= - (game--piece-continues $Piece) - ( (constraint-continue-captures $Con) (game--piece-has-constraint $Piece $Con))) -; - - - - (= - (game--piece-must-capture $Piece) - ( (constraint-must-capture $Con) (game--piece-has-constraint $Piece $Con))) -; + (= (game--piece-must-capture $Piece) + (constraint-must-capture $Con) + (game--piece-has-constraint $Piece $Con)) ; -; - +; Whether a piece must capture. ; -; - +; It must capture either if the game has this constraint, ; -; - +; or the piece itself does. ; -; - +; Note this assumes Piece is bound, won't nec. generate them. - (= - (game--piece-must $Piece) + (= (game--piece-must $Piece) (det-if-then-else current-game-must-capture True (game--piece-must-capture $Piece))) -; - ; -; - +; --------------------------------------------- ; -; - +; Promoting ; -; - +; Could simplify by using same structure produced by generator, ; -; - +; instead of translating. ; -; - - - - (= - (game--piece-has-promoting $Piece $Promoting) - ( (current-game $Game) (game-piece-has-promoting $Piece $Promoting $Game))) -; +; Must handle simple case also (promote to fish). + (= (game--piece-has-promoting $Piece $Promoting) + (current-game $Game) + (game-piece-has-promoting $Piece $Promoting $Game)) - (= - (game--piece-promoting $Piece $Promoting) - ( (current-game $Game) (game-piece-promoting $Piece $Promoting $Game))) -; + (= (game--piece-promoting $Piece $Promoting) + (current-game $Game) + (game-piece-promoting $Piece $Promoting $Game)) - (= - (game--promote-rank $Rank) - ( (current-game $Game) (game-promote-rank $Game $Rank))) -; - + (= (game--promote-rank $Rank) + (current-game $Game) + (game-promote-rank $Game $Rank)) diff --git a/metagame/theory/parse1.metta b/metagame/theory/parse1.metta index 9692e50..8e6c1f2 100644 --- a/metagame/theory/parse1.metta +++ b/metagame/theory/parse1.metta @@ -1,145 +1,104 @@ +; (convert_to_metta_file parse1 $_136278 metagame/theory/parse1.pl metagame/theory/parse1.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; parse1.pl ; -; - +; Experimenting with different versions of generating and ; -; - +; saving games. - (= - (generate-make-test-game) - ( (generate-game $G) (make-test-game $G))) -; - + (= (generate-make-test-game) + (generate-game $G) + (make-test-game $G)) ; -; - +; GENERATE_AND_LOAD(+File) ; -; - +; Generates a new game into file 'File.game', ; -; - - - (= - (generate-and-load $File) - ( (random-game-to-file $File) (load-game $File))) -; +; then loads it. + (= (generate-and-load $File) + (random-game-to-file $File) + (load-game $File)) ; -; - +; LOAD_GAME(+GameName) ; -; - +; Finds a file GameName.game in a library directory. ; -; - - - (= - (load-game $Name) - ( (find-game-file $Name $File) (file-make-test-game $File))) -; +; Then loads this file as the current (test) game. + (= (load-game $Name) + (find-game-file $Name $File) + (file-make-test-game $File)) ; -; +; Uses predicate in sysdev.pl - - (= - (find-game-file $Name $File) + (= (find-game-file $Name $File) (find-suffixed-library-file $Name game $File)) -; - ; -; - - - (= - (file-make-test-game $File) - ( (read-game-from-file-to-list $File $Game) (parse-make-test-game $Game))) -; +; file_make_test_game('~/MeTTa/play/chess.game'). + (= (file-make-test-game $File) + (read-game-from-file-to-list $File $Game) + (parse-make-test-game $Game)) ; -; - +; STRING_MAKE_TEST_GAME(+String) - (= - (string-make-test-game $String) - ( (read-game-from-string-to-list $String $Game) (parse-make-test-game $Game))) -; + (= (string-make-test-game $String) + (read-game-from-string-to-list $String $Game) + (parse-make-test-game $Game)) - - (= - (parse-make-test-game $Game) - ( (set-parsing-mode) - (format "~nParsing game.~n" Nil) - (game $G $Game Nil) - (make-test-game $G))) -; - + (= (parse-make-test-game $Game) + (set-parsing-mode) + (format "~nParsing game.~n" Nil) + (game $G $Game Nil) + (make-test-game $G)) !(dynamic (, (/ player-current-game 1) (/ opponent-current-game 1))) -; - ; -; - +; index_sym_dirs/0 defined in compile_syms.pl ; -; +; To compare speed without it, comment out that line. - - (= - (make-test-game $G) + (= (make-test-game $G) ( (game-name $G $Name) (format "~nMaking ~w the current test game~n" (:: $Name)) (abolish (/ player-current-game 1)) (abolish (/ opponent-current-game 1)) - (add-symbol &self + (add-is-symbol &self (player_current_game $G)) (invert $G opponent $G1) - (add-symbol &self + (add-is-symbol &self (opponent_current_game $G1)) (maybe-compile-syms))) -; - - (= - (maybe-compile-syms) + (= (maybe-compile-syms) (det-if-then-else (parameter compile-symmetries on) index-sym-dirs True)) -; - diff --git a/metagame/theory/parse2.metta b/metagame/theory/parse2.metta index c64e8ce..183be9a 100644 --- a/metagame/theory/parse2.metta +++ b/metagame/theory/parse2.metta @@ -1,367 +1,247 @@ +; (convert_to_metta_file parse2 $_218178 metagame/theory/parse2.pl metagame/theory/parse2.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; ;; parse2.pl ; -; - +; ;; Taking some preds out of parse, as not state-dependent. - (= - (current-game-for-player player $Game) + (= (current-game-for-player player $Game) (player-current-game $Game)) -; - - (= - (current-game-for-player opponent $Game) + (= (current-game-for-player opponent $Game) (opponent-current-game $Game)) -; - - (= - (current-game-name $GameName) - ( (player-current-game $G) (game-name $G $GameName))) -; - + (= (current-game-name $GameName) + (player-current-game $G) + (game-name $G $GameName)) - (= - (current-game-piece-name $Name) - ( (player-current-game $Game) (game-piece-def $Game $Name $_))) -; - + (= (current-game-piece-name $Name) + (player-current-game $Game) + (game-piece-def $Game $Name $_)) - (= - (game-piece-name $Game $Name) - (game-piece-def $Game $Name $_)) -; - + (= (game-piece-name $Game $Name) + (game-piece-def $Game $Name $_)) ; -; - - - (= - (game-piece-struct-def $Game $PieceStruct $Def) - ( (piece-struct-name $PieceStruct $Name) (game-piece-def $Game $Name $Def))) -; +; Finds def. corresponding to the name of the piece in piecestruct. + (= (game-piece-struct-def $Game $PieceStruct $Def) + (piece-struct-name $PieceStruct $Name) + (game-piece-def $Game $Name $Def)) ; -; - - - (= - (game-piece-def $Game $Name $Def) - ( (game-piece-defs $Game $Defs) - (member $Def $Defs) - (piece-name $Def $Name))) -; +; Finds the definition corresponding to a particular NAME of piece. + (= (game-piece-def $Game $Name $Def) + (game-piece-defs $Game $Defs) + (member $Def $Defs) + (piece-name $Def $Name)) - (= - (game-piece-defs $G $P) + (= (game-piece-defs $G $P) (game-pieces $G $P)) -; - ; -; - - - (= - (game-has-goal $Game $Goal) - ( (game-goal $Game $CompGoal) (goal-component $CompGoal $Goal))) -; +; ; Goals + (= (game-has-goal $Game $Goal) + (game-goal $Game $CompGoal) + (goal-component $CompGoal $Goal)) - (= - (goal-component $CompGoal $Goal) + (= (goal-component $CompGoal $Goal) (member $Goal $CompGoal)) -; - ; -; - +; Constraints - (= - (game-must-capture $Game) - ( (constraint-must-capture $Con) (game-constraints $Game $Con))) -; - + (= (game-must-capture $Game) + (constraint-must-capture $Con) + (game-constraints $Game $Con)) - (= - (game-continues $Game) - ( (constraint-continue-captures $Con) (game-constraints $Game $Con))) -; - + (= (game-continues $Game) + (constraint-continue-captures $Con) + (game-constraints $Game $Con)) - (= - (current-game-must-capture) - ( (player-current-game $Game) (game-must-capture $Game))) -; - + (= (current-game-must-capture) + (player-current-game $Game) + (game-must-capture $Game)) ; -; - +; Constraints on pieces - (= - (game-piece-has-constraint $Piece $Constraint $Game) - ( (game-piece-struct-def $Game $Piece $Def) (piece-constraints $Def $Constraint))) -; - + (= (game-piece-has-constraint $Piece $Constraint $Game) + (game-piece-struct-def $Game $Piece $Def) + (piece-constraints $Def $Constraint)) ; -; - +; Movement - (= - (game-piece-has-movement $Piece $Movement $Game) - ( (game-piece-struct-def $Game $Piece $Def) - (piece-movement $Def $CompMovement) - (movement-component $CompMovement $Movement))) -; + (= (game-piece-has-movement $Piece $Movement $Game) + (game-piece-struct-def $Game $Piece $Def) + (piece-movement $Def $CompMovement) + (movement-component $CompMovement $Movement)) - - (= - (movement-component $CompMovement $Movement) + (= (movement-component $CompMovement $Movement) (member $Movement $CompMovement)) -; - ; -; - +; Backtracking gives all the dirs that the piece ; -; - +; can leap to, based on its symmetries. ; -; +; (not so happy having this in parse file!). - - (= - (leap $M $Dir) - ( (movement-type $M $L) - (leaper $L) - (movement-sym-dir $M $Dir))) -; - + (= (leap $M $Dir) + (movement-type $M $L) + (leaper $L) + (movement-sym-dir $M $Dir)) ; -; - +; Valid_min and valid_max are defined in boards.pl ; -; - +; Valid_max computes the greatest number of leaps ; -; - +; which need to be considered before the piece would ; -; - - - (= - (ride $M $Dir $Min $Max $Longest) - ( (movement-type $M $R) - (rider $R $Longest $Min1 $Max1) - (movement-sym-dir $M $Dir) - (valid-min $Min1 $Min) - (valid-max $Max1 $Dir $Max))) -; +; be off the board or wrapped back to the original square. + (= (ride $M $Dir $Min $Max $Longest) + (movement-type $M $R) + (rider $R $Longest $Min1 $Max1) + (movement-sym-dir $M $Dir) + (valid-min $Min1 $Min) + (valid-max $Max1 $Dir $Max)) ; -; - - - (= - (longest yes) True) -; - - +; When unified with the longest component, succeeds if it should. + (= (longest yes) True) - (= - (hop $M $Dir $Before $Over $After $Description) - ( (movement-type $M $H) - (hopper $H $Description $Before $Over $After) - (movement-sym-dir $M $Dir))) -; + (= (hop $M $Dir $Before $Over $After $Description) + (movement-type $M $H) + (hopper $H $Description $Before $Over $After) + (movement-sym-dir $M $Dir)) - (= - (movement-sym-dir $M $Dir) - ( (movement-dir $M $D) - (movement-syms $M $Syms) - (sym-dir $D $Syms $Dir))) -; + (= (movement-sym-dir $M $Dir) + (movement-dir $M $D) + (movement-syms $M $Syms) + (sym-dir $D $Syms $Dir)) ; -; - +; Uses sym_set from grammar.pl. ; -; - +; This is absurdly inefficient! - (= - (movement-syms $M $Syms) - ( (movement-sym $M $S) (sym-set $S $Syms Nil))) -; - + (= (movement-syms $M $Syms) + (movement-sym $M $S) + (sym-set $S $Syms Nil)) ; -; - +; Capturing - (= - (game-piece-has-capture $Piece $Capture $Game) - ( (game-piece-struct-def $Game $Piece $Def) - (piece-capture $Def $CompCapture) - (capture-component $CompCapture $Capture))) -; + (= (game-piece-has-capture $Piece $Capture $Game) + (game-piece-struct-def $Game $Piece $Def) + (piece-capture $Def $CompCapture) + (capture-component $CompCapture $Capture)) + (= (capture-has-movement $Capture $M) + (capture-movement $Capture $Ms) + (member $M $Ms)) - (= - (capture-has-movement $Capture $M) - ( (capture-movement $Capture $Ms) (member $M $Ms))) -; - - - (= - (capture-component $CompCapture $Capture) + (= (capture-component $CompCapture $Capture) (member $Capture $CompCapture)) -; - - (= - (capture-has-method $Capture $Method) - ( (capture-methods $Capture $Methods) (component-of-method $Method $Methods))) -; + (= (capture-has-method $Capture $Method) + (capture-methods $Capture $Methods) + (component-of-method $Method $Methods)) - - (= - (component-of-method clobber $M) + (= (component-of-method clobber $M) (method-clobber $M yes)) -; - - (= - (component-of-method retrieve $M) + (= (component-of-method retrieve $M) (method-retrieve $M yes)) -; - - (= - (component-of-method hop $M) + (= (component-of-method hop $M) (method-hop $M yes)) -; - - (= - (capture-methods-list $Capturing $Meths) + (= (capture-methods-list $Capturing $Meths) (bagof $Meth (capture-has-method $Capturing $Meth) $Meths)) -; - ; -; - +; Promoting ; -; - +; Could simplify by using same structure produced by generator, ; -; - +; instead of translating. ; -; +; Must handle simple case also (promote to fish). + (= (game-piece-has-promoting $Piece $Promoting $Game) + (game-piece-struct-def $Game $Piece $Def) + (piece-promote $Def $Promoting)) - (= - (game-piece-has-promoting $Piece $Promoting $Game) - ( (game-piece-struct-def $Game $Piece $Def) (piece-promote $Def $Promoting))) -; - - - - (= - (game-piece-promoting $Piece $Promoting $Game) - ( (game-piece-has-promoting $Piece $Promote $Game) (promoting-info $Promote $Promoting))) -; + (= (game-piece-promoting $Piece $Promoting $Game) + (game-piece-has-promoting $Piece $Promote $Game) + (promoting-info $Promote $Promoting)) ; -; - - - (= - (promoting_info - (promote $Promote) - (promote $Promote)) True) -; - - (= - (promoting-info $Promote $Promoting) - ( (decision-chooser $Promote $Player) - (decision-options $Promote $Descr) - (= $Promoting - (promote $Player $Descr)))) -; - +; Either a decision, or a simple type. + (= (promoting_info (promote $Promote) (promote $Promote)) True) + (= (promoting-info $Promote $Promoting) + (decision-chooser $Promote $Player) + (decision-options $Promote $Descr) + (= $Promoting + (promote $Player $Descr))) - (= - (game-promote-rank $Game $Rank) - ( (game-board $Game $Board) (board-promote-rows $Board $Rank))) -; + (= (game-promote-rank $Game $Rank) + (game-board $Game $Board) + (board-promote-rows $Board $Rank)) diff --git a/metagame/theory/print_boards.metta b/metagame/theory/print_boards.metta index 277539d..497dd1f 100644 --- a/metagame/theory/print_boards.metta +++ b/metagame/theory/print_boards.metta @@ -1,479 +1,334 @@ +; (convert_to_metta_file print_boards $_355286 metagame/theory/print_boards.pl metagame/theory/print_boards.metta) ; -; - +; ============================================================ ; -; - +; METAGAME Game-Playing Workbench ; -; - +; Copyright (c) 1992 Barney D. Pell ; -; - +; ============================================================ ; -; - +; print_boards.pl ; -; - +; ================================================================================ ; -; - +; Printing Boards ; -; - - - - (= - (print-state) - ( (print-board) - (move-count $Count) - (control $P) - (nl) - (write-pieces-in-hand player) - (write-pieces-in-hand opponent) - (format "~nMove Number: ~d~nControl: ~p~n" - (:: $Count $P)) - (print-stage) - (print-opponent-promotes) - (print-effect) - (print-movement))) -; - - - - (= - (print-stage) +; ================================================================================ + + + (= (print-state) + (print-board) + (move-count $Count) + (control $P) + (nl) + (write-pieces-in-hand player) + (write-pieces-in-hand opponent) + (format "~nMove Number: ~d~nControl: ~p~n" + (:: $Count $P)) + (print-stage) + (print-opponent-promotes) + (print-effect) + (print-movement)) +; ; print_captured, + + + (= (print-stage) (det-if-then-else (stage $S) (verbosely-format "Stage: ~p~n" (:: $S)) True)) -; - ; -; - +; This message isn't correct, depends on which player to move. ; -; - +; Can't tell just from control, as sometimes see this when still ; -; +; player's move, otherwise when opponents. - - (= - (print-opponent-promotes) + (= (print-opponent-promotes) (det-if-then-else (opponent-promotes $OldPiece $Sq) (, (control $O) (format "~p must promote: ~p on ~p~n" (:: $O $OldPiece $Sq))) True)) -; - - (= - (print-movement) + (= (print-movement) (det-if-then-else (moved-onto $Piece $Square) (format "~p moved onto ~p~n" (:: $Piece $Square)) True)) -; - - (= - (print-effect) + (= (print-effect) (det-if-then-else (effects $Effect $Captured) (, (real-capture (:: (captured $Effect $Captured)) Nil $String Nil) (print-tokens $String)) True)) -; - +; /* print_effect :- effect(E) -> format("Effect: ~p~n",[E]) ; true. */ - (= - (print-captured) + (= (print-captured) (det-if-then-else (setof (@ $C $Sq) (captured $C $Sq) $Caps) (format "Captured: ~p~n" (:: $Caps)) True)) -; - - (= - (pieces-in-hand $Player $Pieces) + (= (pieces-in-hand $Player $Pieces) (bagof $Piece (in-hand $Piece $Player) $Pieces)) -; - - (= - (write-pieces-in-hand $Player) + (= (write-pieces-in-hand $Player) (det-if-then-else (pieces-in-hand $Player $Pieces) (format "Pieces in ~p's hand: ~p~n" (:: $Player $Pieces)) True)) -; - - - - (= - (print-board) - ( (current-board-size $X $Y) - (nl) - (print-squares-in-rows 1 $Y $X))) -; - + (= (print-board) + (current-board-size $X $Y) + (nl) + (print-squares-in-rows 1 $Y $X)) - (= - (print-hline 0) - ( (format "+~n" Nil) (set-det))) -; - (= - (print-hline $N) - ( (format "+---" Nil) - (is $N1 - (- $N 1)) - (print-hline $N1))) -; + (= (print-hline 0) + (format "+~n" Nil) + (set-det)) + (= (print-hline $N) + (format "+---" Nil) + (is $N1 + (- $N 1)) + (print-hline $N1)) - (= - (print-column-labels $Size) + (= (print-column-labels $Size) (print-column-labels 1 $Size)) -; - - - (= - (print-column-labels $X $Max) - ( (> $X $Max) - (set-det) - (nl))) -; - - (= - (print-column-labels $C $Max) - ( (write ) - (print-column-label $C) - (write ' ') - (is $C1 - (+ $C 1)) - (print-column-labels $C1 $Max))) -; - - - - (= - (print-column-label $C) - ( (nth-letter $C $Letter) (write $Letter))) -; + (= (print-column-labels $X $Max) + (> $X $Max) + (set-det) + (nl)) + (= (print-column-labels $C $Max) + (write ) + (print-column-label $C) + (write ' ') + (is $C1 + (+ $C 1)) + (print-column-labels $C1 $Max)) + + + (= (print-column-label $C) + (nth-letter $C $Letter) + (write $Letter)) ; -; - +; print_squares_in_rows(MinRow,MaxRow,Size) ; -; - - +; Prints Size squares in each of rows [MinRow .. MaxRow]. - (= - (print-squares-in-rows $Min $Max $Size) - ( (is $Min1 - (- $Min 1)) - (print-hline $Size) - (print-squares-in-rows $Max $Min1 $Max $Size))) -; + (= (print-squares-in-rows $Min $Max $Size) + (is $Min1 + (- $Min 1)) + (print-hline $Size) + (print-squares-in-rows $Max $Min1 $Max $Size)) - (= - (print-squares-in-rows $Min $Min $Max $Size) - ( (set-det) (print-column-labels $Size))) -; - - (= - (print-squares-in-rows $_ $_ $_ 0) + (= (print-squares-in-rows $Min $Min $Max $Size) + (set-det) + (print-column-labels $Size)) + (= (print-squares-in-rows $_ $_ $_ 0) (set-det)) -; - - (= - (print-squares-in-rows $Row $Min $Max $Size) - ( (print-squares-in-row $Row $Size) - (nl) - (print-hline $Size) - (is $Row1 - (- $Row 1)) - (print-squares-in-rows $Row1 $Min $Max $Size))) -; - + (= (print-squares-in-rows $Row $Min $Max $Size) + (print-squares-in-row $Row $Size) + (nl) + (print-hline $Size) + (is $Row1 + (- $Row 1)) + (print-squares-in-rows $Row1 $Min $Max $Size)) - (= - (print-squares-in-row $Row $Size) + (= (print-squares-in-row $Row $Size) (print-squares-in-row $Row 1 $Size)) -; - - (= - (print-end-row $Row) + (= (print-end-row $Row) (format "| ~p" (:: $Row))) -; - - (= - (print-squares-in-row $Row $Current $Max) - ( (> $Current $Max) - (set-det) - (print-end-row $Row))) -; + (= (print-squares-in-row $Row $Current $Max) + (> $Current $Max) + (set-det) + (print-end-row $Row)) + (= (print-squares-in-row $Row $Cur $Max) + (is $Cur1 + (+ $Cur 1)) + (print-square $Cur $Row) + (print-squares-in-row $Row $Cur1 $Max)) +; ; Column first, then row. - (= - (print-squares-in-row $Row $Cur $Max) - ( (is $Cur1 - (+ $Cur 1)) - (print-square $Cur $Row) - (print-squares-in-row $Row $Cur1 $Max))) -; - - - (= - (print-square $X $Y) - ( (write |) - (square $Square $X $Y) - (print-piece-on-square $Square))) -; - + (= (print-square $X $Y) + (write |) + (square $Square $X $Y) + (print-piece-on-square $Square)) +; ; Column first, then row. ; -; - +; ;; question_marker is used only for special printing of ; -; - - - (= - (print-piece-on-square $Square) - ( (on $Piece $Square) - (ground $Piece) - (set-det) - (print-piece-or-empty $Piece $Square))) -; +; ;; variablized boards. - (= - (print-piece-on-square $Square) - ( (question-marker $Square $Mark) (write $Mark))) -; + (= (print-piece-on-square $Square) + (on $Piece $Square) + (ground $Piece) + (set-det) + (print-piece-or-empty $Piece $Square)) + (= (print-piece-on-square $Square) + (question-marker $Square $Mark) + (write $Mark)) - - (= - (print-piece-or-empty $Piece $Square) - ( (piece-struct-name $Piece $Name) - (set-det) - (piece-struct-owner $Piece $Player) - (print-player-piece $Player $Name))) -; - - (= - (print-piece-or-empty $Piece $Square) + (= (print-piece-or-empty $Piece $Square) + (piece-struct-name $Piece $Name) + (set-det) + (piece-struct-owner $Piece $Player) + (print-player-piece $Player $Name)) + (= (print-piece-or-empty $Piece $Square) (print-empty-square $Square)) -; - +; ; empty(Square), - (= - (print-empty-square $Square) - ( (square $Square $X $Y) - (parity $X $Y $Par) - (parity-marker $Par $Mark) - (write $Mark))) -; + (= (print-empty-square $Square) + (square $Square $X $Y) + (parity $X $Y $Par) + (parity-marker $Par $Mark) + (write $Mark)) - - (= - (parity $X $Y $Total) + (= (parity $X $Y $Total) (is $Total (mod (+ $X $Y) 2))) -; - ; -; - +; parity_marker(0,'@'). ; -; - - - - (= - (parity_marker 0 ...) True) -; - - (= - (parity_marker 1 ) True) -; +; parity_marker(1,'-'). + (= (parity_marker 0 ...) True) + (= (parity_marker 1 ) True) - (= - (question_marker $_ ? ) True) -; + (= (question_marker $_ ? ) True) - (= - (print-colored player $Name) + (= (print-colored player $Name) (format " ~p " (:: $Name))) -; - - (= - (print-colored opponent $Name) + (= (print-colored opponent $Name) (format "*~p*" (:: $Name))) -; - - - (= - (print-player-piece $Player $Piece) - ( (player-piece-print-name $Player $Piece $Name) (print-colored $Player $Name))) -; + (= (print-player-piece $Player $Piece) + (player-piece-print-name $Player $Piece $Name) + (print-colored $Player $Name)) - (= - (player-piece-print-name $Player $P $Name) - ( (piece-print-name $P $PName) (name-for-player $Player $PName $Name))) -; - + (= (player-piece-print-name $Player $P $Name) + (piece-print-name $P $PName) + (name-for-player $Player $PName $Name)) ; -; - +; If pieces are named pieceN, returns the value N. ; -; - +; Otherwise, name must start with an alpha characters, ; -; - +; and this first character will become the print name. ; -; - +; (Thus, no different pieces should have same first character). ; -; - +; Ex. piece1 prints as: a ; -; - +; bishop prints as: b - (= - (piece-print-name $P $PieceNum) - ( (bi-concat piece $PieceNum $P) - (number-chars $PieceNum $NumChars) - (set-det))) -; - - (= - (piece-print-name $P $PieceNum) - ( (name $P - (Cons $InitChar $Rest)) - (name $Letter - (:: $InitChar)) - (nth-letter $PieceNum $Letter))) -; - + (= (piece-print-name $P $PieceNum) + (bi-concat piece $PieceNum $P) + (number-chars $PieceNum $NumChars) + (set-det)) + (= (piece-print-name $P $PieceNum) + (name $P + (Cons $InitChar $Rest)) + (name $Letter + (:: $InitChar)) + (nth-letter $PieceNum $Letter)) ; -; - +; NewName is the Nth alpha char, where PieceNum is N, an integer. ; -; - +; Used to be: ; -; - +; Lower case for PLAYER, upper case for OPPONENT. ; -; - +; Ex: piece(piece1,player) prints as 'a', ; -; - +; piece(piece1,opponent) prints as 'A'. ; -; - +; Now prints both same, but prints player Piece as ' P ', ; -; - - - (= - (name-for-player $Player $PieceNum $NewName) - ( (player-offset $Player $Off) - (is $OrdNum - (- - (+ $Off $PieceNum) 1)) - (name $NewName - (:: $OrdNum)))) -; - +; opponent as '*P*' + + (= (name-for-player $Player $PieceNum $NewName) + (player-offset $Player $Off) + (is $OrdNum + (- + (+ $Off $PieceNum) 1)) + (name $NewName + (:: $OrdNum))) - (= - (player-offset player $O) + (= (player-offset player $O) (name A (:: $O))) -; - - (= - (player-offset opponent $O) + (= (player-offset opponent $O) (name A (:: $O))) -; - ; -; - +; ================================================================================ diff --git a/miles/argument_types.metta b/miles/argument_types.metta index e1d19ed..57375a2 100644 --- a/miles/argument_types.metta +++ b/miles/argument_types.metta @@ -1,6 +1,6 @@ +; (convert_to_metta_file argument_types $_195816 miles/argument_types.pl miles/argument_types.metta) ; -; - +; MODULE argument_types EXPORTS !(module argument-types (:: @@ -15,13 +15,10 @@ (/ compare-types 3) (/ define-type 0) (/ verify-types 0))) -; - ; -; - +; IMPORTS !(use-module (home kb) (:: @@ -31,13 +28,9 @@ (/ store-clause 4) (/ known 6) (/ delete-clause 1))) -; - !(use-module (home lgg) (:: (/ set-lgg 2))) -; - !(use-module (home div-utils) (:: @@ -49,988 +42,672 @@ (/ make-unique 2) (/ shares-var 2) (/ mysetof 3))) -; - !(use-module (home var-utils) (:: (/ only-vars 2))) -; - !(use-module (home td-basic) (:: (/ append-body 3))) -; - !(use-module (home interpreter) (:: (/ t-interpreter 2))) -; - !(use-module (home show-utils) (:: (/ show-kb-types 0))) -; - !(use-module-if-exists (library subsumes) (:: (/ variant 2))) -; - !(use-module-if-exists (library occurs) (:: (/ contains-var 2))) -; - !(use-module-if-exists (library basics) (:: (/ member 2))) -; - !(use-module-if-exists (library strings) (:: (/ gensym 2))) -; - ; -; - +; METAPREDICATES ; -; - +; none !(dynamic (/ type-restriction 2)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: argument_types.pl ; -; - +; * ; -; - +; * author: I.Stahl date:12/92 ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * ; -; - +; * description: algorithm for determining argument types ; -; - +; * results for each predicate p within the pos examples ; -; - +; * in a kb entry ; -; - +; * type_restriction(p(V1,..,Vn),[type1(V1),...,typen(Vn)]) ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: argument_types/0 ; -; - +; * ; -; - +; * syntax: - ; -; - +; * ; -; - +; * args: none ; -; - +; * ; -; - +; * ; -; - +; * description: toplevel predicate for determining argument types ; -; - +; * results for each predicate p within the pos examples ; -; - +; * in a kb entry ; -; - +; * type_restriction(p(V1,..,Vn),[type1(V1),...,typen(Vn)]) ; -; - +; * ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (argument-types) - ( (mysetof $E - (^ $I - (get-example $I $E +)) $Elist) - (different-predicates $Elist $Elist1) - (argument-types $Elist1) - (set-det))) -; +; *********************************************************************** - - (= - (argument_types ()) True) -; - - (= - (argument-types (Cons $E $R)) - ( (argument-types $R) (arg-types $E))) -; + (= (argument-types) + (mysetof $E + (^ $I + (get-example $I $E +)) $Elist) + (different-predicates $Elist $Elist1) + (argument-types $Elist1) + (set-det)) +; ; Elist = [E1,...,En] pos examples +; ; Elist1 = [[E1,..,Em],...] +; ; list of lists of pos examples with +; ; the same predicate symbol + (= (argument_types ()) True) + (= (argument-types (Cons $E $R)) + (argument-types $R) + (arg-types $E)) - (= - (arg-types (Cons $E $R)) - ( (functor $E $P $N) - (functor $P1 $P $N) - (det-if-then-else - (type-restriction $P1 $_) True - (add-symbol &self - (type_restriction $P1 ()))) - (arg-types $N - (Cons $E $R) $P $N))) -; + (= (arg-types (Cons $E $R)) + (functor $E $P $N) + (functor $P1 $P $N) + (det-if-then-else + (type-restriction $P1 $_) True + (add-is-symbol &self + (type_restriction $P1 ()))) + (arg-types $N + (Cons $E $R) $P $N)) +; ; assert a type restriction for the +; ; predicate if not already present ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: arg_types/4 ; -; - +; * ; -; - +; * syntax: arg_types(+Counter,+Examplelist,+Pred_symbol,+Pred_arity) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * ; -; - +; * description: ; -; - +; * for each argument position (1 to Pred_arity) of the predicate Pred_symbol ; -; - +; * the type of the terms occurring at that position is determined. ; -; - +; * If the same type occurred already elsewhere, the old definition is taken ; -; - +; * in order to avoid duplicate type definitions ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (arg-types 0 $_ $_ $_) + (= (arg-types 0 $_ $_ $_) (set-det)) -; - - (= - (arg-types $N $EL $P $M) - ( (is $N1 - (- $N 1)) - (arg-types $N1 $EL $P $M) - (nth-arg $EL $N $S) - (gensym type $Type) - (arg-type $S Nil Nil $CL $Type) - (minimize-cl $CL $Type $Type1) - (adapt-type-restriction $M $P $N $Type1))) -; - + (= (arg-types $N $EL $P $M) + (is $N1 + (- $N 1)) + (arg-types $N1 $EL $P $M) + (nth-arg $EL $N $S) + (gensym type $Type) + (arg-type $S Nil Nil $CL $Type) + (minimize-cl $CL $Type $Type1) + (adapt-type-restriction $M $P $N $Type1)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: arg_type/5 ; -; - +; * ; -; - +; * syntax: arg_type(+Set_of_Argterms,+Ancestors,+Clause_list,-Clause_list,+Typename) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * ; -; - +; * description: ; -; - +; * Ancestors are all types calling Typename in their definition. Clauselist ; -; - +; * contains all clauses defining Typename ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (arg-type $S $Ancestors $CL $CL2 $T) - ( (different-predicates $S $Slist) - (init-cl $Slist $T $CL0) - (append $CL $CL0 $CL1) - (refine-cl $Slist - (Cons $T $Ancestors) $CL0 $CL1 $CL2))) -; - ; -; + (= (arg-type $S $Ancestors $CL $CL2 $T) + (different-predicates $S $Slist) + (init-cl $Slist $T $CL0) + (append $CL $CL0 $CL1) + (refine-cl $Slist + (Cons $T $Ancestors) $CL0 $CL1 $CL2)) +; ; splits the set of Argterms according to +; ; different functors, Slist = [[T1,..,Tm],..] +; ; for each set of Argterms in Slist, generate +; ; a clause head with pred symbol Typename ; +; generate clause bodies - (= - (init_cl () $_ ()) True) -; - - (= - (init-cl - (Cons $EL $R) $T - (Cons - (= $T1 True) $R1)) - ( (init-cl $R $T $R1) - (set-lgg $EL $E) - (=.. $T1 - (:: $T $E)))) -; - + (= (init_cl () $_ ()) True) + (= (init-cl (Cons $EL $R) $T (Cons (= $T1 True) $R1)) + (init-cl $R $T $R1) + (set-lgg $EL $E) + (=.. $T1 + (:: $T $E))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: refine_cl/5 ; -; - +; * ; -; - +; * syntax: refine_cl(+Slist,+Ancestors,+Clauses,+Clauselist,-Clauselist) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * ; -; - +; * description: ; -; - +; * for each set of Argterms in Slist and each corresponding clause head ; -; - +; * in Clauses and Clauselist, add a body literal for each variable in the ; -; - +; * clause head. This body literal may be atom(_),atomic(_),number(_), ; -; - +; * typex(_),where typex is in Ancestors, or typez(_), where typez is a ; -; - +; * new type (recursive call of the algorithm) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (refine_cl () $_ $_ $CL $CL) True) -; +; *********************************************************************** - (= - (refine-cl - (Cons $S $R) $A - (Cons - (= $Head $_) $R1) $CL $CL2) - ( (refine-cl $R $A $R1 $CL $CL1) - (arg 1 $Head $E) - (det-if-then-else - (var $E) - (test-var-instantiations $E $S $Head $A $CL1 $CL2) - (, - (functor $E $_ $N) - (ref-cl $N $E $S $Head $A $CL1 $CL2))))) -; + (= (refine_cl () $_ $_ $CL $CL) True) + (= (refine-cl (Cons $S $R) $A (Cons (= $Head $_) $R1) $CL $CL2) + (refine-cl $R $A $R1 $CL $CL1) + (arg 1 $Head $E) + (det-if-then-else + (var $E) + (test-var-instantiations $E $S $Head $A $CL1 $CL2) + (, + (functor $E $_ $N) + (ref-cl $N $E $S $Head $A $CL1 $CL2)))) +; ; if the head argument is a variable, test its instantiations +; ; in S and add the corresponding literal to the body of Head +; ; if the head argument is no variable, +; ; decompose it, test the variables it contains +; ; and add the corresponding literals to the body +; ; of Head ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: ref_cl/7 ; -; - +; * ; -; - +; * syntax: ref_cl(+Counter,+Argument,+Argterms,+Head,+Ancestors, ; -; - +; * +Clauselist, -Clauselist) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: decompose the head argument and test the variables it contains; ; -; - +; * add the corresponding literals to the body of Head ; -; - +; * ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (ref-cl 0 $_ $_ $_ $_ $CL $CL) + (= (ref-cl 0 $_ $_ $_ $_ $CL $CL) (set-det)) -; - - (= - (ref-cl $N $E $S $H $A $CL $CL2) - ( (is $N1 - (- $N 1)) - (ref-cl $N1 $E $S $H $A $CL $CL1) - (arg $N $E $X) - (nth-arg $S $N $Sn) - (det-if-then-else - (var $X) - (test-var-instantiations $X $Sn $H $A $CL1 $CL2) - (, - (functor $X $_ $M) - (ref-cl $M $X $Sn $H $A $CL1 $CL2))))) -; - + (= (ref-cl $N $E $S $H $A $CL $CL2) + (is $N1 + (- $N 1)) + (ref-cl $N1 $E $S $H $A $CL $CL1) + (arg $N $E $X) + (nth-arg $S $N $Sn) + (det-if-then-else + (var $X) + (test-var-instantiations $X $Sn $H $A $CL1 $CL2) + (, + (functor $X $_ $M) + (ref-cl $M $X $Sn $H $A $CL1 $CL2)))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: test_var_instantiation/6 ; -; - +; * ; -; - +; * syntax: test_var_instantiations(+Var,+Argterms,+Head,+Ancestors, ; -; - +; * +Clauselist,-Clauselist) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * ; -; - +; * description: ; -; - +; * Argterms are the instantiations of Var. If all instantiations of Var ; -; - +; * are atoms/number/atomic, the literal atom(Var)/number(Var)/atomic(Var) is ; -; - +; * added to the body of Head in Clauselist. Else if the definition of a typex ; -; - +; * in Ancestors covers all instantiations of Var, typex(Var) is added to the ; -; - +; * body of Head in Clauselist (recursive definition). Else a new symbol typen ; -; - +; * is created, the literal typen(Var) is added to the body of Head in Clauselist ; -; - +; * and a definition of typen is induced by a recursive call of arg_type. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (test-var-instantiations $X $S $H $_ $CL $CL1) - ( (myforall $S is-symbol) - (set-det) - (=.. $Lit - (:: is-symbol $X)) - (add-literal $CL $H $Lit $CL1))) -; - +; *********************************************************************** - (= - (test-var-instantiations $X $S $H $_ $CL $CL1) - ( (myforall $S number) - (set-det) - (=.. $Lit - (:: number $X)) - (add-literal $CL $H $Lit $CL1))) -; + (= (test-var-instantiations $X $S $H $_ $CL $CL1) + (myforall $S is-symbol) + (set-det) + (=.. $Lit + (:: is-symbol $X)) + (add-literal $CL $H $Lit $CL1)) - (= - (test-var-instantiations $X $S $H $_ $CL $CL1) - ( (myforall $S symbolic) - (set-det) - (=.. $Lit - (:: symbolic $X)) - (add-literal $CL $H $Lit $CL1))) -; + (= (test-var-instantiations $X $S $H $_ $CL $CL1) + (myforall $S number) + (set-det) + (=.. $Lit + (:: number $X)) + (add-literal $CL $H $Lit $CL1)) + (= (test-var-instantiations $X $S $H $_ $CL $CL1) + (myforall $S symbolic) + (set-det) + (=.. $Lit + (:: symbolic $X)) + (add-literal $CL $H $Lit $CL1)) - (= - (test-var-instantiations $X $S $H $A $CL $CL1) - ( (test-ancestor $S $A $CL $APred) - (set-det) - (=.. $Lit - (:: $APred $X)) - (add-literal $CL $H $Lit $CL1))) -; + (= (test-var-instantiations $X $S $H $A $CL $CL1) + (test-ancestor $S $A $CL $APred) + (set-det) + (=.. $Lit + (:: $APred $X)) + (add-literal $CL $H $Lit $CL1)) + (= (test-var-instantiations $X $S $H $A $CL $CL1) + (gensym type $T) + (=.. $Lit + (:: $T $X)) + (add-literal $CL $H $Lit $CL0) + (arg-type $S $A $CL0 $CL1 $T)) - (= - (test-var-instantiations $X $S $H $A $CL $CL1) - ( (gensym type $T) - (=.. $Lit - (:: $T $X)) - (add-literal $CL $H $Lit $CL0) - (arg-type $S $A $CL0 $CL1 $T))) -; - - - (= - (test-ancestor $S - (Cons $APred $_) $CL $APred) - ( (myforall-interpreted $S $APred $CL) (set-det))) -; - - (= - (test-ancestor $S - (Cons $_ $R) $CL $APred) + (= (test-ancestor $S (Cons $APred $_) $CL $APred) + (myforall-interpreted $S $APred $CL) + (set-det)) + (= (test-ancestor $S (Cons $_ $R) $CL $APred) (test-ancestor $S $R $CL $APred)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: myforall_interpreted/3 ; -; - +; * ; -; - +; * syntax: myforall_interpreted(+Argterms,+Pred,+Clauselist) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * ; -; - +; * description: tests for each argument term T in Argterms whether Pred(T) ; -; - +; * follows from Clauselist. For that purpose, a special interpreter ; -; - +; * t_interpreter is used that works on Clauselist as program instead ; -; - +; * of the knowledge base. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (myforall_interpreted () $_ $_) True) -; - - (= - (myforall-interpreted - (Cons $E $R) $Pred $CL) - ( (=.. $C - (:: $Pred $E)) - (t-interpreter $C $CL) - (myforall-interpreted $R $Pred $CL))) -; + (= (myforall_interpreted () $_ $_) True) + (= (myforall-interpreted (Cons $E $R) $Pred $CL) + (=.. $C + (:: $Pred $E)) + (t-interpreter $C $CL) + (myforall-interpreted $R $Pred $CL)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: add_literal/4 ; -; - +; * ; -; - +; * syntax: add_literal(+Clauselist,+Head,+Lit,-Clauselist1) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: adds literal Lit to the clause (Head:- B) within Clauselist ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (add-literal - (Cons - (= $H $B) $R) $H1 $Lit - (Cons - (= $H - ($Lit $B)) $R)) - ( (== $H $H1) (set-det))) -; - (= - (add-literal - (Cons $C $R) $H $Lit - (Cons $C $R1)) + (= (add-literal (Cons (= $H $B) $R) $H1 $Lit (Cons (= $H + ($Lit $B)) $R)) + (== $H $H1) + (set-det)) + (= (add-literal (Cons $C $R) $H $Lit (Cons $C $R1)) (add-literal $R $H $Lit $R1)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: adapt_type_restriction/4 ; -; - +; * ; -; - +; * syntax: adapt_type_restriction(+Pred_arity,+Pred_name,+A,+Type) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: ; -; - +; * Type is the type of the Ath Argposition of the predicate Pred_name. The ; -; - +; * type restriction is type_restriction(p(V1,..,Vn),L). If there is not yet ; -; - +; * an entry typex(VA) in L, Type(VA) is added to L. Else let the definition ; -; - +; * of typex be typex(Hx1):- Bx1. and of Type be Type(H1):- B1. ; -; - +; * ... ... ; -; - +; * typex(Hxm):- Bxm. Type(Ho):- Bo. ; -; - +; * Then we add a new type Tnew(VA) to L with the definition ; -; - +; * Tnew(Hx1):- Bx1. Tnew(H1):- B1. ; -; - +; * ... ... ; -; - +; * Tnew(Hxm):- Bxm. Tnew(Ho):- Bo. ; -; - +; * The definitions of typex and Type remain. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (adapt-type-restriction $M $P $N $T) + (= (adapt-type-restriction $M $P $N $T) ( (functor $P1 $P $M) - (remove-symbol &self + (remove-is-symbol &self (type_restriction $P1 $L)) (arg $N $P1 $P1n) (det-if-then-else @@ -1045,605 +722,416 @@ (:: $Tnew $P1n)) (remove-v (:: $T1) $L $L1) - (add-symbol &self + (add-is-symbol &self (type_restriction $P1 (Cons $D $L1))) (adapt-tr $Tnew $T $T2)) (, (=.. $D (:: $T $P1n)) - (add-symbol &self + (add-is-symbol &self (type_restriction $P1 (Cons $D $L))))))) -; - - - - (= - (adapt-tr $Tnew $T1 $T2) - ( (functor $HT1 $T1 1) - (functor $HT2 $T2 1) - (mysetof - (= $HT1 $B1) - (^ $I - (^ $Clist - (get-clause $I $HT1 $B1 $Clist type))) $C1) - (mysetof - (= $HT2 $B2) - (^ $I - (^ $Clist - (get-clause $I $HT2 $B2 $Clist type))) $C2) - (append $C1 $C2 $C3) - (adapt-tr1 $C3 $Tnew $C4) - (make-unique $C4 $C5) - (store-clauses $C5 type))) -; - - - - (= - (adapt_tr1 () $_ ()) True) -; - - (= - (adapt-tr1 - (Cons - (= $H $B) $R) $T - (Cons - (= $H1 $B) $R1)) - ( (adapt-tr1 $R $T $R1) - (=.. $H - (Cons $_ $Arg)) - (=.. $H1 - (Cons $T $Arg)))) -; + (= (adapt-tr $Tnew $T1 $T2) + (functor $HT1 $T1 1) + (functor $HT2 $T2 1) + (mysetof + (= $HT1 $B1) + (^ $I + (^ $Clist + (get-clause $I $HT1 $B1 $Clist type))) $C1) + (mysetof + (= $HT2 $B2) + (^ $I + (^ $Clist + (get-clause $I $HT2 $B2 $Clist type))) $C2) + (append $C1 $C2 $C3) + (adapt-tr1 $C3 $Tnew $C4) + (make-unique $C4 $C5) + (store-clauses $C5 type)) -; -; -; -; + (= (adapt_tr1 () $_ ()) True) + (= (adapt-tr1 (Cons (= $H $B) $R) $T (Cons (= $H1 $B) $R1)) + (adapt-tr1 $R $T $R1) + (=.. $H + (Cons $_ $Arg)) + (=.. $H1 + (Cons $T $Arg))) -; -; ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: minimize_cl/3 ; -; - +; * ; -; - +; * syntax: minimize_cl(+CL,+Typename,-Typename) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: CL is the list of clauses defining the type Typename. ; -; - +; * If CL contains definitions that occur already in the database, ; -; - +; * or if it contains duplicate definitions, it is minimized. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - - +; * +; +; * see also: +; +; * +; +; *********************************************************************** - (= - (minimize-cl $CL $Type $Type1) - ( (mysetof - (= $H $B) - (^ $I - (^ $Clist - (get-clause $I $H $B $Clist type))) $Old_types) - (mysetof $T - (^ $H - (^ $B - (^ $R - (, - (member - (= $H $B) $Old_types) - (=.. $H - (Cons $T $R)))))) $Oldt_names) - (mysetof $T - (^ $H - (^ $B - (^ $R - (, - (member - (= $H $B) $CL) - (=.. $H - (Cons $T $R)))))) $Newt_names) - (append $Old_types $CL $Clauses) - (minimize-cl $Oldt_names $Newt_names $Clauses $CL $Type $Type1))) -; + (= (minimize-cl $CL $Type $Type1) + (mysetof + (= $H $B) + (^ $I + (^ $Clist + (get-clause $I $H $B $Clist type))) $Old_types) + (mysetof $T + (^ $H + (^ $B + (^ $R + (, + (member + (= $H $B) $Old_types) + (=.. $H + (Cons $T $R)))))) $Oldt_names) + (mysetof $T + (^ $H + (^ $B + (^ $R + (, + (member + (= $H $B) $CL) + (=.. $H + (Cons $T $R)))))) $Newt_names) + (append $Old_types $CL $Clauses) + (minimize-cl $Oldt_names $Newt_names $Clauses $CL $Type $Type1)) - (= - (minimize-cl Nil $Newt_names $Clauses $CL $Type $Type1) + (= (minimize-cl Nil $Newt_names $Clauses $CL $Type $Type1) (minim-cl $Newt_names $Clauses $CL $Type $Type1)) -; - - (= - (minimize-cl - (Cons $T $R) $Newt_names $Clauses $CL $Type $Type2) - ( (mysetof $T1 - (, - (member $T1 $Newt_names) - (type-equal $T $T1 - (:: (with_self $T $T1)) $Clauses)) $Tlist) - (replace-t $CL $Tlist $T $CL1) - (make-unique $CL1 $CL2) - (remove-v $Tlist $Newt_names $Newt_names1) - (det-if-then-else - (member $Type $Tlist) - (= $Type1 $T) - (= $Type1 $Type)) - (minimize-cl $R $Newt_names1 $Clauses $CL2 $Type1 $Type2))) -; - - + (= (minimize-cl (Cons $T $R) $Newt_names $Clauses $CL $Type $Type2) + (mysetof $T1 + (, + (member $T1 $Newt_names) + (type-equal $T $T1 + (:: (with_self $T $T1)) $Clauses)) $Tlist) + (replace-t $CL $Tlist $T $CL1) + (make-unique $CL1 $CL2) + (remove-v $Tlist $Newt_names $Newt_names1) + (det-if-then-else + (member $Type $Tlist) + (= $Type1 $T) + (= $Type1 $Type)) + (minimize-cl $R $Newt_names1 $Clauses $CL2 $Type1 $Type2)) - (= - (minim-cl Nil $_ $CL $Type $Type) - ( (min-cl $CL $CL1) (store-clauses $CL1 type))) -; - ; -; + (= (minim-cl Nil $_ $CL $Type $Type) + (min-cl $CL $CL1) + (store-clauses $CL1 type)) ; +; the remaining (minimized) set of clauses is stored ; -; - - (= - (minim-cl - (Cons $T $R) $Clauses $CL $Type $Type2) - ( (mysetof $T1 - (, - (member $T1 $R) - (type-equal $T $T1 - (:: (with_self $T $T1)) $Clauses)) $Tlist) - (replace-t $CL $Tlist $T $CL1) - (make-unique $CL1 $CL2) - (remove-v $Tlist $R $R1) - (det-if-then-else - (member $Type $Tlist) - (= $Type1 $T) - (= $Type1 $Type)) - (minim-cl $R1 $Clauses $CL2 $Type1 $Type2))) -; - - - - (= - (min_cl () ()) True) -; +; in the database + (= (minim-cl (Cons $T $R) $Clauses $CL $Type $Type2) + (mysetof $T1 + (, + (member $T1 $R) + (type-equal $T $T1 + (:: (with_self $T $T1)) $Clauses)) $Tlist) + (replace-t $CL $Tlist $T $CL1) + (make-unique $CL1 $CL2) + (remove-v $Tlist $R $R1) + (det-if-then-else + (member $Type $Tlist) + (= $Type1 $T) + (= $Type1 $Type)) + (minim-cl $R1 $Clauses $CL2 $Type1 $Type2)) - (= - (min-cl - (Cons - (= $H $B) $R) - (Cons - (= $H $B1) $R1)) - ( (min-cl $R $R1) (min-cl1 $B $B1))) -; + (= (min_cl () ()) True) + (= (min-cl (Cons (= $H $B) $R) (Cons (= $H $B1) $R1)) + (min-cl $R $R1) + (min-cl1 $B $B1)) - (= - (min-cl1 $A $A) + (= (min-cl1 $A $A) (set-det)) -; - - (= - (min-cl1 True True) + (= (min-cl1 True True) (set-det)) -; - - (= - (min-cl1 - (, $A $B) - (, $A $B1)) + (= (min-cl1 (, $A $B) (, $A $B1)) (min-cl1 $B $B1)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: replace_t/4 ; -; - +; * ; -; - +; * syntax: replace_t(+CL,+List_of_typenames,+Typename,-CL) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: replaces in CL each occurrence of a typename ; -; - +; * in List_of_typenames by Typename ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** + (= (replace_t () $_ $_ ()) True) + (= (replace-t (Cons (= $H $_) $R) $Tlist $T $R1) + (=.. $H + (Cons $T1 $_)) + (member $T1 $Tlist) + (set-det) + (replace-t $R $Tlist $T $R1)) + (= (replace-t (Cons (= $H $B) $R) $Tlist $T (Cons (= $H $B1) $R1)) + (repl-t $B $Tlist $T $B1) + (replace-t $R $Tlist $T $R1)) - (= - (replace_t () $_ $_ ()) True) -; - (= - (replace-t - (Cons - (= $H $_) $R) $Tlist $T $R1) - ( (=.. $H - (Cons $T1 $_)) + (= (repl-t (, $A $B) $Tlist $T (, $A1 $B1)) + (set-det) + (repl-t $A $Tlist $T $A1) + (repl-t $B $Tlist $T $B1)) + (= (repl-t $A $Tlist $T $A1) + (=.. $A + (Cons $T1 $R)) + (det-if-then-else (member $T1 $Tlist) - (set-det) - (replace-t $R $Tlist $T $R1))) -; - - (= - (replace-t - (Cons - (= $H $B) $R) $Tlist $T - (Cons - (= $H $B1) $R1)) - ( (repl-t $B $Tlist $T $B1) (replace-t $R $Tlist $T $R1))) -; - - - - (= - (repl-t - (, $A $B) $Tlist $T - (, $A1 $B1)) - ( (set-det) - (repl-t $A $Tlist $T $A1) - (repl-t $B $Tlist $T $B1))) -; - - (= - (repl-t $A $Tlist $T $A1) - ( (=.. $A - (Cons $T1 $R)) (det-if-then-else (member $T1 $Tlist) (=.. $A1 (Cons $T $R)) (= $A1 $A)))) -; - + (=.. $A1 + (Cons $T $R)) + (= $A1 $A))) ; -; - +; ***********************************************************************************; ; -; - +; * ; -; - +; * predicate: type_equal/2 ; -; - +; * ; -; - +; * syntax: type_equal(+Type_name1,+Type_name2) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: Tests whether the types Type_name1 and Type_name2 are defined ; -; - +; * identically ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ********************************************************************************** - (= - (type-equal $T $T) + (= (type-equal $T $T) (set-det)) -; - - (= - (type-equal $T1 $T2) - ( (mysetof - (= $H1 $B1) - (^ $I - (^ $CL - (^ $R - (, - (get-clause $I $H1 $B1 $CL type) - (=.. $H1 - (Cons $T1 $R)))))) $Clauses1) - (mysetof - (= $H2 $B2) - (^ $I - (^ $CL - (^ $R - (, - (get-clause $I $H2 $B2 $CL type) - (=.. $H2 - (Cons $T2 $R)))))) $Clauses2) - (append $Clauses1 $Clauses2 $Clauses) - (type-equal $T1 $T2 - (:: (with_self $T1 $T2)) $Clauses))) -; - - - (= - (type-equal $T $T $_ $_) + (= (type-equal $T1 $T2) + (mysetof + (= $H1 $B1) + (^ $I + (^ $CL + (^ $R + (, + (get-clause $I $H1 $B1 $CL type) + (=.. $H1 + (Cons $T1 $R)))))) $Clauses1) + (mysetof + (= $H2 $B2) + (^ $I + (^ $CL + (^ $R + (, + (get-clause $I $H2 $B2 $CL type) + (=.. $H2 + (Cons $T2 $R)))))) $Clauses2) + (append $Clauses1 $Clauses2 $Clauses) + (type-equal $T1 $T2 + (:: (with_self $T1 $T2)) $Clauses)) + + (= (type-equal $T $T $_ $_) (set-det)) -; - - (= - (type-equal $T1 $T2 $Ancestors $Clauses) - ( (mysetof - (= $H $B) - (^ $R - (, - (member - (= $H $B) $Clauses) - (=.. $H - (Cons $T1 $R)))) $Clist1) - (mysetof - (= $H $B) - (^ $R - (, - (member - (= $H $B) $Clauses) - (=.. $H - (Cons $T2 $R)))) $Clist2) - (compare-clauses $Clist1 $Clist2 $Clauses $Ancestors))) -; - + (= (type-equal $T1 $T2 $Ancestors $Clauses) + (mysetof + (= $H $B) + (^ $R + (, + (member + (= $H $B) $Clauses) + (=.. $H + (Cons $T1 $R)))) $Clist1) + (mysetof + (= $H $B) + (^ $R + (, + (member + (= $H $B) $Clauses) + (=.. $H + (Cons $T2 $R)))) $Clist2) + (compare-clauses $Clist1 $Clist2 $Clauses $Ancestors)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: compare_clauses/4 ; -; - +; * ; -; - +; * syntax: compare_clauses(+Clist1,+Clist2,+Clauses12,+Ancestors) ; -; - +; * ; -; - +; * args: Clist1 .. clauses defining Type_name1 ; -; - +; * Clist2 .. clauses defining Type_name2 ; -; - +; * Clauses12 .. all clauses defining Type_name1 and Type_name2 ; -; - +; * Ancestors .. types already tested on equality ; -; - +; * ; -; - +; * description: tests whether Type_name1 and Type_name2 are identically ; -; - +; * defined by comparing the defining clauses ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (compare_clauses () () $_ $_) True) -; - - (= - (compare-clauses - (Cons - (= $H1 $B1) $R) $CL2 $Clauses $Ancestors) - ( (find-variant-clause $CL2 $H1 $CL21 - (= $H2 $B2)) - (arg 1 $H1 $E1) - (arg 1 $H2 $E2) - (comp-clauses $E1 $E2 $B1 $B2 $Clauses $Ancestors) - (compare-clauses $R $CL21 $Clauses $Ancestors))) -; - +; *********************************************************************** - (= - (comp-clauses $E1 $E2 $B1 $B2 $C $A) - ( (var $E1) - (set-det) - (def-literal $E1 $B1 $L1) - (def-literal $E2 $B2 $L2) - (=.. $L1 - (Cons $T1 $_)) - (=.. $L2 - (Cons $T2 $_)) - (c-clauses $T1 $T2 $C $A))) -; + (= (compare_clauses () () $_ $_) True) + (= (compare-clauses (Cons (= $H1 $B1) $R) $CL2 $Clauses $Ancestors) + (find-variant-clause $CL2 $H1 $CL21 + (= $H2 $B2)) + (arg 1 $H1 $E1) + (arg 1 $H2 $E2) + (comp-clauses $E1 $E2 $B1 $B2 $Clauses $Ancestors) + (compare-clauses $R $CL21 $Clauses $Ancestors)) - (= - (comp-clauses $E1 $E2 $B1 $B2 $C $A) - ( (functor $E1 $_ $N) (comp-clauses $N $E1 $E2 $B1 $B2 $C $A))) -; - (= - (comp-clauses 0 $_ $_ $_ $_ $_ $_) + (= (comp-clauses $E1 $E2 $B1 $B2 $C $A) + (var $E1) + (set-det) + (def-literal $E1 $B1 $L1) + (def-literal $E2 $B2 $L2) + (=.. $L1 + (Cons $T1 $_)) + (=.. $L2 + (Cons $T2 $_)) + (c-clauses $T1 $T2 $C $A)) + (= (comp-clauses $E1 $E2 $B1 $B2 $C $A) + (functor $E1 $_ $N) + (comp-clauses $N $E1 $E2 $B1 $B2 $C $A)) + (= (comp-clauses 0 $_ $_ $_ $_ $_ $_) (set-det)) -; - - (= - (comp-clauses $N $E1 $E2 $B1 $B2 $C $A) - ( (is $N1 - (- $N 1)) - (comp-clauses $N1 $E1 $E2 $B1 $B2 $C $A) - (arg $N $E1 $E1n) - (arg $N $E2 $E2n) - (comp-clauses $E1n $E2n $B1 $B2 $C $A))) -; - - - - (= - (c-clauses is-symbol $L $_ $_) - ( (set-det) (= $L is-symbol))) -; - - (= - (c-clauses number $L $_ $_) - ( (set-det) (= $L number))) -; - - (= - (c-clauses symbolic $L $_ $_) - ( (set-det) (= $L symbolic))) -; - - (= - (c-clauses $_ $L2 $_ $_) - ( (or - (= $L2 is-symbol) - (or - (= $L2 number) - (= $L2 symbolic))) - (set-det) - (fail))) -; - - (= - (c-clauses $T1 $T2 $C $A) + (= (comp-clauses $N $E1 $E2 $B1 $B2 $C $A) + (is $N1 + (- $N 1)) + (comp-clauses $N1 $E1 $E2 $B1 $B2 $C $A) + (arg $N $E1 $E1n) + (arg $N $E2 $E2n) + (comp-clauses $E1n $E2n $B1 $B2 $C $A)) + + + (= (c-clauses is-symbol $L $_ $_) + (set-det) + (= $L is-symbol)) + (= (c-clauses number $L $_ $_) + (set-det) + (= $L number)) + (= (c-clauses symbolic $L $_ $_) + (set-det) + (= $L symbolic)) + (= (c-clauses $_ $L2 $_ $_) + (or + (= $L2 is-symbol) + (or + (= $L2 number) + (= $L2 symbolic))) + (set-det) + (fail)) + (= (c-clauses $T1 $T2 $C $A) (det-if-then-else (or (member @@ -1653,963 +1141,709 @@ (type-equal $T1 $T2 (Cons (with_self $T1 $T2) $A) $C))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: find_variant_clause/4 ; -; - +; * ; -; - +; * syntax: find_variant_clause(+CL,+Head,-CL1,-Clause) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: CL1 is CL - Clause, where the head argument of Head and ; -; - +; * of the head of Clause are variants ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (find-variant-clause - (Cons - (= $H2 $B2) $R) $H1 $R - (= $H2 $B2)) - ( (arg 1 $H1 $E1) - (arg 1 $H2 $E2) - (variant $E1 $E2))) -; - - (= - (find-variant-clause - (Cons $C $R) $H - (Cons $C $R1) $C1) + (= (find-variant-clause (Cons (= $H2 $B2) $R) $H1 $R (= $H2 $B2)) + (arg 1 $H1 $E1) + (arg 1 $H2 $E2) + (variant $E1 $E2)) + (= (find-variant-clause (Cons $C $R) $H (Cons $C $R1) $C1) (find-variant-clause $R $H $R1 $C1)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: def_literal/3 ; -; - +; * ; -; - +; * syntax: def_literal(+Var,+Body,-Lit) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: Lit is the literal within Body that defines the type of ; -; - +; * Var ; -; - +; * ; -; - +; * example: def_literal(A,(atom(A),list(B)),atom(A)) ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (def-literal $X - (, $A $B) $C) - ( (set-det) (det-if-then-else (contains-var $X $A) (= $C $A) (def-literal $X $B $C)))) -; +; *********************************************************************** - (= - (def-literal $X $A $A) - ( (contains-var $X $A) (set-det))) -; - - (= - (def_literal $X $_ - (all $X)) True) -; + (= (def-literal $X (, $A $B) $C) + (set-det) + (det-if-then-else + (contains-var $X $A) + (= $C $A) + (def-literal $X $B $C))) + (= (def-literal $X $A $A) + (contains-var $X $A) + (set-det)) + (= (def_literal $X $_ (all $X)) True) ; -; - +; ********************************************************************************** ; -; - +; * ; -; - +; * predicate: type_sub/2 ; -; - +; * ; -; - +; * syntax: type_sub(+Gen,+Spec) ; -; - +; * ; -; - +; * args: Gen, Spec: type names or intermediate type definitions ; -; - +; * t_int(H):- B (cf. type_of). ; -; - +; * ; -; - +; * description: succeeds if the type Gen is more general than ; -; - +; * the type Spec. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; ********************************************************************************** - (= - (type-sub $Gen - (= $H $B)) + (= (type-sub $Gen (= $H $B)) (type-sub1 - (:: (= $H $B)) $Gen Nil)) -; - - (= - (type-sub $Gen $Spec) + (:: (= $H $B)) $Gen Nil)) + (= (type-sub $Gen $Spec) (type-sub $Gen $Spec (:: (with_self $Gen $Spec)))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: type_sub/3 ; -; - +; * ; -; - +; * syntax: type_sub(+Gen,+Spec,+Ancestors) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: ; -; - +; * Ancestors contains the types that have been compared already in order to ; -; - +; * avoid infinite recursion ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (type-sub all $_ $_) + (= (type-sub all $_ $_) + (set-det)) ; +; all is the most general type + (= (type-sub $T1 all $_) + (set-det) + (= $T1 all)) + (= (type-sub $T $T1 $_) + (== $T $T1) (set-det)) -; - ; -; - - (= - (type-sub $T1 all $_) - ( (set-det) (= $T1 all))) -; - - (= - (type-sub $T $T1 $_) - ( (== $T $T1) (set-det))) -; - - - (= - (type-sub symbolic $T $_) - ( (set-det) (or (= $T is-symbol) (or (= $T symbolic) (or (= $T number) (, (functor $HT $T 1) (setof (, $HT $B) (^ $ID (^ $CL (get-clause $ID $HT $B $CL type))) $TL) (all-t-in $TL (:: is-symbol number symbolic)))))))) -; - - (= - (type-sub is-symbol $T $_) - ( (set-det) (or (= $T is-symbol) (, (functor $HT $T 1) (setof (, $HT $B) (^ $ID (^ $CL (get-clause $ID $HT $B $CL type))) $TL) (all-t-in $TL (:: is-symbol)))))) -; - - (= - (type-sub number $T $_) - ( (set-det) (or (= $T number) (, (functor $HT $T 1) (setof (, $HT $B) (^ $ID (^ $CL (get-clause $ID $HT $B $CL type))) $TL) (all-t-in $TL (:: number)))))) -; - - - (= - (type-sub $T symbolic $_) - ( (set-det) (or (= $T symbolic) (or (= $T all) (, (functor $HT $T 1) (setof (, $HT $B) (^ $ID (^ $CL (get-clause $ID $HT $B $CL type))) $TL) (all-t-in $TL (:: symbolic))))))) -; - - (= - (type-sub $T is-symbol $_) - ( (set-det) (or (= $T is-symbol) (or (= $T symbolic) (or (= $T all) (, (functor $HT $T 1) (setof (, $HT $B) (^ $ID (^ $CL (get-clause $ID $HT $B $CL type))) $TL) (all-t-in $TL (:: is-symbol symbolic)))))))) -; - - (= - (type-sub $T number $_) - ( (set-det) (or (= $T number) (or (= $T symbolic) (or (= $T all) (, (functor $HT $T 1) (setof (, $HT $B) (^ $ID (^ $CL (get-clause $ID $HT $B $CL type))) $TL) (all-t-in $TL (:: number symbolic)))))))) -; - - - - (= - (type-sub $TG $TS $A) - ( (functor $HTS $TS 1) - (mysetof - (= $HTS $BS) - (^ $ID - (^ $CL - (get-clause $ID $HTS $BS $CL type))) $CS) - (type-sub1 $CS $TG $A))) -; + (= (type-sub symbolic $T $_) + (set-det) + (or + (= $T is-symbol) + (or + (= $T symbolic) + (or + (= $T number) + (, + (functor $HT $T 1) + (setof + (, $HT $B) + (^ $ID + (^ $CL + (get-clause $ID $HT $B $CL type))) $TL) + (all-t-in $TL + (:: is-symbol number symbolic))))))) + (= (type-sub is-symbol $T $_) + (set-det) + (or + (= $T is-symbol) + (, + (functor $HT $T 1) + (setof + (, $HT $B) + (^ $ID + (^ $CL + (get-clause $ID $HT $B $CL type))) $TL) + (all-t-in $TL + (:: is-symbol))))) + (= (type-sub number $T $_) + (set-det) + (or + (= $T number) + (, + (functor $HT $T 1) + (setof + (, $HT $B) + (^ $ID + (^ $CL + (get-clause $ID $HT $B $CL type))) $TL) + (all-t-in $TL + (:: number))))) + + (= (type-sub $T symbolic $_) + (set-det) + (or + (= $T symbolic) + (or + (= $T all) + (, + (functor $HT $T 1) + (setof + (, $HT $B) + (^ $ID + (^ $CL + (get-clause $ID $HT $B $CL type))) $TL) + (all-t-in $TL + (:: symbolic)))))) + (= (type-sub $T is-symbol $_) + (set-det) + (or + (= $T is-symbol) + (or + (= $T symbolic) + (or + (= $T all) + (, + (functor $HT $T 1) + (setof + (, $HT $B) + (^ $ID + (^ $CL + (get-clause $ID $HT $B $CL type))) $TL) + (all-t-in $TL + (:: is-symbol symbolic))))))) + (= (type-sub $T number $_) + (set-det) + (or + (= $T number) + (or + (= $T symbolic) + (or + (= $T all) + (, + (functor $HT $T 1) + (setof + (, $HT $B) + (^ $ID + (^ $CL + (get-clause $ID $HT $B $CL type))) $TL) + (all-t-in $TL + (:: number symbolic))))))) -; -; -; -; + (= (type-sub $TG $TS $A) + (functor $HTS $TS 1) + (mysetof + (= $HTS $BS) + (^ $ID + (^ $CL + (get-clause $ID $HTS $BS $CL type))) $CS) + (type-sub1 $CS $TG $A)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: type_sub1/3 ; -; - +; * ; -; - +; * syntax: type_sub1(+SpecClauses,+Gen,+Ancestors) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: ; -; - +; * for each clause C in SpecClauses defining the more specific type, ; -; - +; * there must be a clause defining Gen that is more general than C ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - - - - (= - (type_sub1 () $_ $_) True) -; +; * see also: +; +; * +; +; *********************************************************************** - (= - (type-sub1 - (Cons - (= $H $B) $R) - (= $HG $BG) $A) - ( (set-det) - (type-sub1 $R - (= $HG $BG) $A) - (set-det) - (=.. $H - (:: $_ $Es)) - (=.. $HG - (:: $_ $Es)) - (expand-to-type-def $BG $BG1) - (is-type-definition (= $H $B)) - (test-type-def $B) - (is-type-definition (= $HG $BG1)) - (test-type-def $BG1) - (only-vars $Es $EsV) - (type-sub2 $EsV $BG1 $B $A))) -; - - (= - (type-sub1 - (Cons - (= $H $B) $R) $TG $A) - ( (type-sub1 $R $TG $A) - (set-det) - (=.. $H - (:: $_ $Es)) - (=.. $HTG - (:: $TG $Es)) - (get-clause $_ $HTG $BG $_ type) - (expand-to-type-def $BG $BG1) - (is-type-definition (= $H $B)) - (test-type-def $B) - (is-type-definition (= $HTG $BG1)) - (test-type-def $BG1) - (only-vars $Es $EsV) - (type-sub2 $EsV $BG1 $B $A))) -; + (= (type_sub1 () $_ $_) True) + (= (type-sub1 (Cons (= $H $B) $R) (= $HG $BG) $A) + (set-det) + (type-sub1 $R + (= $HG $BG) $A) + (set-det) + (=.. $H + (:: $_ $Es)) + (=.. $HG + (:: $_ $Es)) + (expand-to-type-def $BG $BG1) + (is-type-definition (= $H $B)) + (test-type-def $B) + (is-type-definition (= $HG $BG1)) + (test-type-def $BG1) + (only-vars $Es $EsV) + (type-sub2 $EsV $BG1 $B $A)) + (= (type-sub1 (Cons (= $H $B) $R) $TG $A) + (type-sub1 $R $TG $A) + (set-det) + (=.. $H + (:: $_ $Es)) + (=.. $HTG + (:: $TG $Es)) + (get-clause $_ $HTG $BG $_ type) + (expand-to-type-def $BG $BG1) + (is-type-definition (= $H $B)) + (test-type-def $B) + (is-type-definition (= $HTG $BG1)) + (test-type-def $BG1) + (only-vars $Es $EsV) + (type-sub2 $EsV $BG1 $B $A)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: type_sub2/4 ; -; - +; * ; -; - +; * syntax: type_sub2(+Varlist,+Genbody,+Specbody,+Ancestors) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: ; -; - +; * tests for each variable V in Varlist whether the literal defining V in Genbody ; -; - +; * is of a more general type than the literal defining V in Specbody. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (type_sub2 () $_ $_ $_) True) -; - - (= - (type-sub2 - (Cons $X $R) $BG1 $B $A) - ( (type-sub2 $R $BG1 $B $A) - (set-det) - (def-literal $X $BG1 $LG) - (def-literal $X $B $LS) - (=.. $LS - (Cons $TS $_)) - (=.. $LG - (Cons $TG $_)) - (det-if-then-else - (member - (with_self $TG $TS) $A) True - (type-sub $TG $TS - (Cons - (with_self $TG $TS) $A))))) -; + (= (type_sub2 () $_ $_ $_) True) + (= (type-sub2 (Cons $X $R) $BG1 $B $A) + (type-sub2 $R $BG1 $B $A) + (set-det) + (def-literal $X $BG1 $LG) + (def-literal $X $B $LS) + (=.. $LS + (Cons $TS $_)) + (=.. $LG + (Cons $TG $_)) + (det-if-then-else + (member + (with_self $TG $TS) $A) True + (type-sub $TG $TS + (Cons + (with_self $TG $TS) $A)))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: expand_to_type_definition/2 ; -; - +; * ; -; - +; * syntax: expand_to_type_definition(+Body,-Body1) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: ; -; - +; * transform Body to a valid type definition (i.e. each literal is of the ; -; - +; * form t(X), were t in atom,atomic,number,typex and X is simple), by expanding ; -; - +; * literals containing complex terms ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (expand-to-type-def - (, $A $B) - (, $A $B1)) - ( (simple-td $A) (expand-to-type-def $B $B1))) -; - - (= - (expand-to-type-def - (, $A $B) $B1) - ( (not (simple-td $A)) - (get-clause $_ $A $Lits $_ type) - (append-body $Lits $B $B0) - (expand-to-type-def $B0 $B1))) -; - - (= - (expand-to-type-def $A $A) + (= (expand-to-type-def (, $A $B) (, $A $B1)) + (simple-td $A) + (expand-to-type-def $B $B1)) + (= (expand-to-type-def (, $A $B) $B1) + (not (simple-td $A)) + (get-clause $_ $A $Lits $_ type) + (append-body $Lits $B $B0) + (expand-to-type-def $B0 $B1)) + (= (expand-to-type-def $A $A) (simple-td $A)) -; - - (= - (expand-to-type-def $A $A1) - ( (not (= $A (, $_ $_))) - (not (simple-td $A)) - (get-clause $_ $A $Lits $_ type) - (expand-to-type-def $Lits $A1))) -; - + (= (expand-to-type-def $A $A1) + (not (= $A (, $_ $_))) + (not (simple-td $A)) + (get-clause $_ $A $Lits $_ type) + (expand-to-type-def $Lits $A1)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: simple_td/1 ; -; - +; * ; -; - +; * syntax: simple_td(+Lit) ; -; - +; * ; -; - +; * args: Lit is a literal within a type definition ; -; - +; * ; -; - +; * description: succeeds if Lit == true, or Lit = t(X), where X is atomic or ; -; - +; * a variable ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (simple-td True) + (= (simple-td True) (set-det)) -; - - (= - (simple-td $A) - ( (=.. $A - (:: $_ $X)) (simple $X))) -; - + (= (simple-td $A) + (=.. $A + (:: $_ $X)) + (simple $X)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: test_type_definition/1 ; -; - +; * ; -; - +; * syntax: test_type_definition(Body) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: partially evaluates Body. ; -; - +; * Fails if body contains invalid ground literals ; -; - +; * with predicate symbol atom, number or atomic ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (test-type-def (, $A $B)) - ( (set-det) - (test-type-def $A) - (test-type-def $B))) -; - - (= - (test-type-def $A) - ( (=.. $A - (:: $T $X)) - (ground $X) + (= (test-type-def (, $A $B)) + (set-det) + (test-type-def $A) + (test-type-def $B)) + (= (test-type-def $A) + (=.. $A + (:: $T $X)) + (ground $X) + (or + (= $T is-symbol) (or - (= $T is-symbol) - (or - (= $T symbolic) - (= $T number))) - (set-det) - (call $A))) -; - - (= - (test_type_def $_) True) -; - + (= $T symbolic) + (= $T number))) + (set-det) + (call $A)) + (= (test_type_def $_) True) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: is_type_definition/1 ; -; - +; * ; -; - +; * syntax: is_type_definition(+Clause) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: ; -; - +; * succeeds if Clause is a syntactically correct type definition, i.e. only ; -; - +; * atom, atomic, number and typex occur as unary predicate in the body, and ; -; - +; * every variable of Clause occurs once in the head and once in the body of Clause ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (is-type-definition (= $H $B)) - ( (only-vars $H $Vars) (is-type-def $Vars $B))) -; + (= (is-type-definition (= $H $B)) + (only-vars $H $Vars) + (is-type-def $Vars $B)) + (= (is_type_def () $_) True) + (= (is-type-def (Cons $X $R) $B) + (def-literal $X $B $Lit) + (set-det) + (=.. $Lit + (:: $_ $X1)) + (== $X $X1) + (is-type-def $R $B)) - (= - (is_type_def () $_) True) -; - - (= - (is-type-def - (Cons $X $R) $B) - ( (def-literal $X $B $Lit) - (set-det) - (=.. $Lit - (:: $_ $X1)) - (== $X $X1) - (is-type-def $R $B))) -; - - - - (= - (all_t_in () $_) True) -; - - (= - (all-t-in - (Cons - (, $H $B) $R) $L) - ( (=.. $H - (:: $_ $X)) - (var $X) - (=.. $B - (:: $N $X)) - (member $N $L) - (all-t-in $R $L))) -; + (= (all_t_in () $_) True) + (= (all-t-in (Cons (, $H $B) $R) $L) + (=.. $H + (:: $_ $X)) + (var $X) + (=.. $B + (:: $N $X)) + (member $N $L) + (all-t-in $R $L)) ; -; - +; ********************************************************************************** ; -; - +; * ; -; - +; * predicate: type_of/3 ; -; - +; * ; -; - +; * syntax: type_of(+Var,+C,-Type) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: C is a clause or a literal. Returns the most specific type of Var ; -; - +; * within C. If Var does not occur in C or if it occurs at ; -; - +; * positions with incompatible types, type_of returns fail. If Var ; -; - +; * is a term that only partially matches the body of a type ; -; - +; * definition, a intermediate type definition t_int(Var):- B is ; -; - +; * returned ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * pecularities: ; -; - +; * ; -; +; ********************************************************************************** - - (= - (type-of $V - (= $H $B) $Type) - ( (set-det) - (type-of $V $H $Type1) - (type-of $V $B $Type2) - (compare-types $Type1 $Type2 $Type))) -; - - (= - (type-of $V - (, $A $B) $Type) - ( (set-det) - (type-of $V $A $Type1) - (type-of $V $B $Type2) - (compare-types $Type1 $Type2 $Type))) -; - - (= - (type-of $T $Pred $Type) + (= (type-of $V (= $H $B) $Type) + (set-det) + (type-of $V $H $Type1) + (type-of $V $B $Type2) + (compare-types $Type1 $Type2 $Type)) + (= (type-of $V (, $A $B) $Type) + (set-det) + (type-of $V $A $Type1) + (type-of $V $B $Type2) + (compare-types $Type1 $Type2 $Type)) + (= (type-of $T $Pred $Type) (det-if-then-else (type-restriction $Pred $Plist) (, @@ -2619,617 +1853,462 @@ (contains-var $T $Ts)) $TsL) (type-of1 $TsL $T $Type)) (= $Type all))) -; - - (= - (type_of $_ true all) True) -; - - + (= (type_of $_ true all) True) - (= - (type_of1 () $_ all) True) -; - - (= - (type-of1 - (Cons $Ts $R) $T $Type) - ( (set-det) - (type-of1 $R $T $Type1) - (=.. $Ts - (:: $Type0 $T2)) - (det-if-then-else - (== $T2 $T) - (compare-types $Type1 $Type0 $Type) - (, - (get-clause $_ $Ts $_ - (Cons $_ $CL) type) - (mysetof $Ts1 - (, - (member - (with_self $Ts1 $_) $CL) - (contains-var $T $Ts1)) $TsL) - (det-if-then-else - (= $TsL Nil) - (, - (mysetof $Ts2 - (, - (member $Ts2 $CL) - (shares-var $T $Ts2)) $TsL1) - (=.. $H_int - (:: t-int $T)) - (with_self - (kb *) - (body2list $B_int $TsL1)) - (compare-types $Type1 - (= $H_int $B_int) $Type)) - (, - (type-of1 $TsL $T $Type2) - (compare-types $Type1 $Type2 $Type))))))) -; + (= (type_of1 () $_ all) True) + (= (type-of1 (Cons $Ts $R) $T $Type) + (set-det) + (type-of1 $R $T $Type1) + (=.. $Ts + (:: $Type0 $T2)) + (det-if-then-else + (== $T2 $T) + (compare-types $Type1 $Type0 $Type) + (, + (get-clause $_ $Ts $_ + (Cons $_ $CL) type) + (mysetof $Ts1 + (, + (member + (with_self $Ts1 $_) $CL) + (contains-var $T $Ts1)) $TsL) + (det-if-then-else + (= $TsL Nil) + (, + (mysetof $Ts2 + (, + (member $Ts2 $CL) + (shares-var $T $Ts2)) $TsL1) + (=.. $H_int + (:: t-int $T)) + (with_self + (kb *) + (body2list $B_int $TsL1)) + (compare-types $Type1 + (= $H_int $B_int) $Type)) + (, + (type-of1 $TsL $T $Type2) + (compare-types $Type1 $Type2 $Type)))))) ; -; - +; ********************************************************************************** ; -; - +; * ; -; - +; * predicate: types_of/3 ; -; - +; * ; -; - +; * syntax: types_of(+Varlist,+C,-Typelist) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: like type_of for each Var in Varlist. ; -; - +; * Varlist = [V1,..,Vn] => Typelist = [V1:T1,..,Vn:Tn] ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - - - - (= - (types_of () $_ ()) True) -; +; ********************************************************************************** - (= - (types-of - (Cons $V $R) $C - (Cons - (with_self $V $T) $R1)) - ( (type-of $V $C $T) (types-of $R $C $R1))) -; + (= (types_of () $_ ()) True) + (= (types-of (Cons $V $R) $C (Cons (with_self $V $T) $R1)) + (type-of $V $C $T) + (types-of $R $C $R1)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: compare_types/3 ; -; - +; * ; -; - +; * syntax: compare_types(+Type1,+Type2,-Type) ; -; - +; * ; -; - +; * args: Type1,Type2: types to be compared ; -; - +; * Type: the most specific type among type1 and typ2 ; -; - +; * ; -; - +; * description: returns the more specific type ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (compare-types $Type1 $Type2 $Type) + (= (compare-types $Type1 $Type2 $Type) (det-if-then-else (type-sub $Type1 $Type2) (= $Type $Type2) (det-if-then-else (type-sub $Type2 $Type1) (= $Type $Type1) fail))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: define_type/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: allows to define a type restriction for a predicate ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** + (= (define-type) + (show-kb-types) + (read-type-restriction)) - (= - (define-type) - ( (show-kb-types) (read-type-restriction))) -; - - - (= - (read-type-restriction) - ( (repeat) - (nl) - (write 'Please enter name and arity of the predicate p/n: ') - (det-if-then-else - (, - (read (/ $P $N)) - (atom $P) - (integer $N)) - (, - (functor $F $P $N) - (=.. $F - (Cons $P $Args)) - (read-type-restriction $Args 1 $Alist) - (add-symbol &self - (type_restriction $F $Alist))) fail))) -; - - - (= - (read_type_restriction () $_ ()) True) -; - - (= - (read-type-restriction - (Cons $V $R) $N - (Cons $T $R1)) - ( (repeat) - (nl) - (write 'Please enter the type at argument position ') - (write $N) - (write : ) + (= (read-type-restriction) + (repeat) + (nl) + (write 'Please enter name and arity of the predicate p/n: ') + (det-if-then-else + (, + (read (/ $P $N)) + (atom $P) + (integer $N)) + (, + (functor $F $P $N) + (=.. $F + (Cons $P $Args)) + (read-type-restriction $Args 1 $Alist) + (add-is-symbol &self + (type_restriction $F $Alist))) fail)) + + (= (read_type_restriction () $_ ()) True) + (= (read-type-restriction (Cons $V $R) $N (Cons $T $R1)) + (repeat) + (nl) + (write 'Please enter the type at argument position ') + (write $N) + (write : ) + (det-if-then-else + (, + (read $TN) + (atom $TN)) (det-if-then-else + (or + (, + (=.. $H + (:: $TN $_)) + (get-clause $_ $H $_ $_ type)) + (member $TN + (:: is-symbol number symbolic))) + (=.. $T + (:: $TN $V)) (, - (read $TN) - (atom $TN)) - (det-if-then-else - (or - (, - (=.. $H - (:: $TN $_)) - (get-clause $_ $H $_ $_ type)) - (member $TN - (:: is-symbol number symbolic))) + (read-type-definition $TN) (=.. $T - (:: $TN $V)) - (, - (read-type-definition $TN) - (=.. $T - (:: $TN $V)))) fail) - (is $N1 - (+ $N 1)) - (read-type-restriction $R $N1 $R1))) -; - + (:: $TN $V)))) fail) + (is $N1 + (+ $N 1)) + (read-type-restriction $R $N1 $R1)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: read_type_definition/1 ; -; - +; * ; -; - +; * syntax: read_type_definition(+TN) ; -; - +; * ; -; - +; * args: TN.. name of a type ; -; - +; * ; -; - +; * description: allows to enter clauses defining the type TN ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (read-type-definition $TN) - ( (nl) - (write 'Type ') - (write $TN) - (write ' is undefined. Enter a definition (y/n)? ') - (read $A) - (det-if-then-else - (== $A y) - (read-type-def $TN) - (det-if-then-else - (== $A n) fail - (, - (nl) - (write 'Please enter y or n') - (read-type-definition $TN)))))) -; - - - - (= - (read-type-def $TN) - ( (nl) - (write 'Please enter the definition of ') - (write $TN) - (write ' in clausal form. Stop by entering stop.') - (nl) - (repeat) - (read $A) + (= (read-type-definition $TN) + (nl) + (write 'Type ') + (write $TN) + (write ' is undefined. Enter a definition (y/n)? ') + (read $A) + (det-if-then-else + (== $A y) + (read-type-def $TN) (det-if-then-else - (or - (, - (= $A - (= $H $_)) - (=.. $H - (:: $_ $_))) - (=.. $A + (== $A n) fail + (, + (nl) + (write 'Please enter y or n') + (read-type-definition $TN))))) + + + (= (read-type-def $TN) + (nl) + (write 'Please enter the definition of ') + (write $TN) + (write ' in clausal form. Stop by entering stop.') + (nl) + (repeat) + (read $A) + (det-if-then-else + (or + (, + (= $A + (= $H $_)) + (=.. $H (:: $_ $_))) + (=.. $A + (:: $_ $_))) + (, + (store-clause $A $_ type $_) + (nl) + (fail)) + (det-if-then-else + (== $A stop) True (, - (store-clause $A $_ type $_) (nl) - (fail)) - (det-if-then-else - (== $A stop) True - (, - (nl) - (write 'Please enter a clause or stop') - (fail)))))) -; - + (write 'Please enter a clause or stop') + (fail))))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: verify_types/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: checks for the type restrictions in the kb whether ; -; - +; * the contain only defined or built-in types. If not, ; -; - +; * the user is asked for replacing or defining the unknown ; -; - +; * types. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (verify-types) - ( (findall - (, $M $A) - (type-restriction $M $A) $TSet) (verify-types $TSet))) -; + (= (verify-types) + (findall + (, $M $A) + (type-restriction $M $A) $TSet) + (verify-types $TSet)) - (= - (verify_types ()) True) -; + (= (verify_types ()) True) + (= (verify-types (Cons (, $M $A) $R)) + (verify-types $R) + (verify-types $A $M $A)) - (= - (verify-types (Cons (, $M $A) $R)) - ( (verify-types $R) (verify-types $A $M $A))) -; - - - (= - (verify_types () $_ $_) True) -; - - (= - (verify-types - (Cons $H $R) $M $A) - ( (verify-types $R $M $A) - (=.. $H - (Cons $T $_)) - (findall - (, $H1 $B1) - (, - (=.. $H1 - (:: $T $_)) - (known $ID $H1 $B1 $CL $_ $E) - (delete-clause $ID) - (add-symbol &self - (: kb - (known $ID $H1 $B1 $CL type $E)))) $Tlist) - (det-if-then-else - (or - (\== $Tlist Nil) - (member $T - (:: is-symbol number symbolic))) True - (, - (nl) - (write 'The type ') - (write $T) - (write ' is undefined in ') - (copy-term - (, $M $A) - (, $M1 $A1)) - (numbervars - (, $M1 $A1) 0 $_) - (write (type-restriction $M1 $A1)) - (nl) - (show-kb-types) - (repeat) - (nl) - (write 'Do you want to replace ') - (write $T) - (write ' in ') - (write (type-restriction $M1 $A1)) - (write ' (y/n)?') - (nl) - (read $An) + (= (verify_types () $_ $_) True) + (= (verify-types (Cons $H $R) $M $A) + (verify-types $R $M $A) + (=.. $H + (Cons $T $_)) + (findall + (, $H1 $B1) + (, + (=.. $H1 + (:: $T $_)) + (known $ID $H1 $B1 $CL $_ $E) + (delete-clause $ID) + (add-is-symbol &self + (: kb + (known $ID $H1 $B1 $CL type $E)))) $Tlist) + (det-if-then-else + (or + (\== $Tlist Nil) + (member $T + (:: is-symbol number symbolic))) True + (, + (nl) + (write 'The type ') + (write $T) + (write ' is undefined in ') + (copy-term + (, $M $A) + (, $M1 $A1)) + (numbervars + (, $M1 $A1) 0 $_) + (write (type-restriction $M1 $A1)) + (nl) + (show-kb-types) + (repeat) + (nl) + (write 'Do you want to replace ') + (write $T) + (write ' in ') + (write (type-restriction $M1 $A1)) + (write ' (y/n)?') + (nl) + (read $An) + (det-if-then-else + (== $An y) + (, + (remove-is-symbol &self + (type_restriction $M $A)) + (repeat) + (nl) + (write 'Enter the name of the type replacing ') + (write $T) + (write : ) + (det-if-then-else + (, + (read $T1) + (atom $T1)) + (, + (=.. $H1 + (:: $T1 $_)) + (det-if-then-else + (get-clause $_ $H1 $_ $_ $_) + (, + (vrt $A $T $T1 $A2) + (add-is-symbol &self + (type_restriction $M $A2))) + (, + (nl) + (write 'The type ') + (write $T1) + (write ' is undefined.') + (vrt1 $T1)))) fail)) (det-if-then-else - (== $An y) + (== $An n) (, - (remove-symbol &self - (type_restriction $M $A)) - (repeat) (nl) - (write 'Enter the name of the type replacing ') + (write 'Then you have to define ') (write $T) - (write : ) - (det-if-then-else - (, - (read $T1) - (atom $T1)) - (, - (=.. $H1 - (:: $T1 $_)) - (det-if-then-else - (get-clause $_ $H1 $_ $_ $_) - (, - (vrt $A $T $T1 $A2) - (add-symbol &self - (type_restriction $M $A2))) - (, - (nl) - (write 'The type ') - (write $T1) - (write ' is undefined.') - (vrt1 $T1)))) fail)) - (det-if-then-else - (== $An n) - (, - (nl) - (write 'Then you have to define ') - (write $T) - (read-type-def $T)) - (, - (write 'Please enter y or n') - (fail)))))))) -; - - - - (= - (vrt () $_ $_ ()) True) -; + (read-type-def $T)) + (, + (write 'Please enter y or n') + (fail))))))) - (= - (vrt - (Cons $H $R) $T $T1 - (Cons $H1 $R1)) - ( (vrt $R $T $T1 $R1) - (=.. $H - (:: $T2 $V)) - (det-if-then-else - (== $T2 $T) - (=.. $H1 - (:: $T1 $V)) - (= $H1 $H)))) -; + (= (vrt () $_ $_ ()) True) + (= (vrt (Cons $H $R) $T $T1 (Cons $H1 $R1)) + (vrt $R $T $T1 $R1) + (=.. $H + (:: $T2 $V)) + (det-if-then-else + (== $T2 $T) + (=.. $H1 + (:: $T1 $V)) + (= $H1 $H))) - (= - (vrt1 $T1) - ( (nl) - (write 'Do you want to define it (y/n)? ') - (read $Bn) + (= (vrt1 $T1) + (nl) + (write 'Do you want to define it (y/n)? ') + (read $Bn) + (det-if-then-else + (== $Bn y) + (read-type-def $T1) (det-if-then-else - (== $Bn y) - (read-type-def $T1) - (det-if-then-else - (== $Bn n) fail - (, - (write 'Please enter y or n') - (vrt1 $T1)))))) -; - + (== $Bn n) fail + (, + (write 'Please enter y or n') + (vrt1 $T1))))) diff --git a/miles/bu_basics.metta b/miles/bu_basics.metta index bf489b5..b6630b4 100644 --- a/miles/bu_basics.metta +++ b/miles/bu_basics.metta @@ -1,6 +1,6 @@ +; (convert_to_metta_file bu_basics $_475122 miles/bu_basics.pl miles/bu_basics.metta) ; -; - +; MODULE bu_basics EXPORTS !(module bu-basics (:: @@ -35,2190 +35,1391 @@ (/ assert-literals 1) (/ clear-mngr 0) (/ reset-counts 0))) -; - ; -; - +; IMPORTS !(use-module (home div-utils) (:: (/ contains-duplicates 1))) -; - !(use-module-if-exists (library basics) (:: (/ member 2))) -; - !(use-module-if-exists (library random) (:: (/ maybe 0))) -; - ; -; - +; METAPREDICATES ; -; - - - !(dynamic (/ head 3)) -; - ; -; - - !(dynamic (/ body 3)) -; - ; -; +; none + !(dynamic (/ head 3)) ; +; head( Literal, {old,new}, Counter) + !(dynamic (/ body 3)) ; +; body( Literal, {old,new}, Counter) ; -; - +; the second argument is used to check whether ; -; - +; saturation/idev resulted in a new literal at all. ; -; - +; the third argument is 0 for new literals that ; -; - +; resulted from sat/idev, and \= 0 for literals that ; -; - +; have been used for sat/idev !(dynamic (/ assumption 3)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: bu_utils.pl ; -; - +; * ; -; - +; * author: B.Jung, M.Mueller, I.Stahl, B.Tausend date:12/92 ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * description: utilities for bottom-up operators ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: process_new_literals/2 ; -; - +; * ; -; - +; * syntax: process_new_literals(+[H:Proof|_],-Flag) ; -; - +; * ; -; - +; * args: H = Lit/M where M is in {new_head,new_body}, or H = [] ; -; - +; * Proof = [[Lit,N],..,[],...] where N in {head,body} ; -; - +; * ; -; - +; * description: asserts all new heads and bodies of matched clauses ; -; - +; * via head/3 and body/3 ; -; - +; * Flag = 1 if at least one existed ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (process_new_literals () $_) True) -; + (= (process_new_literals () $_) True) - - (= - (process-new-literals - (Cons - (with_self Nil $Proof) $Rest) $Flag) + (= (process-new-literals (Cons (with_self Nil $Proof) $Rest) $Flag) (process-new-literals $Rest $Flag)) -; - - - (= - (process-new-literals - (Cons - (with_self - (/ $L new-body) $Proof) $Rest) $Flag) - ( (body $L $_ $_) - (set-det) - (process-new-literals $Rest $Flag))) -; - - - (= - (process-new-literals - (Cons - (with_self - (/ $L new-head) $Proof) $Rest) $Flag) - ( (head $L $_ $_) - (set-det) - (process-new-literals $Rest $Flag))) -; + (= (process-new-literals (Cons (with_self (/ $L new-body) $Proof) $Rest) $Flag) + (body $L $_ $_) + (set-det) + (process-new-literals $Rest $Flag)) - (= - (process-new-literals - (Cons - (with_self - (/ $L $_) $Proof) $Rest) $Flag) - ( (contains-duplicates $Proof) - (set-det) - (process-new-literals $Rest $Flag))) -; + (= (process-new-literals (Cons (with_self (/ $L new-head) $Proof) $Rest) $Flag) + (head $L $_ $_) + (set-det) + (process-new-literals $Rest $Flag)) + (= (process-new-literals (Cons (with_self (/ $L $_) $Proof) $Rest) $Flag) + (contains-duplicates $Proof) + (set-det) + (process-new-literals $Rest $Flag)) +; ;;eigentlich ein Filter: jedem Literal +; ;;im Parent entspricht eines in der Resolvente - (= - (process-new-literals - (Cons - (with_self - (/ $L new-head) $Proof) $Rest) 1) + (= (process-new-literals (Cons (with_self (/ $L new-head) $Proof) $Rest) 1) ( (set-det) - (add-symbol &self + (add-is-symbol &self (head $L new 0)) (annotate $Proof) (process-new-literals $Rest $_))) -; - - (= - (process-new-literals - (Cons - (with_self - (/ $L new-body) $Proof) $Rest) 1) - ( (add-symbol &self + (= (process-new-literals (Cons (with_self (/ $L new-body) $Proof) $Rest) 1) + ( (add-is-symbol &self (body $L new 0)) (annotate $Proof) (process-new-literals $Rest $_))) -; - ; -; - - (= - (process-new-literals - (Cons - (with_self - (/ $L new-body) $Proof) $Rest) $Flag) - ( (remove-symbol &self +; for backtracking + (= (process-new-literals (Cons (with_self (/ $L new-body) $Proof) $Rest) $Flag) + ( (remove-is-symbol &self (body $L new 0)) (process-new-literals $Rest $Flag))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: annotate/1 ; -; - +; * ; -; - +; * syntax: annotate(+Proofs) ; -; - +; * ; -; - +; * args: Proofs = [L1,..,Ln] where Li = [] or Li = [Lit,N] and N in {head,body} ; -; - +; * ; -; - +; * description: increments counter for each head/body literal in Proofs ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (annotate ()) True) -; + (= (annotate ()) True) - - (= - (annotate (Cons (:: $L body) $Rest)) - ( (remove-symbol &self + (= (annotate (Cons (:: $L body) $Rest)) + ( (remove-is-symbol &self (body $L $OldNew $I)) (is $J (+ $I 1)) - (add-symbol &self + (add-is-symbol &self (body $L $OldNew $J)) (annotate $Rest))) -; - - (= - (annotate (Cons (:: $L head) $Rest)) - ( (remove-symbol &self + (= (annotate (Cons (:: $L head) $Rest)) + ( (remove-is-symbol &self (head $L $OldNew $I)) (is $J (+ $I 1)) - (add-symbol &self + (add-is-symbol &self (head $L $OldNew $J)) (annotate $Rest))) -; - - (= - (annotate (Cons Nil $Rest)) + (= (annotate (Cons Nil $Rest)) (annotate $Rest)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: abs_process_proofs/2 ; -; - +; * ; -; - +; * syntax: abs_process_proofs(+Proofs,-Head) ; -; - +; * ; -; - +; * args: Proofs = [CL1,..,CLn] where CLi is a clause in list notation ; -; - +; * Head: a head literal ; -; - +; * ; -; - +; * description: returns a head literal from one of the CLi, and retracts ; -; - +; * the according body literals body(L,_,_) of CLi (destructive ; -; - +; * absorption) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** + (= (abs-process-proofs (Cons (Cons (with_self $Head (p)) $_) $MoreHeads) $NewHead) + (body $Head $_ $_) + (set-det) + (abs-process-proofs $MoreHeads $NewHead)) - (= - (abs-process-proofs - (Cons - (Cons - (with_self $Head - (p)) $_) $MoreHeads) $NewHead) - ( (body $Head $_ $_) - (set-det) - (abs-process-proofs $MoreHeads $NewHead))) -; + (= (abs-process-proofs (Cons (Cons $_ $Proof) $MoreHeads) $NewHead) + (contains-duplicates $Proof) + (set-det) + (abs-process-proofs $MoreHeads $NewHead)) +; ;;eigentlich ein Filter: jedem Literal +; ;;im Parent entspricht eines in der Resolvente - - (= - (abs-process-proofs - (Cons - (Cons $_ $Proof) $MoreHeads) $NewHead) - ( (contains-duplicates $Proof) - (set-det) - (abs-process-proofs $MoreHeads $NewHead))) -; - - - (= - (abs-process-proofs - (Cons - (Cons - (with_self $Head - (p)) $Proof) $MoreHeads) $Head) + (= (abs-process-proofs (Cons (Cons (with_self $Head (p)) $Proof) $MoreHeads) $Head) (retract-body-literals $Proof)) -; - ; -; - - (= - (abs-process-proofs - (Cons - (Cons - (with_self $Head - (p)) $Proof) $MoreHeads) $NewHead) - ( (assert-body $Proof) (abs-process-proofs $MoreHeads $NewHead))) -; - +; For Backtracking + (= (abs-process-proofs (Cons (Cons (with_self $Head (p)) $Proof) $MoreHeads) $NewHead) + (assert-body $Proof) + (abs-process-proofs $MoreHeads $NewHead)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: ident_process_proofs/2 ; -; - +; * ; -; - +; * syntax: ident_process_proofs(+[[H:Proof]|_],-Head) ; -; - +; * ; -; - +; * args: H = = Lit/M where M is in {new_head,new_body}, or H = [] ; -; - +; * Proof = [[Lit,N],..,[],...] where N in {head,body} ; -; - +; * Head: a literal ; -; - +; * ; -; - +; * description: returns a head literal from one of the H:Proof, and retracts ; -; - +; * the according literals from Proof from the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (ident-process-proofs - (Cons - (:: (with_self (/ $Head new-head) $_)) $MoreHeads) $NewHead) - ( (head $Head $_ $_) - (set-det) - (ident-process-proofs $MoreHeads $NewHead))) -; +; *********************************************************************** - (= - (ident-process-proofs - (Cons - (:: (with_self (/ $_ $_) $Proof)) $MoreHeads) $NewHead) - ( (contains-duplicates $Proof) - (set-det) - (ident-process-proofs $MoreHeads $NewHead))) -; + (= (ident-process-proofs (Cons (:: (with_self (/ $Head new-head) $_)) $MoreHeads) $NewHead) + (head $Head $_ $_) + (set-det) + (ident-process-proofs $MoreHeads $NewHead)) +; ; + (= (ident-process-proofs (Cons (:: (with_self (/ $_ $_) $Proof)) $MoreHeads) $NewHead) + (contains-duplicates $Proof) + (set-det) + (ident-process-proofs $MoreHeads $NewHead)) +; ;;eigentlich ein Filter: jedem Literal +; ;;im Parent entspricht eines in der Resolvente - (= - (ident-process-proofs - (Cons - (:: (with_self (/ $Head new-head) $Proof)) $MoreHeads) $Head) + (= (ident-process-proofs (Cons (:: (with_self (/ $Head new-head) $Proof)) $MoreHeads) $Head) (retract-literals $Proof)) -; - ; -; - - (= - (ident-process-proofs - (Cons - (:: (with_self (/ $Head new-head) $Proof)) $MoreHeads) $NewHead) - ( (assert-literals $Proof) (ident-process-proofs $MoreHeads $NewHead))) -; - +; for backtracking + (= (ident-process-proofs (Cons (:: (with_self (/ $Head new-head) $Proof)) $MoreHeads) $NewHead) + (assert-literals $Proof) + (ident-process-proofs $MoreHeads $NewHead)) +; ; write('new kb'),nl,subsume_mngr:show_heads,subsume_mngr:show_bodies,nl, ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: g1_process_proofs/2 ; -; - +; * ; -; - +; * syntax: g1_process_proofs(+[[H:Proof]|_],-Lit) ; -; - +; * ; -; - +; * args: H = = Lit/M where M is in {new_head,new_body}, or H = [] ; -; - +; * Proof = [[Lit,N],..,[],...] where N in {head,body} ; -; - +; * Lit: a literal and its sign ; -; - +; * ; -; - +; * description: returns the resolution literal from one of the H:Proof, and retracts ; -; - +; * the according literals from Proof from the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (g1-process-proofs - (Cons - (with_self Nil $_) $R) $Lit) + (= (g1-process-proofs (Cons (with_self Nil $_) $R) $Lit) (g1-process-proofs $R $Lit)) -; - - - (= - (g1-process-proofs - (Cons - (with_self - (/ $Head new-head) $_) $MoreHeads) $Lit) - ( (head $Head $_ $_) - (set-det) - (g1-process-proofs $MoreHeads $Lit))) -; - - - - (= - (g1-process-proofs - (Cons - (with_self - (/ $Body new-body) $_) $MoreHeads) $Lit) - ( (body $Body $_ $_) - (set-det) - (g1-process-proofs $MoreHeads $Lit))) -; - - - (= - (g1-process-proofs - (Cons - (with_self - (/ $_ $_) $Proof) $MoreHeads) $Lit) - ( (contains-duplicates $Proof) - (set-det) - (g1-process-proofs $MoreHeads $Lit))) -; - - - (= - (g1-process-proofs - (Cons - (with_self - (/ $Lit $S0) $Proof) $MoreHeads) - (with_self $Lit $S)) - ( (det-if-then-else - (= $S0 new-head) - (= $S p) - (= $S n)) (retract-literals $Proof))) -; + (= (g1-process-proofs (Cons (with_self (/ $Head new-head) $_) $MoreHeads) $Lit) + (head $Head $_ $_) + (set-det) + (g1-process-proofs $MoreHeads $Lit)) + + + (= (g1-process-proofs (Cons (with_self (/ $Body new-body) $_) $MoreHeads) $Lit) + (body $Body $_ $_) + (set-det) + (g1-process-proofs $MoreHeads $Lit)) + + (= (g1-process-proofs (Cons (with_self (/ $_ $_) $Proof) $MoreHeads) $Lit) + (contains-duplicates $Proof) + (set-det) + (g1-process-proofs $MoreHeads $Lit)) +; ;;eigentlich ein Filter: jedem Literal +; ;;im Parent entspricht eines in der Resolvente + + (= (g1-process-proofs (Cons (with_self (/ $Lit $S0) $Proof) $MoreHeads) (with_self $Lit $S)) + (det-if-then-else + (= $S0 new-head) + (= $S p) + (= $S n)) + (retract-literals $Proof)) ; -; - - (= - (g1-process-proofs - (Cons - (with_self - (/ $_ $_) $Proof) $MoreHeads) $Lit) - ( (assert-literals $Proof) (g1-process-proofs $MoreHeads $Lit))) -; - +; for backtracking + (= (g1-process-proofs (Cons (with_self (/ $_ $_) $Proof) $MoreHeads) $Lit) + (assert-literals $Proof) + (g1-process-proofs $MoreHeads $Lit)) +; ; write('new kb'),nl,subsume_mngr:show_heads,subsume_mngr:show_bodies,nl, ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: assert_absorptions/2 ; -; - +; * ; -; - +; * syntax: assert_assorptions(+[CL|_],-Flag) ; -; - +; * ; -; - +; * args: CL: clause in list notation ; -; - +; * ; -; - +; * description: asserts heads H of all absorbed clauses, if new, as ; -; - +; * body(H,_,_). Flag=1 if at least one existed ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - +; *********************************************************************** - (= - (assert_absorptions () $F) True) -; - (= - (assert-absorptions - (Cons - (Cons - (with_self $Head - (p)) $_) $MoreHeads) $F) - ( (body $Head $OldNew $Count) - (set-det) - (assert-absorptions $MoreHeads $F))) -; + (= (assert_absorptions () $F) True) + (= (assert-absorptions (Cons (Cons (with_self $Head (p)) $_) $MoreHeads) $F) + (body $Head $OldNew $Count) + (set-det) + (assert-absorptions $MoreHeads $F)) - (= - (assert-absorptions - (Cons - (Cons - (with_self $Head - (p)) $Proof) $MoreHeads) 1) - ( (add-symbol &self + (= (assert-absorptions (Cons (Cons (with_self $Head (p)) $Proof) $MoreHeads) 1) + ( (add-is-symbol &self (body $Head new 0)) (annotate-redundancy $Proof) (assert-absorptions $MoreHeads 1))) -; - ; -; - - (= - (assert-absorptions - (Cons - (Cons - (with_self $Head - (p)) $Proof) $MoreHeads) $_) - (remove-symbol &self +; For Backtracking + (= (assert-absorptions (Cons (Cons (with_self $Head (p)) $Proof) $MoreHeads) $_) + (remove-is-symbol &self (body $Head new 0))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: annotate_redundancy/1 ; -; - +; * ; -; - +; * syntax: annotate_redundancy(+Proof) ; -; - +; * ; -; - +; * args: Proof: clause in list notation ; -; - +; * ; -; - +; * description: increments counter for each body literal in Proof ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (annotate_redundancy ()) True) -; - - (= - (annotate-redundancy (Cons (with_self $L $_) $More)) - ( (remove-symbol &self + (= (annotate_redundancy ()) True) + (= (annotate-redundancy (Cons (with_self $L $_) $More)) + ( (remove-is-symbol &self (body $L $OldNew $I)) (is $J (+ $I 1)) - (add-symbol &self + (add-is-symbol &self (body $L $OldNew $J)) (annotate-redundancy $More))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: assert_body_randomly/1 ; -; - +; * ; -; - +; * syntax: assert_body_randomly(+Clause_list) ; -; - +; * ; -; - +; * args: +Clause_list ... Clause in list notation ; -; - +; * ; -; - +; * description: assert body literals in random order ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (assert-body-randomly Nil) + (= (assert-body-randomly Nil) (set-det)) -; - - - (= - (assert-body-randomly (Cons (with_self $H (p)) $More)) - ( (head $H $_ $_) - (set-det) - (assert-body-randomly $More))) -; + (= (assert-body-randomly (Cons (with_self $H (p)) $More)) + (head $H $_ $_) + (set-det) + (assert-body-randomly $More)) - (= - (assert-body-randomly (Cons (with_self $H (p)) $More)) - ( (add-symbol &self + (= (assert-body-randomly (Cons (with_self $H (p)) $More)) + ( (add-is-symbol &self (head $H $_ $_)) (assert-body-randomly $More))) -; + (= (assert-body-randomly (Cons (with_self $L $_) $More)) + (body $L $_ $_) + (set-det) + (assert-body-randomly $More)) - (= - (assert-body-randomly (Cons (with_self $L $_) $More)) - ( (body $L $_ $_) - (set-det) - (assert-body-randomly $More))) -; - - - (= - (assert-body-randomly (Cons (with_self $L $_) $More)) + (= (assert-body-randomly (Cons (with_self $L $_) $More)) ( (maybe) - (add-symbol &self + (add-is-symbol &self (body $L old 0)) (assert-body-randomly $More))) -; - - (= - (assert-body-randomly (Cons (with_self $L $_) $More)) - ( (add-symbol &self + (= (assert-body-randomly (Cons (with_self $L $_) $More)) + ( (add-is-symbol &self (body $L old 0)) (assert-body-randomly $More))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: addtolist/1 ; -; - +; * ; -; - +; * syntax: addtolist(+ToAdd) ; -; - +; * ; -; - +; * args: ToAdd .. Id or list of Id's ; -; - +; * ; -; - +; * description: asserts list of Id's ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (addtolist (Cons $L $IST)) - ( (remove-symbol &self + (= (addtolist (Cons $L $IST)) + ( (remove-is-symbol &self (id_list $List1)) (append $List1 (Cons $L $IST) $List2) - (add-symbol &self + (add-is-symbol &self (id_list $List2)) (set-det))) -; - - (= - (addtolist $Id) - ( (remove-symbol &self + (= (addtolist $Id) + ( (remove-is-symbol &self (id_list $List1)) - (add-symbol &self + (add-is-symbol &self (id_list (Cons $Id $List1))) (set-det))) -; - - (= - (addtolist (Cons $L $IST)) - ( (add-symbol &self + (= (addtolist (Cons $L $IST)) + ( (add-is-symbol &self (id_list (Cons $L $IST))) (set-det))) -; - - (= - (addtolist $Id) - ( (add-symbol &self + (= (addtolist $Id) + ( (add-is-symbol &self (id_list ($Id))) (set-det))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: getlist/1 ; -; - +; * ; -; - +; * syntax: getlist(-ID_list) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: retracts the list of id's that has been asserted by ; -; - +; * addtolist/1 ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (getlist $List) - (remove-symbol &self + (= (getlist $List) + (remove-is-symbol &self (id_list $List))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: cover_assert_assumptions ; -; - +; * ; -; - +; * syntax: cover_assert_assumptions(+Clause_list) ; -; - +; * ; -; - +; * args: Clause_list .. clause in list representation ; -; - +; * ; -; - +; * description: asserts for each literal L in Clause_list assumption(L,_,_) ; -; - +; * in the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (cover_assert_assumptions ()) True) -; - - (= - (cover-assert-assumptions (Cons (with_self $L $_) $More)) - ( (add-symbol &self + (= (cover_assert_assumptions ()) True) + (= (cover-assert-assumptions (Cons (with_self $L $_) $More)) + ( (add-is-symbol &self (assumption $L $_ $_)) (cover-assert-assumptions $More))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: clear_mngr/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: retracts all head/3 and body/3 within the knowledge base ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (clear-mngr) - ( (remove-all-symbols &self - (head $_ $_ $_)) (remove-all-symbols &self (body $_ $_ $_)))) -; - + (= (clear-mngr) + ( (remove-all-atoms &self + (head $_ $_ $_)) (remove-all-atoms &self (body $_ $_ $_)))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: retract_body_literals/1 ; -; - +; * ; -; - +; * syntax: retract_body_literals(+CL) ; -; - +; * ; -; - +; * args: CL: clause in list notation ; -; - +; * ; -; - +; * description: retracts body(L,_,_) for each L:_ in CL ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (retract-body-literals (Cons (with_self $L $_) $More)) - ( (remove-symbol &self + (= (retract-body-literals (Cons (with_self $L $_) $More)) + ( (remove-is-symbol &self (body $L $_ $_)) (retract-body-literals $More))) -; - - (= - (retract_body_literals ()) True) -; - + (= (retract_body_literals ()) True) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: retract_literals/1 ; -; - +; * ; -; - +; * syntax: retract_literals(+[[Lit,N]|_]) ; -; - +; * ; -; - +; * args: N in {head,body} ; -; - +; * ; -; - +; * description: retracts head(Lit,_,_)/body(Lit,_,_) for each [Lit,head]/ ; -; - +; * [Lit,body] in the input ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (retract_literals ()) True) -; - - (= - (retract-literals (Cons (:: $L head) $Rest)) - ( (remove-symbol &self + (= (retract_literals ()) True) + (= (retract-literals (Cons (:: $L head) $Rest)) + ( (remove-is-symbol &self (head $L $_ $_)) (set-det) (retract-literals $Rest))) -; - - (= - (retract-literals (Cons (:: $L body) $Rest)) - ( (remove-symbol &self + (= (retract-literals (Cons (:: $L body) $Rest)) + ( (remove-is-symbol &self (body $L $_ $_)) (set-det) (retract-literals $Rest))) -; - - (= - (retract-literals (Cons (:: $_ $_) $Rest)) + (= (retract-literals (Cons (:: $_ $_) $Rest)) (retract-literals $Rest)) -; - - (= - (retract-literals (Cons Nil $Rest)) + (= (retract-literals (Cons Nil $Rest)) (retract-literals $Rest)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: assert_literals/1 ; -; - +; * ; -; - +; * syntax: assert_literals(+[[Lit,N]|_]) ; -; - +; * ; -; - +; * args: N in {head,body} ; -; - +; * ; -; - +; * description: asserts each Lit with [Lit,N] in the input as N(Lit,_,_) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (assert_literals ()) True) -; - - (= - (assert-literals (Cons (:: $L head) $Rest)) - ( (add-symbol &self + (= (assert_literals ()) True) + (= (assert-literals (Cons (:: $L head) $Rest)) + ( (add-is-symbol &self (head $L $_ $_)) (set-det) (assert-literals $Rest))) -; - - (= - (assert-literals (Cons (:: $L body) $Rest)) - ( (add-symbol &self + (= (assert-literals (Cons (:: $L body) $Rest)) + ( (add-is-symbol &self (body $L $_ $_)) (set-det) (assert-literals $Rest))) -; - - (= - (assert-literals (Cons (:: $_ $_) $Rest)) + (= (assert-literals (Cons (:: $_ $_) $Rest)) (assert-literals $Rest)) -; - - (= - (assert-literals (Cons Nil $Rest)) + (= (assert-literals (Cons Nil $Rest)) (assert-literals $Rest)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: assert_clause/1 ; -; - +; * ; -; - +; * syntax: assert_clause(+CL) ; -; - +; * ; -; - +; * args: CL .. clause in list representation ; -; - +; * ; -; - +; * description: asserts positive literals L in CL as head(L,old,0), ; -; - +; * negative and redundant literals as body(L,old,0). ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (assert-clause $C) + (= (assert-clause $C) (assert-clause1 $C)) -; - - (= - (assert-clause $_) - ( (clear-mngr) - (set-det) - (fail))) -; - ; -; - + (= (assert-clause $_) + (clear-mngr) + (set-det) + (fail)) ; +; on backtracking - (= - (assert_clause1 ()) True) -; - - (= - (assert-clause1 (Cons $H $T)) - ( (assert-clause1 $H) (assert-clause1 $T))) -; - - (= - (assert-clause1 (with_self $H (p))) + (= (assert_clause1 ()) True) + (= (assert-clause1 (Cons $H $T)) + (assert-clause1 $H) + (assert-clause1 $T)) + (= (assert-clause1 (with_self $H (p))) (head $H $_ $_)) -; - - (= - (assert-clause1 (with_self $H (p))) - (add-symbol &self + (= (assert-clause1 (with_self $H (p))) + (add-is-symbol &self (head $H old 0))) -; - - (= - (assert-clause1 (with_self $H $S)) + (= (assert-clause1 (with_self $H $S)) + (member $S + (:: n r)) + (body $H $_ $_)) + (= (assert-clause1 (with_self $H $S)) ( (member $S - (:: n r)) (body $H $_ $_))) -; - - (= - (assert-clause1 (with_self $H $S)) - ( (member $S - (:: n r)) (add-symbol &self (body $H old 0)))) -; - + (:: n r)) (add-is-symbol &self (body $H old 0)))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: assert_body/1 ; -; - +; * ; -; - +; * syntax: assert_body(+CL) ; -; - +; * ; -; - +; * args: CL ... clause body in list representation (only negative and ; -; - +; * redundant literals) ; -; - +; * ; -; - +; * description: asserts each literal L in CL as body(L,old,0) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (assert_body ()) True) -; - - (= - (assert-body (Cons $H $T)) - ( (assert-body $H) (assert-body $T))) -; - - (= - (assert-body (with_self $H $S)) + (= (assert_body ()) True) + (= (assert-body (Cons $H $T)) + (assert-body $H) + (assert-body $T)) + (= (assert-body (with_self $H $S)) ( (member $S - (:: n r)) (add-symbol &self (body $H old 0)))) -; - + (:: n r)) (add-is-symbol &self (body $H old 0)))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: assert_body_unique/1 ; -; - +; * ; -; - +; * syntax: assert_body_unique(+CL) ; -; - +; * ; -; - +; * args: CL ... clause body in list representation (only negative and ; -; - +; * redundant literals) ; -; - +; * ; -; - +; * description: as assert_body/1, but tests whether body(L,_,_) is already ; -; - +; * in the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (assert_body_unique ()) True) -; - - (= - (assert-body-unique (Cons $H $T)) - ( (assert-body-unique $H) (assert-body-unique $T))) -; - - (= - (assert-body-unique (with_self $H $S)) + (= (assert_body_unique ()) True) + (= (assert-body-unique (Cons $H $T)) + (assert-body-unique $H) + (assert-body-unique $T)) + (= (assert-body-unique (with_self $H $S)) + (member $S + (:: n r)) + (body $H $_ $_)) + (= (assert-body-unique (with_self $H $S)) ( (member $S - (:: n r)) (body $H $_ $_))) -; - - (= - (assert-body-unique (with_self $H $S)) - ( (member $S - (:: n r)) (add-symbol &self (body $H old 0)))) -; - + (:: n r)) (add-is-symbol &self (body $H old 0)))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: reset_counts/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: for each kb-entry head(Lit,_,Count) and body(Lit,_,Count), ; -; - +; * Count is set to 0 ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (reset-counts) - ( (remove-symbol &self + (= (reset-counts) + ( (remove-is-symbol &self (body $L $O $_)) - (add-symbol &self + (add-is-symbol &self (body $L $O 0)) (fail))) -; - - (= - (reset-counts) - ( (remove-symbol &self + (= (reset-counts) + ( (remove-is-symbol &self (head $L $O $_)) - (add-symbol &self + (add-is-symbol &self (head $L $O 0)) (fail))) -; - - (= reset_counts True) -; - + (= reset_counts True) ; -; - +; ********************************************************************** ; -; - +; * ; -; - +; * predicate: subs_build_clause/1 ; -; - +; * ; -; - +; * syntax: subs_build_clause(-CL) ; -; - +; * ; -; - +; * args: CL ... Horn clause in list representation ; -; - +; * ; -; - +; * description: retracts one entry head(H,_,_) and all entries ; -; - +; * body(L,_,_) and builds clause [H:p,..,L:p,...] ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (subs-build-clause (Cons (with_self $H (p)) $Body)) - ( (remove-symbol &self + (= (subs-build-clause (Cons (with_self $H (p)) $Body)) + ( (remove-is-symbol &self (head $H $_ $_)) (subs-build-clause $Body) (set-det))) -; - - (= - (subs-build-clause (Cons (with_self $L (n)) $Body)) - ( (remove-symbol &self + (= (subs-build-clause (Cons (with_self $L (n)) $Body)) + ( (remove-is-symbol &self (body $L $_ $_)) (subs-build-clause $Body))) -; - - (= - (subs-build-clause Nil) + (= (subs-build-clause Nil) (set-det)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: sat_build_clause/3 ; -; - +; * ; -; - +; * syntax: sat_build_clause(+H,+B,-CL) ; -; - +; * ; -; - +; * args: H ... head ; -; - +; * B ... list of body literals ; -; - +; * CL ... Horn clause in list representation ; -; - +; * ; -; - +; * description: build clause CL = [H:p,...,L:M,....] for each L in B. ; -; - +; * M is n, if body(L,_,_) is true, else M is r ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (sat-build-clause $H $B - (Cons - (with_self $H - (p)) $B1)) + (= (sat-build-clause $H $B (Cons (with_self $H (p)) $B1)) (sat-build-body $B $B1)) -; - - (= - (sat_build_body () ()) True) -; - - (= - (sat-build-body - (Cons $L $B) - (Cons - (with_self $L - (n)) $B1)) - ( (body $L $_ 0) - (set-det) - (sat-build-body $B $B1))) -; - - (= - (sat-build-body - (Cons $L $B) - (Cons - (with_self $L - (r)) $B1)) + (= (sat_build_body () ()) True) + (= (sat-build-body (Cons $L $B) (Cons (with_self $L (n)) $B1)) + (body $L $_ 0) + (set-det) (sat-build-body $B $B1)) -; - +; ; nonredundant literal + (= (sat-build-body (Cons $L $B) (Cons (with_self $L (r)) $B1)) + (sat-build-body $B $B1)) +; ; (probably) superfluos literal ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: msg_build_long_clause/1 ; -; - +; * ; -; - +; * syntax: msg_build_long_clause(-CL) ; -; - +; * ; -; - +; * args: CL ... a general clause in list representation ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (msg-build-long-clause $Clause) - ( (msg-build-heads $Heads) - (msg-build-body $Body) - (append $Heads $Body $Clause) - (set-det))) -; - + (= (msg-build-long-clause $Clause) + (msg-build-heads $Heads) + (msg-build-body $Body) + (append $Heads $Body $Clause) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: msg_build_heads/1 ; -; - +; * ; -; - +; * syntax: msg_build_heads(-CL) ; -; - +; * ; -; - +; * args: CL ... clause in list representation, consisting only of ; -; - +; * positive literals ; -; - +; * ; -; - +; * description: collects all Literals L such that head(L,_,_) is in kb, ; -; - +; * and returns CL = [...,L:p,....] ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (msg-build-heads (Cons (with_self $H (p)) $More)) - ( (remove-symbol &self + (= (msg-build-heads (Cons (with_self $H (p)) $More)) + ( (remove-is-symbol &self (head $H $F $I)) (msg-build-heads $More) - (add-symbol &self + (add-is-symbol &self (head $H $F $I)))) -; - - (= - (msg-build-heads Nil) + (= (msg-build-heads Nil) (set-det)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: msg_build_body/1 ; -; - +; * ; -; - +; * syntax: msg_build_body(-CL) ; -; - +; * ; -; - +; * args: CL ... clause in list representation, consisting only of ; -; - +; * negative and redundant literals ; -; - +; * ; -; - +; * description: collects all Literals L such that body(L,_,_) is in kb, ; -; - +; * and returns CL = [...,L:M,....], M in {n,r} ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (msg-build-body (Cons (with_self $H $Sign) $More)) - ( (remove-symbol &self + (= (msg-build-body (Cons (with_self $H $Sign) $More)) + ( (remove-is-symbol &self (body $H $F $I)) (det-if-then-else (= $I 0) @@ -2226,138 +1427,96 @@ (= $Sign r)) (msg-build-body $More) (set-det) - (add-symbol &self + (add-is-symbol &self (body $H $F $I)))) -; - - (= - (msg-build-body Nil) + (= (msg-build-body Nil) (set-det)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: idev_build_clause1/1 ; -; - +; * ; -; - +; * syntax: idev_build_clause1(-CL) ; -; - +; * ; -; - +; * args: CL .. Horn clause in list representation ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (idev-build-clause1 (Cons (with_self $H (p)) $More)) - ( (remove-symbol &self + (= (idev-build-clause1 (Cons (with_self $H (p)) $More)) + ( (remove-is-symbol &self (head $H $F 0)) (set-det) (idev-build-body $More) - (add-symbol &self + (add-is-symbol &self (head $H $F 0)))) -; - +; ; the head is unique ! ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: idev_build_body/1 ; -; - +; * ; -; - +; * syntax: idev_build_body(-CL) ; -; - +; * ; -; - +; * args: CL ... clause in list represenation, only negative and redundant literals ; -; - +; * ; -; - +; * description: collects all L such that body(L,_,_) is in kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (idev-build-body (Cons (with_self $H $Sign) $More)) - ( (remove-symbol &self + (= (idev-build-body (Cons (with_self $H $Sign) $More)) + ( (remove-is-symbol &self (body $H $F $I)) (det-if-then-else (= $I 0) @@ -2365,399 +1524,259 @@ (= $Sign r)) (idev-build-body $More) (set-det) - (add-symbol &self + (add-is-symbol &self (body $H $F $I)))) -; - - (= - (idev-build-body Nil) + (= (idev-build-body Nil) (set-det)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: idev_build_clause/2 ; -; - +; * ; -; - +; * syntax: idev_build_clause(+H,-CL) ; -; - +; * ; -; - +; * args: CL .. clause in list representation ; -; - +; * H ... preferred head of CL ; -; - +; * ; -; - +; * description: as idev_build_clause1/1, but with preferred head in CL ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (idev-build-clause $PrefHead - (Cons - (with_self $H - (p)) $More)) - ( (idev-build-head $PrefHead $H) - (idev-build-body $More) - (set-det))) -; - + (= (idev-build-clause $PrefHead (Cons (with_self $H (p)) $More)) + (idev-build-head $PrefHead $H) + (idev-build-body $More) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: idev_build_head/2 ; -; - +; * ; -; - +; * syntax: idev_build_head(+PrefH,-H) ; -; - +; * ; -; - +; * args: PrefH, H .. clause heads ; -; - +; * ; -; - +; * description: returns H such that head(H,_,_) in kb and PrefH and H ; -; - +; * unifiable. If none exists, the first H with head(H,_,_) in kb ; -; - +; * is returned. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (idev-build-head $PrefHead $PrefHead) - ( (remove-symbol &self + (= (idev-build-head $PrefHead $PrefHead) + ( (remove-is-symbol &self (head $PrefHead $F $N)) (set-det) - (add-symbol &self + (add-is-symbol &self (head $PrefHead $F $N)))) -; - - (= - (idev-build-head $_ $Head) + (= (idev-build-head $_ $Head) (head $Head $_ $_)) -; - ; -; - +; retract( head(Head,F,N) ), ; -; - +; !, ; -; - +; asserta( head(H,F,N) ) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: ident_build_body/1 ; -; - +; * ; -; - +; * syntax: ident_build_body(-CL) ; -; - +; * ; -; - +; * args: CL ... clause in list notation, contains only negative literals ; -; - +; * ; -; - +; * description: CL = [...,L:n,...] for each L such that body(L,_,0) in kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (ident-build-body (Cons (with_self $L (n)) $Rest)) - ( (remove-symbol &self + (= (ident-build-body (Cons (with_self $L (n)) $Rest)) + ( (remove-is-symbol &self (body $L $_ 0)) (set-det) (ident-build-body $Rest) - (add-symbol &self - (body $L old 0)))) -; - ; -; - - (= - (ident-build-body Nil) + (add-is-symbol &self + (body $L old 0)))) ; +; for backtracking + (= (ident-build-body Nil) (set-det)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: g1_build_clause/2 ; -; - +; * ; -; - +; * syntax: g1_build_clause(+ResLit,-CL) ; -; - +; * ; -; - +; * args: CL ... Horn clause in list notation ; -; - +; * ResLit ... the resolution literal ; -; - +; * ; -; - +; * description: CL is the second parent clause for the g1-operator ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (g1-build-clause - (with_self $L - (p)) - (Cons - (with_self $L - (p)) $Body)) - ( (ident-build-body $Body) (set-det))) -; - (= - (g1-build-clause - (with_self $L - (n)) - (Cons - (with_self $H - (p)) - (Cons - (with_self $L - (n)) $Body))) + (= (g1-build-clause (with_self $L (p)) (Cons (with_self $L (p)) $Body)) + (ident-build-body $Body) + (set-det)) + (= (g1-build-clause (with_self $L (n)) (Cons (with_self $H (p)) (Cons (with_self $L (n)) $Body))) ( (ident-build-body $Body) - (remove-symbol &self + (remove-is-symbol &self (head $H $_ 0)) (set-det) - (add-symbol &self - (head $L old 0)))) -; - + (add-is-symbol &self + (head $L old 0)))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: abs_build_body/1 ; -; - +; * ; -; - +; * syntax: abs_build_body(-CL) ; -; - +; * ; -; - +; * args: CL .. clause in list representation, contains only negative literals ; -; - +; * ; -; - +; * description: CL = [...,L:n,....] for each L such that body(L,_,_) in kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (abs-build-body (Cons (with_self $L (n)) $Rest)) - ( (remove-symbol &self + (= (abs-build-body (Cons (with_self $L (n)) $Rest)) + ( (remove-is-symbol &self (body $L $F $I)) (set-det) (abs-build-body $Rest) - (add-symbol &self + (add-is-symbol &self (body $L $F $I)))) -; - - (= - (abs-build-body Nil) + (= (abs-build-body Nil) (set-det)) -; - diff --git a/miles/clause_heads.metta b/miles/clause_heads.metta index 1266297..f9f7fe6 100644 --- a/miles/clause_heads.metta +++ b/miles/clause_heads.metta @@ -1,6 +1,6 @@ +; (convert_to_metta_file clause_heads $_472804 miles/clause_heads.pl miles/clause_heads.metta) ; -; - +; MODULE clause_heads EXPORTS !(module clause-heads @@ -9,12 +9,9 @@ (/ heads 1) (/ heads 2) (/ heads 3))) -; - ; -; - +; IMPORTS !(use-module (home div-utils) (:: @@ -25,18 +22,12 @@ (/ split-examples 4) (/ insert-unique 3) (/ remove-v 3))) -; - !(use-module (home var-utils) (:: (/ terms 4))) -; - !(use-module (home interpreter) (:: (/ proof-path 4))) -; - !(use-module (home kb) (:: @@ -44,947 +35,631 @@ (/ get-clause 5) (/ store-clauses 2) (/ delete-clause 1))) -; - !(use-module (home argument-types) (:: (/ type-restriction 2))) -; - !(use-module (home lgg) (:: (/ set-lgg 2))) -; - !(use-module (home evaluation) (:: (/ eval-examples 0))) -; - !(use-module-if-exists (library subsumes) (:: (/ subsumes-chk 2))) -; - !(use-module-if-exists (library basics) (:: (/ member 2))) -; - !(use-module-if-exists (library lists) (:: (/ rev 2))) -; - ; -; - +; METAPREDICATES ; -; - +; none ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * module: clause_heads.pl ; -; - +; * ; -; - +; * author: Irene Stahl date: 13. 10. 1992 ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * description: algorithm for determining clause heads ; -; - +; * generates database entrys of the form ; -; - +; * known(ID,Head,true,CList,head,_) ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ************************************************************************ ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: clause_heads/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: determines clause heads covering all positive examples in ; -; - +; * the kb and asserts them in the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; ************************************************************************ - - (= - (clause-heads) - ( (mysetof $E - (^ $I - (get-example $I $E +)) $Elist) - (different-predicates $Elist $Elist1) - (clause-heads $Elist1))) -; - + (= (clause-heads) + (mysetof $E + (^ $I + (get-example $I $E +)) $Elist) + (different-predicates $Elist $Elist1) + (clause-heads $Elist1)) +; ; Elist = [E1,..,En] pos examples +; ; Elist1 = [[E1,..,Em],...] +; ; list of lists of pos examples with +; ; the same predicate symbol ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: heads/1 ; -; - +; * ; -; - +; * syntax: heads(-HL) ; -; - +; * ; -; - +; * args: HL list of clause heads ; -; - +; * ; -; - +; * description: returns list of heads covering all positive examples in ; -; - +; * the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; ************************************************************************ - - (= - (heads $HL) - ( (clause-heads) (mysetof $Head (^ $ID (^ $Body (^ $CL (, (get-clause $ID $Head $Body $CL head) (delete-clause $ID))))) $HL))) -; - + (= (heads $HL) + (clause-heads) + (mysetof $Head + (^ $ID + (^ $Body + (^ $CL + (, + (get-clause $ID $Head $Body $CL head) + (delete-clause $ID))))) $HL)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: heads/2 ; -; - +; * ; -; - +; * syntax: heads(+Pred,+Arity) ; -; - +; * ; -; - +; * args: Pred .. predicate symbol (atom), Arity.. an integer ; -; - +; * ; -; - +; * description: determines clause heads covering all positive examples for ; -; - +; * Pred/Arity and asserts them in the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - (= - (heads $P $N) - ( (functor $E $P $N) - (mysetof $E - (^ $I - (get-example $I $E +)) $Elist) - (clause-heads (:: $Elist)))) -; +; ************************************************************************ + (= (heads $P $N) + (functor $E $P $N) + (mysetof $E + (^ $I + (get-example $I $E +)) $Elist) + (clause-heads (:: $Elist))) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: heads/3 ; -; - +; * ; -; - +; * syntax: heads(+Pred,+Arity,-HL) ; -; - +; * ; -; - +; * args: Pred .. predicate symbol, Arity .. integer, HL .. list of heads ; -; - +; * ; -; - +; * description: returns list of heads covering all positive examples for ; -; - +; * Pred/Arity ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - (= - (heads $P $N $HL) - ( (functor $E $P $N) - (mysetof $E - (^ $I - (get-example $I $E +)) $Elist) - (clause-heads (:: $Elist)) - (functor $Head $P $N) - (mysetof $Head - (^ $ID - (^ $Body - (^ $CL - (, - (get-clause $ID $Head $Body $CL head) - (delete-clause $ID))))) $HL))) -; +; ************************************************************************ + (= (heads $P $N $HL) + (functor $E $P $N) + (mysetof $E + (^ $I + (get-example $I $E +)) $Elist) + (clause-heads (:: $Elist)) + (functor $Head $P $N) + (mysetof $Head + (^ $ID + (^ $Body + (^ $CL + (, + (get-clause $ID $Head $Body $CL head) + (delete-clause $ID))))) $HL)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: clause_heads/1 ; -; - +; * ; -; - +; * syntax: clause_heads(+ELL) ; -; - +; * ; -; - +; * args: ELL = [[E1,..,Em],...] list of lists of pos examples with the ; -; - +; * same predicate symbol ; -; - +; * ; -; - +; * description: determines for each [E1,..,Em] in ELL clause heads ; -; - +; * and asserts them in the knowledge base ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; ************************************************************************ - (= - (clause_heads ()) True) -; - - (= - (clause-heads (Cons $EL $R)) - ( (clause-heads $R) - (clause-heads $EL $Heads) - (make-unique $Heads $Heads1) - (minimize-heads $Heads1 $EL $Heads2) - (store-clauses $Heads2 head) - (eval-examples))) -; + (= (clause_heads ()) True) + (= (clause-heads (Cons $EL $R)) + (clause-heads $R) + (clause-heads $EL $Heads) + (make-unique $Heads $Heads1) + (minimize-heads $Heads1 $EL $Heads2) + (store-clauses $Heads2 head) + (eval-examples)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: clause_heads/2 ; -; - +; * ; -; - +; * syntax: clause_heads(+EL,-Heads) ; -; - +; * ; -; - +; * args: +EL = [E1,...,Em] positive examples of a predicate p/n ; -; - +; * Heads = [H1,..,Hk] heads for p/n covering EL ; -; - +; * ; -; - +; * description: determines heads for p/n by determining base heads ; -; - +; * and heads for non-base examples according to the ; -; - +; * differing types ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ************************************************************************ - (= - (clause-heads - (Cons $E $R) $Heads) - ( (functor $E $P $N) - (functor $P1 $P $N) - (det-if-then-else - (type-restriction $P1 $Types) True - (, - (=.. $P1 - (Cons $_ $P1A)) - (trivial-tr $P1A $Types))) - (bases $N - (Cons $E $R) $P1 $Types $B) - (remove-base-examples $B - (Cons $E $R) $E1) - (split-examples-by-types $E1 $P1 $Types $Hlist) - (make-unique $Hlist $Hlist1) - (best-lgg $Hlist1 - (Cons $E $R) $B $Heads))) -; - - - - (= - (trivial_tr () ()) True) -; + (= (clause-heads (Cons $E $R) $Heads) + (functor $E $P $N) + (functor $P1 $P $N) + (det-if-then-else + (type-restriction $P1 $Types) True + (, + (=.. $P1 + (Cons $_ $P1A)) + (trivial-tr $P1A $Types))) + (bases $N + (Cons $E $R) $P1 $Types $B) + (remove-base-examples $B + (Cons $E $R) $E1) + (split-examples-by-types $E1 $P1 $Types $Hlist) + (make-unique $Hlist $Hlist1) + (best-lgg $Hlist1 + (Cons $E $R) $B $Heads)) - (= - (trivial-tr - (Cons $X $R) - (Cons $T $R1)) - ( (trivial-tr $R $R1) (=.. $T (:: all $X)))) -; + (= (trivial_tr () ()) True) + (= (trivial-tr (Cons $X $R) (Cons $T $R1)) + (trivial-tr $R $R1) + (=.. $T + (:: all $X))) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: bases/5 ; -; - +; * ; -; - +; * syntax: bases(+Count,+E,+P,+Type,-B) ; -; - +; * ; -; - +; * args: N .. counter ; -; - +; * E .. positive examples for p/n ; -; - +; * P, Type .. type restriction of the target predicate p/n ; -; - +; * B .. base heads for p/n ; -; - +; * ; -; - +; * description: for each argument position N, ; -; - +; * for each base case at b at that position, ; -; - +; * add lgg({p(..,b,..)|p(..,b,..) in E}) to B ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; ************************************************************************ + (= (bases 0 $_ $_ $_ ()) True) + (= (bases $N $E $P $Type $B) + (is $N1 + (- $N 1)) + (bases $N1 $E $P $Type $B1) + (copy-term + (, $P $Type) + (, $P1 $Type1)) + (arg $N $P1 $P1n) + (member $T $Type1) + (=.. $T + (:: $_ $X)) + (== $X $P1n) + (mysetof $Base + (^ $I + (^ $CL + (^ $R + (, + (get-clause $I $T True $CL type) + (=.. $T + (:: $R $Base)))))) $Bases) + (bases1 $Bases $N $E $B1 $B)) - (= - (bases 0 $_ $_ $_ ()) True) -; - (= - (bases $N $E $P $Type $B) - ( (is $N1 - (- $N 1)) - (bases $N1 $E $P $Type $B1) - (copy-term - (, $P $Type) - (, $P1 $Type1)) - (arg $N $P1 $P1n) - (member $T $Type1) - (=.. $T - (:: $_ $X)) - (== $X $P1n) - (mysetof $Base - (^ $I - (^ $CL - (^ $R - (, - (get-clause $I $T True $CL type) - (=.. $T - (:: $R $Base)))))) $Bases) - (bases1 $Bases $N $E $B1 $B))) -; - - - - (= - (bases1 () $_ $_ $B $B) True) -; - - (= - (bases1 - (Cons $B $R) $N $E $B1 - (Cons $H $B2)) - ( (bases1 $R $N $E $B1 $B2) - (bases2 $E $N $B $Eb) - (set-lgg $Eb $H))) -; - - - - (= - (bases2 () $_ $_ ()) True) -; - - (= - (bases2 - (Cons $E $R) $N $B - (Cons $E $R1)) - ( (arg $N $E $B) - (set-det) - (bases2 $R $N $B $R1))) -; - - (= - (bases2 - (Cons $_ $R) $N $B $R1) - (bases2 $R $N $B $R1)) -; + (= (bases1 () $_ $_ $B $B) True) + (= (bases1 (Cons $B $R) $N $E $B1 (Cons $H $B2)) + (bases1 $R $N $E $B1 $B2) + (bases2 $E $N $B $Eb) + (set-lgg $Eb $H)) + (= (bases2 () $_ $_ ()) True) + (= (bases2 (Cons $E $R) $N $B (Cons $E $R1)) + (arg $N $E $B) + (set-det) + (bases2 $R $N $B $R1)) + (= (bases2 (Cons $_ $R) $N $B $R1) + (bases2 $R $N $B $R1)) -; -; ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: split_examples_by_types/4 ; -; - +; * ; -; - +; * syntax: split_examples_by_types(+E,+P,+Type,-Heads) ; -; - +; * ; -; - +; * args: E ... examles for p/n (without base examples) ; -; - +; * P,Type ... type restriction for p/n ; -; - +; * Heads ... list [..., H:terms(H),...] of heads for p/n according ; -; - +; * to different types ; -; - +; * ; -; - +; * description: splits examples E according to different argument types ; -; - +; * -> ELL list of example lists. For each EL in ELL, lgg(EL) is ; -; - +; * added to heads ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - - - - (= - (split-examples-by-types $E $P $Types $Heads) - ( (split-examples-by-types $Types $P $E Nil $Elist) (construct-heads $Elist $Heads))) -; - - - (= - (split_examples_by_types () $_ $_ $EL $EL) True) -; - - (= - (split-examples-by-types - (Cons $T $R) $P $E $EL $EL3) - ( (split-examples-by-types $R $P $E $EL $EL1) - (mysetof - (, $Ex $Ts) - (, - (member $Ex $E) - (proof-path $Ex $P $T $Ts)) $Elist0) - (split-example-list $Elist0 $EL2) - (append $EL1 $EL2 $EL3))) -; - +; * +; +; ************************************************************************ + (= (split-examples-by-types $E $P $Types $Heads) + (split-examples-by-types $Types $P $E Nil $Elist) + (construct-heads $Elist $Heads)) - (= - (split_example_list () ()) True) -; + (= (split_examples_by_types () $_ $_ $EL $EL) True) + (= (split-examples-by-types (Cons $T $R) $P $E $EL $EL3) + (split-examples-by-types $R $P $E $EL $EL1) + (mysetof + (, $Ex $Ts) + (, + (member $Ex $E) + (proof-path $Ex $P $T $Ts)) $Elist0) + (split-example-list $Elist0 $EL2) + (append $EL1 $EL2 $EL3)) - (= - (split-example-list - (Cons - (, $E $Ts) $R) - (Cons - (Cons $E $EL) $R1)) - ( (split-elist $R $Ts $EL $R0) (split-example-list $R0 $R1))) -; + (= (split_example_list () ()) True) + (= (split-example-list (Cons (, $E $Ts) $R) (Cons (Cons $E $EL) $R1)) + (split-elist $R $Ts $EL $R0) + (split-example-list $R0 $R1)) - (= - (split_elist () $_ () ()) True) -; - (= - (split-elist - (Cons - (, $E $Ts) $R) $Ts - (Cons $E $R1) $R2) + (= (split_elist () $_ () ()) True) + (= (split-elist (Cons (, $E $Ts) $R) $Ts (Cons $E $R1) $R2) (split-elist $R $Ts $R1 $R2)) -; - - (= - (split-elist - (Cons $E $R) $Ts $R1 - (Cons $E $R2)) + (= (split-elist (Cons $E $R) $Ts $R1 (Cons $E $R2)) (split-elist $R $Ts $R1 $R2)) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: construct_heads/2 ; -; - +; * ; -; - +; * syntax: construct_heads(+ELL,-Heads) ; -; - +; * ; -; - +; * args: ELL ... list of lists of examples ; -; - +; * Heads ... list [...,H:terms(H),...] of heads ; -; - +; * ; -; - +; * description: for each EL in ELL set H:= lgg(EL), terms(H) terms of H ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ************************************************************************ - (= - (construct-heads - (Cons $EL $R) - (Cons - (with_self $H $Vars) $R1)) - ( (set-lgg $EL $H) - (functor $H $_ $N) - (terms $N $H Nil $Vars) - (construct-heads $R $R1))) -; - - (= - (construct_heads () ()) True) -; - + (= (construct-heads (Cons $EL $R) (Cons (with_self $H $Vars) $R1)) + (set-lgg $EL $H) + (functor $H $_ $N) + (terms $N $H Nil $Vars) + (construct-heads $R $R1)) + (= (construct_heads () ()) True) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: best_lgg/4 ; -; - +; * ; -; - +; * syntax: best_lgg(+ToRefine,+E,+Heads,-Heads) ; -; - +; * ; -; - +; * args: ToRefine ... list [...,H:terms(H),...] of heads ; -; - +; * E ... examples ; -; - +; * Heads ... resulting heads [...,H,...] ; -; - +; * ; -; - +; * description: while ToRefine \= [], ; -; - +; * add first element H to Heads and ; -; - +; * compute all refinements of H that result from unifying ; -; - +; * terms within H. Add the refinements to ToRefine. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; ************************************************************************ - (= - (best_lgg () $_ $HL $HL) True) -; - (= - (best-lgg - (Cons - (with_self $H $Vars) $R) $E $HL $HL1) + (= (best_lgg () $_ $HL $HL) True) + (= (best-lgg (Cons (with_self $H $Vars) $R) $E $HL $HL1) (det-if-then-else (variant-mem $H $HL) (best-lgg $R $E $HL $HL1) @@ -993,508 +668,329 @@ (append $Lp $R $R1) (best-lgg $R1 $E (Cons $H $HL) $HL1)))) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: try_to_unify/6 ; -; - +; * ; -; - +; * syntax: try_to_unify(+H,+Terms,+Terms,+E,+Result,-Result) ; -; - +; * ; -; - +; * args: H .. head that is to be refined ; -; - +; * Terms ... terms(H) ; -; - +; * E ... examples ; -; - +; * Result ... list [...,H1:terms(H1),...] of refined heads ; -; - +; * ; -; - +; * description: for each pair X,Y (X \== Y) in terms(H) ; -; - +; * if H[X/Y] covers examples E' in E ; -; - +; * then add H1:terms(H1) to result where H1 = lgg(E') ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (try_to_unify $_ () $_ $_ $L $L) True) -; - - (= - (try-to-unify $H - (Cons $X $R) $V $E $L $L2) - ( (unify-vars $H $X $V $E $L $L1) (try-to-unify $H $R $V $E $L1 $L2))) -; - - - - (= - (unify_vars $_ $_ () $_ $L $L) True) -; - - (= - (unify-vars $H $X - (Cons $Y $R) $E $L $L2) - ( (copy-term - (, $H $X $Y) - (, $H1 $X1 $Y1)) - (unify-var $H1 $X1 $Y1 $E $L $L1) - (unify-vars $H $X $R $E $L1 $L2))) -; +; ************************************************************************ + (= (try_to_unify $_ () $_ $_ $L $L) True) + (= (try-to-unify $H (Cons $X $R) $V $E $L $L2) + (unify-vars $H $X $V $E $L $L1) + (try-to-unify $H $R $V $E $L1 $L2)) - (= - (unify-var $_ $X $Y $_ $L $L) - ( (== $X $Y) (set-det))) -; - (= - (unify-var $H $X $X $E $L0 $L1) - ( (set-det) - (split-examples $E $H $Pos $_) - (det-if-then-else - (\== $Pos Nil) - (, - (set-lgg $Pos $H1) - (functor $H1 $_ $N) - (terms $N $H1 Nil $Vars1) - (= $L1 - (Cons - (with_self $H1 $Vars1) $L0))) - (= $L1 $L0)))) -; + (= (unify_vars $_ $_ () $_ $L $L) True) + (= (unify-vars $H $X (Cons $Y $R) $E $L $L2) + (copy-term + (, $H $X $Y) + (, $H1 $X1 $Y1)) + (unify-var $H1 $X1 $Y1 $E $L $L1) + (unify-vars $H $X $R $E $L1 $L2)) - (= - (unify_var $_ $_ $_ $_ $L $L) True) -; + (= (unify-var $_ $X $Y $_ $L $L) + (== $X $Y) + (set-det)) + (= (unify-var $H $X $X $E $L0 $L1) + (set-det) + (split-examples $E $H $Pos $_) + (det-if-then-else + (\== $Pos Nil) + (, + (set-lgg $Pos $H1) + (functor $H1 $_ $N) + (terms $N $H1 Nil $Vars1) + (= $L1 + (Cons + (with_self $H1 $Vars1) $L0))) + (= $L1 $L0))) +; ; ( Vars1 == [] -> ; L1 = L0 ; ; +; ; ) + (= (unify_var $_ $_ $_ $_ $L $L) True) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: remove_base_example/3 ; -; - +; * ; -; - +; * syntax: remove_base_example(+BHeads,+E,-E) ; -; - +; * ; -; - +; * args: BHeads ... base heads ; -; - +; * E ... examples ; -; - +; * ; -; - +; * description: removes all examples covered by base heads in BHeads from E ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; ************************************************************************ - - (= - (remove-base-examples $B - (Cons $E $R) $R1) - ( (is-base-example $E $B) - (set-det) - (remove-base-examples $B $R $R1))) -; - - (= - (remove-base-examples $B - (Cons $E $R) - (Cons $E $R1)) + (= (remove-base-examples $B (Cons $E $R) $R1) + (is-base-example $E $B) + (set-det) (remove-base-examples $B $R $R1)) -; - - (= - (remove_base_examples $_ () ()) True) -; - - + (= (remove-base-examples $B (Cons $E $R) (Cons $E $R1)) + (remove-base-examples $B $R $R1)) + (= (remove_base_examples $_ () ()) True) - (= - (is-base-example $E - (Cons $B $_)) - ( (subsumes-chk $B $E) (set-det))) -; - (= - (is-base-example $E - (Cons $_ $R)) + (= (is-base-example $E (Cons $B $_)) + (subsumes-chk $B $E) + (set-det)) + (= (is-base-example $E (Cons $_ $R)) (is-base-example $E $R)) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: minimize_heads/3 ; -; - +; * ; -; - +; * syntax: minimize_heads(+Heads,+Examples,-Heads) ; -; - +; * ; -; - +; * args: Heads.. list of clause heads ; -; - +; * Examples... positive examples to be covered by Heads ; -; - +; * ; -; - +; * description: minimizes the set of clause heads by first removing general ; -; - +; * redundant heads, then specific redundant heads. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; ************************************************************************ - - (= - (minimize-heads $H $EL $H4) - ( (sort-heads-theta $H $H1) - (remove-redundant $H1 $H1 $EL $H2) - (rev $H2 $H3) - (remove-redundant $H3 $H3 $EL $H4))) -; - + (= (minimize-heads $H $EL $H4) + (sort-heads-theta $H $H1) + (remove-redundant $H1 $H1 $EL $H2) + (rev $H2 $H3) + (remove-redundant $H3 $H3 $EL $H4)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: sort_heads_theta/2 ; -; - +; * ; -; - +; * syntax: sort_heads_theta(+Heads,-Heads) ; -; - +; * ; -; - +; * args: Heads.. list of clause heads ; -; - +; * ; -; - +; * description: sorts Heads descendingly according to theta-subsumption ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (sort_heads_theta () ()) True) -; - - (= - (sort-heads-theta - (Cons $H $R) $L) - ( (sort-heads-theta $R $L1) (insert-heads-theta $L1 $H $L))) -; +; ************************************************************************ + (= (sort_heads_theta () ()) True) + (= (sort-heads-theta (Cons $H $R) $L) + (sort-heads-theta $R $L1) + (insert-heads-theta $L1 $H $L)) - (= - (insert-heads-theta - (Cons $H1 $R) $H - (Cons $H1 $R1)) - ( (subsumes-chk $H1 $H) - (set-det) - (insert-heads-theta $R $H $R1))) -; - - (= - (insert_heads_theta $L $H - (Cons $H $L)) True) -; + (= (insert-heads-theta (Cons $H1 $R) $H (Cons $H1 $R1)) + (subsumes-chk $H1 $H) + (set-det) + (insert-heads-theta $R $H $R1)) + (= (insert_heads_theta $L $H (Cons $H $L)) True) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: remove_redundant/4 ; -; - +; * ; -; - +; * syntax: remove_redundant(+Heads,+Heads,+Examples,-Heads) ; -; - +; * ; -; - +; * args: Heads.. list of clause heads ; -; - +; * Examples... positive examples to be covered by Heads ; -; - +; * ; -; - +; * description: removes redundant heads from the list Heads ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; ************************************************************************ - - (= - (remove-redundant - (Cons $H $R) $HL $EL $HL1) - ( (remove-v - (:: $H) $HL $HL0) (det-if-then-else (heads-cover $HL0 $EL) (remove-redundant $R $HL0 $EL $HL1) (remove-redundant $R $HL $EL $HL1)))) -; - - (= - (remove_redundant () $HL $_ $HL) True) -; - + (= (remove-redundant (Cons $H $R) $HL $EL $HL1) + (remove-v + (:: $H) $HL $HL0) + (det-if-then-else + (heads-cover $HL0 $EL) + (remove-redundant $R $HL0 $EL $HL1) + (remove-redundant $R $HL $EL $HL1))) + (= (remove_redundant () $HL $_ $HL) True) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: heads_cover/2 ; -; - +; * ; -; - +; * syntax: heads_cover(+Heads,+Examples) ; -; - +; * ; -; - +; * args: Heads.. list of clause heads ; -; - +; * Examples... positive examples to be covered by Heads ; -; - +; * ; -; - +; * description: tests whether the heads in Heads cover all examples ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (heads_cover $_ ()) True) -; +; ************************************************************************ - (= - (heads-cover - (Cons $H $R) $E) - ( (split-examples $E $H $_ $E1) (heads-cover $R $E1))) -; + (= (heads_cover $_ ()) True) + (= (heads-cover (Cons $H $R) $E) + (split-examples $E $H $_ $E1) + (heads-cover $R $E1)) diff --git a/miles/div_utils.metta b/miles/div_utils.metta index dcf4f7c..c35a8fb 100644 --- a/miles/div_utils.metta +++ b/miles/div_utils.metta @@ -1,6 +1,6 @@ +; (convert_to_metta_file div_utils $_303102 miles/div_utils.pl miles/div_utils.metta) ; -; - +; MODULE div_utils EXPORTS !(module div-utils @@ -46,2937 +46,1857 @@ (/ log2 2) (/ log2nueberk 3) (/ sum-of-logs 3))) -; - ; -; - +; METAPREDICATES !(meta-predicate (mysetof + : -)) -; - ; -; - +; IMPORTS !(use-module-if-exists (library basics) (:: (/ member 2))) -; - !(use-module-if-exists (library subsumes) (:: (/ variant 2))) -; - !(use-module-if-exists (library occurs) (:: (/ sub-term 2) (/ contains-var 2))) -; - !(use-module-if-exists (library lists) (:: (/ rev 2))) -; - !(use-module-if-exists (library math) (:: (/ log 2))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: div_utils.pl ; -; - +; * ; -; - +; * author: B.Jung, M.Mueller, I.Stahl, B.Tausend date:12/92 ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * description: small auxiliary procedures ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: remove/3 ; -; - +; * ; -; - +; * syntax: remove(+I,+L,-L) ; -; - +; * ; -; - +; * args: I .. number, L ... list of numbers ; -; - +; * ; -; - +; * description: removes I from L (I occurs at most once in L) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (remove $_ () ()) True) -; - - (= - (remove $I - (Cons $I $R) $R) + (= (remove $_ () ()) True) + (= (remove $I (Cons $I $R) $R) (set-det)) -; - - (= - (remove $I - (Cons $J $R) - (Cons $J $R1)) + (= (remove $I (Cons $J $R) (Cons $J $R1)) (remove $I $R $R1)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: sort_by_length/3 ; -; - +; * ; -; - +; * syntax: sort_by_length(+L,+Accu,-Accu) ; -; - +; * ; -; - +; * args: L ... list of lists ; -; - +; * Accu ... L sorted increasingly according to the length of sublists ; -; - +; * ; -; - +; * description: sorts a list of lists increasingly according to ; -; - +; * the length of sublists ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (sort_by_length () $L $L) True) -; +; *********************************************************************** - (= - (sort-by-length - (Cons $IXS $R) $L $L2) - ( (insert-by-length $IXS $L $L1) (sort-by-length $R $L1 $L2))) -; + (= (sort_by_length () $L $L) True) + (= (sort-by-length (Cons $IXS $R) $L $L2) + (insert-by-length $IXS $L $L1) + (sort-by-length $R $L1 $L2)) - (= - (insert-by-length $X - (Cons $Y $R) - (Cons $Y $R1)) - ( (length $X $N) - (length $Y $N1) - (> $N $N1) - (set-det) - (insert-by-length $X $R $R1))) -; - - (= - (insert_by_length $X $L - (Cons $X $L)) True) -; - + (= (insert-by-length $X (Cons $Y $R) (Cons $Y $R1)) + (length $X $N) + (length $Y $N1) + (> $N $N1) + (set-det) + (insert-by-length $X $R $R1)) + (= (insert_by_length $X $L (Cons $X $L)) True) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: mysetof/3 ; -; - +; * ; -; - +; * syntax: mysetof(+Template,+Generator,-Set) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: as setof/3, but succeeds with Set = [], if Generator ; -; - +; * fails ; -; - +; * ; -; - +; * example: setof(X, append([1,2,3],X,[4,5]),Set) -> fail ; -; - +; * mysetof(X, append([1,2,3],X,[4,5]),Set) -> Set = [] ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (mysetof $A $B $C) - ( (setof $A $B $C) (set-det))) -; - - (= - (mysetof $_ $_ ()) True) -; - + (= (mysetof $A $B $C) + (setof $A $B $C) + (set-det)) + (= (mysetof $_ $_ ()) True) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: sum/2 ; -; - +; * ; -; - +; * syntax: sum(+LN,-S) ; -; - +; * ; -; - +; * args: LN .. list of numbers, S number ; -; - +; * ; -; - +; * description: if LN = [I1,..,In], then S = I1 + ... + In ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (sum - ($I) $I) True) -; - - (= - (sum - (Cons $I $More) $C) - ( (sum $More $J) (is $C (+ $I $J)))) -; - + (= (sum ($I) $I) True) + (= (sum (Cons $I $More) $C) + (sum $More $J) + (is $C + (+ $I $J))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: efface/3 (by Clocksin/Mellish) ; -; - +; * ; -; - +; * syntax: efface(+E,+L,-L) ; -; - +; * ; -; - +; * args: E .. element of list L ; -; - +; * ; -; - +; * description: removes the first element of L that is unifiable with E ; -; - +; * from L. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (efface $A - (Cons $A $L) $L) + (= (efface $A (Cons $A $L) $L) (set-det)) -; - - (= - (efface $A - (Cons $B $L) - (Cons $B $M)) + (= (efface $A (Cons $B $L) (Cons $B $M)) (efface $A $L $M)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: effaceall/3 ; -; - +; * ; -; - +; * syntax: effacell(+E,+L,-L) ; -; - +; * ; -; - +; * args: E .. element of list L ; -; - +; * ; -; - +; * description: as efface, but allows backtracking ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (effaceall $A - (Cons $A $L) $L) True) -; - - (= - (effaceall $A - (Cons $B $L) - (Cons $B $M)) + (= (effaceall $A (Cons $A $L) $L) True) + (= (effaceall $A (Cons $B $L) (Cons $B $M)) (effaceall $A $L $M)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: best/2 ; -; - +; * ; -; - +; * syntax: best(+List,-Elem) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: returns the first element of List, on backtracking ; -; - +; * the second etc. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (best - (Cons $X $_) $X) True) -; - - (= - (best - (Cons $_ $R) $X) + (= (best (Cons $X $_) $X) True) + (= (best (Cons $_ $R) $X) (best $R $X)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: buildpar2/3 ; -; - +; * ; -; - +; * syntax: buildpar2(+Lit:M,+CL,-CL1) ; -; - +; * ; -; - +; * args: Lit .. literal, M in {p,n,r}, CL and CL1 clauses in list representation ; -; - +; * ; -; - +; * description: if M = p then CL1 = [Lit:p|CL] ; -; - +; * else CL1 results from CL by adding Lit:M at the end ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (buildpar2 - (: $Elem1 p) $List2 - (Cons - (: $Elem1 p) $List2)) True) -; - - (= - (buildpar2 $ResLit $List2 $Parent2) + (= (buildpar2 (: $Elem1 p) $List2 (Cons (: $Elem1 p) $List2)) True) + (= (buildpar2 $ResLit $List2 $Parent2) (append $List2 (:: $ResLit) $Parent2)) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: neg/2 ; -; - +; * ; -; - +; * syntax: neg(+Lit:M,-Lit:M1) ; -; - +; * ; -; - +; * args: Lit .... literal, M in {p,n,r} ; -; - +; * ; -; - +; * description: switches the mark of the literal, i.e. if M = p then ; -; - +; * M1 = n and vice versa ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; ************************************************************************ - - (= - (neg - (: $F p) - (: $F n)) True) -; - - (= - (neg - (: $F n) - (: $F p)) True) -; - + (= (neg (: $F p) (: $F n)) True) + (= (neg (: $F n) (: $F p)) True) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: contains_duplicates/1 ; -; - +; * ; -; - +; * syntax: contains_duplicates(+L) ; -; - +; * ; -; - +; * args: L ... list ; -; - +; * ; -; - +; * description: succeeds if L contains two unifiable elements ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (contains-duplicates (Cons $H $T)) + (= (contains-duplicates (Cons $H $T)) (member $H $T)) -; - - (= - (contains-duplicates (Cons $_ $T)) + (= (contains-duplicates (Cons $_ $T)) (contains-duplicates $T)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: contains_identicals/1 ; -; - +; * ; -; - +; * syntax: contains_identicals(+L) ; -; - +; * ; -; - +; * args: L ... list ; -; - +; * ; -; - +; * description: succeeds if L contains two identical (==) elements ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; +; *********************************************************************** - - (= - (contains-identicals (Cons $H $T)) + (= (contains-identicals (Cons $H $T)) (contains-var $H $T)) -; - - (= - (contains-identicals (Cons $_ $T)) + (= (contains-identicals (Cons $_ $T)) (contains-identicals $T)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: identical_member/2 ; -; - +; * ; -; - +; * syntax: identical_member(+Elem,+List) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: succeeds if Elem is identically (==) contained in List ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (identical-member $A - (Cons $A1 $_)) - (== $A $A1)) -; - - (= - (identical-member $A - (Cons $_ $R)) - (identical-member $A $R)) -; - + (= (identical-member $A (Cons $A1 $_)) + (== $A $A1)) + (= (identical-member $A (Cons $_ $R)) + (identical-member $A $R)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: convert_to_horn_clause/3 ; -; - +; * ; -; - +; * syntax: convert_to_horn_clause(+PHead,+CL,-HCL) ; -; - +; * ; -; - +; * args: PHead ... preferred head ; -; - +; * CL ... general clause in list representation ; -; - +; * HCL ... horn clause in list representation ; -; - +; * ; -; - +; * description: if CL = [H1:p,..,Hn:p,L1:M1,..,Lm:Mm] where Mi in {p,r} ; -; - +; * then HCL = [Hj:p,L1:M1,...,Lm:Mm], where Hj is the first ; -; - +; * head in CL unifiable with PHead (if one exists), else ; -; - +; * the first head in CL ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (convert-to-horn-clause $PrefHead $GenClause $HornClause) - ( (extract-body $GenClause $Body) - (set-det) - (det-if-then-else - (member - (with_self $PrefHead - (p)) $GenClause) - (= $Head $PrefHead) - (member - (with_self $Head - (p)) $GenClause)) - (= $HornClause - (Cons - (with_self $Head - (p)) $Body)))) -; - + (= (convert-to-horn-clause $PrefHead $GenClause $HornClause) + (extract-body $GenClause $Body) + (set-det) + (det-if-then-else + (member + (with_self $PrefHead + (p)) $GenClause) + (= $Head $PrefHead) + (member + (with_self $Head + (p)) $GenClause)) + (= $HornClause + (Cons + (with_self $Head + (p)) $Body))) +; ; if preferred head is among +; ; candidates, select it. +; ; Else select first candidate. ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: extract_body/2 ; -; - +; * ; -; - +; * syntax: extract_body(+CL,-CL1) ; -; - +; * ; -; - +; * args: CL .. clause in list representation ; -; - +; * CL1 = [...,L:M,...] where M in {p,n} and L in CL ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (extract_body () ()) True) -; - - (= - (extract-body - (Cons - (with_self $L - (n)) $Rest) - (Cons - (with_self $L - (n)) $Rest1)) + (= (extract_body () ()) True) + (= (extract-body (Cons (with_self $L (n)) $Rest) (Cons (with_self $L (n)) $Rest1)) (extract-body $Rest $Rest1)) -; - - (= - (extract-body - (Cons - (with_self $L - (r)) $Rest) - (Cons - (with_self $L - (r)) $Rest1)) + (= (extract-body (Cons (with_self $L (r)) $Rest) (Cons (with_self $L (r)) $Rest1)) (extract-body $Rest $Rest1)) -; - - (= - (extract-body - (Cons - (with_self $_ - (p)) $Rest) $Rest1) + (= (extract-body (Cons (with_self $_ (p)) $Rest) $Rest1) (extract-body $Rest $Rest1)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: list_to_struct/2 ; -; - +; * ; -; - +; * syntax: list_to_struct(+L,-C) ; -; - +; * ; -; - +; * args: L ... list, C ... conjunction of elements of L ; -; - +; * ; -; - +; * description: if L = [E1,...,En] then C = (E1,..,En) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (list-to-struct - (Cons $A - (Cons $B $Rest)) - (, $A $Rest1)) + (= (list-to-struct (Cons $A (Cons $B $Rest)) (, $A $Rest1)) (list-to-struct (Cons $B $Rest) $Rest1)) -; - - (= - (list_to_struct - ($A) $A) True) -; - - (= - (list_to_struct () true) True) -; - + (= (list_to_struct ($A) $A) True) + (= (list_to_struct () true) True) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: clist_to_MeTTa/2 ; -; - +; * ; -; - +; * syntax: clist_to_MeTTa(+CL,-C) ; -; - +; * ; -; - +; * args: CL .. Horn clause in list representation ; -; - +; * C ... Horn clause in MeTTa format ; -; - +; * ; -; - +; * description: convert list format to clause format and vice versa ; -; - +; * (should use body2list!!) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= + (= (clist-to-prolog (Cons (with_self $A (p)) (Cons $B $Rest)) (= $A $Rest1)) + (set-det) (clist-to-prolog - (Cons - (with_self $A - (p)) - (Cons $B $Rest)) - (= $A $Rest1)) - ( (set-det) (clist-to-prolog (Cons $B $Rest) $Rest1))) -; - - (= - (clist-to-prolog - (:: (with_self $A (p))) - (= $A True)) + (Cons $B $Rest) $Rest1)) + (= (clist-to-prolog (:: (with_self $A (p))) (= $A True)) (set-det)) -; - - (= - (clist-to-prolog - (Cons - (with_self $A - (n)) - (Cons $B $Rest)) - (, $A $Rest1)) - ( (set-det) (clist-to-prolog (Cons $B $Rest) $Rest1))) -; - - (= + (= (clist-to-prolog (Cons (with_self $A (n)) (Cons $B $Rest)) (, $A $Rest1)) + (set-det) (clist-to-prolog - (:: (with_self $A (n))) $A) + (Cons $B $Rest) $Rest1)) + (= (clist-to-prolog (:: (with_self $A (n))) $A) (set-det)) -; - - (= - (clist-to-prolog - (Cons - (with_self $A - (r)) - (Cons $B $Rest)) - (, $A $Rest1)) + (= (clist-to-prolog (Cons (with_self $A (r)) (Cons $B $Rest)) (, $A $Rest1)) (clist-to-prolog (Cons $B $Rest) $Rest1)) -; - - (= - (clist_to_prolog - ( (: $A r)) $A) True) -; - + (= (clist_to_prolog ((: $A r)) $A) True) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: append_all/2 ; -; - +; * ; -; - +; * syntax: append_all(+LL,-L) ; -; - +; * ; -; - +; * args: LL .. list of lists, L .. list ; -; - +; * ; -; - +; * description: appends all lists in LL -> L ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (append_all () ()) True) -; - - (= - (append-all - (Cons $P $R) $R2) - ( (append-all $R $R1) (append $P $R1 $R2))) -; - + (= (append_all () ()) True) + (= (append-all (Cons $P $R) $R2) + (append-all $R $R1) + (append $P $R1 $R2)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: maximum/2 ; -; - +; * ; -; - +; * syntax: maximum(+L,-M) ; -; - +; * ; -; - +; * args: L .. list of numbers, M number ; -; - +; * ; -; - +; * description: M is the maximum element of L ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** + (= (maximum ($I) $I) True) - (= - (maximum - ($I) $I) True) -; - - - (= - (maximum - (Cons $I $Rest) $I) - ( (maximum $Rest $J) - (>= $I $J) - (set-det))) -; - + (= (maximum (Cons $I $Rest) $I) + (maximum $Rest $J) + (>= $I $J) + (set-det)) - (= - (maximum - (Cons $_ $Rest) $J) - ( (maximum $Rest $J) (set-det))) -; - + (= (maximum (Cons $_ $Rest) $J) + (maximum $Rest $J) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: myforall/2 ; -; - +; * ; -; - +; * syntax: myforall(+E,+Pred) ; -; - +; * ; -; - +; * args: E ... argument terms, Pred .. type predicate ; -; - +; * ; -; - +; * description: calls Pred(e) for each e in E, and succeeds only if ; -; - +; * every call succeeds ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (myforall () $_) True) -; +; *********************************************************************** - (= - (myforall - (Cons $E $R) $Pred) - ( (=.. $C - (:: $Pred $E)) - (call $C) - (myforall $R $Pred))) -; + (= (myforall () $_) True) + (= (myforall (Cons $E $R) $Pred) + (=.. $C + (:: $Pred $E)) + (call $C) + (myforall $R $Pred)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: identical_make_unique/2 ; -; - +; * ; -; - +; * syntax: identical_make_unique(+L,-L1) ; -; - +; * ; -; - +; * args: L,L1 ... lists ; -; - +; * ; -; - +; * description: removes all identical duplicates (==) from L ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (identical_make_unique () ()) True) -; - - (= - (identical-make-unique - (Cons $X $R) $R1) - ( (contains-var $X $R) - (set-det) - (identical-make-unique $R $R1))) -; - - (= - (identical-make-unique - (Cons $X $R) - (Cons $X $R1)) - (identical-make-unique $R $R1)) -; - + (= (identical_make_unique () ()) True) + (= (identical-make-unique (Cons $X $R) $R1) + (contains-var $X $R) + (set-det) + (identical-make-unique $R $R1)) + (= (identical-make-unique (Cons $X $R) (Cons $X $R1)) + (identical-make-unique $R $R1)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: remove_v/3 ; -; - +; * ; -; - +; * syntax: remove_v(+L0,+L,-L1) ; -; - +; * ; -; - +; * args: L0,L,L1 lists ; -; - +; * ; -; - +; * description: removes each E in L0 from L if E is identically (==) ; -; - +; * contained in L ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (remove_v $_ () ()) True) -; - (= - (remove-v $T - (Cons $T1 $R) $R1) - ( (identical-member $T1 $T) - (set-det) - (remove-v $T $R $R1))) -; - - (= - (remove-v $T - (Cons $T1 $R) - (Cons $T1 $R1)) + (= (remove_v $_ () ()) True) + (= (remove-v $T (Cons $T1 $R) $R1) + (identical-member $T1 $T) + (set-det) + (remove-v $T $R $R1)) + (= (remove-v $T (Cons $T1 $R) (Cons $T1 $R1)) (remove-v $T $R $R1)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: remove_variant/3 ; -; - +; * ; -; - +; * syntax: remove_variant(+L0,+L,-L1) ; -; - +; * ; -; - +; * args: L0,L,L1 lists ; -; - +; * ; -; - +; * description: removes each E in L0 from L if E is ; -; - +; * contained as variant in L ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (remove_variant $_ () ()) True) -; - (= - (remove-variant $T - (Cons $T1 $R) $R1) - ( (variant-mem $T1 $T) - (set-det) - (remove-variant $T $R $R1))) -; - - (= - (remove-variant $T - (Cons $T1 $R) - (Cons $T1 $R1)) + (= (remove_variant $_ () ()) True) + (= (remove-variant $T (Cons $T1 $R) $R1) + (variant-mem $T1 $T) + (set-det) + (remove-variant $T $R $R1)) + (= (remove-variant $T (Cons $T1 $R) (Cons $T1 $R1)) (remove-variant $T $R $R1)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: make_unique/2 ; -; - +; * ; -; - +; * syntax: make_unique(+L,-L1) ; -; - +; * ; -; - +; * args: L,L1 .. lists ; -; - +; * ; -; - +; * description: removes all duplicates (variant) from L ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (make_unique () ()) True) -; - - (= - (make-unique - (Cons $X $R) $R1) - ( (variant-mem $X $R) - (set-det) - (make-unique $R $R1))) -; - - (= - (make-unique - (Cons $X $R) - (Cons $X $R1)) + (= (make_unique () ()) True) + (= (make-unique (Cons $X $R) $R1) + (variant-mem $X $R) + (set-det) + (make-unique $R $R1)) + (= (make-unique (Cons $X $R) (Cons $X $R1)) (make-unique $R $R1)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: variant_mem/2 ; -; - +; * ; -; - +; * syntax: variant_mem(+Elem,+List) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: succeeds if an alphabetical variant of Elem is ; -; - +; * contained in List ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (variant-mem $T - (Cons $T1 $_)) - ( (variant $T $T1) (set-det))) -; - - (= - (variant-mem $T - (Cons $_ $R)) + (= (variant-mem $T (Cons $T1 $_)) + (variant $T $T1) + (set-det)) + (= (variant-mem $T (Cons $_ $R)) (variant-mem $T $R)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: different_predicates/2 ; -; - +; * ; -; - +; * syntax: different_predicates(+L,-LL) ; -; - +; * ; -; - +; * args: L .. list of terms, LL list of lists of terms ; -; - +; * ; -; - +; * description: for each functor f/n occuring in L, LL contains a list Lf ; -; - +; * consisting of all terms in L with principal functor f/n ; -; - +; * ; -; - -; -; - -; -; - -; -; - -; -; - +; * example: L = [f(a,b),f(c,d),h(g)] LL = [[f(a,b),f(c,d)],[h(g)]] ; -; - -; -; - - - - (= - (different_predicates () ()) True) -; - - (= - (different-predicates - (Cons $E $R) - (Cons - (Cons $E $Es) $R2)) - ( (functor $E $F $N) - (diff-predicates $R $R1 $Es $F $N) - (different-predicates $R1 $R2))) -; - - +; * +; +; * peculiarities: none +; +; * +; +; * see also: +; +; * +; +; *********************************************************************** - (= - (diff_predicates () () () $_ $_) True) -; - (= - (diff-predicates - (Cons $E $R) $R2 $Es2 $_ 0) - ( (set-det) - (diff-predicates $R $R1 $Es1 $_ 0) - (det-if-then-else - (functor $E $_ 0) - (, - (= $R2 $R1) - (= $Es2 - (Cons $E $Es1))) - (, - (= $R2 - (Cons $E $R1)) - (= $Es2 $Es1))))) -; + (= (different_predicates () ()) True) + (= (different-predicates (Cons $E $R) (Cons (Cons $E $Es) $R2)) + (functor $E $F $N) + (diff-predicates $R $R1 $Es $F $N) + (different-predicates $R1 $R2)) - (= - (diff-predicates - (Cons $E $R) $R2 $Es2 $F $N) - ( (diff-predicates $R $R1 $Es1 $F $N) (det-if-then-else (functor $E $F $N) (, (= $R2 $R1) (= $Es2 (Cons $E $Es1))) (, (= $R2 (Cons $E $R1)) (= $Es2 $Es1))))) -; + (= (diff_predicates () () () $_ $_) True) + (= (diff-predicates (Cons $E $R) $R2 $Es2 $_ 0) + (set-det) + (diff-predicates $R $R1 $Es1 $_ 0) + (det-if-then-else + (functor $E $_ 0) + (, + (= $R2 $R1) + (= $Es2 + (Cons $E $Es1))) + (, + (= $R2 + (Cons $E $R1)) + (= $Es2 $Es1)))) + (= (diff-predicates (Cons $E $R) $R2 $Es2 $F $N) + (diff-predicates $R $R1 $Es1 $F $N) + (det-if-then-else + (functor $E $F $N) + (, + (= $R2 $R1) + (= $Es2 + (Cons $E $Es1))) + (, + (= $R2 + (Cons $E $R1)) + (= $Es2 $Es1)))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: nth_arg/3 ; -; - +; * ; -; - +; * syntax: nth_arg(+E,+N,-Args) ; -; - +; * ; -; - +; * args: E ... list of terms with principal functor p/n ; -; - +; * N =< n argument position ; -; - +; * Args ... list of argument terms ; -; - +; * ; -; - +; * description: Args = {A | arg(N,P,A) and P in E} ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (nth_arg () $_ ()) True) -; - - (= - (nth-arg - (Cons $F $R) $N - (Cons $Argn $R1)) - ( (arg $N $F $Argn) (nth-arg $R $N $R1))) -; - + (= (nth_arg () $_ ()) True) + (= (nth-arg (Cons $F $R) $N (Cons $Argn $R1)) + (arg $N $F $Argn) + (nth-arg $R $N $R1)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: split_examples/4 ; -; - +; * ; -; - +; * syntax: split_examples(+E,+Term,-P,-N) ; -; - +; * ; -; - +; * args: E,P,N ... list of terms ; -; - +; * ; -; - +; * description: P = {e in E | Term, e unifiable} ; -; - +; * N = E - P ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (split-examples - (Cons $E1 $R) $Lgg $P - (Cons $E1 $M1)) - ( (not (= $E1 $Lgg)) - (split-examples $R $Lgg $P $M1) - (set-det))) -; - - - (= - (split-examples - (Cons $E1 $R) $Lgg - (Cons $E1 $P) $M1) - ( (split-examples $R $Lgg $P $M1) (set-det))) -; - + (= (split-examples (Cons $E1 $R) $Lgg $P (Cons $E1 $M1)) + (not (= $E1 $Lgg)) + (split-examples $R $Lgg $P $M1) + (set-det)) - (= - (split-examples Nil $_ Nil Nil) + (= (split-examples (Cons $E1 $R) $Lgg (Cons $E1 $P) $M1) + (split-examples $R $Lgg $P $M1) (set-det)) -; + (= (split-examples Nil $_ Nil Nil) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: shares_var/2 ; -; - +; * ; -; - +; * syntax: shares_var(+T,+Ts) ; -; - +; * ; -; - +; * args: T: a term or a clause,Ts: a list of terms or clauses ; -; - +; * ; -; - +; * description: tests if T shares at least one variable ; -; - +; * with the terms in t ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (shares-var $T $Ts) - ( (sub-term $V $T) - (var $V) - (contains-var $V $Ts))) -; + (= (shares-var $T $Ts) + (sub-term $V $T) + (var $V) + (contains-var $V $Ts)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: body2list/2 ; -; - +; * ; -; - +; * syntax: body2list(?B,?BList) ; -; - +; * ; -; - +; * args: B: Body of a clause (L1,...,Ln) ; -; - +; * BList: [L1:x,...,Ln:x] where x is in {r,n} ; -; - +; * ; -; - +; * description: transforms a clause body to a list of its literals ; -; - +; * where each literal is augmented by :n (i.e. negative clause literal) ; -; - +; * or :r (i.e. recursive goal in the clause body). ; -; - +; * works in both directions ; -; - +; * ; -; - +; * example: (p(x,y),q(z,w)),[(p(x,y):r,q(z,w):r] ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (body2list $B - (Cons - (with_self $L1 - (n)) $RestL)) - ( (functor $B , 2) - (arg 1 $B $L1) - (arg 2 $B $RestB) - (body2list $RestB $RestL))) -; - - (= - (body2list $B - (:: (with_self $B (n)))) + (= (body2list $B (Cons (with_self $L1 (n)) $RestL)) + (functor $B , 2) + (arg 1 $B $L1) + (arg 2 $B $RestB) + (body2list $RestB $RestL)) + (= (body2list $B (:: (with_self $B (n)))) (set-det)) -; - - (= - (body2list $B - (Cons - (with_self $L1 - (r)) $RestL)) - ( (functor $B , 2) - (arg 1 $B $L1) - (arg 2 $B $RestB) - (body2list $RestB $RestL))) -; - - (= - (body2list $B - (:: (with_self $B (r)))) + (= (body2list $B (Cons (with_self $L1 (r)) $RestL)) + (functor $B , 2) + (arg 1 $B $L1) + (arg 2 $B $RestB) + (body2list $RestB $RestL)) + (= (body2list $B (:: (with_self $B (r)))) (set-det)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: insert_unique/3 ; -; - +; * ; -; - +; * syntax: insert_unique(+N,+L,-L1) ; -; - +; * ; -; - +; * args: N .. number, L,L1 sorted lists of numbers ; -; - +; * ; -; - +; * description: inserts N uniquely in the ascendingly sorted list L ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (insert-unique $I - (Cons $I $R) - (Cons $I $R)) + (= (insert-unique $I (Cons $I $R) (Cons $I $R)) (set-det)) -; - - (= - (insert-unique $I - (Cons $J $R) - (Cons $J $R1)) - ( (> $I $J) - (set-det) - (insert-unique $I $R $R1))) -; - - (= - (insert_unique $I $L - (Cons $I $L)) True) -; - + (= (insert-unique $I (Cons $J $R) (Cons $J $R1)) + (> $I $J) + (set-det) + (insert-unique $I $R $R1)) + (= (insert_unique $I $L (Cons $I $L)) True) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: insert_unique/4 ; -; - +; * ; -; - +; * syntax: insert_unique(+ID,+A,+L,-L1) ; -; - +; * ; -; - +; * args: ID,A .. numbers, L,L1 = [...,ID:List,...] ; -; - +; * ; -; - +; * description: inserts A in the sublist identified by ID in L ; -; - +; * ; -; - +; * example: insert_unique(2,5,[1:[5,6],2:[4],3:[9,8]], ; -; - +; * [1:[5,6],2:[5,4],3:[9,8]]) ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (insert-unique $I $A Nil - (:: (with_self $I (:: $A)))) + (= (insert-unique $I $A Nil (:: (with_self $I (:: $A)))) (set-det)) -; - - (= - (insert-unique $I $A - (Cons - (with_self $I $A1) $R) - (Cons - (with_self $I - (Cons $A $A1)) $R)) + (= (insert-unique $I $A (Cons (with_self $I $A1) $R) (Cons (with_self $I (Cons $A $A1)) $R)) (set-det)) -; - - (= - (insert-unique $I $A - (Cons $J $R) - (Cons $J $R1)) + (= (insert-unique $I $A (Cons $J $R) (Cons $J $R1)) (insert-unique $I $A $R $R1)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: genterm_test/3 ; -; - +; * ; -; - +; * syntax: genterm_test(+X/T,+Subst) ; -; - +; * ; -; - +; * args: X/T element of a substitution, Subst substitution ; -; - +; * ; -; - +; * description: succeeds if Subst contains a tuple Y/T1 such that ; -; - +; * T1 == T. In that case, X and Y are unified. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (genterm-test - (/ $X $T1) - (Cons - (/ $X $T2) $_)) - ( (== $T1 $T2) (set-det))) -; - - (= - (genterm-test $S - (Cons $_ $Rest)) + (= (genterm-test (/ $X $T1) (Cons (/ $X $T2) $_)) + (== $T1 $T2) + (set-det)) + (= (genterm-test $S (Cons $_ $Rest)) (genterm-test $S $Rest)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: subset_chk/2 ; -; - +; * ; -; - +; * syntax: subset_chk(+L,+L1) ; -; - +; * ; -; - +; * args: L, L1 .. lists ; -; - +; * ; -; - +; * description: succeeds, if L is a subset of L1 (without unification) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - +; subset check uses library 'basics' - (= - (subset-chk Nil $_) + (= (subset-chk Nil $_) (set-det)) -; - - (= - (subset-chk - (Cons $Elem1 $Rest1) $List2) - ( (identical-member $Elem1 $List2) - (set-det) - (subset-chk $Rest1 $List2))) -; - + (= (subset-chk (Cons $Elem1 $Rest1) $List2) + (identical-member $Elem1 $List2) + (set-det) + (subset-chk $Rest1 $List2)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: subterm_at_position/4 ; -; - +; * ; -; - +; * syntax: subterm_at_position(+Term,-Sub,+Pos,-Pos) ; -; - +; * ; -; - +; * args: Term, Sub: MeTTa terms ; -; - +; * Pos: position of Sub within Term (a list of numbers) ; -; - +; * ; -; - +; * description: returns a subterm of Term and its position, on backtracking ; -; - +; * further subterms ; -; - +; * ; -; - +; * example: ?- subterm_at_position(p(a,[a]),S,[],P). ; -; - +; * S = p(a,[a]), P = []; ; -; - +; * S = a P = [1]; ; -; - +; * S = [a] P = [2]; ; -; - +; * S = a P = [2,1]; ; -; - +; * S = [] P = [2,2] ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (subterm-at-position $T $T $P $P1) + (= (subterm-at-position $T $T $P $P1) (rev $P $P1)) -; - - (= - (subterm-at-position $T $S $P $P1) - ( (nonvar $T) - (functor $T $_ $N) - (> $N 0) - (subterm-at-position $N $T $S $P $P1))) -; - - - (= - (subterm-at-position $N $T $S $P $P1) - ( (> $N 0) - (arg $N $T $Tn) - (subterm-at-position $Tn $S - (Cons $N $P) $P1))) -; - - (= - (subterm-at-position $N $T $S $P $P1) - ( (> $N 0) - (is $N1 - (- $N 1)) - (subterm-at-position $N1 $T $S $P $P1))) -; + (= (subterm-at-position $T $S $P $P1) + (nonvar $T) + (functor $T $_ $N) + (> $N 0) + (subterm-at-position $N $T $S $P $P1)) + (= (subterm-at-position $N $T $S $P $P1) + (> $N 0) + (arg $N $T $Tn) + (subterm-at-position $Tn $S + (Cons $N $P) $P1)) + (= (subterm-at-position $N $T $S $P $P1) + (> $N 0) + (is $N1 + (- $N 1)) + (subterm-at-position $N1 $T $S $P $P1)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: part_of_clause/2 ; -; - +; * ; -; - +; * syntax: part_of_clause(+Term,+Clause) ; -; - +; * ; -; - +; * args: Term: a MeTTa term, Clause: a MeTTa clause ; -; - +; * ; -; - +; * description: succeeds if Term is a literal within clause, a part ; -; - +; * of the clause body or the clause itself ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (part-of-clause $S $B) + (= (part-of-clause $S $B) (== $S $B)) -; - - (= - (part-of-clause $S - (= $H $B)) - ( (set-det) (det-if-then-else (or (== $S $H) (== $S $B)) True (part-of-clause $S $B)))) -; - - (= - (part-of-clause $S - (, $H $B)) - ( (set-det) (det-if-then-else (or (== $S $H) (== $S $B)) True (part-of-clause $S $B)))) -; - + (= (part-of-clause $S (= $H $B)) + (set-det) + (det-if-then-else + (or + (== $S $H) + (== $S $B)) True + (part-of-clause $S $B))) + (= (part-of-clause $S (, $H $B)) + (set-det) + (det-if-then-else + (or + (== $S $H) + (== $S $B)) True + (part-of-clause $S $B))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: several arithmetic predicates ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: arithmetic predicates used in heuristic measures ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - - (= - (fak $X 1) - ( (=:= $X 0) (set-det))) -; - - (= - (fak $N $NF) - ( (is $N1 - (- $N 1)) - (fak $N1 $N1F) - (is $NF - (* $N1F $N)))) -; +; *********************************************************************** - (= - (fak1 $N $N 1) + (= (fak $X 1) + (=:= $X 0) (set-det)) -; + (= (fak $N $NF) + (is $N1 + (- $N 1)) + (fak $N1 $N1F) + (is $NF + (* $N1F $N))) - (= - (fak1 $A $B $C) - ( (is $A1 - (+ $A 1)) - (fak1 $A1 $B $C1) - (is $C - (* $C1 $A1)))) -; + (= (fak1 $N $N 1) + (set-det)) + (= (fak1 $A $B $C) + (is $A1 + (+ $A 1)) + (fak1 $A1 $B $C1) + (is $C + (* $C1 $A1))) - (= - (nueberk $N $K $NUK) - ( (is $NK - (- $N $K)) - (fak1 $NK $N $NKF) - (fak $K $KF) - (is $NUK - (/ $NKF $KF)))) -; - - + (= (nueberk $N $K $NUK) + (is $NK + (- $N $K)) + (fak1 $NK $N $NKF) + (fak $K $KF) + (is $NUK + (/ $NKF $KF))) - (= - (log2 $X $LX) - ( (log $X $LNX) - (log 2 $LN2) - (is $LX - (/ $LNX $LN2)))) -; + (= (log2 $X $LX) + (log $X $LNX) + (log 2 $LN2) + (is $LX + (/ $LNX $LN2))) - (= - (log2nueberk $_ 0.0 0.0) + (= (log2nueberk $_ 0.0 0.0) (set-det)) -; - - (= - (log2nueberk $N 1.0 $LN) - ( (log2 $N $LN) (set-det))) -; - - (= - (log2nueberk $N $N 0.0) + (= (log2nueberk $N 1.0 $LN) + (log2 $N $LN) (set-det)) -; - - (= - (log2nueberk $N $K $L) - ( (is $N1 - (+ - (- $N $K) 1)) - (sum-of-logs $N1 $N $L1) - (sum-of-logs 1.0 $K $L2) - (is $L - (- $L1 $L2)))) -; - - - - (= - (sum-of-logs $O $O $LO) - ( (log2 $O $LO) (set-det))) -; - - (= - (sum-of-logs $U $O $L) - ( (< $U $O) - (set-det) - (is $U1 - (+ $U 1)) - (sum-of-logs $U1 $O $L1) - (log2 $U $LU) - (is $L - (+ $L1 $LU)))) -; - - (= - (sum-of-logs $U $O $_) - ( (> $U $O) - (set-det) - (fail))) -; - + (= (log2nueberk $N $N 0.0) + (set-det)) + (= (log2nueberk $N $K $L) + (is $N1 + (+ + (- $N $K) 1)) + (sum-of-logs $N1 $N $L1) + (sum-of-logs 1.0 $K $L2) + (is $L + (- $L1 $L2))) + + + (= (sum-of-logs $O $O $LO) + (log2 $O $LO) + (set-det)) + (= (sum-of-logs $U $O $L) + (< $U $O) + (set-det) + (is $U1 + (+ $U 1)) + (sum-of-logs $U1 $O $L1) + (log2 $U $LU) + (is $L + (+ $L1 $LU))) + (= (sum-of-logs $U $O $_) + (> $U $O) + (set-det) + (fail)) diff --git a/miles/dmiles.metta b/miles/dmiles.metta index 7048979..52311ed 100644 --- a/miles/dmiles.metta +++ b/miles/dmiles.metta @@ -1,378 +1,245 @@ +; (convert_to_metta_file dmiles $_341450 miles/dmiles.pl miles/dmiles.metta) !(use-module (library logicmoo-utils)) -; - !(multifile (/ file-search-path 2)) -; - !(dynamic (/ file-search-path 2)) -; - - (= - (ensure-loaded-if-exists $X) + (= (ensure-loaded-if-exists $X) (det-if-then-else (exists-source $X) (with_self (system *) (ensure-loaded $X)) (dmsg (ensure-loaded-if-exists $X)))) -; - - (= - (use-module-if-exists $X) + (= (use-module-if-exists $X) (det-if-then-else (exists-source $X) (with_self (system *) (use-module $X)) (dmsg (use-module-if-exists $X)))) -; - - (= - (use-module-if-exists $X $Y) + (= (use-module-if-exists $X $Y) (det-if-then-else (exists-source $X) (with_self (system *) (use-module $X $Y)) (dmsg (use-module-if-exists $X $Y)))) -; - - !((prolog-load-context directory $Dir) (add-symbol &self (file_search_path home $Dir))) -; + !((prolog-load-context directory $Dir) (add-is-symbol &self (file_search_path home $Dir))) +; ;;;;set appropriately! - - (= - (rev $A $B) + (= (rev $A $B) (rev $A $B Nil)) -; - - (= - (rev Nil $B $B) + (= (rev Nil $B $B) (set-det)) -; - - (= - (rev - (Cons $X $A) $B $C) + (= (rev (Cons $X $A) $B $C) (rev $A $B (Cons $X $C))) -; - - - (= - (nonmember $Arg - (Cons $Arg $_)) - ( (set-det) (fail))) -; - - (= - (nonmember $Arg - (Cons $_ $Tail)) - ( (set-det) (nonmember $Arg $Tail))) -; - - (= - (nonmember $_ ()) True) -; + (= (nonmember $Arg (Cons $Arg $_)) + (set-det) + (fail)) + (= (nonmember $Arg (Cons $_ $Tail)) + (set-det) + (nonmember $Arg $Tail)) + (= (nonmember $_ ()) True) ; -; - +; writes Question (using write/1) to the terminal, regardless of the current output stream, and reads an answer. The prompt is followed by ? , so you should not put a question mark in the question yourself. The answer is the first character typed in response; anything following on the same line will be thrown away. If the answer is y or Y, yesno/1 succeeds. If the answer is n or N, yesno/1 fails. Otherwise it repeats the question. The user has to explicitly type a y or n before it will stop. Because the rest of the line is thrown away, the user can type yes, Yes, You'd better not, and so forth with exactly the same effect as a plain y. If the user just presses , that is not taken as yes. - (= - (yesno $Question) + (= (yesno $Question) (yesno $Question no)) -; - - (= - (yesno $Question $Default) - ( (format '~N~w? (~w): ' - (:: $Question $Default)) - (get-single-char $YN) - (det-if-then-else - (= $YN 13) - (== $Default yes) - (member $YN - (:: 121 89))))) -; - + (= (yesno $Question $Default) + (format '~N~w? (~w): ' + (:: $Question $Default)) + (get-single-char $YN) + (det-if-then-else + (= $YN 13) + (== $Default yes) + (member $YN + (:: 121 89)))) ; -; - +; is like yesno/1 except that ; -; - +; Default may be an atom (the first character of whose name will be used), a string (whose first character will be used) or an ASCII code, and will be written in brackets before the question mark; and ; -; - +; if the user just presses , Default will be used as the answer. ; -; - +; For example, yesno('Do you want an extended trace', yes) ; -; - - - (= - (ask-chars $Label $S $E $Answer) - ( (repeat) - (format '~N~w: ?' - (:: $Label)) - (read-line-to-string-echo current-input $Answer) - (atom-length $Answer $Len) - (det-if-then-else - (between $S $E $Len) - (set-det) - (, - (format "~NPlease enter between ~w and ~w characters.~n" - (:: $S $E)) - (fail))))) -; - +; prints Do you want an extended trace [yes]? _ + + (= (ask-chars $Label $S $E $Answer) + (repeat) + (format '~N~w: ?' + (:: $Label)) + (read-line-to-string-echo current-input $Answer) + (atom-length $Answer $Len) + (det-if-then-else + (between $S $E $Len) + (set-det) + (, + (format "~NPlease enter between ~w and ~w characters.~n" + (:: $S $E)) + (fail)))) +; /* ask_chars(+Prompt, +MinLength, +MaxLength, -Answer) writes Prompt to the terminal, and reads a line of characters from it. This response must contain between MinLength and MaxLength characters inclusive, otherwise the question will be repeated until an answer of satisfactory length is obtained. Leading and/or trailing layout characters are retained in the result, and are counted when determining the length of the answer. The list of character codes read is unified with Answer. Note that a colon and a space (: ) are added to the Prompt, so don't add such punctuation yourself. The end-user can find out what sort of input is required by typing a line that starts with a question mark. Therefore it is not possible to read such a line as data. See prompted_line/2 in library(prompt). Examples: | ?- ask_chars('Label', 1, 8, Answer). Label: 213456789 Please enter between 1 and 8 characters. Do not add a full stop unless it is part of the answer. Label: four Answer = "four" | ?- ask_chars('Heading', 1, 30, Answer). Heading: ? Please enter between 1 and 30 characters. Do not add a full stop unless it is part of the answer. Heading: three leading spaces Answer = " three leading spaces" */ - (= - (unify $X $Y) + (= (unify $X $Y) (unify-with-occurs-check $X $Y)) -; - !(use-module-if-exists (library ordsets)) -; - - (= - (union $X $Y) + (= (union $X $Y) (ord-union $X $Y)) -; - ; -; - - - - (= - ($list-skel $V) - ( (var $V) - (set-det) - (fail))) -; +; subseq(X,Y,Z):- ord_union(X,Y). - (= - (%list_skel ()) True) -; - (= - ($list-skel (Cons $_ $L)) + (= ($list-skel $V) + (var $V) + (set-det) + (fail)) + (= (%list_skel ()) True) + (= ($list-skel (Cons $_ $L)) ($list-skel $L)) -; - ; -; - - - (= - (subseq $AB $A $B) - ( ($list-skel $AB) - (set-det) - ($subseq $AB $A $B))) -; +; subseq(Sequence1, SubSequence2, Complement):- - (= - (subseq $AB $A $B) - ( ($list-skel $A) - ($list-skel $B) - (set-det) - ($subseq $AB $A $B))) -; - - (= - (subseq $AB $A $B) + (= (subseq $AB $A $B) + ($list-skel $AB) + (set-det) + ($subseq $AB $A $B)) + (= (subseq $AB $A $B) + ($list-skel $A) + ($list-skel $B) + (set-det) + ($subseq $AB $A $B)) + (= (subseq $AB $A $B) (throw ('instantiation error' $AB $A))) -; - - (= - ($subseq () () ()) True) -; - - (= - ($subseq - (Cons $X $AB) $A - (Cons $X $B)) + (= (%subseq () () ()) True) + (= ($subseq (Cons $X $AB) $A (Cons $X $B)) ($subseq $AB $A $B)) -; - - (= - ($subseq - (Cons $X $AB) - (Cons $X $A) $B) + (= ($subseq (Cons $X $AB) (Cons $X $A) $B) ($subseq $AB $A $B)) -; - - (= - (subseq0 $AB $A) - ( ($list-skel $AB) - (set-det) - ($subseq $AB $A $_))) -; - - (= - (subseq0 $AB $A) + (= (subseq0 $AB $A) + ($list-skel $AB) + (set-det) + ($subseq $AB $A $_)) + (= (subseq0 $AB $A) (throw ('instantiation error' $AB $A))) -; - - (= - (subseq1 $AB $A) - ( ($list-skel $AB) - (set-det) - ($subseq $AB $A $_) - (\== $A $AB))) -; - - (= - (subseq1 $AB $A) + (= (subseq1 $AB $A) + ($list-skel $AB) + (set-det) + ($subseq $AB $A $_) + (\== $A $AB)) + (= (subseq1 $AB $A) (throw ('instantiation error' $AB $A))) -; - - (= - (string-append $A $B $C) + (= (string-append $A $B $C) (string-concat $A $B $C)) -; - - (= - (save-predicates $List $Filename) - ( (tell $Filename) - (listing $List) - (told))) -; - + (= (save-predicates $List $Filename) + (tell $Filename) + (listing $List) + (told)) ; -; - +; basics ; -; - +; Succeeds when SubSequence and Complement are both subsequences of the list Sequence (the order of corresponding elements being preserved) and every element of Sequence which is not in SubSequence is in the Complement and vice versa. That is, - (= - (prompt $X) + (= (prompt $X) (format '~N~w ' - (:: $X))) -; - + (:: $X))) !(expects-dialect sicstus) -; - - (= - (do-full-kb $KB) - ( (clear-kb) - (init-kb $KB) - (forall - (nth-clause do-full-kb1 $Index $_) - (do-full-kb $_ $Index)))) -; + (= (do-full-kb $KB) + (clear-kb) + (init-kb $KB) + (forall + (nth-clause do-full-kb1 $Index $_) + (do-full-kb $_ $Index))) + (= (do-full-kb $KB $Index) + (nth-clause do-full-kb1 $Index $Ref) + (clause do-full-kb1 $Goal $Ref) + (do-full-kb $KB $Index $Goal)) - (= - (do-full-kb $KB $Index) - ( (nth-clause do-full-kb1 $Index $Ref) - (clause do-full-kb1 $Goal $Ref) - (do-full-kb $KB $Index $Goal))) -; - - - (= - (do-full-kb $KB $Index $Goal) + (= (do-full-kb $KB $Index $Goal) (once (, (ignore (, (nonvar $KB) (clear-kb) (init-kb $KB))) (format ~N=================== Nil) (format '~N======= Nth: ~w ~p =======' (:: $Index $Goal)) (format ~N===================~n Nil) (show-kb) (catch (do-full-call-each $Goal) $E (, (dumpST) (throw $E))) (show-kb) (format '~N==== DONE: ~w ========~n~n' (:: $Index))))) -; - - - - (= - (do-full-call-each (, $G1 $G2)) - ( (set-det) - (do-full-call-each $G1) - (do-full-call-each $G2))) -; - (= - (do-full-call-each (det-if-then $G1 $G2)) - ( (not (not (, (wdmsg (do-call (det-if-then $G1 (= $G2 $Vars)))) (my-do-call $G1) (set-det) (term-variables $G2 $Vars) (my-do-call $G2) (set-det) (wdmsg (did-call (+ $Vars)))))) (set-det))) -; - - (= - (do-full-call-each $G1) - ( (= $G2 True) - (not (not (, (wdmsg (do-call (det-if-then $G1 (= $G2 $Vars)))) (my-do-call $G1) (set-det) (term-variables $G2 $Vars) (my-do-call $G2) (set-det) (wdmsg (did-call (+ $Vars)))))) - (set-det))) -; + (= (do-full-call-each (, $G1 $G2)) + (set-det) + (do-full-call-each $G1) + (do-full-call-each $G2)) + (= (do-full-call-each (det-if-then $G1 $G2)) + (not (not (, (wdmsg (do-call (det-if-then $G1 (= $G2 $Vars)))) (my-do-call $G1) (set-det) (term-variables $G2 $Vars) (my-do-call $G2) (set-det) (wdmsg (did-call (+ $Vars)))))) + (set-det)) + (= (do-full-call-each $G1) + (= $G2 True) + (not (not (, (wdmsg (do-call (det-if-then $G1 (= $G2 $Vars)))) (my-do-call $G1) (set-det) (term-variables $G2 $Vars) (my-do-call $G2) (set-det) (wdmsg (did-call (+ $Vars)))))) + (set-det)) ; -; +; my_do_call(G):- !, must_or_rtrace(G). - - (= - (my-do-call $G) + (= (my-do-call $G) (notrace (ignore (catch $G $_ True)))) -; - - - - (= - (do-full-kb1) - ( (argument-types) - (show-kb) - (complete-chk) - (ip $A) - (clause-heads) - (eval-examples) - (show-kb) - (complete-chk) - (correct-chk) - (fp $A) - (refinement $ID $_) - (flatten-kb))) -; - ; -; - - - (= - (do-full-kb1) + + + (= (do-full-kb1) + (argument-types) + (show-kb) + (complete-chk) + (ip $A) + (clause-heads) + (eval-examples) + (show-kb) + (complete-chk) + (correct-chk) + (fp $A) + (refinement $ID $_) + (flatten-kb)) +; ;; Antwort: no +; ;; gibt alle unabgedeckten Bsple zur"uck +; ;; geht jetzt gut +; ;; gibt inkorrekte Klausel(n) + ihre Instantiierung(en) zur"uck +; ;; in der Form [ID:[Instanz]] +; ;; wobei ID der der inkorrekten Klausel ist -> gibt +; ;; Spezialisierungen dieser Klausel (in einer Liste) ; +; ; kb funktionsfrei machen + + (= (do-full-kb1) (det-if-then (intra-construct1 1 2 $A $B $C) (det-if-then @@ -389,11 +256,9 @@ (show-clause $J) (apply-g2 (:: 4 5 10) $A $BB)))))) -; - +; ;; stellt Fragen - (= - (do-full-kb1) + (= (do-full-kb1) (det-if-then (, (intra-construct1 10 11 $A $B $C) @@ -408,11 +273,8 @@ (show-kb) (lgg 7 9 $J)) (show-clause $J))) -; - - (= - (do-full-kb1) + (= (do-full-kb1) (det-if-then (nr-lgg 7 9 $J) (, @@ -421,11 +283,8 @@ (reduce-complete $CL $CL1) (store-clause $_ $CL1 nrlgg $I) (show-clause $I)))) -; - - (= - (do-full-kb1) + (= (do-full-kb1) (det-if-then (gen-msg 5 6 $J 10) (det-if-then @@ -433,20 +292,14 @@ (show-clause $J) (gti 8 9 $J)) (show-clause $J)))) -; - - (= - (do-full-kb1) + (= (do-full-kb1) (det-if-then (rlgg 5 6 $J) (show-clause $J))) -; - - (= - (do-full-kb1) + (= (do-full-kb1) (det-if-then (lgg 1 2 $J) (det-if-then @@ -496,34 +349,25 @@ (show-clauses (:: 14 15 $A $B $C)) (intra-construct2 16 17 $A $B $C)) (show-clauses (:: 16 17 $A $B $C))))))))))))))) -; - +; ; erlaubt backtracking! ; -; - +; ; Sei ID1 der der Klausel: ; -; - +; ; app(A,B,C) :- cons_p(D,E,A),x_p(D),cons_p(F,G,E),a_p(F),nil_p(G), ; -; - +; ; cons_p(H,I,B),b_p(H),cons_p(J,G,I),c_p(J),cons_p(D,K,C),cons_p(F,B,K), ; -; - +; ; ID2 der der Klausel: ; -; - +; ; app(A,B,C) :- cons_p(D,E,A),a_p(D),nil_p(E), ; -; - +; ; cons_p(F,G,B),b_p(F),cons_p(H,E,G),c_p(H),cons_p(D,B,C), ; -; - - (= - (do-full-kb1) +; Dann teste: + (= (do-full-kb1) (det-if-then (absorb $ID1 $ID2 $J) (det-if-then @@ -538,8 +382,6 @@ (show-clause $J2) (unflatten-kb) (set-det)))))) -; - diff --git a/miles/environment.metta b/miles/environment.metta index c744e71..b9c4563 100644 --- a/miles/environment.metta +++ b/miles/environment.metta @@ -1,6 +1,6 @@ +; (convert_to_metta_file environment $_48972 miles/environment.pl miles/environment.metta) ; -; - +; MODULE environment EXPORTS !(module environment @@ -13,13 +13,10 @@ (/ ask-for-ex 1) (/ confirm 2) (/ get-ci 2))) -; - ; -; - +; IMPORTS !(use-module (home kb) (:: @@ -31,237 +28,160 @@ (/ store-ex 3) (/ rename 3) (/ delete-all 1))) -; - !(use-module (home show-utils) (:: (/ show-clauses 1) (/ show-names 0))) -; - !(use-module-if-exists (library prompt) (:: (/ prompt 1))) -; - !(use-module-if-exists (library ask) (:: (/ yesno 1) (/ yesno 2) (/ ask-chars 4))) -; - !(use-module-if-exists (library sets) (:: (/ union 3))) -; - !(use-module-if-exists (library subsumes) (:: (/ subsumes-chk 2))) -; - ; -; - +; METAPREDICATES ; -; - +; none ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: envirnonment.pl ; -; - +; * ; -; - +; * author: B.Jung, M.Mueller, I.Stahl, B.Tausend date:12/92 ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * ; -; - +; * description: procedures for oracle interaction ; -; - +; * 1. membership queries - oracle/1 ; -; - +; * 2. existential queries - oracle/2 ; -; - +; * 3. subset queries - oracle/2 ; -; - +; * 4. name queries - oracle/2 ; -; - +; * 5. general questions with default answers - oracle/3 ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; * ; -; - +; *********************************************************************** ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: satisfiable/1 ; -; - +; * ; -; - +; * syntax: satisfiable(+SG_list) ; -; - +; * ; -; - +; * args: SG_list ... list of subgoals [...,[ID,Subgoal,Proof],...] ; -; - +; * ; -; - +; * description: each Subgoal in SG_list is tested on satisfiability. ; -; - +; * The oracle is used if the satisfiability of Subgoal can not be ; -; - +; * decided on the available knowledge ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (satisfiable ()) True) -; +; *********************************************************************** - (= - (satisfiable (Cons (:: $_ $H $_) $R)) - ( (ask-for $H) (satisfiable $R))) -; + (= (satisfiable ()) True) + (= (satisfiable (Cons (:: $_ $H $_) $R)) + (ask-for $H) + (satisfiable $R)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: ask_for/1 ; -; - +; * ; -; - +; * syntax: ask_for(+Goal) ; -; - +; * ; -; - +; * args: Goal is a ground atom ; -; - +; * ; -; - +; * description: succeds if Goal is valid in the kb, or declared to be ; -; - +; * valid by the oracle ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (ask-for $Lit) + (= (ask-for $Lit) (det-if-then-else (interpretable-predicate $Lit) (det-if-then-else @@ -278,69 +198,48 @@ (, (store-ex $Lit - $_) (fail))) fail))) $Lit)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: ask_for_ex/1 ; -; - +; * ; -; - +; * syntax: ask_for(+Goal) ; -; - +; * ; -; - +; * args: Goal is an atom ; -; - +; * ; -; - +; * description: succeds if Goal is valid in the kb, or declared to be ; -; - +; * valid by the oracle ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (ask-for-ex $Lit) + (= (ask-for-ex $Lit) (det-if-then-else (interpretable-predicate $Lit) (det-if-then-else @@ -352,654 +251,467 @@ (det-if-then-else (oracle $Lit $Lit) (store-ex $Lit + $_) fail))) $Lit)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: term_help/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: prompts a help line ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (term-help) + (= (term-help) (prompt 'Please enter a proper PROLOG-term followed by a full-stop and RETURN')) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: oracle/1 ; -; - +; * ; -; - +; * syntax: oracle( + Literal) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: membership queries: ; -; - +; * "Is the following literal always true?" -> succeeds iff oracle answers yes ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - - - (= - (oracle $Lit) - ( (nl) - (prompt 'Is the following literal always true:') - (nl) - (nl) - (portray-clause $Lit) - (nl) - (set-det) - (yesno '> (y/n) '))) -; +; ;;oracle(mappend(A,B,C)):- !,append(A,B,C). + (= (oracle $Lit) + (nl) + (prompt 'Is the following literal always true:') + (nl) + (nl) + (portray-clause $Lit) + (nl) + (set-det) + (yesno '> (y/n) ')) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: oracle/2 ; -; - +; * ; -; - +; * syntax: oracle( + List_of_Clause_Ids, - Example_Id) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: subset queries ; -; - +; * "Are the following clauses always true?" ; -; - +; * If not, the user might supply a counter example. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: fails only if the oracle answers "no" AND does not ; -; - +; * supply a counter example ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - (= - (oracle - (Cons $Id1 $Rest) $NegexId) - ( (nl) - (prompt 'Are the following clauses always true:') - (nl) - (show-clauses (Cons $Id1 $Rest)) - (set-det) - (det-if-then-else - (yesno '> (y/n) ') True - (det-if-then - (yesno '> Would You like to give a counter-example' no) - (, - (repeat) - (prompt '> Please enter negative example as Prolog-term: ') - (read $Ex) - (det-if-then-else - (= $Ex h) - (, - (term-help) - (fail)) - (, - (store-ex $Ex - $NegexId) - (set-det)))))))) -; +; *********************************************************************** + (= (oracle (Cons $Id1 $Rest) $NegexId) + (nl) + (prompt 'Are the following clauses always true:') + (nl) + (show-clauses (Cons $Id1 $Rest)) + (set-det) + (det-if-then-else + (yesno '> (y/n) ') True + (det-if-then + (yesno '> Would You like to give a counter-example' no) + (, + (repeat) + (prompt '> Please enter negative example as Prolog-term: ') + (read $Ex) + (det-if-then-else + (= $Ex h) + (, + (term-help) + (fail)) + (, + (store-ex $Ex - $NegexId) + (set-det))))))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: oracle/2 ; -; - +; * ; -; - +; * syntax: oracle( + PnameAtom, - NewNameAtom) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * ; -; - +; * description: name queries ; -; - +; * "How would you like to call predicate pXYZ", where pXYZ is a new predicate. ; -; - +; * The oracle may use every atom as answer. However, the atom "list" ; -; - +; * causes the system to show every known predicate symbol within the knowledge base ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: the predicate returns the new predicate name, but does not ; -; - +; * replace the old name by the new one within the kb. ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - (= - (oracle $Pname $Newname) - ( (functor $Pname $_ 0) - (nl) - (prompt 'How would You like to call predicate ') - (write $Pname) - (write ?) - (set-det) - (repeat) - (ask-chars '> Please enter a name or "list" followed by RETURN' 1 40 $A1) - (atom-chars $A2 $A1) - (det-if-then-else - (== $A2 list) - (, - (prompt 'So far the following predicates have been defined in the knowledge-base:') - (nl) - (show-names) - (fail)) - (, - (= $Newname $A2) - (set-det))))) -; +; *********************************************************************** + (= (oracle $Pname $Newname) + (functor $Pname $_ 0) + (nl) + (prompt 'How would You like to call predicate ') + (write $Pname) + (write ?) + (set-det) + (repeat) + (ask-chars '> Please enter a name or "list" followed by RETURN' 1 40 $A1) + (atom-chars $A2 $A1) + (det-if-then-else + (== $A2 list) + (, + (prompt 'So far the following predicates have been defined in the knowledge-base:') + (nl) + (show-names) + (fail)) + (, + (= $Newname $A2) + (set-det)))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: oracle/2 ; -; - +; * ; -; - +; * syntax: oracle(+Lit, -InstLit) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: existential queries ; -; - +; * "Is there a correct instance of the following literal?" ; -; - +; * If yes, the oracle supplies an instance -> InstLit ; -; - +; * Else, the predicate fails ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (oracle $Lit $InstLit) - ( (nl) - (prompt 'Is there a correct instance of the following literal:') - (nl) - (nl) - (portray-clause $Lit) - (nl) - (set-det) - (yesno '> (y/n) ') - (repeat) - (prompt '> Please enter an instance: ') - (read $InstLit) + (= (oracle $Lit $InstLit) + (nl) + (prompt 'Is there a correct instance of the following literal:') + (nl) + (nl) + (portray-clause $Lit) + (nl) + (set-det) + (yesno '> (y/n) ') + (repeat) + (prompt '> Please enter an instance: ') + (read $InstLit) + (det-if-then-else + (= $InstLit h) + (, + (term-help) + (fail)) (det-if-then-else - (= $InstLit h) + (subsumes-chk $Lit $InstLit) + (set-det) (, - (term-help) - (fail)) - (det-if-then-else - (subsumes-chk $Lit $InstLit) - (set-det) - (, - (prompt 'This is no instantiation of the literal!') - (fail)))))) -; - + (prompt 'This is no instantiation of the literal!') + (fail))))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: oracle/3 ; -; - +; * ; -; - +; * syntax: oracle( + QuestionAtom, ? DefaultAtom, - AnswerAtom) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: general questions with default answers ; -; - +; * If no default is necessary, use '_' as second argument ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - (= - (oracle $Question $Default $Answer) - ( (atom-chars $Question $Qlist) - (append - (:: 62 32) $Qlist $P1list) - (det-if-then-else - (var $Default) - (atom-chars $Prompt $P1list) - (, - (atom-chars $Default $Dlist) - (append $Dlist - (:: 93) $D1list) - (append $P1list - (Cons 32 - (Cons 91 $D1list)) $P2list) - (atom-chars $Prompt $P2list))) - (nl) - (ask-chars $Prompt 0 255 $Alist) - (det-if-then-else - (, - (== $Alist Nil) - (nonvar $Default)) - (= $Answer $Default) - (atom-chars $Answer $Alist)))) -; +; *********************************************************************** + (= (oracle $Question $Default $Answer) + (atom-chars $Question $Qlist) + (append + (:: 62 32) $Qlist $P1list) + (det-if-then-else + (var $Default) + (atom-chars $Prompt $P1list) + (, + (atom-chars $Default $Dlist) + (append $Dlist + (:: 93) $D1list) + (append $P1list + (Cons 32 + (Cons 91 $D1list)) $P2list) + (atom-chars $Prompt $P2list))) + (nl) + (ask-chars $Prompt 0 255 $Alist) + (det-if-then-else + (, + (== $Alist Nil) + (nonvar $Default)) + (= $Answer $Default) + (atom-chars $Answer $Alist))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: confirm/2 ; -; - +; * ; -; - +; * syntax: confirm(+Clause_IDs,+Oldterm) ; -; - +; * ; -; - +; * args: Clause_IDs .. list of clauseIDs, ; -; - +; * Oldterm.. term of the predicate to be replaced ; -; - +; * ; -; - +; * description: confirm new clauses and rename the new predicate (using the oracle) ; -; - +; * if oracle refuses the new clauses, delete 'em. ; -; - +; * if they are accepted, delete the old ones (see g2_op). ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (confirm $Clause_ids $L) - ( (oracle $Clause_ids $Ex) - (var $Ex) - (functor $L $Oldname $_) - (oracle $Oldname $Newname) - (rename $Clause_ids $Oldname $Newname) - (set-det))) -; - - - (= - (confirm $Clause_ids $_) - ( (delete-all $Clause_ids) - (nl) - (write 'New clauses deleted.') - (fail))) -; + (= (confirm $Clause_ids $L) + (oracle $Clause_ids $Ex) + (var $Ex) + (functor $L $Oldname $_) + (oracle $Oldname $Newname) + (rename $Clause_ids $Oldname $Newname) + (set-det)) + (= (confirm $Clause_ids $_) + (delete-all $Clause_ids) + (nl) + (write 'New clauses deleted.') + (fail)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: get_ci/2 ; -; - +; * ; -; - +; * syntax: get_ci(+L,-L) ; -; - +; * ; -; - +; * args: L ... list of clauseIDs ; -; - +; * ; -; - +; * description: reads the IDs of the Ci used for the g2-operator one ; -; - +; * by one ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ************************************************************************ - (= - (get-ci $Sofar $CC) - ( (oracle 'Please enter a resolvent ID followed by RETURN' stop $Answer) - (\== $Answer stop) - (atom-chars $Answer $Idc) - (det-if-then-else - (, - (number-chars $Id $Idc) - (union $Sofar - (:: $Id) $Sofarnew)) True - (= $Sofarnew $Sofar)) - (set-det) - (get-ci $Sofarnew $CC))) -; - - (= - (get-ci $CC $CC) - (set-det)) -; - + (= (get-ci $Sofar $CC) + (oracle 'Please enter a resolvent ID followed by RETURN' stop $Answer) + (\== $Answer stop) + (atom-chars $Answer $Idc) + (det-if-then-else + (, + (number-chars $Id $Idc) + (union $Sofar + (:: $Id) $Sofarnew)) True + (= $Sofarnew $Sofar)) + (set-det) + (get-ci $Sofarnew $CC)) + (= (get-ci $CC $CC) + (set-det)) diff --git a/miles/evaluation.metta b/miles/evaluation.metta index b339e34..b8b741c 100644 --- a/miles/evaluation.metta +++ b/miles/evaluation.metta @@ -1,6 +1,6 @@ +; (convert_to_metta_file evaluation $_266776 miles/evaluation.pl miles/evaluation.metta) ; -; - +; MODULE evaluation EXPORTS !(module evaluation @@ -26,12 +26,14 @@ (/ code-length 2) (/ encoding-length-examples 1) (/ encoding-length-clause 2))) -; - +; ; Compute complete evaluation for all examples +; ; AND clauses in kb +; ; Compute evaluation for all pos examples in kb +; ; check completeness, all pos examples covered? +; ; check correctness, no neg examples covered? ; -; - +; IMPORTS !(use-module (home div-utils) (:: @@ -52,21 +54,15 @@ (/ log2 2) (/ log2nueberk 3) (/ sum-of-logs 3))) -; - !(use-module (home environment) (:: (/ ask-for 1))) -; - !(use-module (home var-utils) (:: (/ term-size 2) (/ vars 2) (/ skolemize 3))) -; - !(use-module (home kb) (:: @@ -79,8 +75,6 @@ (/ delete-example 1) (/ delete-clause 1) (/ get-clause 5))) -; - !(use-module (home interpreter) (:: @@ -90,1132 +84,766 @@ (/ solve 3) (/ ip-part1 2) (/ ip-part2 3))) -; - !(use-module-if-exists (library basics) (:: (/ member 2))) -; - !(use-module-if-exists (library subsumes) (:: (/ subsumes-chk 2) (/ variant 2))) -; - !(use-module-if-exists (library occurs) (:: (/ sub-term 2))) -; - !(use-module-if-exists (library math) (:: (/ pow 3))) -; - ; -; - +; METAPREDICATES ; -; - +; none !(dynamic (/ evaluated 1)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: evaluation.pl ; -; - +; * ; -; - +; * author: B.Jung, M.Mueller, I.Stahl, B.Tausend date:12/92 ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * description: evaluation of (parts of) the knowledge base ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: ip/1 ; -; - +; * ; -; - +; * syntax: ip(-UA_List) ; -; - +; * ; -; - +; * args: -UA_List ... list of ground atoms ; -; - +; * ; -; - +; * description: Shapiro's algorithm for diagnosing finite failure ; -; - +; * ip in our framework. Returns a set of ground atoms that ; -; - +; * has to be covered to make all uncovered positive ; -; - +; * examples succeed. ; -; - +; * Allows backtracking on alternative sets of ground atoms ; -; - +; * that make all examples succeed. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (ip $UA_List) - ( (det-if-then-else - (evaluated no) eval-examples True) - (mysetof $E - (^ $I - (^ $Trees - (, - (get-example $I $E +) - (prooftrees $I fail $Trees)))) $Elist) - (set-det) - (ip-list $Elist Nil $UA_List1) - (make-unique $UA_List1 $UA_List))) -; - +; *********************************************************************** - (= - (ip_list () $L $L) True) -; + (= (ip $UA_List) + (det-if-then-else + (evaluated no) eval-examples True) + (mysetof $E + (^ $I + (^ $Trees + (, + (get-example $I $E +) + (prooftrees $I fail $Trees)))) $Elist) + (set-det) + (ip-list $Elist Nil $UA_List1) + (make-unique $UA_List1 $UA_List)) - (= - (ip-list - (Cons $E $R) $L $L2) - ( (ip0 $E $UAs) - (append $L $UAs $L1) - (ip-list $R $L1 $L2))) -; + (= (ip_list () $L $L) True) + (= (ip-list (Cons $E $R) $L $L2) + (ip0 $E $UAs) + (append $L $UAs $L1) + (ip-list $R $L1 $L2)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: ; -; - +; * ; -; - +; * syntax: ip(+UA,-UAs) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: UA is an uncovered atom, i.e. both prooftrees(I,fail,Trees) ; -; - +; * and ex(I,UA,+) are in the knowledge base. ; -; - +; * UAs is a list [A1,...,An] such that a proof of UA would ; -; - +; * succeed if A1 through An were covered by the knowledge base. ; -; - +; * Cave!: Extensive oracle interaction ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (ip0 $Goal $UAs) - ( (setof $Proof - (^ $Goal - (ip-part1 $Goal $Proof)) $Proofs0) - (append-all $Proofs0 $Proofs1) - (proof-close $Proofs1 $Proofs) - (set-det) - (ip-part2 $Proofs $Goal $UAs0) - (make-unique $UAs0 $UAs))) -; - + (= (ip0 $Goal $UAs) + (setof $Proof + (^ $Goal + (ip-part1 $Goal $Proof)) $Proofs0) + (append-all $Proofs0 $Proofs1) + (proof-close $Proofs1 $Proofs) + (set-det) + (ip-part2 $Proofs $Goal $UAs0) + (make-unique $UAs0 $UAs)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: fp/1 ; -; - +; * ; -; - +; * syntax: fp(-OR) ; -; - +; * ; -; - +; * args: OR: ; -; - +; * ; -; - +; * description: a kind of shapiro's contradiction backtracing that ; -; - +; * aims to detect possibly overgeneral clauses. ; -; - +; * As it does not use an oracle, all possibly overgeneral ; -; - +; * clauses are considered and a minimal combination ; -; - +; * such that all negative examples become uncovered is ; -; - +; * returned. ; -; - +; * Allows backtracking to an alternative set of possibly ; -; - +; * overgeneral clauses ; -; - +; * OR is a list [I:E,...], where I is the index of a possibly ; -; - +; * overgeneral clause and E is the set of wrong (head-)instantiations of ; -; - +; * clause I that should be excluded by specializing I. ; -; - +; * OR is a minimal selection of possibly overgeneral clauses such ; -; - +; * that by specialising them all negative examples become uncovered. ; -; - +; * On backtracking, the second selection is returned, and so on. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (fp $OR) - ( (det-if-then-else - (evaluated no) eval-examples True) - (bagof $TL - (^ $I - (^ $E - (^ $Trees - (^ $P - (, - (get-example $I $E -) - (prooftrees $I success $Trees) - (member $P $Trees) - (fp $P Nil $TL)))))) $TList) - (collect-indices $TList Nil $Indices) - (or-subsets $Indices $TList $OR_List) - (set-det) - (best $OR_List $OR))) -; +; *********************************************************************** - (= - (fp ()) True) -; + (= (fp $OR) + (det-if-then-else + (evaluated no) eval-examples True) + (bagof $TL + (^ $I + (^ $E + (^ $Trees + (^ $P + (, + (get-example $I $E -) + (prooftrees $I success $Trees) + (member $P $Trees) + (fp $P Nil $TL)))))) $TList) + (collect-indices $TList Nil $Indices) + (or-subsets $Indices $TList $OR_List) + (set-det) + (best $OR_List $OR)) + (= (fp ()) True) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: fp/3 ; -; - +; * ; -; - +; * syntax: fp(+Prooftree,+L,-L) ; -; - +; * ; -; - +; * args: Prooftree is a prooftree for a succeeding negative example ; -; - +; * L = [...,ID:[G1,..,Gn],...] where ID is a clause index and ; -; - +; * G1,..,Gn are the head instantiations the clause has been applied with ; -; - +; * during the proof Prooftree. ; -; - +; * ; -; - +; * description: collects clauses and goals that have been used during ; -; - +; * a successfull proof of a negative example ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (fp - (:: sys $_ $_) $L $L) + (= (fp (:: sys $_ $_) $L $L) (set-det)) -; - - (= - (fp - (:: $I $A $SG) $L $L2) - ( (fp-list $SG $L $L1) (insert-unique $I $A $L1 $L2))) -; - - + (= (fp (:: $I $A $SG) $L $L2) + (fp-list $SG $L $L1) + (insert-unique $I $A $L1 $L2)) - (= - (fp_list () $L $L) True) -; - - (= - (fp-list - (Cons $G $R) $L $L2) - ( (fp-list $R $L $L1) (fp $G $L1 $L2))) -; + (= (fp_list () $L $L) True) + (= (fp-list (Cons $G $R) $L $L2) + (fp-list $R $L $L1) + (fp $G $L1 $L2)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: fp_hyp/1 ; -; - +; * ; -; - +; * syntax: fp_hyp(-OR) ; -; - +; * ; -; - +; * args: OR: ; -; - +; * ; -; - +; * description: as fp/1, but considers only clauses with label 'hypo' as ; -; - +; * possibly overgeneral ; -; - +; * Allows backtracking to an alternative set of possibly ; -; - +; * overgeneral clauses ; -; - +; * OR is a list [I:E,...], where I is the index of a possibly ; -; - +; * overgeneral clause and E is the set of wrong (head-)instantiations of ; -; - +; * clause I that should be excluded by specializing I. ; -; - +; * OR is a minimal selection of possibly overgeneral clauses such ; -; - +; * that by specialising them all negative examples become uncovered. ; -; - +; * On backtracking, the second selection is returned, and so on. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (fp-hyp $OR) - ( (det-if-then-else - (evaluated no) eval-examples True) - (bagof $TL - (^ $I - (^ $E - (^ $Trees - (^ $P - (, - (get-example $I $E -) - (prooftrees $I success $Trees) - (member $P $Trees) - (fp-hyp $P Nil $TL)))))) $TList) - (collect-indices $TList Nil $Indices) - (or-subsets $Indices $TList $OR_List) - (set-det) - (best $OR_List $OR))) -; - - (= - (fp_hyp ()) True) -; + (= (fp-hyp $OR) + (det-if-then-else + (evaluated no) eval-examples True) + (bagof $TL + (^ $I + (^ $E + (^ $Trees + (^ $P + (, + (get-example $I $E -) + (prooftrees $I success $Trees) + (member $P $Trees) + (fp-hyp $P Nil $TL)))))) $TList) + (collect-indices $TList Nil $Indices) + (or-subsets $Indices $TList $OR_List) + (set-det) + (best $OR_List $OR)) + (= (fp_hyp ()) True) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: fp_hyp/3 ; -; - +; * ; -; - +; * syntax: fp_hyp(+Prooftree,+L,-L) ; -; - +; * ; -; - +; * args: Prooftree is a prooftree for a succeeding negative example ; -; - +; * L = [...,ID:[G1,..,Gn],...] where ID is a clause index of a clause with ; -; - +; * label 'hypo', and ; -; - +; * G1,..,Gn are the head instantiations the clause has been applied with ; -; - +; * during the proof Prooftree. ; -; - +; * ; -; - +; * description: collects clauses and goals that have been used during ; -; - +; * a successfull proof of a negative example ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (fp-hyp - (:: sys $_ $_) $L $L) + (= (fp-hyp (:: sys $_ $_) $L $L) (set-det)) -; - - (= - (fp-hyp - (:: $I $A $SG) $L $L2) - ( (fp-hyp-list $SG $L $L1) (det-if-then-else (get-clause $I $_ $_ $_ hypo) (insert-unique $I $A $L1 $L2) (= $L2 $L1)))) -; - - - - (= - (fp_hyp_list () $L $L) True) -; + (= (fp-hyp (:: $I $A $SG) $L $L2) + (fp-hyp-list $SG $L $L1) + (det-if-then-else + (get-clause $I $_ $_ $_ hypo) + (insert-unique $I $A $L1 $L2) + (= $L2 $L1))) - (= - (fp-hyp-list - (Cons $G $R) $L $L2) - ( (fp-hyp-list $R $L $L1) (fp-hyp $G $L1 $L2))) -; + (= (fp_hyp_list () $L $L) True) + (= (fp-hyp-list (Cons $G $R) $L $L2) + (fp-hyp-list $R $L $L1) + (fp-hyp $G $L1 $L2)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: fpo/1 ; -; - +; * ; -; - +; * syntax: fpo(-OR) ; -; - +; * ; -; - +; * args: OR: ; -; - +; * ; -; - +; * description: as fp/1, but uses oracle ; -; - +; * Allows backtracking to an alternative set of possibly ; -; - +; * overgeneral clauses ; -; - +; * OR is a list [I:E,...], where I is the index of a possibly ; -; - +; * overgeneral clause and E is the set of wrong (head-)instantiations of ; -; - +; * clause I that should be excluded by specializing I. ; -; - +; * OR is a minimal selection of possibly overgeneral clauses such ; -; - +; * that by specialising them all negative examples become uncovered. ; -; - +; * On backtracking, the second selection is returned, and so on. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (fpo $OR) - ( (det-if-then-else - (evaluated no) eval-examples True) - (bagof $TL - (^ $I - (^ $E - (^ $Trees - (^ $P - (, - (get-example $I $E -) - (prooftrees $I success $Trees) - (member $P $Trees) - (fpo $P Nil $TL $_)))))) $TList) - (collect-indices $TList Nil $Indices) - (or-subsets $Indices $TList $OR_List) - (set-det) - (best $OR_List $OR))) -; - - (= - (fpo ()) True) -; - + (= (fpo $OR) + (det-if-then-else + (evaluated no) eval-examples True) + (bagof $TL + (^ $I + (^ $E + (^ $Trees + (^ $P + (, + (get-example $I $E -) + (prooftrees $I success $Trees) + (member $P $Trees) + (fpo $P Nil $TL $_)))))) $TList) + (collect-indices $TList Nil $Indices) + (or-subsets $Indices $TList $OR_List) + (set-det) + (best $OR_List $OR)) + (= (fpo ()) True) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: fpo/4 ; -; - +; * ; -; - +; * syntax: fpo(+Prooftree,+L,-L,-M) ; -; - +; * ; -; - +; * args: Prooftree is a prooftree for a succeeding negative example ; -; - +; * L = [...,ID:[G1,..,Gn],...] where ID is a clause index and ; -; - +; * G1,..,Gn are the head instantiations the clause has been applied with ; -; - +; * during the proof Prooftree. ; -; - +; * M indicates whether Prooftree is successful in the oracle-simulation (ok) ; -; - +; * or not (not_ok) ; -; - +; * ; -; - +; * description: collects wrong clauses and goals that have been used during ; -; - +; * a successfull proof of a negative example (uses oracle) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (fpo - (:: sys $_ $_) $L $L ok) + (= (fpo (:: sys $_ $_) $L $L ok) (set-det)) -; - - (= - (fpo - (:: $I $A $SG) $L $L1 $X) + (= (fpo (:: $I $A $SG) $L $L1 $X) (det-if-then-else (ask-for $A) (fpo-list $SG $L $L1 $X) (, (insert-unique $I $A $L $L1) (= $X not-ok)))) -; - - (= - (fpo_list () $L $L ok) True) -; - - (= - (fpo-list - (Cons $G $R) $L $L2 $X) - ( (fpo $G $L $L1 $Xg) (det-if-then-else (= $Xg ok) (fpo-list $R $L1 $L2 $X) (= $X $Xg)))) -; - + (= (fpo_list () $L $L ok) True) + (= (fpo-list (Cons $G $R) $L $L2 $X) + (fpo $G $L $L1 $Xg) + (det-if-then-else + (= $Xg ok) + (fpo-list $R $L1 $L2 $X) + (= $X $Xg))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: collect_indices/3 ; -; - +; * ; -; - +; * syntax: collect_indices(+L,+Accu,-Accu) ; -; - +; * ; -; - +; * args: L = [[I1:[G11,..,G1n],...,Im:[Gm1,...,Gmn]],...] ; -; - +; * Accu = [I1,...,Ik] ; -; - +; * ; -; - +; * description: given the list of lists produced by fp/3, all indices of ; -; - +; * clauses that participated in successful proofs of negative examples ; -; - +; * are collected ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (collect_indices () $L $L) True) -; - (= - (collect-indices - (Cons $X $R) $L $L2) - ( (c-indices $X $L $L1) (collect-indices $R $L1 $L2))) -; + (= (collect_indices () $L $L) True) + (= (collect-indices (Cons $X $R) $L $L2) + (c-indices $X $L $L1) + (collect-indices $R $L1 $L2)) - - (= - (c_indices () $L $L) True) -; - - (= - (c-indices - (Cons - (with_self $I $_) $R) $L $L2) - ( (c-indices $R $L $L1) (det-if-then-else (member $I $L1) (= $L2 $L1) (= $L2 (Cons $I $L1))))) -; - + (= (c_indices () $L $L) True) + (= (c-indices (Cons (with_self $I $_) $R) $L $L2) + (c-indices $R $L $L1) + (det-if-then-else + (member $I $L1) + (= $L2 $L1) + (= $L2 + (Cons $I $L1)))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: or_subsets/3 ; -; - +; * ; -; - +; * syntax: or_subsets(+Indices,+Tlist,-OR_List) ; -; - +; * ; -; - +; * args: Indices ... list of indices of clauses that participated in successful ; -; - +; * proofs of negative examples ; -; - +; * Tlist = [[I:[G1,..,Gn],..],..] list of lists produced by fp/3 ; -; - +; * OR_List = list of lists [I:E,..] where I is the index of a possibly ; -; - +; * overgeneral clause and E is the set of wrong (head-)instantiations of ; -; - +; * clause I that should be excluded by specializing I. OR_List is sorted ; -; - +; * ascendingly according to the length of the sublists ; -; - +; * ; -; - +; * description: selects all possible combinations of possibly overgeneral clauses ; -; - +; * such that by specialising them all negative examples become uncovered. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (or-subsets $IX $TL $ORL) - ( (initialize-or-subsets $IX $IX $TL $TL1) - (or-all-subsets $TL1 Nil $TL2) - (sort-by-length $TL2 Nil $ORL))) -; - + (= (or-subsets $IX $TL $ORL) + (initialize-or-subsets $IX $IX $TL $TL1) + (or-all-subsets $TL1 Nil $TL2) + (sort-by-length $TL2 Nil $ORL)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: initialize_or_subsets/4 ; -; - +; * ; -; - +; * syntax: initialize_or_subsets(+IX,+IX,+TL,-TL1) ; -; - +; * ; -; - +; * args: IX list of clauseIDs ; -; - +; * TL = [[I:CoveredI,J:CoveredJ,...],...] resulting from fp/3. ; -; - +; * each sublist in TL corresponds to a successful proof of a negative ; -; - +; * example ; -; - +; * ; -; - +; * description: TL1 contains for each I in IX and entry [I:A]:IX1:TLI, ; -; - +; * where IX1 = IX - {I} and TLI results from TL by deleting every ; -; - +; * sublist [J:CJ,..,I:CI,...] that contains I:CI, and accumulating ; -; - +; * the head instances of I in A. ; -; - +; * The set TLI contains all proofs of negative examples that are ; -; - +; * still possible if clause I is excluded (e.g. specialised). ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (initialize_or_subsets () $_ $_ ()) True) -; + (= (initialize_or_subsets () $_ $_ ()) True) ; (error ; (syntax_error operator_clash) ; (file miles/evaluation.pl 478 41 15079)) @@ -1223,166 +851,109 @@ ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: remove_conjuncts/5 ; -; - +; * ; -; - +; * syntax: remove_conjuncts(+I,+TL,-TLI,+A,-A) ; -; - +; * ; -; - +; * args: I .. clause Index, TL = [[I:CI,J:CJ,...],...], ; -; - +; * A = [G1,..,Gn] head instances of I ; -; - +; * ; -; - +; * description: removes from TL every sublist containing I:CI, and accumulates ; -; - +; * CI in A. Each sublist in TL corresponds to a successful proof of ; -; - +; * a negative example. If clause I is assumed to be overgeneral and ; -; - +; * therefore excluded, the proof fails and the remaining clauses that ; -; - +; * have been used need not be specialised. Therefore, the sublist is ; -; - +; * removed from TL. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (remove_conjuncts $_ () () $A $A) True) -; - (= - (remove-conjuncts $I - (Cons $X $R) $R1 $A $A2) - ( (member - (with_self $I $E) $X) - (set-det) - (append $E $A $A0) - (identical-make-unique $A0 $A1) - (remove-conjuncts $I $R $R1 $A1 $A2))) -; - - (= - (remove-conjuncts $I - (Cons $X $R) - (Cons $X $R1) $A $A1) + (= (remove_conjuncts $_ () () $A $A) True) + (= (remove-conjuncts $I (Cons $X $R) $R1 $A $A2) + (member + (with_self $I $E) $X) + (set-det) + (append $E $A $A0) + (identical-make-unique $A0 $A1) + (remove-conjuncts $I $R $R1 $A1 $A2)) + (= (remove-conjuncts $I (Cons $X $R) (Cons $X $R1) $A $A1) (remove-conjuncts $I $R $R1 $A $A1)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: or_all_subsets/3 ; -; - +; * ; -; - +; * syntax: or_all_subsets(+TL1,+Accu,-Accu) ; -; - +; * ; -; - +; * args: TL1 = [IXS:IXR:TLI,...] where IXS = [I:CI,...], IXR the indices not ; -; - +; * occurring in IXS, and TLI the remaining proofs of negative examples ; -; - +; * Accu = [IXS,...] ; -; - +; * ; -; - +; * description: tests every combination of clause indices whether all proofs ; -; - +; * of negative examples are excluded when the clauses are assumed to be ; -; - +; * overgeneral. A combination IXS is successful, if all proofs are excluded, ; -; - +; * i.e. TLI = []. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; (error ; (syntax_error operator_clash) @@ -1393,16 +964,10 @@ ; (file miles/evaluation.pl 543 20 17286)) - (= - (or_all_subsets () $L $L) True) -; + (= (or_all_subsets () $L $L) True) - - (= - (or_asubsets () $_ $_ $_ ()) True) -; - + (= (or_asubsets () $_ $_ $_ ()) True) ; (error ; (syntax_error operator_clash) ; (file miles/evaluation.pl 550 39 17474)) @@ -1410,259 +975,178 @@ ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: eval_pos_examples/1 ; -; - +; * ; -; - +; * syntax: eval_pos_examples ( - List_of_Exs ) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: Evaluate (= try to prove) all positive examples, return a list of the ; -; - +; * ones which *cannot* be proved (empty list if successful). ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: Output-argument looks like [exID1:Fact1, exID2:Fact2, ...]. ; -; - +; * !!! Procedure does not compute evaluation for clauses!! ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (eval-pos-examples $Exlist) - ( (remove-all-symbols &self - (prooftrees $_ $_ $_)) (findall (with_self $I $Fact) (, (ex $I $Fact +) (solve-once $Fact fail $_)) $Exlist))) -; - + (= (eval-pos-examples $Exlist) + ( (remove-all-atoms &self + (prooftrees $_ $_ $_)) (findall (with_self $I $Fact) (, (ex $I $Fact +) (solve-once $Fact fail $_)) $Exlist))) ; -; - +; ****************************************************************************** ; -; - +; * ; -; - +; * predicate: eval_examples/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: One should use this to compute the evaluation for kb clauses! ; -; - +; * - asserts for each example ID prooftrees(ID,Mark,Proofs), where ; -; - +; * Mark in {success,fail} and Proofs are the successful/failing ; -; - +; * proofs accordingly ; -; - +; * - determines the evaluation of each rule in the kb according to ; -; - +; * the current examples ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; ****************************************************************************** - (= - (eval-examples) - ( (evaluated yes) (set-det))) -; + (= (eval-examples) + (evaluated yes) + (set-det)) - (= - (eval-examples) - ( (remove-all-symbols &self + (= (eval-examples) + ( (remove-all-atoms &self (prooftrees $_ $_ $_)) (eval-examples1) (set-det) (change-evaluated yes))) -; - - (= - (eval-examples1) + (= (eval-examples1) ( (ex $I $Fact $_) (solve $Fact $M $Proofs) - (add-symbol &self + (add-is-symbol &self (prooftrees $I $M $Proofs)) (fail))) -; - - (= - (eval-examples1) - ( (bagof - (with_self $I $Proofs) - (prooftrees $I success $Proofs) $Plist) - (findall - (known $J $H $B $Clist $L $_) - (, - (get-clause $J $H $B $Clist $L) - (delete-clause $J)) $Klist) - (compute-evaluation $Klist $Plist $Klist1) - (assertallz $Klist1) - (set-det))) -; - - (= eval_examples1 True) -; - ; -; - + (= (eval-examples1) + (bagof + (with_self $I $Proofs) + (prooftrees $I success $Proofs) $Plist) + (findall + (known $J $H $B $Clist $L $_) + (, + (get-clause $J $H $B $Clist $L) + (delete-clause $J)) $Klist) + (compute-evaluation $Klist $Plist $Klist1) + (assertallz $Klist1) + (set-det)) +; ; don't use bagof here! + (= eval_examples1 True) ; +; in case there are no examples - (= - (clear-evaluation) - ( (remove-all-symbols &self + (= (clear-evaluation) + ( (remove-all-atoms &self (prooftrees $_ $_ $_)) (change-evaluated no))) -; - - (= - (change-evaluated $X) - ( (remove-all-symbols &self - (evaluated $_)) (add-symbol &self (evaluated $X)))) -; - + (= (change-evaluated $X) + ( (remove-all-atoms &self + (evaluated $_)) (add-is-symbol &self (evaluated $X)))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate:correct_chk/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: fails when first *negative* example covered ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: Does not compute evaluation for clauses!! ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (correct-chk) + (= (correct-chk) (det-if-then-else (evaluated no) (det-if-then-else @@ -1673,70 +1157,48 @@ (, (ex $ID $Fact -) (prooftrees $ID success $_)) fail True))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: complete_chk/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: fails if not all *positive* examples covered ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: Does not compute evaluation for clauses!! ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; * origin: kb.pl (Irene/Markus) ; -; - +; * ; -; - +; *********************************************************************** - (= - (complete-chk) + (= (complete-chk) (det-if-then-else (evaluated no) (det-if-then-else @@ -1747,1959 +1209,1373 @@ (, (ex $ID $Fact +) (prooftrees $ID fail $_)) fail True))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate:compute_evaluation/3 ; -; - +; * ; -; - +; * syntax: compute_evaluation(+Klist,+Plist,-Klist) ; -; - +; * ; -; - +; * args: Klist ... list of kb-entries [known(I,H,B,Clist,Label,E),...] ; -; - +; * where E is the evaluation of clause I ; -; - +; * Plist ... list of all successfule Proofs using Klist ; -; - +; * = [I:Proofs,...] where prooftrees(I,success,Proofs) in kb ; -; - +; * ; -; - +; * description: computes for each kb-entry in Klist the evaluation ; -; - +; * E = evaluation(RA,NPos,Pos,NNeg,Neg,UNPos,UPos,UNNeg,UNeg), where ; -; - +; * RA ... #applications of the clause ; -; - +; * NPos ... #definitively positive examples covered by the clause ; -; - +; * Pos ... list of definitively positive examples covered by the clause ; -; - +; * NNeg ... #definitively negative examples covered by the clause ; -; - +; * Neg ... list of definitively negative examples covered by the clause ; -; - +; * UNPos ... #probably positive examples covered by the clause ; -; - +; * i.e. instantiations of the clause used in successful proofs of positive ; -; - +; * examples ; -; - +; * UPos ... list of probably positive examples covered by the clause ; -; - +; * UNNeg ... #probably negative examples covered by the clause ; -; - +; * i.e. instantiations of the clause used in successful proofs of negative ; -; - +; * examples ; -; - +; * UNeg ... list of probably negative examples covered by the clause ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (compute_evaluation () $_ ()) True) -; - - (= - (compute-evaluation - (Cons - (known $I $H $B $Clist $O $_) $R) $Plist - (Cons - (known $I $H $B $Clist $O - (evaluation $RA $NPos $Pos $NNeg $Neg $UNPos $UPos $UNNeg $UNeg)) $R1)) - ( (compute-evaluation $R $Plist $R1) (compute-eval $Plist $I $RA $NPos $Pos $NNeg $Neg $UNPos $UPos $UNNeg $UNeg))) -; + (= (compute_evaluation () $_ ()) True) + (= (compute-evaluation (Cons (known $I $H $B $Clist $O $_) $R) $Plist (Cons (known $I $H $B $Clist $O (evaluation $RA $NPos $Pos $NNeg $Neg $UNPos $UPos $UNNeg $UNeg)) $R1)) + (compute-evaluation $R $Plist $R1) + (compute-eval $Plist $I $RA $NPos $Pos $NNeg $Neg $UNPos $UPos $UNNeg $UNeg)) - - (= - (compute_eval () $_ 0 0 () 0 () 0 () 0 ()) True) -; - - (= - (compute-eval - (Cons - (with_self $I $Proofs) $R) $J $RA $NPos $Pos $NNeg $Neg $UNPos $UPos $UNNeg $UNeg) - ( (compute-eval $R $J $RA0 $NPos0 $Pos0 $NNeg0 $Neg0 $UNPos0 $UPos0 $UNNeg0 $UNeg0) (det-if-then-else (ex $I $_ -) (, (compute-eval $Proofs t $I $J $RA0 $RA $NNeg0 $NNeg $Neg0 $Neg $UNNeg0 $UNNeg $UNeg0 $UNeg) (= $NPos $NPos0) (= $Pos $Pos0) (= $UNPos $UNPos0) (= $UPos $UPos0)) (, (compute-eval $Proofs t $I $J $RA0 $RA $NPos0 $NPos $Pos0 $Pos $UNPos0 $UNPos $UPos0 $UPos) (= $NNeg $NNeg0) (= $Neg $Neg0) (= $UNNeg $UNNeg0) (= $UNeg $UNeg0))))) -; - - - (= - (compute_eval () $_ $_ $_ $RA $RA $N $N $L $L $UN $UN $UL $UL) True) -; - - (= - (compute-eval - (Cons - (:: $I $H $B) $R) $T $K $J $RA $RA3 $N $N3 $L $L3 $UN $UN3 $UL $UL3) - ( (compute-eval $R $T $K $J $RA $RA1 $N $N1 $L $L1 $UN $UN1 $UL $UL1) - (compute-eval $B b $K $J $RA1 $RA2 $N1 $N2 $L1 $L2 $UN1 $UN2 $UL1 $UL2) - (det-if-then-else - (== $I $J) - (, - (is $RA3 - (+ $RA2 1)) + (= (compute_eval () $_ 0 0 () 0 () 0 () 0 ()) True) + (= (compute-eval (Cons (with_self $I $Proofs) $R) $J $RA $NPos $Pos $NNeg $Neg $UNPos $UPos $UNNeg $UNeg) + (compute-eval $R $J $RA0 $NPos0 $Pos0 $NNeg0 $Neg0 $UNPos0 $UPos0 $UNNeg0 $UNeg0) + (det-if-then-else + (ex $I $_ -) + (, + (compute-eval $Proofs t $I $J $RA0 $RA $NNeg0 $NNeg $Neg0 $Neg $UNNeg0 $UNNeg $UNeg0 $UNeg) + (= $NPos $NPos0) + (= $Pos $Pos0) + (= $UNPos $UNPos0) + (= $UPos $UPos0)) + (, + (compute-eval $Proofs t $I $J $RA0 $RA $NPos0 $NPos $Pos0 $Pos $UNPos0 $UNPos $UPos0 $UPos) + (= $NNeg $NNeg0) + (= $Neg $Neg0) + (= $UNNeg $UNNeg0) + (= $UNeg $UNeg0)))) + + (= (compute_eval () $_ $_ $_ $RA $RA $N $N $L $L $UN $UN $UL $UL) True) + (= (compute-eval (Cons (:: $I $H $B) $R) $T $K $J $RA $RA3 $N $N3 $L $L3 $UN $UN3 $UL $UL3) + (compute-eval $R $T $K $J $RA $RA1 $N $N1 $L $L1 $UN $UN1 $UL $UL1) + (compute-eval $B b $K $J $RA1 $RA2 $N1 $N2 $L1 $L2 $UN1 $UN2 $UL1 $UL2) + (det-if-then-else + (== $I $J) + (, + (is $RA3 + (+ $RA2 1)) + (det-if-then-else + (== $T t) (det-if-then-else - (== $T t) - (det-if-then-else - (member - (with_self $_ $H) $L2) - (, - (= $L3 $L2) - (= $N3 $N2) - (= $UN3 $UN2) - (= $UL3 $UL2)) - (, - (is $N3 - (+ $N2 1)) - (= $L3 - (Cons - (with_self $K $H) $L2)) - (= $UN3 $UN2) - (= $UL3 $UL2))) - (det-if-then-else - (member - (with_self $_ $H) $UL2) - (, - (= $L3 $L2) - (= $N3 $N2) - (= $UN3 $UN2) - (= $UL3 $UL2)) - (, - (is $UN3 - (+ $UN2 1)) - (= $UL3 - (Cons - (with_self $K $H) $UL2)) - (= $N3 $N2) - (= $L3 $L2))))) - (, - (= $RA3 $RA2) - (= $L3 $L2) - (= $N3 $N2) - (= $UN3 $UN2) - (= $UL3 $UL2))))) -; - + (member + (with_self $_ $H) $L2) + (, + (= $L3 $L2) + (= $N3 $N2) + (= $UN3 $UN2) + (= $UL3 $UL2)) + (, + (is $N3 + (+ $N2 1)) + (= $L3 + (Cons + (with_self $K $H) $L2)) + (= $UN3 $UN2) + (= $UL3 $UL2))) + (det-if-then-else + (member + (with_self $_ $H) $UL2) + (, + (= $L3 $L2) + (= $N3 $N2) + (= $UN3 $UN2) + (= $UL3 $UL2)) + (, + (is $UN3 + (+ $UN2 1)) + (= $UL3 + (Cons + (with_self $K $H) $UL2)) + (= $N3 $N2) + (= $L3 $L2))))) + (, + (= $RA3 $RA2) + (= $L3 $L2) + (= $N3 $N2) + (= $UN3 $UN2) + (= $UL3 $UL2)))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: covered_pos_examples/1 ; -; - +; * ; -; - +; * syntax: covered_examples(-CE) ; -; - +; * ; -; - +; * args: CE ... list of IDs of covered positive examples ; -; - +; * ; -; - +; * description: returns IDs of all covered positive examples ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (covered-pos-examples $Bag) - ( (det-if-then-else - (evaluated no) eval-examples True) - (findall $ID - (, - (get-example $ID $_ +) - (prooftrees $ID success $_)) $Bag) - (set-det))) -; - + (= (covered-pos-examples $Bag) + (det-if-then-else + (evaluated no) eval-examples True) + (findall $ID + (, + (get-example $ID $_ +) + (prooftrees $ID success $_)) $Bag) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: covered_neg_examples/1 ; -; - +; * ; -; - +; * syntax: covered_neg_examples(-CE) ; -; - +; * ; -; - +; * args: CE ... list of IDs of covered negative examples ; -; - +; * ; -; - +; * description: returns IDs of all covered negative examples ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (covered-neg-examples $Bag) - ( (det-if-then-else - (evaluated no) eval-examples True) - (findall $ID - (, - (get-example $ID $_ -) - (prooftrees $ID success $_)) $Bag) - (set-det))) -; + (= (covered-neg-examples $Bag) + (det-if-then-else + (evaluated no) eval-examples True) + (findall $ID + (, + (get-example $ID $_ -) + (prooftrees $ID success $_)) $Bag) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: all_covered_examples/1 ; -; - +; * ; -; - +; * syntax: all_covered_examples(-CE) ; -; - +; * ; -; - +; * args: CE ... list of IDs of covered negative examples ; -; - +; * ; -; - +; * description: returns IDs of all covered examples ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (all-covered-examples $Bag) - ( (det-if-then-else - (evaluated no) eval-examples True) - (findall $ID - (, - (get-example $ID $_ $_) - (prooftrees $ID success $_)) $Bag) - (set-det))) -; - + (= (all-covered-examples $Bag) + (det-if-then-else + (evaluated no) eval-examples True) + (findall $ID + (, + (get-example $ID $_ $_) + (prooftrees $ID success $_)) $Bag) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: complexity/2 ; -; - +; * ; -; - +; * syntax: complexity(+ClauseID,-Size) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: for kb references ; -; - +; * complexity/2 calculates the size of a clause, ; -; - +; * defined to be the number of constant and function ; -; - +; * symbol occurences in the literals of the clause. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (complexity $I $C) - ( (integer $I) - (get-clause $I $_ $_ $Clause $_) - (compute-complexity $Clause $C) - (set-det))) -; + (= (complexity $I $C) + (integer $I) + (get-clause $I $_ $_ $Clause $_) + (compute-complexity $Clause $C) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: complexity/2 ; -; - +; * ; -; - +; * syntax: complexity(+CL,-Size) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: for clauses in list representation ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - (= - (complexity $Clause $C) - ( (= $Clause - (Cons - (with_self $H - (p)) $_)) - (compute-complexity $Clause $C) - (set-det))) -; +; *********************************************************************** + (= (complexity $Clause $C) + (= $Clause + (Cons + (with_self $H + (p)) $_)) + (compute-complexity $Clause $C) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: complexity/2 ; -; - +; * ; -; - +; * syntax: complexity(List_of_ClauseIDs,-Size) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: for a list of kb references ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (complexity - (Cons $ID $List) $C) - ( (integer $ID) - (findall $Com - (, - (member $I - (Cons $ID $List)) - (get-clause $I $_ $_ $Clause $_) - (compute-complexity $Clause $Com)) $Bag) - (sum $Bag $C) - (set-det))) -; - + (= (complexity (Cons $ID $List) $C) + (integer $ID) + (findall $Com + (, + (member $I + (Cons $ID $List)) + (get-clause $I $_ $_ $Clause $_) + (compute-complexity $Clause $Com)) $Bag) + (sum $Bag $C) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: complexity/2 ; -; - +; * ; -; - +; * syntax: complexity(+Term,-Size) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: for arbitrary MeTTa terms ( but not integers) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - (= - (complexity $Term $Complexity) - ( (term-size $Term $Complexity) (set-det))) -; +; *********************************************************************** + (= (complexity $Term $Complexity) + (term-size $Term $Complexity) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: complexity/2 ; -; - +; * ; -; - +; * syntax: complexity(+usr,-Size) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: for all clauses with label usr ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - (= - (complexity usr $C) - ( (findall $I - (, - (get-clause $_ $_ $_ $Clause usr) - (compute-complexity $Clause $I)) $Bag) - (sum $Bag $C) - (set-det))) -; +; *********************************************************************** + (= (complexity usr $C) + (findall $I + (, + (get-clause $_ $_ $_ $Clause usr) + (compute-complexity $Clause $I)) $Bag) + (sum $Bag $C) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: complexity/2 ; -; - +; * ; -; - +; * syntax: complexity(+examples,-Size) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: for all examples ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - (= - (complexity examples $C) - ( (findall $I - (, - (get-example $_ $Clause $_) - (compute-complexity $Clause $I)) $Bag) - (sum $Bag $C) - (set-det))) -; +; *********************************************************************** + (= (complexity examples $C) + (findall $I + (, + (get-example $_ $Clause $_) + (compute-complexity $Clause $I)) $Bag) + (sum $Bag $C) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: compute_complexity/2 ; -; - +; * ; -; - +; * syntax: compute_complexity(+CL,-Size) ; -; - +; * ; -; - +; * args: CL ... clause in list represenation ; -; - +; * ; -; - +; * description: complexity for a clause in list representation ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (compute_complexity () 0) True) -; +; *********************************************************************** - (= - (compute-complexity - (Cons - (with_self $L $_) $More) $C) - ( (term-size $L $C1) - (compute-complexity $More $C2) - (is $C - (+ $C1 $C2)))) -; + (= (compute_complexity () 0) True) + (= (compute-complexity (Cons (with_self $L $_) $More) $C) + (term-size $L $C1) + (compute-complexity $More $C2) + (is $C + (+ $C1 $C2))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: ivonTunterE/1 ; -; - +; * ; -; - +; * syntax: ivonTunterE(-ITE) ; -; - +; * ; -; - +; * args: ITE... information content of T, given E ; -; - +; * (only for funtion-free T and E!!) ; -; - +; * ; -; - +; * description: Given evidence E for T. Then if T|=E, then ; -; - +; * I(T|E) = I(T) + I(E|T). If T = B & H, then T compresses ; -; - +; * the examples E if I(T|E) =< I(B & E) ; -; - +; * Precondition: B, T, E function-free! ; -; - +; * ; -; - +; * How to compute I(T) and I(E|T) (for function-free T,E): ; -; - +; * - I(E|T) = log2( (|M+(T)| |E+|) ) + log2( (|M-(T)| |E-(T)|) ) ; -; - +; * - P(T) .. #Pred. Symbols in T ; -; - +; * C(T) .. #Constants in T ; -; - +; * V(T) .. max number of vars of any clause in T ; -; - +; * a .. max arity of any pred. symbol in T ; -; - +; * l .. max cardinality of the body of any clause in T ; -; - +; * |T| .. #clauses in T ; -; - +; * ; -; - +; * |A(T)| =< P(T)*(C(T) + V(T))^a ; -; - +; * |CL(T)| =< |A(T)| * (|A(T)| l) ; -; - +; * I(T) = log2( (|CL(T)| |T|) ) ; -; - +; * where (a b) == (a) = n!/(k!*(n-k)!) ; -; - +; * (b) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: L. DeRaedth, S. Muggleton: ILP: Theory and Methods ; -; - +; * submitted to Journal of LP ; -; - +; * ; -; - - - - (= - (ivonTunterE $ITE) - ( (findall - (/ $P $A) - (, - (get-clause $_ $_ $_ $CL $_) - (member - (with_self $F $_) $CL) - (functor $F $P $A)) $Predlist0) - (make-unique $Predlist0 $Predlist) - (max-arity $Predlist $A) - (length $Predlist $PT) - (findall $C - (, - (get-clause $_ $H $B $_ $_) - (sub-term $C - (, $H $B)) - (atomic $C) - (\== $C True)) $Clist0) - (make-unique $Clist0 $Clist) - (length $Clist $CT) - (findall - (/ $V $L2) - (, - (get-clause $_ $_ $_ $CL $_) - (length $CL $L1) - (is $L2 - (- $L1 1)) - (vars $CL $VL) - (length $VL $V)) $LList) - (maxvars $LList $VT) - (max-arity $LList $L) - (findall $ID - (get-clause $ID $_ $_ $_ $_) $IDL) - (length $IDL $BT) - (ivonT $PT $CT $VT $A $L $BT $IT) - (ivonEunterT $Predlist $CT $IET) - (is $ITE - (+ $IT $IET)))) -; - +; *********************************************************************** + (= (ivonTunterE $ITE) + (findall + (/ $P $A) + (, + (get-clause $_ $_ $_ $CL $_) + (member + (with_self $F $_) $CL) + (functor $F $P $A)) $Predlist0) + (make-unique $Predlist0 $Predlist) + (max-arity $Predlist $A) + (length $Predlist $PT) + (findall $C + (, + (get-clause $_ $H $B $_ $_) + (sub-term $C + (, $H $B)) + (atomic $C) + (\== $C True)) $Clist0) + (make-unique $Clist0 $Clist) + (length $Clist $CT) + (findall + (/ $V $L2) + (, + (get-clause $_ $_ $_ $CL $_) + (length $CL $L1) + (is $L2 + (- $L1 1)) + (vars $CL $VL) + (length $VL $V)) $LList) + (maxvars $LList $VT) + (max-arity $LList $L) + (findall $ID + (get-clause $ID $_ $_ $_ $_) $IDL) + (length $IDL $BT) + (ivonT $PT $CT $VT $A $L $BT $IT) + (ivonEunterT $Predlist $CT $IET) + (is $ITE + (+ $IT $IET))) - (= - (ivonT $PT0 $CT0 $VT0 $A0 $L0 $BT0 $IT) - ( (is $PT - (float $PT0)) - (is $CT - (float $CT0)) - (is $VT - (float $VT0)) - (is $A - (float $A0)) - (is $L - (float $L0)) - (is $BT - (float $BT0)) - (is $X1 - (+ $CT $VT)) - (pow $X1 $A $X2) - (is $AT - (* $PT $X2)) - (nueberk $AT $L $X3) - (is $CLT - (* $AT $X3)) - (log2nueberk $CLT $BT $IT))) -; + (= (ivonT $PT0 $CT0 $VT0 $A0 $L0 $BT0 $IT) + (is $PT + (float $PT0)) + (is $CT + (float $CT0)) + (is $VT + (float $VT0)) + (is $A + (float $A0)) + (is $L + (float $L0)) + (is $BT + (float $BT0)) + (is $X1 + (+ $CT $VT)) + (pow $X1 $A $X2) + (is $AT + (* $PT $X2)) + (nueberk $AT $L $X3) + (is $CLT + (* $AT $X3)) + (log2nueberk $CLT $BT $IT)) - (= - (ivonEunterT $Predlist $CT $IET) - ( (all-atoms $Predlist $CT $HT0) - (mTplus $CT $MTP0) - (is $HT - (float $HT0)) - (is $MTP - (float $MTP0)) - (is $MTM - (- $HT $MTP)) - (findall $P - (get-example $_ $P +) $PL) - (length $PL $PLN0) - (findall $N - (get-example $_ $N -) $NL) - (length $NL $NLN0) - (is $PLN - (float $PLN0)) - (is $NLN - (float $NLN0)) - (log2nueberk $MTP $PLN $LX) - (log2nueberk $MTM $NLN $LY) - (is $IET - (+ $LX $LY)))) -; + (= (ivonEunterT $Predlist $CT $IET) + (all-atoms $Predlist $CT $HT0) + (mTplus $CT $MTP0) + (is $HT + (float $HT0)) + (is $MTP + (float $MTP0)) + (is $MTM + (- $HT $MTP)) + (findall $P + (get-example $_ $P +) $PL) + (length $PL $PLN0) + (findall $N + (get-example $_ $N -) $NL) + (length $NL $NLN0) + (is $PLN + (float $PLN0)) + (is $NLN + (float $NLN0)) + (log2nueberk $MTP $PLN $LX) + (log2nueberk $MTM $NLN $LY) + (is $IET + (+ $LX $LY))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: ivonBundE/1 ; -; - +; * ; -; - +; * syntax: ivonBundE(-IBE) ; -; - +; * ; -; - +; * args: ITE... information content of B & E ; -; - +; * (only for funtion-free B and E!!) ; -; - +; * ; -; - +; * description: computes information content of B & E. ; -; - +; * If T = B & H, then T compresses ; -; - +; * the examples E if I(T|E) =< I(B & E) ; -; - +; * Precondition: B, T, E function-free! ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: L. DeRaedth, S. Muggleton: ILP: Theory and Methods ; -; - +; * submitted to Journal of LP ; -; - +; * ; -; - - +; *********************************************************************** - (= - (ivonBundE $IBE) - ( (findall - (/ $P $A) - (, - (get-clause $_ $_ $_ $CL $_) - (member - (with_self $F $_) $CL) - (functor $F $P $A)) $Predlist00) - (findall - (/ $P1 $A1) - (, - (get-example $_ $F $_) - (functor $F $P1 $A1)) $Predlist01) - (append $Predlist00 $Predlist01 $Predlist0) - (make-unique $Predlist0 $Predlist) - (max-arity $Predlist $A) - (length $Predlist $PT) - (findall $C - (, - (get-clause $_ $H $B $_ $_) - (sub-term $C - (, $H $B)) - (atomic $C) - (\== $C True)) $Clist00) - (findall $C1 - (, - (get-example $_ $H1 $_) - (sub-term $C1 $H1) - (atomic $C1) - (\== $C1 True)) $Clist01) - (append $Clist00 $Clist01 $Clist0) - (make-unique $Clist0 $Clist) - (length $Clist $CT) - (findall - (/ $V $L2) - (, - (get-clause $_ $_ $_ $CL $_) - (length $CL $L1) - (is $L2 - (- $L1 1)) - (vars $CL $VL) - (length $VL $V)) $LList) - (maxvars $LList $VT) - (max-arity $LList $L) - (findall $ID - (get-clause $ID $_ $_ $_ $_) $IDL00) - (findall $ID1 - (get-example $ID1 $_ $_) $IDL01) - (append $IDL00 $IDL01 $IDL) - (length $IDL $BT) - (ivonT $PT $CT $VT $A $L $BT $IBE))) -; + (= (ivonBundE $IBE) + (findall + (/ $P $A) + (, + (get-clause $_ $_ $_ $CL $_) + (member + (with_self $F $_) $CL) + (functor $F $P $A)) $Predlist00) + (findall + (/ $P1 $A1) + (, + (get-example $_ $F $_) + (functor $F $P1 $A1)) $Predlist01) + (append $Predlist00 $Predlist01 $Predlist0) + (make-unique $Predlist0 $Predlist) + (max-arity $Predlist $A) + (length $Predlist $PT) + (findall $C + (, + (get-clause $_ $H $B $_ $_) + (sub-term $C + (, $H $B)) + (atomic $C) + (\== $C True)) $Clist00) + (findall $C1 + (, + (get-example $_ $H1 $_) + (sub-term $C1 $H1) + (atomic $C1) + (\== $C1 True)) $Clist01) + (append $Clist00 $Clist01 $Clist0) + (make-unique $Clist0 $Clist) + (length $Clist $CT) + (findall + (/ $V $L2) + (, + (get-clause $_ $_ $_ $CL $_) + (length $CL $L1) + (is $L2 + (- $L1 1)) + (vars $CL $VL) + (length $VL $V)) $LList) + (maxvars $LList $VT) + (max-arity $LList $L) + (findall $ID + (get-clause $ID $_ $_ $_ $_) $IDL00) + (findall $ID1 + (get-example $ID1 $_ $_) $IDL01) + (append $IDL00 $IDL01 $IDL) + (length $IDL $BT) + (ivonT $PT $CT $VT $A $L $BT $IBE)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: all_atoms/3 ; -; - +; * ; -; - +; * syntax: all_atoms(+Predlist,+No_constants,-No_atoms) ; -; - +; * ; -; - +; * args: Predlist = [p1/arity1,...,pn/arityn] list of pred. symbols and ; -; - +; * their arities ; -; - +; * No_constants.... number c of constants in the current theory ; -; - +; * No_atoms = number of atoms that can be built from the preds ; -; - +; * in predlist and the c constants ; -; - +; * = c^arity1 + .... + c^arityn ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (all_symbols () $_ 0) True) -; +; *********************************************************************** - (= - (all-atoms - (Cons - (/ $_ $A0) $R) $CT0 $HT) - ( (all-atoms $R $CT0 $HT0) - (is $CT - (float $CT0)) - (is $A - (float $A0)) - (pow $CT $A $X) - (is $HT - (+ $HT0 $X)))) -; + (= (all_symbols () $_ 0) True) + (= (all-atoms (Cons (/ $_ $A0) $R) $CT0 $HT) + (all-atoms $R $CT0 $HT0) + (is $CT + (float $CT0)) + (is $A + (float $A0)) + (pow $CT $A $X) + (is $HT + (+ $HT0 $X))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: max_arity/2, maxvars/2, maxi/3 ; -; - +; * ; -; - +; * syntax: max_arity(+Plist,-A), maxvars(+Vlist,-V), maxi(+X,+Y,-Z) ; -; - +; * ; -; - +; * args: Plist = [_/n1,...,_/nn] for numbers ni, A is the max of the ni ; -; - +; * Vlist = [_/n1,...,_/nn] for numbers ni, V is the max of the ni ; -; - +; * Z is the max of X and Y ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (max-arity - (:: (/ $_ $A)) $A) - (set-det)) -; - - (= - (max-arity - (Cons - (/ $_ $A) $R) $C) - ( (max-arity $R $B) (maxi $A $B $C))) -; - + (= (max-arity (:: (/ $_ $A)) $A) + (set-det)) + (= (max-arity (Cons (/ $_ $A) $R) $C) + (max-arity $R $B) + (maxi $A $B $C)) - (= - (maxvars - (:: (/ $A $_)) $A) + (= (maxvars (:: (/ $A $_)) $A) (set-det)) -; - - (= - (maxvars - (Cons - (/ $A $_) $R) $C) - ( (maxvars $R $B) (maxi $A $B $C))) -; + (= (maxvars (Cons (/ $A $_) $R) $C) + (maxvars $R $B) + (maxi $A $B $C)) - - (= - (maxi $A $B $C) + (= (maxi $A $B $C) (det-if-then-else (>= $A $B) (= $C $A) (= $C $B))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: herbrand_base_ff/1 ; -; - +; * ; -; - +; * syntax: herbrand_base_ff(-M) ; -; - +; * ; -; - +; * args: M .. reduced list of atoms entailed by the current ; -; - +; * function-free theory ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** + (= (herbrand-base-ff $M) + (findall $H + (get-clause $_ $H True $_ $_) $M00) + (reduce-hb $M00 $M0) + (findall $ID + (, + (get-clause $ID $_ $B $_ $_) + (\== $B True)) $IDlist) + (herbrand-base-ff $IDlist $M0 $M)) - (= - (herbrand-base-ff $M) - ( (findall $H - (get-clause $_ $H True $_ $_) $M00) - (reduce-hb $M00 $M0) - (findall $ID - (, - (get-clause $ID $_ $B $_ $_) - (\== $B True)) $IDlist) - (herbrand-base-ff $IDlist $M0 $M))) -; - - - (= - (herbrand-base-ff $IDlist $M $M2) - ( (herbrand-base-ff $IDlist $M $M $M1 $Mark) (det-if-then-else (== $Mark changed) (herbrand-base-ff $IDlist $M1 $M2) (= $M2 $M1)))) -; - - - (= - (herbrand_base_ff () $_ $M $M not_changed) True) -; - - (= - (herbrand-base-ff - (Cons $ID $R) $M $M1 $M4 $Mark) - ( (herbrand-base-ff $R $M $M1 $M2 $Mark0) - (get-clause $ID $H $B $_ $_) - (findall $H1 - (match-body $H $B $M $H1) $HL) - (append $HL $M2 $M3) - (make-unique $M3 $M31) - (reduce-hb $M31 $M4) - (det-if-then-else - (remove-variant $M2 $M4 Nil) - (= $Mark $Mark0) - (= $Mark changed)))) -; - - - - (= - (match-body $H $B $M $H1) - ( (copy-term - (, $H $B) - (, $H1 $B1)) - (copy-term $M $M1) - (match-body $B1 $M1))) -; - - - (= - (match-body - (, $A $B) $M) - ( (set-det) - (member $A $M) - (match-body $B $M))) -; - - (= - (match-body $A $M) + (= (herbrand-base-ff $IDlist $M $M2) + (herbrand-base-ff $IDlist $M $M $M1 $Mark) + (det-if-then-else + (== $Mark changed) + (herbrand-base-ff $IDlist $M1 $M2) + (= $M2 $M1))) + + (= (herbrand_base_ff () $_ $M $M not_changed) True) + (= (herbrand-base-ff (Cons $ID $R) $M $M1 $M4 $Mark) + (herbrand-base-ff $R $M $M1 $M2 $Mark0) + (get-clause $ID $H $B $_ $_) + (findall $H1 + (match-body $H $B $M $H1) $HL) + (append $HL $M2 $M3) + (make-unique $M3 $M31) + (reduce-hb $M31 $M4) + (det-if-then-else + (remove-variant $M2 $M4 Nil) + (= $Mark $Mark0) + (= $Mark changed))) + + + (= (match-body $H $B $M $H1) + (copy-term + (, $H $B) + (, $H1 $B1)) + (copy-term $M $M1) + (match-body $B1 $M1)) + + (= (match-body (, $A $B) $M) + (set-det) + (member $A $M) + (match-body $B $M)) + (= (match-body $A $M) (member $A $M)) -; - - (= - (reduce-hb $L $L1) + (= (reduce-hb $L $L1) (reduce-hb $L $L $L1)) -; - - (= - (reduce_hb () $_ ()) True) -; - - (= - (reduce-hb - (Cons $H $R) $L $R2) - ( (reduce-hb $R $L $R1) (det-if-then-else (not (sub-contained-in $H $L)) (= $R2 (Cons $H $R1)) (= $R2 $R1)))) -; - + (= (reduce_hb () $_ ()) True) + (= (reduce-hb (Cons $H $R) $L $R2) + (reduce-hb $R $L $R1) + (det-if-then-else + (not (sub-contained-in $H $L)) + (= $R2 + (Cons $H $R1)) + (= $R2 $R1))) - (= - (sub-contained-in $H - (Cons $H1 $R)) + (= (sub-contained-in $H (Cons $H1 $R)) (det-if-then-else (, (\== $H1 $H) (subsumes-chk $H1 $H)) True (sub-contained-in $H $R))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: mTplus/2 ; -; - +; * ; -; - +; * syntax: mTplus(+No_constants,-MT) ; -; - +; * ; -; - +; * args: No_constants... number c of constants in T ; -; - +; * MT ... size of M+(T) for theory T ; -; - +; * ; -; - +; * description: determines first the reduced Herbrand base of T, i.e. ; -; - +; * a list [A1,...,An] where Ai are atoms that might contain variables. ; -; - +; * The size of M+(T) is then ; -; - +; * |vars(A1)|^c + .... + |vars(An)|^c ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (mTplus $CT $MT) - ( (herbrand-base-ff $M) (hb-plus $M $CT $MT))) -; - +; *********************************************************************** - (= - (hb_plus () $_ 0) True) -; + (= (mTplus $CT $MT) + (herbrand-base-ff $M) + (hb-plus $M $CT $MT)) - (= - (hb-plus - (Cons $T $R) $CT0 $MT) - ( (hb-plus $R $CT0 $MT1) - (vars $T $V) - (length $V $VN0) - (is $CT - (float $CT0)) - (is $VN - (float $VN0)) - (pow $CT $VN $X) - (is $MT - (+ $MT1 $X)))) -; + (= (hb_plus () $_ 0) True) + (= (hb-plus (Cons $T $R) $CT0 $MT) + (hb-plus $R $CT0 $MT1) + (vars $T $V) + (length $V $VN0) + (is $CT + (float $CT0)) + (is $VN + (float $VN0)) + (pow $CT $VN $X) + (is $MT + (+ $MT1 $X))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: code_length/2 ; -; - +; * ; -; - +; * syntax: code_length(+Term,-CL) ; -; - +; * ; -; - +; * args: CL .. code length of Term ; -; - +; * ; -; - +; * description: code length of a term a la R. Wirth/S. Muggleton: ; -; - +; * let sym(Term) be all symbols in Term, and N the number of ; -; - +; * all symbol occurrences in Term. Let ps be the relative ; -; - +; * frequency of symbol s in Term. Then ; -; - +; * code_length(Term)= N * sum_{s in sym(Term)} -ps log2ps ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (code-length $S $L) - ( (skolemize $S $_ $S0) - (symbol-frequencies $S0 Nil $SymS) - (relative-frequencies $SymS 0 $N $SymS1) - (code-length1 $SymS1 $L0) - (is $L - (* $N $L0)))) -; + (= (code-length $S $L) + (skolemize $S $_ $S0) + (symbol-frequencies $S0 Nil $SymS) + (relative-frequencies $SymS 0 $N $SymS1) + (code-length1 $SymS1 $L0) + (is $L + (* $N $L0))) + (= (code_length1 () 0) True) + (= (code-length1 (Cons $F $R) $L) + (code-length1 $R $L0) + (log2 $F $LF) + (is $L1 + (* $F + (- $LF))) + (is $L + (+ $L0 $L1))) - (= - (code_length1 () 0) True) -; - (= - (code-length1 - (Cons $F $R) $L) - ( (code-length1 $R $L0) - (log2 $F $LF) - (is $L1 - (* $F - (- $LF))) - (is $L - (+ $L0 $L1)))) -; + (= (relative_frequencies () $N $N ()) True) + (= (relative-frequencies (Cons (/ (/ $_ $_) $M) $R) $N0 $N (Cons $RM $R1)) + (is $N1 + (+ $N0 $M)) + (relative-frequencies $R $N1 $N $R1) + (is $RM + (/ $M $N))) + (= (symbol-frequencies $X $L $L1) + (atomic $X) + (set-det) + (update-frequency-list $L $X 0 $L1)) + (= (symbol-frequencies $X $L $L1) + (functor $X $F $N) + (update-frequency-list $L $F $N $L0) + (symbol-frequencies $N $X $L0 $L1)) - (= - (relative_frequencies () $N $N ()) True) -; - - (= - (relative-frequencies - (Cons - (/ - (/ $_ $_) $M) $R) $N0 $N - (Cons $RM $R1)) - ( (is $N1 - (+ $N0 $M)) - (relative-frequencies $R $N1 $N $R1) - (is $RM - (/ $M $N)))) -; - - - - (= - (symbol-frequencies $X $L $L1) - ( (atomic $X) - (set-det) - (update-frequency-list $L $X 0 $L1))) -; - - (= - (symbol-frequencies $X $L $L1) - ( (functor $X $F $N) - (update-frequency-list $L $F $N $L0) - (symbol-frequencies $N $X $L0 $L1))) -; - - - (= - (symbol-frequencies 0 $_ $L $L) + (= (symbol-frequencies 0 $_ $L $L) (set-det)) -; - - (= - (symbol-frequencies $N $X $L $L2) - ( (is $N1 - (- $N 1)) - (symbol-frequencies $N1 $X $L $L1) - (arg $N $X $Xn) - (symbol-frequencies $Xn $L1 $L2))) -; - - - - (= - (update_frequency_list () $F $N - ( (/ - (/ $F $N) 1))) True) -; - - (= - (update-frequency-list - (Cons - (/ - (/ $F $N) $M) $R) $F $N - (Cons - (/ - (/ $F $N) $M1) $R)) - ( (set-det) (is $M1 (+ $M 1)))) -; - - (= - (update-frequency-list - (Cons $X $R) $F $N - (Cons $X $R1)) + (= (symbol-frequencies $N $X $L $L2) + (is $N1 + (- $N 1)) + (symbol-frequencies $N1 $X $L $L1) + (arg $N $X $Xn) + (symbol-frequencies $Xn $L1 $L2)) + + + (= (update_frequency_list () $F $N ((/ (/ $F $N) 1))) True) + (= (update-frequency-list (Cons (/ (/ $F $N) $M) $R) $F $N (Cons (/ (/ $F $N) $M1) $R)) + (set-det) + (is $M1 + (+ $M 1))) + (= (update-frequency-list (Cons $X $R) $F $N (Cons $X $R1)) (update-frequency-list $R $F $N $R1)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: encoding_length_examples/1, encoding_length_clause/2 ; -; - +; * ; -; - +; * syntax: encoding_length_examples(-EE) ; -; - +; * encoding_length_clause(+CL,-EC) ; -; - +; * ; -; - +; * args: EE, EC.. floats ; -; - +; * CL... clause in list representation ; -; - +; * ; -; - +; * description: encoding length a la Quinlan: ; -; - +; * for examples: PN.. no of pos ex., NN.. no. of neg ex, U = PN + NN ; -; - +; * EE = log2(U) + log2((U PN)) ; -; - +; * for clauses: N.. length of Clause, Preds.. no of preds, ; -; - +; * A .. no of poss. args ; -; - +; * EC = (sum_{i=1}^{N} bits for literal i)/log2(N!) ; -; - +; * bits for literali = 1 + log2(Preds) + log2(A) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (encoding-length-examples $X) - ( (mysetof $ID - (^ $F - (get-example $ID $F +)) $PL) - (length $PL $PN) - (mysetof $ID1 - (^ $F1 - (get-example $ID1 $F1 -)) $NL) - (length $NL $NN) - (is $U - (+ $PN $NN)) - (log2 $U $LU) - (is $U1 - (float $U)) - (is $PN1 - (float $PN)) - (log2nueberk $U1 $PN1 $Y) - (is $X - (+ $LU $Y)))) -; + (= (encoding-length-examples $X) + (mysetof $ID + (^ $F + (get-example $ID $F +)) $PL) + (length $PL $PN) + (mysetof $ID1 + (^ $F1 + (get-example $ID1 $F1 -)) $NL) + (length $NL $NN) + (is $U + (+ $PN $NN)) + (log2 $U $LU) + (is $U1 + (float $U)) + (is $PN1 + (float $PN)) + (log2nueberk $U1 $PN1 $Y) + (is $X + (+ $LU $Y))) + (= (encoding-length-clause $CL $EL) + (length $CL $N) + (is $N1 + (float $N)) + (sum-of-logs 1.0 $N1 $LNF) + (encoding-length-lits $CL $Lits0) + (get-predlist $PList) + (length $PList $Preds) + (log2 $Preds $LPreds) + (is $Lits + (+ + (+ $Lits0 $N) + (* $N $LPreds))) + (is $EL + (/ $Lits $LNF))) - (= - (encoding-length-clause $CL $EL) - ( (length $CL $N) - (is $N1 - (float $N)) - (sum-of-logs 1.0 $N1 $LNF) - (encoding-length-lits $CL $Lits0) - (get-predlist $PList) - (length $PList $Preds) - (log2 $Preds $LPreds) - (is $Lits - (+ - (+ $Lits0 $N) - (* $N $LPreds))) - (is $EL - (/ $Lits $LNF)))) -; + (= (encoding-length-lits (Cons (with_self $H (p)) $R) $M) + (functor $H $_ $N) + (=.. $H + (Cons $_ $Args)) + (log2 $N $LN) + (encoding-length-lits $R $Args $M1) + (is $M + (+ $M1 $LN))) - - (= - (encoding-length-lits - (Cons - (with_self $H - (p)) $R) $M) - ( (functor $H $_ $N) - (=.. $H - (Cons $_ $Args)) - (log2 $N $LN) - (encoding-length-lits $R $Args $M1) - (is $M - (+ $M1 $LN)))) -; - - - (= - (encoding-length-lits - (Cons - (with_self $L $_) $R) $Args $M) - ( (length $Args $LA) - (log2 $LA $M0) - (=.. $L - (Cons $_ $Args1)) - (append $Args1 $Args $Args2) - (identical-make-unique $Args2 $Args3) - (encoding-length-lits $R $Args3 $M1) - (is $M - (+ $M0 $M1)))) -; - - (= - (encoding_length_lits () $_ 0) True) -; - + (= (encoding-length-lits (Cons (with_self $L $_) $R) $Args $M) + (length $Args $LA) + (log2 $LA $M0) + (=.. $L + (Cons $_ $Args1)) + (append $Args1 $Args $Args2) + (identical-make-unique $Args2 $Args3) + (encoding-length-lits $R $Args3 $M1) + (is $M + (+ $M0 $M1))) + (= (encoding_length_lits () $_ 0) True) diff --git a/miles/examples/ex1.metta b/miles/examples/ex1.metta index 3e83506..f27c51a 100644 --- a/miles/examples/ex1.metta +++ b/miles/examples/ex1.metta @@ -1,163 +1,58 @@ +; (convert_to_metta_file ex1 $_18168 miles/examples/ex1.pl miles/examples/ex1.metta) ; -; - - - - (= - (ex - (app - (1 2) - (3) - (1 2 3)) +) True) -; - - (= - (ex - (app - (x a) - (b c) - (x a b c)) +) True) -; - - (= - (ex - (app - (a) - (b c) - (a b c)) +) True) -; - - (= - (ex - (app () () ()) +) True) -; - - (= - (ex - (app - (p) () - (p)) +) True) -; - - (= - (ex - (app () - (u) - (u)) +) True) -; - - (= - (ex - (app () - (x y) - (x y)) +) True) -; - - (= - (ex - (app - (r s) () - (r s)) +) True) -; - - (= - (ex - (app - (g) - (d) - (g d)) +) True) -; - - (= - (ex - (app - (9 8 7) () - (9 8 7)) +) True) -; - - (= - (ex - (app () - (6 5 4) - (6 5 4)) +) True) -; - - (= - (ex - (app - (4 3 5) - (8) - (4 3 5 8)) +) True) -; - - (= - (ex - (app - (r w) - (q t s f i) - (r w q t s f i)) +) True) -; - - (= - (ex - (app - (j k l m) - (n o p q r) - (j k l m n o p q r)) +) True) -; - - (= - (ex - (app - (r s t) - (q u v) - (t s r q u v)) -) True) -; - - (= - (ex - (app - (s t) - (q u v) - (s r q u v)) -) True) -; - - +; ;; examples for appending two lists + + + (= (ex (app (1 2) (3) (1 2 3)) +) True) + (= (ex (app (x a) (b c) (x a b c)) +) True) + (= (ex (app (a) (b c) (a b c)) +) True) + (= (ex (app () () ()) +) True) + (= (ex (app (p) () (p)) +) True) + (= (ex (app () (u) (u)) +) True) + (= (ex (app () (x y) (x y)) +) True) + (= (ex (app (r s) () (r s)) +) True) + (= (ex (app (g) (d) (g d)) +) True) + (= (ex (app (9 8 7) () (9 8 7)) +) True) + (= (ex (app () (6 5 4) (6 5 4)) +) True) + (= (ex (app (4 3 5) (8) (4 3 5 8)) +) True) + (= (ex (app (r w) (q t s f i) (r w q t s f i)) +) True) + (= (ex (app (j k l m) (n o p q r) (j k l m n o p q r)) +) True) + (= (ex (app (r s t) (q u v) (t s r q u v)) -) True) + (= (ex (app (s t) (q u v) (s r q u v)) -) True) + +; +; +; Try for example +; +; | ?- clear_kb, init_kb('examples/ex1.pl'). +; | ?- argument_types. +; | ?- show_kb. +; | ?- complete_chk. ;; Antwort: no +; | ?- ip(A). ;; gibt alle unabgedeckten Bsple zur"uck +; | ?- clause_heads, eval_examples. +; | ?- show_kb. +; | ?- complete_chk. ;; geht jetzt gut +; | ?- correct_chk. +; | ?- fp(A). ;; gibt inkorrekte Klausel(n) + ihre Instantiierung(en) zur"uck +; ;; in der Form [ID:[Instanz]] +; | ?- refinement(ID,_). ;; wobei ID der der inkorrekten Klausel ist -> gibt +; ;; Spezialisierungen dieser Klausel (in einer Liste) +; | ?- flatten_kb. ;; kb funktionsfrei machen +; | ?- show_kb. +; +; ;; Sei ID1 der der Klausel: +; ;; app(A,B,C) :- cons_p(D,E,A),x_p(D),cons_p(F,G,E),a_p(F),nil_p(G), +; ;; cons_p(H,I,B),b_p(H),cons_p(J,G,I),c_p(J),cons_p(D,K,C),cons_p(F,B,K). +; ;; ID2 der der Klausel: +; ;; app(A,B,C) :- cons_p(D,E,A),a_p(D),nil_p(E), +; ;; cons_p(F,G,B),b_p(F),cons_p(H,E,G),c_p(H),cons_p(D,B,C). +; +; Dann teste: +; +; | ?- absorb(ID1,ID2,J), show_clause(J). +; | ?- elem_saturate(ID1,ID2,J1), show_clause(J1). +; | ?- saturate(ID1,J2,5), show_clause(J2). +; | ?- unflatten_kb. +; | ?- show_kb. ; ; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; - diff --git a/miles/examples/ex2.metta b/miles/examples/ex2.metta index c410987..72ac400 100644 --- a/miles/examples/ex2.metta +++ b/miles/examples/ex2.metta @@ -1,255 +1,301 @@ +; (convert_to_metta_file ex2 $_81266 miles/examples/ex2.pl miles/examples/ex2.metta) ; -; - - +; ;; clauses 1-4 define Rouveirols bg knowledge - (= - (column $X) - ( (brick $X) - (standing $X) - (is-on $X $Y) - (ground $Y))) -; + (= (column $X) + (brick $X) + (standing $X) + (is-on $X $Y) + (ground $Y)) - (= - (column $X) - ( (brick $X) - (standing $X) - (is-on $X $Y) - (column $Y))) -; + (= (column $X) + (brick $X) + (standing $X) + (is-on $X $Y) + (column $Y)) + (= (same-height $X $Y) + (ground $X) + (ground $Y)) - (= - (same-height $X $Y) - ( (ground $X) (ground $Y))) -; - - - (= - (same-height $X $Y) - ( (brick $X) - (standing $X) - (brick $Y) - (standing $Y) - (is-on $X $X1) - (is-on $Y $Y1) - (same-height $X1 $Y1))) -; - + (= (same-height $X $Y) + (brick $X) + (standing $X) + (brick $Y) + (standing $Y) + (is-on $X $X1) + (is-on $Y $Y1) + (same-height $X1 $Y1)) ; -; - - - - (= - (arch $X) - ( (part-of $A $X) - (part-of $B $X) - (part-of $C $X) - (is-on $A $B) - (is-on $A $C) - (is-on $B $D) - (is-on $C $E) - (ground $D) - (ground $E) - (left-of $B $C) - (does-not-touch $B $C) - (lying $A) - (wedge $A) - (standing $B) - (standing $C) - (brick $B) - (brick $C))) -; - - - - (= - (arch $X) - ( (part-of $A $X) - (part-of $B $X) - (part-of $C $X) - (is-on $A $B) - (is-on $A $C) - (is-on $B $D) - (is-on $C $E) - (left-of $B $C) - (does-not-touch $B $C) - (lying $A) - (wedge $A) - (standing $B) - (standing $C) - (brick $B) - (brick $C) - (brick $D) - (brick $E) - (does-not-touch $D $E) - (standing $D) - (standing $E) - (is-on $D $F) - (is-on $E $G) - (ground $G) - (ground $F))) -; - +; the next 2 examples (5+6) show arches of different heights + + + (= (arch $X) + (part-of $A $X) + (part-of $B $X) + (part-of $C $X) + (is-on $A $B) + (is-on $A $C) + (is-on $B $D) + (is-on $C $E) + (ground $D) + (ground $E) + (left-of $B $C) + (does-not-touch $B $C) + (lying $A) + (wedge $A) + (standing $B) + (standing $C) + (brick $B) + (brick $C)) + + + (= (arch $X) + (part-of $A $X) + (part-of $B $X) + (part-of $C $X) + (is-on $A $B) + (is-on $A $C) + (is-on $B $D) + (is-on $C $E) + (left-of $B $C) + (does-not-touch $B $C) + (lying $A) + (wedge $A) + (standing $B) + (standing $C) + (brick $B) + (brick $C) + (brick $D) + (brick $E) + (does-not-touch $D $E) + (standing $D) + (standing $E) + (is-on $D $F) + (is-on $E $G) + (ground $G) + (ground $F)) ; -; - - - (= - (arch $X) - ( (part-of $A $X) - (part-of $B $X) - (part-of $C $X) - (is-on $A $B) - (is-on $A $C) - (is-on $B $D) - (is-on $C $E) - (ground $D) - (ground $E) - (left-of $B $C) - (does-not-touch $B $C) - (lying $A) - (wedge $A) - (standing $B) - (standing $C) - (brick $B) - (brick $C) - (red $B) - (green $C))) -; - - - (= - (arch $X) - ( (part-of $A $X) - (part-of $B $X) - (part-of $C $X) - (is-on $A $B) - (is-on $A $C) - (is-on $B $D) - (is-on $C $E) - (ground $D) - (ground $E) - (left-of $B $C) - (does-not-touch $B $C) - (lying $A) - (wedge $A) - (standing $B) - (standing $C) - (brick $B) - (brick $C) - (green $B) - (red $C))) -; - - - (= - (arch $X) - ( (part-of $A $X) - (part-of $B $X) - (part-of $C $X) - (is-on $A $B) - (is-on $A $C) - (is-on $B $D) - (is-on $C $E) - (ground $D) - (ground $E) - (left-of $B $C) - (does-not-touch $B $C) - (lying $A) - (wedge $A) - (standing $B) - (standing $C) - (brick $B) - (brick $C) - (blue $B) - (red $C))) -; - +; the next 3 examples (7-9) show arches of different colors (-> lgg looks strange) + + (= (arch $X) + (part-of $A $X) + (part-of $B $X) + (part-of $C $X) + (is-on $A $B) + (is-on $A $C) + (is-on $B $D) + (is-on $C $E) + (ground $D) + (ground $E) + (left-of $B $C) + (does-not-touch $B $C) + (lying $A) + (wedge $A) + (standing $B) + (standing $C) + (brick $B) + (brick $C) + (red $B) + (green $C)) + + (= (arch $X) + (part-of $A $X) + (part-of $B $X) + (part-of $C $X) + (is-on $A $B) + (is-on $A $C) + (is-on $B $D) + (is-on $C $E) + (ground $D) + (ground $E) + (left-of $B $C) + (does-not-touch $B $C) + (lying $A) + (wedge $A) + (standing $B) + (standing $C) + (brick $B) + (brick $C) + (green $B) + (red $C)) + + (= (arch $X) + (part-of $A $X) + (part-of $B $X) + (part-of $C $X) + (is-on $A $B) + (is-on $A $C) + (is-on $B $D) + (is-on $C $E) + (ground $D) + (ground $E) + (left-of $B $C) + (does-not-touch $B $C) + (lying $A) + (wedge $A) + (standing $B) + (standing $C) + (brick $B) + (brick $C) + (blue $B) + (red $C)) ; -; - - - - (= - (column $X) - ( (brick $X) - (standing $X) - (is-on $X $Y) - (table $Y))) -; - - - (= - (column $X) - ( (block $X) - (standing $X) - (is-on $X $Y) - (ground $Y))) -; - - - (= - (column $X) - ( (block $X) - (standing $X) - (is-on $X $Y) - (column $Y))) -; - - - -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; +; some clauses (10-12) to test intra-construction + + + (= (column $X) + (brick $X) + (standing $X) + (is-on $X $Y) + (table $Y)) + + (= (column $X) + (block $X) + (standing $X) + (is-on $X $Y) + (ground $Y)) + + (= (column $X) + (block $X) + (standing $X) + (is-on $X $Y) + (column $Y)) + + +; +; +; +; ; ?- do_full_kb('examples/ex2.pl'). +; /* +; +; | ?- clear_kb, init_kb('examples/ex2.pl'). +; | ?- show_kb. +; | ?- intra_construct1(10,11,A,B,C). +; | ?- show_clauses([10,11,13,14,15]). +; | ?- g1_op(5,1,I). +; | ?- g1_op(5,3,I). +; | ?- absorb(5,1,I). +; | ?- elem_saturate(5,1,I). +; | ?- saturate(5,I,10). +; | ?- most_spec_v(5,I,J). +; | ?- inv_derivate(5,J). +; | ?- show_kb. +; | ?- lgg(7,9,J), show_clause(J). +; | ?- nr_lgg(7,9,J), show_clause(J), +; get_clause(J,_,_,CL,_),reduce_complete(CL,CL1), +; store_clause(_,CL1,nrlgg,I), show_clause(I). +; +; | ?- clear_kb, init_kb('examples/ex2.pl'). +; | ?- gen_msg(5,6,J,10),show_clause(J). +; | ?- gti(8,9,J),show_clause(J). +; +; | ?- clear_kb, init_kb('examples/ex2.pl'). +; | ?- rlgg(5,6,J),show_clause(J). +; +; ;X-MILES Protocol: +; +; :- clear_kb. +; ; knowledgebase cleared. +; :- init_kb('examples/ex2.pl'). +; ; file "/tmp_mnt/home/stahl/edl/framework/miles/examples/ex2.pl" consulted. +; :- intra_construct1(10,11,Xmout1,Xmout2,Xmout3). +; ; yes +; ; rule 13 created. +; ; rule 14 created. +; ; rule 15 created. +; :- g1_op(5,1,Xmout1). +; ; yes +; ; rule 16 created. +; :- absorb(5,1,Xmout1). +; ; yes +; ; rule 17 created. +; :- elem_saturate(5,1,Xmout1). +; ; yes +; ; rule 18 created. +; :- saturate(5,Xmout1,5). +; ; yes +; ; rule 19 created. +; :- most_spec_v(5,1,Xmout1). +; ; yes +; ; rule 20 created. +; :- inv_derivate(5,Xmout1). +; ; yes +; ; rule 21 created. +; :- lgg(7,9,Xmout1). +; ; yes +; ; rule 22 created. +; :- nr_lgg(7,9,Xmout1). +; ; yes +; ; rule 23 created. +; :- reduce_complete(23). +; ; yes +; :- delete_clause(1). +; :- delete_clause(2). +; :- delete_clause(3). +; :- delete_clause(4). +; :- delete_clause(5). +; :- delete_clause(6). +; :- delete_clause(7). +; :- delete_clause(8). +; :- delete_clause(9). +; :- delete_clause(10). +; :- delete_clause(11). +; :- delete_clause(12). +; :- delete_clause(13). +; :- delete_clause(14). +; :- delete_clause(15). +; :- delete_clause(16). +; :- delete_clause(17). +; :- delete_clause(18). +; :- delete_clause(19). +; :- delete_clause(20). +; :- delete_clause(21). +; :- delete_clause(22). +; :- delete_clause(23). +; ; all rules deleted. +; ; all examples deleted. +; :- clear_kb. +; ; knowledgebase cleared. +; :- init_kb(/tmp_mnt/home/stahl/edl/framework/miles/examples/ex2.pl). +; ; file "/tmp_mnt/home/stahl/edl/framework/miles/examples/ex2.pl" consulted. +; :- gen_msg(5,6,Xmout1). +; ; yes +; ; rule 15 created. +; :- gti(8,9,Xmout1). +; ; yes +; ; rule 16 created. +; :- delete_clause(1). +; :- delete_clause(2). +; :- delete_clause(3). +; :- delete_clause(4). +; :- delete_clause(7). +; :- delete_clause(10). +; :- delete_clause(11). +; :- delete_clause(12). +; :- delete_clause(15). +; :- delete_clause(5). +; :- delete_clause(6). +; :- delete_clause(8). +; :- delete_clause(9). +; :- delete_clause(16). +; ; all rules deleted. +; ; all examples deleted. +; :- clear_kb. +; ; knowledgebase cleared. +; :- init_kb('examples/ex2.pl'). +; ; file "/tmp_mnt/home/stahl/edl/framework/miles/examples/ex2.pl" consulted. +; :- rlgg(5,6,Xmout1). +; ; yes +; ; rule 13 created. ; ; ; @@ -258,89 +304,3 @@ ; ; ; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; - diff --git a/miles/examples/ex3.metta b/miles/examples/ex3.metta index c37df22..52169ca 100644 --- a/miles/examples/ex3.metta +++ b/miles/examples/ex3.metta @@ -1,87 +1,61 @@ +; (convert_to_metta_file ex3 $_203698 miles/examples/ex3.pl miles/examples/ex3.metta) ; -; - - - - (= - (s - (:: hans trifft susi) Nil) - ( (pn - (:: hans trifft susi) - (:: trifft susi)) - (v-t - (:: trifft susi) - (:: susi)) - (pn - (:: susi) Nil))) -; - - - (= - (s - (:: martha schlaeft) Nil) - ( (pn - (:: martha schlaeft) - (:: schlaeft)) (v-i (:: schlaeft) Nil))) -; - - - - - (= - (vp $A $B) - ( (v-t $A $C) (np $C $B))) -; - - (= - (vp - (:: sieht den mann) Nil) - ( (v-t - (:: sieht den mann) - (:: den mann)) - (det - (:: den mann) - (:: mann)) - (n - (:: mann) Nil))) -; - - (= - (vp - (:: hilft karl) Nil) - ( (v-t - (:: hilft karl) - (:: karl)) (pn (:: karl) Nil))) -; - - - - (= - (min1 $D - (Cons - (s $D) $E)) +; grammar rules + + + (= (s (:: hans trifft susi) Nil) + (pn + (:: hans trifft susi) + (:: trifft susi)) + (v-t + (:: trifft susi) + (:: susi)) + (pn + (:: susi) Nil)) + + (= (s (:: martha schlaeft) Nil) + (pn + (:: martha schlaeft) + (:: schlaeft)) + (v-i + (:: schlaeft) Nil)) + + + + (= (vp $A $B) + (v-t $A $C) + (np $C $B)) + (= (vp (:: sieht den mann) Nil) + (v-t + (:: sieht den mann) + (:: den mann)) + (det + (:: den mann) + (:: mann)) + (n + (:: mann) Nil)) + (= (vp (:: hilft karl) Nil) + (v-t + (:: hilft karl) + (:: karl)) + (pn + (:: karl) Nil)) + + + (= (min1 $D (Cons (s $D) $E)) (min1 $D $E)) -; - - (= - (min1 $F - (Cons - (s (s $F)) $G)) + (= (min1 $F (Cons (s (s $F)) $G)) (min1 $F $G)) -; - -; -; -; ; ; +; | ?- clear_kb,do_full_kb('examples/ex3.pl'). ; -; -; -; -; -; -; -; - +; Try: +; | ?- clear_kb, init_kb('examples/ex3.pl'). +; | ?- intra_construct1(1,2,A,B,C),show_clauses([1,2,A,B,C]). +; | ?- g2_op(1,2,A,B,C). ;; stellt Fragen +; | ?- show_kb. +; | ?- identify(4,3,J), show_clause(J). +; | ?- identify(5,I,J), show_clause(J). +; | ?- apply_g2([4,5,10],A,BB),show_kb. diff --git a/miles/examples/ex4.metta b/miles/examples/ex4.metta index 95d2660..974ce44 100644 --- a/miles/examples/ex4.metta +++ b/miles/examples/ex4.metta @@ -1,203 +1,145 @@ +; (convert_to_metta_file ex4 $_271132 miles/examples/ex4.pl miles/examples/ex4.metta) ; -; - +; diverse ; -; - +; index 1 and 2 ; -; - +; ;member(2,[1,2]):- member(2,[2]). ; -; - +; ;member(c,[a,b,c]):- member(c,[b,c]),member(c,[c]). ; -; - - - (= - (scene $X) - ( (part-of $X $Y) - (large $X) - (red $Y) - (part-of $X $Z) - (small $Z) - (green $Z) - (left-of $Y $Z))) -; - - (= - (scene $X) - ( (part-of $X $Y) - (small $X) - (red $Y) - (part-of $X $Z) - (large $Z) - (green $Z) - (left-of $Y $Z))) -; - +; index 3 and 4 + + (= (scene $X) + (part-of $X $Y) + (large $X) + (red $Y) + (part-of $X $Z) + (small $Z) + (green $Z) + (left-of $Y $Z)) + (= (scene $X) + (part-of $X $Y) + (small $X) + (red $Y) + (part-of $X $Z) + (large $Z) + (green $Z) + (left-of $Y $Z)) ; -; +; index 5-9 - - (= - (pet $X) + (= (pet $X) (cat $X)) -; - - (= - (pet $X) + (= (pet $X) (dog $X)) -; - - (= - (small $X) + (= (small $X) (cat $X)) -; - - - (= - (cuddly-pet $X) - ( (small $X) - (fluffy $X) - (dog $X))) -; - - (= - (cuddly-pet $X) - ( (fluffy $X) (cat $X))) -; + (= (cuddly-pet $X) + (small $X) + (fluffy $X) + (dog $X)) + (= (cuddly-pet $X) + (fluffy $X) + (cat $X)) - (= - (ex - (cuddly_pet cathy_the_cat) +) True) -; - - (= - (ex - (cuddly_pet rosi_the_rabbit) +) True) -; - - (= - (ex - (cuddly_pet tom_the_turtle) -) True) -; - + (= (ex (cuddly_pet cathy_the_cat) +) True) + (= (ex (cuddly_pet rosi_the_rabbit) +) True) + (= (ex (cuddly_pet tom_the_turtle) -) True) ; -; - - - (= - (has_wings p) True) -; - +; index 10-13 - (= - (has_beak p) True) -; + (= (has_wings p) True) + (= (has_beak p) True) - (= - (has-wings $X) + (= (has-wings $X) (bird $X)) -; - - (= - (has-beak $X) + (= (has-beak $X) (bird $X)) -; - ; -; - +; index 14 and 15 ; -; - +; ;min(2,[3,2]):- min(2,[2]). ; -; - +; ;min(5,[7,6,5]):- min(5,[6,5]). ; -; - +; index 16 and 17 ; -; - +; ;min1(D,[s(D)|E]):- min1(D,E). ; -; - +; ;min1(F,[s(s(F))|G]):- min1(F,G). ; ; +; | ?- clear_kb,do_full_kb('examples/ex4.pl'). ; +; Try: ; ; +; | ?- clear_kb,init_kb('examples/ex4.pl'). +; | ?- show_kb. +; | ?- lgg(1,2,J),show_clause(J). +; | ?- nr_lgg(1,2,J),show_clause(J). +; | ?- lgg(3,4,J),show_clause(J). +; | ?- nr_lgg(3,4,J),show_clause(J). +; | ?- gti(3,4,J),show_clause(J). ; erlaubt backtracking! +; | ?- lgti(3,4,C,_,_). +; | ?- lgg(8,9,J),show_clause(J). +; | ?- rlgg(8,9,J),show_clause(J). +; | ?- rlgg(8,9,cuddly_pet(_),J),show_clause(J). +; | ?- gen_msg(8,9,J),show_clause(J). +; | ?- rlgg(10,11,J),show_clause(J). +; | ?- intra_construct1(14,15,A,B,C),show_clauses([14,15,A,B,C]). +; | ?- intra_construct2(16,17,A,B,C),show_clauses([16,17,A,B,C]). ; ; +; end_of_file. ; +; Try for example ; +; | ?- clear_kb, init_kb('examples/ex1.pl'). +; | ?- argument_types. +; | ?- show_kb. +; | ?- complete_chk. ;; Antwort: no +; | ?- ip(A). ;; gibt alle unabgedeckten Bsple zur"uck +; | ?- clause_heads, eval_examples. +; | ?- show_kb. +; | ?- complete_chk. ;; geht jetzt gut +; | ?- correct_chk. +; | ?- fp(A). ;; gibt inkorrekte Klausel(n) + ihre Instantiierung(en) zur"uck +; ;; in der Form [ID:[Instanz]] +; | ?- refinement(ID,_). ;; wobei ID der der inkorrekten Klausel ist -> gibt +; ;; Spezialisierungen dieser Klausel (in einer Liste) +; | ?- flatten_kb. ;; kb funktionsfrei machen +; | ?- show_kb. ; +; ;; Sei ID1 der der Klausel: +; ;; app(A,B,C) :- cons_p(D,E,A),x_p(D),cons_p(F,G,E),a_p(F),nil_p(G), +; ;; cons_p(H,I,B),b_p(H),cons_p(J,G,I),c_p(J),cons_p(D,K,C),cons_p(F,B,K). +; ;; ID2 der der Klausel: +; ;; app(A,B,C) :- cons_p(D,E,A),a_p(D),nil_p(E), +; ;; cons_p(F,G,B),b_p(F),cons_p(H,E,G),c_p(H),cons_p(D,B,C). ; +; Dann teste: ; +; | ?- absorb(ID1,ID2,J), show_clause(J). +; | ?- elem_saturate(ID1,ID2,J1), show_clause(J1). +; | ?- saturate(ID1,J2,5), show_clause(J2). +; | ?- unflatten_kb. +; | ?- show_kb. ; ; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; - diff --git a/miles/examples/ex5.metta b/miles/examples/ex5.metta index bbfb3ff..4a839eb 100644 --- a/miles/examples/ex5.metta +++ b/miles/examples/ex5.metta @@ -1,228 +1,101 @@ +; (convert_to_metta_file ex5 $_346650 miles/examples/ex5.pl miles/examples/ex5.metta) ; -; - +; MENDEL ; -; - - - (= - (ex - (colour a red) +) True) -; - - (= - (ex - (colour b yellow) +) True) -; +; parent generation + (= (ex (colour a red) +) True) + (= (ex (colour b yellow) +) True) ; -; - - (= - (ex - (colour - (k a a) red) +) True) -; - - (= - (ex - (colour - (k a b) red) +) True) -; - - (= - (ex - (colour - (k b b) yellow) +) True) -; - +; f1 + (= (ex (colour (k a a) red) +) True) + (= (ex (colour (k a b) red) +) True) + (= (ex (colour (k b b) yellow) +) True) ; -; - - (= - (ex - (colour - (k a - (k a a)) red) +) True) -; - - (= - (ex - (colour - (k a - (k a b)) red) +) True) -; - - (= - (ex - (colour - (k a - (k b b)) red) +) True) -; - - (= - (ex - (colour - (k b - (k a a)) red) +) True) -; - - (= - (ex - (colour - (k b - (k a b)) red) +) True) -; - - (= - (ex - (colour - (k b - (k a b)) yellow) +) True) -; - - (= - (ex - (colour - (k b - (k b b)) yellow) +) True) -; - +; parent with f1 + (= (ex (colour (k a (k a a)) red) +) True) + (= (ex (colour (k a (k a b)) red) +) True) + (= (ex (colour (k a (k b b)) red) +) True) + (= (ex (colour (k b (k a a)) red) +) True) + (= (ex (colour (k b (k a b)) red) +) True) + (= (ex (colour (k b (k a b)) yellow) +) True) + (= (ex (colour (k b (k b b)) yellow) +) True) ; -; - - (= - (ex - (colour - (k - (k a a) - (k a a)) red) +) True) -; - - (= - (ex - (colour - (k - (k a a) - (k a b)) red) +) True) -; - - (= - (ex - (colour - (k - (k a a) - (k b b)) red) +) True) -; - - (= - (ex - (colour - (k - (k a b) - (k a b)) red) +) True) -; - - (= - (ex - (colour - (k - (k a b) - (k a b)) yellow) +) True) -; - - (= - (ex - (colour - (k - (k a b) - (k b b)) red) +) True) -; - - (= - (ex - (colour - (k - (k a b) - (k b b)) yellow) +) True) -; - - (= - (ex - (colour - (k - (k b b) - (k b b)) yellow) +) True) -; +; f2 + (= (ex (colour (k (k a a) (k a a)) red) +) True) + (= (ex (colour (k (k a a) (k a b)) red) +) True) + (= (ex (colour (k (k a a) (k b b)) red) +) True) + (= (ex (colour (k (k a b) (k a b)) red) +) True) + (= (ex (colour (k (k a b) (k a b)) yellow) +) True) + (= (ex (colour (k (k a b) (k b b)) red) +) True) + (= (ex (colour (k (k a b) (k b b)) yellow) +) True) + (= (ex (colour (k (k b b) (k b b)) yellow) +) True) - -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; ; ; +; Try: ; +; | ?- clear_kb, do_full_kb('examples/ex5.pl'). ; +; | ?- clear_kb, init_kb('examples/ex5.pl'). +; | ?- show_kb. +; | ?- lgg(1,2,J),show_clause(J). +; | ?- nr_lgg(1,2,J),show_clause(J). +; | ?- lgg(3,4,J),show_clause(J). +; | ?- nr_lgg(3,4,J),show_clause(J). +; | ?- gti(3,4,J),show_clause(J). ; erlaubt backtracking! +; | ?- lgti(3,4,C,_,_). +; | ?- lgg(8,9,J),show_clause(J). +; | ?- rlgg(8,9,J),show_clause(J). +; | ?- rlgg(8,9,cuddly_pet(_),J),show_clause(J). +; | ?- gen_msg(8,9,J),show_clause(J). +; | ?- rlgg(10,11,J),show_clause(J). +; | ?- intra_construct1(14,15,A,B,C),show_clauses([14,15,A,B,C]). +; | ?- intra_construct2(16,17,A,B,C),show_clauses([16,17,A,B,C]). ; ; +; end_of_file. ; +; Try for example ; +; | ?- clear_kb, init_kb('examples/ex5.pl'). +; | ?- argument_types. +; | ?- show_kb. +; | ?- complete_chk. ;; Antwort: no +; | ?- ip(A). ;; gibt alle unabgedeckten Bsple zur"uck +; | ?- clause_heads, eval_examples. +; | ?- show_kb. +; | ?- complete_chk. ;; geht jetzt gut +; | ?- correct_chk. +; | ?- fp(A). ;; gibt inkorrekte Klausel(n) + ihre Instantiierung(en) zur"uck +; ;; in der Form [ID:[Instanz]] +; | ?- refinement(ID,_). ;; wobei ID der der inkorrekten Klausel ist -> gibt +; ;; Spezialisierungen dieser Klausel (in einer Liste) +; | ?- flatten_kb. ;; kb funktionsfrei machen +; | ?- show_kb. ; +; ;; Sei ID1 der der Klausel: +; ;; app(A,B,C) :- cons_p(D,E,A),x_p(D),cons_p(F,G,E),a_p(F),nil_p(G), +; ;; cons_p(H,I,B),b_p(H),cons_p(J,G,I),c_p(J),cons_p(D,K,C),cons_p(F,B,K). +; ;; ID2 der der Klausel: +; ;; app(A,B,C) :- cons_p(D,E,A),a_p(D),nil_p(E), +; ;; cons_p(F,G,B),b_p(F),cons_p(H,E,G),c_p(H),cons_p(D,B,C). ; +; Dann teste: ; +; | ?- absorb(ID1,ID2,J), show_clause(J). +; | ?- elem_saturate(ID1,ID2,J1), show_clause(J1). +; | ?- saturate(ID1,J2,5), show_clause(J2). +; | ?- unflatten_kb. +; | ?- show_kb. ; ; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; - diff --git a/miles/examples/ex6.metta b/miles/examples/ex6.metta index bb99609..57812a0 100644 --- a/miles/examples/ex6.metta +++ b/miles/examples/ex6.metta @@ -1,83 +1,62 @@ +; (convert_to_metta_file ex6 $_413462 miles/examples/ex6.pl miles/examples/ex6.metta) - (= - (has-wings $X) + (= (has-wings $X) (bird $X)) -; - - (= - (has-beak $X) + (= (has-beak $X) (bird $X)) -; - - (= - (bird $X) + (= (bird $X) (vulture $X)) -; - - (= - (carnivore $X) + (= (carnivore $X) (vulture $X)) -; - - - - (= - (ex - (has_wings tweety) +) True) -; - (= - (ex - (has_beak tweety) +) True) -; + (= (ex (has_wings tweety) +) True) + (= (ex (has_beak tweety) +) True) ; ; +; Try for example ; ; +; | ?- clear_kb, do_full_kb('examples/ex6.pl'). ; +; | ?- clear_kb, init_kb('examples/ex6.pl'). +; | ?- argument_types. +; | ?- show_kb. +; | ?- complete_chk. ;; Antwort: no +; | ?- ip(A). ;; gibt alle unabgedeckten Bsple zur"uck +; | ?- clause_heads, eval_examples. +; | ?- show_kb. +; | ?- complete_chk. ;; geht jetzt gut +; | ?- correct_chk. +; | ?- fp(A). ;; gibt inkorrekte Klausel(n) + ihre Instantiierung(en) zur"uck +; ;; in der Form [ID:[Instanz]] +; | ?- refinement(ID,_). ;; wobei ID der der inkorrekten Klausel ist -> gibt +; ;; Spezialisierungen dieser Klausel (in einer Liste) +; | ?- flatten_kb. ;; kb funktionsfrei machen +; | ?- show_kb. ; +; ;; Sei ID1 der der Klausel: +; ;; app(A,B,C) :- cons_p(D,E,A),x_p(D),cons_p(F,G,E),a_p(F),nil_p(G), +; ;; cons_p(H,I,B),b_p(H),cons_p(J,G,I),c_p(J),cons_p(D,K,C),cons_p(F,B,K). +; ;; ID2 der der Klausel: +; ;; app(A,B,C) :- cons_p(D,E,A),a_p(D),nil_p(E), +; ;; cons_p(F,G,B),b_p(F),cons_p(H,E,G),c_p(H),cons_p(D,B,C). ; +; Dann teste: ; +; | ?- absorb(ID1,ID2,J), show_clause(J). +; | ?- elem_saturate(ID1,ID2,J1), show_clause(J1). +; | ?- saturate(ID1,J2,5), show_clause(J2). +; | ?- unflatten_kb. +; | ?- show_kb. ; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; - diff --git a/miles/examples/ex7.metta b/miles/examples/ex7.metta index c9a7291..f5e1f80 100644 --- a/miles/examples/ex7.metta +++ b/miles/examples/ex7.metta @@ -1,353 +1,160 @@ +; (convert_to_metta_file ex7 $_470340 miles/examples/ex7.pl miles/examples/ex7.metta) ; -; - +; ;;Examples for truncation ops - (= + (= (member $X (Cons $Y $R)) + (member $X $R) (member $X - (Cons $Y $R)) - ( (member $X $R) (member $X (:: $X)))) -; + (:: $X))) + (= (member $X (Cons $X $_)) True) - (= - (member $X - (Cons $X $_)) True) -; + (= (app (x a) (b c) (x a b c)) True) + (= (app (a) (b c) (a b c)) True) + (= (app () (b c) (b c)) True) - (= - (app - (x a) - (b c) - (x a b c)) True) -; + (= (ex (app (1 2) (3) (1 2 3)) +) True) + (= (ex (app (x a) (b c) (x a b c)) +) True) + (= (ex (app (a) (b c) (a b c)) +) True) + (= (ex (app () () ()) +) True) + (= (ex (app (p) () (p)) +) True) + (= (ex (app () (u) (u)) +) True) + (= (ex (app () (x y) (x y)) +) True) + (= (ex (app (r s) () (r s)) +) True) + (= (ex (app (g) (d) (g d)) +) True) + (= (ex (app (9 8 7) () (9 8 7)) +) True) + (= (ex (app () (6 5 4) (6 5 4)) +) True) + (= (ex (app (4 3 5) (8) (4 3 5 8)) +) True) + (= (ex (app (r w) (q t s f i) (r w q t s f i)) +) True) + (= (ex (app (j k l m) (n o p q r) (j k l m n o p q r)) +) True) + (= (ex (app (r s t) (q u v) (t s r q u v)) -) True) + (= (ex (app (s t) (q u v) (s r q u v)) -) True) - (= - (app - (a) - (b c) - (a b c)) True) -; - (= - (app () - (b c) - (b c)) True) -; + (= (min $A (Cons $A $B)) + (min $C $B) + (ge $E $F)) + (= (p $X) + (q $X $V1) + (r $V1 $V2) + (q $V3) + (s $V3 $V1)) - (= - (ex - (app - (1 2) - (3) - (1 2 3)) +) True) -; - (= - (ex - (app - (x a) - (b c) - (x a b c)) +) True) -; - - (= - (ex - (app - (a) - (b c) - (a b c)) +) True) -; - - (= - (ex - (app () () ()) +) True) -; - - (= - (ex - (app - (p) () - (p)) +) True) -; - (= - (ex - (app () - (u) - (u)) +) True) -; + (= (column $X) + (brick $X) + (standing $X) + (is-on $X $Y) + (ground $Y)) - (= - (ex - (app () - (x y) - (x y)) +) True) -; + (= (column $X) + (brick $X) + (standing $X) + (is-on $X $Y) + (column $Y)) - (= - (ex - (app - (r s) () - (r s)) +) True) -; - (= - (ex - (app - (g) - (d) - (g d)) +) True) -; + (= (same-height $X $Y) + (ground $X) + (ground $Y)) - (= - (ex - (app - (9 8 7) () - (9 8 7)) +) True) -; + (= (same-height $X $Y) + (brick $X) + (standing $X) + (brick $Y) + (standing $Y) + (is-on $X $X1) + (is-on $Y $Y1) + (same-height $X1 $Y1)) - (= - (ex - (app () - (6 5 4) - (6 5 4)) +) True) -; - (= - (ex - (app - (4 3 5) - (8) - (4 3 5 8)) +) True) -; - (= - (ex - (app - (r w) - (q t s f i) - (r w q t s f i)) +) True) -; + (= (arch $X) + (part-of $A $X) + (part-of $B $X) + (part-of $C $X) + (is-on $A $B) + (is-on $A $C) + (is-on $B $D) + (is-on $C $E) + (ground $D) + (ground $E) + (left-of $B $C) + (does-not-touch $B $C) + (lying $A) + (wedge $A) + (standing $B) + (standing $C) + (brick $B) + (brick $C)) - (= - (ex - (app - (j k l m) - (n o p q r) - (j k l m n o p q r)) +) True) -; - (= - (ex - (app - (r s t) - (q u v) - (t s r q u v)) -) True) -; - (= - (ex - (app - (s t) - (q u v) - (s r q u v)) -) True) -; + (= (ex (p a) +) True) + (= (ex (p b) +) True) + (= (ex (p c) -) True) + (= (q a qa) True) + (= (q b qb) True) + (= (q c qc) True) - (= - (min $A - (Cons $A $B)) - ( (min $C $B) (ge $E $F))) -; + (= (r qa x) True) + (= (r qb x) True) + (= (r qc x) True) + (= (s sa qa) True) + (= (s sb qb) True) + (= (s sc qc) True) - (= - (p $X) - ( (q $X $V1) - (r $V1 $V2) - (q $V3) - (s $V3 $V1))) -; + (= (q sa) True) + (= (q sb) True) - (= - (column $X) - ( (brick $X) - (standing $X) - (is-on $X $Y) - (ground $Y))) ; - - - (= - (column $X) - ( (brick $X) - (standing $X) - (is-on $X $Y) - (column $Y))) ; - - - - (= - (same-height $X $Y) - ( (ground $X) (ground $Y))) +; Try for example ; - - - (= - (same-height $X $Y) - ( (brick $X) - (standing $X) - (brick $Y) - (standing $Y) - (is-on $X $X1) - (is-on $Y $Y1) - (same-height $X1 $Y1))) +; | ?- clear_kb, do_full_kb('examples/ex7.pl'). ; - - - - - (= - (arch $X) - ( (part-of $A $X) - (part-of $B $X) - (part-of $C $X) - (is-on $A $B) - (is-on $A $C) - (is-on $B $D) - (is-on $C $E) - (ground $D) - (ground $E) - (left-of $B $C) - (does-not-touch $B $C) - (lying $A) - (wedge $A) - (standing $B) - (standing $C) - (brick $B) - (brick $C))) +; | ?- clear_kb, init_kb('examples/ex7.pl'). +; | ?- argument_types. +; | ?- show_kb. +; | ?- complete_chk. ;; Antwort: no +; | ?- ip(A). ;; gibt alle unabgedeckten Bsple zur"uck +; | ?- clause_heads, eval_examples. +; | ?- show_kb. +; | ?- complete_chk. ;; geht jetzt gut +; | ?- correct_chk. +; | ?- fp(A). ;; gibt inkorrekte Klausel(n) + ihre Instantiierung(en) zur"uck +; ;; in der Form [ID:[Instanz]] +; | ?- refinement(ID,_). ;; wobei ID der der inkorrekten Klausel ist -> gibt +; ;; Spezialisierungen dieser Klausel (in einer Liste) +; | ?- flatten_kb. ;; kb funktionsfrei machen +; | ?- show_kb. ; - - - - - - (= - (ex - (p a) +) True) +; ;; Sei ID1 der der Klausel: +; ;; app(A,B,C) :- cons_p(D,E,A),x_p(D),cons_p(F,G,E),a_p(F),nil_p(G), +; ;; cons_p(H,I,B),b_p(H),cons_p(J,G,I),c_p(J),cons_p(D,K,C),cons_p(F,B,K). +; ;; ID2 der der Klausel: +; ;; app(A,B,C) :- cons_p(D,E,A),a_p(D),nil_p(E), +; ;; cons_p(F,G,B),b_p(F),cons_p(H,E,G),c_p(H),cons_p(D,B,C). ; - - (= - (ex - (p b) +) True) +; Dann teste: ; - - (= - (ex - (p c) -) True) -; - - - - (= - (q a qa) True) -; - - (= - (q b qb) True) -; - - (= - (q c qc) True) -; - - - (= - (r qa x) True) -; - - (= - (r qb x) True) +; | ?- absorb(ID1,ID2,J), show_clause(J). +; | ?- elem_saturate(ID1,ID2,J1), show_clause(J1). +; | ?- saturate(ID1,J2,5), show_clause(J2). +; | ?- unflatten_kb. +; | ?- show_kb. ; - - (= - (r qc x) True) -; - - - (= - (s sa qa) True) -; - - (= - (s sb qb) True) -; - - (= - (s sc qc) True) -; - - - (= - (q sa) True) -; - - (= - (q sb) True) -; - - - - - -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; - diff --git a/miles/examples/ex8.metta b/miles/examples/ex8.metta index ef0b46c..1b6bded 100644 --- a/miles/examples/ex8.metta +++ b/miles/examples/ex8.metta @@ -1,171 +1,86 @@ +; (convert_to_metta_file ex8 $_61530 miles/examples/ex8.pl miles/examples/ex8.metta) - (= - (ex - (reverse () ()) +) True) -; - - (= - (ex - (reverse - (b) - (b)) +) True) -; - - (= - (ex - (reverse - (d e) - (e d)) +) True) -; - - (= - (ex - (reverse - (e) - (e)) +) True) -; - - - (= - (ex - (reverse - (1) - (1)) +) True) -; - - (= - (ex - (reverse - (1 b) - (b 1)) +) True) -; - - (= - (ex - (reverse - (a b) - (b a)) +) True) -; - - (= - (ex - (reverse - (c d e) - (e d c)) +) True) -; - - (= - (ex - (reverse - (c d) - (d c)) +) True) -; - - (= - (ex - (reverse - (d) - (d)) +) True) -; - - - (= - (ex - (reverse - (1 b) - (1)) -) True) -; - - (= - (ex - (reverse - (a b) - (b 1)) -) True) -; - - (= - (ex - (reverse - (a b) - (a b)) -) True) -; + (= (ex (reverse () ()) +) True) + (= (ex (reverse (b) (b)) +) True) + (= (ex (reverse (d e) (e d)) +) True) + (= (ex (reverse (e) (e)) +) True) - (= - (ex - (reverse - (c d e) - (d c e)) -) True) -; + (= (ex (reverse (1) (1)) +) True) + (= (ex (reverse (1 b) (b 1)) +) True) + (= (ex (reverse (a b) (b a)) +) True) + (= (ex (reverse (c d e) (e d c)) +) True) + (= (ex (reverse (c d) (d c)) +) True) + (= (ex (reverse (d) (d)) +) True) + (= (ex (reverse (1 b) (1)) -) True) + (= (ex (reverse (a b) (b 1)) -) True) + (= (ex (reverse (a b) (a b)) -) True) + (= (ex (reverse (c d e) (d c e)) -) True) ; -; - +; ;reverse([],[]). ; -; - - -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; - +; ;reverse([X|Y],Z):- reverse(Y,Z1). + +; +; +; try: +; +; | ?- clear_kb, do_full_kb('examples/ex8.pl'). +; +; :- init_kb('examples/ex8.pl'). +; ; file "/tmp_mnt/home/stahl/edl/framework/miles/examples/ex8.pl" consulted. +; :- argument_types. +; ; yes +; :- clause_heads. +; ; yes +; :- complete_chk. +; ; yes +; :- correct_chk. +; ; no +; :- fp(Xmout1). +; ; yes +; ; resulting rules selected +; :- refinement_add_body_literal(18,Xmout1). +; ; yes +; :- eval_examples. +; ; yes +; :- complete_chk. +; ; yes +; :- correct_chk. +; ; no +; :- fp(Xmout1). +; ; yes +; ; resulting rules selected +; :- specialize_with_newpred(18,Xmout1). +; ; yes +; :- store_clause(newp5([e,d],[d,c],e,c),_,user,32). +; ; rule added. +; :- store_clause(newp5([d],[c],d,c),_,user,33). +; ; rule added. +; :- flatten_kb. +; ; yes +; :- absorb(32,33,Xmout1). +; ; yes +; ; rule 53 created. +; :- unflatten_kb. +; ; yes +; :- delete_clause(53). +; :- store_clause(newp5([E|A],[B|C],E,D) :- +; newp5(A,C,B,D),_,user,53). +; ; rule changed. +; :- clause_heads. +; ; yes +; :- delete_clause(32). +; :- delete_clause(33). +; :- delete_clause(55). +; :- delete_clause(56). +; :- delete_clause(57). +; ; selected rules deleted. +; :- eval_examples. +; ; yes +; :- complete_chk. +; ; yes +; :- correct_chk. +; ; yes diff --git a/miles/examples/ex9.metta b/miles/examples/ex9.metta index 7a67fcb..d711657 100644 --- a/miles/examples/ex9.metta +++ b/miles/examples/ex9.metta @@ -1,324 +1,146 @@ +; (convert_to_metta_file ex9 $_123086 miles/examples/ex9.pl miles/examples/ex9.metta) - (= - (lt $A $B) + (= (lt $A $B) (< $A $B)) -; - - - (= - (type_restriction - (lt $A $B) - ( (number $A) (number $B))) True) -; - - - - - (= - (ex - (merge () () ()) +) True) -; - - (= - (ex - (merge () - (2) - (2)) +) True) -; - - (= - (ex - (merge () - (3 4) - (3 4)) +) True) -; - - (= - (ex - (merge - (5) () - (5)) +) True) -; - - (= - (ex - (merge - (2 3) () - (2 3)) +) True) -; - - - - - (= - (ex - (merge - (1) - (2) - (1 2)) +) True) -; - - (= - (ex - (merge - (0 1) - (3 4) - (0 1 3 4)) +) True) -; - - (= - (ex - (merge - (1) - (3 4) - (1 3 4)) +) True) -; - - - (= - (ex - (merge - (5) - (4) - (4 5)) +) True) -; - - (= - (ex - (merge - (6 7) - (3 4) - (3 4 6 7)) +) True) -; - - (= - (ex - (merge - (6 7) - (4) - (4 6 7)) +) True) -; - - - - (= - (ex - (merge - (2 3 4 6) - (5 7) - (2 3 4 5 6 7)) +) True) -; - - (= - (ex - (merge - (43 55 63) - (22 33 44 53) - (22 33 43 44 53 55 63)) +) True) -; - - (= - (ex - (merge - (29 39 49 59) - (37 79 99) - (29 37 39 49 59 79 99)) +) True) -; - - (= - (ex - (merge - (2) - (4 7) - (2 4 7)) +) True) -; - - - - (= - (ex - (merge () () - (3)) -) True) -; - - (= - (ex - (merge () - (2) - (1 2)) -) True) -; - - (= - (ex - (merge () - (3 4) - (4 3)) -) True) -; - - (= - (ex - (merge - (5 6) () - (5)) -) True) -; - - (= - (ex - (merge - (2 3) () - (1 2 3)) -) True) -; - - - - - (= - (ex - (merge - (1) - (2) - (2 1)) -) True) -; - - (= - (ex - (merge - (0 1) - (3 4) - (0 1 4)) -) True) -; - - (= - (ex - (merge - (1) - (3 4) - (4 1 1 3)) -) True) -; - - - (= - (ex - (merge - (5) - (1 4) - (4 1 5)) -) True) -; - - (= - (ex - (merge - (6 7) - (3 4) - (3 6 4 7)) -) True) -; - - (= - (ex - (merge - (6 7) - (4) - (6 7 4)) -) True) -; - - -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; + (= (type_restriction (lt $A $B) ((number $A) (number $B))) True) + + + + (= (ex (merge () () ()) +) True) + (= (ex (merge () (2) (2)) +) True) + (= (ex (merge () (3 4) (3 4)) +) True) + (= (ex (merge (5) () (5)) +) True) + (= (ex (merge (2 3) () (2 3)) +) True) + + + + (= (ex (merge (1) (2) (1 2)) +) True) + (= (ex (merge (0 1) (3 4) (0 1 3 4)) +) True) + (= (ex (merge (1) (3 4) (1 3 4)) +) True) + + (= (ex (merge (5) (4) (4 5)) +) True) + (= (ex (merge (6 7) (3 4) (3 4 6 7)) +) True) + (= (ex (merge (6 7) (4) (4 6 7)) +) True) + + + (= (ex (merge (2 3 4 6) (5 7) (2 3 4 5 6 7)) +) True) + (= (ex (merge (43 55 63) (22 33 44 53) (22 33 43 44 53 55 63)) +) True) + (= (ex (merge (29 39 49 59) (37 79 99) (29 37 39 49 59 79 99)) +) True) + (= (ex (merge (2) (4 7) (2 4 7)) +) True) + + + + (= (ex (merge () () (3)) -) True) + (= (ex (merge () (2) (1 2)) -) True) + (= (ex (merge () (3 4) (4 3)) -) True) + (= (ex (merge (5 6) () (5)) -) True) + (= (ex (merge (2 3) () (1 2 3)) -) True) + + + + (= (ex (merge (1) (2) (2 1)) -) True) + (= (ex (merge (0 1) (3 4) (0 1 4)) -) True) + (= (ex (merge (1) (3 4) (4 1 1 3)) -) True) + + (= (ex (merge (5) (1 4) (4 1 5)) -) True) + (= (ex (merge (6 7) (3 4) (3 6 4 7)) -) True) + (= (ex (merge (6 7) (4) (6 7 4)) -) True) + +; +; +; ;| ?- clear_kb, do_full_kb('examples/ex9.pl'). +; +; ;try: +; :- clear_kb, init_kb('examples/ex9.pl'). +; ; file "/tmp_mnt/home/stahl/edl/framework/miles/examples/ex9.pl" consulted. +; :- store_clause(merge([],[2],[2]),_,user,28). +; ; rule added. +; :- store_clause(merge([5],[],[5]),_,user,29). +; ; rule added. +; :- store_clause(merge([1],[2],[1,2]),_,user,30). +; ; rule added. +; :- store_clause(merge([0,1],[3,4],[0,1,3,4]),_,user,31). +; ; rule added. +; :- store_clause(merge([1],[3,4],[1,3,4]),_,user,32). +; ; rule added. +; :- store_clause(merge([5],[4],[4,5]),_,user,33). +; ; rule added. +; :- store_clause(merge([6,7],[3,4],[3,4,6,7]),_,user,34). +; ; rule added. +; :- store_clause(merge([6,7],[4],[4,6,7]),_,user,35). +; ; rule added. +; :- flatten_rules. +; ; yes +; :- saturate(30,Xmout1,5). +; ; yes +; ; rule 36 created. +; :- saturate(31,Xmout1,5). +; ; yes +; ; rule 37 created. +; :- saturate(33,Xmout1,5). +; ; yes +; ; rule 38 created. +; :- saturate(34,Xmout1,5). +; ; yes +; ; rule 39 created. +; :- unflatten_kb. +; ; yes +; :- lgg(36,37,Xmout1). +; ; yes +; ; rule 40 created. +; :- lgg(38,39,Xmout1). +; ; yes +; ; rule 41 created. +; :- delete_clause(36). +; :- delete_clause(37). +; :- delete_clause(38). +; :- delete_clause(39). +; ; selected rules deleted. +; :- delete_clause(28). +; :- delete_clause(29). +; :- delete_clause(30). +; :- delete_clause(31). +; :- delete_clause(32). +; :- delete_clause(33). +; :- delete_clause(34). +; :- delete_clause(35). +; ; selected rules deleted. +; :- argument_types. +; ; yes +; :- clause_heads. +; ; yes +; :- delete_clause(47). +; :- delete_clause(48). +; ; selected rules deleted. +; :- eval_examples. +; ; yes +; :- complete_chk. +; ; yes +; :- correct_chk. +; ; no +; :- fp(Xmout1). +; ; yes +; ; resulting rules selected +; :- refinement_add_body_literal(40,Xmout1). +; ; yes +; :- eval_examples. +; ; yes +; :- complete_chk. +; ; yes +; :- correct_chk. +; ; no +; :- fp(Xmout1). +; ; yes +; ; resulting rules selected +; :- refinement_add_body_literal(41,Xmout1). +; ; yes +; :- eval_examples. +; ; yes +; :- correct_chk. +; ; yes +; :- complete_chk. +; ; yes ; ; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; -; - diff --git a/miles/filter.metta b/miles/filter.metta index 92c6e00..d4e6d8e 100644 --- a/miles/filter.metta +++ b/miles/filter.metta @@ -1,6 +1,6 @@ +; (convert_to_metta_file filter $_456074 miles/filter.pl miles/filter.metta) ; -; - +; MODULE filter EXPORTS !(module filter (:: @@ -28,18 +28,13 @@ (/ noduplicate-symbol 2) (/ select-var-sharing-lits 2) (/ already-in 3))) -; - ; -; - +; IMPORTS !(use-module-if-exists (library not) (:: (/ once 1))) -; - !(use-module-if-exists (library sets) (:: @@ -50,21 +45,15 @@ (/ subtract 3) (/ subset 2) (/ select 3))) -; - !(use-module-if-exists (library strings) (:: (/ string-append 3) (/ substring 4) (/ midstring 6))) -; - !(use-module-if-exists (library basics) (:: (/ member 2))) -; - !(use-module-if-exists (library lists) (:: @@ -72,28 +61,18 @@ (/ rev 2) (/ last 2) (/ nth1 4))) -; - !(use-module-if-exists (library occurs) (:: (/ sub-term 2))) -; - !(use-module-if-exists (library arg) (:: (/ genarg 3))) -; - !(use-module-if-exists (library subsumes) (:: (/ subsumes-chk 2))) -; - !(use-module (home div-utils) (:: (/ shares-var 2))) -; - !(use-module (home var-utils) (:: @@ -103,8 +82,6 @@ (/ deskolemize 3) (/ skolems 2) (/ flagged-contains-vars 3))) -; - !(use-module (home kb) (:: @@ -113,495 +90,338 @@ (/ delete-clause 1) (/ get-fact 4) (/ unflatten-kb 0))) -; - !(use-module (home flatten) (:: (/ flatten-clause 2) (/ unflatten-clause 2))) -; - !(use-module (home evaluation) (:: (/ correct-chk 0))) -; - ; -; - +; METAPREDICATES ; -; - +; none !(dynamic (/ functional-mode 1)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: filter.pl ; -; - +; * ; -; - +; * author: B.Jung, M.Mueller, I.Stahl, B.Tausend date:12/92 ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * description: various filters useful for td- and bu-induction ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - +; *********************************************************************** ; -; - +; * predicate: already_in/3 (optional) ; -; - +; * ; -; - +; * syntax: already_in(+N,+P,+Y) ; -; - +; * ; -; - +; * args: N: arity of a literal P ; -; - +; * P: literal ; -; - +; * Y: term ; -; - +; * ; -; - +; * description: succeeds if Y is(==) already an argument of P ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (already-in 0 $_ $_) - ( (set-det) (fail))) -; +; *********************************************************************** - (= - (already-in $N $P $Y) - ( (arg $N $P $Pn) (det-if-then-else (== $Pn $Y) True (, (is $N1 (- $N 1)) (already-in $N1 $P $Y))))) -; + (= (already-in 0 $_ $_) + (set-det) + (fail)) + (= (already-in $N $P $Y) + (arg $N $P $Pn) + (det-if-then-else + (== $Pn $Y) True + (, + (is $N1 + (- $N 1)) + (already-in $N1 $P $Y)))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: select_var_sharing_lits/2 ; -; - +; * ; -; - +; * syntax: select_var_sharing_lits(+List_of_Clauses,-List_of_Clauses) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: removes all clauses from List_of_Clauses the last ; -; - +; * literal of which does not share a variable with ; -; - +; * the rest of the clause -> to be used during td-refinement ; -; - +; * (not to add unconnected body literals) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (select_var_sharing_lits () ()) True) -; - - (= - (select-var-sharing-lits - (Cons $C $R) $R2) - ( (select-var-sharing-lits $R $R1) (det-if-then-else (var-sharing-lit $C Nil) (= $R2 (Cons $C $R1)) (= $R2 $R1)))) -; - + (= (select_var_sharing_lits () ()) True) + (= (select-var-sharing-lits (Cons $C $R) $R2) + (select-var-sharing-lits $R $R1) + (det-if-then-else + (var-sharing-lit $C Nil) + (= $R2 + (Cons $C $R1)) + (= $R2 $R1))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: var_sharing_lit/2 ; -; - +; * ; -; - +; * syntax: var_sharing_lit(+Clause,+CAccu) ; -; - +; * ; -; - +; * args: CAccu contains all literals of clause except the last one ; -; - +; * ; -; - +; * description: succeeds if the last literal of clause shares (at least) ; -; - +; * a variable with the rest of the clause. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (var-sharing-lit - (= $H $B) Nil) - ( (set-det) (var-sharing-lit $B (:: $H)))) -; - - (= - (var-sharing-lit - (, $A $B) $C) - ( (set-det) (var-sharing-lit $B (Cons $A $C)))) -; +; *********************************************************************** - (= - (var-sharing-lit $A $C) - ( (shares-var $A $C) (set-det))) -; + (= (var-sharing-lit (= $H $B) Nil) + (set-det) + (var-sharing-lit $B + (:: $H))) + (= (var-sharing-lit (, $A $B) $C) + (set-det) + (var-sharing-lit $B + (Cons $A $C))) + (= (var-sharing-lit $A $C) + (shares-var $A $C) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * predicate: noduplicate_atom/2 ; -; - +; * ; -; - +; * syntax: noduplicate_atom(+P,+B) ; -; - +; * ; -; - +; * args: P: literal ; -; - +; * B: clause body ; -; - +; * ; -; - +; * description: tests if P already occurs(==) in B ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (noduplicate-atom $P - (, $A $B)) - ( (set-det) - (\== $P $A) - (noduplicate-atom $P $B))) -; - - (= - (noduplicate-atom $P $A) + (= (noduplicate-atom $P (, $A $B)) + (set-det) + (\== $P $A) + (noduplicate-atom $P $B)) + (= (noduplicate-atom $P $A) (\== $P $A)) -; - ; -; - +; *********************************************************************** ; -; - +; * predicate: noduplicate_atoms/1 ; -; - +; * ; -; - +; * syntax: noduplicate_atoms(+Clause) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: tests whether Clause contains duplicate literals ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (noduplicate-atoms (= $A $B)) - ( (set-det) - (noduplicate-atom $A $B) - (noduplicate-atoms $B))) -; - - (= - (noduplicate-atoms (, $A $B)) - ( (set-det) - (noduplicate-atom $A $B) - (noduplicate-atoms $B))) -; - - (= - (noduplicate_symbols $_) True) -; - + (= (noduplicate-atoms (= $A $B)) + (set-det) + (noduplicate-atom $A $B) + (noduplicate-atoms $B)) + (= (noduplicate-atoms (, $A $B)) + (set-det) + (noduplicate-atom $A $B) + (noduplicate-atoms $B)) + (= (noduplicate_symbols $_) True) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: connected_vars/4 ; -; - +; * ; -; - +; * syntax: connected_vars(+ClauseIn,-ClauseOut,-Connected,-Unconnected) ; -; - +; * ; -; - +; * args: ClauseIn,ClauseOut: clauses in list notation ; -; - +; * Connected,Unconnected: list of variables ; -; - +; * ; -; - +; * description: returns connected & unconnected vars ; -; - +; * A variable is connected ( to the head literal ) iff ; -; - +; * - it appears in the head, or ; -; - +; * - it appears in a literal with a connected variable ; -; - +; * A literal is connected iff it's vars are. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: we make a copy of the input clause ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; (error ; (syntax_error operator_clash) @@ -609,1445 +429,984 @@ - (= - (connected-skolems - (Cons - (with_self $Head - (p)) $Body) $Connected $Unconnected) - ( (skolems $Head $Con) - (= $Uncon Nil) - (find-connected-skolems-in-body $Body $Con $Connected $Uncon $Unconnected_tupels) - (union $Unconnected_tupels $Unconnected))) -; - + (= (connected-skolems (Cons (with_self $Head (p)) $Body) $Connected $Unconnected) + (skolems $Head $Con) + (= $Uncon Nil) + (find-connected-skolems-in-body $Body $Con $Connected $Uncon $Unconnected_tupels) + (union $Unconnected_tupels $Unconnected)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: find_connected_skolems_in_body/5 ; -; - +; * ; -; - +; * syntax: find_connected_skolems_in_body(+Body_list,+Connected,-Connected, ; -; - +; * +Unconnected_tuples,-Unconnected_tuples) ; -; - +; * ; -; - +; * args: Body_list .. clause body in list notation, ; -; - +; * Connected .. connected skolem atoms ; -; - +; * Unconnected_tuples .. lists of lists of unconnected skolem atoms ; -; - +; * ; -; - +; * description: separates connected and unconnected skolem atoms ; -; - +; * (each corresponds to a variable) within the body ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (find-connected-skolems-in-body - (Cons - (with_self $L $_) $Rest) $C1 $C2 $U1 $U2) - ( (skolems $L $V1) - (det-if-then-else - (, - (intersection $C1 $V1 $I) - (\== $I Nil)) - (, - (union $C1 $V1 $C4) - (connect $V1 $C4 $C3 $U1 $U3)) - (, - (= $C3 $C1) - (= $U3 - (Cons $V1 $U1)))) - (find-connected-skolems-in-body $Rest $C3 $C2 $U3 $U2))) -; - - (= - (find_connected_skolems_in_body () $C $C $U $U) True) -; - - - - (= - (connect $V $C $C () ()) True) -; - - (= - (connect $Vars $C1 $C2 - (Cons $Tupel $More) $U2) - ( (member $Var $Vars) - (member $Var $Tupel) - (set-det) - (union $C1 $Tupel $C3) - (connect $Vars $C3 $C2 $More $U2))) -; - - (= - (connect $Vars $C1 $C2 - (Cons $Tupel $More) - (Cons $Tupel $U2)) + (= (find-connected-skolems-in-body (Cons (with_self $L $_) $Rest) $C1 $C2 $U1 $U2) + (skolems $L $V1) + (det-if-then-else + (, + (intersection $C1 $V1 $I) + (\== $I Nil)) + (, + (union $C1 $V1 $C4) + (connect $V1 $C4 $C3 $U1 $U3)) + (, + (= $C3 $C1) + (= $U3 + (Cons $V1 $U1)))) + (find-connected-skolems-in-body $Rest $C3 $C2 $U3 $U2)) + (= (find_connected_skolems_in_body () $C $C $U $U) True) + + + (= (connect $V $C $C () ()) True) + (= (connect $Vars $C1 $C2 (Cons $Tupel $More) $U2) + (member $Var $Vars) + (member $Var $Tupel) + (set-det) + (union $C1 $Tupel $C3) + (connect $Vars $C3 $C2 $More $U2)) + (= (connect $Vars $C1 $C2 (Cons $Tupel $More) (Cons $Tupel $U2)) (connect $Vars $C1 $C2 $More $U2)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: is_weakly_generative/1 ; -; - +; * ; -; - +; * syntax: is_weakly_generative(+Clause) ; -; - +; * ; -; - +; * args: Clause: clause in list notation ; -; - +; * ; -; - +; * description: a clause is weakly generative if all vars of its head ; -; - +; * appear also in another literal ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: Muggleton,90 ; -; - +; * ; -; - +; *********************************************************************** - (= - (is-weakly-generative (Cons (with_self $H (p)) $B)) - ( (vars $H $Vars) (contains-vars $Vars $B))) -; - + (= (is-weakly-generative (Cons (with_self $H (p)) $B)) + (vars $H $Vars) + (contains-vars $Vars $B)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: is_stronly_generative/1 ; -; - +; * ; -; - +; * syntax: is_strongly_generative(+Clause) ; -; - +; * ; -; - +; * args: Clause: clausew in list notation ; -; - +; * ; -; - +; * description: a clause is strongly generative if every variable ; -; - +; * appears in at least 2 literals ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: Muggleton,90 ; -; - +; * ; -; - - +; *********************************************************************** - (= - (is-strongly-generative $Clause) - ( (findall $Flag - (, - (subseq $Clause - (:: $L) $Rest) - (vars $L $Vars) - (flagged-contains-vars $Vars $Rest $Flag)) $Flags) - (not (member False $Flags)) - (set-det))) -; + (= (is-strongly-generative $Clause) + (findall $Flag + (, + (subseq $Clause + (:: $L) $Rest) + (vars $L $Vars) + (flagged-contains-vars $Vars $Rest $Flag)) $Flags) + (not (member False $Flags)) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: is_connected/1 ; -; - +; * ; -; - +; * syntax: is_connected(+Clause) ; -; - +; * ; -; - +; * args: Clause: clause in list notation ; -; - +; * ; -; - +; * description: a clause is connected if every variable is connected ; -; - +; * to the head. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: Rouveirol,91 ; -; - +; * ; -; - +; *********************************************************************** - (= - (is-connected $Clause) + (= (is-connected $Clause) (connected-vars $Clause $_ $_ Nil)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: is_flat/1, is_unflat/1 ; -; - +; * ; -; - +; * syntax: is_flat(+Clause), is_unflat(Clause) ; -; - +; * ; -; - +; * args: clause in list notation [ head:p, b1:n, .. ] ; -; - +; * ; -; - +; * description: succeeds/fails if Clause contains no function symbols ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: if input is not a clause in list form, is_flat/1 ; -; - +; * always succeeds. ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (is-flat $Clause) - ( (nonvar $Clause) (not (is-unflat $Clause)))) -; + (= (is-flat $Clause) + (nonvar $Clause) + (not (is-unflat $Clause))) - (= - (is-unflat (Cons (with_self $L $_) $Rest)) + (= (is-unflat (Cons (with_self $L $_) $Rest)) (is-unflat-literal $L)) -; - - (= - (is-unflat (Cons $_ $Rest)) - (is-unflat $Rest)) -; - - + (= (is-unflat (Cons $_ $Rest)) + (is-unflat $Rest)) - (= - (is-unflat-literal $L) - ( (sub-term $Subterm $L) - (\== $Subterm $L) - (nonvar $Subterm) - (set-det))) -; + (= (is-unflat-literal $L) + (sub-term $Subterm $L) + (\== $Subterm $L) + (nonvar $Subterm) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: truncate/3 ; -; - +; * ; -; - +; * syntax: truncate(+Strategy,+ClauseIn,-ClauseOut) ; -; - +; * ; -; - +; * args: Strategy: one of { r, unconnected, unconnecting, ; -; - +; * strongly_generative} ; -; - +; * ClauseIn,ClauseOut: integers (kb references) ; -; - +; * ; -; - +; * description: performs truncation operator on ClauseIn ; -; - +; * using Strategy. ; -; - +; * ; -; - +; * The list of possible strategies is to be completed. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (truncate $Strategy $In $Out) - ( (get-clause $In $_ $_ $C1 $_) - (do-truncate $Strategy $C1 $C2) - (store-clause $_ $C2 trunc $Out))) -; + (= (truncate $Strategy $In $Out) + (get-clause $In $_ $_ $C1 $_) + (do-truncate $Strategy $C1 $C2) + (store-clause $_ $C2 trunc $Out)) - (= - (do-truncate r $C1 $C2) + (= (do-truncate r $C1 $C2) (truncate-r $C1 $C2)) -; - - (= - (do-truncate unconnected $C1 $C2) + (= (do-truncate unconnected $C1 $C2) (truncate-unconnected $C1 $C2)) -; - - (= - (do-truncate strongly-generative $C1 $C2) + (= (do-truncate strongly-generative $C1 $C2) (truncate-strongly-generative $C1 $C2)) -; - - (= - (do-truncate unconnecting $C1 $C2) - (truncate-unconnecting $C1 $C2)) -; - + (= (do-truncate unconnecting $C1 $C2) + (truncate-unconnecting $C1 $C2)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: truncate_r/2/1 ; -; - +; * ; -; - +; * syntax: truncate_r(ClauseIn,ClauseOut) ; -; - +; * truncate_r(ID) ; -; - +; * ; -; - +; * args: clauses in list notation ; -; - +; * ; -; - +; * description: drop all literals with label ':r', ; -; - +; * i.e. drop all literals that were used in saturation. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (truncate-r $ID) - ( (get-clause $ID $_ $_ $ClauseIn $_) - (truncate-r $ClauseIn $ClauseOut) - (delete-clause $ID) - (store-clause $_ $ClauseOut trc $ID))) -; + (= (truncate-r $ID) + (get-clause $ID $_ $_ $ClauseIn $_) + (truncate-r $ClauseIn $ClauseOut) + (delete-clause $ID) + (store-clause $_ $ClauseOut trc $ID)) + (= (truncate-r $ClauseIn $ClauseOut) + (copy-term $ClauseIn $C) + (do-truncate-r $C $ClauseOut)) - (= - (truncate-r $ClauseIn $ClauseOut) - ( (copy-term $ClauseIn $C) (do-truncate-r $C $ClauseOut))) -; - - - - (= - (do_truncate_r () ()) True) -; - - (= - (do-truncate-r - (Cons - (with_self $L - (r)) $Rest) $Rest1) - ( (set-det) (do-truncate-r $Rest $Rest1))) -; - - (= - (do-truncate-r - (Cons - (with_self $L $S) $Rest) - (Cons - (with_self $L $S) $Rest1)) - ( (set-det) (do-truncate-r $Rest $Rest1))) -; + (= (do_truncate_r () ()) True) + (= (do-truncate-r (Cons (with_self $L (r)) $Rest) $Rest1) + (set-det) + (do-truncate-r $Rest $Rest1)) + (= (do-truncate-r (Cons (with_self $L $S) $Rest) (Cons (with_self $L $S) $Rest1)) + (set-det) + (do-truncate-r $Rest $Rest1)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: truncate_flat_r/2/1 ; -; - +; * ; -; - +; * syntax: truncate_flat_r(ClauseIn,ClauseOut) ; -; - +; * truncate_flat_r(ID) ; -; - +; * ; -; - +; * args: clauses in list notation ; -; - +; * ; -; - +; * description: drop all true literals with label ':r', ; -; - +; * i.e. drop all literals that were used in saturation, ; -; - +; * but no literals with type information ( suffix '_p'). ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (truncate-flat-r $ID) - ( (get-clause $ID $_ $_ $ClauseIn $_) - (truncate-flat-r $ClauseIn $ClauseOut) - (delete-clause $ID) - (store-clause $_ $ClauseOut trc $ID))) -; + (= (truncate-flat-r $ID) + (get-clause $ID $_ $_ $ClauseIn $_) + (truncate-flat-r $ClauseIn $ClauseOut) + (delete-clause $ID) + (store-clause $_ $ClauseOut trc $ID)) + (= (truncate-flat-r $ClauseIn $ClauseOut) + (copy-term $ClauseIn $C) + (do-truncate-flat-r $C $ClauseOut)) - (= - (truncate-flat-r $ClauseIn $ClauseOut) - ( (copy-term $ClauseIn $C) (do-truncate-flat-r $C $ClauseOut))) -; - - - - (= - (do_truncate_flat_r () ()) True) -; - - (= - (do-truncate-flat-r - (Cons - (with_self $L - (r)) $Rest) $Rest1) - ( (functor $L $F $N) - (functor $LC $F $N) - (get-clause $_ $LC $_ $_ usr) - (set-det) - (do-truncate-flat-r $Rest $Rest1))) -; - - (= - (do-truncate-flat-r - (Cons - (with_self $L $S) $Rest) - (Cons - (with_self $L $S) $Rest1)) - ( (set-det) (do-truncate-flat-r $Rest $Rest1))) -; + (= (do_truncate_flat_r () ()) True) + (= (do-truncate-flat-r (Cons (with_self $L (r)) $Rest) $Rest1) + (functor $L $F $N) + (functor $LC $F $N) + (get-clause $_ $LC $_ $_ usr) + (set-det) + (do-truncate-flat-r $Rest $Rest1)) +; ; L is bg predicate + (= (do-truncate-flat-r (Cons (with_self $L $S) $Rest) (Cons (with_self $L $S) $Rest1)) + (set-det) + (do-truncate-flat-r $Rest $Rest1)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: truncate_unconnected/2 ; -; - +; * ; -; - +; * syntax: truncate_unconnected(+ClauseIn, -ClauseOut) ; -; - +; * ; -; - +; * args: ClauseIn,ClauseOut: clauses in list notation ; -; - +; * ; -; - +; * description: truncate unconnected body literals (see above) ; -; - +; * ; -; - +; * example: let ClauseIn = [ min(A,[A|B]):p, min(C,B):n, ge(E,F):n ] ; -; - +; * then ClauseOut = [ min(A,[A|B]):p, min(C,B):n ] ; -; - +; * let ClauseIn = [p(X):n,q(X,V1):n,r(V1,V2):n,q(V3):n,s(V3,V1):n], ; -; - +; * then ClauseOut = [p(X):n,q(X,V1):n,r(V1,V2):n,q(V3):n,s(V3,V1):n] ; -; - +; * (in contrast to truncate_unconnecting) ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (truncate-unconnected $ID) - ( (get-clause $ID $_ $_ $C $_) - (truncate-unconnected $C $D) - (delete-clause $ID) - (store-clause $_ $D trc-unconn $ID) - (set-det))) -; - - - - - (= - (truncate-unconnected $ClauseIn $ClauseOut) - ( (skolemize $ClauseIn $S $ClauseInS) - (connected-skolems $ClauseInS $Con $Uncon) - (= $ClauseInS - (Cons - (with_self $Head - (p)) $Body)) - (truncate-unconnected1 $Body $Uncon $BodyOut) - (= $ClauseOutS - (Cons - (with_self $Head - (p)) $BodyOut)) - (deskolemize $ClauseOutS $S $ClauseOut))) -; +; *********************************************************************** + (= (truncate-unconnected $ID) + (get-clause $ID $_ $_ $C $_) + (truncate-unconnected $C $D) + (delete-clause $ID) + (store-clause $_ $D trc-unconn $ID) + (set-det)) - (= - (truncate_unconnected1 () $_ ()) True) -; - ; -; - (= - (truncate-unconnected1 $B Nil $B) - (set-det)) -; - ; -; - (= - (truncate-unconnected1 + (= (truncate-unconnected $ClauseIn $ClauseOut) + (skolemize $ClauseIn $S $ClauseInS) + (connected-skolems $ClauseInS $Con $Uncon) + (= $ClauseInS (Cons - (with_self $L $_) $More) $Uncon $BodyOut) - ( (det-if-then-else - (, - (skolems $L $SKs) - (member $A $SKs)) - (, - (member $A $Uncon) - (truncate-unconnected1 $More $Uncon $BodyOut)) fail) (set-det))) -; - - (= - (truncate-unconnected1 - (Cons - (with_self $L $S) $More) $Uncon + (with_self $Head + (p)) $Body)) + (truncate-unconnected1 $Body $Uncon $BodyOut) + (= $ClauseOutS (Cons - (with_self $L $S) $BodyOut)) - ( (truncate-unconnected1 $More $Uncon $BodyOut) (set-det))) -; + (with_self $Head + (p)) $BodyOut)) + (deskolemize $ClauseOutS $S $ClauseOut)) + (= (truncate_unconnected1 () $_ ()) True) ; +; no literals to drop + (= (truncate-unconnected1 $B Nil $B) + (set-det)) ; +; all vars connected + (= (truncate-unconnected1 (Cons (with_self $L $_) $More) $Uncon $BodyOut) + (det-if-then-else + (, + (skolems $L $SKs) + (member $A $SKs)) + (, + (member $A $Uncon) + (truncate-unconnected1 $More $Uncon $BodyOut)) fail) + (set-det)) +; ; either all or no vars in L are connected +; ; local cut + (= (truncate-unconnected1 (Cons (with_self $L $S) $More) $Uncon (Cons (with_self $L $S) $BodyOut)) + (truncate-unconnected1 $More $Uncon $BodyOut) + (set-det)) -; -; ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: truncate_unconnecting/1/2 ; -; - +; * ; -; - +; * syntax: truncate_unconnecting(ClauseIn,ClauseOut) ; -; - +; * ; -; - +; * args: clauses in list notation ; -; - +; * ; -; - +; * description: connectivity heuristics for truncation: ; -; - +; * Rouveirol: Drop a body literal if all other literals remain ; -; - +; * connected. ; -; - +; * We added another constraint: the resulting clause must be ; -; - +; * weakly generative. ; -; - +; * Do not confuse the connectivity with the connectedness ; -; - +; * heuristics !! ; -; - +; * ; -; - +; * example: truncate_unconnecting([p(X):n,q(X,V1):n,r(V1,V2):n,q(V3):n,s(V3,V1):n], ; -; - +; * [p(X):n,q(X,V1):n,r(V1,V2):n, s(V3,V1):n], ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: Rouveirol '90; module connectedness.pl ; -; - - - - (= - (truncate-unconnecting $ID) - ( (get-clause $ID $_ $_ $C $_) - (truncate-unconnecting $C $D) - (delete-clause $ID) - (store-clause $_ $D trc-unconn $ID) - (set-det))) -; +; * +; +; *********************************************************************** - (= - (truncate-unconnecting $ClauseIn $ClauseOut) - ( (copy-term $ClauseIn - (Cons - (with_self $H - (p)) $Body)) - (subseq $Body - (:: $L) $BodyOut) - (= $ClauseOut1 - (Cons - (with_self $H - (p)) $BodyOut)) - (connected-vars $ClauseOut1 $ClauseOut $Con Nil) - (is-weakly-generative $ClauseOut))) -; + (= (truncate-unconnecting $ID) + (get-clause $ID $_ $_ $C $_) + (truncate-unconnecting $C $D) + (delete-clause $ID) + (store-clause $_ $D trc-unconn $ID) + (set-det)) + (= (truncate-unconnecting $ClauseIn $ClauseOut) + (copy-term $ClauseIn + (Cons + (with_self $H + (p)) $Body)) + (subseq $Body + (:: $L) $BodyOut) + (= $ClauseOut1 + (Cons + (with_self $H + (p)) $BodyOut)) + (connected-vars $ClauseOut1 $ClauseOut $Con Nil) + (is-weakly-generative $ClauseOut)) +; ; no unconnected vars ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: truncate_strongly_generative/2 ; -; - +; * ; -; - +; * syntax: truncate_strongly_generative(+ClauseIn,-ClauseOut) ; -; - +; * ; -; - +; * args: clauses in list notation ; -; - +; * ; -; - +; * description: drop one body literal from a strongly generative ; -; - +; * clause s.t. the resulting clause is also strongly ; -; - +; * generative. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (truncate-strongly-generative $ID) - ( (get-clause $ID $_ $_ $C $_) - (truncate-strongly-generative $C $D) - (delete-clause $ID) - (store-clause $_ $D trc-unconn $ID) - (set-det))) -; + (= (truncate-strongly-generative $ID) + (get-clause $ID $_ $_ $C $_) + (truncate-strongly-generative $C $D) + (delete-clause $ID) + (store-clause $_ $D trc-unconn $ID) + (set-det)) - (= - (truncate-strongly-generative $ClauseIn $ClauseOut) - ( (copy-term $ClauseIn - (Cons - (with_self $H - (p)) $Body)) - (subseq $Body - (:: $L) $BodyOut) - (= $ClauseOut - (Cons - (with_self $H - (p)) $BodyOut)) - (is-strongly-generative $ClauseOut))) -; - + (= (truncate-strongly-generative $ClauseIn $ClauseOut) + (copy-term $ClauseIn + (Cons + (with_self $H + (p)) $Body)) + (subseq $Body + (:: $L) $BodyOut) + (= $ClauseOut + (Cons + (with_self $H + (p)) $BodyOut)) + (is-strongly-generative $ClauseOut)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: truncate_neg_based/1 ; -; - +; * ; -; - +; * syntax: truncate_neg_based(+ID) ; -; - +; * ; -; - +; * args: integer, kb reference ; -; - +; * ; -; - +; * description: truncate as many literals as possible, s.t. the ; -; - +; * resulting clause covers no negative examples. ; -; - +; * ; -; - +; * This only works on unflat clauses; ; -; - +; * i.e. it only accounts for dropping condition. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also : Muggleton's negative based reduction ; -; - +; * ; -; - - - - (= - (truncate-neg-based $ID) - ( (or - (get-clause $ID $_ $_ $C $Label) - (, - (store-clause $_ $C $Label $ID) - (fail))) - (delete-clause $ID) - (once (truncate-unconnected $C $D)) - (store-clause $_ $D trc $ID) - (correct-chk) - (= $D - (Cons $H $Body)) - (length $Body $N) - (truncate-neg-based1 $N $ID $H $Body))) -; - +; *********************************************************************** - (= - (truncate-neg-based1 0 $_ $_ $_) + (= (truncate-neg-based $ID) + (or + (get-clause $ID $_ $_ $C $Label) + (, + (store-clause $_ $C $Label $ID) + (fail))) + (delete-clause $ID) + (once (truncate-unconnected $C $D)) + (store-clause $_ $D trc $ID) + (correct-chk) + (= $D + (Cons $H $Body)) + (length $Body $N) + (truncate-neg-based1 $N $ID $H $Body)) + + + (= (truncate-neg-based1 0 $_ $_ $_) (set-det)) -; - - - (= - (truncate-neg-based1 $N $ID $H $Body) - ( (nth1 $N $Body $L $NewBody) - (delete-clause $ID) - (store-clause $_ - (Cons $H $NewBody) trc $ID) - (is $M - (- $N 1)) - (det-if-then-else - (, - (is-weakly-generative (Cons $H $NewBody)) - (correct-chk)) - (truncate-neg-based1 $M $ID $H $NewBody) - (, - (delete-clause $ID) - (store-clause $_ - (Cons $H $Body) trc $ID) - (truncate-neg-based1 $M $ID $H $Body))))) -; + (= (truncate-neg-based1 $N $ID $H $Body) + (nth1 $N $Body $L $NewBody) + (delete-clause $ID) + (store-clause $_ + (Cons $H $NewBody) trc $ID) + (is $M + (- $N 1)) + (det-if-then-else + (, + (is-weakly-generative (Cons $H $NewBody)) + (correct-chk)) + (truncate-neg-based1 $M $ID $H $NewBody) + (, + (delete-clause $ID) + (store-clause $_ + (Cons $H $Body) trc $ID) + (truncate-neg-based1 $M $ID $H $Body)))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: truncate_flat_neg_based/1 ; -; - +; * ; -; - +; * syntax: truncate_flat_neg_based(+ID) ; -; - +; * ; -; - +; * args: integer, kb reference ; -; - +; * ; -; - +; * description: truncate as many literals as possible, s.t. the ; -; - +; * resulting clause covers no negative examples. ; -; - +; * ; -; - +; * As initial condition, the kb must be unflat. ; -; - +; * The truncation is done on the flattened clause, so that ; -; - +; * this accounts for the dropping rule & inverse subst. ; -; - +; * On exiting, the kb is unflat. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also : Muggleton's negative based reduction ; -; - +; * ; -; - +; *********************************************************************** - (= - (truncate-flat-neg-based $ID) - ( (get-clause $ID $_ $_ $C $Label) - (flatten-clause $C $D) - (truncate-unconnected $D $E) - (delete-clause $ID) - (store-clause $_ $E $Trc $ID) - (set-det) - (or - (, - (once correct-chk) - (= $D - (Cons $H $Body)) - (truncate-flat-neg-based $ID $H Nil $Body)) - (, - (delete-clause $ID) - (store-clause $_ $C $Label $ID))))) -; - - - (= - (truncate-flat-neg-based $ID $H $Nec Nil) - ( (delete-clause $ID) - (truncate-unconnected - (Cons $H $Nec) $D) - (unflatten-clause $D $E) - (store-clause $_ $E trc $ID) - (set-det) - (correct-chk))) -; - + (= (truncate-flat-neg-based $ID) + (get-clause $ID $_ $_ $C $Label) + (flatten-clause $C $D) + (truncate-unconnected $D $E) + (delete-clause $ID) + (store-clause $_ $E $Trc $ID) + (set-det) + (or + (, + (once correct-chk) + (= $D + (Cons $H $Body)) + (truncate-flat-neg-based $ID $H Nil $Body)) + (, + (delete-clause $ID) + (store-clause $_ $C $Label $ID)))) + (= (truncate-flat-neg-based $ID $H $Nec Nil) + (delete-clause $ID) + (truncate-unconnected + (Cons $H $Nec) $D) + (unflatten-clause $D $E) + (store-clause $_ $E trc $ID) + (set-det) + (correct-chk)) - (= - (truncate-flat-neg-based $ID $H $Nec - (Cons $L $Maybe)) - ( (append $Nec $Maybe $C) - (truncate-unconnected - (Cons $H $C) $D) - (unflatten-clause $D $E) - (delete-clause $ID) - (store-clause $_ $E trc $ID) - (det-if-then-else correct-chk - (= $Nec1 $Nec) - (append $Nec - (:: $L) $Nec1)) - (truncate-flat-neg-based $ID $H $Nec1 $Maybe))) -; + (= (truncate-flat-neg-based $ID $H $Nec (Cons $L $Maybe)) + (append $Nec $Maybe $C) + (truncate-unconnected + (Cons $H $C) $D) + (unflatten-clause $D $E) + (delete-clause $ID) + (store-clause $_ $E trc $ID) + (det-if-then-else correct-chk + (= $Nec1 $Nec) + (append $Nec + (:: $L) $Nec1)) + (truncate-flat-neg-based $ID $H $Nec1 $Maybe)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: truncate_facts/1 ; -; - +; * ; -; - +; * syntax: truncate_facts(+ID) ; -; - +; * ; -; - +; * args: integer, kb reference ; -; - +; * ; -; - +; * description: truncate all body literals unifying with a kb fact ; -; - +; * labeled 'usr'. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** + (= (truncate-facts $ID) + (get-clause $ID $_ $_ + (Cons $H $B) $_) + (truncate-facts1 $B $BodyOut) + (delete-clause $ID) + (store-clause $_ + (Cons $H $BodyOut) trc $ID)) - (= - (truncate-facts $ID) - ( (get-clause $ID $_ $_ - (Cons $H $B) $_) - (truncate-facts1 $B $BodyOut) - (delete-clause $ID) - (store-clause $_ - (Cons $H $BodyOut) trc $ID))) -; - - - - (= - (truncate_facts1 () ()) True) -; - - (= - (truncate-facts1 - (Cons - (with_self $L $S) $Rest) $BodyOut) - ( (truncate-facts1 $Rest $Rest1) (det-if-then-else (, (get-fact $_ $L1 $_ usr) (subsumes-chk $L1 $L)) (= $BodyOut $Rest1) (= $BodyOut (Cons (with_self $L $S) $Rest1))))) -; + (= (truncate_facts1 () ()) True) + (= (truncate-facts1 (Cons (with_self $L $S) $Rest) $BodyOut) + (truncate-facts1 $Rest $Rest1) + (det-if-then-else + (, + (get-fact $_ $L1 $_ usr) + (subsumes-chk $L1 $L)) + (= $BodyOut $Rest1) + (= $BodyOut + (Cons + (with_self $L $S) $Rest1)))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: truncate_j/2 ; -; - +; * ; -; - +; * syntax: truncate_j(+ID,J) ; -; - +; * ; -; - +; * args: ID: kb reference ; -; - +; * J : integer = number of allowed new variables per literal ; -; - +; * ; -; - +; * description: truncate all literals containing more than J variables ; -; - +; * not appearing in the head of kb clause ID. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: truncate_j is remotely related to Muggleton's ; -; - +; * ij-determination. We take i = 1. ; -; - +; * More importantly, we cannot tell in our system, if a ; -; - +; * literal is determinate or not, since we have no model. ; -; - +; * ; -; +; *********************************************************************** - - (= - (truncate-j $ID $J) - ( (get-clause $ID $_ $_ $C $_) - (skolemize $C $S - (Cons - (with_self $Head - (p)) $BodyIn)) - (skolems $Head $Vars) - (do-truncate-j $J $Vars $BodyIn $BodyOutS) - (deskolemize - (Cons - (with_self $Head - (p)) $BodyOutS) $S $D) - (truncate-unconnected $D $E) - (delete-clause $ID) - (store-clause $_ $E trc-j $ID))) -; - + (= (truncate-j $ID $J) + (get-clause $ID $_ $_ $C $_) + (skolemize $C $S + (Cons + (with_self $Head + (p)) $BodyIn)) + (skolems $Head $Vars) + (do-truncate-j $J $Vars $BodyIn $BodyOutS) + (deskolemize + (Cons + (with_self $Head + (p)) $BodyOutS) $S $D) + (truncate-unconnected $D $E) + (delete-clause $ID) + (store-clause $_ $E trc-j $ID)) - (= - (do-truncate-j $J $Vars $BodyIn $BodyOut) + (= (do-truncate-j $J $Vars $BodyIn $BodyOut) (findall $L (, (member $L $BodyIn) (once (, (skolems $L $VarsL) (subtract $VarsL $Vars $NewVars) (length $NewVars $J1) (=< $J1 $J)))) $BodyOut)) -; - diff --git a/miles/flatten.metta b/miles/flatten.metta index cf4777b..b8f9f0e 100644 --- a/miles/flatten.metta +++ b/miles/flatten.metta @@ -1,6 +1,6 @@ +; (convert_to_metta_file flatten $_484398 miles/flatten.pl miles/flatten.metta) ; -; - +; MODULE flatten EXPORTS !(module flatten (:: @@ -12,1204 +12,815 @@ (/ unflatten-clause 2) (/ flatten-clause 2) (/ unflatten-clause 3))) -; - ; -; - +; IMPORTS !(use-module (home div-utils) (:: (/ clist-to-prolog 2) (/ list-to-struct 2))) -; - !(use-module-if-exists (library basics) (:: (/ member 2))) -; - !(use-module-if-exists (library strings) (:: (/ concat-symbol 3) (/ midstring 6) (/ substring 5))) -; - !(use-module-if-exists (library occurs) (:: (/ sub-term 2) (/ contains-var 2))) -; - ; -; - +; METAPREDICATES ; -; - +; none ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: flatten.pl ; -; - +; * ; -; - +; * author: B.Jung, M.Mueller, I.Stahl, B.Tausend date:12/92 ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * description: Rouveirol's representation change to function free ; -; - +; * Horn clauses. ; -; - +; * Shared variables are deteced. ; -; - +; * Following the later versions of flattening('90,'91) ; -; - +; * identical terms are only represented once thru a ; -; - +; * new body literal. The older version (1989) introduced ; -; - +; * for each occurence of a term a unique new body literal. ; -; - +; * ( the newer approach might not always be more adequate) ; -; - +; * ; -; - +; * peculiarities: In the process of flattening all literals that are ; -; - +; * introduced for functions end with the suffix "_p". ; -; - +; * In return, when unflattening a clause it is assumed ; -; - +; * that every predicate symbol ending in "_p" stems from ; -; - +; * a function. This assumption is made because the names ; -; - +; * for functions and predicates need to be distinct. ; -; - +; * ; -; - +; * DON'T FLATTEN ANY CLAUSE CONTAINING LITERALS ENDING IN "_p" !!! ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: flatten_term/7 ; -; - +; * ; -; - +; * syntax: flatten_term(+Term, +NewVar , +OldSubstituion, ; -; - +; * -NewSubstitution,+OldBackground, ; -; - +; * -NewBackground, -Literals) ; -; - +; * ; -; - +; * args: Term: term to be replace by NewVar, e.g. [a,b] ; -; - +; * NewVar: new variable ; -; - +; * OldSubstitution: list of substitutions that have already ; -; - +; * been performed while flattening a clause. ; -; - +; * This way shared variables / terms are detected. ; -; - +; * e.g. [], [ X/a , Y/[b] ] ; -; - +; * NewSubstitution: = OldSubstitution + [ NewVar/Term ] ; -; - +; * OldBackground: old list of predicate definitions ; -; - +; * NewBackground: new ... ; -; - +; * motivation: e.g. let term be "red". ; -; - +; * the resulting literal is " red(X) " which is ; -; - +; * true iff X=red. Therefore ; -; - +; * NewBackground = OldBackground + [ red(red) ] ; -; - +; * Literals: list of literals to replace function ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: can't flatten integers ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (flatten-term $Lin $Lout) + (= (flatten-term $Lin $Lout) (flatten-term $Lin $_ Nil $_ Nil $_ $Lout)) -; - ; -; - +; flatten_term(+,-,+,-,+,-,-) ; -; - - (= - (flatten-term $Term $Var $S $S $Bg $Bg Nil) - ( (member - (/ $Var $Term1) $S) - (== $Term $Term1) - (set-det))) -; - - -; -; +; known terms ; change: represent only vars once + (= (flatten-term $Term $Var $S $S $Bg $Bg Nil) + (member + (/ $Var $Term1) $S) + (== $Term $Term1) + (set-det)) +; ; var(Term), ; new !!! ; -; - - (= - (flatten-term $X $X $S $S $Bg $Bg Nil) - ( (var $X) (set-det))) -; - - +; Variables ; -; - - (= - (flatten-term Nil $V $S - (Cons - (/ $V Nil) $S) $Bg - (Cons - (nil-p Nil) $Bg) - (:: (nil-p $V))) +; flatten_term( X, V, S,[(V/X)|S],[]):- var(X),!. + (= (flatten-term $X $X $S $S $Bg $Bg Nil) + (var $X) (set-det)) -; - ; -; - - (= - (flatten-term $A $V $S - (Cons - (/ $V $A) $S) $Bg - (Cons $B $Bg) - (:: $L)) - ( (atom $A) - (set-det) - (concat-atom - (:: $A p) - $Functor) - (=.. $L - (:: $Functor $V)) - (=.. $B - (:: $Functor $A)))) -; - +; empty list + (= (flatten-term Nil $V $S (Cons (/ $V Nil) $S) $Bg (Cons (nil-p Nil) $Bg) (:: (nil-p $V))) + (set-det)) ; -; - - (= - (flatten-term $Int $V $S - (Cons - (/ $V $Int) $S) $Bg - (Cons $B $Bg) - (:: $L)) - ( (integer $Int) - (set-det) - (map-function-to-pred $Int $PredName) - (=.. $L - (:: $PredName $V)) - (=.. $B - (:: $PredName $Int)))) -; - +; other atoms + (= (flatten-term $A $V $S (Cons (/ $V $A) $S) $Bg (Cons $B $Bg) (:: $L)) + (atom $A) + (set-det) + (concat-atom + (:: $A p) - $Functor) + (=.. $L + (:: $Functor $V)) + (=.. $B + (:: $Functor $A))) + +; +; integers + (= (flatten-term $Int $V $S (Cons (/ $V $Int) $S) $Bg (Cons $B $Bg) (:: $L)) + (integer $Int) + (set-det) + (map-function-to-pred $Int $PredName) + (=.. $L + (:: $PredName $V)) + (=.. $B + (:: $PredName $Int))) ; -; - - (= - (flatten-term - (Cons $A $B) $V $S $Snew $Bg +; list + (= (flatten-term (Cons $A $B) $V $S $Snew $Bg (Cons (cons-p $A $B (Cons $A $B)) $Bg2) $Literals) + (set-det) + (flatten-term $A $V1 $S $S1 $Bg $Bg1 $Literals1) + (flatten-term $B $V2 $S1 $Snew1 $Bg1 $Bg2 $Literals2) + (= $Snew (Cons - (cons-p $A $B - (Cons $A $B)) $Bg2) $Literals) - ( (set-det) - (flatten-term $A $V1 $S $S1 $Bg $Bg1 $Literals1) - (flatten-term $B $V2 $S1 $Snew1 $Bg1 $Bg2 $Literals2) - (= $Snew - (Cons - (/ $V - (Cons $A $B)) $Snew1)) - (append $Literals1 $Literals2 $Literals3) - (= $Literals - (Cons - (cons-p $V1 $V2 $V) $Literals3)))) -; - + (/ $V + (Cons $A $B)) $Snew1)) + (append $Literals1 $Literals2 $Literals3) + (= $Literals + (Cons + (cons-p $V1 $V2 $V) $Literals3))) ; -; - - (= - (flatten-term $Function $V $S $Snew $Bg - (Cons $BgPredicate $Bg1) $Literals) - ( (=.. $Function - (Cons $Functor $Args)) - (flatten-args $Args $Vs $S $Snew1 $Bg $Bg1 $Literals1) - (= $Snew - (Cons - (/ $V $Function) $Snew1)) - (append $Vs - (:: $V) $NewArgs) - (concat-atom - (:: $Functor p) - $NewFunctor) - (=.. $Predicate - (Cons $NewFunctor $NewArgs)) - (append $Args - (:: $Function) $BgArgs) - (=.. $BgPredicate - (Cons $NewFunctor $BgArgs)) - (= $Literals - (Cons $Predicate $Literals1)))) -; - - - +; other functions + (= (flatten-term $Function $V $S $Snew $Bg (Cons $BgPredicate $Bg1) $Literals) + (=.. $Function + (Cons $Functor $Args)) + (flatten-args $Args $Vs $S $Snew1 $Bg $Bg1 $Literals1) + (= $Snew + (Cons + (/ $V $Function) $Snew1)) + (append $Vs + (:: $V) $NewArgs) + (concat-atom + (:: $Functor p) - $NewFunctor) + (=.. $Predicate + (Cons $NewFunctor $NewArgs)) + (append $Args + (:: $Function) $BgArgs) + (=.. $BgPredicate + (Cons $NewFunctor $BgArgs)) + (= $Literals + (Cons $Predicate $Literals1))) +; ; build new predicate of arity n+1 - (= - (flatten_args () () $S $S $Bg $Bg ()) True) -; - (= - (flatten-args - (Cons $A $Args) - (Cons $V $Vars) $S $Snew $Bg $Bg1 $Literals) - ( (flatten-term $A $V $S $Snew1 $Bg $Bg2 $L1) - (flatten-args $Args $Vars $Snew1 $Snew $Bg2 $Bg1 $L2) - (append $L1 $L2 $Literals))) -; + (= (flatten_args () () $S $S $Bg $Bg ()) True) + (= (flatten-args (Cons $A $Args) (Cons $V $Vars) $S $Snew $Bg $Bg1 $Literals) + (flatten-term $A $V $S $Snew1 $Bg $Bg2 $L1) + (flatten-args $Args $Vars $Snew1 $Snew $Bg2 $Bg1 $L2) + (append $L1 $L2 $Literals)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: flatten_literal/2 ; -; - +; * ; -; - +; * syntax: flatten_literal(+Lit,-Lit_list) ; -; - +; * ; -; - +; * args: Lit .. Literal, Lit_list .. list of literals ; -; - +; * ; -; - +; * description: returns the list of literals Lit has to be replaced with ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (flatten-literal $In $Out) + (= (flatten-literal $In $Out) (flatten-literal $In Nil $_ Nil $_ $Out)) -; - ; -; - +; flatten_literal(+,+,-,+,-,-) - (= - (flatten-literal True $S $S $Bg $Bg Nil) + (= (flatten-literal True $S $S $Bg $Bg Nil) (set-det)) -; - - - (= - (flatten-literal $Predicate $S $Snew $Bg $Bg1 $Literals) - ( (=.. $Predicate - (Cons $Functor $Args)) - (flatten-args $Args $Vars $S $Snew $Bg $Bg1 $Literals1) - (=.. $NewPredicate - (Cons $Functor $Vars)) - (= $Literals - (Cons $NewPredicate $Literals1)))) -; + (= (flatten-literal $Predicate $S $Snew $Bg $Bg1 $Literals) + (=.. $Predicate + (Cons $Functor $Args)) + (flatten-args $Args $Vars $S $Snew $Bg $Bg1 $Literals1) + (=.. $NewPredicate + (Cons $Functor $Vars)) + (= $Literals + (Cons $NewPredicate $Literals1))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: flatten_literals/2 ; -; - +; * ; -; - +; * syntax: flatten_literals(+Body,+OldSubst,-NewSubst, ; -; - +; * +OldBackground,-NewBackground,-Literals) ; -; - +; * ; -; - +; * args: Body.. clause body ; -; - +; * OldSubst: list of substitutions that have already ; -; - +; * been performed. ; -; - +; * NewSubst: = OldSubst + additional substitutions for Body ; -; - +; * OldBackground: old list of predicate definitions ; -; - +; * NewBackground: new ... ; -; - +; * Literals: list of literals to replace Body ; -; - +; * ; -; - +; * description: flattens clause body ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (flatten-literals - (, $A $B) $S $Snew $Bg $Bg1 $Literals) - ( (set-det) - (flatten-literal $A $S $Snew1 $Bg $Bg2 $Literals1) - (flatten-literals $B $Snew1 $Snew $Bg2 $Bg1 $Literals2) - (append $Literals1 $Literals2 $Literals))) -; + (= (flatten-literals (, $A $B) $S $Snew $Bg $Bg1 $Literals) + (set-det) + (flatten-literal $A $S $Snew1 $Bg $Bg2 $Literals1) + (flatten-literals $B $Snew1 $Snew $Bg2 $Bg1 $Literals2) + (append $Literals1 $Literals2 $Literals)) +; ; cut, to prevent 2nd clause - (= - (flatten-literals $A $S $Snew $Bg $Bg1 $Literals) + (= (flatten-literals $A $S $Snew $Bg $Bg1 $Literals) (flatten-literal $A $S $Snew $Bg $Bg1 $Literals)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: flatten_clause/2 ; -; - +; * ; -; - +; * syntax: flatten_clause(+ClauseIn,-ClauseOut) ; -; - +; * ; -; - +; * args: clauses in MeTTa notation, i.e. ( head :- body ) ; -; - +; * or list notation, i.e. [ head:p , b1:n, b2:n, ... ] ; -; - +; * ; -; - +; * description: flatten a clause ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (flatten-clause $In $Out) - ( (= $In - (Cons - (with_self $_ - (p)) $_)) - (set-det) - (clist-to-prolog $In $F) - (flatten-clause $F $G) - (clist-to-prolog $Out $G) - (set-det))) -; - - - (= - (flatten-clause $In $Out) - ( (flatten-clause $In Nil $_ Nil $_ $Out) (set-det))) -; - + (= (flatten-clause $In $Out) + (= $In + (Cons + (with_self $_ + (p)) $_)) + (set-det) + (clist-to-prolog $In $F) + (flatten-clause $F $G) + (clist-to-prolog $Out $G) + (set-det)) +; ; list notation - (= - (flatten-clause $Clause $S $Snew $Bg $Bg1 $ClauseOut) - ( (=.. $Clause - (:: :- $Head $Body)) - (=.. $Head - (Cons $Functor $Args)) - (flatten-args $Args $Vars $S $Snew1 $Bg $Bg2 $Literals1) - (=.. $NewHead - (Cons $Functor $Vars)) - (flatten-literals $Body $Snew1 $Snew $Bg2 $Bg1 $Literals2) - (append $Literals1 $Literals2 $Literals) - (list-to-struct $Literals $StrucLits) - (=.. $ClauseOut - (:: :- $NewHead $StrucLits)))) -; + (= (flatten-clause $In $Out) + (flatten-clause $In Nil $_ Nil $_ $Out) + (set-det)) + (= (flatten-clause $Clause $S $Snew $Bg $Bg1 $ClauseOut) + (=.. $Clause + (:: :- $Head $Body)) + (=.. $Head + (Cons $Functor $Args)) + (flatten-args $Args $Vars $S $Snew1 $Bg $Bg2 $Literals1) + (=.. $NewHead + (Cons $Functor $Vars)) + (flatten-literals $Body $Snew1 $Snew $Bg2 $Bg1 $Literals2) + (append $Literals1 $Literals2 $Literals) + (list-to-struct $Literals $StrucLits) + (=.. $ClauseOut + (:: :- $NewHead $StrucLits))) +; ; flatten head +; ; flatten body ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicates: substitute_in_literals/4 ; -; - +; * substitute_in_literal/4 ; -; - +; * substitute_args/4 ; -; - +; * syntax: substitute_in_literals(+Var,+Term,+OldLiterals,-NewLiterals) ; -; - +; * substitute_in_literal(+Var,+Term,+OldLiteral,-NewLiteral) ; -; - +; * substitute_args(+Var,+Term,+OldArgs,-NewArgs) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: replaces all occurences of Var in OldLiterals with Term ; -; - +; * and outputs NewLiterals. ; -; - +; * Note that also occurences of Var in subterms of args are ; -; - +; * detected. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - - - (= - (substitute_in_literals $Var $Term () ()) True) -; - - (= - (substitute-in-literals $Var $Term - (Cons $Lit1 $Lits) - (Cons $Lit1new $Litsnew)) - ( (set-det) - (substitute-in-literal $Var $Term $Lit1 $Lit1new) - (substitute-in-literals $Var $Term $Lits $Litsnew))) -; - +; substitute all occurences of Var in LiteralIn by Term + (= (substitute_in_literals $Var $Term () ()) True) + (= (substitute-in-literals $Var $Term (Cons $Lit1 $Lits) (Cons $Lit1new $Litsnew)) + (set-det) + (substitute-in-literal $Var $Term $Lit1 $Lit1new) + (substitute-in-literals $Var $Term $Lits $Litsnew)) - (= - (substitute-in-literal $Var $Term $LiteralIn $LiteralOut) - ( (=.. $LiteralIn - (Cons $Functor $Vars)) - (substitute-args $Var $Term $Vars $Args) - (=.. $LiteralOut - (Cons $Functor $Args)))) -; + (= (substitute-in-literal $Var $Term $LiteralIn $LiteralOut) + (=.. $LiteralIn + (Cons $Functor $Vars)) + (substitute-args $Var $Term $Vars $Args) + (=.. $LiteralOut + (Cons $Functor $Args))) ; -; - - - (= - (substitute-args $Var $Term - (Cons $V $Vs) - (Cons $Term $Args)) - ( (== $Var $V) - (set-det) - (substitute-args $Var $Term $Vs $Args))) -; - - - (= - (substitute-args $Var $Term - (Cons $V $Vs) - (Cons $Arg $Args)) - ( (contains-var $Var $V) - (set-det) - (=.. $V - (Cons $Functor $SubVars)) - (substitute-args $Var $Term $SubVars $SubArgs) - (=.. $Arg - (Cons $Functor $SubArgs)) - (substitute-args $Var $Term $Vs $Args))) -; - +; substitute variables Vars in argument positions by Term if identical to Var - (= - (substitute-args $Var $Term - (Cons $V $Vs) - (Cons $V $Args)) + (= (substitute-args $Var $Term (Cons $V $Vs) (Cons $Term $Args)) + (== $Var $V) + (set-det) (substitute-args $Var $Term $Vs $Args)) -; + (= (substitute-args $Var $Term (Cons $V $Vs) (Cons $Arg $Args)) + (contains-var $Var $V) + (set-det) + (=.. $V + (Cons $Functor $SubVars)) + (substitute-args $Var $Term $SubVars $SubArgs) + (=.. $Arg + (Cons $Functor $SubArgs)) + (substitute-args $Var $Term $Vs $Args)) +; ; Var is subterm of V - (= - (substitute_args $Var $Term () ()) True) -; + (= (substitute-args $Var $Term (Cons $V $Vs) (Cons $V $Args)) + (substitute-args $Var $Term $Vs $Args)) + (= (substitute_args $Var $Term () ()) True) ; -; - +; ******************************************************************************* ; -; - +; * ; -; - +; * predicate: unflatten_clause/2 ; -; - +; * ; -; - +; * syntax: unflatten_clause(+FlatClause,-UnFlatClause) ; -; - +; * ; -; - +; * args: FlatClause : flattened clause (either in list or MeTTa notation) ; -; - +; * UnFlatClause : unflattened clause ; -; - +; * ; -; - +; * description: Algorithm for unflattening: (Rouveirol,91.p131) ; -; - +; * for each flattened predicate f_p(t1,..,tn,X) in the body of clause C ; -; - +; * substitute all occurences of X by the functional term f(t1,..tn) ; -; - +; * & drop f_p(t1,...,tn,X) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (unflatten-clause - (= $Head $Body) - (= $Head1 $Body1)) - ( (list-to-struct $BodyListIn $Body) - (unflatten-clause1 $Head Nil $BodyListIn $Head1 $BodyListOut Nil Nil) - (list-to-struct $BodyListOut $Body1) - (set-det))) -; +; ******************************************************************************* + (= (unflatten-clause (= $Head $Body) (= $Head1 $Body1)) + (list-to-struct $BodyListIn $Body) + (unflatten-clause1 $Head Nil $BodyListIn $Head1 $BodyListOut Nil Nil) + (list-to-struct $BodyListOut $Body1) + (set-det)) - (= - (unflatten-clause $In $Out) - ( (= $In - (Cons - (with_self $_ - (p)) $_)) - (set-det) - (clist-to-prolog $In $F) - (unflatten-clause $F $G) - (clist-to-prolog $Out $G) - (set-det))) -; + (= (unflatten-clause $In $Out) + (= $In + (Cons + (with_self $_ + (p)) $_)) + (set-det) + (clist-to-prolog $In $F) + (unflatten-clause $F $G) + (clist-to-prolog $Out $G) + (set-det)) +; ; list notation ; -; - +; ******************************************************************************* ; -; - +; * ; -; - +; * predicate: unflatten_clause/3 ; -; - +; * ; -; - +; * syntax: unflatten_clause(+FlatClause,?Bg,-UnFlatClause) ; -; - +; * ; -; - +; * args: FlatClause = ( Head:-Body) : flattened clause ; -; - +; * Bg : optional background facts - not used yet ; -; - +; * UnFlatClause : unflattened clause ; -; - +; * ; -; - +; * description: Algorithm for unflattening: (Rouveirol,91.p131) ; -; - +; * for each flattened predicate f_p(t1,..,tn,X) in the body of clause C ; -; - +; * substitute all occurences of X by the functional term f(t1,..tn) ; -; - +; * & drop f_p(t1,...,tn,X) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - (= - (unflatten-clause - (= $Head $Body) $Bg - (= $Head1 $Body1)) - ( (list-to-struct $BodyListIn $Body) - (unflatten-clause1 $Head Nil $BodyListIn $Head1 $BodyListOut Nil $Bg) - (list-to-struct $BodyListOut $Body1))) -; +; ******************************************************************************* + (= (unflatten-clause (= $Head $Body) $Bg (= $Head1 $Body1)) + (list-to-struct $BodyListIn $Body) + (unflatten-clause1 $Head Nil $BodyListIn $Head1 $BodyListOut Nil $Bg) + (list-to-struct $BodyListOut $Body1)) ; -; - +; **************************************************************** ; -; - +; * ; -; - +; * predicate: unflatten_clause1/7 ; -; - +; * ; -; - +; * syntax: unflatten_clause1(+HeadIn,+BodyIn1,+BodyIn2,-HeadOut,-BodyOut1, ; -; - +; * -BodyOut2,?Bg) ; -; - +; * ; -; - +; * args: +HeadIn (function free) head of flattened clause ; -; - +; * +BodyIn1 ; -; - +; * +BodyIn2 difference lists of body literals (flattened) ; -; - +; * -HeadOut head of unflattened clause ; -; - +; * -BodyOut1 ; -; - +; * -BodyOut2 difference lists of body literals (unflattened) ; -; - +; * ?Bg optional background knowledge - not used yet ; -; - +; * ; -; - +; * description: unflattens a clause ; ; -; - +; * some variables are replaced by functions & ; -; - +; * certain literals are dumped ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; **************************************************************** - (= - (unflatten-clause1 $HeadIn $BodyIn1 - (Cons $Literal $Rest) $HeadOut $BodyOut1 $BodyOut2 $Bg) - ( (=.. $Literal - (Cons $PredFunctor $Args)) - (map-function-to-pred $Functor $PredFunctor) - (set-det) - (append $Fargs - (:: $Var) $Args) - (=.. $Function - (Cons $Functor $Fargs)) - (substitute-in-literal $Var $Function $HeadIn $HeadInt) - (substitute-in-literals $Var $Function $BodyIn1 $BodyInt1) - (substitute-in-literals $Var $Function $Rest $BodyInt2) - (unflatten-clause1 $HeadInt $BodyInt1 $BodyInt2 $HeadOut $BodyOut1 $BodyOut2 $Bg))) -; + (= (unflatten-clause1 $HeadIn $BodyIn1 (Cons $Literal $Rest) $HeadOut $BodyOut1 $BodyOut2 $Bg) + (=.. $Literal + (Cons $PredFunctor $Args)) + (map-function-to-pred $Functor $PredFunctor) + (set-det) + (append $Fargs + (:: $Var) $Args) + (=.. $Function + (Cons $Functor $Fargs)) + (substitute-in-literal $Var $Function $HeadIn $HeadInt) + (substitute-in-literals $Var $Function $BodyIn1 $BodyInt1) + (substitute-in-literals $Var $Function $Rest $BodyInt2) + (unflatten-clause1 $HeadInt $BodyInt1 $BodyInt2 $HeadOut $BodyOut1 $BodyOut2 $Bg)) +; ; Literal was introduced by flattening +; ; get first n args (Fargs) +; ; substitute Var by Function in whole clause - (= - (unflatten-clause1 $HeadIn $BodyIn1 - (Cons $Literal $Rest) $HeadOut $BodyOut1 $BodyOut2 $Bg) - ( (set-det) - (append $BodyIn1 - (:: $Literal) $BodyInt1) - (unflatten-clause1 $HeadIn $BodyInt1 $Rest $HeadOut $BodyOut1 $BodyOut2 $Bg))) -; + (= (unflatten-clause1 $HeadIn $BodyIn1 (Cons $Literal $Rest) $HeadOut $BodyOut1 $BodyOut2 $Bg) + (set-det) + (append $BodyIn1 + (:: $Literal) $BodyInt1) + (unflatten-clause1 $HeadIn $BodyInt1 $Rest $HeadOut $BodyOut1 $BodyOut2 $Bg)) - - (= - (unflatten_clause1 $Head $Body () $Head $Body () $Bg) True) -; - + (= (unflatten_clause1 $Head $Body () $Head $Body () $Bg) True) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: map_function_to_pred/2 ; -; - +; * ; -; - +; * syntax: map_function_to_pred(+Function_symbol,-PredName) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: constructs a PredName Function_symbol_p for flattening ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (map-function-to-pred Nil nil-p) + (= (map-function-to-pred Nil nil-p) + (set-det)) ; +; [] -> nil + (= (map-function-to-pred . cons-p) + (set-det)) ; +; lists + (= (map-function-to-pred $Integer $PredName) + (integer $Integer) + (var $PredName) + (number-chars $Integer $String) + (atom-chars $Atom $String) + (concat-atom + (:: integer $Atom p) - $PredName) (set-det)) -; - ; -; - - (= - (map-function-to-pred . cons-p) +; ; integers , e.g. 15 -> integer_15_p +; ; spypoint, + (= (map-function-to-pred $Integer $PredName) + (var $Integer) + (nonvar $PredName) + (midstring $PredName $S integer--p 8 $_ 2) + (name $S $List) + (number-chars $Integer $List) + (integer $Integer) + (set-det)) +; ; integer_15_p -> 15 + (= (map-function-to-pred $FunctionName $PredName) + (atom $FunctionName) + (var $PredName) + (concat-atom + (:: $FunctionName -p) $PredName) + (set-det)) +; ; function symbols + (= (map-function-to-pred $FunctionName $PredName) + (atom $PredName) + (var $FunctionName) + (midstring $PredName -p $FunctionName $_ 2 0) (set-det)) -; - ; -; - - (= - (map-function-to-pred $Integer $PredName) - ( (integer $Integer) - (var $PredName) - (number-chars $Integer $String) - (atom-chars $Atom $String) - (concat-atom - (:: integer $Atom p) - $PredName) - (set-det))) -; - - (= - (map-function-to-pred $Integer $PredName) - ( (var $Integer) - (nonvar $PredName) - (midstring $PredName $S integer--p 8 $_ 2) - (name $S $List) - (number-chars $Integer $List) - (integer $Integer) - (set-det))) -; - - (= - (map-function-to-pred $FunctionName $PredName) - ( (atom $FunctionName) - (var $PredName) - (concat-atom - (:: $FunctionName -p) $PredName) - (set-det))) -; - - (= - (map-function-to-pred $FunctionName $PredName) - ( (atom $PredName) - (var $FunctionName) - (midstring $PredName -p $FunctionName $_ 2 0) - (set-det))) -; - diff --git a/miles/g1_ops.metta b/miles/g1_ops.metta index a1002df..7f92554 100644 --- a/miles/g1_ops.metta +++ b/miles/g1_ops.metta @@ -1,6 +1,6 @@ +; (convert_to_metta_file g1_ops $_286080 miles/g1_ops.pl miles/g1_ops.metta) ; -; - +; MODULE g1_ops EXPORTS !(module g1-ops (:: @@ -16,19 +16,16 @@ (/ g1-op 3) (/ g1-op 4) (/ apply-g1 2))) -; - +; ; saturate with default depth +; ; saturate with given maximum depth ; -; - +; IMPORTS !(use-module (home lgg) (:: (/ headed-lgg 3) (/ headed-lgg 4))) -; - !(use-module (home kb) (:: @@ -36,24 +33,18 @@ (/ store-clause 4) (/ delete-clause 1) (/ get-example 3))) -; - !(use-module (home var-utils) (:: (/ skolemize 3) (/ skolemize 4) (/ deskolemize 3))) -; - !(use-module (home div-utils) (:: (/ neg 2) (/ buildpar2 3) (/ efface 3))) -; - !(use-module (home bu-basics) (:: @@ -73,613 +64,443 @@ (/ assert-absorptions 2) (/ body 3) (/ ident-build-body 1))) -; - !(use-module (home show-utils) (:: (/ show-bodies 0))) -; - !(use-module (home interpreter) (:: (/ prove3 2) (/ prove4 3))) -; - !(use-module-if-exists (library basics) (:: (/ member 2))) -; - ; -; - +; METAPREDICATES ; -; - +; none ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: g1_ops.pl ; -; - +; * ; -; - +; * author: B.Jung, M.Mueller, I.Stahl, B.Tausend date:12/92 ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * ; -; - +; * description: - g1-Operator ; -; - +; * Implementation of Ruediger Wirth's G1-operator for inverse ; -; - +; * resolution corresponding to his 1989 PhD thesis. ; -; - +; * - Absorption ; -; - +; * All clauses induced by absorption are labelled "abs" in kb ; -; - +; * - Rouveirol's saturation, with functions allowed as terms. ; -; - +; * *Saturation: Maximum depth: given as input ; -; - +; * default: 100 inverse resolution steps ; -; - +; * *elementary saturation ; -; - +; * - inverse derivate ; -; - +; * Muggleton's inverse linear derivation, i.e. the ; -; - +; * repeated application of the most specific v ; -; - +; * (most specific absorption &most specific identification) ; -; - +; * Induced clauses are marked invd ; -; - +; * - identification ; -; - +; * clauses induced by identification are labelled "idn" in kb ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - +; ********************************************************************************; ; -; - +; * ; -; - +; * predicate: g1_op/3, g1_op/4 ; -; - +; * ; -; - +; * syntax: g1_op ( +ResolventID, +Parent1ID, -Parent2ID ) ; -; - +; * g1_op ( +ResolventID, +Parent1ID, -Parent2ID, + Label ) ; -; - +; * ; -; - +; * args: ResolventID, Parent1ID, Parent2ID .. clauseIDs ; -; - +; * Label for Parent2ID (default: g11) ; -; - +; * ; -; - +; * description: given a resolvent and one parent clause, the second parent clause ; -; - +; * is constructed ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ******************************************************************************** - (= - (g1-op $Res $Par1 $Par2) + (= (g1-op $Res $Par1 $Par2) (g1-op $Res $Par1 $Par2 g11)) -; - - (= - (g1-op $Res $Par1 $Par2 $Label) - ( (det-if-then-else - (var $Label) - (= $Label g11) True) - (get-clause $Res $_ $_ $Lres $_) - (get-clause $Par1 $_ $_ $Lpar1 $_) - (\== $Res $Par1) - (clear-mngr) - (skolemize $Lres $SS $LresSko) - (assert-clause $LresSko) - (findall - (with_self $Uncovered $Proof) - (prove4 $Lpar1 $Uncovered $Proof) $Proofs) - (g1-process-proofs $Proofs $Reslit) - (g1-build-clause $Reslit $Lpar2Sko) - (deskolemize $Lpar2Sko $SS $Lpar2) - (store-clause $_ $Lpar2 $Label $Par2))) -; - ; -; - + (= (g1-op $Res $Par1 $Par2 $Label) + (det-if-then-else + (var $Label) + (= $Label g11) True) + (get-clause $Res $_ $_ $Lres $_) + (get-clause $Par1 $_ $_ $Lpar1 $_) + (\== $Res $Par1) + (clear-mngr) + (skolemize $Lres $SS $LresSko) + (assert-clause $LresSko) + (findall + (with_self $Uncovered $Proof) + (prove4 $Lpar1 $Uncovered $Proof) $Proofs) + (g1-process-proofs $Proofs $Reslit) + (g1-build-clause $Reslit $Lpar2Sko) + (deskolemize $Lpar2Sko $SS $Lpar2) + (store-clause $_ $Lpar2 $Label $Par2)) +; ; clauses in list representation +; ; not a clause with itself +; ; skolemize resolvent +; ; build parent2 +; ; deskolemize ; +; and store ; -; - +; ********************************************************************************; ; -; - +; * ; -; - +; * predicate: extend_g1/2 ; -; - +; * ; -; - +; * syntax: extend_g1(+Ai_ID,-A_Id) ; -; - +; * ; -; - +; * args: clauseIDs ; -; - +; * ; -; - +; * description: locates suitable V's that are already available in the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ********************************************************************************; - (= - (extend-g1 $Ai_id $A_id) - ( (get-clause $Ai_id $_ $_ $Ai $_) - (length $Ai $Li) - (get-clause $Aj_id $_ $_ $Aj g11) - (\== $Ai_id $Aj_id) - (length $Aj $Li) - (headed-lgg $Ai_id $Aj_id $A_id g1) - (get-clause $A_id $_ $_ $A $_) - (length $A $L) - (det-if-then-else - (>= $L $Li) - (delete-clause $Aj_id) - (, - (delete-clause $A_id) - (fail))))) -; - + (= (extend-g1 $Ai_id $A_id) + (get-clause $Ai_id $_ $_ $Ai $_) + (length $Ai $Li) + (get-clause $Aj_id $_ $_ $Aj g11) + (\== $Ai_id $Aj_id) + (length $Aj $Li) + (headed-lgg $Ai_id $Aj_id $A_id g1) + (get-clause $A_id $_ $_ $A $_) + (length $A $L) + (det-if-then-else + (>= $L $Li) + (delete-clause $Aj_id) + (, + (delete-clause $A_id) + (fail)))) +; ; heuristic ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: apply_g1/2 ; -; - +; * ; -; - +; * syntax: apply_g1( + NewClauseId, - List_of_ResultIds ) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: One might want to use apply_g1/2 if a new clause of background ; -; - +; * knowledge is added to the kb and the G1-operator is to be applied. ; -; - +; * If there already is a suitable "V", it will be extended and the ; -; - +; * lgg of two A's will be built. ; -; - +; * ; -; - +; * A ; -; - +; * Bi / \ Bj ; -; - +; * \ Ai Aj / ; -; - +; * \ / \ / ; -; - +; * Ci Cj ; -; - +; * ; -; - +; * If a clause A can be built as lgg of Ai and Aj (extend_g1/2), ; -; - +; * Ai and Aj will be deleted. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (apply-g1 $Clause $_) - ( (g1-op $_ $Clause $Par2) - (findall $GenPar2 - (extend-g1 $Par2 $GenPar2) $Bag) - (det-if-then-else - (== $Bag Nil) - (addtolist $Par2) - (, - (delete-clause $Par2) - (addtolist $Bag))) - (fail) - (set-det))) -; +; *********************************************************************** - (= - (apply-g1 $Clause $_) - ( (g1-op $Clause $_ $Par2) - (findall $GenPar2 - (extend-g1 $Par2 $GenPar2) $Bag) - (det-if-then-else - (== $Bag Nil) - (addtolist $Par2) - (, - (delete-clause $Par2) - (addtolist $Bag))) - (fail))) -; - (= - (apply-g1 $_ $List) + (= (apply-g1 $Clause $_) + (g1-op $_ $Clause $Par2) + (findall $GenPar2 + (extend-g1 $Par2 $GenPar2) $Bag) + (det-if-then-else + (== $Bag Nil) + (addtolist $Par2) + (, + (delete-clause $Par2) + (addtolist $Bag))) + (fail) + (set-det)) +; ; use new clause as parent1 + (= (apply-g1 $Clause $_) + (g1-op $Clause $_ $Par2) + (findall $GenPar2 + (extend-g1 $Par2 $GenPar2) $Bag) + (det-if-then-else + (== $Bag Nil) + (addtolist $Par2) + (, + (delete-clause $Par2) + (addtolist $Bag))) + (fail)) +; ; use new clause as resolvent + (= (apply-g1 $_ $List) (getlist $List)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: absorb/3 ; -; - +; * ; -; - +; * syntax: absorb(+ExID, ?Parent1ID, -NewID) ; -; - +; * ; -; - +; * args: ExID: ID of example clause ; -; - +; * Parent1ID: id of known parent clause ; -; - +; * NewID: ID of absorption of example clause ; -; - +; * ; -; - +; * description: apply one absorption step on input clause ExID; ; -; - +; * if Parent1ID is given, it is tried to perform the ; -; - +; * absorption step with it as known parent. ; -; - +; * Otherwise absorption will be performed with the first ; -; - +; * applicable background clause. ; -; - +; * It is made sure that no 2 literals of a parent ; -; - +; * clause abs_match the same literal in the resolvent. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: no inverse subsitution yet ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - - - (= - (absorb $ExID $PID $NewID) - ( (nonvar $PID) - (clear-mngr) - (get-clause $ExID $_ $_ $Ex $_) - (skolemize $Ex $S - (Cons - (with_self $SHead - (p)) $SBody)) - (assert-body $SBody) - (set-det) - (abs-match1 $PID success $Proofs) - (abs-process-proofs $Proofs $PHead) - (abs-build-body $Body1) - (append $Body1 - (:: (with_self $PHead (n))) $Body) - (= $NewClauseS - (Cons - (with_self $SHead - (p)) $Body)) - (deskolemize $NewClauseS $S $NewClause) - (store-clause $_ $NewClause abs $NewID))) -; +; parent given + (= (absorb $ExID $PID $NewID) + (nonvar $PID) + (clear-mngr) + (get-clause $ExID $_ $_ $Ex $_) + (skolemize $Ex $S + (Cons + (with_self $SHead + (p)) $SBody)) + (assert-body $SBody) + (set-det) + (abs-match1 $PID success $Proofs) + (abs-process-proofs $Proofs $PHead) + (abs-build-body $Body1) + (append $Body1 + (:: (with_self $PHead (n))) $Body) + (= $NewClauseS + (Cons + (with_self $SHead + (p)) $Body)) + (deskolemize $NewClauseS $S $NewClause) + (store-clause $_ $NewClause abs $NewID)) ; -; - - (= - (absorb $ExID $PID $NewID) - ( (var $PID) - (clear-mngr) - (get-clause $ExID $_ $_ $Ex $_) - (skolemize $Ex $S - (Cons - (with_self $SHead - (p)) $SBody)) - (assert-body $SBody) - (set-det) - (abs-match $ExID success $Proofs) - (abs-process-proofs $Proofs $PHead) - (abs-build-body $Body1) - (append $Body1 - (:: (with_self $PHead (n))) $Body) - (= $NewClauseS - (Cons - (with_self $SHead - (p)) $Body)) - (deskolemize $NewClauseS $S $NewClause) - (store-clause $_ $NewClause abs $NewID))) -; - +; parent not given + (= (absorb $ExID $PID $NewID) + (var $PID) + (clear-mngr) + (get-clause $ExID $_ $_ $Ex $_) + (skolemize $Ex $S + (Cons + (with_self $SHead + (p)) $SBody)) + (assert-body $SBody) + (set-det) + (abs-match $ExID success $Proofs) + (abs-process-proofs $Proofs $PHead) + (abs-build-body $Body1) + (append $Body1 + (:: (with_self $PHead (n))) $Body) + (= $NewClauseS + (Cons + (with_self $SHead + (p)) $Body)) + (deskolemize $NewClauseS $S $NewClause) + (store-clause $_ $NewClause abs $NewID)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: abs_match/3 ; -; - +; * ; -; - +; * syntax: abs_match(+ExID,-Mark,-Proofs) ; -; - +; * ; -; - +; * args: ExID: Id of the resolvent ; -; - +; * Mark in {success,fail} ; -; - +; * Proofs = [CL,...] where CL is a clause in list notation ; -; - +; * ; -; - +; * description: returns all (instantiated) clauses that can be embedded in the ; -; - +; * skolemized example clause (stored in kb with head/3,body/3) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (abs-match $ExID $Mark $Proofs) + (= (abs-match $ExID $Mark $Proofs) (det-if-then-else (findall $Proof (abs-match0 $ExID $Proof) $Proofs) @@ -687,83 +508,56 @@ (, (= $Proofs Nil) (= $Mark fail)))) -; - - (= - (abs-match0 $ExId + (= (abs-match0 $ExId (Cons (with_self $Goal (p)) $Proof)) + (get-clause $I $_ $_ (Cons (with_self $Goal - (p)) $Proof)) - ( (get-clause $I $_ $_ - (Cons - (with_self $Goal - (p)) $Body) usr) - (\== $I $ExId) - (prove3 $Body $Proof))) -; - + (p)) $Body) usr) + (\== $I $ExId) + (prove3 $Body $Proof)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: abs_match1/3 ; -; - +; * ; -; - +; * syntax: abs_match1(+PID,-Mark,-Proofs) ; -; - +; * ; -; - +; * args: PID: ID of a parent clause ; -; - +; * ; -; - +; * description: as abs_match, except for the fixed parent clause that ; -; - +; * is embedded in the resolvent ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (abs-match1 $PID $Mark $Proofs) + (= (abs-match1 $PID $Mark $Proofs) (det-if-then-else (findall $Proof (abs-match1a $PID $Proof) $Proofs) @@ -771,228 +565,163 @@ (, (= $Proofs Nil) (= $Mark fail)))) -; - - (= - (abs-match1a $PID + (= (abs-match1a $PID (Cons (with_self $Goal (p)) $Proof)) + (get-clause $PID $_ $_ (Cons (with_self $Goal - (p)) $Proof)) - ( (get-clause $PID $_ $_ - (Cons - (with_self $Goal - (p)) $Body) $_) (prove3 $Body $Proof))) -; - + (p)) $Body) $_) + (prove3 $Body $Proof)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: identify/3 ; -; - +; * ; -; - +; * syntax: identify(+ExID, ?Parent1ID, -NewID) ; -; - +; * ; -; - +; * args: ExID: ID of example clause ; -; - +; * Parent1ID: id of known parent clause ; -; - +; * NewID: ID of identification of example clause ; -; - +; * ; -; - +; * description: apply one identification step on input clause ExID; ; -; - +; * if Parent1ID is given, it is tried to perform the ; -; - +; * identification step with it as known parent. ; -; - +; * Otherwise identification will be performed with the ; -; - +; * first applicable background clause. ; -; - +; * It is made sure that no 2 literals of a parent ; -; - +; * clause ident_match the same literal in the resolvent. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: no inverse subsitution yet ; -; - +; * no backtraking ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - - - (= - (identify $ExID $PID $NewID) - ( (nonvar $PID) - (clear-mngr) - (get-clause $ExID $_ $_ $Ex $_) - (skolemize $Ex $S $SClause) - (assert-clause $SClause) - (set-det) - (ident-match1 $PID success $Proofs) - (ident-process-proofs $Proofs $PHead) - (ident-build-body $Body1) - (= $NewClauseS - (Cons - (with_self $PHead - (p)) $Body1)) - (deskolemize $NewClauseS $S $NewClause) - (store-clause $_ $NewClause idn $NewID))) -; +; parent given + (= (identify $ExID $PID $NewID) + (nonvar $PID) + (clear-mngr) + (get-clause $ExID $_ $_ $Ex $_) + (skolemize $Ex $S $SClause) + (assert-clause $SClause) + (set-det) + (ident-match1 $PID success $Proofs) + (ident-process-proofs $Proofs $PHead) + (ident-build-body $Body1) + (= $NewClauseS + (Cons + (with_self $PHead + (p)) $Body1)) + (deskolemize $NewClauseS $S $NewClause) + (store-clause $_ $NewClause idn $NewID)) ; -; - - (= - (identify $ExID $PID $NewID) - ( (var $PID) - (get-clause $ExID $_ $_ $Ex $_) - (clear-mngr) - (skolemize $Ex $S $SClause) - (assert-clause $SClause) - (ident-match $ExID success $Proofs) - (ident-process-proofs $Proofs $PHead) - (ident-build-body $Body1) - (= $NewClauseS - (Cons - (with_self $PHead - (p)) $Body1)) - (deskolemize $NewClauseS $S $NewClause) - (store-clause $_ $NewClause idn $NewID))) -; - +; parent not given + (= (identify $ExID $PID $NewID) + (var $PID) + (get-clause $ExID $_ $_ $Ex $_) + (clear-mngr) + (skolemize $Ex $S $SClause) + (assert-clause $SClause) + (ident-match $ExID success $Proofs) + (ident-process-proofs $Proofs $PHead) + (ident-build-body $Body1) + (= $NewClauseS + (Cons + (with_self $PHead + (p)) $Body1)) + (deskolemize $NewClauseS $S $NewClause) + (store-clause $_ $NewClause idn $NewID)) +; ; show_bodies, ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: ident_match/3 ; -; - +; * ; -; - +; * syntax: ident_match(+ExID,-Mark,-Proofs) ; -; - +; * ; -; - +; * args: ExID: ID of the resolvent ; -; - +; * Mark in {success,fail} ; -; - +; * Proofs = [P1,..,Pm], where Pi=[Uncovered:Proof] and ; -; - +; * Uncovered = Lit/M (M in {new_head,new_body}), Proof = [[Lit,N],...] ; -; - +; * (N in {head,body} ; -; - +; * ; -; - +; * description: matches clauses in kb against skolemized resolvent (stored ; -; - +; * in kb with head/3,body/3), Uncovered is the resolution ; -; - +; * literal that might be positive (new_head) or negative ; -; - +; * (new_body) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (ident-match $ExID $Mark $Proofs) + (= (ident-match $ExID $Mark $Proofs) (det-if-then-else (findall $Proof (ident-match0 $ExID $Proof) $Proofs) @@ -1000,79 +729,54 @@ (, (= $Proofs Nil) (= $Mark fail)))) -; - - (= - (ident-match0 $ExId - (:: (with_self $Uncovered $Proof))) - ( (get-clause $I $_ $_ $Clause usr) - (\== $I $ExId) - (prove4 $Clause $Uncovered $Proof))) -; - + (= (ident-match0 $ExId (:: (with_self $Uncovered $Proof))) + (get-clause $I $_ $_ $Clause usr) + (\== $I $ExId) + (prove4 $Clause $Uncovered $Proof)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: ident_match1/3 ; -; - +; * ; -; - +; * syntax: ident_match1(+PID,-Mark,-Proofs) ; -; - +; * ; -; - +; * args: PID ...parentID, Mark,Proofs as for ident_match ; -; - +; * ; -; - +; * description: as ident_match, except for the parent clause to be matched ; -; - +; * against the resolvent is given ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (ident-match1 $PID $Mark $Proofs) + (= (ident-match1 $PID $Mark $Proofs) (det-if-then-else (findall $Proof (ident-match1a $PID $Proof) $Proofs) @@ -1080,758 +784,535 @@ (, (= $Proofs Nil) (= $Mark fail)))) -; - - - (= - (ident-match1a $PID - (:: (with_self $Uncovered $Proof))) - ( (get-clause $PID $_ $_ $Clause $_) (prove4 $Clause $Uncovered $Proof))) -; + (= (ident-match1a $PID (:: (with_self $Uncovered $Proof))) + (get-clause $PID $_ $_ $Clause $_) + (prove4 $Clause $Uncovered $Proof)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicates: inv_derivate/2/3 ; -; - +; * ; -; - +; * syntax: inv_derivate(+ExID,-NewID) ; -; - +; * inv_derivate(+ExID,+PrefHead,-NewID) ; -; - +; * ; -; - +; * args: ExID : id of example ; -; - +; * NewID: id of expanded example ; -; - +; * PrefHead: a MeTTa literal ; -; - +; * ; -; - +; * description: Muggleton's inverse linear derivation ; -; - +; * But: ; -; - +; * while in intermediate stages several head literals ; -; - +; * might appear simultanously, the result will always ; -; - +; * be a Horn clause. As head literal we choose the ; -; - +; * latest one derived in inv_derivate/2. ; -; - +; * inv_derivate/3 takes as additional argument ; -; - +; * a literal, which is interpreted as a preferred ; -; - +; * head. If it is possible, inv_derivate/3 results ; -; - +; * in a Horn clause where the head matches this ; -; - +; * literal. ; -; - +; * The operator is restricted to finding clauses at most ; -; - +; * 100 inverse resolution steps away. ; -; - +; * ; -; - +; * example: inv_derivate(1, member(A,B), ID) ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (inv-derivate $ExID $NewID) - ( (clear-mngr) - (or - (get-clause $ExID $_ $_ $CList $_) - (, - (get-example $ExID $Ex +) - (= $CList - (:: (with_self $Ex (p)))))) - (skolemize $CList $S $CListS) - (assert-clause $CListS) - (inv-derivate1 $ExID 1) - (idev-build-clause $_ $Clause1) - (deskolemize $Clause1 $S $Clause) - (store-clause $_ $Clause invd $NewID) - (set-det))) -; - - - - (= - (inv-derivate $ExID $PrefHead $NewID) - ( (clear-mngr) + (= (inv-derivate $ExID $NewID) + (clear-mngr) + (or (get-clause $ExID $_ $_ $CList $_) - (skolemize $CList $S $CListS) - (assert-clause $CListS) - (inv-derivate1 $ExID 1) - (idev-build-clause $PrefHead $Clause1) - (deskolemize $Clause1 $S $Clause) - (store-clause $_ $Clause invd $NewID) - (set-det))) -; + (, + (get-example $ExID $Ex +) + (= $CList + (:: (with_self $Ex (p)))))) + (skolemize $CList $S $CListS) + (assert-clause $CListS) + (inv-derivate1 $ExID 1) + (idev-build-clause $_ $Clause1) + (deskolemize $Clause1 $S $Clause) + (store-clause $_ $Clause invd $NewID) + (set-det)) + (= (inv-derivate $ExID $PrefHead $NewID) + (clear-mngr) + (get-clause $ExID $_ $_ $CList $_) + (skolemize $CList $S $CListS) + (assert-clause $CListS) + (inv-derivate1 $ExID 1) + (idev-build-clause $PrefHead $Clause1) + (deskolemize $Clause1 $S $Clause) + (store-clause $_ $Clause invd $NewID) + (set-det)) - (= - (inv-derivate1 $ExID $I) - ( (setof - (with_self $U $P) - (^ $ExID - (^ $Clause - (idev-match0 $ExID $Clause $U $P))) $Proofs) - (process-new-literals $Proofs $Flag) - (det-if-then-else - (, - (nonvar $Flag) - (< $I 100)) - (, - (is $J - (+ $I 1)) - (inv-derivate1 $ExID $J)) True))) -; + (= (inv-derivate1 $ExID $I) + (setof + (with_self $U $P) + (^ $ExID + (^ $Clause + (idev-match0 $ExID $Clause $U $P))) $Proofs) + (process-new-literals $Proofs $Flag) + (det-if-then-else + (, + (nonvar $Flag) + (< $I 100)) + (, + (is $J + (+ $I 1)) + (inv-derivate1 $ExID $J)) True)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: idev_match0/4 ; -; - +; * ; -; - +; * syntax: idev_match0(+ExID,-Clause,-Uncovered,-Proof) ; -; - +; * ; -; - +; * args: ExID: ID of the resolvent ; -; - +; * Clause: clause in list notation ; -; - +; * Uncovered: Lit/M, where M in {new_head,new_body} ; -; - +; * Proof: [[Lit,N],...] where N in {head,body} ; -; - +; * ; -; - +; * description: matches clause on skolemized resolvent (stored in kb ; -; - +; * with head/3, body/3), and returns the instantiation ; -; - +; * of clause and the resolution literal (Uncovered) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (idev-match0 $ExID $Clause $Uncovered $Proof) - ( (get-clause $ID $_ $_ $Clause $_) - (\== $ExID $ID) - (prove4 $Clause $Uncovered $Proof))) -; - + (= (idev-match0 $ExID $Clause $Uncovered $Proof) + (get-clause $ID $_ $_ $Clause $_) + (\== $ExID $ID) + (prove4 $Clause $Uncovered $Proof)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: most_spec_v/3 ; -; - +; * ; -; - +; * syntax: most_spec_v(+ExID, ?PID, -NewID) ; -; - +; * ; -; - +; * args: ExID: id of example (resolvent) ; -; - +; * PID: id of known parent ; -; - +; * NewID: id of new clause ; -; - +; * ; -; - +; * description: ; -; - +; * Apply one most-spec-v operation to example with parent PID; ; -; - +; * If PID is not given, take the first applicable clause ; -; - +; * of bg as parent. ; -; - +; * The most specific v comprises the most specific absorption ; -; - +; * and the most specific identification. ; -; - +; * Since we always want Horn clauses as a result, this operator ; -; - +; * does not implement the most specific identification as ; -; - +; * described by Muggleton: Instead of adding a second head ; -; - +; * literal to the old clause, we replace the original head. ; -; - +; * I.e. our most specific identification operator is destructive. ; -; - +; * The most specific absorption remains nondestructive ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarites: ; -; - +; * ; -; - +; * see also: inv_derivate/2 where multiple head literals are ; -; - +; * allowed om intermediate stages. ; -; - +; * ; -; - +; *********************************************************************** - (= - (most-spec-v $ExID $PID $NewID) - ( (or - (get-clause $ExID $_ $_ $CList $_) - (, - (get-example $ExID $Ex +) - (= $CList - (:: (with_self $Ex (p)))))) - (clear-mngr) - (skolemize $CList $S $CListS) - (assert-clause $CListS) - (idev-match1 $ExID $_ $Uncovered $Proof $PID) - (process-new-literals - (:: (with_self $Uncovered $Proof)) $Flag) - (nonvar $Flag) - (idev-build-clause $_ $Clause1) - (deskolemize $Clause1 $S $Clause) - (store-clause $_ $Clause msv $NewID))) -; - + (= (most-spec-v $ExID $PID $NewID) + (or + (get-clause $ExID $_ $_ $CList $_) + (, + (get-example $ExID $Ex +) + (= $CList + (:: (with_self $Ex (p)))))) + (clear-mngr) + (skolemize $CList $S $CListS) + (assert-clause $CListS) + (idev-match1 $ExID $_ $Uncovered $Proof $PID) + (process-new-literals + (:: (with_self $Uncovered $Proof)) $Flag) + (nonvar $Flag) + (idev-build-clause $_ $Clause1) + (deskolemize $Clause1 $S $Clause) + (store-clause $_ $Clause msv $NewID)) +; ; Uncovered \== [], ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: idev_match1/5 ; -; - +; * ; -; - +; * syntax: idev_match1(+ExID,-Clause,-Uncovered,-Proof,-ID) ; -; - +; * ; -; - +; * args: ExID: ID of the resolvent, ID: ID of matched clause ; -; - +; * Clause: clause in list notation ; -; - +; * Uncovered: Lit/M, where M in {new_head,new_body} ; -; - +; * Proof: [[Lit,N],...] where N in {head,body} ; -; - +; * ; -; - +; * description: is like idev_match0/4, but returns id of absorbed clause ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (idev-match1 $ExID $Clause $Uncovered $Proof $ID) - ( (get-clause $ID $_ $_ $Clause $_) - (\== $ExID $ID) - (prove4 $Clause $Uncovered $Proof))) -; - + (= (idev-match1 $ExID $Clause $Uncovered $Proof $ID) + (get-clause $ID $_ $_ $Clause $_) + (\== $ExID $ID) + (prove4 $Clause $Uncovered $Proof)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: saturate/2,saturate/3 ; -; - +; * ; -; - +; * syntax: saturate(+ExID, -NewID), saturate(+ExID,-NewID,+Bound) ; -; - +; * ; -; - +; * args: ExID: ID of example clause ; -; - +; * NewID: ID of saturation of example clause ; -; - +; * ; -; - +; * description: apply elementary saturation w.r.t. background ; -; - +; * clauses. ; -; - +; * It is bounded by at most 100 iterations, if bound is not given ; -; - +; * When checking the preconditions for firing one ; -; - +; * absorption step, ; -; - +; * it is made sure that no 2 literals of a parent ; -; - +; * clause subsume the same literal in the resolvent. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (saturate $ExID $GenID) + (= (saturate $ExID $GenID) (saturate $ExID $GenID 100)) -; - - - (= - (saturate $ExID $GenID $Bound) - ( (saturate1 $ExID $NewClause $Bound) - (store-clause $_ $NewClause sat $GenID) - (set-det))) -; - ; -; + (= (saturate $ExID $GenID $Bound) + (saturate1 $ExID $NewClause $Bound) + (store-clause $_ $NewClause sat $GenID) + (set-det)) +; ; Rouveirol's theorem proving alg. +; ; write(NewClause),nl, ; +; no backtracking ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: saturate1/3 ; -; - +; * ; -; - +; * syntax: saturate1(+ExID,-NewClause,+Bound) ; -; - +; * ; -; - +; * args: ExID .. ID of example clause, NewClause .. MeTTa clause in list notation, ; -; - +; * Bound .. bound for interations ; -; - +; * ; -; - +; * description: saturates example clause w.r.t. background knowledge. ; -; - +; * It is bounded by at most Bound interations. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (saturate1 $ExID $NewClause $Bound) - ( (clear-mngr) - (get-clause $ExID $H $B $T $_) - (skolemize $T $S - (Cons - (with_self $HS - (p)) $U)) - (assert-body $U) - (saturate1a $HS 1 $Bound $S $S1) - (bagof $A - (^ $M - (^ $I - (body $A $I $M))) $NewBody1) - (sat-build-clause $H $NewBody1 $Clause1) - (deskolemize $Clause1 $S1 $NewClause))) -; - + (= (saturate1 $ExID $NewClause $Bound) + (clear-mngr) + (get-clause $ExID $H $B $T $_) + (skolemize $T $S + (Cons + (with_self $HS + (p)) $U)) + (assert-body $U) + (saturate1a $HS 1 $Bound $S $S1) + (bagof $A + (^ $M + (^ $I + (body $A $I $M))) $NewBody1) + (sat-build-clause $H $NewBody1 $Clause1) + (deskolemize $Clause1 $S1 $NewClause)) +; ; Clause in list notation ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: saturate1a/5 ; -; - +; * ; -; - +; * syntax: saturate1a(+HS,+Count,+Bound,+Subst,-Subst) ; -; - +; * ; -; - +; * args: HS: skolemized head of the example clause, ; -; - +; * Count,Bound: integers ; -; - +; * Subst: skolem subtitutions ; -; - +; * ; -; - +; * description: while Count < Bound, all heads following from the saturated ; -; - +; * clause so far (stored as body(Lit,_,_)) are asserted as ; -; - +; * additional body-literals (via body/3) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (saturate1a $HS $I $Bound $S1 $S2) - ( (sat-match $HS success $Proofs) - (set-det) - (skolemize $Proofs $S1 $S3 $Proofs1) - (assert-absorptions $Proofs1 $Flag) - (det-if-then-else - (, - (nonvar $Flag) - (< $I $Bound)) - (, - (is $J - (+ $I 1)) - (saturate1a $HS $J $Bound $S3 $S2)) - (= $S2 $S3)))) -; + (= (saturate1a $HS $I $Bound $S1 $S2) + (sat-match $HS success $Proofs) + (set-det) + (skolemize $Proofs $S1 $S3 $Proofs1) + (assert-absorptions $Proofs1 $Flag) + (det-if-then-else + (, + (nonvar $Flag) + (< $I $Bound)) + (, + (is $J + (+ $I 1)) + (saturate1a $HS $J $Bound $S3 $S2)) + (= $S2 $S3))) - (= - (saturate1a $_ $_ $_ $S $S) + (= (saturate1a $_ $_ $_ $S $S) (set-det)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: sat_match/3 ; -; - +; * ; -; - +; * syntax: sat_match(+HS,-M,-Proofs) ; -; - +; * ; -; - +; * args: HS: skolemized head of the example clause ; -; - +; * Proofs = [CL,...] where each CL is a clause in list notation ; -; - +; * ; -; - +; * description: finds all possible proofs for all possible absorptions ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (sat-match $HS $Mark $Proofs) + (= (sat-match $HS $Mark $Proofs) (det-if-then-else (setof $Proof (^ $HS @@ -1840,229 +1321,164 @@ (, (= $Proofs Nil) (= $Mark fail)))) -; - - (= - (sat-match0 $HS + (= (sat-match0 $HS (Cons (with_self $Goal (p)) $ProofBody)) + (get-clause $I $_ $_ (Cons (with_self $Goal - (p)) $ProofBody)) - ( (get-clause $I $_ $_ - (Cons - (with_self $Goal - (p)) $Body) $_) - (prove3 $Body $ProofBody) - (\== $Goal $HS))) -; + (p)) $Body) $_) + (prove3 $Body $ProofBody) + (\== $Goal $HS)) - -; -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: elem_saturate/3 ; -; - +; * ; -; - +; * syntax: elem_saturate( +ExID, ?PID, -NewID) ; -; - +; * ; -; - +; * args: ExID: id of resolvent ; -; - +; * PID : id of parent in bg ; -; - +; * NewID: id of new parent ; -; - +; * ; -; - +; * description: ; -; - +; * Add head of parent from bg to body of resolvent. ; -; - +; * The Operator is identical to Muggleton's ; -; - +; * most-specific-absorption. ; -; - +; * When checking the preconditions for firing one ; -; - +; * absorption step, ; -; - +; * it is made sure that no 2 literals of a parent ; -; - +; * clause subsume the same literal in the resolvent. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - - +; * ; -; - - - (= - (elem-saturate $ExID $PID $NewID) - ( (nonvar $PID) - (clear-mngr) - (get-clause $ExID $_ $_ - (Cons - (with_self $H - (p)) $B) $_) - (skolemize $B $S $BS) - (assert-body $BS) - (get-clause $PID $_ $_ - (Cons - (with_self $Goal - (p)) $Body) $_) - (prove3 $Body $ProofBody) - (assert-absorptions - (:: (Cons (with_self $Goal (p)) $ProofBody)) $Flag) - (nonvar $Flag) - (findall $L - (body $L $I $M) $NewBody) - (sat-build-clause $H $NewBody $Clause1) - (deskolemize $Clause1 $S $NewClause) - (store-clause $_ $NewClause esat $NewID))) -; - - +; *********************************************************************** ; -; - - (= - (elem-saturate $ExID $PID $NewID) - ( (var $PID) - (clear-mngr) - (get-clause $ExID $_ $_ - (Cons - (with_self $H - (p)) $B) $_) - (skolemize $B $S $BS) - (assert-body $BS) - (sat-match1 $ExID - (Cons - (with_self $Goal - (p)) $ProofBody) $PID) - (assert-absorptions - (:: (Cons (with_self $Goal (p)) $ProofBody)) $Flag) - (nonvar $Flag) - (findall $L - (body $L $I $M) $NewBody) - (sat-build-clause $H $NewBody $Clause1) - (deskolemize $Clause1 $S $NewClause) - (store-clause $_ $NewClause esat $NewID))) -; +; parent given + (= (elem-saturate $ExID $PID $NewID) + (nonvar $PID) + (clear-mngr) + (get-clause $ExID $_ $_ + (Cons + (with_self $H + (p)) $B) $_) + (skolemize $B $S $BS) + (assert-body $BS) + (get-clause $PID $_ $_ + (Cons + (with_self $Goal + (p)) $Body) $_) + (prove3 $Body $ProofBody) + (assert-absorptions + (:: (Cons (with_self $Goal (p)) $ProofBody)) $Flag) + (nonvar $Flag) + (findall $L + (body $L $I $M) $NewBody) + (sat-build-clause $H $NewBody $Clause1) + (deskolemize $Clause1 $S $NewClause) + (store-clause $_ $NewClause esat $NewID)) + + +; +; parent not given + (= (elem-saturate $ExID $PID $NewID) + (var $PID) + (clear-mngr) + (get-clause $ExID $_ $_ + (Cons + (with_self $H + (p)) $B) $_) + (skolemize $B $S $BS) + (assert-body $BS) + (sat-match1 $ExID + (Cons + (with_self $Goal + (p)) $ProofBody) $PID) + (assert-absorptions + (:: (Cons (with_self $Goal (p)) $ProofBody)) $Flag) + (nonvar $Flag) + (findall $L + (body $L $I $M) $NewBody) + (sat-build-clause $H $NewBody $Clause1) + (deskolemize $Clause1 $S $NewClause) + (store-clause $_ $NewClause esat $NewID)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: sat_match1/3 ; -; - +; * ; -; - +; * syntax: sat_match1(+ExID,-Proof,-ID) ; -; - +; * ; -; - +; * args: ExID,ID: clauseIDs, Proofs: clause in list notation ; -; - +; * ; -; - +; * description: is like sat_match0/2, but returns id of absorbed clause ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (sat-match1 $Ex + (= (sat-match1 $Ex (Cons (with_self $Goal (p)) $ProofBody) $I) + (get-clause $I $_ $_ (Cons (with_self $Goal - (p)) $ProofBody) $I) - ( (get-clause $I $_ $_ - (Cons - (with_self $Goal - (p)) $Body) $_) - (\== $I $Ex) - (prove3 $Body $ProofBody))) -; - + (p)) $Body) $_) + (\== $I $Ex) + (prove3 $Body $ProofBody)) diff --git a/miles/g2_ops.metta b/miles/g2_ops.metta index 18583f0..e576a3b 100644 --- a/miles/g2_ops.metta +++ b/miles/g2_ops.metta @@ -1,6 +1,6 @@ +; (convert_to_metta_file g2_ops $_234856 miles/g2_ops.pl miles/g2_ops.metta) ; -; - +; MODULE g2_ops EXPORTS !(module g2-ops (:: @@ -14,12 +14,15 @@ (/ apply-g2 5) (/ apply-g2 3) (/ apply-g2 2))) -; - +; ; ITOU-like +; ; give name of new pred +; ; give name & bound for common generalizations +; ; CIGOL-like +; ; give name of new pred +; ; give name & bound for common generalizations ; -; - +; IMPORTS !(use-module (home lgg) (:: @@ -27,11 +30,8 @@ (/ lgg 5) (/ buildlgg 4) (/ gti 5) - (/ lgti 5))) -; - ; -; - + (/ lgti 5))) ; +; ;;diese f"ur lgti/6 ersetzen (ohne Bound) !(use-module (home kb) (:: @@ -39,8 +39,6 @@ (/ store-clause 4) (/ delete-clause 1) (/ delete-all 1))) -; - !(use-module (home var-utils) (:: @@ -54,956 +52,684 @@ (/ findargs 3) (/ allarg 4) (/ buildrelterms 6))) -; - !(use-module (home div-utils) (:: (/ effaceall 3) (/ genterm-test 2))) -; - !(use-module (home g1-ops) (:: (/ g1-op 4))) -; - !(use-module (home environment) (:: (/ oracle 2) (/ confirm 2) (/ get-ci 2))) -; - !(use-module (home evaluation) (:: (/ complexity 2))) -; - !(use-module-if-exists (library strings) (:: (/ gensym 2))) -; - !(use-module-if-exists (library basics) (:: (/ member 2))) -; - !(use-module-if-exists (library sets) (:: (/ subtract 3))) -; - !(use-module-if-exists (library not) (:: (/ once 1))) -; - ; -; - +; METAPREDICATES ; -; - +; none ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: g2_ops.pl ; -; - +; * ; -; - +; * author: B.Jung, M.Mueller, I.Stahl, B.Tausend date:12/92 ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * description: Intra-Construction, G2 ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: intra_construct1/5/6/7 ; -; - +; * ; -; - +; * syntax: intra_construct1(+C1,+C2,-A,-B1,-B2) ; -; - +; * intra_construct1(+C1,+C2,-A,-B1,-B2,PName) ; -; - +; * intra_construct1(+C1,+C2,-A,-B1,-B2,PName,Bound) ; -; - +; * ; -; - +; * args: C1,C2,A,B1,B2: references to clauses in kb ; -; - +; * PName: atom - name of invented predicate ; -; - +; * Bound: integer ; -; - +; * ; -; - +; * description: intra-construction where C1,C2 are at bottom of W, ; -; - +; * A at the center top, B1,B2 at outside top positions. ; -; - +; * S1(A) in C1, S2(A) in C2; the substitutions ; -; - +; * between Bi & Ci are empty. ; -; - +; * Uses an ITOU-like heursitics for determining relevant ; -; - +; * variables for the new predicate ; -; - +; * Our intra-construction will only work, if the two ; -; - +; * input clauses require the same number of arguments ; -; - +; * for the newly invented predicate. ; -; - +; * This restriction is not part of the original ; -; - +; * definition of intra-construction, but its at least ; -; - +; * a very useful heuristics. If the restriction does not ; -; - +; * fit your needs, change it in relevant_vars/3, ; -; - +; * module "var_utils.pl". ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: backtracking over lgti/6 until the same number ; -; - +; * of arguments is reached. ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (intra-construct1 $IDC1 $IDC2 $IDA $IDB1 $IDB2) - ( (gensym new-pred $NewPred) (intra-construct1 $IDC1 $IDC2 $IDA $IDB1 $IDB2 $NewPred))) -; + (= (intra-construct1 $IDC1 $IDC2 $IDA $IDB1 $IDB2) + (gensym new-pred $NewPred) + (intra-construct1 $IDC1 $IDC2 $IDA $IDB1 $IDB2 $NewPred)) + (= (intra-construct1 $IDC1 $IDC2 $IDA $IDB1 $IDB2 $NewPred) + (intra-construct1 $IDC1 $IDC2 $IDA $IDB1 $IDB2 $NewPred 10)) - (= - (intra-construct1 $IDC1 $IDC2 $IDA $IDB1 $IDB2 $NewPred) - (intra-construct1 $IDC1 $IDC2 $IDA $IDB1 $IDB2 $NewPred 10)) -; - - - (= - (intra-construct1 $IDC1 $IDC2 $IDA $IDB1 $IDB2 $NewPred $Bound) - ( (atom $NewPred) - (get-clause $IDC1 $_ $_ $C1 $_) - (get-clause $IDC2 $_ $_ $C2 $_) - (set-det) - (lgti $C1 $C2 $G $S1 $S2 $Bound) - (once (, (relevant-vars3 $C1 $C2 $G $S1 $S2 $Vars) (=.. $NewLit (Cons $NewPred $Vars)) (append $G (:: (with_self $NewLit (n))) $A) (copy-term (, $C1 $G $S1 $NewLit) (, $C11 $G11 $S11 $NewLit11)) (skolemize (, $C11 $G11 $S11 $NewLit11) $Phi1 (, $C12 $G12 $S12 $NewLit12)) (replace $G12 $S12 $G13 $S12) (replace (:: $NewLit12) $S12 (:: $NewLit13) $S12) (subtract $C12 $G13 $B1BodyS) (= $B1S (Cons (with_self $NewLit13 (p)) $B1BodyS)) (deskolemize $B1S $Phi1 $B1) (copy-term (, $C2 $G $S2 $NewLit) (, $C21 $G21 $S21 $NewLit21)) (skolemize (, $C21 $G21 $S21 $NewLit21) $Phi2 (, $C22 $G22 $S22 $NewLit22)) (replace $G22 $S22 $G23 $S22) (replace (:: $NewLit22) $S22 (:: $NewLit23) $S22) (subtract $C22 $G23 $B2BodyS) (= $B2S (Cons (with_self $NewLit23 (p)) $B2BodyS)) (deskolemize $B2S $Phi2 $B2) (store-clause $_ $A ic $IDA) (store-clause $_ $B1 ic $IDB1) (store-clause $_ $B2 ic $IDB2))))) -; - + (= (intra-construct1 $IDC1 $IDC2 $IDA $IDB1 $IDB2 $NewPred $Bound) + (atom $NewPred) + (get-clause $IDC1 $_ $_ $C1 $_) + (get-clause $IDC2 $_ $_ $C2 $_) + (set-det) + (lgti $C1 $C2 $G $S1 $S2 $Bound) + (once (, (relevant-vars3 $C1 $C2 $G $S1 $S2 $Vars) (=.. $NewLit (Cons $NewPred $Vars)) (append $G (:: (with_self $NewLit (n))) $A) (copy-term (, $C1 $G $S1 $NewLit) (, $C11 $G11 $S11 $NewLit11)) (skolemize (, $C11 $G11 $S11 $NewLit11) $Phi1 (, $C12 $G12 $S12 $NewLit12)) (replace $G12 $S12 $G13 $S12) (replace (:: $NewLit12) $S12 (:: $NewLit13) $S12) (subtract $C12 $G13 $B1BodyS) (= $B1S (Cons (with_self $NewLit13 (p)) $B1BodyS)) (deskolemize $B1S $Phi1 $B1) (copy-term (, $C2 $G $S2 $NewLit) (, $C21 $G21 $S21 $NewLit21)) (skolemize (, $C21 $G21 $S21 $NewLit21) $Phi2 (, $C22 $G22 $S22 $NewLit22)) (replace $G22 $S22 $G23 $S22) (replace (:: $NewLit22) $S22 (:: $NewLit23) $S22) (subtract $C22 $G23 $B2BodyS) (= $B2S (Cons (with_self $NewLit23 (p)) $B2BodyS)) (deskolemize $B2S $Phi2 $B2) (store-clause $_ $A ic $IDA) (store-clause $_ $B1 ic $IDB1) (store-clause $_ $B2 ic $IDB2)))) +; ; G is common generalization +; ;;; ITOU - like +; ; build clause in center top +; ; build clause at top left +; ; +; ; build clause at top right ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: intra_construct2/5/6/7 ; -; - +; * ; -; - +; * syntax: intra_construct2(+C1,+C2,-A,-B1,-B2) ; -; - +; * intra_construct2(+C1,+C2,-A,-B1,-B2,PName) ; -; - +; * intra_construct2(+C1,+C2,-A,-B1,-B2,PName,Bound) ; -; - +; * ; -; - +; * args: C1,C2,A,B1,B2: references to clauses in kb ; -; - +; * PName: atom - name of invented predicate ; -; - +; * Bound: integer ; -; - +; * ; -; - +; * description: intra-construction where C1,C2 are at bottom of W, ; -; - +; * A at the center top, B1,B2 at outside top positions. ; -; - +; * S1(A) in C1, S2(A) in C2; the substitutions ; -; - +; * between Bi & Ci are empty. ; -; - +; * Uses a CIGOL-like heursitics for determining relevant ; -; - +; * variables for the new predicate ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: backtracking over lgti/6 until the same number ; -; - +; * of arguments is reached. ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (intra-construct2 $IDC1 $IDC2 $IDA $IDB1 $IDB2) - ( (gensym new-pred $NewPred) (intra-construct2 $IDC1 $IDC2 $IDA $IDB1 $IDB2 $NewPred))) -; + (= (intra-construct2 $IDC1 $IDC2 $IDA $IDB1 $IDB2) + (gensym new-pred $NewPred) + (intra-construct2 $IDC1 $IDC2 $IDA $IDB1 $IDB2 $NewPred)) + (= (intra-construct2 $IDC1 $IDC2 $IDA $IDB1 $IDB2 $NewPred) + (intra-construct2 $IDC1 $IDC2 $IDA $IDB1 $IDB2 $NewPred 10)) - (= - (intra-construct2 $IDC1 $IDC2 $IDA $IDB1 $IDB2 $NewPred) - (intra-construct2 $IDC1 $IDC2 $IDA $IDB1 $IDB2 $NewPred 10)) -; - - - (= - (intra-construct2 $IDC1 $IDC2 $IDA $IDB1 $IDB2 $NewPred $Bound) - ( (atom $NewPred) - (get-clause $IDC1 $_ $_ $C1 $_) - (get-clause $IDC2 $_ $_ $C2 $_) - (set-det) - (lgti $C1 $C2 $G $S1 $S2 $Bound) - (once (, (relevant-vars2 $C1 $C2 $G $S1 $S2 $Vars) (=.. $NewLit (Cons $NewPred $Vars)) (append $G (:: (with_self $NewLit (n))) $A) (copy-term (, $C1 $G $S1 $NewLit) (, $C11 $G11 $S11 $NewLit11)) (skolemize (, $C11 $G11 $S11 $NewLit11) $Phi1 (, $C12 $G12 $S12 $NewLit12)) (replace $G12 $S12 $G13 $S12) (replace (:: $NewLit12) $S12 (:: $NewLit13) $S12) (subtract $C12 $G13 $B1BodyS) (= $B1S (Cons (with_self $NewLit13 (p)) $B1BodyS)) (deskolemize $B1S $Phi1 $B1) (copy-term (, $C2 $G $S2 $NewLit) (, $C21 $G21 $S21 $NewLit21)) (skolemize (, $C21 $G21 $S21 $NewLit21) $Phi2 (, $C22 $G22 $S22 $NewLit22)) (replace $G22 $S22 $G23 $S22) (replace (:: $NewLit22) $S22 (:: $NewLit23) $S22) (subtract $C22 $G23 $B2BodyS) (= $B2S (Cons (with_self $NewLit23 (p)) $B2BodyS)) (deskolemize $B2S $Phi2 $B2) (store-clause $_ $A ic $IDA) (store-clause $_ $B1 ic $IDB1) (store-clause $_ $B2 ic $IDB2))))) -; - + (= (intra-construct2 $IDC1 $IDC2 $IDA $IDB1 $IDB2 $NewPred $Bound) + (atom $NewPred) + (get-clause $IDC1 $_ $_ $C1 $_) + (get-clause $IDC2 $_ $_ $C2 $_) + (set-det) + (lgti $C1 $C2 $G $S1 $S2 $Bound) + (once (, (relevant-vars2 $C1 $C2 $G $S1 $S2 $Vars) (=.. $NewLit (Cons $NewPred $Vars)) (append $G (:: (with_self $NewLit (n))) $A) (copy-term (, $C1 $G $S1 $NewLit) (, $C11 $G11 $S11 $NewLit11)) (skolemize (, $C11 $G11 $S11 $NewLit11) $Phi1 (, $C12 $G12 $S12 $NewLit12)) (replace $G12 $S12 $G13 $S12) (replace (:: $NewLit12) $S12 (:: $NewLit13) $S12) (subtract $C12 $G13 $B1BodyS) (= $B1S (Cons (with_self $NewLit13 (p)) $B1BodyS)) (deskolemize $B1S $Phi1 $B1) (copy-term (, $C2 $G $S2 $NewLit) (, $C21 $G21 $S21 $NewLit21)) (skolemize (, $C21 $G21 $S21 $NewLit21) $Phi2 (, $C22 $G22 $S22 $NewLit22)) (replace $G22 $S22 $G23 $S22) (replace (:: $NewLit22) $S22 (:: $NewLit23) $S22) (subtract $C22 $G23 $B2BodyS) (= $B2S (Cons (with_self $NewLit23 (p)) $B2BodyS)) (deskolemize $B2S $Phi2 $B2) (store-clause $_ $A ic $IDA) (store-clause $_ $B1 ic $IDB1) (store-clause $_ $B2 ic $IDB2)))) +; ; G is common generalization +; ;;; CIGOL - like +; ; build clause in center top +; ; build clause at top left +; ; +; ; build clause at top right ; -; - +; ******************************************************************************** ; -; - +; * ; -; - +; * predicate: g2_op/5 ; -; - +; * ; -; - +; * syntax: g2_op ( + C1_ID, + C2_ID, - A_ID, - B1_ID, - B2_ID) ; -; - +; * ; -; - +; * args: Ci_ID ... IDs of resolvent clauses C1 and C2 to be generalized ; -; - +; * A_ID ... ID of common parent clause A ; -; - +; * Bi_ID ... IDs of corresponding parent clauses B1 and B2 ; -; - +; * ; -; - +; * description: Implementation of Ruediger Wirth's G2-operator for inverse ; -; - +; * resolution corresponding to his 1989 PhD thesis. ; -; - +; * We generalize the Ci using Plotkin's LGG, then build a new ; -; - +; * predicate as resolution literal, find the argument terms for the ; -; - +; * new predicate (in a heuristic manner) and finally build the Bi ; -; - +; * using our well-known G1-operator. ; -; - +; * The compression achieved is evaluated thru a simple, though quite ; -; - +; * sophisticated complexity heuristic (cf. module 'complexity'). ; -; - +; * If the resulting clauses show some compression, the are passed ; -; - +; * to the oracle for confirmation and the user gets a chance to ; -; - +; * rename the new predicate. ; -; - +; * Clauses which become obsolete during the process will be deleted. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: The procedure 'inv_replace' might yield unsatisfying results, ; -; - +; * due to the possible ambiguity of inverse substitution. ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ******************************************************************************** - (= - (g2-op $C1 $C2 $A $B1 $B2) - ( (get-clause $C1 $_ $_ $C1list $_) - (get-clause $C2 $_ $_ $C2list $_) - (lgg $C1list $C2list $Clgg $S1 $S2) - (not-unary $Clgg) - (buildrelterms $C1list $C2list $Clgg $S1 $S2 $Terms) - (buildreslit $Terms $L) - (buildparentA $Clgg $L $Alist) - (store-clause $_ $Alist g2 $A) + (= (g2-op $C1 $C2 $A $B1 $B2) + (get-clause $C1 $_ $_ $C1list $_) + (get-clause $C2 $_ $_ $C2list $_) + (lgg $C1list $C2list $Clgg $S1 $S2) + (not-unary $Clgg) + (buildrelterms $C1list $C2list $Clgg $S1 $S2 $Terms) + (buildreslit $Terms $L) + (buildparentA $Clgg $L $Alist) + (store-clause $_ $Alist g2 $A) + (det-if-then-else + (, + (g1-op $C1 $A $B1 g2g1) + (g1-op $C2 $A $B2 g2g1)) (det-if-then-else + (compression-heuristic + (:: $A $B1 $B2) + (:: $C1 $C2)) (, - (g1-op $C1 $A $B1 g2g1) - (g1-op $C2 $A $B2 g2g1)) - (det-if-then-else - (compression-heuristic - (:: $A $B1 $B2) - (:: $C1 $C2)) - (, - (confirm - (:: $A $B1 $B2) $L) - (delete-all (:: $C1 $C2)) - (nl) - (write 'Resolvent clauses deleted.')) - (, - (nl) - (write 'G2: No compression achieved.') - (nl) - (fail))) - (delete-clause $A)))) -; - + (confirm + (:: $A $B1 $B2) $L) + (delete-all (:: $C1 $C2)) + (nl) + (write 'Resolvent clauses deleted.')) + (, + (nl) + (write 'G2: No compression achieved.') + (nl) + (fail))) + (delete-clause $A))) +; ; Clgg = A\{L} +; ; heuristic proc. +; ; Terms = List of Args for L +; ; L = resolution literal +; ; Alist = parentclause A +; ; Bi = parentclauses ; -; - +; ******************************************************************************** ; -; - +; * ; -; - +; * predicate: apply_g2/3 - tries to apply the G2-operator to a set of clauses Ci. ; -; - +; * The output will be a kb reference of the common parent ; -; - +; * clause A and a list of id's for parent clauses Bi. ; -; - +; * ; -; - +; * Bi A Bj ; -; - +; * \ / \ / ; -; - +; * \ / \ / ; -; - +; * Ci Cj ; -; - +; * apply_g2/2 - ORACLE is asked to enter the Id's of resolvent clauses ; -; - +; * Ci one by one. This continues until oracle says 'stop'. ; -; - +; * Doubles and answers which are not a number are ignored. ; -; - +; * Finally apply_g2/3 is called. ; -; - +; * apply_g2/5 - simply calls g2_op/5 ; -; - +; * ; -; - +; * syntax: apply_g2( + CC, - A, -BB), apply_g2( - A, -BB), ; -; - +; * apply_g2 ( + C1_ID, + C2_ID, - A_ID, - B1_ID, - B2_ID) ; -; - +; * ; -; - +; * args: CC ... Id-list of resolvent clauses Ci to be generalized ; -; - +; * A ... Id of common parent clause A ; -; - +; * BB ... Id-list of corresponding parent clauses Bi ; -; - +; * C_ID, A_ID, B_ID .. as for g2_op/5 ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (apply-g2 $C1 $C2 $A $B1 $B2) - ( (g2-op $C1 $C2 $A $B1 $B2) (set-det))) -; +; ********************************************************************************; + (= (apply-g2 $C1 $C2 $A $B1 $B2) + (g2-op $C1 $C2 $A $B1 $B2) + (set-det)) - (= - (apply-g2 $A $BB) - ( (get-ci Nil $CC) - (apply-g2 $CC $A $BB) - (set-det))) -; + (= (apply-g2 $A $BB) + (get-ci Nil $CC) + (apply-g2 $CC $A $BB) + (set-det)) - (= - (apply-g2 $CC $A $BB) - ( (sort $CC $CCsort) - (gensym new-p $N) - (findall $Aij - (, - (member $Ci $CCsort) - (member $Cj $CCsort) - (< $Ci $Cj) - (g2-op-A $Ci $Cj $N $Aij)) $AA) - (= $AA - (Cons $A1 $An)) - (buildlgg $An $A1 $A g2) - (delete-all $AA) - (findall $Bi - (, - (member $Ci $CC) - (g1-op $Ci $A $Bi g2g1)) $BB) - (length $CC $NoC) + (= (apply-g2 $CC $A $BB) + (sort $CC $CCsort) + (gensym new-p $N) + (findall $Aij + (, + (member $Ci $CCsort) + (member $Cj $CCsort) + (< $Ci $Cj) + (g2-op-A $Ci $Cj $N $Aij)) $AA) + (= $AA + (Cons $A1 $An)) + (buildlgg $An $A1 $A g2) + (delete-all $AA) + (findall $Bi + (, + (member $Ci $CC) + (g1-op $Ci $A $Bi g2g1)) $BB) + (length $CC $NoC) + (det-if-then-else + (length $BB $NoC) (det-if-then-else - (length $BB $NoC) - (det-if-then-else - (compression-heuristic - (Cons $A $BB) $CC) - (, - (confirm - (Cons $A $BB) $N) - (delete-all $CC) - (nl) - (write 'Resolvent clauses deleted.')) - (, - (nl) - (write 'G2: No compression achieved.') - (nl) - (fail))) + (compression-heuristic + (Cons $A $BB) $CC) (, - (delete-all $BB) - (delete-clause $A) - (fail))))) -; - + (confirm + (Cons $A $BB) $N) + (delete-all $CC) + (nl) + (write 'Resolvent clauses deleted.')) + (, + (nl) + (write 'G2: No compression achieved.') + (nl) + (fail))) + (, + (delete-all $BB) + (delete-clause $A) + (fail)))) - (= - (g2-op-A $C1 $C2 $Name $A) - ( (get-clause $C1 $_ $_ $C1list $_) - (get-clause $C2 $_ $_ $C2list $_) - (lgg $C1list $C2list $Clgg $S1 $S2) - (buildrelterms $C1list $C2list $Clgg $S1 $S2 $T) - (not-unary $Clgg) - (length $T $N) - (functor $L $Name $N) - (setargs $N $T $L) - (buildparentA $Clgg $L $Alist) - (store-clause $_ $Alist g2 $A))) -; - + (= (g2-op-A $C1 $C2 $Name $A) + (get-clause $C1 $_ $_ $C1list $_) + (get-clause $C2 $_ $_ $C2list $_) + (lgg $C1list $C2list $Clgg $S1 $S2) + (buildrelterms $C1list $C2list $Clgg $S1 $S2 $T) + (not-unary $Clgg) + (length $T $N) + (functor $L $Name $N) + (setargs $N $T $L) + (buildparentA $Clgg $L $Alist) + (store-clause $_ $Alist g2 $A)) +; ; Clgg = A\{L} +; ; T = List of Args for L +; ; heuristic proc. +; ; Name = common for all L's +; ; L = resolution literal +; ; parentclause A ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: not_unary/1 ; -; - +; * ; -; - +; * syntax: not_unary(+CL) ; -; - +; * ; -; - +; * args: CL .. clause in list representation ; -; - +; * ; -; - +; * description: fails, if CL is a unary clause or a unary goal ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (not-unary (:: (with_self $_ (p)))) - ( (nl) - (write 'No compression achievable.') - (set-det) - (fail))) -; +; ************************************************************************ - (= - (not-unary (:: (with_self (True *) (p)) $_)) - ( (nl) - (write 'No compression achievable.') - (set-det) - (fail))) -; - - (= - (not_unary $_) True) -; + (= (not-unary (:: (with_self $_ (p)))) + (nl) + (write 'No compression achievable.') + (set-det) + (fail)) + (= (not-unary (:: (with_self (True *) (p)) $_)) + (nl) + (write 'No compression achievable.') + (set-det) + (fail)) + (= (not_unary $_) True) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: buildreslit/2 ; -; - +; * ; -; - +; * syntax: buildreslit(+TermList,-Lit) ; -; - +; * ; -; - +; * args: TermList is the list of relevant argument terms, Lit is the resolution ; -; - +; * literal (with a new predicate symbol) ; -; - +; * ; -; - +; * description: constructs the resolution literal ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ************************************************************************ - (= - (buildreslit $T $L) - ( (length $T $N) - (gensym new-p $F) - (functor $L $F $N) - (setargs $N $T $L))) -; + (= (buildreslit $T $L) + (length $T $N) + (gensym new-p $F) + (functor $L $F $N) + (setargs $N $T $L)) - - (= - (setargs 0 Nil $_) + (= (setargs 0 Nil $_) (set-det)) -; - - (= - (setargs $N - (Cons $Arg1 $Rest) $L) - ( (arg $N $L $Arg1) - (is $M - (- $N 1)) - (setargs $M $Rest $L))) -; - + (= (setargs $N (Cons $Arg1 $Rest) $L) + (arg $N $L $Arg1) + (is $M + (- $N 1)) + (setargs $M $Rest $L)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: buildparentA/3 ; -; - +; * ; -; - +; * syntax: buildparentA(+A_L,+Lit,-AL) ; -; - +; * ; -; - +; * args: A_L ... A\{Lit} the lgg of C1 and C2 ; -; - +; * Lit ... the new predicate literal ; -; - +; * AL ... A\{Lit} + {Lit} ; -; - +; * ; -; - +; * description: adds the new predicate literal Lit either as head or ; -; - +; * as body literal to A_L ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; ************************************************************************ - - (= - (buildparentA - (Cons - (with_self - (True *) - (p)) $Rest) $L - (Cons - (with_self $L - (p)) $Rest)) + (= (buildparentA (Cons (with_self (True *) (p)) $Rest) $L (Cons (with_self $L (p)) $Rest)) + (set-det)) + (= (buildparentA $List $L $Alist) + (append $List + (:: (with_self $L (n))) $Alist) (set-det)) -; - - (= - (buildparentA $List $L $Alist) - ( (append $List - (:: (with_self $L (n))) $Alist) (set-det))) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: compression_heuristic/2 ; -; - +; * ; -; - +; * syntax: compression_heuristic(+NewIDs,+OldIDs) ; -; - +; * ; -; - +; * args: NewIDs, OldIDs ... clauseIDs ; -; - +; * ; -; - +; * description: succeeds if the size of the clauses NewIDs is smaller ; -; - +; * than that of the clauses OldIDs ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ************************************************************************ - (= - (compression-heuristic $New_cl $Old_cl) - ( (complexity $Old_cl $Cold) - (complexity $New_cl $Cnew) - (det-if-then-else - (< $Cnew $Cold) True - (, - (delete-all $New_cl) - (fail))))) -; - + (= (compression-heuristic $New_cl $Old_cl) + (complexity $Old_cl $Cold) + (complexity $New_cl $Cnew) + (det-if-then-else + (< $Cnew $Cold) True + (, + (delete-all $New_cl) + (fail)))) diff --git a/miles/gencon.metta b/miles/gencon.metta index 97c636e..3774a73 100644 --- a/miles/gencon.metta +++ b/miles/gencon.metta @@ -1,294 +1,239 @@ +; (convert_to_metta_file gencon $_46512 miles/gencon.pl miles/gencon.metta) ; -; - +; MODULE gencon EXPORTS !(module gencon (:: (/ gilppi 12) (/ gilppi 14))) -; - ; -; - +; METAPREDICATES !(meta-predicate (, (gilppi : : : : : : : : : : : :) (gilppi + + : : : : : : : : : : : :))) -; - ; -; - +; IMPORTS !(use-module (home kb) (:: (/ store-clauses 2))) -; - !(use-module (home show-utils) (:: (/ write-list 1) (/ show-kb 0))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: gilppi.pl ; -; - +; * ; -; - +; * author: I.Stahl date:7/93 ; -; - +; * ; -; - +; * description: generic control for induction a la GENCOL ; -; - +; * enhanced with PI capabilties ; -; - +; * Given: B, E+, E- ; -; - +; * Algorithm: ; -; - +; * Partial_Sols := initialize() ; -; - +; * Complete_Sols := {} ; -; - +; * while not(Stop_C(Complete_Sols)) do ; -; - +; * PS := Select(Partial_Sols) ; -; - +; * if Quality_C(PS) ; -; - +; * then Complete_Sols := Complete_Sols U {PS} ; -; - +; * Partial_Sols := Update(Partial_Sols) ; -; - +; * else if active(PS) ; -; - +; * then One_of(->Partial_Sols := Add(Partial_Sols,Spec(PS)) ; -; - +; * ->Partial_Sols := Add(Partial_Sols,Spec(PS))) ; -; - +; * all PS in spec(PS) (gen(PS)) marked active ; -; - +; * else Partial_Sols := Add(Partial_Sols,L_Newp(PS)) ; -; - +; * mark PS as passive ; -; - +; * Partial_Sols := Filter(Partial_Sols) ; -; - +; * Output(Complete_Sols) ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicates: gilppi/12 ; -; - +; * ; -; - +; * syntax: gilppi(+Initialize, +Stop_C, +Quality_C, +Update, +Select, +Add, +Filter, ; -; - +; * +One_of, +Spec, +Gen, +L_newp, +Output) ; -; - +; * ; -; - +; * args: Initialize... name of a 1-place predicate that initializes the list ; -; - +; * of partial solutions ; -; - +; * Stop_C... name of a 1-place predicate that checks whether complete_sols ; -; - +; * contains a satisfactory solution ; -; - +; * Quality_C... name of a 1-place predicate that checks whether the current ; -; - +; * theory PS is satisfactory ; -; - +; * Update... name of a 2-place predicate that updates the list of partial ; -; - +; * solutions after a satisfactory solution has been found ; -; - +; * Select... name of a 4-place predicate that selects a promising partial ; -; - +; * solution from partial_sols ; -; - +; * Add... name of a 3-place predicate that adds the new partial solutions ; -; - +; * to the list partial_sols ; -; - +; * Filter... name of a two-place predicate that filters the most promising ; -; - +; * among partial_sols ; -; - +; * One_of... name of a two-place predicate that decides whether the current ; -; - +; * theory PS should be generalised or specialised ; -; - +; * Spec... name of a 2-place predicate that determines all specialisations ; -; - +; * of the current theory PS wrt the bias ; -; - +; * Gen... name of a 2-place predicate that determines all generalisations ; -; - +; * of the current theory PS wrt the bias ; -; - +; * L_newp... name of a 14-place predicate, the actual PI-module ; -; - +; * Output... name of a 1-place predicate that outputs the complete solutions ; -; - +; * ; -; - +; * ; -; - +; * description: implements a generic ILP algorithm (cf GENCOL) with PI capabilities ; -; - +; * the actual learning algorithm depends on the implementations of ; -; - +; * the argument predicates ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - - - - - (= - (gilppi $Initialize $Stop_C $Quality_C $Update $Select $Add $Filter $One_of $Spec $Gen $L_newp $Output) - ( (c-call $Initialize - (:: $Partial_Sols)) (gilppi $Partial_Sols Nil $Initialize $Stop_C $Quality_C $Update $Select $Add $Filter $One_of $Spec $Gen $L_newp $Output))) -; - - - - (= - (gilppi $_ $Complete_Sols $_ $Stop_C $_ $_ $_ $_ $_ $_ $_ $_ $_ $Output) - ( (c-call $Stop_C - (:: $Complete_Sols)) - (set-det) - (c-call $Output - (:: $Complete_Sols)))) -; +; *********************************************************************** - (= - (gilppi $Partial_Sols $Complete_Sols $Initialize $Stop_C $Quality_C $Update $Select $Add $Filter $One_of $Spec $Gen $L_newp $Output) - ( (c-call $Select - (:: $Partial_Sols $PS $M $Partial_Sols1)) (det-if-then-else (c-call $Quality_C (:: $PS)) (, (c-call $Update (:: $Partial_Sols1 $Partial_Sols2)) (gilppi $Partial_Sols2 (Cons $PS $Complete_Sols) $Initialize $Stop_C $Quality_C $Update $Select $Add $Filter $One_of $Spec $Gen $L_newp $Output)) (, (det-if-then-else (== $M active) (, (c-call $One_of (:: $PS $GS)) (det-if-then-else (== $GS spec) (, (write Specialising) (nl) (write-list $PS) (nl) (nl) (c-call $Spec (:: $PS $PSL))) (, (write Generalising) (nl) (write-list $PS) (nl) (nl) (c-call $Gen (:: $PS $PSL))))) (c-call $L_newp (:: $PS $PSL $Initialize $Stop_C $Quality_C $Update $Select $Add $Filter $One_of $Spec $Gen $L_newp $Output))) (c-call $Add (:: $Partial_Sols1 $PSL $Partial_Sols2)) (c-call $Filter (:: $Partial_Sols2 $Partial_Sols3)) (gilppi $Partial_Sols3 $Complete_Sols $Initialize $Stop_C $Quality_C $Update $Select $Add $Filter $One_of $Spec $Gen $L_newp $Output))))) -; + (= (gilppi $Initialize $Stop_C $Quality_C $Update $Select $Add $Filter $One_of $Spec $Gen $L_newp $Output) + (c-call $Initialize + (:: $Partial_Sols)) + (gilppi $Partial_Sols Nil $Initialize $Stop_C $Quality_C $Update $Select $Add $Filter $One_of $Spec $Gen $L_newp $Output)) + (= (gilppi $_ $Complete_Sols $_ $Stop_C $_ $_ $_ $_ $_ $_ $_ $_ $_ $Output) + (c-call $Stop_C + (:: $Complete_Sols)) + (set-det) + (c-call $Output + (:: $Complete_Sols))) - (= - (c-call $MPred $Arglist) - ( (c-mod $MPred $M $Pred) - (=.. $Call - (Cons $Pred $Arglist)) - (call (with_self $M $Call)))) -; + (= (gilppi $Partial_Sols $Complete_Sols $Initialize $Stop_C $Quality_C $Update $Select $Add $Filter $One_of $Spec $Gen $L_newp $Output) + (c-call $Select + (:: $Partial_Sols $PS $M $Partial_Sols1)) + (det-if-then-else + (c-call $Quality_C + (:: $PS)) + (, + (c-call $Update + (:: $Partial_Sols1 $Partial_Sols2)) + (gilppi $Partial_Sols2 + (Cons $PS $Complete_Sols) $Initialize $Stop_C $Quality_C $Update $Select $Add $Filter $One_of $Spec $Gen $L_newp $Output)) + (, + (det-if-then-else + (== $M active) + (, + (c-call $One_of + (:: $PS $GS)) + (det-if-then-else + (== $GS spec) + (, + (write Specialising) + (nl) + (write-list $PS) + (nl) + (nl) + (c-call $Spec + (:: $PS $PSL))) + (, + (write Generalising) + (nl) + (write-list $PS) + (nl) + (nl) + (c-call $Gen + (:: $PS $PSL))))) + (c-call $L_newp + (:: $PS $PSL $Initialize $Stop_C $Quality_C $Update $Select $Add $Filter $One_of $Spec $Gen $L_newp $Output))) + (c-call $Add + (:: $Partial_Sols1 $PSL $Partial_Sols2)) + (c-call $Filter + (:: $Partial_Sols2 $Partial_Sols3)) + (gilppi $Partial_Sols3 $Complete_Sols $Initialize $Stop_C $Quality_C $Update $Select $Add $Filter $One_of $Spec $Gen $L_newp $Output)))) - (= - (c-mod - (with_self $M $Pred) $M $Pred) - ( (simple $Pred) (set-det))) -; + (= (c-call $MPred $Arglist) + (c-mod $MPred $M $Pred) + (=.. $Call + (Cons $Pred $Arglist)) + (call (with_self $M $Call))) - (= - (c-mod - (with_self $_ $P) $M1 $Pred) - ( (set-det) (c-mod $P $M1 $Pred))) -; + (= (c-mod (with_self $M $Pred) $M $Pred) + (simple $Pred) + (set-det)) + (= (c-mod (with_self $_ $P) $M1 $Pred) + (set-det) + (c-mod $P $M1 $Pred)) diff --git a/miles/gencon_instances/constrained_clauses.metta b/miles/gencon_instances/constrained_clauses.metta index 5bd77fc..51a6929 100644 --- a/miles/gencon_instances/constrained_clauses.metta +++ b/miles/gencon_instances/constrained_clauses.metta @@ -1,23 +1,17 @@ +; (convert_to_metta_file constrained_clauses $_197668 miles/gencon_instances/constrained_clauses.pl miles/gencon_instances/constrained_clauses.metta) ; -; - +; MODULE constrained_clauses EXPORTS !(module constrained-clauses (:: (/ learn-constrained 0))) -; - ; -; - +; METAPREDICATES !(meta-predicate (ccl-newp + + : : : : : : : : : : : :)) -; - ; -; - +; IMPORTS !(use-module (home kb) (:: @@ -31,34 +25,24 @@ (/ store-ex 3) (/ delete-all 1) (/ known 6))) -; - !(use-module (home gencon) (:: (/ gilppi 12) (/ gilppi 14))) -; - !(use-module (home argument-types) (:: (/ types-of 3) - (/ type-restriction 2))) -; - + (/ type-restriction 2))) !(use-module (home clause-heads) - (:: (/ heads 1))) -; - + (:: (/ heads 1))) !(use-module (home show-utils) (:: (/ show-kb 0) - (/ write-list 1))) -; - + (/ write-list 1))) !(use-module (home evaluation) (:: @@ -70,13 +54,9 @@ (/ covered-neg-examples 1) (/ fp-hyp 1) (/ change-evaluated 1))) -; - !(use-module (home lgg) (:: (/ set-lgg 2))) -; - !(use-module (home div-utils) (:: @@ -85,336 +65,200 @@ (/ mysetof 3) (/ make-unique 2) (/ body2list 2))) -; - !(use-module (home var-utils) (:: (/ only-vars 2) (/ clause-terms 2))) -; - !(use-module (home tdref-it) (:: (/ refinement-add-body-literal 3))) -; - !(use-module (home newpred) (:: (/ specialize-with-newpred 7))) -; - !(use-module (home interpreter) (:: (/ prooftrees 3))) -; - !(use-module-if-exists (library basics) (:: (/ member 2))) -; - !(use-module-if-exists (library strings) (:: (/ gensym 2))) -; - !(use-module-if-exists (library sets) (:: (/ subset 2))) -; - !(use-module-if-exists (library subsumes) (:: (/ variant 2))) -; - ; -; - +; METAPREDICATES ; -; - +; none ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: constrained_clauses.pl ; -; - +; * ; -; - +; * author: I.Stahl date:8/93 ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * ; -; - +; * description: instantiation of gilppi for RUL-programs ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (learn-constrained) + (= (learn-constrained) (gilppi ccinitialize ccstop-c ccquality-c ccupdate ccselect ccadd ccfilter ccone-of ccspec ccgen ccl-newp ccoutput)) -; - - - - - (= - (ccinitialize (:: (, (with_self $HL (with_self (:: $S1 $S2) $HL)) (active)))) - ( (heads $HL) - (store-clauses $HL hypo) - (eval-examples) - (findall - (, $ID $H $B $CL $E) - (, - (get-clause $ID $H $B $CL hypo) - (get-evaluation $ID $E) - (delete-clause $ID)) $S1) - (findall - (, $ID1 $M1 $T1) - (remove-symbol &self - (prooftrees $ID1 $M1 $T1)) $S2))) -; - - - - (= - (ccinitialize-newp (:: (, (with_self $PS (with_self (:: $S1 $S2) $PS)) (active)))) - ( (heads $HL) - (store-clauses $HL hypo) - (eval-examples) - (findall - (= $H0 $B0) - (get-clause $_ $H0 $B0 $_ hypo) $PS) - (findall - (, $ID $H $B $CL $E) - (, - (get-clause $ID $H $B $CL hypo) - (get-evaluation $ID $E) - (delete-clause $ID)) $S1) - (findall - (, $ID1 $M1 $T1) - (remove-symbol &self - (prooftrees $ID1 $M1 $T1)) $S2))) -; - - - - (= - (ccstop_c - ($_)) True) -; + (= (ccinitialize (:: (, (with_self $HL (with_self (:: $S1 $S2) $HL)) (active)))) + (heads $HL) + (store-clauses $HL hypo) + (eval-examples) + (findall + (, $ID $H $B $CL $E) + (, + (get-clause $ID $H $B $CL hypo) + (get-evaluation $ID $E) + (delete-clause $ID)) $S1) + (findall + (, $ID1 $M1 $T1) + (remove-is-symbol &self + (prooftrees $ID1 $M1 $T1)) $S2)) + + + (= (ccinitialize-newp (:: (, (with_self $PS (with_self (:: $S1 $S2) $PS)) (active)))) + (heads $HL) + (store-clauses $HL hypo) + (eval-examples) + (findall + (= $H0 $B0) + (get-clause $_ $H0 $B0 $_ hypo) $PS) + (findall + (, $ID $H $B $CL $E) + (, + (get-clause $ID $H $B $CL hypo) + (get-evaluation $ID $E) + (delete-clause $ID)) $S1) + (findall + (, $ID1 $M1 $T1) + (remove-is-symbol &self + (prooftrees $ID1 $M1 $T1)) $S2)) - (= - (ccquality-c (with_self $_ (with_self (:: $SC $SP) $_))) - ( (sclauses $SC) - (sprooftrees $SP) - (det-if-then-else - (, - (complete-chk) - (correct-chk)) True fail))) -; + (= (ccstop_c ($_)) True) - (= - (ccupdate $L $L) True) -; + (= (ccquality-c (with_self $_ (with_self (:: $SC $SP) $_))) + (sclauses $SC) + (sprooftrees $SP) + (det-if-then-else + (, + (complete-chk) + (correct-chk)) True fail)) - (= - (sclauses ()) True) -; + (= (ccupdate $L $L) True) - (= - (sclauses (Cons (, $ID $H $B $CL $E) $R)) - ( (sclauses $R) (add-symbol &self (: kb (known $ID $H $B $CL hypo $E))))) -; + (= (sclauses ()) True) + (= (sclauses (Cons (, $ID $H $B $CL $E) $R)) + ( (sclauses $R) (add-is-symbol &self (: kb (known $ID $H $B $CL hypo $E))))) - (= - (sprooftrees Nil) + (= (sprooftrees Nil) (change-evaluated yes)) -; - - (= - (sprooftrees (Cons (, $ID $M $T) $R)) - ( (sprooftrees $R) (add-symbol &self (: interpreter (prooftrees $ID $M $T))))) -; - + (= (sprooftrees (Cons (, $ID $M $T) $R)) + ( (sprooftrees $R) (add-is-symbol &self (: interpreter (prooftrees $ID $M $T))))) - (= - (ccselect $Partial_Sols $PS active $Partial_Sols1) + (= (ccselect $Partial_Sols $PS active $Partial_Sols1) (select-active $Partial_Sols $PS $Partial_Sols1)) -; - - (= - (ccselect $Partial_Sols $PS passive $Partial_Sols) + (= (ccselect $Partial_Sols $PS passive $Partial_Sols) (select-passive $Partial_Sols $PS)) -; - - (= - (select_active - (Cons - (, $PS active) $R) $PS - (Cons - (, $PS passive) $R)) True) -; - - (= - (select-active - (Cons $P $R) $PS - (Cons $P $R1)) + (= (select_active (Cons (, $PS active) $R) $PS (Cons (, $PS passive) $R)) True) + (= (select-active (Cons $P $R) $PS (Cons $P $R1)) (select-active $R $PS $R1)) -; - - (= - (select-passive $Partial_Sols $PS) - ( (candidates $Partial_Sols Nil $Partial_Sols1) (best $Partial_Sols1 (- $_ $PS)))) -; + (= (select-passive $Partial_Sols $PS) + (candidates $Partial_Sols Nil $Partial_Sols1) + (best $Partial_Sols1 + (- $_ $PS))) + (= (candidates () $PSS $PSS) True) + (= (candidates (Cons (, (with_self $PS (with_self (:: $SC $SP) $Hist)) $_) $R) $PSS $PSS2) + (candidates $R $PSS $PSS1) + (sclauses $SC) + (sprooftrees $SP) + (det-if-then-else complete-chk + (, + (covered-neg-examples $N) + (length $N $NN) + (ccins + (- $NN + (with_self $PS + (with_self + (:: $SC $SP) $Hist))) $PSS1 $PSS2)) + (= $PSS1 $PSS2)) + (clear-evaluation) + (findall $ID + (, + (get-clause $ID $_ $_ $_ hypo) + (delete-clause $ID)) $_)) - (= - (candidates () $PSS $PSS) True) -; - - (= - (candidates - (Cons - (, - (with_self $PS - (with_self - (:: $SC $SP) $Hist)) $_) $R) $PSS $PSS2) - ( (candidates $R $PSS $PSS1) - (sclauses $SC) - (sprooftrees $SP) - (det-if-then-else complete-chk - (, - (covered-neg-examples $N) - (length $N $NN) - (ccins - (- $NN - (with_self $PS - (with_self - (:: $SC $SP) $Hist))) $PSS1 $PSS2)) - (= $PSS1 $PSS2)) - (clear-evaluation) - (findall $ID - (, - (get-clause $ID $_ $_ $_ hypo) - (delete-clause $ID)) $_))) -; + (= (ccins (- $N $PS) (Cons (- $N1 $PS1) $R) (Cons (- $N1 $PS1) $R1)) + (> $N $N1) + (set-det) + (ccins + (- $N $PS) $R $R1)) + (= (ccins $X $L (Cons $X $L)) True) - (= - (ccins - (- $N $PS) - (Cons - (- $N1 $PS1) $R) - (Cons - (- $N1 $PS1) $R1)) - ( (> $N $N1) - (set-det) - (ccins - (- $N $PS) $R $R1))) -; - - (= - (ccins $X $L - (Cons $X $L)) True) -; - - - - (= - (ccadd $Partial_Sols $PSL $Partial_Sols1) + (= (ccadd $Partial_Sols $PSL $Partial_Sols1) (append $Partial_Sols $PSL $Partial_Sols1)) -; - - (= - (ccfilter $Partial_Sols $Partial_Sols1) + (= (ccfilter $Partial_Sols $Partial_Sols1) (ccfilter $Partial_Sols Nil $Partial_Sols1)) -; + (= (ccfilter () $Partial_Sols $Partial_Sols) True) + (= (ccfilter (Cons $X $R) $Partial_Sols $Partial_Sols2) + (ccfilter1 $X $Partial_Sols $Partial_Sols1) + (ccfilter $R $Partial_Sols1 $Partial_Sols2)) - (= - (ccfilter () $Partial_Sols $Partial_Sols) True) -; - (= - (ccfilter - (Cons $X $R) $Partial_Sols $Partial_Sols2) - ( (ccfilter1 $X $Partial_Sols $Partial_Sols1) (ccfilter $R $Partial_Sols1 $Partial_Sols2))) -; - - - - (= - (ccfilter1 $X () - ($X)) True) -; - - (= - (ccfilter1 - (, - (with_self $PS - (with_self $DB $Hist)) $M) - (Cons - (, - (with_self $PS1 - (with_self $DB1 $Hist1)) $M1) $R) - (Cons - (, - (with_self $PS1 - (with_self $DB1 $Hist1)) $M1) $R1)) + (= (ccfilter1 $X () ($X)) True) + (= (ccfilter1 (, (with_self $PS (with_self $DB $Hist)) $M) (Cons (, (with_self $PS1 (with_self $DB1 $Hist1)) $M1) $R) (Cons (, (with_self $PS1 (with_self $DB1 $Hist1)) $M1) $R1)) (det-if-then-else (, (= $M $M1) @@ -424,296 +268,233 @@ (, (with_self $PS (with_self $DB $Hist)) $M) $R $R1))) -; - - (= - (ccone-of $_ $M) + (= (ccone-of $_ $M) (det-if-then-else complete-chk (= $M spec) (= $M gen))) -; - - (= - (ccspec - (with_self $_ - (with_self $_ $Hist)) $PSL) - ( (ccspec1 $Hist $PSL) - (write-l $PSL) - (findall $ID - (get-clause $ID $_ $_ $_ hypo) $IDL) - (delete-all $IDL))) -; - - - - (= - (ccspec1 $Hist $PSL) - ( (covered-neg-examples $NIDs) - (fp-hyp $OR) - (best $OR - (with_self $I $_)) - (get-clause $I $H $B $_ hypo) - (get-evaluation $I - (evaluation $_ $_ $Pos $_ $_ $_ $_ $_ $_)) - (\== $Pos Nil) - (clause-terms - (= $H $B) $Terms) - (types-of $Terms - (= $H $B) $TTerms) - (refinement-add-body-literal - (= $H $B) $TTerms $CL) - (length $CL $CLl) - (nl) - (write 'no refs: ') - (write $CLl) - (nl) - (nl) - (check-refinements $CL $NIDs $I $Hist - (= $H $B) $PSL))) -; - - - - (= - (check-refinements $CL $NIDs $I $Hist $C $PSL) - ( (delete-clause $I) - (clear-evaluation) - (check-refinements $CL $NIDs $I $Hist $PSL) - (store-clause $C $_ hypo $I) - (set-det))) -; - - - (= - (check_refinements () $_ $_ $_ ()) True) -; - - (= - (check-refinements - (Cons $C $R) $NID $I $Hist $PSL2) - ( (det-if-then-else - (, - (constrained $C) - (not (clause-in $C $Hist $_))) - (, - (store-clause $C $_ hypo $I) - (eval-examples) - (get-evaluation $I - (evaluation $_ $_ $Pos $_ $_ $_ $_ $_ $_)) - (covered-neg-examples $NID1) - (det-if-then-else - (, - (genuine-subset $NID1 $NID) - (\== $Pos Nil)) - (, - (findall - (= $H $B) - (get-clause $ID $H $B $_ hypo) $PS) - (findall - (, $ID $H $B $CL $E) + (= (ccspec (with_self $_ (with_self $_ $Hist)) $PSL) + (ccspec1 $Hist $PSL) + (write-l $PSL) + (findall $ID + (get-clause $ID $_ $_ $_ hypo) $IDL) + (delete-all $IDL)) + + + (= (ccspec1 $Hist $PSL) + (covered-neg-examples $NIDs) + (fp-hyp $OR) + (best $OR + (with_self $I $_)) + (get-clause $I $H $B $_ hypo) + (get-evaluation $I + (evaluation $_ $_ $Pos $_ $_ $_ $_ $_ $_)) + (\== $Pos Nil) + (clause-terms + (= $H $B) $Terms) + (types-of $Terms + (= $H $B) $TTerms) + (refinement-add-body-literal + (= $H $B) $TTerms $CL) + (length $CL $CLl) + (nl) + (write 'no refs: ') + (write $CLl) + (nl) + (nl) + (check-refinements $CL $NIDs $I $Hist + (= $H $B) $PSL)) + + + (= (check-refinements $CL $NIDs $I $Hist $C $PSL) + (delete-clause $I) + (clear-evaluation) + (check-refinements $CL $NIDs $I $Hist $PSL) + (store-clause $C $_ hypo $I) + (set-det)) + + (= (check_refinements () $_ $_ $_ ()) True) + (= (check-refinements (Cons $C $R) $NID $I $Hist $PSL2) + (det-if-then-else + (, + (constrained $C) + (not (clause-in $C $Hist $_))) + (, + (store-clause $C $_ hypo $I) + (eval-examples) + (get-evaluation $I + (evaluation $_ $_ $Pos $_ $_ $_ $_ $_ $_)) + (covered-neg-examples $NID1) + (det-if-then-else + (, + (genuine-subset $NID1 $NID) + (\== $Pos Nil)) + (, + (findall + (= $H $B) + (get-clause $ID $H $B $_ hypo) $PS) + (findall + (, $ID $H $B $CL $E) + (, + (get-clause $ID $H $B $CL hypo) + (get-evaluation $ID $E)) $S1) + (findall + (, $ID1 $M1 $T1) + (remove-is-symbol &self + (prooftrees $ID1 $M1 $T1)) $S2) + (= $PSL2 + (Cons (, - (get-clause $ID $H $B $CL hypo) - (get-evaluation $ID $E)) $S1) - (findall - (, $ID1 $M1 $T1) - (remove-symbol &self - (prooftrees $ID1 $M1 $T1)) $S2) - (= $PSL2 - (Cons - (, - (with_self $PS - (with_self - (:: $S1 $S2) - (Cons $C $Hist))) - (active)) $PSL1))) - (, - (= $PSL2 $PSL1) - (clear-evaluation))) - (delete-clause $I)) - (= $PSL2 $PSL1)) (check-refinements $R $NID $I $Hist $PSL1))) -; - - - - - (= - (constrained (= $H $B)) - ( (only-vars $H $HV) - (only-vars $B $BV) - (remove-v $HV $BV Nil))) -; - - - - (= - (clause-in - (= $H True) - (Cons - (= $H1 $B1) $R) $R2) - ( (set-det) (det-if-then-else (, (variant $H $H1) (== $B1 True)) (= $R2 $R) (, (clause-in (= $H True) $R $R1) (= $R2 (Cons (= $H1 $B1) $R1)))))) -; - - (= - (clause-in - (= $H $B) - (Cons - (= $H1 $B1) $R) $R2) - ( (body2list $B $BL) - (body2list $B1 $B1L) - (set-det) - (det-if-then-else - (, - (variant $H $H1) - (length $BL $N) - (length $B1L $N)) - (, - (= $H $H1) - (det-if-then-else - (c-in $BL $B1L) - (= $R2 $R) - (, - (clause-in - (= $H $B) $R $R1) - (= $R2 - (Cons - (= $H1 $B1) $R1))))) - (, - (clause-in - (= $H $B) $R $R1) - (= $R2 - (Cons - (= $H1 $B1) $R1)))))) -; + (with_self $PS + (with_self + (:: $S1 $S2) + (Cons $C $Hist))) + (active)) $PSL1))) + (, + (= $PSL2 $PSL1) + (clear-evaluation))) + (delete-clause $I)) + (= $PSL2 $PSL1)) + (check-refinements $R $NID $I $Hist $PSL1)) - (= - (c_in () ()) True) -; + (= (constrained (= $H $B)) + (only-vars $H $HV) + (only-vars $B $BV) + (remove-v $HV $BV Nil)) - (= - (c-in - (Cons $L $R) $B) - ( (remove-v - (:: $L) $B $B1) - (set-det) - (c-in $R $B1))) -; + (= (clause-in (= $H True) (Cons (= $H1 $B1) $R) $R2) + (set-det) + (det-if-then-else + (, + (variant $H $H1) + (== $B1 True)) + (= $R2 $R) + (, + (clause-in + (= $H True) $R $R1) + (= $R2 + (Cons + (= $H1 $B1) $R1))))) + (= (clause-in (= $H $B) (Cons (= $H1 $B1) $R) $R2) + (body2list $B $BL) + (body2list $B1 $B1L) + (set-det) + (det-if-then-else + (, + (variant $H $H1) + (length $BL $N) + (length $B1L $N)) + (, + (= $H $H1) + (det-if-then-else + (c-in $BL $B1L) + (= $R2 $R) + (, + (clause-in + (= $H $B) $R $R1) + (= $R2 + (Cons + (= $H1 $B1) $R1))))) + (, + (clause-in + (= $H $B) $R $R1) + (= $R2 + (Cons + (= $H1 $B1) $R1))))) - (= - (clause_variants () ()) True) -; + (= (c_in () ()) True) + (= (c-in (Cons $L $R) $B) + (remove-v + (:: $L) $B $B1) + (set-det) + (c-in $R $B1)) - (= - (clause-variants - (Cons $C $R) $CL) - ( (clause-in $C $CL $CL1) (clause-variants $R $CL1))) -; + (= (clause_variants () ()) True) + (= (clause-variants (Cons $C $R) $CL) + (clause-in $C $CL $CL1) + (clause-variants $R $CL1)) - (= - (genuine-subset $L1 $L2) - ( (length $L1 $L1n) - (length $L2 $L2n) - (< $L1n $L2n) - (subset $L1 $L2))) -; + (= (genuine-subset $L1 $L2) + (length $L1 $L1n) + (length $L2 $L2n) + (< $L1n $L2n) + (subset $L1 $L2)) + (= (ccgen (with_self $_ (with_self $_ $Hist)) (:: (, (with_self $PS (with_self (:: $S1 $S2) $Hist)) (active)))) + (covered-pos-examples $Cov) + (findall + (with_self $ID1 $E1) + (, + (member $ID1 $Cov) + (get-example $ID1 $E1 $_)) $Cov1) + (get-clause $ID $H $B $_ hypo) + (mysetof + (with_self $IDE $H) + (get-example $IDE $H +) $PH) + (remove-v $Cov1 $PH $P1) + (\== $P1 Nil) + (ccgen2 $ID $H $B $PH $B1) + (store-clause + (= $H $B1) $_ hypo $_) + (eval-examples) + (findall + (, $ID2 $H2 $B2 $CL2 $E2) + (, + (get-clause $ID2 $H2 $B2 $CL2 hypo) + (get-evaluation $ID2 $E2)) $S1) + (findall + (, $ID3 $M3 $T3) + (remove-is-symbol &self + (prooftrees $ID3 $M3 $T3)) $S2) + (findall + (= $H4 $B4) + (, + (get-clause $ID4 $H4 $B4 $_ hypo) + (delete-clause $ID4)) $PS) + (write-l (:: (, (with_self $PS (with_self (:: $S1 $S2) $Hist)) (active))))) - (= - (ccgen - (with_self $_ - (with_self $_ $Hist)) - (:: (, (with_self $PS (with_self (:: $S1 $S2) $Hist)) (active)))) - ( (covered-pos-examples $Cov) - (findall - (with_self $ID1 $E1) - (, - (member $ID1 $Cov) - (get-example $ID1 $E1 $_)) $Cov1) - (get-clause $ID $H $B $_ hypo) - (mysetof - (with_self $IDE $H) - (get-example $IDE $H +) $PH) - (remove-v $Cov1 $PH $P1) - (\== $P1 Nil) - (ccgen2 $ID $H $B $PH $B1) - (store-clause - (= $H $B1) $_ hypo $_) - (eval-examples) - (findall - (, $ID2 $H2 $B2 $CL2 $E2) - (, - (get-clause $ID2 $H2 $B2 $CL2 hypo) - (get-evaluation $ID2 $E2)) $S1) - (findall - (, $ID3 $M3 $T3) - (remove-symbol &self - (prooftrees $ID3 $M3 $T3)) $S2) - (findall - (= $H4 $B4) - (, - (get-clause $ID4 $H4 $B4 $_ hypo) - (delete-clause $ID4)) $PS) - (write-l (:: (, (with_self $PS (with_self (:: $S1 $S2) $Hist)) (active)))))) -; - - - - (= - (ccgen2 $ID $H $B $PH $B1) - ( (delete-clause $ID) - (body2list $B $BL) - (ccgen3 $BL $ID $H $PH $BL1) - (det-if-then-else - (== $BL1 Nil) - (= $B1 True) - (body2list $B1 $BL1)) - (store-clause - (= $H $B) $_ hypo $ID))) -; - - - - (= - (ccgen3 () $_ $_ $_ ()) True) -; - - (= - (ccgen3 - (Cons - (with_self $L $M) $R) $ID $H $PH $B) - ( (ccgen3 $R $ID $H $PH $B1) - (store-clause - (= $H $L) $_ hypo $ID) - (eval-examples) - (get-evaluation $ID - (evaluation $_ $_ $Pos $_ $_ $_ $_ $_ $_)) - (delete-clause $ID) - (det-if-then-else - (remove-v $Pos $PH Nil) - (= $B - (Cons - (with_self $L $M) $B1)) - (= $B $B1)))) -; + (= (ccgen2 $ID $H $B $PH $B1) + (delete-clause $ID) + (body2list $B $BL) + (ccgen3 $BL $ID $H $PH $BL1) + (det-if-then-else + (== $BL1 Nil) + (= $B1 True) + (body2list $B1 $BL1)) + (store-clause + (= $H $B) $_ hypo $ID)) + + + (= (ccgen3 () $_ $_ $_ ()) True) + (= (ccgen3 (Cons (with_self $L $M) $R) $ID $H $PH $B) + (ccgen3 $R $ID $H $PH $B1) + (store-clause + (= $H $L) $_ hypo $ID) + (eval-examples) + (get-evaluation $ID + (evaluation $_ $_ $Pos $_ $_ $_ $_ $_ $_)) + (delete-clause $ID) + (det-if-then-else + (remove-v $Pos $PH Nil) + (= $B + (Cons + (with_self $L $M) $B1)) + (= $B $B1))) - (= - (ccl-newp - (with_self $_ - (with_self $_ $Hist)) - (:: (, (with_self $PS (with_self (:: $S1 $S2) $Hist)) (active))) $Initialize $Stop_C $Quality_C $Update $Select $Add $Filter $One_of $Spec $Gen $L_newp $Output) + (= (ccl-newp (with_self $_ (with_self $_ $Hist)) (:: (, (with_self $PS (with_self (:: $S1 $S2) $Hist)) (active))) $Initialize $Stop_C $Quality_C $Update $Select $Add $Filter $One_of $Spec $Gen $L_newp $Output) ( (fp-hyp $OR) (best $OR (with_self $I $_)) @@ -721,12 +502,12 @@ (get-evaluation $I (evaluation $_ $_ $Pos $_ $Neg $_ $_ $_ $_)) (specialize-with-newpred - (= $H $B) $Pos $Neg $NC $NPos $NNeg $NType) + (= $H $B) $Pos $Neg $NC $NPos $NNeg $NType) (delete-clause $I) (delete-old-ex $Elist) (store-newp-ex $NPos $NNeg $IDL0) (make-unique $IDL0 $IDL) - (add-symbol &self $NType) + (add-is-symbol &self $NType) (store-clause $NC $_ hypo $I) (ccinitialize-newp $PSL) (gilppi $PSL Nil $Initialize $Stop_C $Quality_C $Update $Select $Add $Filter $One_of $Spec $Gen $L_newp $Output) @@ -737,7 +518,7 @@ (get-clause $ID0 $H0 $B0 $_ constrained-clause) (delete-clause $ID0) (store-clause - (= $H0 $B0) $_ hypo $ID0)) $_) + (= $H0 $B0) $_ hypo $ID0)) $_) (eval-examples) (findall (, $ID3 $H3 $B3 $CL3 $E3) @@ -746,86 +527,53 @@ (get-evaluation $ID3 $E3)) $S1) (findall (, $ID1 $M1 $T1) - (remove-symbol &self + (remove-is-symbol &self (prooftrees $ID1 $M1 $T1)) $S2) (findall - (= $H2 $B2) + (= $H2 $B2) (, (get-clause $ID2 $H2 $B2 $_ hypo) (delete-clause $ID2)) $PS))) -; - - - - (= - (delete-old-ex (Cons (ex $ID $F $M) $R)) - ( (get-example $ID $F $M) - (delete-example $ID) - (delete-old-ex $R))) -; - - (= - (delete_old_ex ()) True) -; + (= (delete-old-ex (Cons (ex $ID $F $M) $R)) + (get-example $ID $F $M) + (delete-example $ID) + (delete-old-ex $R)) + (= (delete_old_ex ()) True) - (= - (store_old_ex ()) True) -; - (= - (store-old-ex (Cons (ex $ID $F $M) $R)) - ( (store-ex $F $M $ID) (store-old-ex $R))) -; + (= (store_old_ex ()) True) + (= (store-old-ex (Cons (ex $ID $F $M) $R)) + (store-ex $F $M $ID) + (store-old-ex $R)) - - (= - (store_newp_ex () () ()) True) -; - - (= - (store-newp-ex Nil - (Cons $F $R) - (Cons $ID $R1)) - ( (store-ex $F - $ID) (store-newp-ex Nil $R $R1))) -; - - (= - (store-newp-ex - (Cons $F $R) $L - (Cons $ID $R1)) - ( (store-ex $F + $ID) (store-newp-ex $R $L $R1))) -; - - - - (= - (ccoutput (:: (with_self $CL (with_self $_ $_)))) - ( (findall $ID - (get-clause $ID $_ $_ $_ hypo) $IDL) - (delete-all $IDL) - (store-clauses $CL constrained-clause) - (nl) - (nl) - (write 'gilppi completed..........') - (nl) - (nl) - (show-kb))) -; - + (= (store_newp_ex () () ()) True) + (= (store-newp-ex Nil (Cons $F $R) (Cons $ID $R1)) + (store-ex $F - $ID) + (store-newp-ex Nil $R $R1)) + (= (store-newp-ex (Cons $F $R) $L (Cons $ID $R1)) + (store-ex $F + $ID) + (store-newp-ex $R $L $R1)) + (= (ccoutput (:: (with_self $CL (with_self $_ $_)))) + (findall $ID + (get-clause $ID $_ $_ $_ hypo) $IDL) + (delete-all $IDL) + (store-clauses $CL constrained-clause) + (nl) + (nl) + (write 'gilppi completed..........') + (nl) + (nl) + (show-kb)) - (= - (write-l (Cons (, (with_self $CL (with_self $_ $_)) $_) $R)) - ( (write-list $CL) - (nl) - (write-l $R))) -; - (= - (write_l ()) True) -; + (= (write-l (Cons (, (with_self $CL (with_self $_ $_)) $_) $R)) + (write-list $CL) + (nl) + (write-l $R)) + (= (write_l ()) True) diff --git a/miles/gencon_instances/constrained_clauses_ex.metta b/miles/gencon_instances/constrained_clauses_ex.metta index 7900d60..6c8a2f8 100644 --- a/miles/gencon_instances/constrained_clauses_ex.metta +++ b/miles/gencon_instances/constrained_clauses_ex.metta @@ -1,379 +1,99 @@ - - (= - (type_restriction - (male $A) - ( (is-symbol $A))) True) -; - - (= - (type_restriction - (female $A) - ( (is-symbol $A))) True) -; - - (= - (type_restriction - (parent $A $B) - ( (is-symbol $A) (is-symbol $B))) True) -; - - - - - (= - (ex - (father ma b) +) True) -; - - (= - (ex - (father mc d) +) True) -; - - (= - (ex - (father me f) +) True) -; - - (= - (ex - (father mg h) +) True) -; - - (= - (ex - (father mi j) +) True) -; - - (= - (ex - (father mk l) +) True) -; - - - (= - (ex - (father fa b) -) True) -; - - (= - (ex - (father fc d) -) True) -; - - (= - (ex - (father fe f) -) True) -; - - (= - (ex - (father fg h) -) True) -; - - (= - (ex - (father fi j) -) True) -; - - (= - (ex - (father fk l) -) True) -; - - - (= - (ex - (father b ma) -) True) -; - - (= - (ex - (father d mc) -) True) -; - - (= - (ex - (father f me) -) True) -; - - (= - (ex - (father h mg) -) True) -; - - (= - (ex - (father j mi) -) True) -; - - (= - (ex - (father l mk) -) True) -; - - (= - (ex - (father b fa) -) True) -; - - (= - (ex - (father d fc) -) True) -; - - (= - (ex - (father f fe) -) True) -; - - (= - (ex - (father h fg) -) True) -; - - (= - (ex - (father j fi) -) True) -; - - (= - (ex - (father l fk) -) True) -; - - - - (= - (ex - (human ma) +) True) -; - - (= - (ex - (human mc) +) True) -; - - (= - (ex - (human me) +) True) -; - - (= - (ex - (human mg) +) True) -; - - (= - (ex - (human mi) +) True) -; - - (= - (ex - (human mk) +) True) -; - - (= - (ex - (human fa) +) True) -; - - (= - (ex - (human fc) +) True) -; - - (= - (ex - (human fe) +) True) -; - - (= - (ex - (human fg) +) True) -; - - (= - (ex - (human fi) +) True) -; - - (= - (ex - (human fk) +) True) -; - - (= - (ex - (human b) +) True) -; - - (= - (ex - (human d) +) True) -; - - (= - (ex - (human f) +) True) -; - - (= - (ex - (human h) +) True) -; - - (= - (ex - (human j) +) True) -; - - (= - (ex - (human l) +) True) -; - - (= - (ex - (human a) -) True) -; - - (= - (ex - (human c) -) True) -; - - - - - (= - (male ma) True) -; - - (= - (male mc) True) -; - - (= - (male me) True) -; - - (= - (male mg) True) -; - - (= - (male mi) True) -; - - (= - (male mk) True) -; - - (= - (male b) True) -; - - (= - (male d) True) -; - - (= - (male f) True) -; - - (= - (male h) True) -; - - (= - (male j) True) -; - - (= - (male l) True) -; - - - - (= - (female fa) True) -; - - (= - (female fc) True) -; - - (= - (female fe) True) -; - - (= - (female fg) True) -; - - (= - (female fi) True) -; - - (= - (female fk) True) -; - - - - - (= - (parent ma b) True) -; - - (= - (parent mc d) True) -; - - (= - (parent me f) True) -; - - (= - (parent mg h) True) -; - - (= - (parent mi j) True) -; - - (= - (parent mk l) True) -; - - - (= - (parent fa b) True) -; - - (= - (parent fc d) True) -; - - (= - (parent fe f) True) -; - - (= - (parent fg h) True) -; - - (= - (parent fi j) True) -; - - (= - (parent fk l) True) -; - - - -; - +; (convert_to_metta_file constrained_clauses_ex $_30708 miles/gencon_instances/constrained_clauses_ex.pl miles/gencon_instances/constrained_clauses_ex.metta) + + (= (type_restriction (male $A) ((is-symbol $A))) True) +; /* type_restriction((A < B),[number(A),number(B)]). ex(merge([1],[2],[1,2]),'+'). ex(merge([6],[4],[4,6]),'+'). ex(merge([2,3,4,5],[4,7],[2,3,4,4,5,7]),'+'). ex(merge([44,55,66],[22,33,44,55],[22,33,44,44,55,55,66]),'+'). ex(merge([],[54,66,77,88,97],[54,66,77,88,97]),'+'). ex(merge([],[4],[4]),'+'). ex(merge([],[],[]),'+'). ex(merge([22,23,24,25],[],[22,23,24,25]),'+'). ex(merge([24],[],[24]),'+'). ex(merge([29,39,49,59],[37,79,99],[29,37,39,49,59,79,99]),'+'). ex(merge([2],[4,7],[2,4,7]),'+'). ex(merge([1],[2],[2,1]),'-'). ex(merge([6],[4],[6,4]),'-'). ex(merge([8],[7],[8]),'-'). ex(merge([2,3,4,5],[4,7],[4,3,2,4,5,7]),'-'). ex(merge([44,55,66],[22,33,44,55],[22,44,55,33,55,44,66]),'-'). ex(merge([29,39,49,59],[37,79,99],[37,39,29,59,79,49,99]),'-'). ex(merge([2],[4,7],[4,2]),'-'). ex(merge([1,2],[3,4],[1,3,2,4]),'-'). */ + (= (type_restriction (female $A) ((is-symbol $A))) True) + (= (type_restriction (parent $A $B) ((is-symbol $A) (is-symbol $B))) True) + + + + (= (ex (father ma b) +) True) + (= (ex (father mc d) +) True) + (= (ex (father me f) +) True) + (= (ex (father mg h) +) True) + (= (ex (father mi j) +) True) + (= (ex (father mk l) +) True) + + (= (ex (father fa b) -) True) + (= (ex (father fc d) -) True) + (= (ex (father fe f) -) True) + (= (ex (father fg h) -) True) + (= (ex (father fi j) -) True) + (= (ex (father fk l) -) True) + + (= (ex (father b ma) -) True) + (= (ex (father d mc) -) True) + (= (ex (father f me) -) True) + (= (ex (father h mg) -) True) + (= (ex (father j mi) -) True) + (= (ex (father l mk) -) True) + (= (ex (father b fa) -) True) + (= (ex (father d fc) -) True) + (= (ex (father f fe) -) True) + (= (ex (father h fg) -) True) + (= (ex (father j fi) -) True) + (= (ex (father l fk) -) True) + + + (= (ex (human ma) +) True) + (= (ex (human mc) +) True) + (= (ex (human me) +) True) + (= (ex (human mg) +) True) + (= (ex (human mi) +) True) + (= (ex (human mk) +) True) + (= (ex (human fa) +) True) + (= (ex (human fc) +) True) + (= (ex (human fe) +) True) + (= (ex (human fg) +) True) + (= (ex (human fi) +) True) + (= (ex (human fk) +) True) + (= (ex (human b) +) True) + (= (ex (human d) +) True) + (= (ex (human f) +) True) + (= (ex (human h) +) True) + (= (ex (human j) +) True) + (= (ex (human l) +) True) + (= (ex (human a) -) True) + (= (ex (human c) -) True) + + + + (= (male ma) True) + (= (male mc) True) + (= (male me) True) + (= (male mg) True) + (= (male mi) True) + (= (male mk) True) + (= (male b) True) + (= (male d) True) + (= (male f) True) + (= (male h) True) + (= (male j) True) + (= (male l) True) + + + (= (female fa) True) + (= (female fc) True) + (= (female fe) True) + (= (female fg) True) + (= (female fi) True) + (= (female fk) True) + + + + (= (parent ma b) True) + (= (parent mc d) True) + (= (parent me f) True) + (= (parent mg h) True) + (= (parent mi j) True) + (= (parent mk l) True) + + (= (parent fa b) True) + (= (parent fc d) True) + (= (parent fe f) True) + (= (parent fg h) True) + (= (parent fi j) True) + (= (parent fk l) True) + + +; /* ex(t(nil),+). ex(t(tree(nil,0,nil)),+). ex(t(tree(nil,0,tree(nil,0,nil))),+). ex(t(tree(nil,0,tree(nil,s(0),nil))),+). ex(t(tree(nil,0,tree(nil,s(s(0)),nil))),+). ex(t(tree(nil,0,tree(nil,s(s(s(0))),nil))),+). ex(t(tree(nil,s(0),nil)),+). ex(t(tree(nil,s(0),tree(nil,0,nil))),+). ex(t(tree(nil,s(0),tree(nil,s(0),nil))),+). ex(t(tree(nil,s(0),tree(nil,s(s(0)),nil))),+). ex(t(tree(nil,s(0),tree(nil,s(s(s(0))),nil))),+). ex(t(tree(nil,s(s(0)),nil)),+). ex(t(tree(nil,s(s(0)),tree(nil,0,nil))),+). ex(t(tree(nil,s(s(0)),tree(nil,s(0),nil))),+). ex(t(tree(nil,s(s(0)),tree(nil,s(s(0)),nil))),+). ex(t(tree(nil,s(s(0)),tree(nil,s(s(s(0))),nil))),+). ex(t(tree(nil,s(s(s(0))),nil)),+). ex(t(tree(nil,s(s(s(0))),tree(nil,0,nil))),+). ex(t(tree(nil,s(s(s(0))),tree(nil,s(0),nil))),+). ex(t(tree(nil,s(s(s(0))),tree(nil,s(s(0)),nil))),+). ex(t(tree(nil,s(s(s(0))),tree(nil,s(s(s(0))),nil))),+). ex(t(tree(tree(nil,0,nil),0,nil)),+). ex(t(tree(tree(nil,0,nil),0,tree(nil,0,nil))),+). ex(t(tree(tree(nil,0,nil),0,tree(nil,s(0),nil))),+). ex(t(tree(tree(nil,0,nil),0,tree(nil,s(s(0)),nil))),+). ex(t(tree(tree(nil,0,nil),0,tree(nil,s(s(s(0))),nil))),+). ex(t(tree(tree(nil,0,nil),s(0),nil)),+). ex(t(tree(tree(nil,0,nil),s(0),tree(nil,0,nil))),+). ex(t(tree(tree(nil,0,nil),s(0),tree(nil,s(0),nil))),+). ex(t(tree(tree(nil,0,nil),s(0),tree(nil,s(s(0)),nil))),+). ex(t(tree(tree(nil,0,nil),s(0),tree(nil,s(s(s(0))),nil))),+). ex(t(tree(tree(nil,0,nil),s(s(0)),nil)),+). ex(t(tree(tree(nil,0,nil),s(s(0)),tree(nil,0,nil))),+). ex(t(tree(tree(nil,0,nil),s(s(0)),tree(nil,s(0),nil))),+). ex(t(tree(tree(nil,0,nil),s(s(0)),tree(nil,s(s(0)),nil))),+). ex(t(tree(tree(nil,0,nil),s(s(0)),tree(nil,s(s(s(0))),nil))),+). ex(t(tree(tree(nil,0,nil),s(s(s(0))),nil)),+). ex(t(tree(tree(nil,0,nil),s(s(s(0))),tree(nil,0,nil))),+). ex(t(tree(tree(nil,0,nil),s(s(s(0))),tree(nil,s(0),nil))),+). ex(t(tree(tree(nil,0,nil),s(s(s(0))),tree(nil,s(s(0)),nil))),+). ex(t(tree(tree(nil,0,nil),s(s(s(0))),tree(nil,s(s(s(0))),nil))),+). ex(t(tree(tree(nil,s(0),nil),0,nil)),+). ex(t(tree(tree(nil,s(0),nil),0,tree(nil,0,nil))),+). ex(t(tree(tree(nil,s(0),nil),0,tree(nil,s(0),nil))),+). ex(t(tree(tree(nil,s(0),nil),0,tree(nil,s(s(0)),nil))),+). ex(t(tree(tree(nil,s(0),nil),0,tree(nil,s(s(s(0))),nil))),+). ex(t(tree(tree(nil,s(0),nil),s(0),nil)),+). ex(t(tree(tree(nil,s(0),nil),s(0),tree(nil,0,nil))),+). ex(t(tree(tree(nil,s(0),nil),s(0),tree(nil,s(0),nil))),+). ex(t(tree(tree(nil,s(0),nil),s(0),tree(nil,s(s(0)),nil))),+). ex(t(tree(tree(nil,s(0),nil),s(0),tree(nil,s(s(s(0))),nil))),+). ex(t(tree(tree(nil,s(0),nil),s(s(0)),nil)),+). ex(t(tree(tree(nil,s(0),nil),s(s(0)),tree(nil,0,nil))),+). ex(t(tree(tree(nil,s(0),nil),s(s(0)),tree(nil,s(0),nil))),+). ex(t(tree(tree(nil,s(0),nil),s(s(0)),tree(nil,s(s(0)),nil))),+). ex(t(tree(tree(nil,s(0),nil),s(s(0)),tree(nil,s(s(s(0))),nil))),+). ex(t(tree(tree(nil,s(0),nil),s(s(s(0))),nil)),+). ex(t(tree(tree(nil,s(0),nil),s(s(s(0))),tree(nil,0,nil))),+). ex(t(tree(tree(nil,s(0),nil),s(s(s(0))),tree(nil,s(0),nil))),+). ex(t(tree(tree(nil,s(0),nil),s(s(s(0))),tree(nil,s(s(0)),nil))),+). ex(t(tree(tree(nil,s(0),nil),s(s(s(0))),tree(nil,s(s(s(0))),nil))),+). ex(t(tree(tree(nil,s(s(0)),nil),0,nil)),+). ex(t(tree(tree(nil,s(s(0)),nil),0,tree(nil,0,nil))),+). ex(t(tree(tree(nil,s(s(0)),nil),0,tree(nil,s(0),nil))),+). ex(t(tree(tree(nil,s(s(0)),nil),0,tree(nil,s(s(0)),nil))),+). ex(t(tree(tree(nil,s(s(0)),nil),0,tree(nil,s(s(s(0))),nil))),+). ex(t(tree(tree(nil,s(s(0)),nil),s(0),nil)),+). ex(t(tree(tree(nil,s(s(0)),nil),s(0),tree(nil,0,nil))),+). ex(t(tree(tree(nil,s(s(0)),nil),s(0),tree(nil,s(0),nil))),+). ex(t(tree(tree(nil,s(s(0)),nil),s(0),tree(nil,s(s(0)),nil))),+). ex(t(tree(tree(nil,s(s(0)),nil),s(0),tree(nil,s(s(s(0))),nil))),+). ex(t(tree(tree(nil,s(s(0)),nil),s(s(0)),nil)),+). ex(t(tree(tree(nil,s(s(0)),nil),s(s(0)),tree(nil,0,nil))),+). ex(t(tree(tree(nil,s(s(0)),nil),s(s(0)),tree(nil,s(0),nil))),+). ex(t(tree(tree(nil,s(s(0)),nil),s(s(0)),tree(nil,s(s(0)),nil))),+). ex(t(tree(tree(nil,s(s(0)),nil),s(s(0)),tree(nil,s(s(s(0))),nil))),+). ex(t(tree(tree(nil,s(s(0)),nil),s(s(s(0))),nil)),+). ex(t(tree(tree(nil,s(s(0)),nil),s(s(s(0))),tree(nil,0,nil))),+). ex(t(tree(tree(nil,s(s(0)),nil),s(s(s(0))),tree(nil,s(0),nil))),+). ex(t(tree(tree(nil,s(s(0)),nil),s(s(s(0))),tree(nil,s(s(0)),nil))),+). ex(t(tree(tree(nil,s(s(0)),nil),s(s(s(0))),tree(nil,s(s(s(0))),nil))),+). ex(t(tree(tree(nil,s(s(s(0))),nil),0,nil)),+). ex(t(tree(tree(nil,s(s(s(0))),nil),0,tree(nil,0,nil))),+). ex(t(tree(tree(nil,s(s(s(0))),nil),0,tree(nil,s(0),nil))),+). ex(t(tree(tree(nil,s(s(s(0))),nil),0,tree(nil,s(s(0)),nil))),+). ex(t(tree(tree(nil,s(s(s(0))),nil),0,tree(nil,s(s(s(0))),nil))),+). ex(t(tree(tree(nil,s(s(s(0))),nil),s(0),nil)),+). ex(t(tree(tree(nil,s(s(s(0))),nil),s(0),tree(nil,0,nil))),+). ex(t(tree(tree(nil,s(s(s(0))),nil),s(0),tree(nil,s(0),nil))),+). ex(t(tree(tree(nil,s(s(s(0))),nil),s(0),tree(nil,s(s(0)),nil))),+). ex(t(tree(tree(nil,s(s(s(0))),nil),s(0),tree(nil,s(s(s(0))),nil))),+). ex(t(tree(tree(nil,s(s(s(0))),nil),s(s(0)),nil)),+). ex(t(tree(tree(nil,s(s(s(0))),nil),s(s(0)),tree(nil,0,nil))),+). ex(t(tree(tree(nil,s(s(s(0))),nil),s(s(0)),tree(nil,s(0),nil))),+). ex(t(tree(tree(nil,s(s(s(0))),nil),s(s(0)),tree(nil,s(s(0)),nil))),+). ex(t(tree(tree(nil,s(s(s(0))),nil),s(s(0)),tree(nil,s(s(s(0))),nil))),+). ex(t(tree(tree(nil,s(s(s(0))),nil),s(s(s(0))),nil)),+). ex(t(tree(tree(nil,s(s(s(0))),nil),s(s(s(0))),tree(nil,0,nil))),+). ex(t(tree(tree(nil,s(s(s(0))),nil),s(s(s(0))),tree(nil,s(0),nil))),+). ex(t(tree(tree(nil,s(s(s(0))),nil),s(s(s(0))),tree(nil,s(s(0)),nil))),+). ex(t(tree(tree(nil,s(s(s(0))),nil),s(s(s(0))),tree(nil,s(s(s(0))),nil))),+). ex(t(0),-). ex(t(s(0)),-). ex(t(s(s(0))),-). ex(t(s(s(s(0)))),-). ex(t(tree(nil,nil,nil)),-). ex(t(tree(nil,tree(nil,0,nil),nil)),-). ex(t(tree(0,0,s(0))),-). ex(t(tree(s(s(0)),s(0),s(s(s(0))))),-). ex(t(tree(nil,0,s(0))),-). ex(t(tree(nil,s(0),s(s(s(0))))),-). ex(t(tree(0,0,nil)),-). ex(t(tree(s(s(s(0))),s(0),nil)),-). ex(t(tree(nil,s(nil),nil)),-). ex(t(tree(nil,s(s(nil)),nil)),-). ex(t(tree(nil,s(tree(nil,0,nil)),nil)),-). ex(t(tree(nil,s(s(tree(nil,s(0),nil))),nil)),-). ex(t(tree(nil,s(s(s(nil))),nil)),-). ex(p(f([],[])),+). ex(p(f([a],[b])),+). ex(p(f([a,a],[b,b])),+). ex(p(f([a,a,a],[b,b,b])),+). ex(p(f([a,a,a,a],[b,b,b,b])),+). ex(p([]),-). ex(p([a]),-). ex(p([a,a]),-). ex(p([a,a,a]),-). ex(p([a,a,a,a]),-). ex(p([b]),-). ex(p([b,b]),-). ex(p([b,b,b]),-). ex(p([b,b,b,b]),-). ex(p(f([a],[])),-). ex(p(f([],[b,b])),-). ex(p(f([a,a,a],[b,b])),-). ex(p(f([a],[b,b,b])),-). ex(p(f([a,a,a,a],[b,b,b])),-). */ diff --git a/miles/gencon_instances/foil.metta b/miles/gencon_instances/foil.metta index 820333f..d56b030 100644 --- a/miles/gencon_instances/foil.metta +++ b/miles/gencon_instances/foil.metta @@ -1,19 +1,16 @@ +; (convert_to_metta_file foil $_163290 miles/gencon_instances/foil.pl miles/gencon_instances/foil.metta) ; -; - +; MODULE foil EXPORTS !(module foil (:: (/ learn-foil 0) (/ infogain 3))) -; - ; -; - +; IMPORTS !(use-module (home kb) @@ -26,8 +23,6 @@ (/ get-clause 5) (/ known 6) (/ store-ex 3))) -; - !(use-module (home evaluation) @@ -35,14 +30,10 @@ (/ eval-examples 0) (/ encoding-length-examples 1) (/ encoding-length-clause 2))) -; - !(use-module (home tdref-it) (:: (/ refinement-add-body-literal 2))) -; - !(use-module (home div-utils) @@ -51,91 +42,61 @@ (/ log2 2) (/ log2nueberk 3) (/ mysetof 3))) -; - !(use-module (home gencon) (:: (/ gilppi 12))) -; - !(use-module (home show-utils) (:: (/ show-kb 0))) -; - ; -; - +; METAPREDICATES ; -; - +; none ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * module: foil.pl ; -; - +; * ; -; - +; * author: Irene Stahl date: 1. 7. 1993 ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * description: simple implementation of infogain heuristic ; -; - +; * foil as instantiation of the generic algorithm (25. 11. 93) ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ************************************************************************ - (= - (learn-foil) + (= (learn-foil) (gilppi initialize stop-c quality-c update select add filter one-of spec gen l-newp output)) -; - !(dynamic (/ el-ex 1)) -; - !(dynamic (/ total-ex 1)) -; - - (= - (initialize (:: (, (with_self (:: $MGT) 0) (active)))) + (= (initialize (:: (, (with_self (:: $MGT) 0) (active)))) ( (mysetof (, $P $N) (^ $ID @@ -146,423 +107,298 @@ (:: (, $P1 $N1))) (functor $MGT $P1 $N1) (encoding-length-examples $X) - (add-symbol &self + (add-is-symbol &self (el_ex $X)) (mysetof $ID1 (^ $F1 (^ $L1 (get-example $ID1 $F1 $L1))) $IDL) (length $IDL $TE) - (add-symbol &self + (add-is-symbol &self (total_ex $TE)))) -; - - (= - (select - (Cons - (, - (: $C $G) active) $R) $C active - (Cons - (, - (: $C $G) passive) $R)) True) -; - - (= - (select - (Cons $X $R) $C active - (Cons $X $R1)) + (= (select (Cons (, (: $C $G) active) $R) $C active (Cons (, (: $C $G) passive) $R)) True) + (= (select (Cons $X $R) $C active (Cons $X $R1)) (select $R $C active $R1)) -; - - - - (= - (quality-c (:: $C)) - ( (store-clause $C $_ usr $ID) - (eval-examples) - (get-clause $ID $H $B $CL $_) - (get-evaluation $ID $E) - (det-if-then-else - (arg 5 $E Nil) - (, - (arg 3 $E $Pos) - (remove-covered-ex $Pos)) - (, - (delete-clause $ID) - (add-symbol &self - (known $ID $H $B $CL hypo $E)) - (set-det) - (fail))))) -; + (= (quality-c (:: $C)) + (store-clause $C $_ usr $ID) + (eval-examples) + (get-clause $ID $H $B $CL $_) + (get-evaluation $ID $E) + (det-if-then-else + (arg 5 $E Nil) + (, + (arg 3 $E $Pos) + (remove-covered-ex $Pos)) + (, + (delete-clause $ID) + (add-is-symbol &self + (known $ID $H $B $CL hypo $E)) + (set-det) + (fail)))) - (= - (remove_covered_ex ()) True) -; - (= - (remove-covered-ex (Cons (with_self $ID $Fact) $R)) + (= (remove_covered_ex ()) True) + (= (remove-covered-ex (Cons (with_self $ID $Fact) $R)) ( (delete-example $ID) - (add-symbol &self + (add-is-symbol &self (saved_ex $ID $Fact)) (remove-covered-ex $R))) -; - - - - (= - (update $_ - (:: (, (with_self (:: $MGT) 0) (active)))) - ( (mysetof - (, $P $N) - (^ $ID - (, - (get-example $ID $F +) - (functor $F $P $N))) - (:: (, $P1 $N1))) - (functor $MGT $P1 $N1) - (set-det))) -; - - (= - (update $_ ()) True) -; - - (= - (one_of $_ spec) True) -; + (= (update $_ (:: (, (with_self (:: $MGT) 0) (active)))) + (mysetof + (, $P $N) + (^ $ID + (, + (get-example $ID $F +) + (functor $F $P $N))) + (:: (, $P1 $N1))) + (functor $MGT $P1 $N1) + (set-det)) + (= (update $_ ()) True) + (= (one_of $_ spec) True) - (= - (spec - (:: $C) $PSL) - ( (refinement-add-body-literal $C $CL) (infogain $CL $PSL))) -; + (= (spec (:: $C) $PSL) + (refinement-add-body-literal $C $CL) + (infogain $CL $PSL)) - (= - (add $PS () $PS) True) -; - - (= - (add $PS - (Cons $X $R) $PS1) - ( (insert-by-gain $X $PS $PS0) (add $PS0 $R $PS1))) -; + (= (add $PS () $PS) True) + (= (add $PS (Cons $X $R) $PS1) + (insert-by-gain $X $PS $PS0) + (add $PS0 $R $PS1)) - - (= + (= (insert-by-gain (with_self $C $G) (Cons (, (with_self $C1 $G1) $L) $R) (Cons (, (with_self $C1 $G1) $L) $R1)) + (< $G $G1) + (set-det) (insert-by-gain - (with_self $C $G) - (Cons - (, - (with_self $C1 $G1) $L) $R) - (Cons - (, - (with_self $C1 $G1) $L) $R1)) - ( (< $G $G1) - (set-det) - (insert-by-gain - (with_self $C $G) $R $R1))) -; - - (= - (insert_by_gain - (: $C $G) $L - (Cons - (, - (: - ($C) $G) active) $L)) True) -; - - - + (with_self $C $G) $R $R1)) + (= (insert_by_gain (: $C $G) $L (Cons (, (: ($C) $G) active) $L)) True) - (= - (filter $L $L) True) -; + (= (filter $L $L) True) - (= - (stop-c $_) - ( (not (get-example $_ $_ +)) (set-det))) -; - (= - (stop-c $CL) - ( (stop-c1 $CL $N) - (el-ex $X) - (> $N $X))) -; + (= (stop-c $_) + (not (get-example $_ $_ +)) + (set-det)) + (= (stop-c $CL) + (stop-c1 $CL $N) + (el-ex $X) + (> $N $X)) - - (= - (stop_c1 () 0) True) -; - - (= - (stop-c1 + (= (stop_c1 () 0) True) + (= (stop-c1 (Cons (:: (= $H $B)) $R) $M) + (stop-c1 $R $M0) + (body2list $B $BL) + (encoding-length-clause (Cons - (:: (= $H $B)) $R) $M) - ( (stop-c1 $R $M0) - (body2list $B $BL) - (encoding-length-clause - (Cons - (with_self $H - (p)) $BL) $M1) - (is $M - (+ $M0 $M1)))) -; + (with_self $H + (p)) $BL) $M1) + (is $M + (+ $M0 $M1))) - - (= - (output $_) - ( (remove-symbol &self + (= (output $_) + ( (remove-is-symbol &self (saved_ex $ID $Fact)) (store-ex $Fact + $ID) (output $_))) -; - - (= - (output $_) - ( (remove-all-symbols &self + (= (output $_) + ( (remove-all-atoms &self (total_ex $_)) - (remove-all-symbols &self + (remove-all-atoms &self (el_ex $_)) (show-kb))) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: info_gain/3 ; -; - +; * ; -; - +; * syntax: infogain(+Clause,+Clause_refs,-CL) ; -; - +; * ; -; - +; * args: Clause.. MeTTa clause that is refined ; -; - +; * Clause_refs .. list of MeTTa clauses, refinements of Clause ; -; - +; * CL.. list of clauses with their gain: CL = [C1:Gain1,..,Cn:Gainn] ; -; - +; * ; -; - +; * description: Clause is an overgeneral clause, CL is the ; -; - +; * list of refinements of this overgeneral clause, ; -; - +; * CL = [C1,...,Cn]. infogain returns a list ; -; - +; * CL = [C1:Gain_C1,..], where ; -; - +; * Gain is the information gain of Ci in comparison ; -; - +; * with the overgeneral clause ; -; - +; * ; -; - +; ************************************************************************* - (= - (infogain $Clause $Ref_list $CL) - ( (store-clause $Clause $_ gain $ID) - (eval-examples) - (get-evaluation $ID - (evaluation $_ $Tip $_ $Tim $_ $_ $_ $_ $_)) - (delete-clause $ID) - (is $OTi - (/ $Tip - (+ $Tip $Tim))) - (log2 $OTi $LNOTi) - (is $ITi - (- $LNOTi)) - (infogain1 $Ref_list $CL $ITi))) -; + (= (infogain $Clause $Ref_list $CL) + (store-clause $Clause $_ gain $ID) + (eval-examples) + (get-evaluation $ID + (evaluation $_ $Tip $_ $Tim $_ $_ $_ $_ $_)) + (delete-clause $ID) + (is $OTi + (/ $Tip + (+ $Tip $Tim))) + (log2 $OTi $LNOTi) + (is $ITi + (- $LNOTi)) + (infogain1 $Ref_list $CL $ITi)) + (= (infogain1 () () $_) True) + (= (infogain1 (Cons $C $R) $R2 $ITi) + (infogain1 $R $R1 $ITi) + (store-clause $C $_ gain $ID) + (eval-examples) + (get-evaluation $ID + (evaluation $_ $Ti1p $_ $Ti1m $_ $_ $_ $_ $_)) + (delete-clause $ID) + (det-if-then-else + (= $Ti1p 0) + (, + (copy-term $C $C1) + (numbervars $C1 0 $_) + (write 'refuted: ') + (write $C1) + (nl) + (nl) + (= $R2 $R1)) + (, + (is $OTi1 + (/ $Ti1p + (+ $Ti1p $Ti1m))) + (log2 $OTi1 $LNOTi1) + (is $ITi1 + (- $LNOTi1)) + (is $IG + (* $Ti1p + (- $ITi $ITi1))) + (copy-term $C $C1) + (numbervars $C1 0 $_) + (write 'refined clause: ') + (write $C1) + (write ) + (write $IG) + (nl) + (nl) + (= $R2 + (Cons + (with_self $C $IG) $R1))))) - (= - (infogain1 () () $_) True) -; - (= - (infogain1 - (Cons $C $R) $R2 $ITi) - ( (infogain1 $R $R1 $ITi) - (store-clause $C $_ gain $ID) - (eval-examples) - (get-evaluation $ID - (evaluation $_ $Ti1p $_ $Ti1m $_ $_ $_ $_ $_)) - (delete-clause $ID) - (det-if-then-else - (= $Ti1p 0) - (, - (copy-term $C $C1) - (numbervars $C1 0 $_) - (write 'refuted: ') - (write $C1) - (nl) - (nl) - (= $R2 $R1)) - (, - (is $OTi1 - (/ $Ti1p - (+ $Ti1p $Ti1m))) - (log2 $OTi1 $LNOTi1) - (is $ITi1 - (- $LNOTi1)) - (is $IG - (* $Ti1p - (- $ITi $ITi1))) - (copy-term $C $C1) - (numbervars $C1 0 $_) - (write 'refined clause: ') - (write $C1) - (write ) - (write $IG) - (nl) - (nl) - (= $R2 - (Cons - (with_self $C $IG) $R1)))))) -; - - - - (= - (infogain $Ref_list $CL) - ( (get-clause $ID $_ $_ $_ hypo) - (get-evaluation $ID - (evaluation $_ $Tip $_ $Tim $_ $_ $_ $_ $_)) - (delete-clause $ID) - (is $OTi - (/ $Tip - (+ $Tip $Tim))) - (log2 $OTi $LNOTi) - (is $ITi - (- $LNOTi)) - (infogain2 $Ref_list $CL $ITi))) -; - - - - - (= - (infogain2 () () $_) True) -; - - (= - (infogain2 - (Cons $C $R) $R2 $ITi) - ( (infogain2 $R $R1 $ITi) - (store-clause $C $_ gain $ID) - (eval-examples) - (get-evaluation $ID - (evaluation $_ $Ti1p $_ $Ti1m $_ $_ $_ $_ $_)) - (encoding-length $Ti1p $X) - (det-if-then-else - (= $C - (= $H $B)) - (, - (body2list $B $BL) - (encoding-length-clause - (Cons - (with_self $H - (p)) $BL) $XE)) + (= (infogain $Ref_list $CL) + (get-clause $ID $_ $_ $_ hypo) + (get-evaluation $ID + (evaluation $_ $Tip $_ $Tim $_ $_ $_ $_ $_)) + (delete-clause $ID) + (is $OTi + (/ $Tip + (+ $Tip $Tim))) + (log2 $OTi $LNOTi) + (is $ITi + (- $LNOTi)) + (infogain2 $Ref_list $CL $ITi)) + + + + (= (infogain2 () () $_) True) + (= (infogain2 (Cons $C $R) $R2 $ITi) + (infogain2 $R $R1 $ITi) + (store-clause $C $_ gain $ID) + (eval-examples) + (get-evaluation $ID + (evaluation $_ $Ti1p $_ $Ti1m $_ $_ $_ $_ $_)) + (encoding-length $Ti1p $X) + (det-if-then-else + (= $C + (= $H $B)) + (, + (body2list $B $BL) (encoding-length-clause - (:: (with_self $C (p))) $XE)) - (delete-clause $ID) - (det-if-then-else - (or - (= $Ti1p 0) - (> $XE $X)) - (, - (copy-term $C $C1) - (numbervars $C1 0 $_) - (write 'refuted: ') - (write $C1) - (nl) - (nl) - (= $R2 $R1)) - (, - (is $OTi1 - (/ $Ti1p - (+ $Ti1p $Ti1m))) - (log2 $OTi1 $LNOTi1) - (is $ITi1 - (- $LNOTi1)) - (is $IG - (* $Ti1p - (- $ITi $ITi1))) - (copy-term $C $C1) - (numbervars $C1 0 $_) - (write 'refined clause: ') - (write $C1) - (write ) - (write $IG) - (nl) - (nl) - (= $R2 - (Cons - (with_self $C $IG) $R1)))))) -; - - - - (= - (encoding-length $PN $X) - ( (total-ex $U) - (log2 $U $LU) - (is $U1 - (float $U)) - (is $PN1 - (float $PN)) - (log2nueberk $U1 $PN1 $Y) - (is $X - (+ $LU $Y)))) -; - + (Cons + (with_self $H + (p)) $BL) $XE)) + (encoding-length-clause + (:: (with_self $C (p))) $XE)) + (delete-clause $ID) + (det-if-then-else + (or + (= $Ti1p 0) + (> $XE $X)) + (, + (copy-term $C $C1) + (numbervars $C1 0 $_) + (write 'refuted: ') + (write $C1) + (nl) + (nl) + (= $R2 $R1)) + (, + (is $OTi1 + (/ $Ti1p + (+ $Ti1p $Ti1m))) + (log2 $OTi1 $LNOTi1) + (is $ITi1 + (- $LNOTi1)) + (is $IG + (* $Ti1p + (- $ITi $ITi1))) + (copy-term $C $C1) + (numbervars $C1 0 $_) + (write 'refined clause: ') + (write $C1) + (write ) + (write $IG) + (nl) + (nl) + (= $R2 + (Cons + (with_self $C $IG) $R1))))) + + + (= (encoding-length $PN $X) + (total-ex $U) + (log2 $U $LU) + (is $U1 + (float $U)) + (is $PN1 + (float $PN)) + (log2nueberk $U1 $PN1 $Y) + (is $X + (+ $LU $Y))) diff --git a/miles/gencon_instances/foil_ex.metta b/miles/gencon_instances/foil_ex.metta index 0047e5d..a4055e4 100644 --- a/miles/gencon_instances/foil_ex.metta +++ b/miles/gencon_instances/foil_ex.metta @@ -1,328 +1,70 @@ - - (= - (type_restriction - (member $A $B) - ( (atomic $A) (list $B))) True) -; - - (= - (type_restriction - (components $A $B $C) - ( (list $A) - (atomic $B) - (list $C))) True) -; - - - - (= - (list ()) True) -; - - (= - (list (Cons $A $B)) - ( (atomic $A) (list $B))) -; - - - - - (= - (components - (Cons $X $Y) $X $Y) True) -; - - - - - (= - (ex - (member e - (e o z)) +) True) -; - - (= - (ex - (member o - (o z)) +) True) -; - - (= - (ex - (member o - (e o z)) +) True) -; - - (= - (ex - (member z - (z)) +) True) -; - - (= - (ex - (member z - (o z)) +) True) -; - - (= - (ex - (member z - (e o z)) +) True) -; - - - - - (= - (ex - (member e e) -) True) -; - - (= - (ex - (member e o) -) True) -; - - (= - (ex - (member e z) -) True) -; - - (= - (ex - (member e ()) -) True) -; - - (= - (ex - (member e - (z)) -) True) -; - - (= - (ex - (member e - (o z)) -) True) -; - - (= - (ex - (member o e) -) True) -; - - (= - (ex - (member o o) -) True) -; - - (= - (ex - (member o z) -) True) -; - - (= - (ex - (member o ()) -) True) -; - - (= - (ex - (member o - (z)) -) True) -; - - (= - (ex - (member z e) -) True) -; - - (= - (ex - (member z o) -) True) -; - - (= - (ex - (member z z) -) True) -; - - (= - (ex - (member z ()) -) True) -; - - (= - (ex - (member () e) -) True) -; - - (= - (ex - (member () o) -) True) -; - - (= - (ex - (member () z) -) True) -; - - (= - (ex - (member () ()) -) True) -; - - (= - (ex - (member () - (z)) -) True) -; - - (= - (ex - (member () - (o z)) -) True) -; - - (= - (ex - (member () - (e o z)) -) True) -; - - (= - (ex - (member - (z) e) -) True) -; - - (= - (ex - (member - (z) o) -) True) -; - - (= - (ex - (member - (z) z) -) True) -; - - (= - (ex - (member - (z) ()) -) True) -; - - (= - (ex - (member - (z) - (z)) -) True) -; - - (= - (ex - (member - (z) - (o z)) -) True) -; - - (= - (ex - (member - (z) - (e o z)) -) True) -; - - (= - (ex - (member - (o z) e) -) True) -; - - (= - (ex - (member - (o z) o) -) True) -; - - (= - (ex - (member - (o z) z) -) True) -; - - (= - (ex - (member - (o z) ()) -) True) -; - - (= - (ex - (member - (o z) - (z)) -) True) -; - - (= - (ex - (member - (o z) - (o z)) -) True) -; - - (= - (ex - (member - (o z) - (e o z)) -) True) -; - - (= - (ex - (member - (e o z) e) -) True) -; - - (= - (ex - (member - (e o z) o) -) True) -; - - (= - (ex - (member - (e o z) z) -) True) -; - - (= - (ex - (member - (e o z) ()) -) True) -; - - (= - (ex - (member - (e o z) - (z)) -) True) -; - - (= - (ex - (member - (e o z) - (o z)) -) True) -; - - (= - (ex - (member - (e o z) - (e o z)) -) True) -; - +; (convert_to_metta_file foil_ex $_360686 miles/gencon_instances/foil_ex.pl miles/gencon_instances/foil_ex.metta) + + (= (type_restriction (member $A $B) ((is-symbolic $A) (list $B))) True) + (= (type_restriction (components $A $B $C) ((list $A) (is-symbolic $B) (list $C))) True) + + + (= (list ()) True) + (= (list (Cons $A $B)) + (atomic $A) + (list $B)) + + + + (= (components (Cons $X $Y) $X $Y) True) + + + + (= (ex (member e (e o z)) +) True) + (= (ex (member o (o z)) +) True) + (= (ex (member o (e o z)) +) True) + (= (ex (member z (z)) +) True) + (= (ex (member z (o z)) +) True) + (= (ex (member z (e o z)) +) True) + + + + (= (ex (member e e) -) True) + (= (ex (member e o) -) True) + (= (ex (member e z) -) True) + (= (ex (member e ()) -) True) + (= (ex (member e (z)) -) True) + (= (ex (member e (o z)) -) True) + (= (ex (member o e) -) True) + (= (ex (member o o) -) True) + (= (ex (member o z) -) True) + (= (ex (member o ()) -) True) + (= (ex (member o (z)) -) True) + (= (ex (member z e) -) True) + (= (ex (member z o) -) True) + (= (ex (member z z) -) True) + (= (ex (member z ()) -) True) + (= (ex (member () e) -) True) + (= (ex (member () o) -) True) + (= (ex (member () z) -) True) + (= (ex (member () ()) -) True) + (= (ex (member () (z)) -) True) + (= (ex (member () (o z)) -) True) + (= (ex (member () (e o z)) -) True) + (= (ex (member (z) e) -) True) + (= (ex (member (z) o) -) True) + (= (ex (member (z) z) -) True) + (= (ex (member (z) ()) -) True) + (= (ex (member (z) (z)) -) True) + (= (ex (member (z) (o z)) -) True) + (= (ex (member (z) (e o z)) -) True) + (= (ex (member (o z) e) -) True) + (= (ex (member (o z) o) -) True) + (= (ex (member (o z) z) -) True) + (= (ex (member (o z) ()) -) True) + (= (ex (member (o z) (z)) -) True) + (= (ex (member (o z) (o z)) -) True) + (= (ex (member (o z) (e o z)) -) True) + (= (ex (member (e o z) e) -) True) + (= (ex (member (e o z) o) -) True) + (= (ex (member (e o z) z) -) True) + (= (ex (member (e o z) ()) -) True) + (= (ex (member (e o z) (z)) -) True) + (= (ex (member (e o z) (o z)) -) True) + (= (ex (member (e o z) (e o z)) -) True) diff --git a/miles/gencon_instances/rul.metta b/miles/gencon_instances/rul.metta index 655bd45..afd4124 100644 --- a/miles/gencon_instances/rul.metta +++ b/miles/gencon_instances/rul.metta @@ -1,16 +1,13 @@ +; (convert_to_metta_file rul $_455226 miles/gencon_instances/rul.pl miles/gencon_instances/rul.metta) ; -; - +; MODULE rul EXPORTS !(module rul (:: (/ learn-rul 0))) -; - ; -; - +; IMPORTS !(use-module (home kb) (:: @@ -23,439 +20,261 @@ (/ store-clauses 3) (/ store-clause 4) (/ delete-all 1))) -; - !(use-module (home argument-types) (:: (/ type-sub 2) (/ type-equal 4) - (/ replace-t 4))) -; - + (/ replace-t 4))) !(use-module (home gencon) - (:: (/ gilppi 12))) -; - + (:: (/ gilppi 12))) !(use-module (home show-utils) - (:: (/ show-kb 0))) -; - + (:: (/ show-kb 0))) !(use-module (home evaluation) (:: (/ eval-examples 0) (/ covered-pos-examples 1))) -; - !(use-module (home lgg) (:: (/ set-lgg 2))) -; - !(use-module (home div-utils) (:: (/ different-predicates 2) (/ remove-v 3) (/ mysetof 3))) -; - !(use-module (home var-utils) (:: (/ only-vars 2))) -; - !(use-module (home td-basic) (:: (/ append-body 3))) -; - !(use-module (home newpred) (:: (/ is-newpred 1))) -; - !(use-module-if-exists (library basics) (:: (/ member 2))) -; - !(use-module-if-exists (library strings) (:: (/ gensym 2))) -; - ; -; - +; METAPREDICATES ; -; - +; none ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: rul.pl ; -; - +; * ; -; - +; * author: I.Stahl date:7/93 ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * ; -; - +; * description: instantiation of gilppi for RUL-programs ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (learn-rul) + (= (learn-rul) (gilppi initialize stop-c quality-c update select add filter one-of spec gen l-newp output)) -; - - - - (= - (initialize (:: (with_self $HL (active)))) - ( (mysetof $E - (^ $I - (get-example $I $E +)) $Elist) - (different-predicates $Elist $Elist1) - (initialize1 $Elist1 $HL))) -; - - (= - (initialize1 () ()) True) -; - - (= - (initialize1 - (Cons - (Cons $E $ER) $R) $HL) - ( (initialize1 $R $HL0) - (functor $E $T $_) - (mysetof $A - (^ $M - (, - (member $M - (Cons $E $ER)) - (arg 1 $M $A))) $Alist) - (different-predicates $Alist $Alist1) - (initialize2 $Alist1 $T $HL1) - (append $HL1 $HL0 $HL))) -; - - - - (= - (initialize2 () $_ ()) True) -; - - (= - (initialize2 - (Cons $A $R) $T - (Cons - (= $H True) $R1)) - ( (set-lgg $A $A1) - (=.. $H - (:: $T $A1)) - (initialize2 $R $T $R1))) -; - + (= (initialize (:: (with_self $HL (active)))) + (mysetof $E + (^ $I + (get-example $I $E +)) $Elist) + (different-predicates $Elist $Elist1) + (initialize1 $Elist1 $HL)) + (= (initialize1 () ()) True) + (= (initialize1 (Cons (Cons $E $ER) $R) $HL) + (initialize1 $R $HL0) + (functor $E $T $_) + (mysetof $A + (^ $M + (, + (member $M + (Cons $E $ER)) + (arg 1 $M $A))) $Alist) + (different-predicates $Alist $Alist1) + (initialize2 $Alist1 $T $HL1) + (append $HL1 $HL0 $HL)) - (= - (stop_c - ($_)) True) -; + (= (initialize2 () $_ ()) True) + (= (initialize2 (Cons $A $R) $T (Cons (= $H True) $R1)) + (set-lgg $A $A1) + (=.. $H + (:: $T $A1)) + (initialize2 $R $T $R1)) - (= - (quality_c ()) True) -; - (= - (quality-c (Cons (= $H $B) $R)) - ( (only-vars $H $HV) - (only-vars $B $BV) - (remove-v $BV $HV Nil) - (quality-c $R))) -; + (= (stop_c ($_)) True) + (= (quality_c ()) True) + (= (quality-c (Cons (= $H $B) $R)) + (only-vars $H $HV) + (only-vars $B $BV) + (remove-v $BV $HV Nil) + (quality-c $R)) - (= - (update $L $L) True) -; + (= (update $L $L) True) - (= - (select $Partial_Sols $PS active $Partial_Sols1) + (= (select $Partial_Sols $PS active $Partial_Sols1) (select-active $Partial_Sols $PS $Partial_Sols1)) -; - - (= - (select $Partial_Sols $PS passive $Partial_Sols) + (= (select $Partial_Sols $PS passive $Partial_Sols) (select-passive $Partial_Sols $PS)) -; - - (= - (select_active - (Cons - (: $PS active) $R) $PS - (Cons - (: $PS passive) $R)) True) -; - - (= - (select-active - (Cons $P $R) $PS - (Cons $P $R1)) + (= (select_active (Cons (: $PS active) $R) $PS (Cons (: $PS passive) $R)) True) + (= (select-active (Cons $P $R) $PS (Cons $P $R1)) (select-active $R $PS $R1)) -; - - (= - (select-passive - (:: (with_self $PS $_)) $PS) + (= (select-passive (:: (with_self $PS $_)) $PS) (set-det)) -; - - (= - (select-passive - (Cons - (with_self $PS $_) $R) $PS2) - ( (select-passive $R $PS1) (most-specific $PS $PS1 $PS2))) -; - + (= (select-passive (Cons (with_self $PS $_) $R) $PS2) + (select-passive $R $PS1) + (most-specific $PS $PS1 $PS2)) - (= - (most-specific $PS $PS1 $PS2) + (= (most-specific $PS $PS1 $PS2) (det-if-then-else (more-specific $PS $PS1) (= $PS2 $PS) (= $PS2 $PS1))) -; - - (= - (more-specific $Spec $Gen) - ( (copy-term - (, $Spec $Gen) - (, $Spec0 $Gen0)) - (normalize $Spec0 $Spec1) - (normalize $Gen0 $Gen1) - (rename-types $Gen1 $Spec1 $Spec2 $Tlist) - (store-clauses $Spec2 type $IDS) - (store-clauses $Gen1 type $IDG) - (append $IDS $IDG $IDA) - (det-if-then-else - (more-spec $Tlist) + (= (more-specific $Spec $Gen) + (copy-term + (, $Spec $Gen) + (, $Spec0 $Gen0)) + (normalize $Spec0 $Spec1) + (normalize $Gen0 $Gen1) + (rename-types $Gen1 $Spec1 $Spec2 $Tlist) + (store-clauses $Spec2 type $IDS) + (store-clauses $Gen1 type $IDG) + (append $IDS $IDG $IDA) + (det-if-then-else + (more-spec $Tlist) + (delete-all $IDA) + (, (delete-all $IDA) - (, - (delete-all $IDA) - (set-det) - (fail))))) -; - - - + (set-det) + (fail)))) - (= - (more_spec ()) True) -; - (= - (more-spec (Cons (with_self $Spec $Gen) $R)) - ( (type-sub $Gen $Spec) (more-spec $R))) -; + (= (more_spec ()) True) + (= (more-spec (Cons (with_self $Spec $Gen) $R)) + (type-sub $Gen $Spec) + (more-spec $R)) - (= - (normalize () ()) True) -; + (= (normalize () ()) True) + (= (normalize (Cons (= $H $B) $R) (Cons (= $H $B1) $R1)) + (normalize $R $R1) + (only-vars $H $HV) + (only-vars $B $BV) + (remove-v $BV $HV $RV) + (normalize $RV $B $B1)) - (= - (normalize - (Cons - (= $H $B) $R) - (Cons - (= $H $B1) $R1)) - ( (normalize $R $R1) - (only-vars $H $HV) - (only-vars $B $BV) - (remove-v $BV $HV $RV) - (normalize $RV $B $B1))) -; - - - (= - (normalize - (:: $V) True - (all $V)) + (= (normalize (:: $V) True (all $V)) (set-det)) -; - - (= - (normalize () $B $B) True) -; - - (= - (normalize - (Cons $V $R) $B - (, - (all $V) $B1)) + (= (normalize () $B $B) True) + (= (normalize (Cons $V $R) $B (, (all $V) $B1)) (normalize $R $B $B1)) -; - - - - (= - (rename-types $Gen $Spec $Spec1 $Tlist) - ( (mysetof $Pred - (^ $H - (^ $B - (, - (member - (= $H $B) $Gen) - (functor $H $Pred 1)))) $Plist) - (rename-t $Plist $Tlist) - (transform-t $Spec $Spec1 $Tlist))) -; - - - (= - (rename_t () ()) True) -; - (= - (rename-t - (Cons $P $R) - (Cons - (with_self $P1 $P) $R1)) - ( (rename-t $R $R1) (gensym $P $P1))) -; - - - - (= - (transform_t () () $_) True) -; + (= (rename-types $Gen $Spec $Spec1 $Tlist) + (mysetof $Pred + (^ $H + (^ $B + (, + (member + (= $H $B) $Gen) + (functor $H $Pred 1)))) $Plist) + (rename-t $Plist $Tlist) + (transform-t $Spec $Spec1 $Tlist)) - (= - (transform-t - (Cons - (= $H $B) $R) - (Cons - (= $H1 $B1) $R1) $Tlist) - ( (transform-t $R $R1 $Tlist) (transform-t1 (, $H $B) $Tlist (, $H1 $B1)))) -; + (= (rename_t () ()) True) + (= (rename-t (Cons $P $R) (Cons (with_self $P1 $P) $R1)) + (rename-t $R $R1) + (gensym $P $P1)) - (= + (= (transform_t () () $_) True) + (= (transform-t (Cons (= $H $B) $R) (Cons (= $H1 $B1) $R1) $Tlist) + (transform-t $R $R1 $Tlist) (transform-t1 - (, $A $B) $Tlist - (, $A1 $B1)) - ( (set-det) - (transform-t1 $A $Tlist $A1) - (transform-t1 $B $Tlist $B1))) -; - - (= - (transform-t1 True $_ True) - (set-det)) -; + (, $H $B) $Tlist + (, $H1 $B1))) - (= - (transform-t1 $A $Tlist $A1) - ( (=.. $A - (:: $Pred $Arg)) (det-if-then-else (member (with_self $Pred1 $Pred) $Tlist) (=.. $A1 (:: $Pred1 $Arg)) (= $A1 $A)))) -; + (= (transform-t1 (, $A $B) $Tlist (, $A1 $B1)) + (set-det) + (transform-t1 $A $Tlist $A1) + (transform-t1 $B $Tlist $B1)) + (= (transform-t1 True $_ True) + (set-det)) + (= (transform-t1 $A $Tlist $A1) + (=.. $A + (:: $Pred $Arg)) + (det-if-then-else + (member + (with_self $Pred1 $Pred) $Tlist) + (=.. $A1 + (:: $Pred1 $Arg)) + (= $A1 $A))) - (= - (add $Partial_Sols $PSL $Partial_Sols1) + (= (add $Partial_Sols $PSL $Partial_Sols1) (append $PSL $Partial_Sols $Partial_Sols1)) -; - - - (= - (filter () ()) True) -; - (= - (filter - (Cons $CL $R) - (Cons $CL1 $R2)) - ( (filter $R $CL $R1 $CL1) (filter $R1 $R2))) -; - - (= - (filter () $CL () $CL) True) -; - - (= - (filter - (Cons - (with_self $CL1 $A) $R) - (with_self $CL $B) $R1 $CL2) + (= (filter () ()) True) + (= (filter (Cons $CL $R) (Cons $CL1 $R2)) + (filter $R $CL $R1 $CL1) + (filter $R1 $R2)) + (= (filter () $CL () $CL) True) + (= (filter (Cons (with_self $CL1 $A) $R) (with_self $CL $B) $R1 $CL2) (det-if-then-else (more-specific $CL $CL1) (det-if-then-else @@ -482,336 +301,262 @@ (with_self $CL1 $A) $R0)) (filter $R (with_self $CL $B) $R0 $CL2))))) -; - - (= - (one-of $PS $M) - ( (store-clauses $PS hypo $IDL) - (eval-examples) - (mysetof - (with_self $ID $P) - (get-example $ID $P +) $Pos) - (rem-other-covered $IDL $Pos $Pos1) - (delete-all $IDL) - (det-if-then-else - (= $Pos1 Nil) - (= $M spec) - (= $M gen)))) -; - - - - - (= - (spec $PS $PSL) - ( (store-clauses $PS hypo $IDL) - (eval-examples) - (mysetof $P - (^ $ID0 - (^ $H0 - (^ $B0 - (^ $CL0 - (^ $L0 - (, - (get-clause $ID0 $H0 $B0 $CL0 $L0) - (functor $H0 $P 1))))))) $Predlist) - (spec $IDL $Predlist $PSL))) -; - - - (= - (spec Nil $_ Nil) + (= (one-of $PS $M) + (store-clauses $PS hypo $IDL) + (eval-examples) (mysetof - (= $H1 $B1) + (with_self $ID $P) + (get-example $ID $P +) $Pos) + (rem-other-covered $IDL $Pos $Pos1) + (delete-all $IDL) + (det-if-then-else + (= $Pos1 Nil) + (= $M spec) + (= $M gen))) + + + + (= (spec $PS $PSL) + (store-clauses $PS hypo $IDL) + (eval-examples) + (mysetof $P + (^ $ID0 + (^ $H0 + (^ $B0 + (^ $CL0 + (^ $L0 + (, + (get-clause $ID0 $H0 $B0 $CL0 $L0) + (functor $H0 $P 1))))))) $Predlist) + (spec $IDL $Predlist $PSL)) + + (= (spec Nil $_ Nil) + (mysetof + (= $H1 $B1) (^ $ID1 (^ $CL (, (get-clause $ID1 $H1 $B1 $CL hypo) (delete-clause $ID1)))) $_)) -; - - (= - (spec - (Cons $ID $R) $Preds $PSL) - ( (get-clause $ID $H $B $_ $_) (det-if-then-else (specable $H $B $RV) (, (get-evaluation $ID (evaluation $_ $_ $Pos $_ $_ $_ $_ $_ $_)) (remove-other-covered $H $ID $Pos $Pos1) (delete-clause $ID) (spec-c $RV $H $B $Preds $ID $Pos1 $PSL0) (det-if-then-else (\== $PSL0 Nil) (, (= $PSL0 $PSL) (mysetof (= $H1 $B1) (^ $ID1 (^ $CL (, (get-clause $ID1 $H1 $B1 $CL hypo) (delete-clause $ID1)))) $_)) (, (store-clause (= $H $B) $_ hypo $ID) (spec $R $Preds $PSL)))) (spec $R $Preds $PSL)))) -; - - - - - (= - (specable $H $B $RV) - ( (only-vars $H $HV) - (only-vars $B $BV) - (remove-v $BV $HV $RV) - (\== $RV Nil) - (set-det))) -; - - - - (= - (remove-other-covered $H $ID $Pos $Pos1) - ( (functor $H $F $N) - (functor $H1 $F $N) - (mysetof $ID0 - (^ $H1 - (^ $B1 - (^ $CL1 - (get-clause $ID0 $H1 $B1 $CL1 hypo)))) $IDL0) - (remove-v - (:: $ID) $IDL0 $IDL) - (rem-other-covered $IDL $Pos $Pos1) - (set-det))) -; - - - - (= - (rem_other_covered () $Pos $Pos) True) -; - - (= - (rem-other-covered - (Cons $ID $R) $Pos $Pos2) - ( (rem-other-covered $R $Pos $Pos1) - (get-evaluation $ID - (evaluation $_ $_ $P $_ $_ $_ $_ $_ $_)) - (remove-v $P $Pos1 $Pos2))) -; - - - - - (= - (spec_c () $_ $_ $_ $_ $_ ()) True) -; - - (= - (spec-c - (Cons $V $R) $H $B $Predlist $ID $Pos $PSL) - ( (spec-c $R $H $B $Predlist $ID $Pos $PSL0) - (spec-c1 $Predlist $V $H $B $ID $Pos $PSL1) - (append $PSL0 $PSL1 $PSL))) -; - - - - (= - (spec_c1 () $_ $_ $_ $_ $_ ()) True) -; - - (= - (spec-c1 - (Cons $Pred $R) $V $H $B $ID $Pos $PSL) - ( (copy-term - (, $V $H $B) - (, $V1 $H1 $B1)) - (=.. $Lit - (:: $Pred $V1)) - (append-body - (= $H1 $B1) $Lit $C) - (store-clause $C $_ hypo $ID) - (eval-examples) - (get-evaluation $ID - (evaluation $_ $_ $Pos1 $_ $_ $_ $_ $_ $_)) - (delete-clause $ID) - (det-if-then-else - (remove-v $Pos1 $Pos Nil) - (, - (mysetof - (= $H2 $B2) - (^ $ID2 - (^ $CL - (get-clause $ID2 $H2 $B2 $CL hypo))) $RestPS) - (= $PSL - (Cons - (with_self - (Cons $C $RestPS) - (active)) $PSL0))) - (= $PSL $PSL0)) - (spec-c1 $R $V $H $B $ID $Pos $PSL0))) -; - - - - - - (= - (gen $PS - (:: (with_self (Cons (= $H True) $RestPS) (active)))) - ( (store-clauses $PS hypo) - (eval-examples) - (covered-pos-examples $Cov) - (get-clause $ID $H $_ $_ hypo) - (mysetof $IDE - (^ $H - (get-example $IDE $H +)) $PH) - (remove-v $Cov $PH $P1) - (\== $P1 Nil) - (delete-clause $ID) - (mysetof - (= $H2 $B2) - (^ $ID2 - (^ $CL2 - (, - (get-clause $ID2 $H2 $B2 $CL2 hypo) - (delete-clause $ID2)))) $RestPS))) -; + (= (spec (Cons $ID $R) $Preds $PSL) + (get-clause $ID $H $B $_ $_) + (det-if-then-else + (specable $H $B $RV) + (, + (get-evaluation $ID + (evaluation $_ $_ $Pos $_ $_ $_ $_ $_ $_)) + (remove-other-covered $H $ID $Pos $Pos1) + (delete-clause $ID) + (spec-c $RV $H $B $Preds $ID $Pos1 $PSL0) + (det-if-then-else + (\== $PSL0 Nil) + (, + (= $PSL0 $PSL) + (mysetof + (= $H1 $B1) + (^ $ID1 + (^ $CL + (, + (get-clause $ID1 $H1 $B1 $CL hypo) + (delete-clause $ID1)))) $_)) + (, + (store-clause + (= $H $B) $_ hypo $ID) + (spec $R $Preds $PSL)))) + (spec $R $Preds $PSL))) - + (= (specable $H $B $RV) + (only-vars $H $HV) + (only-vars $B $BV) + (remove-v $BV $HV $RV) + (\== $RV Nil) + (set-det)) + + + (= (remove-other-covered $H $ID $Pos $Pos1) + (functor $H $F $N) + (functor $H1 $F $N) + (mysetof $ID0 + (^ $H1 + (^ $B1 + (^ $CL1 + (get-clause $ID0 $H1 $B1 $CL1 hypo)))) $IDL0) + (remove-v + (:: $ID) $IDL0 $IDL) + (rem-other-covered $IDL $Pos $Pos1) + (set-det)) + (= (rem_other_covered () $Pos $Pos) True) + (= (rem-other-covered (Cons $ID $R) $Pos $Pos2) + (rem-other-covered $R $Pos $Pos1) + (get-evaluation $ID + (evaluation $_ $_ $P $_ $_ $_ $_ $_ $_)) + (remove-v $P $Pos1 $Pos2)) + + + + (= (spec_c () $_ $_ $_ $_ $_ ()) True) + (= (spec-c (Cons $V $R) $H $B $Predlist $ID $Pos $PSL) + (spec-c $R $H $B $Predlist $ID $Pos $PSL0) + (spec-c1 $Predlist $V $H $B $ID $Pos $PSL1) + (append $PSL0 $PSL1 $PSL)) + + + (= (spec_c1 () $_ $_ $_ $_ $_ ()) True) + (= (spec-c1 (Cons $Pred $R) $V $H $B $ID $Pos $PSL) + (copy-term + (, $V $H $B) + (, $V1 $H1 $B1)) + (=.. $Lit + (:: $Pred $V1)) + (append-body + (= $H1 $B1) $Lit $C) + (store-clause $C $_ hypo $ID) + (eval-examples) + (get-evaluation $ID + (evaluation $_ $_ $Pos1 $_ $_ $_ $_ $_ $_)) + (delete-clause $ID) + (det-if-then-else + (remove-v $Pos1 $Pos Nil) + (, + (mysetof + (= $H2 $B2) + (^ $ID2 + (^ $CL + (get-clause $ID2 $H2 $B2 $CL hypo))) $RestPS) + (= $PSL + (Cons + (with_self + (Cons $C $RestPS) + (active)) $PSL0))) + (= $PSL $PSL0)) + (spec-c1 $R $V $H $B $ID $Pos $PSL0)) + + + + + (= (gen $PS (:: (with_self (Cons (= $H True) $RestPS) (active)))) + (store-clauses $PS hypo) + (eval-examples) + (covered-pos-examples $Cov) + (get-clause $ID $H $_ $_ hypo) + (mysetof $IDE + (^ $H + (get-example $IDE $H +)) $PH) + (remove-v $Cov $PH $P1) + (\== $P1 Nil) + (delete-clause $ID) + (mysetof + (= $H2 $B2) + (^ $ID2 + (^ $CL2 + (, + (get-clause $ID2 $H2 $B2 $CL2 hypo) + (delete-clause $ID2)))) $RestPS)) + - (= - (l-newp $PS - (:: (with_self $Clist1 (active))) $_ $_ $_ $_ $_ $_ $_ $_ $_ $_ $_ $_) - ( (store-clauses $PS hypo) - (eval-examples) - (get-all-clauses $Clist) - (correct-with-newp $Clist $Clist1))) -; - (= - (get-all-clauses (Cons (with_self (= $H $B) (with_self $Pos $RV)) $R)) - ( (get-clause $ID $H $B $_ hypo) - (get-evaluation $ID - (evaluation $_ $_ $Pos $_ $_ $_ $_ $_ $_)) - (only-vars $H $HV) - (only-vars $B $BV) - (remove-v $BV $HV $RV) - (delete-clause $ID) - (get-all-clauses $R))) -; - (= - (get_all_clauses ()) True) -; + (= (l-newp $PS (:: (with_self $Clist1 (active))) $_ $_ $_ $_ $_ $_ $_ $_ $_ $_ $_ $_) + (store-clauses $PS hypo) + (eval-examples) + (get-all-clauses $Clist) + (correct-with-newp $Clist $Clist1)) + (= (get-all-clauses (Cons (with_self (= $H $B) (with_self $Pos $RV)) $R)) + (get-clause $ID $H $B $_ hypo) + (get-evaluation $ID + (evaluation $_ $_ $Pos $_ $_ $_ $_ $_ $_)) + (only-vars $H $HV) + (only-vars $B $BV) + (remove-v $BV $HV $RV) + (delete-clause $ID) + (get-all-clauses $R)) + (= (get_all_clauses ()) True) - (= - (correct_with_newp () ()) True) -; - (= - (correct-with-newp + (= (correct_with_newp () ()) True) + (= (correct-with-newp (Cons (with_self (= $H $B) (with_self $_ Nil)) $R) (Cons (= $H $B) $R1)) + (set-det) + (correct-with-newp $R $R1)) + (= (correct-with-newp (Cons (with_self (= $H $B) (with_self $Pos $RV)) $R) $R2) + (correct-with-newp $R $R1) + (c-with-newp $RV $B $B1 $Newps) + (instances $Newps $Pos $H $Elist) + (initialize1 $Elist $HL) + (append (Cons - (with_self - (= $H $B) - (with_self $_ Nil)) $R) - (Cons - (= $H $B) $R1)) - ( (set-det) (correct-with-newp $R $R1))) -; + (= $H $B1) $R1) $HL $R2)) + + + (= (c_with_newp () $B $B ()) True) + (= (c-with-newp (:: $V) True $New (:: $New)) + (set-det) + (gensym newp $Newp) + (=.. $New + (:: $Newp $V))) + (= (c-with-newp (Cons $V $R) $B (, $New $B1) (Cons $New $R1)) + (c-with-newp $R $B $B1 $R1) + (gensym newp $Newp) + (=.. $New + (:: $Newp $V))) + + + (= (instances () $_ $_ ()) True) + (= (instances (Cons $New $R) $Pos $H (Cons $NewE $R1)) + (instances $R $Pos $H $R1) + (mysetof $New + (^ $I + (^ $J + (^ $H + (, + (member + (with_self $I $H) $Pos) + (store-ex $New + $J))))) $NewE)) - (= - (correct-with-newp - (Cons - (with_self - (= $H $B) - (with_self $Pos $RV)) $R) $R2) - ( (correct-with-newp $R $R1) - (c-with-newp $RV $B $B1 $Newps) - (instances $Newps $Pos $H $Elist) - (initialize1 $Elist $HL) - (append - (Cons - (= $H $B1) $R1) $HL $R2))) -; - - - - (= - (c_with_newp () $B $B ()) True) -; - - (= - (c-with-newp - (:: $V) True $New - (:: $New)) - ( (set-det) - (gensym newp $Newp) - (=.. $New - (:: $Newp $V)))) -; - - (= - (c-with-newp - (Cons $V $R) $B - (, $New $B1) - (Cons $New $R1)) - ( (c-with-newp $R $B $B1 $R1) - (gensym newp $Newp) - (=.. $New - (:: $Newp $V)))) -; - - - - (= - (instances () $_ $_ ()) True) -; - - (= - (instances - (Cons $New $R) $Pos $H - (Cons $NewE $R1)) - ( (instances $R $Pos $H $R1) (mysetof $New (^ $I (^ $J (^ $H (, (member (with_self $I $H) $Pos) (store-ex $New + $J))))) $NewE))) -; - - - - (= - (output (:: $CL)) - ( (mysetof $PN - (^ $H - (^ $B - (^ $R - (, - (member - (= $H $B) $CL) - (=.. $H - (Cons $PN $R)) - (is-newpred $PN))))) $Newpredlist) - (minimize-output $Newpredlist $CL $CL1) - (store-clauses $CL1 rul) - (show-kb))) -; - - - - (= - (minimize_output () $CL $CL) True) -; - - (= - (minimize-output - (Cons $P $R) $CL $CL2) - ( (findall $P1 - (, - (member $P1 $R) - (type-equal $P $P1 - (:: (with_self $P $P1)) $CL)) $P1L) - (replace-t $CL $P1L $P $CL1) - (findall $I - (, - (member $NP $P1L) - (get-example $I $NPP $_) - (=.. $NPP - (Cons $NP $_))) $IDL) - (delete-all $IDL) - (remove-v $P1L $R $R1) - (minimize-output $R1 $CL1 $CL2))) -; + (= (output (:: $CL)) + (mysetof $PN + (^ $H + (^ $B + (^ $R + (, + (member + (= $H $B) $CL) + (=.. $H + (Cons $PN $R)) + (is-newpred $PN))))) $Newpredlist) + (minimize-output $Newpredlist $CL $CL1) + (store-clauses $CL1 rul) + (show-kb)) + + + (= (minimize_output () $CL $CL) True) + (= (minimize-output (Cons $P $R) $CL $CL2) + (findall $P1 + (, + (member $P1 $R) + (type-equal $P $P1 + (:: (with_self $P $P1)) $CL)) $P1L) + (replace-t $CL $P1L $P $CL1) + (findall $I + (, + (member $NP $P1L) + (get-example $I $NPP $_) + (=.. $NPP + (Cons $NP $_))) $IDL) + (delete-all $IDL) + (remove-v $P1L $R $R1) + (minimize-output $R1 $CL1 $CL2)) diff --git a/miles/gencon_instances/rul_ex.metta b/miles/gencon_instances/rul_ex.metta index f731340..4198ac1 100644 --- a/miles/gencon_instances/rul_ex.metta +++ b/miles/gencon_instances/rul_ex.metta @@ -1,1182 +1,119 @@ +; (convert_to_metta_file rul_ex $_255318 miles/gencon_instances/rul_ex.pl miles/gencon_instances/rul_ex.metta) ; -; - +; ;; use init_kb('gilppi_instances/rul_ex.pl',type) for loading ; -; - +; ;; ~~~~~ - (= - (matomic $X) + (= (matomic $X) (atomic $X)) -; - - (= - (matom $X) + (= (matom $X) (atom $X)) -; - - (= - (mnumber $X) + (= (mnumber $X) (number $X)) -; - - - (= - (ex - (t nil) +) True) -; - - (= - (ex - (t - (tree nil 0 nil)) +) True) -; - - (= - (ex - (t - (tree nil 0 - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree nil 0 - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree nil 0 - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree nil 0 - (tree nil - (s - (s - (s 0))) nil))) +) True) -; - - (= - (ex - (t - (tree nil - (s 0) nil)) +) True) -; - - (= - (ex - (t - (tree nil - (s 0) - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree nil - (s 0) - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree nil - (s 0) - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree nil - (s 0) - (tree nil - (s - (s - (s 0))) nil))) +) True) -; - - (= - (ex - (t - (tree nil - (s - (s 0)) nil)) +) True) -; - - (= - (ex - (t - (tree nil - (s - (s 0)) - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree nil - (s - (s 0)) - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree nil - (s - (s 0)) - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree nil - (s - (s 0)) - (tree nil - (s - (s - (s 0))) nil))) +) True) -; - - (= - (ex - (t - (tree nil - (s - (s - (s 0))) nil)) +) True) -; - - (= - (ex - (t - (tree nil - (s - (s - (s 0))) - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree nil - (s - (s - (s 0))) - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree nil - (s - (s - (s 0))) - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree nil - (s - (s - (s 0))) - (tree nil - (s - (s - (s 0))) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) 0 nil)) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) 0 - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) 0 - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) 0 - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) 0 - (tree nil - (s - (s - (s 0))) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) - (s 0) nil)) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) - (s 0) - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) - (s 0) - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) - (s 0) - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) - (s 0) - (tree nil - (s - (s - (s 0))) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) - (s - (s 0)) nil)) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) - (s - (s 0)) - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) - (s - (s 0)) - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) - (s - (s 0)) - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) - (s - (s 0)) - (tree nil - (s - (s - (s 0))) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) - (s - (s - (s 0))) nil)) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) - (s - (s - (s 0))) - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) - (s - (s - (s 0))) - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) - (s - (s - (s 0))) - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil 0 nil) - (s - (s - (s 0))) - (tree nil - (s - (s - (s 0))) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) 0 nil)) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) 0 - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) 0 - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) 0 - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) 0 - (tree nil - (s - (s - (s 0))) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) - (s 0) nil)) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) - (s 0) - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) - (s 0) - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) - (s 0) - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) - (s 0) - (tree nil - (s - (s - (s 0))) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) - (s - (s 0)) nil)) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) - (s - (s 0)) - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) - (s - (s 0)) - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) - (s - (s 0)) - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) - (s - (s 0)) - (tree nil - (s - (s - (s 0))) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) - (s - (s - (s 0))) nil)) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) - (s - (s - (s 0))) - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) - (s - (s - (s 0))) - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) - (s - (s - (s 0))) - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s 0) nil) - (s - (s - (s 0))) - (tree nil - (s - (s - (s 0))) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) 0 nil)) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) 0 - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) 0 - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) 0 - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) 0 - (tree nil - (s - (s - (s 0))) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) - (s 0) nil)) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) - (s 0) - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) - (s 0) - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) - (s 0) - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) - (s 0) - (tree nil - (s - (s - (s 0))) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) - (s - (s 0)) nil)) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) - (s - (s 0)) - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) - (s - (s 0)) - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) - (s - (s 0)) - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) - (s - (s 0)) - (tree nil - (s - (s - (s 0))) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) - (s - (s - (s 0))) nil)) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) - (s - (s - (s 0))) - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) - (s - (s - (s 0))) - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) - (s - (s - (s 0))) - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s 0)) nil) - (s - (s - (s 0))) - (tree nil - (s - (s - (s 0))) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) 0 nil)) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) 0 - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) 0 - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) 0 - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) 0 - (tree nil - (s - (s - (s 0))) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) - (s 0) nil)) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) - (s 0) - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) - (s 0) - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) - (s 0) - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) - (s 0) - (tree nil - (s - (s - (s 0))) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) - (s - (s 0)) nil)) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) - (s - (s 0)) - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) - (s - (s 0)) - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) - (s - (s 0)) - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) - (s - (s 0)) - (tree nil - (s - (s - (s 0))) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) - (s - (s - (s 0))) nil)) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) - (s - (s - (s 0))) - (tree nil 0 nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) - (s - (s - (s 0))) - (tree nil - (s 0) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) - (s - (s - (s 0))) - (tree nil - (s - (s 0)) nil))) +) True) -; - - (= - (ex - (t - (tree - (tree nil - (s - (s - (s 0))) nil) - (s - (s - (s 0))) - (tree nil - (s - (s - (s 0))) nil))) +) True) -; + (= (ex (t nil) +) True) +; /* ex(app([1,2]),'+'). ex(app([a]),'+'). ex(app([]),'+'). ex(app([p]),'+'). ex(app([r,s]),'+'). ex(app([g]),'+'). ex(app([9,8,7]),'+'). ex(app([4,3,5]),'+'). ex(app([r,w]),'+'). ex(app([j,k,l,m]),'+'). ex(split([3]),'+'). ex(split([4]),'+'). ex(split([1,2]),'+'). ex(split([55,66]),'+'). ex(split([7,8,9]),'+'). ex(split([11,12,13]),'+'). ex(split([14,15,16,17]),'+'). ex(split([18,19,20,21]),'+'). ex(split([22,23,24,25,26]),'+'). ex(split([27,28,29,30,31]),'+'). ex(obti([[],0,[]]),'+'). ex(obti([]),'+'). ex(obti([[],2,[]]),'+'). ex(obti([[[],1,[]],2,[[[],3,[]],4,[]]]),'+'). ex(obti([[[],6,[[],7,[]]],8,[[],9,[]]]),'+'). ex(obti([[[],89,[]],90,[[],91,[]]]),'+'). ex(obti([[[],91,[]],92,[[],93,[]]]),'+'). ex(obti([[],50,[[[],51,[]],52,[[],54,[]]]]),'+'). ex(obti([[[[],36,[]],37,[[],39,[]]],46,[]]),'+'). ex(plus(0),'+'). ex(plus(s(0)),'+'). ex(plus(s(s(0))),'+'). ex(plus(s(s(s(s(s(s(0))))))),'+'). ex(plus(s(s(s(0)))),'+'). ex(plus(s(s(s(s(0))))),'+'). ex(equiv(not(and([]))),'+'). ex(equiv(not(and([a]))),'+'). ex(equiv(not(and([b]))),'+'). ex(equiv(not(and([x,y]))),'+'). ex(equiv(not(and([r,s]))),'+'). ex(equiv(not(and([k,l,m]))),'+'). ex(equiv(not(and([kk,ll,mm]))),'+'). ex(equiv(not(and([h,i,j,k]))),'+'). ex(equiv(not(and([hh,ii,jj,kk]))),'+'). ex(equiv(not(and([c,d,e,f,g]))),'+'). ex(equiv(not(and([cc,dd,ee,ff,gg]))),'+'). ex(equiv(not(or([]))),'+'). ex(equiv(not(or([a1]))),'+'). ex(equiv(not(or([b1]))),'+'). ex(equiv(not(or([x1,y1]))),'+'). ex(equiv(not(or([r1,s1]))),'+'). ex(equiv(not(or([k1,l1,m1]))),'+'). ex(equiv(not(or([kk1,ll1,mm1]))),'+'). ex(equiv(not(or([h1,i1,j1,k1]))),'+'). ex(equiv(not(or([hh1,ii1,jj1,kk1]))),'+'). ex(equiv(not(or([c1,d1,e1,f1,g1]))),'+'). ex(equiv(not(or([cc1,dd1,ee1,ff1,gg1]))),'+'). ex(equiv(or([])),'+'). ex(equiv(or([not(a)])),'+'). ex(equiv(or([not(b)])),'+'). ex(equiv(or([not(x),not(y)])),'+'). ex(equiv(or([not(r),not(s)])),'+'). ex(equiv(or([not(k),not(l),not(m)])),'+'). ex(equiv(or([not(kk),not(ll),not(mm)])),'+'). ex(equiv(or([not(h),not(i),not(j),not(k)])),'+'). ex(equiv(or([not(hh),not(ii),not(jj),not(kk)])),'+'). ex(equiv(or([not(c),not(d),not(e),not(f),not(g)])),'+'). ex(equiv(or([not(cc),not(dd),not(ee),not(ff),not(gg)])),'+'). ex(equiv(and([])),'+'). ex(equiv(and([not(a1)])),'+'). ex(equiv(and([not(b1)])),'+'). ex(equiv(and([not(x1),not(y1)])),'+'). ex(equiv(and([not(r1),not(s1)])),'+'). ex(equiv(and([not(k1),not(l1),not(m1)])),'+'). ex(equiv(and([not(kk1),not(ll1),not(mm1)])),'+'). ex(equiv(and([not(h1),not(i1),not(j1),not(k1)])),'+'). ex(equiv(and([not(hh1),not(ii1),not(jj1),not(kk1)])),'+'). ex(equiv(and([not(c1),not(d1),not(e1),not(f1),not(g1)])),'+'). ex(equiv(and([not(cc1),not(dd1),not(ee1),not(ff1),not(gg1)])),'+'). ex(equiv(not(and([]))),'+'). ex(equiv(not(or([]))),'+'). ex(equiv(not(and([a]))),'+'). ex(equiv(not(or([b]))),'+'). ex(equiv(not(and([x,y]))),'+'). ex(equiv(not(or([r,s]))),'+'). ex(equiv(not(and([k,l,m]))),'+'). ex(equiv(not(or([kk,ll,mm]))),'+'). ex(equiv(and([])),'+'). ex(equiv(or([])),'+'). ex(equiv(and([not(a1)])),'+'). ex(equiv(or([not(b1)])),'+'). ex(equiv(and([not(x1),not(y1)])),'+'). ex(equiv(or([not(r1),not(s1)])),'+'). ex(equiv(and([not(k1),not(l1),not(m1)])),'+'). ex(equiv(or([not(kk1),not(ll1),not(mm1)])),'+'). newp4([A|B]):-matom(A),newp4(B). equiv(and(A)):-newp2(A). equiv(not A):-newp3(A). equiv(or(A)):-newp1(A). newp1([]). newp1([not A|B]):-matom(A),newp1(B). newp2([]). newp2([not A|B]):-matom(A),newp1(B). newp3(and(A)):-newp5(A). newp3(or(A)):-newp4(A). newp4([]). newp5([]). newp5([A|B]). ex(t(f(a,f(b,f(c,x)))),'+'). ex(t(f(d,f(e,f(f,f(g,x))))),'+'). ex(t(f(i,f(j,x))),'+'). ex(t(f(h,x)),'+'). ex(t(x),'+'). ex(t(f(k,g(y))),'+'). ex(t(f(m,g(g(y)))),'+'). ex(t(f(n,g(g(g(y))))),'+'). ex(t(f(o,g(g(g(g(y)))))),'+'). ex(t(f(p,y)),'+'). ex(r(x),'+'). ex(r(f(h,x)),'+'). ex(r(f(i,g(j,x))),'+'). ex(r(f(a,g(b,f(c,x)))),'+'). ex(r(f(d,g(e,f(f,g(g,x))))),'+'). ex(r(f(q,g(r,f(s,g(t,f(u,x)))))),'+'). ex(r(f(k,g(l,f(m,g(n,f(o,g(p,x))))))),'+'). ex(r(f(k1,g(l1,f(m1,g(n1,f(o1,g(p1,f(q1,x)))))))),'+'). ex(s(x),'+'). ex(s(f(h,x)),'+'). ex(s(f(g(j,x),g(j,x))),'+'). ex(s(f(g(b,h(c,x)),g(b,h(c,x)))),'+'). ex(s(f(g(e,h(f,f(g,x))),g(e,h(f,f(g,x))))),'+'). ex(s(f(g(r,h(s,f(t,g(u,x)))),g(r,h(s,f(t,g(u,x)))))),'+'). ex(s(f(g(l,h(m,f(n,g(o,h(p,x))))),g(l,h(m,f(n,g(o,h(p,x))))))),'+'). ex(s(f(g(l1,h(m1,f(n1,g(o1,h(p1,f(q1,x)))))),g(l1,h(m1,f(n1,g(o1,h(p1,f(q1,x)))))))),'+'). ex(s(f(g(l1,h(m1,f(n1,g(o1,h(p1,f(q1,g(r1,x))))))), g(l1,h(m1,f(n1,g(o1,h(p1,f(q1,g(r1,x))))))))),'+'). ex(s(f(g(l1,h(m1,f(n1,g(o1,h(p1,f(q1,g(t1,h(u1,x)))))))), g(l1,h(m1,f(n1,g(o1,h(p1,f(q1,g(t1,h(u1,x)))))))))),'+'). ex(s(f(g(l1,h(m1,f(n1,g(o1,h(p1,f(q1,g(v1,h(w1,f(x1,x))))))))), g(l1,h(m1,f(n1,g(o1,h(p1,f(q1,g(v1,h(w1,f(x1,x))))))))))),'+'). ex(i(not(not(and(a,a)))),'+'). ex(i(not(and(not(a),not(a)))),'+'). ex(i(not(and(not(a),and(a,a)))),'+'). ex(i(not(and(and(a,a),not(a)))),'+'). ex(i(not(and(and(a,a),and(a,a)))),'+'). ex(i(not(not(a))),'+'). ex(i(not(and(a,a))),'+'). ex(i(not(a)),'+'). ex(i(not(not(not(a)))),'+'). ex(i(and(not(not(a)),not(a))),'+'). ex(i(and(not(not(a)),and(not(a),not(a)))),'+'). ex(i(and(not(not(a)),and(not(a),and(a,a)))),'+'). ex(i(and(not(not(a)),and(not(a),a))),'+'). ex(i(and(not(and(a,a)),not(not(a)))),'+'). ex(i(and(not(and(a,a)),not(and(a,a)))),'+'). ex(i(and(not(and(a,a)),not(a))),'+'). ex(i(and(not(and(a,a)),and(not(a),not(a)))),'+'). ex(i(and(not(and(a,a)),and(not(a),and(a,a)))),'+'). ex(i(and(not(and(a,a)),and(not(a),a))),'+'). ex(i(and(not(not(a)),and(and(a,a),not(a)))),'+'). ex(i(and(not(not(a)),and(and(a,a),and(a,a)))),'+'). ex(i(and(and(not(a),not(a)),and(a,and(a,a)))),'+'). ex(i(and(and(not(a),not(a)),and(a,a))),'+'). ex(i(and(and(not(a),not(a)),a)),'+'). ex(i(and(and(not(a),and(a,a)),not(not(a)))),'+'). ex(i(and(not(a),not(a))),'+'). ex(i(and(not(a),and(a,a))),'+'). ex(i(and(not(a),a)),'+'). ex(i(and(and(a,a),not(a))),'+'). ex(i(and(and(a,a),and(a,a))),'+'). ex(i(and(and(a,a),a)),'+'). ex(i(and(a,not(a))),'+'). ex(i(and(a,and(a,a))),'+'). ex(i(and(a,a)),'+'). ex(i(a),'+'). */ + (= (ex (t (tree nil 0 nil)) +) True) + (= (ex (t (tree nil 0 (tree nil 0 nil))) +) True) + (= (ex (t (tree nil 0 (tree nil (s 0) nil))) +) True) + (= (ex (t (tree nil 0 (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree nil 0 (tree nil (s (s (s 0))) nil))) +) True) + (= (ex (t (tree nil (s 0) nil)) +) True) + (= (ex (t (tree nil (s 0) (tree nil 0 nil))) +) True) + (= (ex (t (tree nil (s 0) (tree nil (s 0) nil))) +) True) + (= (ex (t (tree nil (s 0) (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree nil (s 0) (tree nil (s (s (s 0))) nil))) +) True) + (= (ex (t (tree nil (s (s 0)) nil)) +) True) + (= (ex (t (tree nil (s (s 0)) (tree nil 0 nil))) +) True) + (= (ex (t (tree nil (s (s 0)) (tree nil (s 0) nil))) +) True) + (= (ex (t (tree nil (s (s 0)) (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree nil (s (s 0)) (tree nil (s (s (s 0))) nil))) +) True) + (= (ex (t (tree nil (s (s (s 0))) nil)) +) True) + (= (ex (t (tree nil (s (s (s 0))) (tree nil 0 nil))) +) True) + (= (ex (t (tree nil (s (s (s 0))) (tree nil (s 0) nil))) +) True) + (= (ex (t (tree nil (s (s (s 0))) (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree nil (s (s (s 0))) (tree nil (s (s (s 0))) nil))) +) True) + (= (ex (t (tree (tree nil 0 nil) 0 nil)) +) True) + (= (ex (t (tree (tree nil 0 nil) 0 (tree nil 0 nil))) +) True) + (= (ex (t (tree (tree nil 0 nil) 0 (tree nil (s 0) nil))) +) True) + (= (ex (t (tree (tree nil 0 nil) 0 (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree (tree nil 0 nil) 0 (tree nil (s (s (s 0))) nil))) +) True) + (= (ex (t (tree (tree nil 0 nil) (s 0) nil)) +) True) + (= (ex (t (tree (tree nil 0 nil) (s 0) (tree nil 0 nil))) +) True) + (= (ex (t (tree (tree nil 0 nil) (s 0) (tree nil (s 0) nil))) +) True) + (= (ex (t (tree (tree nil 0 nil) (s 0) (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree (tree nil 0 nil) (s 0) (tree nil (s (s (s 0))) nil))) +) True) + (= (ex (t (tree (tree nil 0 nil) (s (s 0)) nil)) +) True) + (= (ex (t (tree (tree nil 0 nil) (s (s 0)) (tree nil 0 nil))) +) True) + (= (ex (t (tree (tree nil 0 nil) (s (s 0)) (tree nil (s 0) nil))) +) True) + (= (ex (t (tree (tree nil 0 nil) (s (s 0)) (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree (tree nil 0 nil) (s (s 0)) (tree nil (s (s (s 0))) nil))) +) True) + (= (ex (t (tree (tree nil 0 nil) (s (s (s 0))) nil)) +) True) + (= (ex (t (tree (tree nil 0 nil) (s (s (s 0))) (tree nil 0 nil))) +) True) + (= (ex (t (tree (tree nil 0 nil) (s (s (s 0))) (tree nil (s 0) nil))) +) True) + (= (ex (t (tree (tree nil 0 nil) (s (s (s 0))) (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree (tree nil 0 nil) (s (s (s 0))) (tree nil (s (s (s 0))) nil))) +) True) + (= (ex (t (tree (tree nil (s 0) nil) 0 nil)) +) True) + (= (ex (t (tree (tree nil (s 0) nil) 0 (tree nil 0 nil))) +) True) + (= (ex (t (tree (tree nil (s 0) nil) 0 (tree nil (s 0) nil))) +) True) + (= (ex (t (tree (tree nil (s 0) nil) 0 (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree (tree nil (s 0) nil) 0 (tree nil (s (s (s 0))) nil))) +) True) + (= (ex (t (tree (tree nil (s 0) nil) (s 0) nil)) +) True) + (= (ex (t (tree (tree nil (s 0) nil) (s 0) (tree nil 0 nil))) +) True) + (= (ex (t (tree (tree nil (s 0) nil) (s 0) (tree nil (s 0) nil))) +) True) + (= (ex (t (tree (tree nil (s 0) nil) (s 0) (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree (tree nil (s 0) nil) (s 0) (tree nil (s (s (s 0))) nil))) +) True) + (= (ex (t (tree (tree nil (s 0) nil) (s (s 0)) nil)) +) True) + (= (ex (t (tree (tree nil (s 0) nil) (s (s 0)) (tree nil 0 nil))) +) True) + (= (ex (t (tree (tree nil (s 0) nil) (s (s 0)) (tree nil (s 0) nil))) +) True) + (= (ex (t (tree (tree nil (s 0) nil) (s (s 0)) (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree (tree nil (s 0) nil) (s (s 0)) (tree nil (s (s (s 0))) nil))) +) True) + (= (ex (t (tree (tree nil (s 0) nil) (s (s (s 0))) nil)) +) True) + (= (ex (t (tree (tree nil (s 0) nil) (s (s (s 0))) (tree nil 0 nil))) +) True) + (= (ex (t (tree (tree nil (s 0) nil) (s (s (s 0))) (tree nil (s 0) nil))) +) True) + (= (ex (t (tree (tree nil (s 0) nil) (s (s (s 0))) (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree (tree nil (s 0) nil) (s (s (s 0))) (tree nil (s (s (s 0))) nil))) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) 0 nil)) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) 0 (tree nil 0 nil))) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) 0 (tree nil (s 0) nil))) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) 0 (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) 0 (tree nil (s (s (s 0))) nil))) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) (s 0) nil)) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) (s 0) (tree nil 0 nil))) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) (s 0) (tree nil (s 0) nil))) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) (s 0) (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) (s 0) (tree nil (s (s (s 0))) nil))) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) (s (s 0)) nil)) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) (s (s 0)) (tree nil 0 nil))) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) (s (s 0)) (tree nil (s 0) nil))) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) (s (s 0)) (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) (s (s 0)) (tree nil (s (s (s 0))) nil))) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) (s (s (s 0))) nil)) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) (s (s (s 0))) (tree nil 0 nil))) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) (s (s (s 0))) (tree nil (s 0) nil))) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) (s (s (s 0))) (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree (tree nil (s (s 0)) nil) (s (s (s 0))) (tree nil (s (s (s 0))) nil))) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) 0 nil)) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) 0 (tree nil 0 nil))) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) 0 (tree nil (s 0) nil))) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) 0 (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) 0 (tree nil (s (s (s 0))) nil))) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) (s 0) nil)) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) (s 0) (tree nil 0 nil))) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) (s 0) (tree nil (s 0) nil))) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) (s 0) (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) (s 0) (tree nil (s (s (s 0))) nil))) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) (s (s 0)) nil)) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) (s (s 0)) (tree nil 0 nil))) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) (s (s 0)) (tree nil (s 0) nil))) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) (s (s 0)) (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) (s (s 0)) (tree nil (s (s (s 0))) nil))) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) (s (s (s 0))) nil)) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) (s (s (s 0))) (tree nil 0 nil))) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) (s (s (s 0))) (tree nil (s 0) nil))) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) (s (s (s 0))) (tree nil (s (s 0)) nil))) +) True) + (= (ex (t (tree (tree nil (s (s (s 0))) nil) (s (s (s 0))) (tree nil (s (s (s 0))) nil))) +) True) diff --git a/miles/interpreter.metta b/miles/interpreter.metta index 1e8a7ea..48b0a1a 100644 --- a/miles/interpreter.metta +++ b/miles/interpreter.metta @@ -1,7 +1,7 @@ +; (convert_to_metta_file interpreter $_170804 miles/interpreter.pl miles/interpreter.metta) ; -; - +; MODULE interpreter EXPORTS !(module interpreter (:: @@ -19,19 +19,14 @@ (/ t-interpreter 2) (/ ip-part1 2) (/ ip-part2 3))) -; - ; -; - +; IMPORTS !(use-module (home kb) (:: (/ get-clause 5) (/ interpretable-predicate 1))) -; - !(use-module (home div-utils) (:: @@ -39,354 +34,228 @@ (/ identical-member 2) (/ append-all 2) (/ mysetof 3))) -; - !(use-module (home bu-basics) (:: (/ head 3) (/ body 3) (/ assumption 3))) -; - !(use-module (home environment) (:: (/ satisfiable 1))) -; - !(use-module-if-exists (library basics) (:: (/ member 2))) -; - !(use-module-if-exists (library unify) (:: (/ unify 2))) -; - ; -; - +; METAPREDICATES ; -; +; none - - !(dynamic (, (/ failed-proof 1) (/ tag 1) (/ prooftrees 3) (/ depth-bound 1) (/ depth-exceeded 0) (/ depth-exceeded 3))) -; - + !(dynamic (, (/ failed-proof 1) (/ tag 1) (/ prooftrees 3) (/ depth-bound 1) (/ depth-exceeded 0) (/ depth-exceeded 3))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: interpreter.pl ; -; - +; * ; -; - +; * author: B.Jung, M.Mueller, I.Stahl, B.Tausend date:12/92 ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * description: different interpreters working on the knowledge base ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: ip_part1/2 ; -; - +; * ; -; - +; * syntax: ip_part1(+Goal,-Proof) ; -; - +; * ; -; - +; * args: Goal: an uncovered positive example ; -; - +; * Proof: a failing proof for the positive example ; -; - +; * ; -; - +; * description: works exactly as the general interpreter solve0/2. The only ; -; - +; * difference is that instead of failing when a system goal is failing ; -; - +; * or a proof is looping or rules are missing, the interpreter ; -; - +; * continues, assuming that the failing goals should be correct ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (ip-part1 $Goal $Proof) - ( (remove-all-symbols &self + (= (ip-part1 $Goal $Proof) + ( (remove-all-atoms &self (tag $_)) - (add-symbol &self + (add-is-symbol &self (tag $Goal)) (gen-depth $D $Delta) (ipp1 $Goal $D $Delta $Proof $Proof Nil))) -; - - (= - (ipp1 True $D $Delta $Proof $Poi $_) - ( (set-det) (= $Poi Nil))) -; - + (= (ipp1 True $D $Delta $Proof $Poi $_) + (set-det) + (= $Poi Nil)) - (= - (ipp1 no-rule $_ $_ $_ $_ $_) + (= (ipp1 no-rule $_ $_ $_ $_ $_) (set-det)) -; - - - (= - (ipp1 - (, $A $B) $D $Delta $Proof $Poi $Ancestors) - ( (set-det) - (= $Poi - (Cons $PoiA $PoiB)) - (ipp1 $A $D $Delta $Proof - (:: $PoiA) $Ancestors) - (ipp1 $B $D $Delta $Proof $PoiB $Ancestors))) -; + (= (ipp1 (, $A $B) $D $Delta $Proof $Poi $Ancestors) + (set-det) + (= $Poi + (Cons $PoiA $PoiB)) + (ipp1 $A $D $Delta $Proof + (:: $PoiA) $Ancestors) + (ipp1 $B $D $Delta $Proof $PoiB $Ancestors)) - (= - (ipp1 $A $D $Delta $Proof $Poi $Ancestors) - ( (interpretable-predicate $A) - (set-det) - (det-if-then-else - (> $D 0) True - (, - (add-symbol &self - (tag $A)) - (fail))) - (det-if-then-else - (identical-member $A $Ancestors) + (= (ipp1 $A $D $Delta $Proof $Poi $Ancestors) + (interpretable-predicate $A) + (set-det) + (det-if-then-else + (> $D 0) True + (, + (add-is-symbol &self + (tag $A)) + (fail))) + (det-if-then-else + (identical-member $A $Ancestors) + (= $Poi + (:: (:: -1 $A looping))) + (, + (is $D1 + (- $D 1)) + (ipp1-rule $D $Delta $Proof $Poi $I $A $B) (= $Poi - (:: (:: -1 $A looping))) - (, - (is $D1 - (- $D 1)) - (ipp1-rule $D $Delta $Proof $Poi $I $A $B) - (= $Poi - (:: (:: $I $A $PoiB))) - (ipp1 $B $D1 $Delta $Proof $PoiB - (Cons $A $Ancestors)))))) -; + (:: (:: $I $A $PoiB))) + (ipp1 $B $D1 $Delta $Proof $PoiB + (Cons $A $Ancestors))))) - - (= - (ipp1 $A $D $Delta $Proof $Poi $_) + (= (ipp1 $A $D $Delta $Proof $Poi $_) (det-if-then-else (call $A) (= $Poi (:: (:: sys $A Nil))) (= $Poi (:: (:: sys $A fail))))) -; - - (= - (ipp1-rule $_ $_ $_ $_ $I $A $B) + (= (ipp1-rule $_ $_ $_ $_ $I $A $B) (get-clause $I $A $B $_ $_)) -; - - (= - (ipp1-rule $D $Delta $Proof $Poi $_ $A no-rule) + (= (ipp1-rule $D $Delta $Proof $Poi $_ $A no-rule) (det-if-then-else (get-clause $_ $A $_ $_ $_) fail (= $Poi (:: (:: -1 $A no-rules))))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: ip_part2/3 ; -; - +; * ; -; - +; * syntax: ip_part2(+Proofs,+Goal,-Uncovered_Atoms) ; -; - +; * ; -; - +; * args: Proofs: failing proofs determined by ip_part1, ; -; - +; * Goal: uncovered positive example Uncovered_Atoms: Atoms that make ; -; - +; * Goal succeed, if they were covered by the kb ; -; - +; * ; -; - +; * description: the satisfiability of each subgoal within failing proof is ; -; - +; * determined. For that, the oracle might be necessary. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (ip-part2 - (Cons $P $_) $Goal $UA) + (= (ip-part2 (Cons $P $_) $Goal $UA) (ipp2 $P Nil Nil $UA)) -; - - (= - (ip-part2 - (Cons $_ $R) $Goal $UA) + (= (ip-part2 (Cons $_ $R) $Goal $UA) (ip-part2 $R $Goal $UA)) -; - - (= - (ipp2 - (:: $I $H looping) $_ $L - (Cons - (with_self $I $H) $L)) + (= (ipp2 (:: $I $H looping) $_ $L (Cons (with_self $I $H) $L)) (set-det)) -; - - (= - (ipp2 - (:: sys $_ fail) - (Cons - (with_self $I $A) $_) $L - (Cons - (with_self $I $A) $L)) + (= (ipp2 (:: sys $_ fail) (Cons (with_self $I $A) $_) $L (Cons (with_self $I $A) $L)) (set-det)) -; - - (= - (ipp2 - (:: $_ $_ Nil) $_ $L $L) + (= (ipp2 (:: $_ $_ Nil) $_ $L $L) (set-det)) -; - - (= - (ipp2 - (:: $_ $H no-rules) $_ $L - (Cons - (with_self -1 $H) $L)) + (= (ipp2 (:: $_ $H no-rules) $_ $L (Cons (with_self -1 $H) $L)) (set-det)) -; - - (= - (ipp2 - (:: $I $H $SG) $Ancestors $L $L1) + (= (ipp2 (:: $I $H $SG) $Ancestors $L $L1) (det-if-then-else (satisfiable $SG) (ipp2-list $SG @@ -395,643 +264,448 @@ (= $L1 (Cons (with_self $I $H) $L)))) -; - - (= - (ipp2_list () $_ $L $L) True) -; - - (= - (ipp2-list - (Cons $G $R) $A $L $L2) - ( (ipp2 $G $A $L $L1) (ipp2-list $R $A $L1 $L2))) -; - + (= (ipp2_list () $_ $L $L) True) + (= (ipp2-list (Cons $G $R) $A $L $L2) + (ipp2 $G $A $L $L1) + (ipp2-list $R $A $L1 $L2)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: proof_path/4 ; -; - +; * ; -; - +; * syntax: proof_path(+Ex,+Pred,+Type,-ClauseIDs) ; -; - +; * ; -; - +; * args: Ex: example for p/n ; -; - +; * Pred = p(X1,..,Xn): most general term of p/n ; -; - +; * Type = typei(Xi) for an argument of p/n ; -; - +; * ClauseIDs: list of clauseIDs that have beed used for proving ; -; - +; * typei(ei) for the ith argument of Ex ; -; - +; * ; -; - +; * description: simulates the proof of typei(ei) for the ith argument of Ex ; -; - +; * and collects the indices of all used clauses ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** + (= (proof-path $Ex $P $T $Ts) + (copy-term + (, $P $T) + (, $Ex $T0)) + (proof-path $T0 Nil $Ts)) - (= - (proof-path $Ex $P $T $Ts) - ( (copy-term - (, $P $T) - (, $Ex $T0)) (proof-path $T0 Nil $Ts))) -; - - - (= - (proof-path True $T $T) + (= (proof-path True $T $T) + (set-det)) + (= (proof-path (, $A $B) $T $T2) + (set-det) + (proof-path $A $T $T1) + (proof-path $B $T1 $T2)) + + (= (proof-path $A $T $T) + (=.. $A + (Cons all $_)) (set-det)) -; - - (= - (proof-path - (, $A $B) $T $T2) - ( (set-det) - (proof-path $A $T $T1) - (proof-path $B $T1 $T2))) -; - - - (= - (proof-path $A $T $T) - ( (=.. $A - (Cons all $_)) (set-det))) -; - - (= - (proof-path $A $T $T) - ( (=.. $A - (Cons $T1 $_)) + (= (proof-path $A $T $T) + (=.. $A + (Cons $T1 $_)) + (or + (= $T1 is-symbol) (or - (= $T1 is-symbol) - (or - (= $T1 symbolic) - (= $T1 number))) - (set-det) - (call $A))) -; - - - (= - (proof-path $A $T $T1) - ( (get-clause $I $A $B $_ type) - (proof-path $B $T $T0) - (insert-unique $I $T0 $T1))) -; + (= $T1 symbolic) + (= $T1 number))) + (set-det) + (call $A)) + (= (proof-path $A $T $T1) + (get-clause $I $A $B $_ type) + (proof-path $B $T $T0) + (insert-unique $I $T0 $T1)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: t_interpreter/2 ; -; - +; * ; -; - +; * syntax: t_interpreter(+Goal,+ClauseList) ; -; - +; * ; -; - +; * args: Goal: goal type(Arg), Arg ground ; -; - +; * ClauseList: List of clauses defining different types ; -; - +; * ; -; - +; * description: proves type(Arg) from ClauseList as kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (t-interpreter True $_) + (= (t-interpreter True $_) (set-det)) -; - - (= - (t-interpreter - (, $A $B) $CL) - ( (set-det) - (t-interpreter $A $CL) - (t-interpreter $B $CL))) -; - - (= - (t-interpreter $C $_) - ( (=.. $C - (Cons $P $_)) + (= (t-interpreter (, $A $B) $CL) + (set-det) + (t-interpreter $A $CL) + (t-interpreter $B $CL)) + (= (t-interpreter $C $_) + (=.. $C + (Cons $P $_)) + (or + (= $P is-symbol) (or - (= $P is-symbol) - (or - (= $P number) - (= $P symbolic))) - (set-det) - (call $C))) -; - - (= - (t-interpreter $C $CL) - ( (copy-term $CL $CL1) - (member - (= $C $B) $CL1) - (t-interpreter $B $CL))) -; - + (= $P number) + (= $P symbolic))) + (set-det) + (call $C)) + (= (t-interpreter $C $CL) + (copy-term $CL $CL1) + (member + (= $C $B) $CL1) + (t-interpreter $B $CL)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: solve/3 ; -; - +; * ; -; - +; * syntax: solve(+Goal,-Mark,-Proofs) ; -; - +; * ; -; - +; * args: Goal: ground atom or rule with ground head ; -; - +; * Mark: success or fail ; -; - +; * Proofs: all succeeding/failing proofs according to Mark ; -; - +; * ; -; - +; * description: format for Proofs: [P1,..,Pn] ; -; - +; * where Pi = [ID,Head,PBody] where ID is the ID of the ; -; - +; * applied rule (sys for system predicates, -1 if no rule ; -; - +; * is applicable), Head is the instantiation of the rule head, ; -; - +; * and PBody is the proof of the rule body. PBody is of the form ; -; - +; * - [], if Head is true ; -; - +; * - fail, if Head is a failing syspred ; -; - +; * - looping if the proof is looping on Head ; -; - +; * - no_rules if no rules match Head ; -; - +; * - depth_exceeded if the proof fails because of depth bound ; -; - +; * Maximum depth for proofs: 50 ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ************************************************************************ - (= - (solve - (= $H $B) $Mark $Proofs) + (= (solve (= $H $B) $Mark $Proofs) (det-if-then-else (ground $H) (solve $B $Mark $Proofs) (, (set-det) (fail)))) -; - - - (= - (solve $Goal $Mark $Proofs) - ( (det-if-then-else - (setof $Proof - (^ $Goal - (solve0 $Goal $Proof)) $Proofs0) - (= $Mark success) - (, - (bagof $FProof - (failed-proof $FProof) $Proofs00) - (= $Mark fail) - (det-if-then-else depth-exceeded - (, - (setof $EProof - (^ $A - (depth-exceeded $A $EProof - (:: (:: -1 $A depth-exceeded)))) $EProofs0) - (append $EProofs0 $Proofs00 $Proofs0)) - (= $Proofs0 $Proofs00)))) - (append-all $Proofs0 $Proofs1) - (proof-close $Proofs1 $Proofs))) -; + (= (solve $Goal $Mark $Proofs) + (det-if-then-else + (setof $Proof + (^ $Goal + (solve0 $Goal $Proof)) $Proofs0) + (= $Mark success) + (, + (bagof $FProof + (failed-proof $FProof) $Proofs00) + (= $Mark fail) + (det-if-then-else depth-exceeded + (, + (setof $EProof + (^ $A + (depth-exceeded $A $EProof + (:: (:: -1 $A depth-exceeded)))) $EProofs0) + (append $EProofs0 $Proofs00 $Proofs0)) + (= $Proofs0 $Proofs00)))) + (append-all $Proofs0 $Proofs1) + (proof-close $Proofs1 $Proofs)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: solve_once/3 ; -; - +; * ; -; - +; * syntax: solve_once(+Goal,-Mark,-Proof) ; -; - +; * ; -; - +; * args: as solve/3 ; -; - +; * ; -; - +; * description: proves Goal only once ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (solve-once - (= $H $B) $Mark $Proofs) + (= (solve-once (= $H $B) $Mark $Proofs) (det-if-then-else (ground $H) (solve-once $B $Mark $Proofs) (, (set-det) (fail)))) -; - - - (= - (solve-once $Goal $Mark $Proofs) - ( (det-if-then-else - (solve0 $Goal $Proof) - (, - (= $Proofs0 - (:: $Proof)) - (= $Mark success)) - (, - (bagof $FProof - (failed-proof $FProof) $Proofs0) - (= $Mark fail))) - (append-all $Proofs0 $Proofs1) - (proof-close $Proofs1 $Proofs))) -; + (= (solve-once $Goal $Mark $Proofs) + (det-if-then-else + (solve0 $Goal $Proof) + (, + (= $Proofs0 + (:: $Proof)) + (= $Mark success)) + (, + (bagof $FProof + (failed-proof $FProof) $Proofs0) + (= $Mark fail))) + (append-all $Proofs0 $Proofs1) + (proof-close $Proofs1 $Proofs)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: proof_close/2 ; -; - +; * ; -; - +; * syntax: proof_close(+Proofs,-Proofs) ; -; - +; * ; -; - +; * args: Proofs as for solve/3 ; -; - +; * ; -; - +; * description: closes the open lists in Proofs ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (proof-close $X Nil) - ( (var $X) (set-det))) -; - - (= - (proof-close - (Cons - (:: $J $H $B1) $R1) - (Cons - (:: $J $H $B2) $R2)) - ( (proof-close $B1 $B2) (proof-close $R1 $R2))) -; +; *********************************************************************** - (= - (proof-close $X $X) - ( (atomic $X) (set-det))) -; + (= (proof-close $X Nil) + (var $X) + (set-det)) + (= (proof-close (Cons (:: $J $H $B1) $R1) (Cons (:: $J $H $B2) $R2)) + (proof-close $B1 $B2) + (proof-close $R1 $R2)) + (= (proof-close $X $X) + (atomic $X) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: solve0/2 ; -; - +; * ; -; - +; * syntax: solve0(+Goal,-Proof) ; -; - +; * ; -; - +; * args: Goal: ground atom, Proof: one possible proof for Goal ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (solve0 $Goal $Proof) - ( (remove-all-symbols &self + (= (solve0 $Goal $Proof) + ( (remove-all-atoms &self (tag $_)) - (remove-all-symbols &self + (remove-all-atoms &self (failed_proof $_)) - (remove-all-symbols &self + (remove-all-atoms &self (depth_exceeded $_ $_ $_)) - (remove-all-symbols &self depth_exceeded) + (remove-all-atoms &self depth_exceeded) (gen-depth $D $Delta) (solve2 $Goal $D $Delta $Proof $Proof Nil))) -; - - (= - (solve2 True $_ $_ $_ Nil $_) + (= (solve2 True $_ $_ $_ Nil $_) (set-det)) -; - - (= - (solve2 - (, $A $B) $D $Delta $Proof $Poi $Ancestors) - ( (set-det) - (= $Poi - (Cons $PoiA $PoiB)) - (solve2 $A $D $Delta $Proof - (:: $PoiA) $Ancestors) - (solve2 $B $D $Delta $Proof $PoiB $Ancestors))) -; - + (= (solve2 (, $A $B) $D $Delta $Proof $Poi $Ancestors) + (set-det) + (= $Poi + (Cons $PoiA $PoiB)) + (solve2 $A $D $Delta $Proof + (:: $PoiA) $Ancestors) + (solve2 $B $D $Delta $Proof $PoiB $Ancestors)) - (= - (solve2 $A $D $Delta $Proof $Poi $Ancestors) - ( (interpretable-predicate $A) - (set-det) + (= (solve2 $A $D $Delta $Proof $Poi $Ancestors) + (interpretable-predicate $A) + (set-det) + (det-if-then-else + (= $D 0) + (, + (add-is-symbol &self + (tag $A)) + (add-is-symbol &self + (depth_exceeded $A $Proof $Poi)) + (fail)) (det-if-then-else - (= $D 0) + (identical-member $A $Ancestors) (, - (add-symbol &self - (tag $A)) - (add-symbol &self - (depth_exceeded $A $Proof $Poi)) + (= $Poi + (:: (:: -1 $A looping))) + (det-if-then-else + (< $D $Delta) + (add-is-symbol &self + (failed_proof $Proof)) True) (fail)) - (det-if-then-else - (identical-member $A $Ancestors) - (, - (= $Poi - (:: (:: -1 $A looping))) - (det-if-then-else - (< $D $Delta) - (add-symbol &self - (failed_proof $Proof)) True) - (fail)) - (, - (is $D1 - (- $D 1)) - (solve-rule $D1 $Delta $Proof $Poi $I $A $B) - (= $Poi - (:: (:: $I $A $PoiB))) - (solve2 $B $D1 $Delta $Proof $PoiB - (Cons $A $Ancestors))))))) -; - - - (= - (solve2 $A $D $Delta $Proof $Poi $_) + (, + (is $D1 + (- $D 1)) + (solve-rule $D1 $Delta $Proof $Poi $I $A $B) + (= $Poi + (:: (:: $I $A $PoiB))) + (solve2 $B $D1 $Delta $Proof $PoiB + (Cons $A $Ancestors)))))) +; ; A is in KB + + (= (solve2 $A $D $Delta $Proof $Poi $_) (det-if-then-else (, (predicate-property $A built-in) @@ -1044,186 +718,142 @@ (:: (:: sys $A fail))) (det-if-then-else (< $D $Delta) - (add-symbol &self + (add-is-symbol &self (failed_proof $Proof)) True) (fail)))) -; - +; ; A is built-in +; ; exception handling - (= - (solve2 $A $D $D $Proof $Poi $_) + (= (solve2 $A $D $D $Proof $Poi $_) ( (not depth-exceeded) (= $Poi (:: (:: -1 $A no-rules))) - (add-symbol &self + (add-is-symbol &self (failed_proof $Proof)) (fail))) -; - +; ; no rules at all for initial goal ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: solve_rule/7 ; -; - +; * ; -; - +; * syntax: solve_rule(+D,+Delta,+Proof,+Proof_Poi,-ID,+Goal,-Body) ; -; - +; * ; -; - +; * args: D,Delta: depth bounds for iterative deepening ; -; - +; * Proof,Proof_Poi: intermediate Proof of the toplevel goal (open list) ; -; - +; * Goal: current goal ; -; - +; * ID,Body: id and body of a kb-rule matchin Goal (if any) ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (solve-rule $_ $_ $_ $_ $I $A $B) - ( (functor $A $F $N) - (functor $A1 $F $N) - (get-clause $I $A1 $B $_ $_) - (unify $A $A1))) -; - - (= - (solve-rule $D $Delta $Proof $Poi $_ $A $_) - ( (= $Poi - (:: (:: -1 $A no-more-rules))) - (det-if-then-else - (< $D $Delta) - (add-symbol &self - (failed_proof $Proof)) True) - (fail))) -; - + (= (solve-rule $_ $_ $_ $_ $I $A $B) + (functor $A $F $N) + (functor $A1 $F $N) + (get-clause $I $A1 $B $_ $_) + (unify $A $A1)) + (= (solve-rule $D $Delta $Proof $Poi $_ $A $_) + (= $Poi + (:: (:: -1 $A no-more-rules))) + (det-if-then-else + (< $D $Delta) + (add-is-symbol &self + (failed_proof $Proof)) True) + (fail)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: gen_depth/2 ; -; - +; * ; -; - +; * syntax: gen_depth(D, Delta) ; -; - +; * ; -; - +; * args: D,Delta: integers ; -; - +; * ; -; - +; * description: generates depth bound for the interative deepening ; -; - +; * theorem prover. Delta is the difference between D and ; -; - +; * the former depth (not to create duplicate proofs) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (gen-depth $D $Delta) - ( (depth-bound $N) (det-if-then-else (number $N) (det-if-then-else (>= $N 3) (gen-depth 3 $D 3 $Delta) (gen-depth $N $D $N $Delta)) (gen-depth 3 $D 3 $Delta)))) -; - + (= (gen-depth $D $Delta) + (depth-bound $N) + (det-if-then-else + (number $N) + (det-if-then-else + (>= $N 3) + (gen-depth 3 $D 3 $Delta) + (gen-depth $N $D $N $Delta)) + (gen-depth 3 $D 3 $Delta))) +; /***** gen_depth without maximum depth***** gen_depth(D, Delta) :- gen_depth(3, 100, D, Delta). gen_depth(D, Delta, D, Delta). gen_depth(D0, _, D, Delta) :- Delta1 is D0 div 2 + 1, D1 is D0 + Delta1, ( tag(_) -> retractall(tag(_)), gen_depth(D1, Delta1, D, Delta) ; fail ). *******/ +; ; D = new depth for proofs +; ; Delta = new D - former D - (= - (gen_depth $D $D $Delta $Delta) True) -; - + (= (gen_depth $D $D $Delta $Delta) True) - (= - (gen-depth $D0 $D $_ $Delta) + (= (gen-depth $D0 $D $_ $Delta) (det-if-then-else (tag $_) (, - (remove-all-symbols &self + (remove-all-atoms &self (tag $_)) (is $Delta1 (+ @@ -1235,102 +865,74 @@ (number $Max) (det-if-then-else (=< $D1 $Max) - (remove-all-symbols &self + (remove-all-atoms &self (depth_exceeded $_ $_ $_)) (, - (add-symbol &self depth_exceeded) + (add-is-symbol &self depth_exceeded) (fail))) True) (gen-depth $D1 $D $Delta1 $Delta)) fail)) -; - - (= - (set-proof-depth) + (= (set-proof-depth) ( (nl) (nl) (write 'Speficy maximum depth for theorem prover (number or n for unbound proofs): ') (read $N) - (remove-all-symbols &self + (remove-all-atoms &self (depth_bound $_)) - (add-symbol &self + (add-is-symbol &self (depth_bound $N)))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: prove1/2 ; -; - +; * ; -; - +; * syntax: prove1(+Clause, -Proof) ; -; - +; * ; -; - +; * args: Clause: clause in list form ( [H:p,L1:n,L2:n,..]) ; -; - +; * Proof: list of all literals used to prove clause ; -; - +; * ; -; - +; * description: ; -; - +; * prove1 tries to match Clause against literals in this kb, ; -; - +; * use for clause reduction wrt theta-subsumption (Plotkin). ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: Buntine,1988. Plotkin,1970. ; -; - +; * ; -; - +; *********************************************************************** - (= - (prove1 $CL $SProof) - ( (ini-prove1 $CL $CL1) (prove1a $CL1 Nil $SProof))) -; + (= (prove1 $CL $SProof) + (ini-prove1 $CL $CL1) + (prove1a $CL1 Nil $SProof)) +; /* prove1([H|T],Proof):- prove1(H,HProof), prove1(T,TProof), append(HProof,TProof,Proof). prove1([],[]). prove1(L:S,[L:S]):- member(S,[n,r]), body(L,_O,_I). prove1(L:p,[L:p]):- head(L,_O,_I). */ +; ;*********************************************************************** ;* ;* predicate: prove1/2 ;* ;* syntax: prove1(+Clause, -Proof) ;* ;* args: Clause: clause in list form ( [H:p,L1:n,L2:n,..]) ;* Proof: list of all literals used to prove clause ;* ;* description: ;* prove1 tries to match Clause against literals in this kb, ;* use for clause reduction wrt theta-subsumption (Plotkin). ;* This is a more efficient version for embedding Clause in the kb: ;* (IRENE) ;* a list CL1 = [Lit:Sign:Litlist|_] is constructed from Clause ;* where Litlist is the list of literals in the kb (if Sign = p, literals ;* head(L,_,_), else body(L,_,_)) unifiable with Lit. CL1 is sorted ;* ascendingly according to the length of Litlist. If there is an ;* empty Litlist in CL1, prove1a fails and backtracking occurs. ;* Else Lit is unified with a literal in Litlist (backtracking point), ;* and the remaining list CL1 is updated. ;* ;* example: ;* ;* peculiarities: ;* ;* see also: Buntine,1988. Plotkin,1970. ;* ;*********************************************************************** - - (= - (prove1a () $SP $SP) True) -; - + (= (prove1a () $SP $SP) True) ; (error ; (syntax_error operator_clash) ; (file miles/interpreter.pl 618 26 17908)) @@ -1341,10 +943,7 @@ - (= - (ini_prove1 () ()) True) -; - + (= (ini_prove1 () ()) True) ; (error ; (syntax_error operator_clash) ; (file miles/interpreter.pl 634 20 18344)) @@ -1355,17 +954,10 @@ ; (file miles/interpreter.pl 636 16 18376)) - (= - (insert_prove1 $X $L - (Cons $X $L)) True) -; - + (= (insert_prove1 $X $L (Cons $X $L)) True) - (= - (adapt_prove1 () $_ $_ ()) True) -; - + (= (adapt_prove1 () $_ $_ ()) True) ; (error ; (syntax_error operator_clash) ; (file miles/interpreter.pl 643 18 18567)) @@ -1377,309 +969,179 @@ ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: prove3/2 ; -; - +; * ; -; - +; * syntax: prove3(+CL,-CL) ; -; - +; * ; -; - +; * args: CL: clause body in list notation ; -; - +; * ; -; - +; * description: embedd CL in skolemized body of an example clause ; -; - +; * (body/3 entries in the kb) ; -; - +; * used for absorption, saturation ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (prove3 - (Cons $A $B) - (Cons $ProofA $ProofB)) - ( (prove3 $A $ProofA) (prove3 $B $ProofB))) -; - (= - (prove3 () ()) True) -; + (= (prove3 (Cons $A $B) (Cons $ProofA $ProofB)) + (prove3 $A $ProofA) + (prove3 $B $ProofB)) + (= (prove3 () ()) True) - - (= - (prove3 - (with_self $A - (n)) - (with_self $A - (n))) + (= (prove3 (with_self $A (n)) (with_self $A (n))) (body $A $_ $_)) -; - - (= - (prove3 - (with_self $A - (r)) - (with_self $A - (r))) + (= (prove3 (with_self $A (r)) (with_self $A (r))) (body $A $_ $_)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: prove4/3 ; -; - +; * ; -; - +; * syntax: prove4(+CL,-Uncovered,-Proof) ; -; - +; * ; -; - +; * args: CL: clause in list notation ; -; - +; * Uncovered = H/M, where M in {new_head,new_body} ; -; - +; * or Uncovered = [] if all literals are covered ; -; - +; * Proof = [[Lit,N],...] where N in {head,body} ; -; - +; * ; -; - +; * description: embeds CL in skolemized example clause (head/3,body/3 entries) ; -; - +; * allows 1 uncovered literal (= the resolution literal) & returns it ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (prove4 - (Cons $H $More) $Uncovered - (Cons $ProofH $ProofRest)) - ( (prove4 $H $Uncovered $ProofH) (prove4 $More $Uncovered $ProofRest))) -; + (= (prove4 (Cons $H $More) $Uncovered (Cons $ProofH $ProofRest)) + (prove4 $H $Uncovered $ProofH) + (prove4 $More $Uncovered $ProofRest)) - - (= - (prove4 Nil Nil Nil) + (= (prove4 Nil Nil Nil) (set-det)) -; - - (= - (prove4 Nil $_ Nil) + (= (prove4 Nil $_ Nil) (set-det)) -; - - (= - (prove4 - (with_self $H - (n)) $_ - (:: $H body)) + (= (prove4 (with_self $H (n)) $_ (:: $H body)) (body $H $_ $_)) -; - - (= - (prove4 - (with_self $H - (r)) $_ - (:: $H body)) + (= (prove4 (with_self $H (r)) $_ (:: $H body)) (body $H $_ $_)) -; - - (= - (prove4 - (with_self $H - (p)) $_ - (:: $H head)) + (= (prove4 (with_self $H (p)) $_ (:: $H head)) (head $H $_ $_)) -; - - (= - (prove4 - (with_self $H - (n)) $Uncovered Nil) - ( (var $Uncovered) (= $Uncovered (/ $H new-head)))) -; - - (= - (prove4 - (with_self $H - (r)) $Uncovered Nil) - ( (var $Uncovered) (= $Uncovered (/ $H new-head)))) -; - - (= - (prove4 - (with_self $H - (p)) $Uncovered Nil) - ( (var $Uncovered) (= $Uncovered (/ $H new-body)))) -; - + (= (prove4 (with_self $H (n)) $Uncovered Nil) + (var $Uncovered) + (= $Uncovered + (/ $H new-head))) + (= (prove4 (with_self $H (r)) $Uncovered Nil) + (var $Uncovered) + (= $Uncovered + (/ $H new-head))) + (= (prove4 (with_self $H (p)) $Uncovered Nil) + (var $Uncovered) + (= $Uncovered + (/ $H new-body))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: prove5/2 ; -; - +; * ; -; - +; * syntax: prove5(+HS,+RuleIDs) ; -; - +; * ; -; - +; * args: HS: skolemized clause head, RuleIDs: list of ruleIDs ; -; - +; * ; -; - +; * description: tries to infer HS from assumptions and the rules in ; -; - +; * RuleIDs ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (prove5 $H $_) + (= (prove5 $H $_) (assumption $H $_ $_)) -; - - (= - (prove5 true $_) True) -; - - (= - (prove5 $H $RULES) - ( (get-clause $ID $H True $_ $_) (member $ID $RULES))) -; - - (= - (prove5 - (, $L1 $L2) $RULES) - ( (prove5 $L1 $RULES) (prove5 $L2 $RULES))) -; - - (= - (prove5 $H $RULES) - ( (get-clause $ID $H $B $_ $_) - (member $ID $RULES) - (prove5 $B $RULES))) -; - + (= (prove5 true $_) True) + (= (prove5 $H $RULES) + (get-clause $ID $H True $_ $_) + (member $ID $RULES)) + (= (prove5 (, $L1 $L2) $RULES) + (prove5 $L1 $RULES) + (prove5 $L2 $RULES)) + (= (prove5 $H $RULES) + (get-clause $ID $H $B $_ $_) + (member $ID $RULES) + (prove5 $B $RULES)) diff --git a/miles/kb.metta b/miles/kb.metta index 8f1d02a..7fa7560 100644 --- a/miles/kb.metta +++ b/miles/kb.metta @@ -1,6 +1,6 @@ +; (convert_to_metta_file kb $_166284 miles/kb.pl miles/kb.metta) ; -; - +; MODULE kb EXPORTS !(module kb (:: @@ -52,19 +52,48 @@ (/ ex 3) (/ assertallz 1) (/ interpretable-predicate 1))) -; - - -; -; - +; ; Read, store and evaluate background knowledge +; ; and examples, label them 'usr' +; ; same as before, using specified label +; ; Save knowledge base to qof-file +; ; Consult qof-file without additional processing +; ; generates a new kb id +; ; last generated id +; ; Store horn-clause or Clist in kb +; ; Store a list of Clauses in kb +; ; as store_clauses,but returns clauseIDs +; ; Store example in kb +; ; example | +; ; Retrieve clause | from knowledge base +; ; fact | +; ; clause-evaluation| +; ; Remove everything +; ; Remove clauses one by one +; ; Remove examples one by one +; ; one random pos. example +; ; 2 random pos. examples +; ; 2 random uncovered pos. examples +; ; 2 random examples from given list +; ; i random pos. examples +; ; shortest clause +; ; shortest clause with label +; ; 2 shortest clauses +; ; 2 shortest clauses with label +; ; shortest pos. example +; ; shortest uncovered pos. example +; ; shortest ex from list +; ; 2 shortest pos. examples +; ; 2 shortest pos. uncovered ex +; ; list of all shortest pos. examples +; ; list of all shortest uncovered pos. examples + +; +; IMPORTS !(use-module (home div-utils) (:: (/ body2list 2) (/ mysetof 3))) -; - !(use-module (home evaluation) (:: @@ -72,493 +101,332 @@ (/ complexity 2) (/ evaluated 1) (/ change-evaluated 1))) -; - !(use-module (home argument-types) (:: (/ type-restriction 2) (/ verify-types 0))) -; - !(use-module (home flatten) (:: (/ flatten-clause 2) (/ unflatten-clause 2))) -; - !(use-module (home interpreter) (:: (/ prooftrees 3))) -; - !(use-module-if-exists (library prompt)) -; - !(use-module-if-exists (library ask) (:: (/ yesno 1))) -; - !(use-module-if-exists (library basics) (:: (/ nonmember 2) (/ member 2))) -; - !(use-module-if-exists (library random) (:: (/ random-select 3))) -; - ; -; - +; METAPREDICATES ; -; - +; none !(dynamic (, (/ id-count 1) (/ ex 3) (/ known 6))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: kb.pl ; -; - +; * ; -; - +; * author: B.Jung, M.Mueller, I.Stahl, B.Tausend date:12/92 ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * description: - knowledge base handling ; -; - +; * - flatten / unflatten knowledge base ( clauses & examples) ; -; - +; * - heuristics to select examples from kb randomly ; -; - +; * or according to their complexities. ; -; - +; * It is assumed that the examples' current evaluation ; -; - +; * corresponds to the current rules. ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: gen_id/1 ; -; - +; * ; -; - +; * syntax: gen_id(-New) ; -; - +; * ; -; - +; * args: -New kbID ; -; - +; * ; -; - +; * description: generates a new kb id ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (gen-id $New) - ( (remove-symbol &self + (= (gen-id $New) + ( (remove-is-symbol &self (id_count $Old)) (is $New (+ $Old 1)) - (add-symbol &self + (add-is-symbol &self (id_count $New)))) -; - - (= - (gen-id 1) - (add-symbol &self + (= (gen-id 1) + (add-is-symbol &self (id_count 1))) -; - ; -; - +; **************************************************************************************** ; -; - +; * ; -; - +; * predicate: init_kb/1,2 ; -; - +; * ; -; - +; * syntax: init_kb (+Filename) ; -; - +; * init_kb (+Filename, +Label) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: the file Filename may contain Horn clauses "H:-B." and ; -; - +; * "H.", examples "ex(Fact,Class)" and comments ";* blabla". ; -; - +; * Examples are stored in the kb as "ex(ID, Fact, Class)", ; -; - +; * clauses as ; -; - +; * "known(ID,Head,Body,Clist,Label,evaluation(1,2,3,4,5,6,7,8,9))". ; -; - +; * where ID ... unique kb identifier (a natural number) ; -; - +; * Class ... +,-,? ; -; - +; * Clist ... clause in list representation ; -; - +; * [head:p, body1:n, body2:n, body3:r, ...]. Each literal is ; -; - +; * marked p(positiv), n(negativ) or r(negativ + redundant) ; -; - +; * Label ... e.g. the generating operator ; -; - +; * default used for init_kb/1: usr ; -; - +; * evaluation ... of the clauses w.r.t. the examples: ; -; - +; * 1... #applications of the clause ; -; - +; * 2... #definitively positive examples covered by the clause ; -; - +; * 3... list of definitively positive examples covered by the clause ; -; - +; * of the form [...exID:Fact........] ; -; - +; * 4... #definitively negative examples covered by the clause ; -; - +; * 5... list of definitively negative examples covered by the clause ; -; - +; * of the form [...exID:Fact........] ; -; - +; * 6... #probably positive examples covered by the clause ; -; - +; * i.e. instantiations of the clause used in successful ; -; - +; * proofs of positive examples ; -; - +; * 7... list of probably positive examples covered by the clause ; -; - +; * [...exID:Fact........] where exID is the example of which the ; -; - +; * proof uses fact as subgoal ; -; - +; * 8... #probably negative examples covered by the clause ; -; - +; * i.e. instantiations of the clause used in successful ; -; - +; * proofs of negative examples ; -; - +; * 9... list of probably negative examples covered by the clause ; -; - +; * [...exID:Fact........] where exID is the example of which the ; -; - +; * proof uses fact as subgoal ; -; - +; * ; -; - +; * For each example, all possible prooftrees are stored in the kb: ; -; - +; * "prooftrees(ID,M,Trees)" where M is success or fail and Trees contains ; -; - +; * all successful or failing proofs of example ID. ; -; - +; * ; -; - +; * init_kb can be used successively for different files ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ***************************************************************************************** - (= - (init-kb $Filename) + (= (init-kb $Filename) (init-kb $Filename usr)) -; - - - (= - (init-kb $Filename $Origin) - ( (open $Filename read $S) - (repeat) - (read $S $Term) - (store-term $Term $Origin) - (close $S) - (set-det) - (eval-examples) - (verify-types))) -; + (= (init-kb $Filename $Origin) + (open $Filename read $S) + (repeat) + (read $S $Term) + (store-term $Term $Origin) + (close $S) + (set-det) + (eval-examples) + (verify-types)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: consult_kb/1 ; -; - +; * ; -; - +; * syntax: consult_kb(+ Filename) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: Restore knowledge base from qof-file which was produced by save_kb/1. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (consult-kb $Filename) + (= (consult-kb $Filename) ( (clear-kb) $Filename)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: save_kb/1 ; -; - +; * ; -; - +; * syntax: save_kb(+ Filename) ; -; - +; * ; -; - +; * args: Filename: name of a file (.qof) ; -; - +; * ; -; - +; * description: Save snapshot of current knowledge base as compiled file ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: suffix, .qof is recommended for Filename. ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (save-kb $Filename) + (= (save-kb $Filename) (save-predicates (:: (/ known 6) @@ -567,257 +435,178 @@ (/ id-count 1) (/ type-restriction 2) (/ evaluated 1)) $Filename)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: clear_kb/0 ; -; - +; * ; -; - +; * syntax: - ; -; - +; * ; -; - +; * args: none ; -; - +; * ; -; - +; * description: deletes all rules and examples from the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (clear-kb) - ( (remove-all-symbols &self + (= (clear-kb) + ( (remove-all-atoms &self (known $_ $_ $_ $_ $_ $_)) - (remove-all-symbols &self + (remove-all-atoms &self (ex $_ $_ $_)) - (remove-all-symbols &self + (remove-all-atoms &self (prooftrees $_ $_ $_)) - (remove-all-symbols &self + (remove-all-atoms &self (id_count $_)) - (remove-all-symbols &self + (remove-all-atoms &self (type_restriction $_ $_)) - (remove-all-symbols &self + (remove-all-atoms &self (evaluated $_)))) -; - +; ;nl,yesno('Delete all knowledge and examples (y/n) '), ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: store_term/2 ; -; - +; * ; -; - +; * syntax: store_term(+Term,+Label) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: stores clause Term or example Term read from the ; -; - +; * input file during init_kb in the kb using known/6 ; -; - +; * or ex/3 ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (store-term end-of-file $_) + (= (store-term end-of-file $_) (set-det)) -; - - (= - (store-term - (ex $F $C) $_) + (= (store-term (ex $F $C) $_) ( (gen-id $ID) - (add-symbol &self + (add-is-symbol &self (ex $ID $F $C)) (set-det) (fail))) -; - - (= - (store-term - (= $H $B) $O) + (= (store-term (= $H $B) $O) ( (body2list $B $L) (gen-id $ID) - (add-symbol &self + (add-is-symbol &self (known $ID $H $B (Cons (: $H p) $L) $O (evaluation 0 0 () 0 () 0 () 0 ()))) (set-det) (fail))) -; - - (= - (store-term - (type-restriction $M $A) $_) - ( (add-symbol &self + (= (store-term (type-restriction $M $A) $_) + ( (add-is-symbol &self (: argument_types (type_restriction $M $A))) (set-det) (fail))) -; - - (= - (store-term $H $O) + (= (store-term $H $O) ( (gen-id $ID) - (add-symbol &self + (add-is-symbol &self (known $ID $H true ( (: $H p)) $O (evaluation 0 0 () 0 () 0 () 0 ()))) (set-det) (fail))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: store_clause/4 ; -; - +; * ; -; - +; * syntax: store_clause (?MeTTa-clause,?clause-list,+label,-ID) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: Store new clause in knowledge base (provide either horn-clause ; -; - +; * or clause-list), label it and receive the unique clause-ID. ; -; - +; * If store_clause is called with ID instantiated, it will fail if ID is ; -; - +; * already in use in the knowledge-base. If not, ID will be used. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (store-clause $A $B $_ $ID) + (= (store-clause $A $B $_ $ID) (det-if-then-else (, (nonvar $ID) @@ -834,14 +623,7 @@ (, (set-det) (fail)) fail))) -; - - (= - (store-clause - (= $H $B) - (Cons - (with_self $H - (p)) $L) $Label $ID) + (= (store-clause (= $H $B) (Cons (with_self $H (p)) $L) $Label $ID) ( (body2list $B $L) (det-if-then-else (var $ID) @@ -852,18 +634,14 @@ (det-if-then-else (var $Label) (= $Label usr) True) - (add-symbol &self + (add-is-symbol &self (known $ID $H $B (Cons (: $H p) $L) $Label (evaluation 0 0 () 0 () 0 () 0 ()))) (set-det) (change-evaluated no))) -; - - (= - (store-clause $H - (:: (with_self $H (p))) $Label $ID) + (= (store-clause $H (:: (with_self $H (p))) $Label $ID) ( (det-if-then-else (var $ID) (gen-id $ID) @@ -873,220 +651,147 @@ (det-if-then-else (var $Label) (= $Label usr) True) - (add-symbol &self + (add-is-symbol &self (known $ID $H true ( (: $H p)) $Label (evaluation 0 0 () 0 () 0 () 0 ()))) (set-det) (change-evaluated no))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: store_clauses/2 ; -; - +; * ; -; - +; * syntax: store_clauses(+List_of_Clauses,+Label) ; -; - +; * ; -; - +; * args: List_of_Clauses ... list of MeTTa clauses ; -; - +; * ; -; - +; * description: Same as store_clause/4 for a list of clauses ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (store_clauses () $_) True) -; +; *********************************************************************** - (= - (store-clauses - (Cons $C $R) $Label) - ( (store-clause $C $_ $Label $_) (store-clauses $R $Label))) -; + (= (store_clauses () $_) True) + (= (store-clauses (Cons $C $R) $Label) + (store-clause $C $_ $Label $_) + (store-clauses $R $Label)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: store_clauses/3 ; -; - +; * ; -; - +; * syntax: store_clauses(+List_of_Clauses,+Label,-IDlist) ; -; - +; * ; -; - +; * args: List_of_Clauses ... list of MeTTa clauses ; -; - +; * IDlist... kb-ids for the clauses ; -; - +; * ; -; - +; * description: Same as store_clauses/2, but returns IDs of the clauses ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - (= - (store_clauses () $_ ()) True) -; - - (= - (store-clauses - (Cons $C $R) $Label - (Cons $ID $R1)) - ( (store-clause $C $_ $Label $ID) (store-clauses $R $Label $R1))) -; +; *********************************************************************** + (= (store_clauses () $_ ()) True) + (= (store-clauses (Cons $C $R) $Label (Cons $ID $R1)) + (store-clause $C $_ $Label $ID) + (store-clauses $R $Label $R1)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: store_ex/3 ; -; - +; * ; -; - +; * syntax: store_ex(?fact,?classification,-ID) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: Store new example in knowledge base and receive the ; -; - +; * unique identification number. ; -; - +; * If it is called with ID already instantiated: see above. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (store-ex $F $Class $ID) - ( (ex $ID1 $F1 $Class1) - (== $F $F1) - (set-det) - (= $Class $Class1) - (= $ID $ID1))) -; - (= - (store-ex $F $_ $ID) + (= (store-ex $F $Class $ID) + (ex $ID1 $F1 $Class1) + (== $F $F1) + (set-det) + (= $Class $Class1) + (= $ID $ID1)) + (= (store-ex $F $_ $ID) (det-if-then-else (, (nonvar $ID) @@ -1101,1763 +806,1205 @@ (, (set-det) (fail)) fail))) -; - - (= - (store-ex $Fact $Class $ID) + (= (store-ex $Fact $Class $ID) ( (det-if-then-else (var $ID) (gen-id $ID) (, (id-count $Top) (=< $ID $Top))) - (add-symbol &self + (add-is-symbol &self (ex $ID $Fact $Class)) (set-det) (change-evaluated no))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: get_example/3 ; -; - +; * get_clause/5 ; -; - +; * get_fact/4 ; -; - +; * get_evaluation/2 ; -; - +; * ; -; - +; * syntax: get_example (? ID, ? Example, ? Classification) ; -; - +; * get_clause (? ID, ? Head, ? Body, ? Clist, ? Label) ; -; - +; * get_fact (? ID, ? Fact, ? Clist, ? Label) ; -; - +; * get_evaluation (+ ID, - Evaluation) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: read example/clause/fact or clause evaluation from the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (get-example $ID $F $C) + (= (get-example $ID $F $C) (ex $ID $F $C)) -; + (= (get-clause $ID $H $B $L $O) + (known $ID $H $B $L $O $_)) - (= - (get-clause $ID $H $B $L $O) - (known $ID $H $B $L $O $_)) -; - - - (= - (get-fact $ID $F $L $O) + (= (get-fact $ID $F $L $O) (known $ID $F True $L $O $_)) -; - - (= - (get-evaluation $ID $Eval) + (= (get-evaluation $ID $Eval) (known $ID $_ $_ $_ $_ $Eval)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: delete_clause/1 , delete_example/1, delete_all/1 ; -; - +; * ; -; - +; * syntax: delete_clause(+ ID) , delete_example(+ ID), ; -; - +; * delete_all(+list_of_clauseIDs) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: delete clause(s)/example(s) with identifier(s) ID(list_of_clauseIDs) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (delete-clause $ID) - ( (remove-symbol &self + (= (delete-clause $ID) + ( (remove-is-symbol &self (known $ID $_ $_ $_ $_ $_)) (change-evaluated no))) -; - - (= - (delete-example $ID) - ( (remove-symbol &self + (= (delete-example $ID) + ( (remove-is-symbol &self (ex $ID $_ $_)) (change-evaluated no))) -; - - - - (= - (delete-all Nil) - (set-det)) -; - - (= - (delete-all (Cons $Id1 $Rest)) - ( (delete-clause $Id1) - (set-det) - (delete-all $Rest))) -; - (= - (delete-all (Cons $Id1 $Rest)) - ( (delete-example $Id1) - (set-det) - (delete-all $Rest))) -; + (= (delete-all Nil) + (set-det)) + (= (delete-all (Cons $Id1 $Rest)) + (delete-clause $Id1) + (set-det) + (delete-all $Rest)) + (= (delete-all (Cons $Id1 $Rest)) + (delete-example $Id1) + (set-det) + (delete-all $Rest)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: interpretable_predicate/1 ; -; - +; * ; -; - +; * syntax: interpretable_predicate(-Term) ; -; - +; * ; -; - +; * args: Term .. MeTTa term with principal funtor P/N ; -; - +; * ; -; - +; * description: succeeds if rules or examples for P/N are in the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (interpretable-predicate $A) - ( (functor $A $F $N) - (functor $A1 $F $N) - (or - (get-clause $_ $A1 $_ $_ $_) - (get-example $_ $A1 $_)))) -; - + (= (interpretable-predicate $A) + (functor $A $F $N) + (functor $A1 $F $N) + (or + (get-clause $_ $A1 $_ $_ $_) + (get-example $_ $A1 $_))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: assertallz/1 ; -; - +; * ; -; - +; * syntax: assertallz(+List) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: asserts all elements of List at the end of the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (assertallz ()) True) -; +; *********************************************************************** - (= - (assertallz (Cons $X $R)) - ( (add-symbol &self $X) (assertallz $R))) -; + (= (assertallz ()) True) + (= (assertallz (Cons $X $R)) + ( (add-is-symbol &self $X) (assertallz $R))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: rename_clause/3 ; -; - +; * ; -; - +; * syntax: rename (+ ID_list,+ Old_name,+ New_name ) ; -; - +; * ; -; - +; * args: Old_name, New_name ... atoms ; -; - +; * ; -; - +; * description: rename every occurence of predicate 'Old_name' to 'New_name' ; -; - +; * in a set of clauses given as ; -; - +; * a list of kb-references (Id-list). 'New_name' should be atomic. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (rename Nil $_ $_) + (= (rename Nil $_ $_) (set-det)) -; - - (= - (rename - (Cons $Id1 $Rest) $Old $New) - ( (get-clause $Id1 $_ $_ $Clist $Label) - (rename-clause $Clist $NewClause $Old $New) - (delete-clause $Id1) - (store-clause $_ $NewClause $Label $Id1) - (set-det) - (rename $Rest $Old $New))) -; - + (= (rename (Cons $Id1 $Rest) $Old $New) + (get-clause $Id1 $_ $_ $Clist $Label) + (rename-clause $Clist $NewClause $Old $New) + (delete-clause $Id1) + (store-clause $_ $NewClause $Label $Id1) + (set-det) + (rename $Rest $Old $New)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: rename_clause/4 ; -; - +; * ; -; - +; * syntax: rename_clause(+CL,-CL1,+Old,+New) ; -; - +; * ; -; - +; * args: CL,CL1.. clauses in list representation ; -; - +; * Old, New atoms ; -; - +; * ; -; - +; * description: replaces each literal Old(...) within CL with New(...) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (rename-clause Nil Nil $_ $_) + (= (rename-clause Nil Nil $_ $_) (set-det)) -; - - (= - (rename-clause - (Cons - (with_self $Lit $X) $Rest) - (Cons - (with_self $NewLit $X) $NewRest) $Old $New) - ( (det-if-then-else - (=.. $Lit - (Cons $Old $Args)) - (=.. $NewLit - (Cons $New $Args)) - (= $NewLit $Lit)) - (set-det) - (rename-clause $Rest $NewRest $Old $New))) -; - + (= (rename-clause (Cons (with_self $Lit $X) $Rest) (Cons (with_self $NewLit $X) $NewRest) $Old $New) + (det-if-then-else + (=.. $Lit + (Cons $Old $Args)) + (=.. $NewLit + (Cons $New $Args)) + (= $NewLit $Lit)) + (set-det) + (rename-clause $Rest $NewRest $Old $New)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: random_ex/1 ; -; - +; * ; -; - +; * syntax: random_ex(-ID) ; -; - +; * ; -; - +; * args: ID exampleID ; -; - +; * ; -; - +; * description: chooses randomly an example from the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (random-ex $ID1) - ( (findall $ID - (get-example $ID $_ +) $Bag) (random-select $ID1 $Bag $_))) -; - + (= (random-ex $ID1) + (findall $ID + (get-example $ID $_ +) $Bag) + (random-select $ID1 $Bag $_)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: two_random_ex/2 ; -; - +; * ; -; - +; * syntax: two_random_ex(-ID1,-ID2) ; -; - +; * ; -; - +; * args: ID1,ID2 exampleIDs ; -; - +; * ; -; - +; * description: chooses randomly two examples from the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (two-random-ex $ID1 $ID2) - ( (findall $ID - (get-example $ID $_ +) $Bag) - (or - (random-select $ID1 $Bag $Residue) - (select $ID1 $Bag $Residue)) - (or - (random-select $ID2 $Residue $_) - (select $ID2 $Residue $_)))) -; - + (= (two-random-ex $ID1 $ID2) + (findall $ID + (get-example $ID $_ +) $Bag) + (or + (random-select $ID1 $Bag $Residue) + (select $ID1 $Bag $Residue)) + (or + (random-select $ID2 $Residue $_) + (select $ID2 $Residue $_))) ; -; - +; sometimes random_select/3 doesn't work properly - (= - (two-random-ex-from-list $List $ID1 $ID2) - ( (random-select $ID1 $List $Residue) (random-select $ID2 $Residue $_))) -; + (= (two-random-ex-from-list $List $ID1 $ID2) + (random-select $ID1 $List $Residue) + (random-select $ID2 $Residue $_)) - - (= - (two-random-uncovered-ex $ID1 $ID2) - ( (findall $ID - (, - (with_self - (kb *) - (prooftrees $ID fail $_)) - (get-example $ID $_ +)) $Uncovered) (two-random-ex-from-list $Uncovered $ID1 $ID2))) -; - + (= (two-random-uncovered-ex $ID1 $ID2) + (findall $ID + (, + (with_self + (kb *) + (prooftrees $ID fail $_)) + (get-example $ID $_ +)) $Uncovered) + (two-random-ex-from-list $Uncovered $ID1 $ID2)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: i_random_ex/2 ; -; - +; * ; -; - +; * syntax: i_random_ex(+I,-ExIDs) ; -; - +; * ; -; - +; * args: I .. number ; -; - +; * ; -; - +; * description: selects randomly I examples from the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (i-random-ex $I $Examples) - ( (> $I 0) - (findall $ID - (get-example $ID $_ +) $Bag) - (length $Bag $J) - (det-if-then-else - (=< $J $I) - (= $Examples $Bag) - (i-random-ex $I $Bag $Examples)))) -; - - (= - (i-random-ex 0 $_ Nil) + (= (i-random-ex $I $Examples) + (> $I 0) + (findall $ID + (get-example $ID $_ +) $Bag) + (length $Bag $J) + (det-if-then-else + (=< $J $I) + (= $Examples $Bag) + (i-random-ex $I $Bag $Examples))) + (= (i-random-ex 0 $_ Nil) (set-det)) -; - - (= - (i-random-ex $N $Bag - (Cons $ID $Rest)) - ( (random-select $ID $Bag $Residue) - (is $M - (- $N 1)) - (i-random-ex $M $Residue $Rest))) -; - + (= (i-random-ex $N $Bag (Cons $ID $Rest)) + (random-select $ID $Bag $Residue) + (is $M + (- $N 1)) + (i-random-ex $M $Residue $Rest)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: shortest_clause/1 ; -; - +; * ; -; - +; * syntax: shortest_clause(-ID:C) ; -; - +; * ; -; - +; * args: ID .. clauseID, C ... complexity of the corresponding clause ; -; - +; * ; -; - +; * description: selects the shortest clause from the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (shortest-clause (with_self $ID1 $C1)) + (= (shortest-clause (with_self $ID1 $C1)) (shortest-clause $_ - (with_self $ID1 $C1))) -; - + (with_self $ID1 $C1))) - (= - (shortest-clause $Label - (with_self $ID1 $C1)) - ( (findall - (with_self $ID $C) - (, - (get-clause $ID $_ $_ $Clause $Label) - (complexity $Clause $C)) $Bag) (shortest $Bag (with_self $ID1 $C1) $_))) -; - + (= (shortest-clause $Label (with_self $ID1 $C1)) + (findall + (with_self $ID $C) + (, + (get-clause $ID $_ $_ $Clause $Label) + (complexity $Clause $C)) $Bag) + (shortest $Bag + (with_self $ID1 $C1) $_)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: two_shortest_clauses/2 ; -; - +; * ; -; - +; * syntax: two_shortest_clauses(-ID1:CL1,-ID2:CL2) ; -; - +; * ; -; - +; * args: ID1/2 .. clauseIDs, CL1/2 ... complexities of the corresponding clauses ; -; - +; * ; -; - +; * description: selects two shortest clauses from kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (two-shortest-clauses - (with_self $ID1 $C1) - (with_self $ID2 $C2)) + (= (two-shortest-clauses (with_self $ID1 $C1) (with_self $ID2 $C2)) (two-shortest-clauses $_ (with_self $ID1 $C1) (with_self $ID2 $C2))) -; - - (= - (two-shortest-clauses $Label + (= (two-shortest-clauses $Label (with_self $ID1 $C1) (with_self $ID2 $C2)) + (findall + (with_self $ID $C) + (, + (get-clause $ID $_ $_ $Clause $Label) + (complexity $Clause $C)) $Bag) + (two-shortest $Bag (with_self $ID1 $C1) - (with_self $ID2 $C2)) - ( (findall - (with_self $ID $C) - (, - (get-clause $ID $_ $_ $Clause $Label) - (complexity $Clause $C)) $Bag) (two-shortest $Bag (with_self $ID1 $C1) (with_self $ID2 $C2)))) -; - + (with_self $ID2 $C2))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: shortest_ex/1 ; -; - +; * ; -; - +; * syntax: shortest_ex(-ID:C) ; -; - +; * ; -; - +; * args: ID .. exID, C .. complexity of the corresponding example ; -; - +; * ; -; - +; * description: selects the shortest example from kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (shortest-ex (with_self $ID1 $C1)) - ( (findall - (with_self $ID $C) - (, - (get-example $ID $Ex +) - (complexity $Ex $C)) $Bag) (shortest $Bag (with_self $ID1 $C1) $_))) -; - + (= (shortest-ex (with_self $ID1 $C1)) + (findall + (with_self $ID $C) + (, + (get-example $ID $Ex +) + (complexity $Ex $C)) $Bag) + (shortest $Bag + (with_self $ID1 $C1) $_)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: two_shortest_ex/2 ; -; - +; * ; -; - +; * syntax: two_shortest_ex(-ID1:C1,-ID2:C2) ; -; - +; * ; -; - +; * args: ID1/2 .. exIDs, C1/2 .. complexities of the corresponding examples ; -; - +; * ; -; - +; * description: selects two shortest example from kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (two-shortest-ex + (= (two-shortest-ex (with_self $ID1 $C1) (with_self $ID2 $C2)) + (findall + (with_self $ID $C) + (, + (get-example $ID $Ex +) + (complexity $Ex $C)) $Bag) + (two-shortest $Bag (with_self $ID1 $C1) - (with_self $ID2 $C2)) - ( (findall - (with_self $ID $C) - (, - (get-example $ID $Ex +) - (complexity $Ex $C)) $Bag) (two-shortest $Bag (with_self $ID1 $C1) (with_self $ID2 $C2)))) -; - + (with_self $ID2 $C2))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: shortest_uncovered_ex/1 ; -; - +; * ; -; - +; * syntax: shortest_uncovered_ex(-ExID) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: selects the shortest example that is not covered by the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (shortest-uncovered-ex $ID1) - ( (findall - (with_self $ID $C) - (, - (with_self - (kb *) - (prooftrees $ID fail $_)) - (get-example $ID $Ex +) - (complexity $Ex $C)) $Uncovered) (shortest $Uncovered (with_self $ID1 $_) $Residue))) -; - + (= (shortest-uncovered-ex $ID1) + (findall + (with_self $ID $C) + (, + (with_self + (kb *) + (prooftrees $ID fail $_)) + (get-example $ID $Ex +) + (complexity $Ex $C)) $Uncovered) + (shortest $Uncovered + (with_self $ID1 $_) $Residue)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: shortest_uncovered_ex/2 ; -; - +; * ; -; - +; * syntax: shortest_uncovered_ex(+ExIds,-ExId) ; -; - +; * ; -; - +; * args: ExIds .. list of Ids of uncovered examples ; -; - +; * ; -; - +; * description: selects the shortest example among ExIds ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - (= - (shortest-uncovered-ex $Uncovered $ID1) - ( (add-complexities $Uncovered $Bag) (shortest $Bag (with_self $ID1 $_) $Residue))) -; +; *********************************************************************** + (= (shortest-uncovered-ex $Uncovered $ID1) + (add-complexities $Uncovered $Bag) + (shortest $Bag + (with_self $ID1 $_) $Residue)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: two_shortest_uncovered_ex/2 ; -; - +; * ; -; - +; * syntax: two_shortest_uncovered_ex(-ExID1,-ExID2) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: selects two shortest examples that are not covered by the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (two-shortest-uncovered-ex $ID1 $ID2) - ( (findall - (with_self $ID $C) - (, - (with_self - (kb *) - (prooftrees $ID fail $_)) - (get-example $ID $Ex +) - (complexity $Ex $C)) $Uncovered) (two-shortest $Uncovered (with_self $ID1 $_) (with_self $ID2 $_)))) -; - + (= (two-shortest-uncovered-ex $ID1 $ID2) + (findall + (with_self $ID $C) + (, + (with_self + (kb *) + (prooftrees $ID fail $_)) + (get-example $ID $Ex +) + (complexity $Ex $C)) $Uncovered) + (two-shortest $Uncovered + (with_self $ID1 $_) + (with_self $ID2 $_))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: all_shortest_ex/1 ; -; - +; * ; -; - +; * syntax: all_shortest_ex(-ExIds) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: selects all shortest examples from kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (all-shortest-ex $Bag) - ( (shortest-ex (with_self $_ $C1)) (findall $ID (, (get-example $ID $Ex +) (complexity $Ex $C1)) $Bag))) -; - + (= (all-shortest-ex $Bag) + (shortest-ex (with_self $_ $C1)) + (findall $ID + (, + (get-example $ID $Ex +) + (complexity $Ex $C1)) $Bag)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: all_shortest_uncovered_ex/1 ; -; - +; * ; -; - +; * syntax: all_shortest_uncovered_ex(-ExIds) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: selects all shortest uncovered examples from kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (all-shortest-uncovered-ex $Bag) - ( (findall - (with_self $ID $C) - (, - (with_self - (kb *) - (prooftrees $ID fail $_)) - (get-example $ID $Ex +) - (complexity $Ex $C)) $Uncovered) - (shortest $Uncovered - (with_self $_ $C1) $_) - (findall $ID2 - (member - (with_self $ID2 $C1) $Uncovered) $Bag))) -; - + (= (all-shortest-uncovered-ex $Bag) + (findall + (with_self $ID $C) + (, + (with_self + (kb *) + (prooftrees $ID fail $_)) + (get-example $ID $Ex +) + (complexity $Ex $C)) $Uncovered) + (shortest $Uncovered + (with_self $_ $C1) $_) + (findall $ID2 + (member + (with_self $ID2 $C1) $Uncovered) $Bag)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: two_shortest /3 ; -; - +; * ; -; - +; * syntax: two_shortest(+Bag,-ID1:C1,-ID2:C2) ; -; - +; * ; -; - +; * args: Bag = [ ID:C, ...] , where ID refers to example with complexity C ; -; - +; * ID1/2 ...exampleIDs, C1/2 ... corresponding complexities ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (two-shortest $Bag - (with_self $ID1 $C1) - (with_self $ID2 $C2)) - ( (shortest $Bag - (with_self $ID1 $C1) $Residue) - (shortest $Residue - (with_self $ID2 $C2) $_) - (set-det))) -; - + (= (two-shortest $Bag (with_self $ID1 $C1) (with_self $ID2 $C2)) + (shortest $Bag + (with_self $ID1 $C1) $Residue) + (shortest $Residue + (with_self $ID2 $C2) $_) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: shortest/3 ; -; - +; * ; -; - +; * syntax: shortest(+Bag,-ID:C,-Residue) ; -; - +; * ; -; - +; * args: Bag, Residue = [ ID:C, ...] , where ID is the complexity of ID ; -; - +; * ID ...kbID, C ... corresponding complexity ; -; - +; * ; -; - +; * description: selects the shortest ID from Bag wrt complexity, Residue is the rest ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (shortest - ( (: $ID $C)) - (: $ID $C) ()) True) -; - - (= - (shortest - (Cons - (with_self $ID1 $C1) $Rest) - (with_self $ID $C) $Residue) - ( (shortest $Rest - (with_self $ID2 $C2) $Residue2) - (| - (det-if-then - (< $C1 $C2) - (, - (= $ID $ID1) - (= $C $C1) - (= $Residue $Rest))) - (det-if-then otherwise - (, - (= $ID $ID2) - (= $C $C2) - (= $Residue - (Cons - (with_self $ID1 $C1) $Residue2))))) - (set-det))) -; + (= (shortest ((: $ID $C)) (: $ID $C) ()) True) + (= (shortest (Cons (with_self $ID1 $C1) $Rest) (with_self $ID $C) $Residue) + (shortest $Rest + (with_self $ID2 $C2) $Residue2) + (| + (det-if-then + (< $C1 $C2) + (, + (= $ID $ID1) + (= $C $C1) + (= $Residue $Rest))) + (det-if-then otherwise + (, + (= $ID $ID2) + (= $C $C2) + (= $Residue + (Cons + (with_self $ID1 $C1) $Residue2))))) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate:add_complexities/2 ; -; - +; * ; -; - +; * syntax: add_complexities(+L,-Pairs) ; -; - +; * ; -; - +; * args: L = [ID:kb_entry_for_ID,...], ; -; - +; * Pairs = [ID:complexity_of_kb_entry_for_ID,...] ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (add_complexities () ()) True) -; - - - (= - (add-complexities - (Cons - (with_self $ID $Ex) $More) - (Cons - (with_self $ID $C) $MorePairs)) - ( (complexity $Ex $C) (add-complexities $More $MorePairs))) -; + (= (add_complexities () ()) True) + (= (add-complexities (Cons (with_self $ID $Ex) $More) (Cons (with_self $ID $C) $MorePairs)) + (complexity $Ex $C) + (add-complexities $More $MorePairs)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: no_rules/0, no_pos_examples/0, ; -; - +; * no_neg_examples/0, no_examples/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: tests kb on the different properties ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (no-rules) + (= (no-rules) (not (get-clause $_ $_ $_ $_ $_))) -; - - (= - (no-pos-examples) + (= (no-pos-examples) (not (get-example $_ $_ +))) -; - - (= - (no-neg-examples) + (= (no-neg-examples) (not (get-example $_ $_ -))) -; - - (= - (no-examples) + (= (no-examples) (not (get-example $_ $_ $_))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: delete_covered_examples/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: deletes examples explained by the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (delete-covered-examples) - ( (findall $I - (, - (get-evaluation $I $Eval) - (arg 3 $Eval $CoveredEx) - (member - (with_self $ID $_) $CoveredEx) - (delete-example $ID)) $_) (set-det))) -; - + (= (delete-covered-examples) + (findall $I + (, + (get-evaluation $I $Eval) + (arg 3 $Eval $CoveredEx) + (member + (with_self $ID $_) $CoveredEx) + (delete-example $ID)) $_) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: flatten_rules/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: flattens all clauses in the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; (error ; (syntax_error operator_clash) @@ -2865,56 +2012,39 @@ ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: flatten_kb/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: flattens all clauses and examples in the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; (error ; (syntax_error operator_clash) @@ -2923,56 +2053,39 @@ ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: unflatten_kb/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: unflattens a flat kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; (error ; (syntax_error operator_clash) @@ -2980,74 +2093,50 @@ ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: store_flat_clauses/1 ; -; - +; * ; -; - +; * syntax: store_flat_clauses(+CL) ; -; - +; * ; -; - +; * args: CL = [ID:C:Label,...] where ID is clause- or exampleID, C is the corresponding ; -; - +; * clause in list notation and Label is the clause label or "ex" if examples are ; -; - +; * flattened ; -; - +; * ; -; - +; * description: store flat clauses preferably with their old Id. ; -; - +; * After flattening, examples become clauses; they get a new Id ; -; - +; * while their unflat form remains in the kb. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (store_flat_clauses ()) True) -; - + (= (store_flat_clauses ()) True) ; (error ; (syntax_error operator_clash) ; (file miles/kb.pl 1159 23 34514)) @@ -3055,74 +2144,50 @@ ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: store_unflat_clauses/1 ; -; - +; * ; -; - +; * syntax: store_unflat_clauses(+CL) ; -; - +; * ; -; - +; * args: CL = [ID:C:Label,...] where ID is a clause- or exampleID, C is the corresponding ; -; - +; * clause in list notation and Label is the clause label or "ex" ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: if Label \= ex, C is unflattened and replaced in the kb by ; -; - +; * the unflat version ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (store_unflat_clauses ()) True) -; + (= (store_unflat_clauses ()) True) ; (error ; (syntax_error operator_clash) ; (file miles/kb.pl 1188 27 35402)) @@ -3134,188 +2199,122 @@ ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: get_predlist/1 ; -; - +; * ; -; - +; * syntax: get_predlist(-Predlist) ; -; - +; * ; -; - +; * args: Predlist = [P:PVars|_] ; -; - +; * ; -; - +; * description: selects all predicates with a type restriction from kb ; -; - +; * & adapts type restrictions by transfomation in a list [X:Tx,...] ; -; - +; * of variables X and types Tx ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (get-predlist $Predlist) - ( (mysetof - (with_self $P $N) - (^ $I - (^ $H - (^ $B - (^ $CL - (^ $L - (, - (get-clause $I $H $B $CL $L) - (\== $L type) - (functor $H $P $N))))))) $Plist) (get-pred $Plist $Predlist))) -; + (= (get-predlist $Predlist) + (mysetof + (with_self $P $N) + (^ $I + (^ $H + (^ $B + (^ $CL + (^ $L + (, + (get-clause $I $H $B $CL $L) + (\== $L type) + (functor $H $P $N))))))) $Plist) + (get-pred $Plist $Predlist)) +; ; mysetof(P:PVars, ; Vars^( type_restriction(P,Vars), ; adapt_v(Vars,PVars)), Predlist). - - (= - (get_pred () ()) True) -; - - (= - (get-pred - (Cons - (with_self $Pred $N) $R) - (Cons - (with_self $P $PVars) $R1)) - ( (get-pred $R $R1) - (functor $P $Pred $N) - (det-if-then-else - (type-restriction $P $Vars) - (adapt-v $Vars $PVars) - (, - (=.. $P - (Cons $_ $Vars)) - (adapt-v1 $Vars $PVars))))) -; - + (= (get_pred () ()) True) + (= (get-pred (Cons (with_self $Pred $N) $R) (Cons (with_self $P $PVars) $R1)) + (get-pred $R $R1) + (functor $P $Pred $N) + (det-if-then-else + (type-restriction $P $Vars) + (adapt-v $Vars $PVars) + (, + (=.. $P + (Cons $_ $Vars)) + (adapt-v1 $Vars $PVars)))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: adapt_v/2 ; -; - +; * ; -; - +; * syntax: adapt_v(+TR,-Vars) ; -; - +; * ; -; - +; * args: TR: [Tx(X),...] type restrictions for variables X of a predicate ; -; - +; * Vars: [X:Tx,...] ; -; - +; * ; -; - +; * description: transforms a set of type restrictions Tx(X) into ; -; - +; * a set X:Tx of variables X and types Tx ; -; - +; * ; -; - +; * example: adapt_v([list(A),atom(B)],[A:list,B:atom] ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (adapt_v () ()) True) -; - (= - (adapt-v - (Cons $T $R) - (Cons - (with_self $X $Tx) $R1)) - ( (adapt-v $R $R1) (=.. $T (:: $Tx $X)))) -; + (= (adapt_v () ()) True) + (= (adapt-v (Cons $T $R) (Cons (with_self $X $Tx) $R1)) + (adapt-v $R $R1) + (=.. $T + (:: $Tx $X))) - - (= - (adapt_v1 () ()) True) -; - - (= - (adapt-v1 - (Cons $X $R) - (Cons - (with_self $X - (all)) $R1)) + (= (adapt_v1 () ()) True) + (= (adapt-v1 (Cons $X $R) (Cons (with_self $X (all)) $R1)) (adapt-v1 $R $R1)) -; - diff --git a/miles/lgg.metta b/miles/lgg.metta index 163f45a..f608d14 100644 --- a/miles/lgg.metta +++ b/miles/lgg.metta @@ -1,6 +1,6 @@ +; (convert_to_metta_file lgg $_337376 miles/lgg.pl miles/lgg.metta) ; -; - +; MODULE lgg EXPORTS !(module lgg (:: @@ -36,12 +36,13 @@ (/ lgti 3) (/ lgti 5) (/ lgti 6))) -; - +; ; Buntine's most specific generalization +; ; " with given bound for saturation +; ; rllg +; ; rllg with given head literal of preference ; -; - +; IMPORTS !(use-module (home kb) (:: @@ -49,8 +50,6 @@ (/ delete-clause 1) (/ store-clause 4) (/ get-example 3))) -; - !(use-module (home bu-basics) (:: @@ -67,8 +66,6 @@ (/ msg-build-long-clause 1) (/ msg-build-heads 1) (/ msg-build-body 1))) -; - !(use-module (home var-utils) (:: @@ -76,8 +73,6 @@ (/ skolemize 4) (/ deskolemize 3) (/ clean-subst 3))) -; - !(use-module (home div-utils) (:: @@ -88,612 +83,433 @@ (/ maximum 2) (/ identical-member 2) (/ identical-make-unique 2))) -; - !(use-module (home interpreter) (:: (/ prove1 2) (/ prove5 2))) -; - !(use-module (home g1-ops) (:: (/ saturate 2) (/ saturate 3) (/ inv-derivate1 2))) -; - !(use-module (home filter) (:: (/ truncate-unconnected 2))) -; - !(use-module (home evaluation) (:: (/ complexity 2))) -; - !(use-module-if-exists (library sets) (:: (/ list-to-set 2) (/ subtract 3))) -; - !(use-module-if-exists (library lists) (:: (/ is-list 1) (/ subseq0 2) (/ nth1 4))) -; - !(use-module-if-exists (library basics) (:: (/ member 2))) -; - !(use-module-if-exists (library random) (:: (/ maybe 0))) -; - !(use-module-if-exists (library not) (:: (/ once 1))) -; - !(use-module-if-exists (library occurs) (:: (/ contains-var 2) (/ free-of-var 2))) -; - !(use-module-if-exists (library subsumes) (:: (/ subsumes-chk 2) (/ variant 2))) -; - ; -; - +; METAPREDICATES ; -; - +; none !(dynamic (, (/ counter 1) (/ shortsubst 2) (/ iterate 1))) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: lgg.pl ; -; - +; * ; -; - +; * author: B.Jung, M.Mueller, I.Stahl, B.Tausend date:12/92 ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * description: - clause reduction ; -; - +; * reduce clause with no repect to background ; -; - +; * knowledge (Plotkin,1970) ; -; - +; * reduce w.r.t. background knowledge (Buntine,1988) ; -; - +; * Since reduction is in both cases NP-complete, ; -; - +; * we provide 2 versions for each case: ; -; - +; * a correct, but higly inefficient solution ; -; - +; * & an approximation. ; -; - +; * - clause_subsumption ; -; - +; * - Buntine's most specific generalization under ; -; - +; * generalized subsumption ; -; - +; * - Plotkin's RLGG, with Muggleton's algorithm ; -; - +; * - Plotkins least general generalisation (lgg) ; -; - +; * under theta subsumption ; -; - +; * - least general intersection lgti ; -; - +; * ; -; - +; * see also: Buntine,88; Muggleton,90; Plotkin, 70; ; -; - +; * module lgg.pl for msg ; -; - +; * ; -; - +; *********************************************************************** ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicates: reduce_complete/2 ; -; - +; * ; -; - +; * syntax: reduce_complete(+Clause,-ReducedClause) ; -; - +; * ; -; - +; * args: Clause: input clause in list form ; -; - +; * ReducedClause: reduced, minimal clause equivalent to Clause ; -; - +; * ; -; - +; * description: do not consider bg, i.e. reduction wrt theta subsumption ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (reduce-complete $ID) - ( (get-clause $ID $_ $_ $C $_) - (reduce-complete $C $D) - (delete-clause $ID) - (store-clause $_ $D reduce $ID) - (set-det))) -; - + (= (reduce-complete $ID) + (get-clause $ID $_ $_ $C $_) + (reduce-complete $C $D) + (delete-clause $ID) + (store-clause $_ $D reduce $ID) + (set-det)) - (= - (reduce-complete $Clause $Reduced) - ( (clear-mngr) - (skolemize $Clause $S $SClause) - (assert-clause $SClause) - (reduce-complete1 $Clause $S $SReduced0) - (list-to-set $SReduced0 $SReduced) - (deskolemize $SReduced $S $Reduced) - (set-det))) -; - ; -; + (= (reduce-complete $Clause $Reduced) + (clear-mngr) + (skolemize $Clause $S $SClause) + (assert-clause $SClause) + (reduce-complete1 $Clause $S $SReduced0) + (list-to-set $SReduced0 $SReduced) + (deskolemize $SReduced $S $Reduced) + (set-det)) ; +; No backtracking allowed (solution is unique) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: reduce_complete1/3 ; -; - +; * ; -; - +; * syntax: reduce_complete1(+CL,+Subst,-ReducedCL) ; -; - +; * ; -; - +; * args: CL,ReducedCL: clauses in list notation ; -; - +; * Subst: skolem substitution ; -; - +; * ; -; - +; * description: reduces CL by matching it on the skolemized head and ; -; - +; * body literals of the reduced clause in the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** + (= (reduce-complete1 $C $S $RC) + (copy-term $C $ToShow) + (prove1 $ToShow $SProof) + (det-if-then-else + (reduce-complete-test $SProof) + (, + (clear-mngr) + (list-to-set $SProof $SProof1) + (assert-clause $SProof1) + (copy-term $S $S1) + (deskolemize $SProof1 $S1 $Proof) + (reduce-complete1 $Proof $S $RC)) + (, + (reset-counts) + (fail)))) +; ; backtrack, find another proof + (= (reduce-complete1 $_ $S $RC) + (set-det) + (subs-build-clause $RC)) +; ; there is no shorter proof, the minimal clause is found. - (= - (reduce-complete1 $C $S $RC) - ( (copy-term $C $ToShow) - (prove1 $ToShow $SProof) - (det-if-then-else - (reduce-complete-test $SProof) - (, - (clear-mngr) - (list-to-set $SProof $SProof1) - (assert-clause $SProof1) - (copy-term $S $S1) - (deskolemize $SProof1 $S1 $Proof) - (reduce-complete1 $Proof $S $RC)) - (, - (reset-counts) - (fail))))) -; - - (= - (reduce-complete1 $_ $S $RC) - ( (set-det) (subs-build-clause $RC))) -; - - - - - (= - (reduce-complete-test $P) - ( (findall - (with_self $H - (p)) - (head $H $_ $_) $HL) - (setof - (with_self $B $_) - (body $B $_ $_) $BL) - (append $HL $BL $L) - (list-to-set $L $L0) - (list-to-set $P $P0) - (subtract $L0 $P0 $D) - (set-det) - (\== $D Nil))) -; + (= (reduce-complete-test $P) + (findall + (with_self $H + (p)) + (head $H $_ $_) $HL) + (setof + (with_self $B $_) + (body $B $_ $_) $BL) + (append $HL $BL $L) + (list-to-set $L $L0) + (list-to-set $P $P0) + (subtract $L0 $P0 $D) + (set-det) + (\== $D Nil)) -; -; ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: reduce_approx/2 ; -; - +; * ; -; - +; * syntax: reduce_approx(+Clause,-ReducedClause) ; -; - +; * ; -; - +; * args: Clause: input clause in list form ; -; - +; * ReducedClause: reduced, minimal clause equivalent to Clause ; -; - +; * ; -; - +; * description: as reduce_complete except that the number of single ; -; - +; * reduction steps is bound ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - - - - (= - (reduce-approx $Clause $Reduced) - ( (clear-mngr) - (copy-term $Clause $Copy) - (skolemize $Copy $S $SClause) - (assert-clause $SClause) - (reduce-approx1 $S 1 50) - (reduce-get-current-clause $SReduced0) - (list-to-set $SReduced0 $SReduced) - (deskolemize $SReduced $S $Reduced))) -; +; * +; +; *********************************************************************** + (= (reduce-approx $Clause $Reduced) + (clear-mngr) + (copy-term $Clause $Copy) + (skolemize $Copy $S $SClause) + (assert-clause $SClause) + (reduce-approx1 $S 1 50) + (reduce-get-current-clause $SReduced0) + (list-to-set $SReduced0 $SReduced) + (deskolemize $SReduced $S $Reduced)) - (= - (reduce-approx1 $S $Counter $Bound) - ( (=< $Counter $Bound) - (copy-term $S $S1) - (reduce-get-current-clause $C) - (deskolemize $C $S1 $ToShow) - (prove1 $ToShow $SProof) - (clear-mngr) - (assert-body-randomly $SProof) - (is $J - (+ $Counter 1)) - (reduce-approx1 $S $J $Bound))) -; + (= (reduce-approx1 $S $Counter $Bound) + (=< $Counter $Bound) + (copy-term $S $S1) + (reduce-get-current-clause $C) + (deskolemize $C $S1 $ToShow) + (prove1 $ToShow $SProof) + (clear-mngr) + (assert-body-randomly $SProof) + (is $J + (+ $Counter 1)) + (reduce-approx1 $S $J $Bound)) - (= - (reduce_approx1 $_ $_ $_) True) -; - + (= (reduce_approx1 $_ $_ $_) True) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: reduce_get_current_clause/1 ; -; - +; * ; -; - +; * syntax: reduce_get_current_clause(-CL) ; -; - +; * ; -; - +; * args: CL: clause in list notation ; -; - +; * ; -; - +; * description: returns current skolemized clause that is stored via ; -; - +; * head/3 and body/3 in the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (reduce-get-current-clause $CL) - ( (findall - (with_self $H - (p)) - (head $H $_ $_) $Heads) - (findall - (with_self $L - (n)) - (body $L $_ $_) $Body) - (append $Heads $Body $CL))) -; - + (= (reduce-get-current-clause $CL) + (findall + (with_self $H + (p)) + (head $H $_ $_) $Heads) + (findall + (with_self $L + (n)) + (body $L $_ $_) $Body) + (append $Heads $Body $CL)) ; -; - +; ********************************************************************* ; -; - +; * ; -; - +; * predicate: covered_clause/2 ; -; - +; * ; -; - +; * syntax: covered_clause(+RULES, +ID) ; -; - +; * ; -; - +; * args: RULES: list of kb references (integers) ; -; - +; * ID: id of clause to be tested ; -; - +; * ; -; - +; * description: Test, if a clause is a specialization of RULES. ; -; - +; * ; -; - +; * example: let RULES refer to clauses ; -; - +; * member(A,[A|B]). ; -; - +; * member(A,[B|C]):- member(A,C). ; -; - +; * then ; -; - +; * member(3,[1,2,3]):- member(3,[2,3]) ; -; - +; * is covered by RULES ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ******************************************************************** - (= - (covered-clause $RULES $ID) - ( (nonvar $RULES) (member $ID $RULES))) -; + (= (covered-clause $RULES $ID) + (nonvar $RULES) + (member $ID $RULES)) - - (= - (covered-clause $RULES $ID) + (= (covered-clause $RULES $ID) ( (nonvar $RULES) - (remove-all-symbols &self + (remove-all-atoms &self (assumption $_ $_ $_)) (get-clause $ID $_ $_ $Clause $_) (skolemize $Clause $_ @@ -703,96 +519,66 @@ (cover-assert-assumptions $Body) (prove5 $H $RULES) (set-det))) -; - ; -; - +; **************************************************************** ; -; - +; * ; -; - +; * predicate: covered_clauses/4 ; -; - +; * ; -; - +; * syntax: covered_clauses(+RULES,+ToTest,-Covered,-Uncovered) ; -; - +; * ; -; - +; * args: RULES: list of kb references (integers) ; -; - +; * ToTest: either label of kb entries (lgg, sat, ex ..) ; -; - +; * or a list of kb references ; -; - +; * description: test if RULES explain all example clauses ; -; - +; * denoted by ToTest. ; -; - +; * Or: RULES |= clauses(ToTest) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (covered-clauses $RULES $LABEL $Covered $Uncovered) - ( (nonvar $RULES) - (atom $LABEL) - (findall $ID - (get-clause $ID $_ $_ $_ $LABEL) $ToTest) - (covering $RULES $ToTest Nil $Covered Nil $Uncovered))) -; +; **************************************************************** - (= - (covered-clauses $RULES $ToTest $Covered $Uncovered) - ( (nonvar $RULES) - (is-list $ToTest) - (covering $RULES $ToTest Nil $Covered Nil $Uncovered))) -; + (= (covered-clauses $RULES $LABEL $Covered $Uncovered) + (nonvar $RULES) + (atom $LABEL) + (findall $ID + (get-clause $ID $_ $_ $_ $LABEL) $ToTest) + (covering $RULES $ToTest Nil $Covered Nil $Uncovered)) + (= (covered-clauses $RULES $ToTest $Covered $Uncovered) + (nonvar $RULES) + (is-list $ToTest) + (covering $RULES $ToTest Nil $Covered Nil $Uncovered)) - (= - (covering $RULES - (Cons $ID $ToTest) $Covered1 $Covered2 $Uncovered1 $Uncovered2) - ( (remove-all-symbols &self + (= (covering $RULES (Cons $ID $ToTest) $Covered1 $Covered2 $Uncovered1 $Uncovered2) + ( (remove-all-atoms &self (assumption $_ $_ $_)) (get-clause $ID $_ $_ $Clause $_) (not (or (member $ID $Covered1) (member $ID $Uncovered1))) @@ -821,422 +607,299 @@ (= $Uncovered3 (Cons $ID $Uncovered1))))) (covering $RULES $ToTest $Covered3 $Covered2 $Uncovered3 $Uncovered2))) -; - - (= - (covering $_ Nil $Covered $Covered $Uncovered $Uncovered) + (= (covering $_ Nil $Covered $Covered $Uncovered $Uncovered) (set-det)) -; - ; -; - +; *************************************************************** ; -; - +; * ; -; - +; * predicates: gen_msg/3/4 ; -; - +; * ; -; - +; * syntax: gen_msg(+ID1,+ID2,-ID) ; -; - +; * gen_msg(+ID1,+ID2,-ID,+Bound) ; -; - +; * ; -; - +; * args: ID1,ID2,ID:integers, references to clauses in kb ; -; - +; * Bound :integer, depth bound for saturation ; -; - +; * ; -; - +; * description: Approximation of Buntine's most specific ; -; - +; * generalization. We saturate the 2 input clauses ; -; - +; * & build the lgg over them. ; -; - +; * Our procedure differs from Buntine's in that ; -; - +; * saturation does not construct all generalizing ; -; - +; * clauses under generalized subsumption: if some ; -; - +; * head literal entailed by the body contains ; -; - +; * unbound variables, saturation adds it to the ; -; - +; * body as it is, whereas Buntine instead adds all ; -; - +; * of its ground instances. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: the resulting clause is not yet reduced ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *************************************************************** - (= - (gen-msg $ID1 $ID2 $ID) - ( (get-clause $ID1 $H1 $_ $_ $_) - (get-clause $ID2 $H2 $_ $_ $_) - (functor $H1 $F $N) - (functor $H2 $F $N) - (saturate $ID1 $A) - (saturate $ID2 $B) - (lgti $A $B $ID) - (delete-clause $A) - (delete-clause $B))) -; - - - (= - (gen-msg $ID1 $ID2 $ID $Bound) - ( (get-clause $ID1 $H1 $_ $C1 $_) - (get-clause $ID2 $H2 $_ $C2 $_) - (functor $H1 $F $N) - (functor $H2 $F $N) - (delete-clause $ID2) - (saturate $ID1 $A $Bound) - (delete-clause $ID1) - (get-clause $A $_ $_ $C1sat $_) - (delete-clause $A) - (store-clause $_ $C2 genmsg $ID2) - (saturate $ID2 $B $Bound) - (store-clause $_ $C1sat sat $A) - (delete-clause $ID2) - (nr-lgg $A $B $ID) - (delete-clause $A) - (delete-clause $B))) -; + (= (gen-msg $ID1 $ID2 $ID) + (get-clause $ID1 $H1 $_ $_ $_) + (get-clause $ID2 $H2 $_ $_ $_) + (functor $H1 $F $N) + (functor $H2 $F $N) + (saturate $ID1 $A) + (saturate $ID2 $B) + (lgti $A $B $ID) + (delete-clause $A) + (delete-clause $B)) +; ; lgg(A,B,ID), +; ; changed ! + (= (gen-msg $ID1 $ID2 $ID $Bound) + (get-clause $ID1 $H1 $_ $C1 $_) + (get-clause $ID2 $H2 $_ $C2 $_) + (functor $H1 $F $N) + (functor $H2 $F $N) + (delete-clause $ID2) + (saturate $ID1 $A $Bound) + (delete-clause $ID1) + (get-clause $A $_ $_ $C1sat $_) + (delete-clause $A) + (store-clause $_ $C2 genmsg $ID2) + (saturate $ID2 $B $Bound) + (store-clause $_ $C1sat sat $A) + (delete-clause $ID2) + (nr-lgg $A $B $ID) + (delete-clause $A) + (delete-clause $B)) +; ; lgti(A,B,ID). ; changed ! ; -; - +; *************************************************************** ; -; - +; * ; -; - +; * predicate: rllg/3/4 ; -; - +; * ; -; - +; * syntax: rllg(+ID1,+ID2,-ID) ; -; - +; * rllg(+ID1,+ID2,+PrefHead,-ID) ; -; - +; * ; -; - +; * args: ID1,ID2,ID: integers, references to clauses in kb ; -; - +; * PrefHead: MeTTa literal ; -; - +; * ; -; - +; * description: Plotkin's relative leat general generalization. ; -; - +; * Implementation thru Muggleton's alg. : ; -; - +; * Construct 2 inverse linear derivations, ; -; - +; * then build lgg over them. ; -; - +; * ; -; - +; * If PrefHead is given & it is possible to find ; -; - +; * a rllg who's head matches PrefHead, rllg will ; -; - +; * construct this clause. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: no reduction yet ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *************************************************************** - (= - (rlgg $ID1 $ID2 $ID) + (= (rlgg $ID1 $ID2 $ID) (rlgg $ID1 $ID2 $_ $ID)) -; - - - (= - (rlgg $ID1 $ID2 $PrefHead $ID) - ( (or - (get-clause $ID1 $_ $_ $Clause1 $_) - (, - (get-example $ID1 $Ex1 +) - (= $Clause1 - (:: (with_self $Ex1 (p)))))) - (clear-mngr) - (skolemize $Clause1 $S1 $C1) - (assert-clause $C1) - (inv-derivate1 $ID1 1) - (msg-build-long-clause $D1) - (deskolemize $D1 $S1 $A1) - (or - (get-clause $ID2 $_ $_ $Clause2 $_) - (, - (get-example $ID2 $Ex2 +) - (= $Clause2 - (:: (with_self $Ex2 (p)))))) - (clear-mngr) - (skolemize $Clause2 $S2 $C2) - (assert-clause $C2) - (inv-derivate1 $ID2 1) - (msg-build-long-clause $D2) - (deskolemize $D2 $S2 $A2) - (lgg-gen-clause $A1 $A2 $D $_ Nil Nil $_ $_) - (set-det) - (convert-to-horn-clause $PrefHead $D $E) - (truncate-unconnected $E $F) - (store-clause $_ $F rlgg $ID))) -; + (= (rlgg $ID1 $ID2 $PrefHead $ID) + (or + (get-clause $ID1 $_ $_ $Clause1 $_) + (, + (get-example $ID1 $Ex1 +) + (= $Clause1 + (:: (with_self $Ex1 (p)))))) + (clear-mngr) + (skolemize $Clause1 $S1 $C1) + (assert-clause $C1) + (inv-derivate1 $ID1 1) + (msg-build-long-clause $D1) + (deskolemize $D1 $S1 $A1) + (or + (get-clause $ID2 $_ $_ $Clause2 $_) + (, + (get-example $ID2 $Ex2 +) + (= $Clause2 + (:: (with_self $Ex2 (p)))))) + (clear-mngr) + (skolemize $Clause2 $S2 $C2) + (assert-clause $C2) + (inv-derivate1 $ID2 1) + (msg-build-long-clause $D2) + (deskolemize $D2 $S2 $A2) + (lgg-gen-clause $A1 $A2 $D $_ Nil Nil $_ $_) + (set-det) + (convert-to-horn-clause $PrefHead $D $E) + (truncate-unconnected $E $F) + (store-clause $_ $F rlgg $ID)) +; ; thru backtracking different +; ; heads may be obtained ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: subsumes_list/2 ; -; - +; * ; -; - +; * syntax: subsumes_list(+General,+Specific) ; -; - +; * ; -; - +; * args: clauses in list notation ; -; - +; * ; -; - +; * description: checks for theta subsumption by list matching. ; -; - +; * No proofs, no substitutions are returned. ; -; - +; * General will not be instantiated. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (subsumes-list $Gen $Spec) - ( (copy-term $Gen $Gen1) - (copy-term $Spec $Spec1) - (numbervars $Spec1 1 $_) - (subsumes-list1 $Gen1 $Spec1))) -; + (= (subsumes-list $Gen $Spec) + (copy-term $Gen $Gen1) + (copy-term $Spec $Spec1) + (numbervars $Spec1 1 $_) + (subsumes-list1 $Gen1 $Spec1)) - - (= - (subsumes_list1 () $_) True) -; - - (= - (subsumes-list1 - (Cons $L $Rest) $Spec) - ( (member $L $Spec) (subsumes-list1 $Rest $Spec))) -; - + (= (subsumes_list1 () $_) True) + (= (subsumes-list1 (Cons $L $Rest) $Spec) + (member $L $Spec) + (subsumes-list1 $Rest $Spec)) ; -; - +; ******************************************************************************** ; -; - +; * ; -; - +; * predicates: lgg_terms/3, lgg_terms/5, lgg_terms/7 ; -; - +; * ; -; - +; * syntax: lgg_terms( + Term1, + Term2, - GenTerm ) ; -; - +; * lgg_terms( + Term1, + Term2, - GenTerm, ; -; - +; * - Subst_Term1, - Subst_Term2 ) ; -; - +; * lgg_terms( + Term1, + Term2, - GenTerm, ; -; - +; * - Subst1, - Subst2, ; -; - +; * + Init_Subst1, + Init_Subst2 ) ; -; - +; * ; -; - +; * args: Term1,Term2,GenTerm: MeTTa terms ; -; - +; * Subst_termi: [Var/Fi,..] substitution such that Termi = GenTerm Subst_termi ; -; - +; * ; -; - +; * description: Plotkins least general generalisation wrt theta-subsumption ; -; - +; * on terms ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; +; ************************************************************************ - - (= - (lgg-terms $Term1 $Term2 $GTerm) + (= (lgg-terms $Term1 $Term2 $GTerm) (lgg-terms $Term1 $Term2 $GTerm $_ $_ Nil Nil)) -; - - (= - (lgg-terms $Term1 $Term2 $GTerm $Subst1 $Subst2) + (= (lgg-terms $Term1 $Term2 $GTerm $Subst1 $Subst2) (lgg-terms $Term1 $Term2 $GTerm $Subst1 $Subst2 Nil Nil)) -; - - (= - (lgg-terms $Term1 $Term2 $GTerm $S1 $S2 $Accu1 $Accu2) + (= (lgg-terms $Term1 $Term2 $GTerm $S1 $S2 $Accu1 $Accu2) (det-if-then-else (, (nonvar $Term1) @@ -1266,1361 +929,938 @@ (Cons (/ $NewVar $Term2) $Accu2)) (= $GTerm $NewVar)))))) -; - +; ; if same functor, same arity +; ; then: build new term by generalizing arguments +; ; else if same instantiation +; ; then: no problem +; ; else if substitution has already been applied +; ; then: again, no problem +; ; else if neither is true +; ; then: substitute with a new variable ; -; - +; generalize argument-terms (loop from position n to position 0) - (= - (generalize-arguments $_ $_ 0 $_ $Ac1 $Ac2 $Ac1 $Ac2) + (= (generalize-arguments $_ $_ 0 $_ $Ac1 $Ac2 $Ac1 $Ac2) (set-det)) -; - - (= - (generalize-arguments $Term1 $Term2 $N $GTerm $Ac1 $Ac2 $S1 $S2) - ( (arg $N $Term1 $ArgN1) - (arg $N $Term2 $ArgN2) - (arg $N $GTerm $ArgNG) - (lgg-terms $ArgN1 $ArgN2 $ArgNG $Ac1new $Ac2new $Ac1 $Ac2) - (is $K - (- $N 1)) - (generalize-arguments $Term1 $Term2 $K $GTerm $Ac1new $Ac2new $S1 $S2))) -; - + (= (generalize-arguments $Term1 $Term2 $N $GTerm $Ac1 $Ac2 $S1 $S2) + (arg $N $Term1 $ArgN1) + (arg $N $Term2 $ArgN2) + (arg $N $GTerm $ArgNG) + (lgg-terms $ArgN1 $ArgN2 $ArgNG $Ac1new $Ac2new $Ac1 $Ac2) + (is $K + (- $N 1)) + (generalize-arguments $Term1 $Term2 $K $GTerm $Ac1new $Ac2new $S1 $S2)) ; -; +; test whether two terms at the same position have already a common generalised term - - (= - (substituted - (Cons - (/ $X $T1) $_) - (Cons - (/ $X $T2) $_) $Term1 $Term2 $X) - ( (== $T1 $Term1) - (== $T2 $Term2) - (set-det))) -; - - (= - (substituted - (Cons $_ $Accu1) - (Cons $_ $Accu2) $Term1 $Term2 $X) + (= (substituted (Cons (/ $X $T1) $_) (Cons (/ $X $T2) $_) $Term1 $Term2 $X) + (== $T1 $Term1) + (== $T2 $Term2) + (set-det)) + (= (substituted (Cons $_ $Accu1) (Cons $_ $Accu2) $Term1 $Term2 $X) (substituted $Accu1 $Accu2 $Term1 $Term2 $X)) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: set_lgg/2 ; -; - +; * ; -; - +; * syntax: set_lgg(+List_of_Terms,-GenTerm) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: lgg of a list of terms ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; ************************************************************************ - - (= - (set-lgg - (:: $L) $L) + (= (set-lgg (:: $L) $L) (set-det)) -; - - (= + (= (set-lgg (Cons $X (Cons $Y $R)) $Lgg) + (lgg-terms $X $Y $Lgg0) (set-lgg - (Cons $X - (Cons $Y $R)) $Lgg) - ( (lgg-terms $X $Y $Lgg0) (set-lgg (Cons $Lgg0 $R) $Lgg))) -; - + (Cons $Lgg0 $R) $Lgg)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: headed_lgg/3, headed_lgg/4 ; -; - +; * ; -; - +; * syntax: headed_lgg(+ID1,+ID2,-IDG) ; -; - +; * headed_lgg(+ID1,_ID2,-IDG,?Label) ; -; - +; * ; -; - +; * args: ID1,ID2,IDG: clauseIDs, Label: atom ; -; - +; * ; -; - +; * description: returns lgg of clauses ID1 ID2 in IDG, if both clauses ; -; - +; * have a compatible head literal (i.e. same pred, same ; -; - +; * arity). Fails else. ; -; - +; * Default label is hlgg ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; ************************************************************************ - - (= - (headed-lgg $Id1 $Id2 $IdG) + (= (headed-lgg $Id1 $Id2 $IdG) (headed-lgg $Id1 $Id2 $IdG hlgg)) -; - - - (= - (headed-lgg $Id1 $Id2 $IdG $Label) - ( (det-if-then-else - (var $Label) - (= $Label hlgg) True) - (hlgg1 $Id1 $Id2 $HG $BGlist) - (reduce-complete - (Cons - (with_self $HG - (p)) $BGlist) - (Cons - (with_self $HGr - (p)) $BGlistred)) - (store-clause $_ - (Cons - (with_self $HGr - (p)) $BGlistred) $Label $IdG))) -; - + (= (headed-lgg $Id1 $Id2 $IdG $Label) + (det-if-then-else + (var $Label) + (= $Label hlgg) True) + (hlgg1 $Id1 $Id2 $HG $BGlist) + (reduce-complete + (Cons + (with_self $HG + (p)) $BGlist) + (Cons + (with_self $HGr + (p)) $BGlistred)) + (store-clause $_ + (Cons + (with_self $HGr + (p)) $BGlistred) $Label $IdG)) +; ; reduce_irene([HG:p|BGlist],[HGr:p|BGlistred]), +; ; finally reduce lgg-body ; reduce_approx([HG:p|BGlist],[HGr:p|BGlistred]),; alternatively (more efficient) - (= - (hlgg1 $Id1 $Id2 $HG $BGlist) - ( (get-clause $Id1 $H1 $_ - (Cons $_ $B1list) $_) - (get-clause $Id2 $H2 $_ - (Cons $_ $B2list) $_) - (functor $H1 $F $N) - (functor $H2 $F $N) - (lgg-terms $H1 $H2 $HG $Subst1 $Subst2) - (lgg-body $B1list $B2list $BGlist Nil $Subst1 $Subst2 $_ $_))) -; + (= (hlgg1 $Id1 $Id2 $HG $BGlist) + (get-clause $Id1 $H1 $_ + (Cons $_ $B1list) $_) + (get-clause $Id2 $H2 $_ + (Cons $_ $B2list) $_) + (functor $H1 $F $N) + (functor $H2 $F $N) + (lgg-terms $H1 $H2 $HG $Subst1 $Subst2) + (lgg-body $B1list $B2list $BGlist Nil $Subst1 $Subst2 $_ $_)) +; ; if name + arity match for both heads +; ; generalize heads first, +; ; then generalize bodies. ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: hnr_lgg/3, hnr_lgg/4 ; -; - +; * ; -; - +; * syntax: hnr_lgg(+ID1,+ID2,-IDG) ; -; - +; * hnr_lgg(+ID1,_ID2,-IDG,?Label) ; -; - +; * ; -; - +; * args: ID1,ID2,IDG: clauseIDs, Label: atom ; -; - +; * ; -; - +; * description: same as headed_lgg, except that the resulting generalised ; -; - +; * clause is NOT reduced. Default label is hnrlgg ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ************************************************************************ - (= - (hnr-lgg $Id1 $Id2 $IdG) + (= (hnr-lgg $Id1 $Id2 $IdG) (hnr-lgg $Id1 $Id2 $IdG hnrlgg)) -; - - - (= - (hnr-lgg $Id1 $Id2 $IdG $Label) - ( (det-if-then-else - (var $Label) - (= $Label hnrlgg) True) - (hlgg1 $Id1 $Id2 $HG $BGlist) - (store-clause $_ - (Cons - (with_self $HG - (p)) $BGlist) $Label $IdG))) -; + (= (hnr-lgg $Id1 $Id2 $IdG $Label) + (det-if-then-else + (var $Label) + (= $Label hnrlgg) True) + (hlgg1 $Id1 $Id2 $HG $BGlist) + (store-clause $_ + (Cons + (with_self $HG + (p)) $BGlist) $Label $IdG)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: lgg/3, lgg/4 ; -; - +; * ; -; - +; * syntax: lgg(+ID1,+ID2,-IDG) ; -; - +; * lgg(+ID1,_ID2,-IDG,?Label) ; -; - +; * ; -; - +; * args: ID1,ID2,IDG: clauseIDs, Label: atom ; -; - +; * ; -; - +; * description: returns lgg of clauses ID1 ID2 in IDG. If both clauses ; -; - +; * have no compatible head literal, the head literal of IDG ; -; - +; * is set to 'true'. ; -; - +; * Default label is lgg ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ************************************************************************ - (= - (lgg $Id1 $Id2 $IdG) + (= (lgg $Id1 $Id2 $IdG) (lgg $Id1 $Id2 $IdG lgg)) -; - - - (= - (lgg $Id1 $Id2 $IdG $Label) - ( (det-if-then-else - (var $Label) - (= $Label lgg) True) - (lgg1 $Id1 $Id2 $HG $BGlist) - (reduce-complete - (Cons - (with_self $HG - (p)) $BGlist) - (Cons - (with_self $HGr - (p)) $BGlistred)) - (store-clause $_ - (Cons - (with_self $HGr - (p)) $BGlistred) $Label $IdG))) -; + (= (lgg $Id1 $Id2 $IdG $Label) + (det-if-then-else + (var $Label) + (= $Label lgg) True) + (lgg1 $Id1 $Id2 $HG $BGlist) + (reduce-complete + (Cons + (with_self $HG + (p)) $BGlist) + (Cons + (with_self $HGr + (p)) $BGlistred)) + (store-clause $_ + (Cons + (with_self $HGr + (p)) $BGlistred) $Label $IdG)) +; ; reduce_irene([HG:p|BGlist],[HGr:p|BGlistred]), +; ; finally reduce lgg-body ; reduce_approx([HG:p|BGlist],[HGr:p|BGlistred]), ; alternatively (more efficient) - (= - (lgg1 $Id1 $Id2 $HG $BGlist) - ( (get-clause $Id1 $H1 $_ - (Cons $_ $B1list) $_) - (get-clause $Id2 $H2 $_ - (Cons $_ $B2list) $_) - (det-if-then-else - (, - (functor $H1 $F $N) - (functor $H2 $F $N)) - (lgg-terms $H1 $H2 $HG $Subst1 $Subst2) - (, - (= $HG True) - (= $Subst1 Nil) - (= $Subst2 Nil))) - (lgg-body $B1list $B2list $BGlist Nil $Subst1 $Subst2 $_ $_))) -; - + (= (lgg1 $Id1 $Id2 $HG $BGlist) + (get-clause $Id1 $H1 $_ + (Cons $_ $B1list) $_) + (get-clause $Id2 $H2 $_ + (Cons $_ $B2list) $_) + (det-if-then-else + (, + (functor $H1 $F $N) + (functor $H2 $F $N)) + (lgg-terms $H1 $H2 $HG $Subst1 $Subst2) + (, + (= $HG True) + (= $Subst1 Nil) + (= $Subst2 Nil))) + (lgg-body $B1list $B2list $BGlist Nil $Subst1 $Subst2 $_ $_)) +; ; if name + arity match for both heads +; ; then generalize heads, +; ; else use 'true' as head; +; ; then generalize bodies. ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: nr_lgg/3, nr_lgg/4 ; -; - +; * ; -; - +; * syntax: nr_lgg(+ID1,+ID2,-IDG) ; -; - +; * nr_lgg(+ID1,_ID2,-IDG,?Label) ; -; - +; * ; -; - +; * args: ID1,ID2,IDG: clauseIDs, Label: atom ; -; - +; * ; -; - +; * description: same as lgg, except that the resulting generalised ; -; - +; * clause is NOT reduced. Default label is nrlgg ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ************************************************************************ - (= - (nr-lgg $Id1 $Id2 $IdG) + (= (nr-lgg $Id1 $Id2 $IdG) (nr-lgg $Id1 $Id2 $IdG nrlgg)) -; - - - (= - (nr-lgg $Id1 $Id2 $IdG $Label) - ( (det-if-then-else - (var $Label) - (= $Label nrlgg) True) - (lgg1 $Id1 $Id2 $HG $BGlist) - (store-clause $_ - (Cons - (with_self $HG - (p)) $BGlist) $Label $IdG))) -; + (= (nr-lgg $Id1 $Id2 $IdG $Label) + (det-if-then-else + (var $Label) + (= $Label nrlgg) True) + (lgg1 $Id1 $Id2 $HG $BGlist) + (store-clause $_ + (Cons + (with_self $HG + (p)) $BGlist) $Label $IdG)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: buildlgg/4 ; -; - +; * ; -; - +; * syntax: build_lgg(+IDs,+IID,-GID,+Label) ; -; - +; * ; -; - +; * args: IDs: list of clauseIDs, ; -; - +; * IID,GID: clauseIDs ; -; - +; * Label: atom ; -; - +; * ; -; - +; * description: returns in GID the ID of the lgg of all clauses in IDs. IID is ; -; - +; * the ID of the intermediate result ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (buildlgg - (:: $C1) $C2 $Clgg $L) - ( (lgg $C1 $C2 $Clgg $L) (set-det))) -; + (= (buildlgg (:: $C1) $C2 $Clgg $L) + (lgg $C1 $C2 $Clgg $L) + (set-det)) - (= - (buildlgg - (Cons $C1 $CRest) $Clgg_old $Clgg_new2 $L) - ( (lgg $C1 $Clgg_old $Clgg_new1 tmp) - (set-det) - (det-if-then-else - (buildlgg $CRest $Clgg_new1 $Clgg_new2 $L) + (= (buildlgg (Cons $C1 $CRest) $Clgg_old $Clgg_new2 $L) + (lgg $C1 $Clgg_old $Clgg_new1 tmp) + (set-det) + (det-if-then-else + (buildlgg $CRest $Clgg_new1 $Clgg_new2 $L) + (delete-clause $Clgg_new1) + (, (delete-clause $Clgg_new1) - (, - (delete-clause $Clgg_new1) - (fail))))) -; - - - (= - (buildlgg Nil $O $N $L) - ( (get-clause $O $_ $_ $Cl $_) - (store-clause $_ $Cl $L $N) - (set-det))) -; + (fail)))) + (= (buildlgg Nil $O $N $L) + (get-clause $O $_ $_ $Cl $_) + (store-clause $_ $Cl $L $N) + (set-det)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: lgg/5, nr_lgg/5 ; -; - +; * ; -; - +; * syntax: (nr_)lgg(+CL1,+CL2,-CLG,-Subst1,-Subst2) ; -; - +; * ; -; - +; * args: CL1,CL2,CLG: clauses in list notation ; -; - +; * Substi: Substitutions such that CLG Substi \subseteq CLi ; -; - +; * ; -; - +; * description: CLG is (non-reduced) lgg of clauses CL1 and CL2 ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; ************************************************************************ - - (= - (lgg $Clause1list $Clause2list - (Cons $HGr $BGlistred) $S1 $S2) - ( (nr-lgg $Clause1list $Clause2list - (Cons $HG $BGlist) $SS1 $SS2) - (reduce-complete - (Cons $HG $BGlist) - (Cons $HGr $BGlistred)) - (clean-subst - (Cons $HGr $BGlistred) $SS1 $S1) - (clean-subst - (Cons $HGr $BGlistred) $SS2 $S2))) -; - + (= (lgg $Clause1list $Clause2list (Cons $HGr $BGlistred) $S1 $S2) + (nr-lgg $Clause1list $Clause2list + (Cons $HG $BGlist) $SS1 $SS2) + (reduce-complete + (Cons $HG $BGlist) + (Cons $HGr $BGlistred)) + (clean-subst + (Cons $HGr $BGlistred) $SS1 $S1) + (clean-subst + (Cons $HGr $BGlistred) $SS2 $S2)) +; ;Theta1, Theta2) :- +; ; reduce_irene([HG|BGlist],[HGr|BGlistred]). ; -; - +; reduce_approx([HG|BGlist],[HGr|BGlistred]), ;;alternatively (more efficient) - (= - (nr-lgg - (Cons - (with_self $H1 - (p)) $B1list) - (Cons - (with_self $H2 - (p)) $B2list) - (Cons - (with_self $HG - (p)) $BGlist) $Theta1 $Theta2) - ( (det-if-then-else - (, - (functor $H1 $F $N) - (functor $H2 $F $N)) - (lgg-terms $H1 $H2 $HG $Subst1 $Subst2) - (, - (= $HG True) - (= $Subst1 Nil) - (= $Subst2 Nil))) (lgg-body $B1list $B2list $BGlist Nil $Subst1 $Subst2 $Theta1 $Theta2))) -; - + (= (nr-lgg (Cons (with_self $H1 (p)) $B1list) (Cons (with_self $H2 (p)) $B2list) (Cons (with_self $HG (p)) $BGlist) $Theta1 $Theta2) + (det-if-then-else + (, + (functor $H1 $F $N) + (functor $H2 $F $N)) + (lgg-terms $H1 $H2 $HG $Subst1 $Subst2) + (, + (= $HG True) + (= $Subst1 Nil) + (= $Subst2 Nil))) + (lgg-body $B1list $B2list $BGlist Nil $Subst1 $Subst2 $Theta1 $Theta2)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: headed_lgg/5, hnr_lgg/5 ; -; - +; * ; -; - +; * syntax: headed_lgg(+CL1,+CL2,-CLG,-Subst1,-Subst2) ; -; - +; * hnr_lgg(+CL1,+CL2,-CLG,-Subst1,-Subst2) ; -; - +; * ; -; - +; * args: CL1,CL2,CLG: clauses in list notation ; -; - +; * Substi: Substitutions such that CLG Substi \subseteq CLi ; -; - +; * ; -; - +; * description: CLG is (non-reduced) headed lgg of clauses CL1 and CL2 ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; ************************************************************************ - (= - (headed-lgg $Clause1list $Clause2list - (Cons $HGr $BGlistred) $S1 $S2) - ( (hnr-lgg $Clause1list $Clause2list - (Cons $HG $BGlist) $SS1 $SS2) - (reduce-complete - (Cons $HG $BGlist) - (Cons $HGr $BGlistred)) - (clean-subst - (Cons $HGr $BGlistred) $SS1 $S1) - (clean-subst - (Cons $HGr $BGlistred) $SS2 $S2))) -; + (= (headed-lgg $Clause1list $Clause2list (Cons $HGr $BGlistred) $S1 $S2) + (hnr-lgg $Clause1list $Clause2list + (Cons $HG $BGlist) $SS1 $SS2) + (reduce-complete + (Cons $HG $BGlist) + (Cons $HGr $BGlistred)) + (clean-subst + (Cons $HGr $BGlistred) $SS1 $S1) + (clean-subst + (Cons $HGr $BGlistred) $SS2 $S2)) +; ;;;Theta1, Theta2) :- +; ; reduce_irene([HG|BGlist],[HGr|BGlistred]). ; -; +; reduce_approx([HG|BGlist],[HGr|BGlistred]), ;;alternatively (more efficient) - - (= - (hnr-lgg - (Cons - (with_self $H1 - (p)) $B1list) - (Cons - (with_self $H2 - (p)) $B2list) - (Cons - (with_self $HG - (p)) $BGlist) $Theta1 $Theta2) - ( (functor $H1 $F $N) - (functor $H2 $F $N) - (lgg-terms $H1 $H2 $HG $Subst1 $Subst2) - (lgg-body $B1list $B2list $BGlist Nil $Subst1 $Subst2 $Theta1 $Theta2))) -; - + (= (hnr-lgg (Cons (with_self $H1 (p)) $B1list) (Cons (with_self $H2 (p)) $B2list) (Cons (with_self $HG (p)) $BGlist) $Theta1 $Theta2) + (functor $H1 $F $N) + (functor $H2 $F $N) + (lgg-terms $H1 $H2 $HG $Subst1 $Subst2) + (lgg-body $B1list $B2list $BGlist Nil $Subst1 $Subst2 $Theta1 $Theta2)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: lgg_body/8 ; -; - +; * ; -; - +; * syntax: lgg_body(+CL1,+CL2,+CLAccu,-CLAccu,+Subst1,+Subst2,-Subst1,-Subst2) ; -; - +; * ; -; - +; * args: CL1,CL2,CLAccu: clauses bodiesin list representation ; -; - +; * Subst..:Substitutions for the variables in CLAccu ; -; - +; * ; -; - +; * description: CLAccu is the non-reduced lgg of the clause bodies CL1 and ; -; - +; * CL2. The generalisation of two redundant literals L1:r, L2:r is ; -; - +; * marked as redundant LG:r. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ************************************************************************ - (= - (lgg-body Nil $_ $Accu $Accu $S1 $S2 $S1 $S2) + (= (lgg-body Nil $_ $Accu $Accu $S1 $S2 $S1 $S2) (set-det)) -; - - (= - (lgg-body $_ Nil $Accu $Accu $S1 $S2 $S1 $S2) + (= (lgg-body $_ Nil $Accu $Accu $S1 $S2 $S1 $S2) (set-det)) -; - - (= - (lgg-body - (Cons $Elem1 $R1) $List2 $Glist $AcGL $S1old $S2old $Theta1 $Theta2) - ( (generalize-elem $List2 $Elem1 $GLelem1 $S1old $S2old $S1new $S2new) - (append $AcGL $GLelem1 $AcGLnew) - (lgg-body $R1 $List2 $Glist $AcGLnew $S1new $S2new $Theta1 $Theta2))) -; - + (= (lgg-body (Cons $Elem1 $R1) $List2 $Glist $AcGL $S1old $S2old $Theta1 $Theta2) + (generalize-elem $List2 $Elem1 $GLelem1 $S1old $S2old $S1new $S2new) + (append $AcGL $GLelem1 $AcGLnew) + (lgg-body $R1 $List2 $Glist $AcGLnew $S1new $S2new $Theta1 $Theta2)) ; -; - +; *************************************************************** ; -; - +; * ; -; - +; * predicate: lgg_gen_clause/8 ; -; - +; * ; -; - +; * syntax: lgg_gen_clause(+CL1,+CL2,+CLAccu,-CLAccu,+Subst1, ; -; - +; * +Subst2,-Subst1,-Subst2) ; -; - +; * ; -; - +; * args: CL1,CL2,CLAccu: general clauses in list representation ; -; - +; * Subst..:Substitutions for the variables in CLAccu ; -; - +; * ; -; - +; * description: CLAccu is the lgg of CL1 and CL2 (non-reduced) ; -; - +; * CL1, CL2 might be non Horn ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *************************************************************** - - (= - (lgg-gen-clause Nil $_ $Accu $Accu $S1 $S2 $S1 $S2) + (= (lgg-gen-clause Nil $_ $Accu $Accu $S1 $S2 $S1 $S2) (set-det)) -; - - (= - (lgg-gen-clause $_ Nil $Accu $Accu $S1 $S2 $S1 $S2) + (= (lgg-gen-clause $_ Nil $Accu $Accu $S1 $S2 $S1 $S2) (set-det)) -; - - (= - (lgg-gen-clause - (Cons - (with_self $Elem1 $Sign1) $R1) $List2 $Glist $AcGL $S1old $S2old $Theta1 $Theta2) - ( (generalize-elem $List2 - (with_self $Elem1 $Sign1) $GLelem1 $S1old $S2old $S1new $S2new) - (append $AcGL $GLelem1 $AcGLnew) - (lgg-gen-clause $R1 $List2 $Glist $AcGLnew $S1new $S2new $Theta1 $Theta2))) -; - + (= (lgg-gen-clause (Cons (with_self $Elem1 $Sign1) $R1) $List2 $Glist $AcGL $S1old $S2old $Theta1 $Theta2) + (generalize-elem $List2 + (with_self $Elem1 $Sign1) $GLelem1 $S1old $S2old $S1new $S2new) + (append $AcGL $GLelem1 $AcGLnew) + (lgg-gen-clause $R1 $List2 $Glist $AcGLnew $S1new $S2new $Theta1 $Theta2)) ; -; - +; *************************************************************** ; -; - +; * ; -; - +; * predicate: generalize_elem/7 ; -; - +; * ; -; - +; * syntax: generalize_elem(+CL,+Lit:Sign,-GCL,+Subst1,+Subst2,-Subst1,-Subst2) ; -; - +; * ; -; - +; * args: CL,GCL: clauses in list notation ; -; - +; * GCL: clause in list notation ; -; - +; * Lit:Sign: literal and sign (in {p,n,r}) ; -; - +; * Subst..: Sustitutions for the variables in GCL ; -; - +; * ; -; - +; * description: for each literal L in CL matching Lit:Sign (i.e. same functor, arity ; -; - +; * and compatible sign), the lgg of L and Lit is added to GCL, and the ; -; - +; * subtitutions are extended accordingly ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *************************************************************** - (= - (generalize-elem Nil $_ Nil $S1 $S2 $S1 $S2) + (= (generalize-elem Nil $_ Nil $S1 $S2 $S1 $S2) (set-det)) -; - - (= - (generalize-elem - (Cons - (with_self $Elem1 $Sign1) $R1) - (with_self $Literal $Sign2) - (Cons - (with_self $GTerm $Sign) $RestGL) $S10 $S20 $S12 $S22) - ( (functor $Literal $F $N) - (functor $Elem1 $F $N) - (lgg-terms $Literal $Elem1 $GTerm $S11 $S21 $S10 $S20) + (= (generalize-elem (Cons (with_self $Elem1 $Sign1) $R1) (with_self $Literal $Sign2) (Cons (with_self $GTerm $Sign) $RestGL) $S10 $S20 $S12 $S22) + (functor $Literal $F $N) + (functor $Elem1 $F $N) + (lgg-terms $Literal $Elem1 $GTerm $S11 $S21 $S10 $S20) + (det-if-then-else + (, + (== $Sign1 p) + (== $Sign2 p)) + (= $Sign p) (det-if-then-else (, - (== $Sign1 p) - (== $Sign2 p)) - (= $Sign p) + (== $Sign1 r) + (== $Sign2 r)) + (= $Sign r) (det-if-then-else (, - (== $Sign1 r) - (== $Sign2 r)) - (= $Sign r) - (det-if-then-else + (== $Sign1 n) + (member $Sign2 + (:: n r))) + (= $Sign n) + (det-if-then (, - (== $Sign1 n) - (member $Sign2 - (:: n r))) - (= $Sign n) - (det-if-then - (, - (== $Sign1 r) - (== $Sign2 n)) - (= $Sign n))))) - (generalize-elem $R1 - (with_self $Literal $Sign2) $RestGL $S11 $S21 $S12 $S22) - (set-det))) -; - + (== $Sign1 r) + (== $Sign2 n)) + (= $Sign n))))) + (generalize-elem $R1 + (with_self $Literal $Sign2) $RestGL $S11 $S21 $S12 $S22) + (set-det)) - (= - (generalize-elem - (Cons $_ $R1) $Literal $RestGL $S1old $S2old $S1new $S2new) + (= (generalize-elem (Cons $_ $R1) $Literal $RestGL $S1old $S2old $S1new $S2new) (generalize-elem $R1 $Literal $RestGL $S1old $S2old $S1new $S2new)) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: gti/3, gti/5 ; -; - +; * ; -; - +; * syntax: gti(+C1,+C2,-C), gti(+C1,+C2,-C,-S1,-S2) ; -; - +; * ; -; - +; * args: C1,C2,C: clauses in list notation ; -; - +; * S1,S2: substitutions [ V1/Term1 , .... ] ; -; - +; * ; -; - +; * description: generalization thru intersection ; -; - +; * least general intersection ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: the resulting clause might be unconnected ; -; - +; * ( see connectedness.pl ) ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; ************************************************************************ - - (= - (gti $C1 $C2 $C) + (= (gti $C1 $C2 $C) (gti $C1 $C2 $C $S1 $S2)) -; - - - (= - (gti $Id1 $Id2 $ID $S1 $S2) - ( (integer $Id1) - (integer $Id2) - (set-det) - (get-clause $Id1 $_ $_ $C1 $_) - (get-clause $Id2 $_ $_ $C2 $_) - (gti $C1 $C2 $C $S1 $S2) - (store-clause $_ $C gti $ID))) -; + (= (gti $Id1 $Id2 $ID $S1 $S2) + (integer $Id1) + (integer $Id2) + (set-det) + (get-clause $Id1 $_ $_ $C1 $_) + (get-clause $Id2 $_ $_ $C2 $_) + (gti $C1 $C2 $C $S1 $S2) + (store-clause $_ $C gti $ID)) - (= - (gti - (Cons - (with_self $H1 - (p)) $C1) - (Cons - (with_self $H2 - (p)) $C2) - (Cons - (with_self $H - (p)) $C) $S1 $S2) - ( (lgg-terms $H1 $H2 $H $Phi1 $Phi2) (gti $C1 $C2 $C $Phi1 $Phi2 $S1 $S2))) -; + (= (gti (Cons (with_self $H1 (p)) $C1) (Cons (with_self $H2 (p)) $C2) (Cons (with_self $H (p)) $C) $S1 $S2) + (lgg-terms $H1 $H2 $H $Phi1 $Phi2) + (gti $C1 $C2 $C $Phi1 $Phi2 $S1 $S2)) + (= (gti () $_ () $S1 $S2 $S1 $S2) True) - (= - (gti () $_ () $S1 $S2 $S1 $S2) True) -; - - - (= - (gti - (Cons - (with_self $L1 $Sign1) $Rest1) $C2 - (Cons - (with_self $L $Sign) $Rest) $Phi1 $Phi2 $S1 $S2) - ( (nth1 $N $C2 - (with_self $L2 $Sign2) $Rest2) - (lgg-terms $L1 $L2 $L $Theta1 $Theta2 $Phi1 $Phi2) - (nonvar $L) - (| - (det-if-then - (, - (= $Sign1 r) - (= $Sign2 r)) - (= $Sign r)) - (det-if-then otherwise - (= $Sign n))) - (gti $Rest1 $Rest2 $Rest $Theta1 $Theta2 $S1 $S2))) -; - + (= (gti (Cons (with_self $L1 $Sign1) $Rest1) $C2 (Cons (with_self $L $Sign) $Rest) $Phi1 $Phi2 $S1 $S2) + (nth1 $N $C2 + (with_self $L2 $Sign2) $Rest2) + (lgg-terms $L1 $L2 $L $Theta1 $Theta2 $Phi1 $Phi2) + (nonvar $L) + (| + (det-if-then + (, + (= $Sign1 r) + (= $Sign2 r)) + (= $Sign r)) + (det-if-then otherwise + (= $Sign n))) + (gti $Rest1 $Rest2 $Rest $Theta1 $Theta2 $S1 $S2)) +; ; subtract L2 from C2 - (= - (gti - (Cons $_ $Rest1) $C2 $Rest $Phi1 $Phi2 $S1 $S2) - (gti $Rest1 $C2 $Rest $Phi1 $Phi2 $S1 $S2)) -; - + (= (gti (Cons $_ $Rest1) $C2 $Rest $Phi1 $Phi2 $S1 $S2) + (gti $Rest1 $C2 $Rest $Phi1 $Phi2 $S1 $S2)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: lgti/3, lgti/5, lgti/6 ; -; - +; * ; -; - +; * syntax: lgti(+C1,+C2,-C,-S1,-S2),lgti(+C1,+C2,-C,-S1,-S2,+Bound) ; -; - +; * ; -; - +; * args: C1,C2,C,S1,S2: see gti above ; -; - +; * Bound : pos. integer ; -; - +; * ; -; - +; * description: apply gti-operator Bound times ( default: Bound = 10 ). ; -; - +; * Return the longest resulting clause & substitutions. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (lgti $ID1 $ID2 $ID) - ( (integer $ID1) - (integer $ID2) - (set-det) - (lgti $ID1 $ID2 $C $_ $_ 10) - (or - (store-clause $_ $C lgti $ID) - (, - (delete-clause $ID) - (fail))))) -; + (= (lgti $ID1 $ID2 $ID) + (integer $ID1) + (integer $ID2) + (set-det) + (lgti $ID1 $ID2 $C $_ $_ 10) + (or + (store-clause $_ $C lgti $ID) + (, + (delete-clause $ID) + (fail)))) - (= - (lgti $C1 $C2 $C $S1 $S2) + (= (lgti $C1 $C2 $C $S1 $S2) (lgti $C1 $C2 $C $S1 $S2 10)) -; + (= (lgti $Id1 $Id2 $C $S1 $S2 $Bound) + (integer $Id1) + (integer $Id2) + (set-det) + (get-clause $Id1 $_ $_ $C1 $_) + (get-clause $Id2 $_ $_ $C2 $_) + (lgti $C1 $C2 $C $S1 $S2 $Bound)) - (= - (lgti $Id1 $Id2 $C $S1 $S2 $Bound) - ( (integer $Id1) - (integer $Id2) - (set-det) - (get-clause $Id1 $_ $_ $C1 $_) - (get-clause $Id2 $_ $_ $C2 $_) - (lgti $C1 $C2 $C $S1 $S2 $Bound))) -; - - - - (= - (lgti $C1 $C2 $C $S1 $S2 $Bound) - ( (integer $Bound) - (> $Bound 0) - (init-chart $C1 $C2 $Bound) - (set-det) - (chart $_ $_ $_ $_ $_ $_) - (findall $Comp - (chart $Comp $_ $_ $_ $_ $_) $Bag) - (once (maximum $Bag $MaxComp)) - (once (remove-symbol &self (chart $MaxComp $C $C1 $C2 $S1 $S2))))) -; + (= (lgti $C1 $C2 $C $S1 $S2 $Bound) + (integer $Bound) + (> $Bound 0) + (init-chart $C1 $C2 $Bound) + (set-det) + (chart $_ $_ $_ $_ $_ $_) + (findall $Comp + (chart $Comp $_ $_ $_ $_ $_) $Bag) + (once (maximum $Bag $MaxComp)) + (once (remove-is-symbol &self (chart $MaxComp $C $C1 $C2 $S1 $S2)))) !(dynamic (/ chart 6)) -; - - (= - (init-chart $C1 $C2 $Bound) - ( (remove-all-symbols &self + (= (init-chart $C1 $C2 $Bound) + ( (remove-all-atoms &self (chart_count $_)) - (add-symbol &self + (add-is-symbol &self (chart_count 1)) - (remove-all-symbols &self + (remove-all-atoms &self (chart $_ $_ $_ $_ $_ $_)) (set-det) (init-chart1 $C1 $C2 $Bound))) -; - - (= - (init-chart1 $C1 $C2 $Bound) - ( (gti $C1 $C2 $C $S1 $S2) - (once (, (complexity $C $Comp) (add-symbol &self (chart $Comp $C $C1 $C2 $S1 $S2)) (remove-symbol &self (chart_count $I)) (is $J (+ $I 1)) (add-symbol &self (chart_count $J)))) - (> $J $Bound))) -; - - - (= - (init-chart1 $_ $_ $_) - (set-det)) -; - ; -; + (= (init-chart1 $C1 $C2 $Bound) + (gti $C1 $C2 $C $S1 $S2) + (once (, (complexity $C $Comp) (add-is-symbol &self (chart $Comp $C $C1 $C2 $S1 $S2)) (remove-is-symbol &self (chart_count $I)) (is $J (+ $I 1)) (add-is-symbol &self (chart_count $J)))) + (> $J $Bound)) +; ; no backtracking thru this + (= (init-chart1 $_ $_ $_) + (set-det)) ; +; if there are less than Bound solutions. diff --git a/miles/miles.metta b/miles/miles.metta index 3bd2f50..2e891ba 100644 --- a/miles/miles.metta +++ b/miles/miles.metta @@ -1,90 +1,37 @@ +; (convert_to_metta_file miles $_459330 miles/miles.pl miles/miles.metta) !(ensure-loaded dmiles) -; - !(multifile (/ file-search-path 2)) -; - !(dynamic (/ file-search-path 2)) -; - !(ensure-loaded-if-exists (library prompt)) -; - !(ensure-loaded (home argument-types)) -; - !(ensure-loaded (home bu-basics)) -; - !(ensure-loaded (home clause-heads)) -; - !(ensure-loaded (home div-utils)) -; - !(ensure-loaded (home environment)) -; - !(ensure-loaded (home evaluation)) -; - !(ensure-loaded (home filter)) -; - !(ensure-loaded (home flatten)) -; - !(ensure-loaded (home g1-ops)) -; - !(ensure-loaded (home g2-ops)) -; - !(ensure-loaded (home interpreter)) -; - !(ensure-loaded (home kb)) -; - !(ensure-loaded (home lgg)) -; - !(ensure-loaded (home show-utils)) -; - !(ensure-loaded (home td-basic)) -; - !(ensure-loaded (home tdref-it)) -; - !(ensure-loaded (home var-utils)) -; - !(ensure-loaded (home newpred)) -; - !(ensure-loaded (home gencon)) -; - !(ensure-loaded (home gencon-instances/rul.pl)) -; - !(ensure-loaded (home gencon-instances/constrained-clauses.pl)) -; - !(ensure-loaded (home gencon-instances/foil.pl)) -; - - !((remove-all-symbols &self + !((remove-all-atoms &self (: interpreter - (depth_bound $_))) (add-symbol &self (: interpreter (depth_bound 10)))) -; - + (depth_bound $_))) (add-is-symbol &self (: interpreter (depth_bound 10)))) diff --git a/miles/newpred.metta b/miles/newpred.metta index 393cdcf..98c99be 100644 --- a/miles/newpred.metta +++ b/miles/newpred.metta @@ -1,19 +1,16 @@ +; (convert_to_metta_file newpred $_27198 miles/newpred.pl miles/newpred.metta) ; -; - +; MODULE newpred EXPORTS !(module newpred (:: (/ specialize-with-newpred 5) (/ specialize-with-newpred 7) (/ specialize-with-newpred 2) (/ is-newpred 1))) -; - ; -; - +; IMPORTS !(use-module (home kb) (:: @@ -22,760 +19,497 @@ (/ delete-clause 1) (/ store-clause 4) (/ store-ex 3))) -; - !(use-module (home var-utils) (:: (/ only-vars 2))) -; - !(use-module (home div-utils) (:: (/ mysetof 3))) -; - !(use-module (home td-basic) (:: (/ append-body 3))) -; - !(use-module (home interpreter) (:: (/ prooftrees 3))) -; - !(use-module (home environment) (:: (/ ask-for-ex 1))) -; - !(use-module (home argument-types) (:: (/ types-of 3) (/ type-restriction 2))) -; - !(use-module-if-exists (library basics) (:: (/ member 2))) -; - !(use-module-if-exists (library sets) (:: (/ intersection 3))) -; - !(use-module-if-exists (library strings) (:: (/ gensym 2))) -; - ; -; - +; METAPREDICATES ; -; - +; none ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: newpred.pl ; -; - +; * ; -; - +; * author: I.Stahl ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: specialize_with_newpred/1 ; -; - +; * ; -; - +; * syntax: specialize_with_newpred(+ID) ; -; - +; * ; -; - +; * args: ID .. Clause ID ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (specialize-with-newpred $ID - (, $ID $L)) + (= (specialize-with-newpred $ID (, $ID $L)) (mysetof (, $NC $Pos $Neg $TR) (specialize-with-newpred $ID $NC $Pos $Neg $TR) $L)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: specialize_with_newpred/5 ; -; - +; * ; -; - +; * syntax: specialize_with_newpred(+ID,-Newclause,-Pos,-Neg,-Typerestriction) ; -; - +; * ; -; - +; * args: ID .. Clause ID, Newclause.. specialized clause ; -; - +; * Pos.. positive examples for the new predicate ; -; - +; * Neg.. negative examples for the new predicate ; -; - +; * Typerestriction.. type restriction for the new predicate ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - (= - (specialize-with-newpred $ID $NC $P $N - (type-restriction $Newp2 $TR)) - ( (get-clause $ID $H $B $_ $_) - (get-evaluation $ID - (evaluation $_ $_ $Pos $_ $Neg $_ $_ $_ $_)) - (det-if-then-else - (or - (= $Pos Nil) - (= $Neg Nil)) fail - (, - (only-vars - (, $H $B) $Vars) - (types-of $Vars - (= $H $B) $TVars) - (clause-instances $Pos $ID $H $B $Vars $PV) - (clause-instances $Neg $ID $H $B $Vars $NV) - (reduce-newpred-args $Vars $Vars $PV $NV $Vars1 $P0 $N0) - (gensym newp $X) - (=.. $Newp - (Cons $X $Vars1)) - (make-newp-ex $P0 $X $P) - (make-newp-ex $N0 $X $N) - (append-body - (= $H $B) $Newp $NC) - (copy-term - (, $Vars1 $TVars $Newp) - (, $Vars2 $TVars2 $Newp2)) - (make-type-restriction $Vars2 $TVars2 $TR))))) -; +; *********************************************************************** + (= (specialize-with-newpred $ID $NC $P $N (type-restriction $Newp2 $TR)) + (get-clause $ID $H $B $_ $_) + (get-evaluation $ID + (evaluation $_ $_ $Pos $_ $Neg $_ $_ $_ $_)) + (det-if-then-else + (or + (= $Pos Nil) + (= $Neg Nil)) fail + (, + (only-vars + (, $H $B) $Vars) + (types-of $Vars + (= $H $B) $TVars) + (clause-instances $Pos $ID $H $B $Vars $PV) + (clause-instances $Neg $ID $H $B $Vars $NV) + (reduce-newpred-args $Vars $Vars $PV $NV $Vars1 $P0 $N0) + (gensym newp $X) + (=.. $Newp + (Cons $X $Vars1)) + (make-newp-ex $P0 $X $P) + (make-newp-ex $N0 $X $N) + (append-body + (= $H $B) $Newp $NC) + (copy-term + (, $Vars1 $TVars $Newp) + (, $Vars2 $TVars2 $Newp2)) + (make-type-restriction $Vars2 $TVars2 $TR)))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: specialize_with_newpred/7 ; -; - +; * ; -; - +; * syntax: specialize_with_newpred(+Clause,+CPos,+CNeg,-Newclause, ; -; - +; * -Pos,-Neg,-Typerestriction) ; -; - +; * ; -; - +; * args: Clause.. clause to be specialised with new predicate ; -; - +; * CPos,CNeg.. pos./neg. examples covered by the clause ; -; - +; * Newclause.. specialized clause ; -; - +; * Pos.. positive examples for the new predicate ; -; - +; * Neg.. negative examples for the new predicate ; -; - +; * Typerestriction.. type restriction for the new predicate ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - (= - (specialize-with-newpred - (= $H $B) $Pos $Neg $NC $P $N - (type-restriction $Newp2 $TR)) - ( (only-vars - (, $H $B) $Vars) - (types-of $Vars - (= $H $B) $TVars) - (clause-instances $Pos $ID $H $B $Vars $PV) - (clause-instances $Neg $ID $H $B $Vars $NV) - (reduce-newpred-args $Vars $Vars $PV $NV $Vars1 $P0 $N0) - (gensym newp $X) - (=.. $Newp - (Cons $X $Vars1)) - (make-newp-ex $P0 $X $P) - (make-newp-ex $N0 $X $N) - (append-body - (= $H $B) $Newp $NC) - (copy-term - (, $Vars1 $TVars $Newp) - (, $Vars2 $TVars2 $Newp2)) - (make-type-restriction $Vars2 $TVars2 $TR))) -; +; *********************************************************************** + (= (specialize-with-newpred (= $H $B) $Pos $Neg $NC $P $N (type-restriction $Newp2 $TR)) + (only-vars + (, $H $B) $Vars) + (types-of $Vars + (= $H $B) $TVars) + (clause-instances $Pos $ID $H $B $Vars $PV) + (clause-instances $Neg $ID $H $B $Vars $NV) + (reduce-newpred-args $Vars $Vars $PV $NV $Vars1 $P0 $N0) + (gensym newp $X) + (=.. $Newp + (Cons $X $Vars1)) + (make-newp-ex $P0 $X $P) + (make-newp-ex $N0 $X $N) + (append-body + (= $H $B) $Newp $NC) + (copy-term + (, $Vars1 $TVars $Newp) + (, $Vars2 $TVars2 $Newp2)) + (make-type-restriction $Vars2 $TVars2 $TR)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: clause_instances/5 ; -; - +; * ; -; - +; * syntax: clause_instances(+Covered,+ID,+Head,+Body,+Vars,-Varinstances) ; -; - +; * ; -; - +; * args: Covered.. examples covered by clause ID ; -; - +; * ID .. clauseID ; -; - +; * Head,Body.. of clause ID, Vars.. variables of clause ID ; -; - +; * Varinstances.. instantiations of the clause variables according ; -; - +; * to Covered. If Vars = [V1,..,Vn] and |Covered| = m, then ; -; - +; * Varinstances = [[I11,..,I1n],..,[Im1,..,Imn]] ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (clause_instances () $_ $_ $_ $_ ()) True) -; + (= (clause_instances () $_ $_ $_ $_ ()) True) + (= (clause-instances (Cons (with_self $ID $Ex) $R) $IDC $H $B $Vars (Cons $Vars1 $R1)) + (clause-instances $R $IDC $H $B $Vars $R1) + (copy-term + (, $H $B $Vars) + (, $Ex $B1 $Vars1)) + (prooftrees $ID success $Proofs) + (setof $PBody + (member + (:: $IDC $Ex $PBody) $Proofs) $Bodies) + (body-instances $Bodies $B1)) - (= - (clause-instances - (Cons - (with_self $ID $Ex) $R) $IDC $H $B $Vars - (Cons $Vars1 $R1)) - ( (clause-instances $R $IDC $H $B $Vars $R1) - (copy-term - (, $H $B $Vars) - (, $Ex $B1 $Vars1)) - (prooftrees $ID success $Proofs) - (setof $PBody - (member - (:: $IDC $Ex $PBody) $Proofs) $Bodies) - (body-instances $Bodies $B1))) -; + (= (body_instances () $_) True) + (= (body-instances (Cons $B $R) $B1) + (body-instances $R $B1) + (body-inst $B $B1)) - (= - (body_instances () $_) True) -; - - (= - (body-instances - (Cons $B $R) $B1) - ( (body-instances $R $B1) (body-inst $B $B1))) -; - - - - (= - (body-inst Nil True) + (= (body-inst Nil True) (set-det)) -; - - (= - (body-inst - (Cons - (:: $_ $B $_) $R) - (, $B $R1)) - ( (set-det) - (det-if-then-else - (not (ground $B)) - (ask-for-ex $B) True) - (body-inst $R $R1))) -; - - (= - (body-inst - (:: (:: $_ $B $_)) $B) + (= (body-inst (Cons (:: $_ $B $_) $R) (, $B $R1)) + (set-det) + (det-if-then-else + (not (ground $B)) + (ask-for-ex $B) True) + (body-inst $R $R1)) + (= (body-inst (:: (:: $_ $B $_)) $B) (det-if-then-else (not (ground $B)) (ask-for-ex $B) True)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: reduce_newpred_args/7 ; -; - +; * ; -; - +; * syntax: reduce_newpred_args(+Vars,+Vars,+PCovered,+Ncovered, ; -; - +; * -Vars,-PCovered,-NCovered) ; -; - +; * ; -; - +; * args: Vars.. argument variables of the new predicate, to be ; -; - +; * reduced ; -; - +; * PCovered,NCovered.. Instantiations of these argument ; -; - +; * variables according to the Pos/Neg examples covered ; -; - +; * by the clause ; -; - +; * ; -; - +; * description: discrimination based reduction ; -; - +; * ; -; - +; * see also: CHAMP/DBC ; -; - +; * ; -; - - +; *********************************************************************** - (= - (reduce_newpred_args () $Vars $PVars $NVars $Vars $PVars $NVars) True) -; - (= - (reduce-newpred-args - (Cons $X $R) $Vars $P $N $Vars2 $P2 $N2) - ( (remove-arg $X $Vars $Vars1 $P $P1 $N $N1) - (intersection $P1 $N1 Nil) - (reduce-newpred-args $R $Vars1 $P1 $N1 $Vars2 $P2 $N2))) -; - - (= - (reduce-newpred-args - (Cons $_ $R) $Vars $P $N $Vars2 $P2 $N2) + (= (reduce_newpred_args () $Vars $PVars $NVars $Vars $PVars $NVars) True) + (= (reduce-newpred-args (Cons $X $R) $Vars $P $N $Vars2 $P2 $N2) + (remove-arg $X $Vars $Vars1 $P $P1 $N $N1) + (intersection $P1 $N1 Nil) + (reduce-newpred-args $R $Vars1 $P1 $N1 $Vars2 $P2 $N2)) + (= (reduce-newpred-args (Cons $_ $R) $Vars $P $N $Vars2 $P2 $N2) (reduce-newpred-args $R $Vars $P $N $Vars2 $P2 $N2)) -; - - - (= - (remove-arg $X $Vars $Vars1 $P $P1 $N $N1) - ( (rem-arg $X $Vars $Vars1 1 $Pos) - (set-det) - (rem-ins $P $Pos $P1) - (rem-ins $N $Pos $N1))) -; + (= (remove-arg $X $Vars $Vars1 $P $P1 $N $N1) + (rem-arg $X $Vars $Vars1 1 $Pos) + (set-det) + (rem-ins $P $Pos $P1) + (rem-ins $N $Pos $N1)) - (= - (rem-arg $X - (Cons $Y $R) $R $Pos $Pos) - ( (== $X $Y) (set-det))) -; - - (= - (rem-arg $X - (Cons $Y $R) - (Cons $Y $R1) $Pos $Pos1) - ( (is $Pos0 - (+ $Pos 1)) (rem-arg $X $R $R1 $Pos0 $Pos1))) -; - - - - (= - (rem_ins () $_ ()) True) -; + (= (rem-arg $X (Cons $Y $R) $R $Pos $Pos) + (== $X $Y) + (set-det)) + (= (rem-arg $X (Cons $Y $R) (Cons $Y $R1) $Pos $Pos1) + (is $Pos0 + (+ $Pos 1)) + (rem-arg $X $R $R1 $Pos0 $Pos1)) - (= - (rem-ins - (Cons $V $R) $Pos - (Cons $V1 $R1)) - ( (rem-i $V 1 $Pos $V1) (rem-ins $R $Pos $R1))) -; + (= (rem_ins () $_ ()) True) + (= (rem-ins (Cons $V $R) $Pos (Cons $V1 $R1)) + (rem-i $V 1 $Pos $V1) + (rem-ins $R $Pos $R1)) - (= - (rem-i - (Cons $_ $R) $P $P $R) + (= (rem-i (Cons $_ $R) $P $P $R) (set-det)) -; - - (= - (rem-i - (Cons $X $R) $P $P1 - (Cons $X $R1)) - ( (is $P0 - (+ $P 1)) (rem-i $R $P0 $P1 $R1))) -; - + (= (rem-i (Cons $X $R) $P $P1 (Cons $X $R1)) + (is $P0 + (+ $P 1)) + (rem-i $R $P0 $P1 $R1)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: make_newp_ex/3 ; -; - +; * ; -; - +; * syntax: make_newp_ex(Varinstances,Newp_name,Newp_examples) ; -; - +; * ; -; - +; * args: Varinstances.. instantiations of the argument variables ; -; - +; * [[I11,..,I1n],..,[Im1,..,Imn]] ; -; - +; * Newp_examples [New_name(I11,..,I1n),..,Newp_name(Im1,..,Imn)] ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (make_newp_ex () $_ ()) True) -; - - (= - (make-newp-ex - (Cons $V $R) $X - (Cons $N $R1)) - ( (=.. $N - (Cons $X $V)) (make-newp-ex $R $X $R1))) -; + (= (make_newp_ex () $_ ()) True) + (= (make-newp-ex (Cons $V $R) $X (Cons $N $R1)) + (=.. $N + (Cons $X $V)) + (make-newp-ex $R $X $R1)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: make_type_restriction/4 ; -; - +; * ; -; - +; * syntax: make_type_restriction(+Newpvars,+Typed_clause_vars, ; -; - +; * -Type_restriction) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (make_type_restriction () $_ ()) True) -; +; *********************************************************************** - (= - (make-type-restriction - (Cons $X $R) $TVars - (Cons $T $R1)) - ( (make-type-restriction $R $TVars $R1) - (mtr $X $TVars $TN) - (=.. $T - (:: $TN $X)))) -; + (= (make_type_restriction () $_ ()) True) + (= (make-type-restriction (Cons $X $R) $TVars (Cons $T $R1)) + (make-type-restriction $R $TVars $R1) + (mtr $X $TVars $TN) + (=.. $T + (:: $TN $X))) - (= - (mtr $X - (Cons - (with_self $Y $T) $_) $T) - ( (== $X $Y) (set-det))) -; - - (= - (mtr $X - (Cons $_ $R) $T) + (= (mtr $X (Cons (with_self $Y $T) $_) $T) + (== $X $Y) + (set-det)) + (= (mtr $X (Cons $_ $R) $T) (mtr $X $R $T)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: is_newpred/1 ; -; - +; * ; -; - +; * syntax: is_newpred(+Pred_Name) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: checks whether Pred_Name is of the form 'newpXX' ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (is-newpred $Name) - ( (name $Name - (Cons $N - (Cons $E - (Cons $W - (Cons $P $_))))) (name newp (:: $N $E $W $P)))) -; + (= (is-newpred $Name) + (name $Name + (Cons $N + (Cons $E + (Cons $W + (Cons $P $_))))) + (name newp + (:: $N $E $W $P))) diff --git a/miles/show_utils.metta b/miles/show_utils.metta index f5f4aae..7134641 100644 --- a/miles/show_utils.metta +++ b/miles/show_utils.metta @@ -1,6 +1,6 @@ +; (convert_to_metta_file show_utils $_250172 miles/show_utils.pl miles/show_utils.metta) ; -; - +; MODULE show_utils EXPORTS !(module show-utils (:: @@ -18,717 +18,493 @@ (/ show-bodies 0) (/ pp-clause 1) (/ write-list 1))) -; - +; ; Show all clauses +; ; Show all examples +; ; Show one clause +; ; Show all names of predicates +; ; Show some clauses +; ; displays all available types +; ; Print all clauses to UNIX-file ; -; - +; IMPORTS !(use-module (home bu-basics) (:: (/ head 3) (/ body 3))) -; - !(use-module (home div-utils) (:: (/ make-unique 2) (/ mysetof 3))) -; - !(use-module (home kb) (:: (/ get-clause 5) (/ get-example 3))) -; - !(use-module (home argument-types) (:: (/ type-restriction 2))) -; - !(use-module-if-exists (library basics) (:: (/ nonmember 2) (/ member 2))) -; - ; -; - +; METAPREDICATES ; -; - +; none ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: show_utils.pl ; -; - +; * ; -; - +; * author: B.Jung, M.Mueller, I.Stahl, B.Tausend date:12/92 ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * description: various diplays predicates ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: show_kb/0 ; -; - +; * ; -; - +; * syntax: - ; -; - +; * ; -; - +; * args: none ; -; - +; * ; -; - +; * description: displays all clauses in kb asserted by known ; -; - +; * ; -; +; *********************************************************************** - - (= - (show-kb) - ( (get-clause $I $H $B $_ $O) - (show-kb-clause $I $H $B $O) - (fail))) -; - - (= - (show-kb) + (= (show-kb) + (get-clause $I $H $B $_ $O) + (show-kb-clause $I $H $B $O) + (fail)) + (= (show-kb) (set-det)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: print_kb/1 ; -; - +; * ; -; - +; * syntax: print_kb(+ File) ; -; - +; * ; -; - +; * args: File: name of a file ; -; - +; * ; -; - +; * description: prints kb to a file ; -; - +; * ; -; - +; *********************************************************************** - (= - (print-kb $Filename) - ( (tell $Filename) - (show-kb) - (told))) -; - + (= (print-kb $Filename) + (tell $Filename) + (show-kb) + (told)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: show_clause/1 ; -; - +; * ; -; - +; * syntax: show_clause(+ ID) ; -; - +; * ; -; - +; * args: ID: the ID of a clause ; -; - +; * ; -; - +; * description: displays the clause stored with ID ; -; - +; * ; -; - +; *********************************************************************** - (= - (show-clause $I) - ( (get-clause $I $H $B $_ $O) - (write $I) - (write : ) - (write '(by ') - (write $O) - (write )) - (portray-clause (= $H $B)) - (set-det))) -; - + (= (show-clause $I) + (get-clause $I $H $B $_ $O) + (write $I) + (write : ) + (write '(by ') + (write $O) + (write )) + (portray-clause (= $H $B)) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: show_clauses/1 ; -; - +; * ; -; - +; * syntax: show_clauses(+List_of_clauseIDs) ; -; - +; * ; -; - +; * args: +List_of_clauseIDs: a list of clause IDs ; -; - +; * ; -; - +; * description: displays each clause with ID in List_of_clauseIDs ; -; - +; * ; -; +; *********************************************************************** - - (= - (show-clauses Nil) + (= (show-clauses Nil) (set-det)) -; - - (= - (show-clauses (Cons $Id1 $Rest)) - ( (show-clause $Id1) - (nl) - (show-clauses $Rest))) -; - + (= (show-clauses (Cons $Id1 $Rest)) + (show-clause $Id1) + (nl) + (show-clauses $Rest)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: show_kb_clause/4 ; -; - +; * ; -; - +; * syntax: show_kb_clause(+I,+H,+B,+O) ; -; - +; * ; -; - +; * args: I: an ID in KB ; -; - +; * H: the head of a clause ; -; - +; * B: the body of a clause ; -; - +; * O: the label of a clause ; -; - +; * ; -; - +; * description: displays a clause H:-B, used for xm ; -; - +; * ; -; - - +; ************************************************************************ - (= - (show-kb-clause $I $H $B $O) - ( (format '~N~n% Clause ~w (label ~w)~n' - (:: $I $O)) - (not (not (, (guess-varnames (= $H $B)) (implode-varnames (= $H $B)) (portray-clause (= $H $B))))) - (set-det))) -; + (= (show-kb-clause $I $H $B $O) + (format '~N~n% Clause ~w (label ~w)~n' + (:: $I $O)) + (not (not (, (guess-varnames (= $H $B)) (implode-varnames (= $H $B)) (portray-clause (= $H $B))))) + (set-det)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate:show_names/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: none ; -; - +; * ; -; - +; * description: lists all predicate names available in the kb ; -; - +; * ; -; - +; *********************************************************************** - (= - (show-names) + (= (show-names) (show-names Nil)) -; - - (= - (show-names $Accu) - ( (get-clause $_ $H $_ $_ $_) - (functor $H $Name $_) - (nonmember $Name $Accu) - (format "~10|~a~n" $Name) - (set-det) - (show-names (Cons $Name $Accu)))) -; - - (= - (show-names $_) + (= (show-names $Accu) + (get-clause $_ $H $_ $_ $_) + (functor $H $Name $_) + (nonmember $Name $Accu) + (format "~10|~a~n" $Name) + (set-det) + (show-names (Cons $Name $Accu))) + (= (show-names $_) (set-det)) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: show_kb_part/2 ; -; - +; * ; -; - +; * syntax: show_kb_part(+From,+To) ; -; - +; * ; -; - +; * args: From: the min ID of KB entries to be shown ; -; - +; * To: the max ID of KB entries to be shown ; -; - +; * ; -; - +; * description: shows all clauses with From <= ID <= To ; -; - +; * ; -; +; ************************************************************************ - - (= - (show-kb-part $From $To) - ( (mysetof $I - (^ $H - (^ $B - (^ $S - (^ $O - (, - (get-clause $I $H $B $S $O) - (=< $From $I) - (>= $To $I)))))) $IDL) (show-clauses $IDL))) -; - + (= (show-kb-part $From $To) + (mysetof $I + (^ $H + (^ $B + (^ $S + (^ $O + (, + (get-clause $I $H $B $S $O) + (=< $From $I) + (>= $To $I)))))) $IDL) + (show-clauses $IDL)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: show_ex/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: none ; -; - +; * ; -; - +; * description: displays all examples in kb ; -; - +; * ; -; - - +; *********************************************************************** - (= - (show-ex) - ( (get-example $I $F $C) - (write 'Example ') - (write $I) - (write : ) - (write $F) - (write -> ) - (write $C) - (nl) - (fail))) -; - (= - (show-ex) + (= (show-ex) + (get-example $I $F $C) + (write 'Example ') + (write $I) + (write : ) + (write $F) + (write -> ) + (write $C) + (nl) + (fail)) + (= (show-ex) (set-det)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: show_heads/0, show_bodies/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: displays all intermediate heads/bodies stored by absorption, ; -; - +; * saturation,... in the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (show-heads) - ( (head $L $Flag $C) - (write (head $L $Flag $C)) - (nl) - (fail))) -; +; *********************************************************************** - (= show_heads True) -; + (= (show-heads) + (head $L $Flag $C) + (write (head $L $Flag $C)) + (nl) + (fail)) + (= show_heads True) - (= - (show-bodies) - ( (body $L $Flag $C) - (write (body $L $Flag $C)) - (nl) - (fail))) -; - - (= show_bodies True) -; - + (= (show-bodies) + (body $L $Flag $C) + (write (body $L $Flag $C)) + (nl) + (fail)) + (= show_bodies True) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: pp_clause/1 ; -; - +; * ; -; - +; * syntax: pp_clause(+CL) ; -; - +; * ; -; - +; * args: CL .. clause in list notation ; -; - +; * ; -; - +; * description: displays clause in list notation ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (pp_clause ()) True) -; - - (= - (pp-clause (Cons (with_self $H $S) $Rest)) - ( (write (with_self $H $S)) - (nl) - (pp-clause $Rest))) -; - + (= (pp_clause ()) True) + (= (pp-clause (Cons (with_self $H $S) $Rest)) + (write (with_self $H $S)) + (nl) + (pp-clause $Rest)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: write_list/1 ; -; - +; * ; -; - +; * syntax: write_list(+List) ; -; - +; * ; -; - +; * args: List: a list ; -; - +; * ; -; - +; * description: displays copy of a list after instantiating all terms ; -; - +; within the copy by $Var(N) ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (write_list ()) True) -; - - (= - (write-list (Cons $X0 $R)) - ( (copy-term $X0 $X) - (numbervars $X 0 $_) - (write $X) - (nl) - (write-list $R))) -; - + (= (write_list ()) True) + (= (write-list (Cons $X0 $R)) + (copy-term $X0 $X) + (numbervars $X 0 $_) + (write $X) + (nl) + (write-list $R)) ; (error ; (syntax_error operator_clash) ; (file miles/show_utils.pl 270 14 7417)) @@ -736,171 +512,119 @@ ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: show_kb_types/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: displays definitions of all types in the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - - - - (= - (show-kb-types) - ( (findall - (with_self $T $Def) - (, - (get-clause $_ $H $_ $_ type) - (=.. $H - (Cons $T $_)) - (findall - (= $H1 $B1) - (, - (get-clause $_ $H1 $B1 $_ type) - (=.. $H1 - (Cons $T $_))) $Def)) $Tlist0) - (make-unique $Tlist0 $Tlist) - (nl) - (write 'The following types are defined in the knowledge base:') - (nl) - (show-kb-types (Cons (with_self (is-symbol *) Nil) (Cons (with_self (number *) Nil) (Cons (with_self (symbolic *) Nil) $Tlist)))))) -; - +; *********************************************************************** - (= - (show_kb_types ()) True) -; - (= - (show-kb-types (Cons (with_self $T $Def) $R)) - ( (nl) - (write $T) - (write :) - (nl) - (show-kb-t $Def) - (show-kb-types $R))) -; + (= (show-kb-types) + (findall + (with_self $T $Def) + (, + (get-clause $_ $H $_ $_ type) + (=.. $H + (Cons $T $_)) + (findall + (= $H1 $B1) + (, + (get-clause $_ $H1 $B1 $_ type) + (=.. $H1 + (Cons $T $_))) $Def)) $Tlist0) + (make-unique $Tlist0 $Tlist) + (nl) + (write 'The following types are defined in the knowledge base:') + (nl) + (show-kb-types (Cons (with_self (is-symbol *) Nil) (Cons (with_self (number *) Nil) (Cons (with_self (symbolic *) Nil) $Tlist))))) + (= (show_kb_types ()) True) + (= (show-kb-types (Cons (with_self $T $Def) $R)) + (nl) + (write $T) + (write :) + (nl) + (show-kb-t $Def) + (show-kb-types $R)) - (= - (show_kb_t ()) True) -; - - (= - (show-kb-t (Cons $C $R)) - ( (numbervars $C 0 $_) - (write $C) - (nl) - (show-kb-t $R))) -; - + (= (show_kb_t ()) True) + (= (show-kb-t (Cons $C $R)) + (numbervars $C 0 $_) + (write $C) + (nl) + (show-kb-t $R)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: show_type_restrictions/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: displays all type restrictions in the kb ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (show-type-restrictions) - ( (type-restriction $M $A) - (numbervars - (, $M $A) 0 $_) - (nl) - (write 'type-restriction( ') - (write $M) - (write , ) - (write $A) - (write )) - (fail))) -; +; *********************************************************************** - (= show_type_restrictions True) -; + (= (show-type-restrictions) + (type-restriction $M $A) + (numbervars + (, $M $A) 0 $_) + (nl) + (write 'type-restriction( ') + (write $M) + (write , ) + (write $A) + (write )) + (fail)) + (= show_type_restrictions True) diff --git a/miles/td_basic.metta b/miles/td_basic.metta index 4402456..b4ec1db 100644 --- a/miles/td_basic.metta +++ b/miles/td_basic.metta @@ -1,6 +1,6 @@ +; (convert_to_metta_file td_basic $_51120 miles/td_basic.pl miles/td_basic.metta) ; -; - +; MODULE td_basic EXPORTS !(module td-basic (:: @@ -8,624 +8,408 @@ (/ vars-of-type 3) (/ enumerate-t 3) (/ append-body 3))) -; - ; -; - +; IMPORTS !(use-module (home argument-types) (:: (/ type-sub 2))) -; - ; -; - +; METAPREDICATES ; -; - +; none ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: td_basic.pl ; -; - +; * ; -; - +; * author: I.Stahl date:12/92 ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * description: basics for top-down induction ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: append_body/3 ; -; - +; * ; -; - +; * syntax: append_body(+Clause,+Literal,-Clause1) ; -; - +; * ; -; - +; * args: Clause,Clause1.. MeTTa clauses ; -; - +; * ; -; - +; * description: adds Literal to the end of the body of Clause ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (append-body - (= $H True) $B - (= $H $B)) + (= (append-body (= $H True) $B (= $H $B)) (set-det)) -; - - (= - (append-body - (= $H $B) $C - (= $H $B1)) - ( (set-det) (append-body $B $C $B1))) -; - - (= - (append-body - (, $A $B) $C - (, $A $D)) - ( (set-det) (append-body $B $C $D))) -; - - (= - (append_body $A $B - (, $A $B)) True) -; - + (= (append-body (= $H $B) $C (= $H $B1)) + (set-det) + (append-body $B $C $B1)) + (= (append-body (, $A $B) $C (, $A $D)) + (set-det) + (append-body $B $C $D)) + (= (append_body $A $B (, $A $B)) True) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: distribute_vars/3 ; -; - +; * ; -; - +; * syntax: distribute_vars(+PVars,+Terms,-DVars) ; -; - +; * ; -; - +; * args: PVars = [X:Tx|R]: terms X with types Tx in the new literal P ; -; - +; * Terms: all terms with their types in the clause C to be refined ; -; - +; * ; -; - +; * DVars = [X:Vx,...]: for each X in PVars a list of all type-matching ; -; - +; * variables Vx in Terms + an additional new variable ; -; - +; * ; -; - +; * description: computes DVars ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (distribute_vars () $_ ()) True) -; - - (= - (distribute-vars - (Cons - (with_self $X $Tx) $R) $V - (Cons - (with_self $X $Vx) $R1)) - ( (distribute-vars $R $V $R1) (vars-of-type $V $Tx $Vx))) -; + (= (distribute_vars () $_ ()) True) + (= (distribute-vars (Cons (with_self $X $Tx) $R) $V (Cons (with_self $X $Vx) $R1)) + (distribute-vars $R $V $R1) + (vars-of-type $V $Tx $Vx)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: vars_of_type/3 ; -; - +; * ; -; - +; * syntax: vars_of_type(+Terms,+Ty,-R2) ; -; - +; * ; -; - +; * args: Terms= [X:Tx|_]: terms X with types Tx in the clause C to be refined ; -; - +; * Ty: type Ty of an argument of the new literal ; -; - +; * R2: a list of all terms in C matching type Ty ; -; - +; * ; -; - +; * description: adds a term X of Terms to R2 if type Ty subsumes type ; -; - +; * of X or vice versa ; -; - +; * and one new term (last element in R2) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (vars_of_type () $_ - ($_)) True) -; - - (= - (vars-of-type - (Cons - (with_self $X $Tx) $R) $Ty $R2) - ( (vars-of-type $R $Ty $R1) (det-if-then-else (or (type-sub $Ty $Tx) (type-sub $Tx $Ty)) (= $R2 (Cons $X $R1)) (= $R2 $R1)))) -; - + (= (vars_of_type () $_ ($_)) True) + (= (vars-of-type (Cons (with_self $X $Tx) $R) $Ty $R2) + (vars-of-type $R $Ty $R1) + (det-if-then-else + (or + (type-sub $Ty $Tx) + (type-sub $Tx $Ty)) + (= $R2 + (Cons $X $R1)) + (= $R2 $R1))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: enumerate_t/3 ; -; - +; * ; -; - +; * syntax: enumerate_t(+DVars,+PL,-PL2) ; -; - +; * ; -; - +; * args: DVars = [X:Vx,...]: all variables X in the new literal ; -; - +; * with their type-matching variables in C ; -; - +; * PL: initial predicate list ; -; - +; * ; -; - +; * PL2: predicate list ; -; - +; * ; -; - +; * description: computes predicates P where variables in Vx are unified to X in P ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (enumerate_t () $PL $PL) True) -; - - (= - (enumerate-t - (Cons - (with_self $X $Vx) $R) $PL $PL2) - ( (enumerate-t $R $PL $PL1) (et $Vx $X $PL1 $PL2))) -; + (= (enumerate_t () $PL $PL) True) + (= (enumerate-t (Cons (with_self $X $Vx) $R) $PL $PL2) + (enumerate-t $R $PL $PL1) + (et $Vx $X $PL1 $PL2)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: et/4 ; -; - +; * ; -; - +; * syntax: et(+Vx,+X,+PL,-PL3) ; -; - +; * ; -; - +; * args: Vx: a list of variables to be unified with X ; -; - +; * X: a term of P to be unified by a variable of Vx ; -; - +; * PL: initial predicate list ; -; - +; * ; -; - +; * PL3: predicate list ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (et () $_ $_ ()) True) -; - - (= - (et - (Cons $Y $R) $X $PL $PL3) - ( (et $R $X $PL $PL1) - (etx $PL $X $Y $PL2) - (append $PL2 $PL1 $PL3))) -; - + (= (et () $_ $_ ()) True) + (= (et (Cons $Y $R) $X $PL $PL3) + (et $R $X $PL $PL1) + (etx $PL $X $Y $PL2) + (append $PL2 $PL1 $PL3)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: etx/4 ; -; - +; * ; -; - +; * syntax: etx(PL,X,Y,R2) ; -; - +; * ; -; - +; * args: PL: literals of P ; -; - +; * X: a term of P to be unified by Y ; -; - +; * Y: a term of the clause C to be unfied with X ; -; - +; * ; -; - +; * R2: predicate list where X and Y are unified ; -; - +; * ; -; - +; * description: (if Y is not in args(P) then ) "unify" X and Y. This is ; -; - +; * done by copying P and replacing X by Y. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (etx () $_ $_ ()) True) -; +; *********************************************************************** - (= - (etx - (Cons $P $R) $X $Y $R2) - ( (etx $R $X $Y $R1) - (functor $P $F $N) - (functor $P1 $F $N) - (etx1 $N $P $P1 $X $Y) - (= $R2 - (Cons $P1 $R1)))) -; + (= (etx () $_ $_ ()) True) + (= (etx (Cons $P $R) $X $Y $R2) + (etx $R $X $Y $R1) + (functor $P $F $N) + (functor $P1 $F $N) + (etx1 $N $P $P1 $X $Y) + (= $R2 + (Cons $P1 $R1))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: etx1/5 ; -; - +; * ; -; - +; * syntax: etx1(+N,+P,-P1,+X,+Y) ; -; - +; * ; -; - +; * args: N: arity of literal P ; -; - +; * P: literal to be added ; -; - +; * X: variable to be replaced by Y ; -; - +; * Y: variable ; -; - +; * ; -; - +; * description: replaces X by Y in the copy P1 of P ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (etx1 0 $_ $_ $_ $_) + (= (etx1 0 $_ $_ $_ $_) (set-det)) -; - - (= - (etx1 $N $P $P1 $X $Y) - ( (is $N1 - (- $N 1)) - (etx1 $N1 $P $P1 $X $Y) - (arg $N $P $Pn) - (det-if-then-else - (== $Pn $X) - (arg $N $P1 $Y) - (arg $N $P1 $Pn)))) -; - + (= (etx1 $N $P $P1 $X $Y) + (is $N1 + (- $N 1)) + (etx1 $N1 $P $P1 $X $Y) + (arg $N $P $Pn) + (det-if-then-else + (== $Pn $X) + (arg $N $P1 $Y) + (arg $N $P1 $Pn))) diff --git a/miles/tdref_it.metta b/miles/tdref_it.metta index 1df7036..7113027 100644 --- a/miles/tdref_it.metta +++ b/miles/tdref_it.metta @@ -1,6 +1,6 @@ +; (convert_to_metta_file tdref_it $_204458 miles/tdref_it.pl miles/tdref_it.metta) ; -; - +; MODULE tdref_it EXPORTS !(module tdref-it (:: @@ -12,1081 +12,758 @@ (/ refinement-add-body-literal 2) (/ refinement 2) (/ possible-body-literals 3))) -; - ; -; - +; IMPORTS !(use-module (home kb) (:: (/ get-clause 5) (/ get-evaluation 2) (/ get-predlist 1))) -; - !(use-module (home td-basic) (:: (/ distribute-vars 3) (/ enumerate-t 3) (/ append-body 3))) -; - !(use-module (home filter) (:: (/ noduplicate-symbols 1) (/ noduplicate-symbol 2) (/ select-var-sharing-lits 2))) -; - !(use-module (home div-utils) (:: (/ mysetof 3))) -; - !(use-module (home var-utils) (:: (/ typed-only-vars1 2) (/ clause-terms 2))) -; - !(use-module (home argument-types) (:: (/ compare-types 3) (/ types-of 3))) -; - !(use-module (home show-utils) (:: (/ write-list 1))) -; - ; -; - +; METAPREDICATES ; -; - +; none ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: tdref_it.pl ; -; - +; * ; -; - +; * author: I.Stahl date:12/92 ; -; - +; * ; -; - +; * changed: comments BT; 11/10/92 ; -; - +; * ; -; - +; * description: top-down refinement operators for Horn clauses ; -; - +; * work iteratively ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; * ; -; - +; *********************************************************************** ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicates: refinement_unify_variables/2, ; -; - +; * refinement_instantiate_variables/2, ; -; - +; * refinement_add_body_literal/2 ; -; - +; * ; -; - +; * syntax: refinement_...(+ClauseID,-(ClauseID,CL)) ; -; - +; * ; -; - +; * args: ClauseID ... ID of the clause to be specialized ; -; - +; * CL .... list of specialisations of Clause ; -; - +; * ; -; - +; * description: refines clause by unifying variables/instantiating ; -; - +; * variables with terms/adding a body literal. Returns ; -; - +; * list of specialised clauses ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** + (= (refinement-unify-variables $ID (, $ID $CL)) + (get-clause $ID $H $B $_ $_) + (= $C + (= $H $B)) + (clause-terms $C $Terms) + (types-of $Terms $C $TTerms) + (refinement-unify-variables $C $TTerms $CL)) - (= - (refinement-unify-variables $ID - (, $ID $CL)) - ( (get-clause $ID $H $B $_ $_) - (= $C - (= $H $B)) - (clause-terms $C $Terms) - (types-of $Terms $C $TTerms) - (refinement-unify-variables $C $TTerms $CL))) -; + (= (refinement-instantiate-variables $ID (, $ID $CL)) + (get-clause $ID $H $B $_ $_) + (= $C + (= $H $B)) + (clause-terms $C $Terms) + (types-of $Terms $C $TTerms) + (refinement-instantiate-variables $C $TTerms $CL)) - (= - (refinement-instantiate-variables $ID - (, $ID $CL)) - ( (get-clause $ID $H $B $_ $_) - (= $C - (= $H $B)) - (clause-terms $C $Terms) - (types-of $Terms $C $TTerms) - (refinement-instantiate-variables $C $TTerms $CL))) -; - - - - (= - (refinement-add-body-literal $ID - (, $ID $CL)) - ( (get-clause $ID $H $B $_ $_) - (= $C - (= $H $B)) - (clause-terms $C $Terms) - (types-of $Terms $C $TTerms) - (refinement-add-body-literal $C $TTerms $CL1) - (select-var-sharing-lits $CL1 $CL))) -; - + (= (refinement-add-body-literal $ID (, $ID $CL)) + (get-clause $ID $H $B $_ $_) + (= $C + (= $H $B)) + (clause-terms $C $Terms) + (types-of $Terms $C $TTerms) + (refinement-add-body-literal $C $TTerms $CL1) + (select-var-sharing-lits $CL1 $CL)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicates: refinement_unify_variables/3, ; -; - +; * refinement_instantiate_variables/3, ; -; - +; * refinement_add_body_literal/3 ; -; - +; * ; -; - +; * syntax: refinement_...(+Clause,+Terms,-CL) ; -; - +; * ; -; - +; * args: Clause ... the clause to be specialized ; -; - +; * Terms ... the terms that shall be used in refinement ; -; - +; * of the form [T:Type,...] ; -; - +; * CL .... list of specialisations of Clause ; -; - +; * ; -; - +; * description: refines clause by unifying variables/instantiating ; -; - +; * variables with terms/adding a body literal. Returns ; -; - +; * list of specialised clauses ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** + (= (refinement-unify-variables $C $T $CL) + (typed-only-vars1 $T $Vars) + (ref-unify-vars $C $Vars $Vars Nil $CL)) - (= - (refinement-unify-variables $C $T $CL) - ( (typed-only-vars1 $T $Vars) (ref-unify-vars $C $Vars $Vars Nil $CL))) -; + (= (refinement-instantiate-variables $C $T $CL) + (typed-only-vars1 $T $Vars) + (ref-instantiate-vars $C $Vars Nil $CL)) - (= - (refinement-instantiate-variables $C $T $CL) - ( (typed-only-vars1 $T $Vars) (ref-instantiate-vars $C $Vars Nil $CL))) -; - - - - (= - (refinement-add-body-literal $C $T $CL) + (= (refinement-add-body-literal $C $T $CL) (det-if-then-else (= $C - (= $_ $_)) + (= $_ $_)) (ref-add-body-literal $C $T Nil $CL) (ref-add-body-literal - (= $C True) $T Nil $CL))) -; - + (= $C True) $T Nil $CL))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicates: possible_body_literals/3 ; -; - +; * ; -; - +; * syntax: possible_body_literals(+Clause,+Terms,-LL) ; -; - +; * ; -; - +; * args: Clause ... the clause to be specialized ; -; - +; * Terms ... the terms that shall be used in refinement ; -; - +; * of the form [T:Type,...] ; -; - +; * LL .... list of literals that might be added ; -; - +; * ; -; - +; * description: Returns the list of literals that might be used to refine ; -; - +; * Clause ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (possible-body-literals $C $Terms $LL) - ( (get-predlist $Predlist) (enumerate-terms $Predlist $Terms $C Nil $LL))) -; + (= (possible-body-literals $C $Terms $LL) + (get-predlist $Predlist) + (enumerate-terms $Predlist $Terms $C Nil $LL)) ; -; - +; *********************************************************************** ; -; - +; * predicate: ref_unify_vars/5 ; -; - +; * syntax: ref_unify_vars(+C,+[X:T|R],+V,+CL,-CL2) ; -; - +; * ; -; - +; * args: C: the clause to be refined ; -; - +; * [X:T|R]: all variables with their types in C ; -; - +; * V: all variables X:T in C ; -; - +; * ; -; - +; * CL: initial clause set ; -; - +; * CL2: CL + copies of C where variables are unified ; -; - +; * ; -; - +; * description: unifies clause variables of the same type ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (ref_unify_vars $_ () $_ $CL $CL) True) -; - - (= - (ref-unify-vars $C - (Cons $X $R) $V $CL $CL2) - ( (ref-unify-vars $C $R $V $CL $CL1) (ref-unify-vars1 $C $X $V $CL1 $CL2))) -; + (= (ref_unify_vars $_ () $_ $CL $CL) True) + (= (ref-unify-vars $C (Cons $X $R) $V $CL $CL2) + (ref-unify-vars $C $R $V $CL $CL1) + (ref-unify-vars1 $C $X $V $CL1 $CL2)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: ref_unify_vars1/5 ; -; - +; * ; -; - +; * syntax: ref_unify_vars1(+C,+X:Tx,+[Y:Ty|R],+CL,-CL2) ; -; - +; * ; -; - +; * args: C: the clause to be refined ; -; - +; * X:Tx: variable X of type Tx in C ; -; - +; * [Y:Ty|R]: all variables Y:Ty in C ; -; - +; * ; -; - +; * CL: initial clause set ; -; - +; * CL2: copies of the clause C where X is unified with each ; -; - +; * matching Y ; -; - +; * ; -; - +; * description: makes copies of the clause C with unified variables ; -; - +; * if the type of the variables is can be matched ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (ref_unify_vars1 $_ $_ () $CL $CL) True) -; - - (= + (= (ref_unify_vars1 $_ $_ () $CL $CL) True) + (= (ref-unify-vars1 $C (with_self $X $Tx) (Cons (with_self $Y $Ty) $R) $CL $CL2) (ref-unify-vars1 $C - (with_self $X $Tx) - (Cons - (with_self $Y $Ty) $R) $CL $CL2) - ( (ref-unify-vars1 $C - (with_self $X $Tx) $R $CL $CL1) (det-if-then-else (, (compare-types $Tx $Ty $_) (@< $X $Y)) (, (copy-term (, $C $X $Y) (, $C1 $Z $Z)) (det-if-then-else (noduplicate-atoms $C1) (= $CL2 (Cons $C1 $CL1)) (= $CL2 $CL1))) (= $CL2 $CL1)))) -; - + (with_self $X $Tx) $R $CL $CL1) + (det-if-then-else + (, + (compare-types $Tx $Ty $_) + (@< $X $Y)) + (, + (copy-term + (, $C $X $Y) + (, $C1 $Z $Z)) + (det-if-then-else + (noduplicate-atoms $C1) + (= $CL2 + (Cons $C1 $CL1)) + (= $CL2 $CL1))) + (= $CL2 $CL1))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: ref_instantiate_vars/4 ; -; - +; * ; -; - +; * syntax: ref_instantiate_vars(+C,+[X:T|R]+CL,-CL2) ; -; - +; * ; -; - +; * args: C: the clause to be refined ; -; - +; * [X:T|R]: variables X of type T in C ; -; - +; * ; -; - +; * CL: initial clause set ; -; - +; * CL2: CL + copies of C where variables are instantiated ; -; - +; * ; -; - +; * description: instantiates variables by terms according to the ; -; - +; * variables' type ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** + (= (ref_instantiate_vars $_ () $CL $CL) True) + (= (ref-instantiate-vars $C (Cons (with_self $X $T) $R) $CL $CL2) + (ref-instantiate-vars $C $R $CL $CL1) + (=.. $H + (:: $T $X)) + (=.. $H1 + (:: $T $X1)) + (mysetof $H1 + (^ $I + (^ $B + (^ $BL + (^ $Lab + (, + (get-clause $I $H1 $B $BL $Lab) + (nonvar $X1)))))) $HL) + (ref-inst-vars $HL $H $C $HL1) + (append $HL1 $CL1 $CL2)) - (= - (ref_instantiate_vars $_ () $CL $CL) True) -; - - (= - (ref-instantiate-vars $C - (Cons - (with_self $X $T) $R) $CL $CL2) - ( (ref-instantiate-vars $C $R $CL $CL1) - (=.. $H - (:: $T $X)) - (=.. $H1 - (:: $T $X1)) - (mysetof $H1 - (^ $I - (^ $B - (^ $BL - (^ $Lab - (, - (get-clause $I $H1 $B $BL $Lab) - (nonvar $X1)))))) $HL) - (ref-inst-vars $HL $H $C $HL1) - (append $HL1 $CL1 $CL2))) -; - - - - (= - (ref_inst_vars () $_ $_ ()) True) -; - - (= - (ref-inst-vars - (Cons $H1 $R) $H $C $HL2) - ( (ref-inst-vars $R $H $C $HL1) (det-if-then-else (, (copy-term (, $H $C) (, $H1 $C1)) (noduplicate-atoms $C1)) (= $HL2 (Cons $C1 $HL1)) (= $HL2 $HL1)))) -; + (= (ref_inst_vars () $_ $_ ()) True) + (= (ref-inst-vars (Cons $H1 $R) $H $C $HL2) + (ref-inst-vars $R $H $C $HL1) + (det-if-then-else + (, + (copy-term + (, $H $C) + (, $H1 $C1)) + (noduplicate-atoms $C1)) + (= $HL2 + (Cons $C1 $HL1)) + (= $HL2 $HL1))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: ref_add_body_literal/4 ; -; - +; * ; -; - +; * syntax: ref_add_body_literal(+C,+Terms,+CL,-CL1) ; -; - +; * ; -; - +; * args: C: the clause to be refined ; -; - +; * [TT:T|R]: all terms TT and subterms with their types T in C ; -; - +; * ; -; - +; * CL: initial clause set ; -; - +; * CL2: CL + copies of C with additional body literals ; -; - +; * ; -; - +; * description: adds a body literal to C by ; -; - +; * - selecting all predicates with a type restriction contained in the kb ; -; - +; * - enumerating literals where (at least one) argument of the new ; -; - +; * literal is unfied with terms in the clause ; -; - +; * - for each literal L: copy C and L, append the copied ; -; - +; * literal to the copy of C and add the resulting clause to CL ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (ref-add-body-literal $C $Terms $CL $CL1) - ( (get-predlist $Predlist) - (enumerate-terms $Predlist $Terms $C Nil $L) - (add-to-bodies $L $C $CL $CL1))) -; + (= (ref-add-body-literal $C $Terms $CL $CL1) + (get-predlist $Predlist) + (enumerate-terms $Predlist $Terms $C Nil $L) + (add-to-bodies $L $C $CL $CL1)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: add_to_bodies/4 ; -; - +; * ; -; - +; * syntax: add_to_bodies(+[Lit|R],+C,+CL,-CL1) ; -; - +; * ; -; - +; * args: [Lit|R]: a set of literals Lit to be added to the body ; -; - +; * C: the clause to be refined ; -; - +; * ; -; - +; * CL: initial clause list ; -; - +; * CL1: CL + refined clauses ; -; - +; * ; -; - +; * description: adds each literal to a copy of C, if it is not ; -; - +; * duplicate in C ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (add_to_bodies () $_ $CL $CL) True) -; - - (= - (add-to-bodies - (Cons $Pred $R) $C $CL $CL2) - ( (add-to-bodies $R $C $CL $CL1) - (copy-term - (, $Pred $C) - (, $Pred1 - (= $H1 $B1))) - (det-if-then-else - (noduplicate-atom $Pred1 - (, $H1 $B1)) - (, - (append-body - (= $H1 $B1) $Pred1 $C2) - (= $CL2 - (Cons $C2 $CL1))) - (= $CL2 $CL1)))) -; + (= (add_to_bodies () $_ $CL $CL) True) + (= (add-to-bodies (Cons $Pred $R) $C $CL $CL2) + (add-to-bodies $R $C $CL $CL1) + (copy-term + (, $Pred $C) + (, $Pred1 + (= $H1 $B1))) + (det-if-then-else + (noduplicate-atom $Pred1 + (, $H1 $B1)) + (, + (append-body + (= $H1 $B1) $Pred1 $C2) + (= $CL2 + (Cons $C2 $CL1))) + (= $CL2 $CL1))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: enumerate_terms/5 ; -; - +; * ; -; - +; * syntax: enumerate_terms(+[P:PVars|R],+Terms,+C,+L,-L2) ; -; - +; * ; -; - +; * args: [P:PVars|R]: predicate P & its variables PVars=[PV1:Tpv1,...] ; -; - +; * Terms: all terms with types in C ; -; - +; * C: clause to be refined ; -; - +; * L: initial literal list ; -; - +; * ; -; - +; * L2: new literal list ; -; - +; * ; -; - +; * description: builds all literals from all predicates to be added by ; -; - +; * - collecting all variables that could be unified with any variable of PVars ; -; - +; * - building all literals with these variables replaced ; -; - +; * - eliminating all those literals that already occur in C ; -; - +; * - appending the literals to L2 ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (enumerate_terms () $_ $_ $L $L) True) -; - - (= - (enumerate-terms - (Cons - (with_self $P $PVars) $R) $V $C $L $L2) - ( (enumerate-terms $R $V $C $L $L1) - (distribute-vars $PVars $V $PVars1) - (enumerate-t $PVars1 - (:: $P) $Plist) - (append $Plist $L1 $L2))) -; + (= (enumerate_terms () $_ $_ $L $L) True) + (= (enumerate-terms (Cons (with_self $P $PVars) $R) $V $C $L $L2) + (enumerate-terms $R $V $C $L $L1) + (distribute-vars $PVars $V $PVars1) + (enumerate-t $PVars1 + (:: $P) $Plist) + (append $Plist $L1 $L2)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: refinement/2 ; -; - +; * ; -; - +; * syntax: refinement(+ID,-CL) ; -; - +; * ; -; - +; * args: ID: ID of a clause to be refined ; -; - +; * CL: a list with refinements of the clause with ID ; -; - +; * ; -; - +; * description: shapiro's general refinement operator for a clause ; -; - +; * with ID (all terms are eligible for refinement): ; -; - +; * if there are covered positive examples: ; -; - +; * - prepare for refinement: ; -; - +; * a list of all terms and subterms augmented by their types ; -; - +; * and a list of all variables in the clause with types ; -; - +; * - refine clause by ; -; - +; * - unifying variables within the clause ; -; - +; * - instantiating variables within the clause to terms ; -; - +; * - adding body literals. Only literals sharing at least a ; -; - +; * variable with clause ID are allowed. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (refinement $ID $CL) - ( (number $ID) - (set-det) - (get-clause $ID $H $B $_ $_) - (get-evaluation $ID - (evaluation $_ $_ $Pos $_ $_ $_ $_ $_ $_)) - (det-if-then-else - (== $Pos Nil) - (= $CL Nil) - (, - (clause-terms - (= $H $B) $Terms) - (types-of $Terms - (= $H $B) $TTerms) - (refinement-unify-variables - (= $H $B) $TTerms $CL0) - (refinement-instantiate-variables - (= $H $B) $TTerms $CL1) - (refinement-add-body-literal - (= $H $B) $TTerms $CL2) - (select-var-sharing-lits $CL2 $CL3) - (append $CL0 $CL1 $CL4) - (append $CL4 $CL3 $CL))))) -; - - - (= - (refinement - (= $H $B) $CL) - ( (clause-terms - (= $H $B) $Terms) - (types-of $Terms - (= $H $B) $TTerms) - (refinement-unify-variables - (= $H $B) $TTerms $CL0) - (refinement-instantiate-variables - (= $H $B) $TTerms $CL1) - (refinement-add-body-literal - (= $H $B) $TTerms $CL2) - (select-var-sharing-lits $CL2 $CL3) - (append $CL0 $CL1 $CL4) - (append $CL4 $CL3 $CL))) -; - + (= (refinement $ID $CL) + (number $ID) + (set-det) + (get-clause $ID $H $B $_ $_) + (get-evaluation $ID + (evaluation $_ $_ $Pos $_ $_ $_ $_ $_ $_)) + (det-if-then-else + (== $Pos Nil) + (= $CL Nil) + (, + (clause-terms + (= $H $B) $Terms) + (types-of $Terms + (= $H $B) $TTerms) + (refinement-unify-variables + (= $H $B) $TTerms $CL0) + (refinement-instantiate-variables + (= $H $B) $TTerms $CL1) + (refinement-add-body-literal + (= $H $B) $TTerms $CL2) + (select-var-sharing-lits $CL2 $CL3) + (append $CL0 $CL1 $CL4) + (append $CL4 $CL3 $CL)))) + + (= (refinement (= $H $B) $CL) + (clause-terms + (= $H $B) $Terms) + (types-of $Terms + (= $H $B) $TTerms) + (refinement-unify-variables + (= $H $B) $TTerms $CL0) + (refinement-instantiate-variables + (= $H $B) $TTerms $CL1) + (refinement-add-body-literal + (= $H $B) $TTerms $CL2) + (select-var-sharing-lits $CL2 $CL3) + (append $CL0 $CL1 $CL4) + (append $CL4 $CL3 $CL)) diff --git a/miles/var_utils.metta b/miles/var_utils.metta index f7d6f60..169f51a 100644 --- a/miles/var_utils.metta +++ b/miles/var_utils.metta @@ -1,6 +1,6 @@ +; (convert_to_metta_file var_utils $_473112 miles/var_utils.pl miles/var_utils.metta) ; -; - +; MODULE var_utils EXPORTS !(module var-utils (:: @@ -29,12 +29,9 @@ (/ clean-subst 3) (/ findargs 3) (/ allarg 4))) -; - ; -; - +; IMPORTS !(use-module (home div-utils) (:: @@ -46,33 +43,23 @@ (/ best 2) (/ subterm-at-position 4) (/ part-of-clause 2))) -; - !(use-module (home flatten) (:: (/ flatten-clause 2) (/ unflatten-clause 2))) -; - !(use-module (home filter) (:: (/ truncate-unconnected 2))) -; - !(use-module (home lgg) - (:: (/ lgg-terms 7))) -; - + (:: (/ lgg-terms 7))) !(use-module-if-exists (library basics) (:: (/ member 2) (/ nonmember 2) (/ memberchk 2))) -; - !(use-module-if-exists (library sets) (:: @@ -80,594 +67,396 @@ (/ subtract 3) (/ list-to-set 2) (/ intersection 3))) -; - !(use-module-if-exists (library strings) (:: (/ gensym 2) (/ string-append 3) (/ substring 4))) -; - !(use-module-if-exists (library occurs) (:: (/ sub-term 2) (/ contains-var 2))) -; - !(use-module-if-exists (library subsumes) (:: (/ variant 2))) -; - ; -; - +; METAPREDICATES ; -; - +; none ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * module: var_utils.pl ; -; - +; * ; -; - +; * author: B.Jung, M.Mueller, I.Stahl, B.Tausend date:12/92 ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * description: - utilities for variable and clause handling ; -; - +; * - determine relevant variables for predicate invention. ; -; - +; * - inverse_substitution ; -; - +; * - skolemization is a special substitution ; -; - +; * - replacement ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: vars/2 ; -; - +; * ; -; - +; * syntax: vars(+Term,-Vars) ; -; - +; * ; -; - +; * args: Term: any MeTTa term ; -; - +; * Vars: list of variables in Term ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: setof changed to mysetof (IS) ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (vars $Term $Vars) + (= (vars $Term $Vars) (mysetof $V (, (sub-term $V $Term) (var $V)) $Vars)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: clause_terms/2 ; -; - +; * ; -; - +; * syntax: clause_terms(+Clause,-Termlist) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: returns list of all non-ground terms in Clause ; -; - +; * ; -; - +; * example: clause_terms((p(f(X),a,g(Y,b)):- r(f(X),Y)), ; -; - +; * [f(X),X,g(Y,b),Y]) ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (clause-terms - (= $H $B) $L) - ( (set-det) - (functor $H $_ $N) - (terms $N $H Nil $L0) - (clause-terms $B $L0 $L))) -; - - (= - (clause-terms $H $L) - ( (functor $H $_ $N) (terms $N $H Nil $L))) -; - +; *********************************************************************** - (= - (clause-terms - (, $A $B) $L $L2) - ( (set-det) - (clause-terms $A $L $L1) - (clause-terms $B $L1 $L2))) -; - (= - (clause-terms $A $L $L1) - ( (functor $A $_ $N) (terms $N $A $L $L1))) -; + (= (clause-terms (= $H $B) $L) + (set-det) + (functor $H $_ $N) + (terms $N $H Nil $L0) + (clause-terms $B $L0 $L)) + (= (clause-terms $H $L) + (functor $H $_ $N) + (terms $N $H Nil $L)) + (= (clause-terms (, $A $B) $L $L2) + (set-det) + (clause-terms $A $L $L1) + (clause-terms $B $L1 $L2)) + (= (clause-terms $A $L $L1) + (functor $A $_ $N) + (terms $N $A $L $L1)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: terms/3,4 ; -; - +; * ; -; - +; * syntax: terms(+Term,+Accu,-Accu) ; -; - +; * terms(+Count,+Term,+Accu,-Accu) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: returns all non-ground subterms within Term ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (terms $V $L $L1) - ( (var $V) - (set-det) - (det-if-then-else - (identical-member $V $L) - (= $L1 $L) - (= $L1 - (Cons $V $L))))) -; - - (= - (terms $T $L $L1) - ( (functor $T $_ $N) (det-if-then-else (or (ground $T) (identical-member $T $L)) (= $L1 $L) (terms $N $T (Cons $T $L) $L1)))) -; +; *********************************************************************** - (= - (terms 0 $_ $L $L) + (= (terms $V $L $L1) + (var $V) + (set-det) + (det-if-then-else + (identical-member $V $L) + (= $L1 $L) + (= $L1 + (Cons $V $L)))) + (= (terms $T $L $L1) + (functor $T $_ $N) + (det-if-then-else + (or + (ground $T) + (identical-member $T $L)) + (= $L1 $L) + (terms $N $T + (Cons $T $L) $L1))) + + (= (terms 0 $_ $L $L) (set-det)) -; - - (= - (terms $N $T $L $L2) - ( (is $N1 - (- $N 1)) - (terms $N1 $T $L $L1) - (arg-quintus $N $T $Tn) - (terms $Tn $L1 $L2))) -; - + (= (terms $N $T $L $L2) + (is $N1 + (- $N 1)) + (terms $N1 $T $L $L1) + (arg-quintus $N $T $Tn) + (terms $Tn $L1 $L2)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: only_vars/2 ; -; - +; * ; -; - +; * syntax: only_vars(+Term,-Varlist) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: returns all variables within Term ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (only-vars $T $L) - ( (terms $T Nil $L1) (only-vars1 $L1 $L))) -; + (= (only-vars $T $L) + (terms $T Nil $L1) + (only-vars1 $L1 $L)) - (= - (only_vars1 () ()) True) -; - - (= - (only-vars1 - (Cons $X $R) - (Cons $X $R1)) - ( (var $X) - (set-det) - (only-vars1 $R $R1))) -; - - (= - (only-vars1 - (Cons $_ $R) $R1) + (= (only_vars1 () ()) True) + (= (only-vars1 (Cons $X $R) (Cons $X $R1)) + (var $X) + (set-det) + (only-vars1 $R $R1)) + (= (only-vars1 (Cons $_ $R) $R1) (only-vars1 $R $R1)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: typed_only_vars1/2 ; -; - +; * ; -; - +; * syntax: typed_only_vars1(+TypedTermlist,-TypedVarlist) ; -; - +; * ; -; - +; * args: TypedTermlist: [T:typeT,...] ; -; - +; * Vars: [Var:typeVar ; -; - +; * ; -; - +; * description: extracts each term T that is a variable ; -; - +; * from a list TypedTermlist of terms with type definition ; -; - +; * ; -; - +; * example: only_vars2([X:type16,Y:type14,f(Z):type23],[X:type16,Y:type14]) ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (typed_only_vars1 () ()) True) -; - (= - (typed-only-vars1 - (Cons - (with_self $X $T) $R) - (Cons - (with_self $X $T) $R1)) - ( (var $X) - (set-det) - (typed-only-vars1 $R $R1))) -; - - (= - (typed-only-vars1 - (Cons $_ $R) $R1) + (= (typed_only_vars1 () ()) True) + (= (typed-only-vars1 (Cons (with_self $X $T) $R) (Cons (with_self $X $T) $R1)) + (var $X) + (set-det) + (typed-only-vars1 $R $R1)) + (= (typed-only-vars1 (Cons $_ $R) $R1) (typed-only-vars1 $R $R1)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: replace/3 ; -; - +; * ; -; - +; * syntax: replace(+C1,+S1,-C2,-S2) ; -; - +; * ; -; - +; * args: C1, C2: clauses in list notation ; -; - +; * S1, S2: replacements [ X / Term, .. ] ; -; - +; * If all X's are variables, this is actually a ; -; - +; * substitution, but we also allow other terms. ; -; - +; * ; -; - +; * description: C2 is a copy of C1 with S1 applied. ; -; - +; * S2 is a copy of S1. ; -; - +; * ; -; - +; * example: replace( [p(A,B):p], [A/a], [p(a,D):p], [C/a]). ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (replace $C $S1 $D $S2) - ( (copy-term - (, $C $S1) - (, $E $S2)) (do-replace $E $S2 $D))) -; + (= (replace $C $S1 $D $S2) + (copy-term + (, $C $S1) + (, $E $S2)) + (do-replace $E $S2 $D)) + (= (do_replace () $_ ()) True) - (= - (do_replace () $_ ()) True) -; + (= (do-replace (Cons $L $More) $S (Cons $L1 $More1)) + (do-replace1 $L $S $L1) + (set-det) + (do-replace $More $S $More1)) - (= - (do-replace - (Cons $L $More) $S - (Cons $L1 $More1)) - ( (do-replace1 $L $S $L1) - (set-det) - (do-replace $More $S $More1))) -; - - - - (= - (do-replace1 $T1 $S $T2) + (= (do-replace1 $T1 $S $T2) (det-if-then-else (, (member @@ -682,122 +471,82 @@ (, (functor $T2 $F $N) (do-replace1 $N $T1 $T2 $S)))))) -; - - (= - (do_replace1 0 $_ $_ $_) True) -; + (= (do_replace1 0 $_ $_ $_) True) + (= (do-replace1 $N $T1 $T2 $S) + (arg-quintus $N $T1 $A) + (arg-quintus $N $T2 $B) + (do-replace1 $A $S $B) + (is $M + (- $N 1)) + (do-replace1 $M $T1 $T2 $S)) - (= - (do-replace1 $N $T1 $T2 $S) - ( (arg-quintus $N $T1 $A) - (arg-quintus $N $T2 $B) - (do-replace1 $A $S $B) - (is $M - (- $N 1)) - (do-replace1 $M $T1 $T2 $S))) -; - - - - (= - (arg-quintus $N $C $E) - ( (compound $C) (arg $N $C $E))) -; + (= (arg-quintus $N $C $E) + (compound $C) + (arg $N $C $E)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: inv_replace/4 ; -; - +; * ; -; - +; * syntax: inv_replace(+C1,+S1,-C2,-S2) ; -; - +; * ; -; - +; * args: C1, C2: clauses in list notation ; -; - +; * S1, S2: replacements [ X / Term, .. ] ; -; - +; * ; -; - +; * description: C2 is a copy of C1 with term of S1 replaced by ass. vars ; -; - +; * S2 is a copy of S1,s.t. vars(S2) in vars(C2). ; -; - +; * ; -; - +; * example: inv_replace( [p(a,B):p], [A/a], [p(C,D):p], [C/a]). ; -; - +; * ; -; - +; * peculiarities: this is not the inverse operation for replacement : ; -; - +; * We don't distinguish the between places of terms. ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (inv-replace $C $S1 $D $S2) - ( (copy-term - (, $C $S1) - (, $E $S2)) (do-inv-replace $E $S2 $D))) -; + (= (inv-replace $C $S1 $D $S2) + (copy-term + (, $C $S1) + (, $E $S2)) + (do-inv-replace $E $S2 $D)) - (= - (do_inv_replace () $_ ()) True) -; + (= (do_inv_replace () $_ ()) True) + (= (do-inv-replace (Cons $L $More) $S (Cons $L1 $More1)) + (do-inv-replace1 $L $S $L1) + (do-inv-replace $More $S $More1)) - (= - (do-inv-replace - (Cons $L $More) $S - (Cons $L1 $More1)) - ( (do-inv-replace1 $L $S $L1) (do-inv-replace $More $S $More1))) -; - - - (= - (do-inv-replace1 $T1 $S $T2) + (= (do-inv-replace1 $T1 $S $T2) (det-if-then-else (var $T1) (= $T1 $T2) @@ -812,110 +561,79 @@ (, (functor $T2 $F $N) (do-inv-replace1 $N $T1 $T2 $S)))))) -; - - - (= - (do_inv_replace1 0 $_ $_ $_) True) -; + (= (do_inv_replace1 0 $_ $_ $_) True) - (= - (do-inv-replace1 $N $T1 $T2 $S) - ( (arg-quintus $N $T1 $A) - (arg-quintus $N $T2 $B) - (do-inv-replace1 $A $S $B) - (is $M - (- $N 1)) - (do-inv-replace1 $M $T1 $T2 $S))) -; + (= (do-inv-replace1 $N $T1 $T2 $S) + (arg-quintus $N $T1 $A) + (arg-quintus $N $T2 $B) + (do-inv-replace1 $A $S $B) + (is $M + (- $N 1)) + (do-inv-replace1 $M $T1 $T2 $S)) - - (= - (do-inv-replace1 2 - (:: $T) $T2 $S) - ( (arg-quintus 2 $T2 Nil) (do-inv-replace1 1 (:: $T) $T2 $S))) -; - + (= (do-inv-replace1 2 (:: $T) $T2 $S) + (arg-quintus 2 $T2 Nil) + (do-inv-replace1 1 + (:: $T) $T2 $S)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: term_size/2 ; -; - +; * ; -; - +; * syntax: term_size(+Term,-Size) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: the folllowing code is a debugged copy from the Quintus library ; -; - +; * 'termdepth' ; -; - +; * term_size(+Term, ?Size) calculates the Size of a Term, defined ; -; - +; * to be the number of constant and function symbol occurrences in it. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (term-size $Term $Size) + (= (term-size $Term $Size) (det-if-then-else (var $Term) (= $Size 0) (, (functor $Term $F $Arity) (term-size $Arity $Term 1 $Size)))) -; +; /* nonvar(Term) */ +; ; Here was the bug +; ; " - - (= - (term-size $N $NonVar $SoFar $Size) + (= (term-size $N $NonVar $SoFar $Size) (det-if-then-else (=:= $N 0) (is $Size $SoFar) @@ -927,1695 +645,1135 @@ (is $M (- $N 1)) (term-size $M $NonVar $Accum $Size)))) -; - ; -; - +; *************************************************************************** ; -; - +; * ; -; - +; * predicate: contains_vars/2 ; -; - +; * ; -; - +; * syntax: contains_vars(+Term,+Terms) ; -; - +; * ; -; - +; * args: Term: any MeTTa term ; -; - +; * Vars: list of MeTTa terms (also variables) ; -; - +; * ; -; - +; * description: succeeds if all terms in Terms occur in Term ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (contains_vars () $_) True) -; - - (= - (contains-vars - (Cons $V $Vars) $Term) - ( (contains-var $V $Term) (contains-vars $Vars $Term))) -; + (= (contains_vars () $_) True) + (= (contains-vars (Cons $V $Vars) $Term) + (contains-var $V $Term) + (contains-vars $Vars $Term)) ; -; - +; *************************************************************************** ; -; - +; * ; -; - +; * predicate: flagged_contains_vars/3 ; -; - +; * ; -; - +; * syntax: flagged_contains_vars(+Term,+Terms,-Flag) ; -; - +; * ; -; - +; * args: Term: any MeTTa term, Flag in {true,false} ; -; - +; * Vars: list of MeTTa terms (also variables) ; -; - +; * ; -; - +; * description: returns true if all terms in Terms occur in Term, else false ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (flagged-contains-vars $Vars $Term True) - ( (contains-vars $Vars $Term) (set-det))) -; - - (= - (flagged_contains_vars $Vars $Term false) True) -; - + (= (flagged-contains-vars $Vars $Term True) + (contains-vars $Vars $Term) + (set-det)) + (= (flagged_contains_vars $Vars $Term false) True) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: inverse_substitute/2 ; -; - +; * ; -; - +; * syntax: inverse_substitute(+ClauseIn,-ClauseOut) ; -; - +; * ; -; - +; * args: clauses in list notation, i.e. [ head(A):p, b1(A):n, .. ] ; -; - +; * ; -; - +; * description: replace one term in ClauseIn by a variable. ; -; - +; * Thru backtracking all solutions can be obtained. ; -; - +; * Implementation: flatten Clause, ; -; - +; * truncate one literal, ; -; - +; * truncate unconnected literals, ; -; - +; * unflatten Clause. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: Since identical terms are represented only once in ; -; - +; * our flattening, we cannot tell between different ; -; - +; * places the terms appear at. ; -; - +; * ; -; - +; * see also: Muggleton,1988 ; -; - +; * ; -; - +; *********************************************************************** - (= - (inverse_substitute $Clause $Clause) True) -; - ; -; - - - (= - (inverse-substitute $ClauseIn $ClauseOut) - ( (flatten-clause $ClauseIn $C1) - (remove-type-literal $C1 $C2) - (truncate-unconnected $C2 $C3) - (unflatten-clause $C3 $ClauseOut))) -; + (= (inverse_substitute $Clause $Clause) True) ; +; empty inverse substitution + (= (inverse-substitute $ClauseIn $ClauseOut) + (flatten-clause $ClauseIn $C1) + (remove-type-literal $C1 $C2) + (truncate-unconnected $C2 $C3) + (unflatten-clause $C3 $ClauseOut)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: remove_type_literal/2 ; -; - +; * ; -; - +; * syntax: remove_type_literal(+CL,-CL1) ; -; - +; * ; -; - +; * args: CL,CL1: clause in list notation ; -; - +; * ; -; - +; * description: drop a "type literal" functor_p(...) ; -; - +; * the next rules allow to perform inverse substitutions on several terms, ; -; - +; * at the cost of an exploding search space. ; -; - +; * A better strategy is to trunacte literals one by one and ; -; - +; * only to truncate the promising clauses further. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (remove-type-literal - (Cons - (with_self $L_p - (n)) $More) $More) - ( (functor $L_p $F $_) (string-append $_ -p $F))) -; - + (= (remove-type-literal (Cons (with_self $L_p (n)) $More) $More) + (functor $L_p $F $_) + (string-append $_ -p $F)) +; ; drop this literal - (= - (remove-type-literal - (Cons - (with_self $L $S) $More) - (Cons - (with_self $L $S) $More1)) + (= (remove-type-literal (Cons (with_self $L $S) $More) (Cons (with_self $L $S) $More1)) (remove-type-literal $More $More1)) -; - +; ; drop another literal ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: inverse_substitute1/2 ; -; - +; * ; -; - +; * syntax: inverse_substitute1(+CL,-CL) ; -; - +; * ; -; - +; * args: CL,CL1: clauses in list notation ; -; - +; * ; -; - +; * description: this is an alternative approach without flattening ; -; - +; * it replaces terms by variables. ; -; - +; * (This does of course not work on flat clauses) ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (inverse-substitute1 $CLin $CLout) - ( (copy-term $CLin $CLin1) - (clist-to-prolog $CLin1 $Clause) - (mysetof - (with_self $Sub $Pos) - (, - (subterm-at-position $Clause $Sub Nil $Pos) - (not (part-of-clause $Sub $Clause)) - (nonvar $Sub)) $Sublist) - (isub1-list $Sublist $Sublist1) - (best $Sublist1 - (with_self $T $Positions)) - (do-inverse-sub1 $T $Positions $_ $Clause $Clause1) - (clist-to-prolog $CLout $Clause1) - (not (variant $CLout $CLin)))) -; - - +; *********************************************************************** - (= - (isub1_list () ()) True) -; - - (= - (isub1-list - (Cons - (with_self $T $Pos) $R) - (Cons - (with_self $T - (Cons $Pos $Pos1)) $R2)) - ( (isub1-l $T $R $R1 $Pos1) (isub1-list $R1 $R2))) -; + (= (inverse-substitute1 $CLin $CLout) + (copy-term $CLin $CLin1) + (clist-to-prolog $CLin1 $Clause) + (mysetof + (with_self $Sub $Pos) + (, + (subterm-at-position $Clause $Sub Nil $Pos) + (not (part-of-clause $Sub $Clause)) + (nonvar $Sub)) $Sublist) + (isub1-list $Sublist $Sublist1) + (best $Sublist1 + (with_self $T $Positions)) + (do-inverse-sub1 $T $Positions $_ $Clause $Clause1) + (clist-to-prolog $CLout $Clause1) + (not (variant $CLout $CLin))) +; ; this rule disallows variable renaming to constrain +; ; search space at the cost of incompleteness - (= - (isub1_l $_ () () ()) True) -; + (= (isub1_list () ()) True) + (= (isub1-list (Cons (with_self $T $Pos) $R) (Cons (with_self $T (Cons $Pos $Pos1)) $R2)) + (isub1-l $T $R $R1 $Pos1) + (isub1-list $R1 $R2)) - (= - (isub1-l $T - (Cons - (with_self $T1 $Pos) $R) $R2 $Pos1) - ( (isub1-l $T $R $R1 $Pos0) (det-if-then-else (== $T $T1) (, (= $R2 $R1) (= $Pos1 (Cons $Pos $Pos0))) (, (= $R2 (Cons (with_self $T1 $Pos) $R1)) (= $Pos1 $Pos0))))) -; + (= (isub1_l $_ () () ()) True) + (= (isub1-l $T (Cons (with_self $T1 $Pos) $R) $R2 $Pos1) + (isub1-l $T $R $R1 $Pos0) + (det-if-then-else + (== $T $T1) + (, + (= $R2 $R1) + (= $Pos1 + (Cons $Pos $Pos0))) + (, + (= $R2 + (Cons + (with_self $T1 $Pos) $R1)) + (= $Pos1 $Pos0)))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: do_inverse_substitute1/5 ; -; - +; * ; -; - +; * syntax: do_inverse_substitute(+Term,+Positions,+Var,+Clause,-Clause) ; -; - +; * ; -; - +; * args: Clause: MeTTa clause ; -; - +; * Term: the term in Clause to be replaced with variable Var ; -; - +; * Positions: list of positions of Term within Clause where it might ; -; - +; * be replaced. A position is a list of numbers ; -; - +; * ; -; - +; * description: replaces Term by a Var ; -; - +; * preference is to replace all occurrences of Term by Var; ; -; - +; * thru backtracking, clauses may be obtained where ; -; - +; * only some occurences of term are replaced. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (do_inverse_sub1 $_ () $_ $Clause $Clause) True) -; +; *********************************************************************** - (= - (do-inverse-sub1 $T - (Cons $P $R) $Var $Clause $Clause2) - ( (do-inverse-sub1 $T $R $Var $Clause $Clause1) (do-isub1 $T $P $Var $Clause1 $Clause2))) -; - (= - (do-inverse-sub1 $T - (Cons $_ $R) $Var $Clause $Clause1) + (= (do_inverse_sub1 $_ () $_ $Clause $Clause) True) + (= (do-inverse-sub1 $T (Cons $P $R) $Var $Clause $Clause2) + (do-inverse-sub1 $T $R $Var $Clause $Clause1) + (do-isub1 $T $P $Var $Clause1 $Clause2)) + (= (do-inverse-sub1 $T (Cons $_ $R) $Var $Clause $Clause1) (do-inverse-sub1 $T $R $Var $Clause $Clause1)) -; - - - - (= - (do_isub1 $_ () $Var $_ $Var) True) -; - (= - (do-isub1 $T - (Cons $P $R) $V $C $C1) - ( (functor $C $F $N) - (functor $C1 $F $N) - (do-isub-copy $N $P $C $C1) - (arg-quintus $P $C1 $C1p) - (arg-quintus $P $C $Cp) - (do-isub1 $T $R $V $Cp $C1p))) -; + (= (do_isub1 $_ () $Var $_ $Var) True) + (= (do-isub1 $T (Cons $P $R) $V $C $C1) + (functor $C $F $N) + (functor $C1 $F $N) + (do-isub-copy $N $P $C $C1) + (arg-quintus $P $C1 $C1p) + (arg-quintus $P $C $Cp) + (do-isub1 $T $R $V $Cp $C1p)) - (= - (do-isub-copy 0 $_ $_ $_) + (= (do-isub-copy 0 $_ $_ $_) (set-det)) -; - - (= - (do-isub-copy $N $P $C $C1) - ( (is $N1 - (- $N 1)) - (do-isub-copy $N1 $P $C $C1) - (det-if-then-else - (== $N $P) True - (, - (arg-quintus $N $C $Cn) - (arg-quintus $N $C1 $Cn))))) -; - + (= (do-isub-copy $N $P $C $C1) + (is $N1 + (- $N 1)) + (do-isub-copy $N1 $P $C $C1) + (det-if-then-else + (== $N $P) True + (, + (arg-quintus $N $C $Cn) + (arg-quintus $N $C1 $Cn)))) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: skolemize/3, deskolemize/3 ; -; - +; * ; -; - +; * syntax: skolemize(+Term1,-Subst,-Term2) ; -; - +; * ; -; - +; * args: Term1,Term2: arbiraty MeTTa terms ; -; - +; * Subst : substitution [ V1/t1, V2/t2, .. ] ; -; - +; * where Vi are variables, ti skolem atoms ; -; - +; * ; -; - +; * description: skolemization is a special substitution: all variables ; -; - +; * of Term1 are substituted by atoms. One keeps track of ; -; - +; * the substitution thru Subst. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: Rouveirol,1991: ITOU. ; -; - +; * ; -; - +; *********************************************************************** - (= - (skolemize $T1 $S $T2) + (= (skolemize $T1 $S $T2) (skolemize $T1 Nil $S $T2)) -; - - - (= - (skolemize $T1 $S $S $Sk_Atom) - ( (var $T1) - (already-skolem-covered $T1 $S $Sk_Atom) - (set-det))) -; - - (= - (skolemize $Var $S - (Cons - (/ $Var $Sk_Atom) $S) $Sk_Atom) - ( (var $Var) - (set-det) - (gensym sk-symbol $Sk_Atom))) -; - - (= - (skolemize $T1 $S1 $S2 $T2) - ( (functor $T1 $F $N) - (functor $T2 $F $N) - (skolemize $N $T1 $S1 $S2 $T2))) -; - - (= - (skolemize 0 $_ $S $S $_) True) -; - - (= - (skolemize $N $T $S1 $S2 $U) - ( (arg-quintus $N $T $Tn) - (arg-quintus $N $U $Un) - (skolemize $Tn $S1 $S3 $Un) - (is $M - (- $N 1)) - (skolemize $M $T $S3 $S2 $U))) -; + (= (skolemize $T1 $S $S $Sk_Atom) + (var $T1) + (already-skolem-covered $T1 $S $Sk_Atom) + (set-det)) + (= (skolemize $Var $S (Cons (/ $Var $Sk_Atom) $S) $Sk_Atom) + (var $Var) + (set-det) + (gensym sk-symbol $Sk_Atom)) + (= (skolemize $T1 $S1 $S2 $T2) + (functor $T1 $F $N) + (functor $T2 $F $N) + (skolemize $N $T1 $S1 $S2 $T2)) + (= (skolemize 0 $_ $S $S $_) True) + (= (skolemize $N $T $S1 $S2 $U) + (arg-quintus $N $T $Tn) + (arg-quintus $N $U $Un) + (skolemize $Tn $S1 $S3 $Un) + (is $M + (- $N 1)) + (skolemize $M $T $S3 $S2 $U)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: already_skolem_covered/3 ; -; - +; * ; -; - +; * syntax: already_skolem_covered(+Var,+Subst,-Skolem_atom) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: if Var has already been skolemized, i.e. Var:Skolem_atom in Subst, ; -; - +; * the corresponding Skolem_atom is returned ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: alter Name: already_covered ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (already-skolem-covered $Var - (Cons - (/ $Var1 $Sk_Atom) $_) $Sk_Atom) - ( (== $Var $Var1) (set-det))) -; + (= (already-skolem-covered $Var (Cons (/ $Var1 $Sk_Atom) $_) $Sk_Atom) + (== $Var $Var1) + (set-det)) - (= - (already-skolem-covered $Var - (Cons $_ $S) $Sk_Atom) - (already-skolem-covered $Var $S $Sk_Atom)) -; - + (= (already-skolem-covered $Var (Cons $_ $S) $Sk_Atom) + (already-skolem-covered $Var $S $Sk_Atom)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: deskolemize/3 ; -; - +; * ; -; - +; * syntax: deskolemize(+Term1,+Subst,-Term2) ; -; - +; * ; -; - +; * ; -; - +; * args: Term1,Term2: arbiraty MeTTa terms ; -; - +; * Subst : substitution [ V1/t1, V2/t2, .. ] ; -; - +; * where Vi are variables, ti skolem atoms ; -; - +; * description: Deskolemization reverses skolemization, if the ; -; - +; * skolem substitution is given as input. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (deskolemize $Sk_Atom $S $Var) - ( (atom $Sk_Atom) - (skolem-covered $Sk_Atom $S $Var) - (set-det))) -; - - (= - (deskolemize $Atom $_ $Atom) - ( (atomic $Atom) (set-det))) -; - - (= - (deskolemize $Var $S $Var) - ( (var $Var) (set-det))) -; +; *********************************************************************** - (= - (deskolemize $T1 $S $T2) - ( (functor $T1 $F $N) - (functor $T2 $F $N) - (deskolemize $N $T1 $S $T2))) -; - - (= - (deskolemize 0 $_ $_ $_) True) -; - - (= - (deskolemize $N $T $S $U) - ( (arg-quintus $N $T $Tn) - (arg-quintus $N $U $Un) - (deskolemize $Tn $S $Un) - (is $M - (- $N 1)) - (deskolemize $M $T $S $U))) -; + (= (deskolemize $Sk_Atom $S $Var) + (atom $Sk_Atom) + (skolem-covered $Sk_Atom $S $Var) + (set-det)) + (= (deskolemize $Atom $_ $Atom) + (atomic $Atom) + (set-det)) + (= (deskolemize $Var $S $Var) + (var $Var) + (set-det)) + (= (deskolemize $T1 $S $T2) + (functor $T1 $F $N) + (functor $T2 $F $N) + (deskolemize $N $T1 $S $T2)) + (= (deskolemize 0 $_ $_ $_) True) + (= (deskolemize $N $T $S $U) + (arg-quintus $N $T $Tn) + (arg-quintus $N $U $Un) + (deskolemize $Tn $S $Un) + (is $M + (- $N 1)) + (deskolemize $M $T $S $U)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: skolem_covered/3 ; -; - +; * ; -; - +; * syntax: skolem_covered(+Skolem_atom,+Subst,-Var) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: returns the variable that has been skolemized with Skolem_atom, ; -; - +; * i.e. Var/Skolem_atom in Subst ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: alter Name: covered ; -; - +; * ; -; - +; *********************************************************************** - (= - (skolem-covered $Sk_Atom - (Cons - (/ $Var $Sk_Atom) $_) $Var) + (= (skolem-covered $Sk_Atom (Cons (/ $Var $Sk_Atom) $_) $Var) (set-det)) -; - - (= - (skolem-covered $Sk_Atom - (Cons $_ $S) $Var) + (= (skolem-covered $Sk_Atom (Cons $_ $S) $Var) (skolem-covered $Sk_Atom $S $Var)) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: skolems/2 ; -; - +; * ; -; - +; * syntax: skolems(+Term,-Skolems) ; -; - +; * ; -; - +; * args: Term: skolemized term, Skolems: all skolem atoms in Term ; -; - +; * ; -; - +; * description: returns skolem atoms occuring in Term ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; *********************************************************************** - (= - (skolems $Term $Skolems) - ( (setof $Skolem - (^ $Len - (, - (sub-term $Skolem $Term) - (atom $Skolem) - (atom-concat sk-symbol $Rest $Skolem) - (atom-length $Rest $Len))) $Skolems) (set-det))) -; - - (= - (skolems $_ ()) True) -; + (= (skolems $Term $Skolems) + (setof $Skolem + (^ $Len + (, + (sub-term $Skolem $Term) + (atom $Skolem) + (atom-concat sk-symbol $Rest $Skolem) + (atom-length $Rest $Len))) $Skolems) + (set-det)) +; ; q_substring(Skolem,sk_atom,0,Len) + (= (skolems $_ ()) True) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: relevant_vars2/6 ; -; - +; * ; -; - +; * syntax: relevant_vars2(+C1,+C2,+Gen,+S1,+S2,-RelVars) ; -; - +; * ; -; - +; * args: C1,C2,Gen: clauses in list notation. C1,C2 at bottom of W. ; -; - +; * S1,S2: substitutions [V1=T1, .. ]. ; -; - +; * RelVars: list of vars [ V1, V2, .. ] ; -; - +; * ; -; - +; * description: determine relevant vars with CIGOL heuristics. ; -; - +; * A variable V in Gen is relevant if ; -; - +; * one of the terms T1, T2 it is substituted by in S1, S2 ; -; - +; * contains a variable that also appears elsewhere ; -; - +; * in S1 or S2. ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - - - (= - (relevant-vars2 $_ $_ $C $S1 $S2 $RelVars) - ( (vars $C $AllVars) (relevant-vars2 $AllVars $S1 $S2 $RelVars))) -; +; *********************************************************************** + (= (relevant-vars2 $_ $_ $C $S1 $S2 $RelVars) + (vars $C $AllVars) + (relevant-vars2 $AllVars $S1 $S2 $RelVars)) - (= - (relevant_vars2 () $_ $_ ()) True) -; + (= (relevant_vars2 () $_ $_ ()) True) - (= - (relevant-vars2 - (Cons $V $MoreVars) $S1 $S2 - (Cons $V $RelVars)) - ( (or - (, - (member - (/ $W $T1) $S1) - (== $V $W) - (member - (/ $X $T1a) $S1) - (\== $V $X) - (sub-term $Subterm1 $T1) - (var $Subterm1) - (contains-var $Subterm1 $T1a)) - (, - (member - (/ $W $T2) $S2) - (== $V $W) - (member - (/ $Y $T2a) $S2) - (\== $V $Y) - (sub-term $Subterm2 $T2) - (var $Subterm2) - (contains-var $Subterm2 $T2a))) - (set-det) - (relevant-vars2 $MoreVars $S1 $S2 $RelVars))) -; - - - (= - (relevant-vars2 - (Cons $V $MoreVars) $S1 $S2 $RelVars) + (= (relevant-vars2 (Cons $V $MoreVars) $S1 $S2 (Cons $V $RelVars)) + (or + (, + (member + (/ $W $T1) $S1) + (== $V $W) + (member + (/ $X $T1a) $S1) + (\== $V $X) + (sub-term $Subterm1 $T1) + (var $Subterm1) + (contains-var $Subterm1 $T1a)) + (, + (member + (/ $W $T2) $S2) + (== $V $W) + (member + (/ $Y $T2a) $S2) + (\== $V $Y) + (sub-term $Subterm2 $T2) + (var $Subterm2) + (contains-var $Subterm2 $T2a))) + (set-det) (relevant-vars2 $MoreVars $S1 $S2 $RelVars)) -; + (= (relevant-vars2 (Cons $V $MoreVars) $S1 $S2 $RelVars) + (relevant-vars2 $MoreVars $S1 $S2 $RelVars)) ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: relevant_vars3/6 ; -; - +; * ; -; - +; * syntax: relevant_vars3(+C1,+C2,+Gen,+S1,+S2,-RelVars) ; -; - +; * ; -; - +; * args: C1,C2,Gen: clauses in list notation ; -; - +; * S1,S2: substititions ; -; - +; * RelVars : set of relevant vars ; -; - +; * ; -; - +; * description: Gen is a common generaliztion of C1,C2 , ; -; - +; * s.t. S1(Gen) is a subsetof C1, and analogously for C2. ; -; - +; * ; -; - +; * A variable is relevant if ; -; - +; * it appears in both Gen and ( C1 - Gen ) ; -; - +; * or Gen and ( C2 - Gen ). ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: none ; -; - +; * ; -; - +; * see also: IRES,ITOU ; -; - +; * ; -; - - - - (= - (relevant-vars3 $C1 $C2 $Gen $S1 $S2 $Vars) - ( (skolemize - (, $C1 $C2 $Gen $S1 $S2) $Phi - (, $D1 $D2 $Gen1 $R1 $R2)) - (relevant-vars3a $D1 $Gen1 $R1 $Vars1) - (relevant-vars3a $D2 $Gen1 $R2 $Vars2) - (length $Vars1 $Len1) - (length $Vars2 $Len2) - (== $Len1 $Len2) - (union $Vars1 $Vars2 $Vars0) - (deskolemize $Vars0 $Phi $Vars))) -; +; *********************************************************************** + (= (relevant-vars3 $C1 $C2 $Gen $S1 $S2 $Vars) + (skolemize + (, $C1 $C2 $Gen $S1 $S2) $Phi + (, $D1 $D2 $Gen1 $R1 $R2)) + (relevant-vars3a $D1 $Gen1 $R1 $Vars1) + (relevant-vars3a $D2 $Gen1 $R2 $Vars2) + (length $Vars1 $Len1) + (length $Vars2 $Len2) + (== $Len1 $Len2) + (union $Vars1 $Vars2 $Vars0) + (deskolemize $Vars0 $Phi $Vars)) - (= - (relevant-vars3a $Spec $Gen $S $Skolems) - ( (replace $Gen $S $Gen1 $S) - (subtract $Spec $Gen1 $Rest) - (inv-replace $Rest $S $Rest1 $S) - (skolems $Rest1 $Skolems1) - (skolems $Gen $Skolems2) - (intersection $Skolems1 $Skolems2 $Skolems))) -; + (= (relevant-vars3a $Spec $Gen $S $Skolems) + (replace $Gen $S $Gen1 $S) + (subtract $Spec $Gen1 $Rest) + (inv-replace $Rest $S $Rest1 $S) + (skolems $Rest1 $Skolems1) + (skolems $Gen $Skolems2) + (intersection $Skolems1 $Skolems2 $Skolems)) +; ;;changed Irene ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * predicate: findargs/3 ; -; - +; * ; -; - +; * syntax: findargs(+CL,+Accu,-Accu) ; -; - +; * ; -; - +; * args: CL: clause in list notation, Accu: arguments of the literals in CL ; -; - +; * ; -; - +; * description: find all arguments of the literals of a given clause ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; *********************************************************************** - (= - (findargs Nil $Result $Result) + (= (findargs Nil $Result $Result) (set-det)) -; + (= (findargs (Cons (with_self $Lit1 $_) $Rest) $Accu $Result) + (functor $Lit1 $_ $N) + (allarg $N $Lit1 Nil $Args) + (union $Accu $Args $Newaccu) + (findargs $Rest $Newaccu $Result)) +; ; set operator - (= - (findargs - (Cons - (with_self $Lit1 $_) $Rest) $Accu $Result) - ( (functor $Lit1 $_ $N) - (allarg $N $Lit1 Nil $Args) - (union $Accu $Args $Newaccu) - (findargs $Rest $Newaccu $Result))) -; - - - (= - (allarg 0 $_ $Accu $Accu) + (= (allarg 0 $_ $Accu $Accu) (set-det)) -; - - (= - (allarg $N $Lit $Args $Result) - ( (arg-quintus $N $Lit $Arg1) - (is $M - (- $N 1)) - (det-if-then-else - (nonmember $Arg1 $Args) - (allarg $M $Lit - (Cons $Arg1 $Args) $Result) - (allarg $M $Lit $Args $Result)))) -; - + (= (allarg $N $Lit $Args $Result) + (arg-quintus $N $Lit $Arg1) + (is $M + (- $N 1)) + (det-if-then-else + (nonmember $Arg1 $Args) + (allarg $M $Lit + (Cons $Arg1 $Args) $Result) + (allarg $M $Lit $Args $Result))) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: buildrelterms/6 ; -; - +; * ; -; - +; * syntax: buildrelterms(+CL1,+CL2,+Clgg,+Subst1,+Subst2,-TermList) ; -; - +; * ; -; - +; * args: CL1, CL2, Clgg .. clauses in list representation ; -; - +; * Subst1,Subst2 ... substitutions such that Clgg Subst1 = CL1 ; -; - +; * and Clgg Subst2 = CL2 ; -; - +; * TermList ... list of relevant terms for the new predicate ; -; - +; * ; -; - +; * description: determines the relevant terms for the new predicate ; -; - +; * as described in R. Wirth's 1989 PhD thesis ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ************************************************************************ - (= - (buildrelterms $SpecC1 $SpecC2 $Gen $S1 $S2 $Terms) - ( (skolemize - (, $Gen $SpecC1 $SpecC2 $S1 $S2) $SS - (, $Gen1 $Spec1 $Spec2 $SS1 $SS2)) - (findterms $Gen1 $Spec1 $SS1 $Terms1) - (findterms $Gen1 $Spec2 $SS2 $Terms2) - (deskolemize - (, $Terms1 $Terms2) $SS - (, $T1 $T2)) - (general-terms $T1 $T2 $Terms $S1 $S2))) -; + (= (buildrelterms $SpecC1 $SpecC2 $Gen $S1 $S2 $Terms) + (skolemize + (, $Gen $SpecC1 $SpecC2 $S1 $S2) $SS + (, $Gen1 $Spec1 $Spec2 $SS1 $SS2)) + (findterms $Gen1 $Spec1 $SS1 $Terms1) + (findterms $Gen1 $Spec2 $SS2 $Terms2) + (deskolemize + (, $Terms1 $Terms2) $SS + (, $T1 $T2)) + (general-terms $T1 $T2 $Terms $S1 $S2)) +; ; Terms1 = RArgs1 != {} +; ; Terms2 = RArgs2 != {} ; union(Terms1,Terms2,TermsS), ; deskolemize(TermsS,SS,Terms). ; changed Irene - - (= - (findterms $Gen $Spec $SS1 $RArgsG) - ( (replace $Gen $SS1 $Gen2 $_) - (subtract $Spec $Gen2 $RestSpec) - (subtract $Spec $RestSpec $SpecG) - (findargs $SpecG Nil $ArgsG) - (findargs $RestSpec Nil $ArgsR) - (exists-intersect $ArgsG $ArgsR $RArgsG))) -; - ; -; - + (= (findterms $Gen $Spec $SS1 $RArgsG) + (replace $Gen $SS1 $Gen2 $_) + (subtract $Spec $Gen2 $RestSpec) + (subtract $Spec $RestSpec $SpecG) + (findargs $SpecG Nil $ArgsG) + (findargs $RestSpec Nil $ArgsR) + (exists-intersect $ArgsG $ArgsR $RArgsG)) +; ; RestSpec = Ci^r ( Spec - Gen ) +; ; SpecG = Ci^g ; +; RArgs = relevant argument terms (not []) ; -; - +; inv_replace(RArgsG0,SS1,RArgsG,SS1). ; changed (Irene) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: general_terms/5 ; -; - +; * ; -; - +; * syntax: general_terms(+T1,+T2,-TG,+Subst1,+Subst2) ; -; - +; * ; -; - +; * args: T1, T2 .. relevant terms in CL1, CL2 (cf. above) ; -; - +; * Subst1, Subst2 .. substitutions (cf. above) ; -; - +; * TG .. relevant terms in Clgg ; -; - +; * ; -; - +; * description: determines the relevant terms in Clgg that ; -; - +; * correspond to the relevant terms in CL1 and CL2 ; -; - +; * here, inv_replace is used!! ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ************************************************************************ ; -; +; * general_terms (like a shotgun wedding between lgg for terms and inverse replacement...) - - (= - (general-terms Nil Nil Nil $_ $_) + (= (general-terms Nil Nil Nil $_ $_) (set-det)) -; - - - (= - (general-terms - (Cons $T1 $R1) Nil - (Cons $T $R3) $S1 $_) - ( (det-if-then-else - (genterm-test - (/ $T $T1) $S1) True - (inv-replace $T1 $S1 $T $_)) - (set-det) - (general-terms $R1 Nil $R3 $S1 $_))) -; - - - (= - (general-terms Nil - (Cons $T2 $R2) - (Cons $T $R3) $_ $S2) - ( (det-if-then-else - (genterm-test - (/ $T $T2) $S2) True - (inv-replace $T2 $S2 $T $_)) - (set-det) - (general-terms Nil $R2 $R3 $_ $S2))) -; - - - (= - (general-terms - (Cons $T1 $R1) $L2 - (Cons $T $R3) $S1 $S2) - ( (gen-term $T1 $L2 $L2Rest $T $S1 $S2) - (set-det) - (general-terms $R1 $L2Rest $R3 $S1 $S2))) -; - - - - (= - (gen-term $T1 $L2 $L2new $T $S1 $S2) - ( (nonvar $T1) - (functor $T1 $F $N) - (effaceall $T2 $L2 $L2new) - (functor $T2 $F $N) - (lgg-terms $T1 $T2 $T $_ $_ $S1 $S2))) -; - - - (= - (gen-term $T1 $L2 $L2new $X $S1 $S2) - ( (effaceall $T2 $L2 $L2new) - (genterm-test - (/ $X $T1) $S1) - (genterm-test - (/ $Y $T2) $S2) - (== $X $Y))) -; + (= (general-terms (Cons $T1 $R1) Nil (Cons $T $R3) $S1 $_) + (det-if-then-else + (genterm-test + (/ $T $T1) $S1) True + (inv-replace $T1 $S1 $T $_)) + (set-det) + (general-terms $R1 Nil $R3 $S1 $_)) - (= - (gen-term $T1 $L2 $L2 $T $S1 $_) + (= (general-terms Nil (Cons $T2 $R2) (Cons $T $R3) $_ $S2) + (det-if-then-else + (genterm-test + (/ $T $T2) $S2) True + (inv-replace $T2 $S2 $T $_)) + (set-det) + (general-terms Nil $R2 $R3 $_ $S2)) + + (= (general-terms (Cons $T1 $R1) $L2 (Cons $T $R3) $S1 $S2) + (gen-term $T1 $L2 $L2Rest $T $S1 $S2) + (set-det) + (general-terms $R1 $L2Rest $R3 $S1 $S2)) + + + (= (gen-term $T1 $L2 $L2new $T $S1 $S2) + (nonvar $T1) + (functor $T1 $F $N) + (effaceall $T2 $L2 $L2new) + (functor $T2 $F $N) + (lgg-terms $T1 $T2 $T $_ $_ $S1 $S2)) + + (= (gen-term $T1 $L2 $L2new $X $S1 $S2) + (effaceall $T2 $L2 $L2new) + (genterm-test + (/ $X $T1) $S1) + (genterm-test + (/ $Y $T2) $S2) + (== $X $Y)) + + (= (gen-term $T1 $L2 $L2 $T $S1 $_) (det-if-then-else (genterm-test (/ $T $T1) $S1) True (inv-replace $T1 $S1 $T $_))) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: exists_intersect/3 ; -; - +; * ; -; - +; * syntax: exists_intersect(+L1,+L2,-L) ; -; - +; * ; -; - +; * args: L1,L2,L: lists ; -; - +; * ; -; - +; * description: if nonempty intersection exists, succeeds and returns ; -; - +; * intersection, fails else ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - - +; ************************************************************************ - (= - (exists-intersect $X $Y $Z) - ( (exi $X $Y $Z $_) (set-det))) -; + (= (exists-intersect $X $Y $Z) + (exi $X $Y $Z $_) + (set-det)) - (= - (exi Nil $_ Nil $Flag) + (= (exi Nil $_ Nil $Flag) (== $Flag yes)) -; - - (= - (exi Nil $_ Nil $_) - ( (set-det) (fail))) -; - - (= - (exi - (Cons $X $R) $Y - (Cons $X $Z) yes) - ( (memberchk $X $Y) - (set-det) - (exi $R $Y $Z yes))) -; - - (= - (exi - (Cons $_ $R) $Y $Z $Flag) + (= (exi Nil $_ Nil $_) + (set-det) + (fail)) + (= (exi (Cons $X $R) $Y (Cons $X $Z) yes) + (memberchk $X $Y) + (set-det) + (exi $R $Y $Z yes)) + (= (exi (Cons $_ $R) $Y $Z $Flag) (exi $R $Y $Z $Flag)) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: clean_subst/3 ; -; - +; * ; -; - +; * syntax: clean_subst(+CL,+Subst,-Subst) ; -; - +; * ; -; - +; * args: CL: clause in list notation, Subst: a substitution [X/Term,...] ; -; - +; * ; -; - +; * description: removes all X/T from Subst such that X does not occur in CL ; -; - +; * ; -; - +; * example: ; -; - +; * ; -; - +; * peculiarities: ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; - +; ************************************************************************ - (= - (clean_subst $_ () ()) True) -; - - (= - (clean-subst $CL - (Cons - (/ $X $T) $R) $R2) - ( (clean-subst $CL $R $R1) (det-if-then-else (contains-var $X $CL) (= $R2 (Cons (/ $X $T) $R1)) (= $R2 $R1)))) -; - + (= (clean_subst $_ () ()) True) + (= (clean-subst $CL (Cons (/ $X $T) $R) $R2) + (clean-subst $CL $R $R1) + (det-if-then-else + (contains-var $X $CL) + (= $R2 + (Cons + (/ $X $T) $R1)) + (= $R2 $R1))) diff --git a/miles/xm.metta b/miles/xm.metta index 7b96bcd..c36590b 100644 --- a/miles/xm.metta +++ b/miles/xm.metta @@ -1,4852 +1,3847 @@ +; (convert_to_metta_file xm $_54378 miles/xm.pl miles/xm.metta) ; -; - +; FILE xm.pl !(ensure-loaded dmiles) -; - ; -; - +; IMPORTS !(use-module-if-exists (library proxt)) -; - !(use-module-if-exists (library ctypes)) -; - !(use-module-if-exists (library strings)) -; - !(use-module-if-exists (library basics)) -; - !(consult miles) -; - ; -; - +; ;;:- use_module(show_utils). !(consult xmiles-functions) -; - ; -; - +; *********************************************************************** ; -; - +; * ; -; - +; * file: xm.pl ; -; - +; * ; -; - +; * author: T. Volz ; -; - +; * ; -; - +; * changed: ; -; - +; * ; -; - +; * description: X interface for MILES. Load this directly into MeTTa ; -; - +; * (NOT qui!!), and call `xm.' to create the interface and start ; -; - +; * the event loop. Use the `Quit XMILES'-button to suspend the ; -; - +; * event loop, if you want to access the MeTTa-prompt directly. ; -; - +; * Calling `xm' again restarts the event loop. ; -; - +; * ; -; - +; * see also: ; -; - +; * ; -; +; *********************************************************************** - - (= - (runtime-entry start) + (= (runtime-entry start) (xm)) -; - !(dynamic (, (/ listItems 1) (/ my-exit-loop 1) (/ toplevel 1))) -; - - (= - (my_exit_loop no) True) -; - + (= (my_exit_loop no) True) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: xm main predicate ; -; - +; * ; -; - +; * syntax: - ; -; - +; * ; -; - +; * args: - ; -; - +; * ; -; - +; * description: Creates the whole xmiles interface. ; -; - +; * ; -; +; ************************************************************************ - - (= - (xm) - ( (det-if-then-else - (toplevel $Widget) - (, - (= $XMiles $Widget) - (open xmProtocol.tmp write $F) - (recordz messages - (file $F) $_) - (updateEvaluationLabel) - (refreshKnowledgeList $Widget rules $Calldata) - (refreshKnowledgeList $Widget examples $Calldata)) - (, - (xtToolkitInitialize) - (xtInitialize X-MILES xMILES $XMiles) - (add-symbol &self - (toplevel $XMiles)) - (clear-kb) - (xmCreateRowColumn $XMiles xMilesRow - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $XMilesRow) - (xtManageChild $XMilesRow) - (xmCreateRowColumn $XMilesRow xMilesColumn1 - (:: - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $XMilesColumn1) - (xtManageChild $XMilesColumn1) - (createCommandArea $XMilesColumn1) - (createFunctionArea $XMilesColumn1) - (createArgumentArea $XMilesColumn1) - (createMessageArea $XMilesColumn1) - (xmCreateRowColumn $XMilesRow xMilesColumn2 - (:: - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $XMilesColumn2) - (xtManageChild $XMilesColumn2) - (createEditorArea $XMilesColumn2) - (createKnowledgeBaseArea $XMilesColumn2) - (xtRealizeWidget $XMiles))) (my-main-loop $XMiles))) -; - - - - (= - (my-main-loop $Shell) + (= (xm) + (det-if-then-else + (toplevel $Widget) + (, + (= $XMiles $Widget) + (open xmProtocol.tmp write $F) + (recordz messages + (file $F) $_) + (updateEvaluationLabel) + (refreshKnowledgeList $Widget rules $Calldata) + (refreshKnowledgeList $Widget examples $Calldata)) + (, + (xtToolkitInitialize) + (xtInitialize X-MILES xMILES $XMiles) + (add-is-symbol &self + (toplevel $XMiles)) + (clear-kb) + (xmCreateRowColumn $XMiles xMilesRow + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $XMilesRow) + (xtManageChild $XMilesRow) + (xmCreateRowColumn $XMilesRow xMilesColumn1 + (:: + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $XMilesColumn1) + (xtManageChild $XMilesColumn1) + (createCommandArea $XMilesColumn1) + (createFunctionArea $XMilesColumn1) + (createArgumentArea $XMilesColumn1) + (createMessageArea $XMilesColumn1) + (xmCreateRowColumn $XMilesRow xMilesColumn2 + (:: + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $XMilesColumn2) + (xtManageChild $XMilesColumn2) + (createEditorArea $XMilesColumn2) + (createKnowledgeBaseArea $XMilesColumn2) + (xtRealizeWidget $XMiles))) + (my-main-loop $XMiles)) + + + (= (my-main-loop $Shell) (det-if-then-else (my-exit-loop yes) (, - (remove-symbol &self + (remove-is-symbol &self (my_exit_loop yes)) - (add-symbol &self + (add-is-symbol &self (my_exit_loop no))) (, (xtNextEvent $Event) (xtDispatchEvent $Event) (my-main-loop $Shell)))) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: createKnowledgeBaseArea/1 ; -; - +; * ; -; - +; * syntax: createKnowledgeBaseArea(+Parent) ; -; - +; * ; -; - +; * args: Parent... specifies the parentwidget of KbRowColumn ; -; - +; * ; -; - +; * description: Creates the knowledge base area of the X user interface ; -; - +; * This area consists of two scrolled windows. One window ; -; - +; * is used to browse the rules of the knowledge base, the ; -; - +; * other window browses the examples. Used by xm/0. ; -; - +; * ; -; +; ************************************************************************ - - (= - (createKnowledgeBaseArea $Parent) - ( (xmCreateFrame $Parent KnowledgeBaseFrame Nil $KnowledgeBaseFrame) - (xtManageChild $KnowledgeBaseFrame) - (xmCreateRowColumn $KnowledgeBaseFrame KnowledgeBaseColumn - (:: - (xmNadjustLast True) - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $KnowledgeBaseColumn) - (xtManageChild $KnowledgeBaseColumn) - (xmCreateRowColumn $KnowledgeBaseColumn titleRC - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN)) $TitleRowColumn) - (xtManageChild $TitleRowColumn) - (proxtGetDefaultCharset $DCharset) - (proxtStringToCharPtr 'Knowledge Base' $KbCP) - (xmStringCreate $KbCP $DCharset $StatusStr) - (xmCreateLabelGadget $TitleRowColumn titleLabel - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $StatusStr)) $KbLabel) - (xtManageChild $KbLabel) - (createEvaluationString $EString) - (proxtStringToCharPtr $EString $KbCP1) - (xmStringCreate $KbCP1 $DCharset $StatusStr1) - (xmCreateLabelGadget $TitleRowColumn titleEvaluation - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $StatusStr1)) $KbLabel1) - (xtManageChild $KbLabel1) - (recordz irene $KbLabel1 $_) - (xmCreateRowColumn $KnowledgeBaseColumn kbRowColumn - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN)) $KnowledgeBaseRow) - (xtManageChild $KnowledgeBaseRow) - (createRuleArea $KnowledgeBaseRow) - (createExampleArea $KnowledgeBaseRow) - (createKbButtons $KnowledgeBaseColumn))) -; - + (= (createKnowledgeBaseArea $Parent) + (xmCreateFrame $Parent KnowledgeBaseFrame Nil $KnowledgeBaseFrame) + (xtManageChild $KnowledgeBaseFrame) + (xmCreateRowColumn $KnowledgeBaseFrame KnowledgeBaseColumn + (:: + (xmNadjustLast True) + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $KnowledgeBaseColumn) + (xtManageChild $KnowledgeBaseColumn) + (xmCreateRowColumn $KnowledgeBaseColumn titleRC + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN)) $TitleRowColumn) + (xtManageChild $TitleRowColumn) + (proxtGetDefaultCharset $DCharset) + (proxtStringToCharPtr 'Knowledge Base' $KbCP) + (xmStringCreate $KbCP $DCharset $StatusStr) + (xmCreateLabelGadget $TitleRowColumn titleLabel + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $StatusStr)) $KbLabel) + (xtManageChild $KbLabel) + (createEvaluationString $EString) + (proxtStringToCharPtr $EString $KbCP1) + (xmStringCreate $KbCP1 $DCharset $StatusStr1) + (xmCreateLabelGadget $TitleRowColumn titleEvaluation + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $StatusStr1)) $KbLabel1) + (xtManageChild $KbLabel1) + (recordz irene $KbLabel1 $_) + (xmCreateRowColumn $KnowledgeBaseColumn kbRowColumn + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN)) $KnowledgeBaseRow) + (xtManageChild $KnowledgeBaseRow) + (createRuleArea $KnowledgeBaseRow) + (createExampleArea $KnowledgeBaseRow) + (createKbButtons $KnowledgeBaseColumn)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: createRuleArea/1 ; -; - +; * ; -; - +; * syntax: createRuleArea(+Parent) ; -; - +; * ; -; - +; * args: Parent... specifies the parent widget of RuleFrame ; -; - +; * ; -; - +; * description: Creates the rule browser of the knowledge base. The rule ; -; - +; * browser consists of a label, a scrolled rule list and ; -; - +; * a refresh button, which looks up for changes of the ; -; - +; * knowledge base. Used by createKbRowColumn/1 ; -; - +; * ; -; - +; ************************************************************************ - (= - (createRuleArea $Parent) - ( (xmCreateFrame $Parent RuleFrame Nil $RuleFrame) - (xtManageChild $RuleFrame) - (xmCreateRowColumn $RuleFrame RuleRowColumn - (:: - (xmNwidth 300) - (xmNadjustLast True) - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $RuleColumn) - (xtManageChild $RuleColumn) - (xmCreateRowColumn $RuleColumn ruleRow - (:: - (xmNorientation xmHORIZONTAL) - (xmNmarginHeight 0) - (xmNpacking xmPACK-TIGHT)) $RuleRow) - (xtManageChild $RuleRow) - (proxtGetDefaultCharset $DCharset) - (proxtStringToCharPtr 'Rules ' $RuleCP) - (xmStringCreate $RuleCP $DCharset $RuleStr) - (xmCreateLabelGadget $RuleRow ruleLabel - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $RuleStr)) $RuleLabel) - (xtManageChild $RuleLabel) - (xmCreatePushButton $RuleRow 'Examine ...' Nil $Examine) - (xtManageChild $Examine) - (createExamineRulesPopup $Examine) - (createKnowledgeList $RuleColumn rules) - (createKbSubButtons $RuleColumn rules))) -; - + (= (createRuleArea $Parent) + (xmCreateFrame $Parent RuleFrame Nil $RuleFrame) + (xtManageChild $RuleFrame) + (xmCreateRowColumn $RuleFrame RuleRowColumn + (:: + (xmNwidth 300) + (xmNadjustLast True) + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $RuleColumn) + (xtManageChild $RuleColumn) + (xmCreateRowColumn $RuleColumn ruleRow + (:: + (xmNorientation xmHORIZONTAL) + (xmNmarginHeight 0) + (xmNpacking xmPACK-TIGHT)) $RuleRow) + (xtManageChild $RuleRow) + (proxtGetDefaultCharset $DCharset) + (proxtStringToCharPtr 'Rules ' $RuleCP) + (xmStringCreate $RuleCP $DCharset $RuleStr) + (xmCreateLabelGadget $RuleRow ruleLabel + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $RuleStr)) $RuleLabel) + (xtManageChild $RuleLabel) + (xmCreatePushButton $RuleRow 'Examine ...' Nil $Examine) + (xtManageChild $Examine) + (createExamineRulesPopup $Examine) + (createKnowledgeList $RuleColumn rules) + (createKbSubButtons $RuleColumn rules)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: createExampleArea/1 ; -; - +; * ; -; - +; * syntax: createExampleArea(+Parent) ; -; - +; * ; -; - +; * args: +Parent Widget ; -; - +; * ; -; - +; * description: Creates the example browser of the knowledge base. The ; -; - +; * example browser consists of a label, a scrolled rule list ; -; - +; * and a refresh button, which looks up for changes of the ; -; - +; * knowledge base. ; -; - +; * ; -; - - +; ************************************************************************ - (= - (createExampleArea $Parent) - ( (xmCreateFrame $Parent ExampleFrame Nil $ExampleFrame) - (xtManageChild $ExampleFrame) - (xmCreateRowColumn $ExampleFrame ExampleRowColumn - (:: - (xmNwidth 300) - (xmNadjustLast True) - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $ExampleRowColumn) - (xtManageChild $ExampleRowColumn) - (proxtGetDefaultCharset $DCharset) - (proxtStringToCharPtr Examples $ExampleCP) - (xmStringCreate $ExampleCP $DCharset $ExampleStr) - (xmCreateLabelGadget $ExampleRowColumn exampleLabel - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $ExampleStr)) $ExampleLabel) - (xtManageChild $ExampleLabel) - (createKnowledgeList $ExampleRowColumn examples) - (createKbSubButtons $ExampleRowColumn examples))) -; + (= (createExampleArea $Parent) + (xmCreateFrame $Parent ExampleFrame Nil $ExampleFrame) + (xtManageChild $ExampleFrame) + (xmCreateRowColumn $ExampleFrame ExampleRowColumn + (:: + (xmNwidth 300) + (xmNadjustLast True) + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $ExampleRowColumn) + (xtManageChild $ExampleRowColumn) + (proxtGetDefaultCharset $DCharset) + (proxtStringToCharPtr Examples $ExampleCP) + (xmStringCreate $ExampleCP $DCharset $ExampleStr) + (xmCreateLabelGadget $ExampleRowColumn exampleLabel + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $ExampleStr)) $ExampleLabel) + (xtManageChild $ExampleLabel) + (createKnowledgeList $ExampleRowColumn examples) + (createKbSubButtons $ExampleRowColumn examples)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: createKnowledgeList/3 ; -; - +; * ; -; - +; * syntax: createKnowledgeList(+Parent,-KnowledgeRC,+KindOfKnowledge) ; -; - +; * ; -; - +; * args: +Parent Widget ; -; - +; * -KnowledgeRC Widget ; -; - +; * +KindOfKnowledge 'rules' or 'examples' ; -; - +; * ; -; - +; * description: Creates a List either containing all rules or all examples ; -; - +; * ; -; +; ************************************************************************ - - (= - (createKnowledgeList $Parent $KindOfKnowledge) - ( (xmCreateScrolledWindow $Parent knowledgelistSW - (:: - (xmNheight 300) - (xmNwidth 300) - (xmNlistSizePolicy xmCONSTANT) - (xmNscrollBarDisplayPolicy xmSTATIC) - (xmNscrollingPolicy xmAUTOMATIC)) $KL) - (xtManageChild $KL) - (xmCreateRowColumn $KL knowledgelistRC - (:: - (xmNadjustLast False) - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $KnowledgeRC) - (recordz $KindOfKnowledge - (knowledgeList $KnowledgeRC) $Ref) - (xtGetValues $KnowledgeRC - (:: (xmNbackground $B))) - (xtGetValues $KL - (:: (xmNclipWindow $CW))) - (xtSetValues $CW - (:: (xmNbackground $B))) - (addKnowledgeListItems $KindOfKnowledge) - (xtManageChild $KnowledgeRC))) -; - + (= (createKnowledgeList $Parent $KindOfKnowledge) + (xmCreateScrolledWindow $Parent knowledgelistSW + (:: + (xmNheight 300) + (xmNwidth 300) + (xmNlistSizePolicy xmCONSTANT) + (xmNscrollBarDisplayPolicy xmSTATIC) + (xmNscrollingPolicy xmAUTOMATIC)) $KL) + (xtManageChild $KL) + (xmCreateRowColumn $KL knowledgelistRC + (:: + (xmNadjustLast False) + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $KnowledgeRC) + (recordz $KindOfKnowledge + (knowledgeList $KnowledgeRC) $Ref) + (xtGetValues $KnowledgeRC + (:: (xmNbackground $B))) + (xtGetValues $KL + (:: (xmNclipWindow $CW))) + (xtSetValues $CW + (:: (xmNbackground $B))) + (addKnowledgeListItems $KindOfKnowledge) + (xtManageChild $KnowledgeRC)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: addKnowledgeListItems/1 ; -; - +; * ; -; - +; * syntax: addKnowledgeListItems(+KindOfKnowledge) ; -; - +; * ; -; - +; * args: +KindOfKnowledge rules or examples ; -; - +; * ; -; - +; * description: Adds a label for each Rule or Example existing in the kb ; -; - +; * to the parent widget stored in ; -; - +; * KindOfKnowledge, knowledgeList(X) ; -; - +; * ; -; - - +; ************************************************************************ - (= - (addKnowledgeListItems rules) - ( (getNextId $Id) - (get-clause $Id $H $B $S $O) - (addRuleItem $Id $H $B $S $O) - (fail))) -; - (= - (addKnowledgeListItems examples) - ( (getNextId $Id) - (get-example $Id $F $C) - (addExampleItem $Id $F $C) - (fail))) -; - - (= - (addKnowledgeListItems $_) + (= (addKnowledgeListItems rules) + (getNextId $Id) + (get-clause $Id $H $B $S $O) + (addRuleItem $Id $H $B $S $O) + (fail)) + (= (addKnowledgeListItems examples) + (getNextId $Id) + (get-example $Id $F $C) + (addExampleItem $Id $F $C) + (fail)) + (= (addKnowledgeListItems $_) (set-det)) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: getNextId/1 ; -; - +; * ; -; - +; * syntax: getNextId(+Id) ; -; - +; * ; -; - +; * args: +Id Integer <= id_count(X) ; -; - +; * ; -; - +; * description: Counts from zero to id_count ; -; - +; * ; -; +; ************************************************************************ - - (= - (getNextId $Id) - ( (id-count $MaxId) - (repeat) - (det-if-then-else + (= (getNextId $Id) + (id-count $MaxId) + (repeat) + (det-if-then-else + (recorded knowledgeList + (xm-id-count $I_old) $Ref) + (, + (erase $Ref) + (is $Id + (+ $I_old 1)) + (recordz knowledgeList + (xm-id-count $Id) $_)) + (, + (= $Id 1) + (recordz knowledgeList + (xm-id-count $Id) $_))) + (det-if-then-else + (< $MaxId $Id) + (, (recorded knowledgeList - (xm-id-count $I_old) $Ref) - (, - (erase $Ref) - (is $Id - (+ $I_old 1)) - (recordz knowledgeList - (xm-id-count $Id) $_)) - (, - (= $Id 1) - (recordz knowledgeList - (xm-id-count $Id) $_))) - (det-if-then-else - (< $MaxId $Id) - (, - (recorded knowledgeList - (xm-id-count $_) $Ref2) - (erase $Ref2) - (set-det) - (fail)) otherwise))) -; - + (xm-id-count $_) $Ref2) + (erase $Ref2) + (set-det) + (fail)) otherwise)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: deleteKnowledgeListItems/1 ; -; - +; * ; -; - +; * syntax: deleteKnowledgeListItems(+KindOfKnowledge) ; -; - +; * ; -; - +; * args: +KindOfKnowledge rules or examples ; -; - +; * ; -; - +; * description: Deletes all Labels representing rules or examples ; -; - +; * of the knowledgelist. Leaves the knowledgebase unchanged ; -; - +; * ; -; - +; ************************************************************************ - (= - (deleteKnowledgeListItems rules) - ( (recorded current - (clause $_ $Label $_) $Ref) - (xtDestroyWidget $Label) - (erase $Ref) - (set-det) - (deleteKnowledgeListItems rules))) -; - - (= - (deleteKnowledgeListItems examples) - ( (recorded current - (example $_ $Label $_) $Ref) - (xtDestroyWidget $Label) - (erase $Ref) - (set-det) - (deleteKnowledgeListItems examples))) -; - - (= - (deleteKnowledgeListItems $_) + (= (deleteKnowledgeListItems rules) + (recorded current + (clause $_ $Label $_) $Ref) + (xtDestroyWidget $Label) + (erase $Ref) + (set-det) + (deleteKnowledgeListItems rules)) + (= (deleteKnowledgeListItems examples) + (recorded current + (example $_ $Label $_) $Ref) + (xtDestroyWidget $Label) + (erase $Ref) + (set-det) + (deleteKnowledgeListItems examples)) + (= (deleteKnowledgeListItems $_) (set-det)) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: addRuleItem/4 ; -; - +; * ; -; - +; * syntax: addRuleItem(+I,+H,+B,+O) ; -; - +; * ; -; - +; * args: +I Integer, spezifies the ID of the rule ; -; - +; * +H Head of the rule ; -; - +; * +B Body of the rule ; -; - +; * +O Label ; -; - +; * ; -; - +; * description: Creates a label to show the rule spezified by the ; -; - +; * arguments. The Label widget is recorded: ; -; - +; * recordz(current,clause(I,Label,notselected),_Ref) ; -; - +; * If the Label allready exists, then only the text changes. ; -; - +; * ; -; +; ************************************************************************ - - (= - (addRuleItem $I $H $B $S $O) - ( (det-if-then - (recorded rules - (viewMin $MinText) $_) - (, - (xmTextGetString $MinText $MinCP) - (proxtCharPtrToString $MinCP $MinStr) - (atom-chars $MinStr $MinC) - (number-chars $Min $MinC))) - (det-if-then + (= (addRuleItem $I $H $B $S $O) + (det-if-then + (recorded rules + (viewMin $MinText) $_) + (, + (xmTextGetString $MinText $MinCP) + (proxtCharPtrToString $MinCP $MinStr) + (atom-chars $MinStr $MinC) + (number-chars $Min $MinC))) + (det-if-then + (recorded rules + (viewMax $MaxText) $_) + (, + (xmTextGetString $MaxText $MaxCP) + (proxtCharPtrToString $MaxCP $MaxStr) + (atom-chars $MaxStr $MaxC) + (number-chars $Max $MaxC))) + (or + (recorded rules + (view all) $_) + (, (recorded rules - (viewMax $MaxText) $_) - (, - (xmTextGetString $MaxText $MaxCP) - (proxtCharPtrToString $MaxCP $MaxStr) - (atom-chars $MaxStr $MaxC) - (number-chars $Max $MaxC))) - (or + (view labels $LabelList) $_) (recorded rules - (view all) $_) - (, - (recorded rules - (view labels $LabelList) $_) - (recorded rules - (view clause-heads $CHList) $_) - (>= $I $Min) - (=< $I $Max) - (functor $H $CH $_) - (or - (= $LabelList Nil) - (member $O $LabelList)) - (or - (= $CHList Nil) - (member $CH $CHList)))) - (proxtGetDefaultCharset $DCharset) - (recorded rules - (knowledgeList $KL) $_) - (xxmWriteToString - (show-kb-clause $I $H $B $O) $DCharset $XmS) - (det-if-then-else - (recorded current - (clause $I $W $_) $_) - (xtSetValues $W - (:: (xmNlabelString $XmS))) - (, - (xmCreateLabel $KL anyClause - (:: - (xmNalignment xmALIGNMENT-BEGINNING) - (xmNlabelString $XmS) - (xmNlabelType xmSTRING)) $Label) - (xtManageChild $Label) - (recordz current - (clause $I $Label notselected) $Ref) - (xtAddEventHandler $Label - (:: buttonReleaseMask) False selectClause rules) - (xtAddEventHandler $Label - (:: buttonPressMask) False firstClauseClick rules))) - (set-det))) -; - - - (= - (addRuleItem $_ $_ $_ $_ $_) + (view clause-heads $CHList) $_) + (>= $I $Min) + (=< $I $Max) + (functor $H $CH $_) + (or + (= $LabelList Nil) + (member $O $LabelList)) + (or + (= $CHList Nil) + (member $CH $CHList)))) + (proxtGetDefaultCharset $DCharset) + (recorded rules + (knowledgeList $KL) $_) + (xxmWriteToString + (show-kb-clause $I $H $B $O) $DCharset $XmS) + (det-if-then-else + (recorded current + (clause $I $W $_) $_) + (xtSetValues $W + (:: (xmNlabelString $XmS))) + (, + (xmCreateLabel $KL anyClause + (:: + (xmNalignment xmALIGNMENT-BEGINNING) + (xmNlabelString $XmS) + (xmNlabelType xmSTRING)) $Label) + (xtManageChild $Label) + (recordz current + (clause $I $Label notselected) $Ref) + (xtAddEventHandler $Label + (:: buttonReleaseMask) False selectClause rules) + (xtAddEventHandler $Label + (:: buttonPressMask) False firstClauseClick rules))) (set-det)) -; + (= (addRuleItem $_ $_ $_ $_ $_) + (set-det)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: addExampleItem/3 ; -; - +; * ; -; - +; * syntax: addExampleItem(+I,+F,+C) ; -; - +; * ; -; - +; * args: +I Integer, spezifies the ID of the example ; -; - +; * +F Example predicate ; -; - +; * +C + or -, classification of the example ; -; - +; * ; -; - +; * description: Creates a label to show the example spezified by the ; -; - +; * arguments. The Label widget is recorded: ; -; - +; * recordz(current,example(I,Label,notselected),_Ref) ; -; - +; * ; -; - +; ************************************************************************ - (= - (addExampleItem $I $F $C) - ( (det-if-then - (recorded examples - (viewMin $MinText) $_) - (, - (xmTextGetString $MinText $MinCP) - (proxtCharPtrToString $MinCP $MinStr) - (atom-chars $MinStr $MinC) - (number-chars $Min $MinC))) - (det-if-then - (recorded examples - (viewMax $MaxText) $_) - (, - (xmTextGetString $MaxText $MaxCP) - (proxtCharPtrToString $MaxCP $MaxStr) - (atom-chars $MaxStr $MaxC) - (number-chars $Max $MaxC))) - (or - (recorded examples - (view all) $_) - (, - (recorded examples - (view clause-heads $CHList) $_) - (functor $F $CH $_) - (>= $I $Min) - (=< $I $Max) - (or - (= $CHList Nil) - (member $CH $CHList)))) - (proxtGetDefaultCharset $DCharset) + (= (addExampleItem $I $F $C) + (det-if-then (recorded examples - (knowledgeList $KL) $_) - (number-chars $I $S1) - (append $S1 " (" $S2) - (atom-chars $C $S3) - (append $S2 $S3 $S4) - (append $S4 "): " $S5) - (atom-chars $A5 $S5) - (proxtStringToCharPtr $A5 $CP5) - (xmStringCreateLtoR $CP5 $DCharset $XmS1) - (xxmWriteToString - (write $F) $DCharset $XmS2) - (xmStringConcat $XmS1 $XmS2 $XmS3) - (xmStringSeparatorCreate $XmSep) - (xmStringConcat $XmS3 $XmSep $XmS) - (det-if-then-else - (recorded current - (example $I $W $_) $_) - (xtSetValues $W - (:: (xmNlabelString $XmS))) - (, - (xmCreateLabel $KL anyExample - (:: - (xmNalignment xmALIGNMENT-BEGINNING) - (xmNlabelString $XmS) - (xmNlabelType xmSTRING)) $Label) - (xtManageChild $Label) - (xtAddEventHandler $Label - (:: buttonReleaseMask) False selectClause examples) - (xtAddEventHandler $Label - (:: buttonPressMask) False firstClauseClick examples) - (recordz current - (example $I $Label notselected) $Ref))) - (set-det))) -; - + (viewMin $MinText) $_) + (, + (xmTextGetString $MinText $MinCP) + (proxtCharPtrToString $MinCP $MinStr) + (atom-chars $MinStr $MinC) + (number-chars $Min $MinC))) + (det-if-then + (recorded examples + (viewMax $MaxText) $_) + (, + (xmTextGetString $MaxText $MaxCP) + (proxtCharPtrToString $MaxCP $MaxStr) + (atom-chars $MaxStr $MaxC) + (number-chars $Max $MaxC))) + (or + (recorded examples + (view all) $_) + (, + (recorded examples + (view clause-heads $CHList) $_) + (functor $F $CH $_) + (>= $I $Min) + (=< $I $Max) + (or + (= $CHList Nil) + (member $CH $CHList)))) + (proxtGetDefaultCharset $DCharset) + (recorded examples + (knowledgeList $KL) $_) + (number-chars $I $S1) + (append $S1 " (" $S2) + (atom-chars $C $S3) + (append $S2 $S3 $S4) + (append $S4 "): " $S5) + (atom-chars $A5 $S5) + (proxtStringToCharPtr $A5 $CP5) + (xmStringCreateLtoR $CP5 $DCharset $XmS1) + (xxmWriteToString + (write $F) $DCharset $XmS2) + (xmStringConcat $XmS1 $XmS2 $XmS3) + (xmStringSeparatorCreate $XmSep) + (xmStringConcat $XmS3 $XmSep $XmS) + (det-if-then-else + (recorded current + (example $I $W $_) $_) + (xtSetValues $W + (:: (xmNlabelString $XmS))) + (, + (xmCreateLabel $KL anyExample + (:: + (xmNalignment xmALIGNMENT-BEGINNING) + (xmNlabelString $XmS) + (xmNlabelType xmSTRING)) $Label) + (xtManageChild $Label) + (xtAddEventHandler $Label + (:: buttonReleaseMask) False selectClause examples) + (xtAddEventHandler $Label + (:: buttonPressMask) False firstClauseClick examples) + (recordz current + (example $I $Label notselected) $Ref))) + (set-det)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: refreshKnowledgeList/3 CallbackProcedure ; -; - +; * ; -; - +; * syntax: refreshKnowledgeList(_Widget,+KindOfKnowledge,_Calldata) ; -; - +; * ; -; - +; * args: _Widget calling Widget ; -; - +; * +KindOfKnowledge rules or examples ; -; - +; * _Calldata Event ; -; - +; * ; -; - +; * description: Ensures that the knowledge displayed is the same than ; -; - +; * the knowledge in the knowledge base. ; -; - +; * ; -; - +; ************************************************************************ - (= - (refreshKnowledgeList $Widget $KindOfKnowledge $Calldata) - ( (deleteKnowledgeListItems $KindOfKnowledge) - (addKnowledgeListItems $KindOfKnowledge) - (updateEvaluationLabel))) -; - + (= (refreshKnowledgeList $Widget $KindOfKnowledge $Calldata) + (deleteKnowledgeListItems $KindOfKnowledge) + (addKnowledgeListItems $KindOfKnowledge) + (updateEvaluationLabel)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: selectClause/3 CallbackProcedure ; -; - +; * ; -; - +; * syntax: selectClause(+Widget,+KindOfKnowledge,_Calldata) ; -; - +; * ; -; - +; * args: +Widget calling Widget ; -; - +; * +KindOfKnowledge rules or examples ; -; - +; * _Calldata Event ; -; - +; * ; -; - +; * description: Toggles selection state of the knowledge item specified ; -; - +; * by Widget. Visual effect is the exchange of foreground ; -; - +; * and background color. ; -; - +; * ; -; - +; ************************************************************************ - (= - (selectClause $Widget rules $CallData) - ( (recorded current - (clause $I $Widget notselected) $Ref) - (xtGetValues $Widget - (:: - (xmNbackground $B) - (xmNforeground $F))) - (xtSetValues $Widget - (:: - (xmNbackground $F) - (xmNforeground $B))) - (erase $Ref) - (recordz current - (clause $I $Widget selected) $_) - (recorded state - (getId $GetId) $_) - (xtGetValues $GetId - (:: (xmNset $GetState))) - (det-if-then-else - (= $GetState True) - (copyId $I 1) otherwise))) -; - - - (= - (selectClause $Widget rules $CallData) - ( (recorded current - (clause $I $Widget selected) $Ref) - (xtGetValues $Widget - (:: - (xmNbackground $B) - (xmNforeground $F))) - (xtSetValues $Widget - (:: - (xmNbackground $F) - (xmNforeground $B))) - (erase $Ref) - (recordz current - (clause $I $Widget notselected) $Ref) - (recorded state - (getId $GetId) $_) - (xtGetValues $GetId - (:: (xmNset $GetState))) - (det-if-then-else - (= $GetState True) - (copyId $I 1) otherwise))) -; - - - (= - (selectClause $Widget examples $CallData) - ( (recorded current - (example $I $Widget notselected) $Ref) - (xtGetValues $Widget - (:: - (xmNbackground $B) - (xmNforeground $F))) - (xtSetValues $Widget - (:: - (xmNbackground $F) - (xmNforeground $B))) - (erase $Ref) - (recordz current - (example $I $Widget selected) $Ref) - (recorded state - (getId $GetId) $_) - (xtGetValues $GetId - (:: (xmNset $GetState))) - (det-if-then-else - (= $GetState True) - (copyId $I 1) otherwise))) -; - - - (= - (selectClause $Widget examples $CallData) - ( (recorded current - (example $I $Widget selected) $Ref) - (xtGetValues $Widget - (:: - (xmNbackground $B) - (xmNforeground $F))) - (xtSetValues $Widget - (:: - (xmNbackground $F) - (xmNforeground $B))) - (erase $Ref) - (recordz current - (example $I $Widget notselected) $Ref) - (recorded state - (getId $GetId) $_) - (xtGetValues $GetId - (:: (xmNset $GetState))) - (det-if-then-else - (= $GetState True) - (copyId $I 1) otherwise))) -; - + (= (selectClause $Widget rules $CallData) + (recorded current + (clause $I $Widget notselected) $Ref) + (xtGetValues $Widget + (:: + (xmNbackground $B) + (xmNforeground $F))) + (xtSetValues $Widget + (:: + (xmNbackground $F) + (xmNforeground $B))) + (erase $Ref) + (recordz current + (clause $I $Widget selected) $_) + (recorded state + (getId $GetId) $_) + (xtGetValues $GetId + (:: (xmNset $GetState))) + (det-if-then-else + (= $GetState True) + (copyId $I 1) otherwise)) + + (= (selectClause $Widget rules $CallData) + (recorded current + (clause $I $Widget selected) $Ref) + (xtGetValues $Widget + (:: + (xmNbackground $B) + (xmNforeground $F))) + (xtSetValues $Widget + (:: + (xmNbackground $F) + (xmNforeground $B))) + (erase $Ref) + (recordz current + (clause $I $Widget notselected) $Ref) + (recorded state + (getId $GetId) $_) + (xtGetValues $GetId + (:: (xmNset $GetState))) + (det-if-then-else + (= $GetState True) + (copyId $I 1) otherwise)) + + (= (selectClause $Widget examples $CallData) + (recorded current + (example $I $Widget notselected) $Ref) + (xtGetValues $Widget + (:: + (xmNbackground $B) + (xmNforeground $F))) + (xtSetValues $Widget + (:: + (xmNbackground $F) + (xmNforeground $B))) + (erase $Ref) + (recordz current + (example $I $Widget selected) $Ref) + (recorded state + (getId $GetId) $_) + (xtGetValues $GetId + (:: (xmNset $GetState))) + (det-if-then-else + (= $GetState True) + (copyId $I 1) otherwise)) + + (= (selectClause $Widget examples $CallData) + (recorded current + (example $I $Widget selected) $Ref) + (xtGetValues $Widget + (:: + (xmNbackground $B) + (xmNforeground $F))) + (xtSetValues $Widget + (:: + (xmNbackground $F) + (xmNforeground $B))) + (erase $Ref) + (recordz current + (example $I $Widget notselected) $Ref) + (recorded state + (getId $GetId) $_) + (xtGetValues $GetId + (:: (xmNset $GetState))) + (det-if-then-else + (= $GetState True) + (copyId $I 1) otherwise)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: firstClauseClick/3 CallbackProcedure ; -; - +; * ; -; - +; * syntax: firstClauseClick(+Widget,_ClientData,_Calldata) ; -; - +; * ; -; - +; * args: +Widget calling Widget ; -; - +; * _ClientData ; -; - +; * _Calldata Event ; -; - +; * ; -; - +; * description: If another click occures in the next two seconds, the ; -; - +; * knowledgebase item specified by Widget is copied into ; -; - +; * the editor. ; -; - +; * ; -; - +; * ; -; - - +; ************************************************************************ - (= - (firstClauseClick $Widget $ClientData $CallData) - ( (xtAddEventHandler $Widget - (:: buttonPressMask) False copyClause $_) (xtAddTimeOut 1000 noDoubleClick $Widget $ID))) -; + (= (firstClauseClick $Widget $ClientData $CallData) + (xtAddEventHandler $Widget + (:: buttonPressMask) False copyClause $_) + (xtAddTimeOut 1000 noDoubleClick $Widget $ID)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: copyClause/3 CallbackProcedure ; -; - +; * ; -; - +; * syntax: copyClause(+Widget,_ClientData,_Calldata) ; -; - +; * ; -; - +; * args: +Widget calling Widget ; -; - +; * _ClientData rules or examples ; -; - +; * _Calldata Event ; -; - +; * ; -; - +; * description: Copies a knowledge base item spezified by Widget to the ; -; - +; * editor text. ; -; - +; * ; -; - +; ************************************************************************ - (= - (copyClause $Widget $ClientData $CallData) - ( (recorded editor - (label $Label) $_) - (proxtGetDefaultCharset $DCharset) - (| - (det-if-then + (= (copyClause $Widget $ClientData $CallData) + (recorded editor + (label $Label) $_) + (proxtGetDefaultCharset $DCharset) + (| + (det-if-then + (recorded editor + (editing $_ $_) $Ref) + (, + (erase $Ref) + (proxtStringToCharPtr Editor $LblCP1) + (xmStringCreate $LblCP1 $DCharset $LblS1) + (xtSetValues $Label + (:: (xmNlabelString $LblS1))))) otherwise) + (| + (det-if-then + (recorded current + (clause $Id $Widget $_) $_) + (, + (get-clause $Id $H $B $_ $_) + (xxmWriteToCharPtr + (portray-clause (= $H $B)) $CP) (recorded editor - (editing $_ $_) $Ref) - (, - (erase $Ref) - (proxtStringToCharPtr Editor $LblCP1) - (xmStringCreate $LblCP1 $DCharset $LblS1) - (xtSetValues $Label - (:: (xmNlabelString $LblS1))))) otherwise) - (| - (det-if-then - (recorded current - (clause $Id $Widget $_) $_) - (, - (get-clause $Id $H $B $_ $_) - (xxmWriteToCharPtr - (portray-clause (= $H $B)) $CP) - (recorded editor - (textWidget $Editor) $_) - (xmTextSetString $Editor $CP) - (recordz editor - (editing rules $Id) $_) - (number-chars $Id $IdCS) - (append "Editor editing rule " $IdCS $LblCS) - (atom-chars $LblAS $LblCS) - (proxtStringToCharPtr $LblAS $LblCP) - (xmStringCreate $LblCP $DCharset $LblS) - (xtSetValues $Label - (:: (xmNlabelString $LblS))))) - (det-if-then - (recorded current - (example $Id $Widget $_) $_) - (, - (get-example $Id $F $_) - (xxmWriteToCharPtr - (writeFullstop $F) $CP) - (recorded editor - (textWidget $Editor) $_) - (xmTextSetString $Editor $CP) - (recordz editor - (editing examples $Id) $_) - (number-chars $Id $IdCS) - (append "Editor editing example " $IdCS $LblCS) - (atom-chars $LblAS $LblCS) - (proxtStringToCharPtr $LblAS $LblCP) - (xmStringCreate $LblCP $DCharset $LblS) - (xtSetValues $Label - (:: (xmNlabelString $LblS)))))))) -; - + (textWidget $Editor) $_) + (xmTextSetString $Editor $CP) + (recordz editor + (editing rules $Id) $_) + (number-chars $Id $IdCS) + (append "Editor editing rule " $IdCS $LblCS) + (atom-chars $LblAS $LblCS) + (proxtStringToCharPtr $LblAS $LblCP) + (xmStringCreate $LblCP $DCharset $LblS) + (xtSetValues $Label + (:: (xmNlabelString $LblS))))) + (det-if-then + (recorded current + (example $Id $Widget $_) $_) + (, + (get-example $Id $F $_) + (xxmWriteToCharPtr + (writeFullstop $F) $CP) + (recorded editor + (textWidget $Editor) $_) + (xmTextSetString $Editor $CP) + (recordz editor + (editing examples $Id) $_) + (number-chars $Id $IdCS) + (append "Editor editing example " $IdCS $LblCS) + (atom-chars $LblAS $LblCS) + (proxtStringToCharPtr $LblAS $LblCP) + (xmStringCreate $LblCP $DCharset $LblS) + (xtSetValues $Label + (:: (xmNlabelString $LblS))))))) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: noDoubleClick/2 TimeOutProcedure ; -; - +; * ; -; - +; * syntax: noDoubleClick(+Widget,_IntervallID) ; -; - +; * ; -; - +; * args: +Widget knowledge label ; -; - +; * _IntervallId calling Intervall ; -; - +; * ; -; - +; * description: Removes event handler for copying a knowledge base item ; -; - +; * into the editor. This predicate is avoked if no second ; -; - +; * button press has occured within two seconds. ; -; - +; * ; -; +; ************************************************************************ - - (= - (noDoubleClick $Widget $IntervallId) + (= (noDoubleClick $Widget $IntervallId) (xtRemoveEventHandler $Widget (:: buttonPressMask) False copyClause $_)) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: selectAll/3 Callback procedure ; -; - +; * ; -; - +; * syntax: selectAll(_Widget,+KindOfKnowledge,_CallData) ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * KindOfKnowledge rules or examples ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Selects all rules or examples of the knowledge base. The ; -; - +; * rules or examples have to satisfy the current display ; -; - +; * restricion. ; -; - +; * ; -; +; ************************************************************************ + (= (selectAll $Widget rules $CallData) + (recorded current + (clause $I $Widget notselected) $Ref) + (set-det) + (xtGetValues $Widget + (:: + (xmNbackground $B) + (xmNforeground $F))) + (xtSetValues $Widget + (:: + (xmNbackground $F) + (xmNforeground $B))) + (erase $Ref) + (recordz current + (clause $I $Widget selected) $Ref) + (selectAll $Widget rules $CallData)) - (= - (selectAll $Widget rules $CallData) - ( (recorded current - (clause $I $Widget notselected) $Ref) - (set-det) - (xtGetValues $Widget - (:: - (xmNbackground $B) - (xmNforeground $F))) - (xtSetValues $Widget - (:: - (xmNbackground $F) - (xmNforeground $B))) - (erase $Ref) - (recordz current - (clause $I $Widget selected) $Ref) - (selectAll $Widget rules $CallData))) -; - - - (= - (selectAll $Widget examples $CallData) - ( (recorded current - (example $I $Widget notselected) $Ref) - (set-det) - (xtGetValues $Widget - (:: - (xmNbackground $B) - (xmNforeground $F))) - (xtSetValues $Widget - (:: - (xmNbackground $F) - (xmNforeground $B))) - (erase $Ref) - (recordz current - (example $I $Widget selected) $Ref) - (selectAll $Widget examples $CallData))) -; - - - (= - (selectAll $_ $_ $_) True) -; + (= (selectAll $Widget examples $CallData) + (recorded current + (example $I $Widget notselected) $Ref) + (set-det) + (xtGetValues $Widget + (:: + (xmNbackground $B) + (xmNforeground $F))) + (xtSetValues $Widget + (:: + (xmNbackground $F) + (xmNforeground $B))) + (erase $Ref) + (recordz current + (example $I $Widget selected) $Ref) + (selectAll $Widget examples $CallData)) + (= (selectAll $_ $_ $_) True) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: unselectAll/3 Callback procedure ; -; - +; * ; -; - +; * syntax: unselectAll(_Widget,+KindOfKnowledge,_CallData) ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * KindOfKnowledge rules or examples ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Unselects all rules or examples of the knowledge base. The ; -; - +; * rules or examples have to satisfy the current display ; -; - +; * restricion. ; -; - +; * ; -; - - +; ************************************************************************ - (= - (unselectAll $Widget rules $CallData) - ( (recorded current - (clause $I $Widget selected) $Ref) - (set-det) - (xtGetValues $Widget - (:: - (xmNbackground $B) - (xmNforeground $F))) - (xtSetValues $Widget - (:: - (xmNbackground $F) - (xmNforeground $B))) - (erase $Ref) - (recordz current - (clause $I $Widget notselected) $Ref) - (unselectAll $Widget rules $CallData))) -; - - - (= - (unselectAll $Widget examples $CallData) - ( (recorded current - (example $I $Widget selected) $Ref) - (set-det) - (xtGetValues $Widget - (:: - (xmNbackground $B) - (xmNforeground $F))) - (xtSetValues $Widget - (:: - (xmNbackground $F) - (xmNforeground $B))) - (erase $Ref) - (recordz current - (example $I $Widget notselected) $Ref) - (unselectAll $Widget examples $CallData))) -; + (= (unselectAll $Widget rules $CallData) + (recorded current + (clause $I $Widget selected) $Ref) + (set-det) + (xtGetValues $Widget + (:: + (xmNbackground $B) + (xmNforeground $F))) + (xtSetValues $Widget + (:: + (xmNbackground $F) + (xmNforeground $B))) + (erase $Ref) + (recordz current + (clause $I $Widget notselected) $Ref) + (unselectAll $Widget rules $CallData)) - (= - (unselectAll $_ $_ $_) True) -; + (= (unselectAll $Widget examples $CallData) + (recorded current + (example $I $Widget selected) $Ref) + (set-det) + (xtGetValues $Widget + (:: + (xmNbackground $B) + (xmNforeground $F))) + (xtSetValues $Widget + (:: + (xmNbackground $F) + (xmNforeground $B))) + (erase $Ref) + (recordz current + (example $I $Widget notselected) $Ref) + (unselectAll $Widget examples $CallData)) + (= (unselectAll $_ $_ $_) True) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: deleteKnowledge/3 Callback procedure ; -; - +; * ; -; - +; * syntax: deleteKnowledge(_Widget,+KindOfKnowledge,_CallData) ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * KindOfKnowledge rules or examples ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Deletes all selected rules or examples. ; -; - +; * ; -; - - +; ************************************************************************ - (= - (deleteKnowledge $Widget rules $CallData) - ( (recorded current - (clause $I $Widget selected) $Ref) - (set-det) - (| - (det-if-then - (recorded editor - (editing rules $I) $_) - (clearEditor $_ $_ $_)) otherwise) - (xtGetValues $Widget - (:: - (xmNbackground $B) - (xmNforeground $F))) - (xtSetValues $Widget - (:: - (xmNbackground $F) - (xmNforeground $B))) - (erase $Ref) - (xtDestroyWidget $Widget) - (delete-clause $I) - (writeMessage ':- delete-clause(') - (writeMessage $I) - (writelnMessage ).) - (deleteKnowledge $Widget rules $CallData))) -; + (= (deleteKnowledge $Widget rules $CallData) + (recorded current + (clause $I $Widget selected) $Ref) + (set-det) + (| + (det-if-then + (recorded editor + (editing rules $I) $_) + (clearEditor $_ $_ $_)) otherwise) + (xtGetValues $Widget + (:: + (xmNbackground $B) + (xmNforeground $F))) + (xtSetValues $Widget + (:: + (xmNbackground $F) + (xmNforeground $B))) + (erase $Ref) + (xtDestroyWidget $Widget) + (delete-clause $I) + (writeMessage ':- delete-clause(') + (writeMessage $I) + (writelnMessage ).) + (deleteKnowledge $Widget rules $CallData)) - (= - (deleteKnowledge $Widget examples $CallData) - ( (| - (det-if-then - (recorded editor - (editing examples $I) $_) - (clearEditor $_ $_ $_)) otherwise) - (recorded current - (example $I $Widget selected) $Ref) - (set-det) - (xtGetValues $Widget - (:: - (xmNbackground $B) - (xmNforeground $F))) - (xtSetValues $Widget - (:: - (xmNbackground $F) - (xmNforeground $B))) - (erase $Ref) - (xtDestroyWidget $Widget) - (delete-example $I) - (writeMessage ':- delete-example(') - (writeMessage $I) - (writelnMessage ).) - (deleteKnowledge $Widget examples $CallData))) -; - - - (= - (deleteKnowledge $_ $KindOfKnowledge $_) - ( (writeMessage '% selected ') - (writeMessage $KindOfKnowledge) - (writelnMessage ' deleted.') - (updateEvaluationLabel))) -; + (= (deleteKnowledge $Widget examples $CallData) + (| + (det-if-then + (recorded editor + (editing examples $I) $_) + (clearEditor $_ $_ $_)) otherwise) + (recorded current + (example $I $Widget selected) $Ref) + (set-det) + (xtGetValues $Widget + (:: + (xmNbackground $B) + (xmNforeground $F))) + (xtSetValues $Widget + (:: + (xmNbackground $F) + (xmNforeground $B))) + (erase $Ref) + (xtDestroyWidget $Widget) + (delete-example $I) + (writeMessage ':- delete-example(') + (writeMessage $I) + (writelnMessage ).) + (deleteKnowledge $Widget examples $CallData)) + (= (deleteKnowledge $_ $KindOfKnowledge $_) + (writeMessage '% selected ') + (writeMessage $KindOfKnowledge) + (writelnMessage ' deleted.') + (updateEvaluationLabel)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: deleteAllKnowledge/3 Callback procedure ; -; - +; * ; -; - +; * syntax: deleteKnowledge(_Widget,+KindOfKnowledge,_CallData) ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * KindOfKnowledge rules or examples ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Deletes all rules or examples within the current display ; -; - +; * restriction. ; -; - +; * ; -; - +; ************************************************************************ - (= - (deleteAllKnowledge $Widget rules $CallData) - ( (| - (det-if-then - (recorded editor - (editing rules $_) $_) - (clearEditor $_ $_ $_)) otherwise) - (recorded current - (clause $I $Widget $_) $Ref) - (set-det) - (xtGetValues $Widget - (:: - (xmNbackground $B) - (xmNforeground $F))) - (xtSetValues $Widget - (:: - (xmNbackground $F) - (xmNforeground $B))) - (erase $Ref) - (xtDestroyWidget $Widget) - (delete-clause $I) - (writeMessage ':- delete-clause(') - (writeMessage $I) - (writelnMessage ).) - (deleteAllKnowledge $Widget rules $CallData))) -; - + (= (deleteAllKnowledge $Widget rules $CallData) + (| + (det-if-then + (recorded editor + (editing rules $_) $_) + (clearEditor $_ $_ $_)) otherwise) + (recorded current + (clause $I $Widget $_) $Ref) + (set-det) + (xtGetValues $Widget + (:: + (xmNbackground $B) + (xmNforeground $F))) + (xtSetValues $Widget + (:: + (xmNbackground $F) + (xmNforeground $B))) + (erase $Ref) + (xtDestroyWidget $Widget) + (delete-clause $I) + (writeMessage ':- delete-clause(') + (writeMessage $I) + (writelnMessage ).) + (deleteAllKnowledge $Widget rules $CallData)) - (= - (deleteAllKnowledge $Widget examples $CallData) - ( (| - (det-if-then - (recorded editor - (editing examples $_) $_) - (clearEditor $_ $_ $_)) otherwise) - (recorded current - (example $I $Widget $_) $Ref) - (set-det) - (xtGetValues $Widget - (:: - (xmNbackground $B) - (xmNforeground $F))) - (xtSetValues $Widget - (:: - (xmNbackground $F) - (xmNforeground $B))) - (erase $Ref) - (xtDestroyWidget $Widget) - (delete-example $I) - (writeMessage ':- delete-example(') - (writeMessage $I) - (writelnMessage ).) - (deleteAllKnowledge $Widget examples $CallData))) -; - - - (= - (deleteAllKnowledge $_ $KindOfKnowledge $_) - ( (writeMessage '% all ') - (writeMessage $KindOfKnowledge) - (writelnMessage ' deleted.'))) -; + (= (deleteAllKnowledge $Widget examples $CallData) + (| + (det-if-then + (recorded editor + (editing examples $_) $_) + (clearEditor $_ $_ $_)) otherwise) + (recorded current + (example $I $Widget $_) $Ref) + (set-det) + (xtGetValues $Widget + (:: + (xmNbackground $B) + (xmNforeground $F))) + (xtSetValues $Widget + (:: + (xmNbackground $F) + (xmNforeground $B))) + (erase $Ref) + (xtDestroyWidget $Widget) + (delete-example $I) + (writeMessage ':- delete-example(') + (writeMessage $I) + (writelnMessage ).) + (deleteAllKnowledge $Widget examples $CallData)) + (= (deleteAllKnowledge $_ $KindOfKnowledge $_) + (writeMessage '% all ') + (writeMessage $KindOfKnowledge) + (writelnMessage ' deleted.')) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: saveKnowledgeBegin/3 Callback procedure ; -; - +; * ; -; - +; * syntax: saveKnowledgeBegin(_Widget,+FileSelectionDialog,_CallData) ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * +FileSelectionDialog FileSelectionDialogWidget ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Pops up a fileselection dialog. ; -; - +; * ; -; - +; ************************************************************************ - (= - (saveKnowledgeBegin $Widget $FileSelectionDialog $CallData) - ( (xtManageChild $FileSelectionDialog) - (xtAddCallback $FileSelectionDialog xmNokCallback saveKnowledgeEnd $FileSelectionDialog) - (xtAddCallback $FileSelectionDialog xmNcancelCallback cancelSaveFileSelect $FileSelectionDialog))) -; - + (= (saveKnowledgeBegin $Widget $FileSelectionDialog $CallData) + (xtManageChild $FileSelectionDialog) + (xtAddCallback $FileSelectionDialog xmNokCallback saveKnowledgeEnd $FileSelectionDialog) + (xtAddCallback $FileSelectionDialog xmNcancelCallback cancelSaveFileSelect $FileSelectionDialog)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: saveKnowledgeEnd/3 Callback procedure ; -; - +; * ; -; - +; * syntax: saveKnowledgeEnd(_Widget,+FileSelectionDialog,+CallData) ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * +FileSelectionDialog FileSelectionDialogWidget ; -; - +; * +CallData event ; -; - +; * ; -; - +; * description: Saves the selected file. ; -; - +; * ; -; - +; ************************************************************************ - (= - (saveKnowledgeEnd $Widget $FileSelectionDialog $CallData) - ( (xtUnmanageChild $FileSelectionDialog) - (xtRemoveCallback $FileSelectionDialog xmNokCallback saveKnowledgeEnd $FileSelectionDialog) - (xtRemoveCallback $FileSelectionDialog xmNcancelCallback cancelSaveFileSelect $FileSelectionDialog) - (sucheInListe - (value $FileNameString) $CallData) - (proxtGetDefaultCharset $DCharset) - (xmStringGetLtoR $FileNameString $DCharset $FileNameCP $_) - (proxtCharPtrToString $FileNameCP $FileName) - (| - (det-if-then - (midstring $FileName $_ .qof 0) - (, - (save-kb $FileName) - (writeMessage ':- save-kb(') - (writeMessage $FileName) - (writelnMessage ).))) - (det-if-then otherwise - (, - (print-kb $FileName) - (writeMessage ':- print-kb(') - (writeMessage $FileName) - (writelnMessage ).)))) - (writeMessage '% file "') - (writeMessage $FileName) - (writelnMessage " saved.))) -; - + (= (saveKnowledgeEnd $Widget $FileSelectionDialog $CallData) + (xtUnmanageChild $FileSelectionDialog) + (xtRemoveCallback $FileSelectionDialog xmNokCallback saveKnowledgeEnd $FileSelectionDialog) + (xtRemoveCallback $FileSelectionDialog xmNcancelCallback cancelSaveFileSelect $FileSelectionDialog) + (sucheInListe + (value $FileNameString) $CallData) + (proxtGetDefaultCharset $DCharset) + (xmStringGetLtoR $FileNameString $DCharset $FileNameCP $_) + (proxtCharPtrToString $FileNameCP $FileName) + (| + (det-if-then + (midstring $FileName $_ .qof 0) + (, + (save-kb $FileName) + (writeMessage ':- save-kb(') + (writeMessage $FileName) + (writelnMessage ).))) + (det-if-then otherwise + (, + (print-kb $FileName) + (writeMessage ':- print-kb(') + (writeMessage $FileName) + (writelnMessage ).)))) + (writeMessage '% file "') + (writeMessage $FileName) + (writelnMessage " saved.)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: loadKnowledgeBegin/3 Callback procedure ; -; - +; * ; -; - +; * syntax: loadKnowledgeBegin(_Widget,+FileSelectionDialog,_CallData) ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * +FileSelectionDialog FileSelectionDialogWidget ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Pops up a fileselection dialog. ; -; - +; * ; -; +; ************************************************************************ - - (= - (loadKnowledgeBegin $Widget $FileSelectionDialog $CallData) - ( (xtManageChild $FileSelectionDialog) - (xtAddCallback $FileSelectionDialog xmNokCallback loadKnowledgeEnd $FileSelectionDialog) - (xtAddCallback $FileSelectionDialog xmNcancelCallback cancelLoadFileSelect $FileSelectionDialog))) -; - + (= (loadKnowledgeBegin $Widget $FileSelectionDialog $CallData) + (xtManageChild $FileSelectionDialog) + (xtAddCallback $FileSelectionDialog xmNokCallback loadKnowledgeEnd $FileSelectionDialog) + (xtAddCallback $FileSelectionDialog xmNcancelCallback cancelLoadFileSelect $FileSelectionDialog)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: loadKnowledgeEnd/3 Callback procedure ; -; - +; * ; -; - +; * syntax: loadKnowledgeEnd(_Widget,+FileSelectionDialog,+CallData) ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * +FileSelectionDialog FileSelectionDialogWidget ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Loads the selected file. ; -; - +; * ; -; +; ************************************************************************ - - (= - (loadKnowledgeEnd $Widget $FileSelectionDialog $CallData) - ( (xtUnmanageChild $FileSelectionDialog) - (xtRemoveCallback $FileSelectionDialog xmNokCallback loadKnowledgeEnd $FileSelectionDialog) - (xtRemoveCallback $FileSelectionDialog xmNcancelCallback cancelLoadFileSelect $FileSelectionDialog) - (sucheInListe - (value $FileNameString) $CallData) - (proxtGetDefaultCharset $DCharset) - (xmStringGetLtoR $FileNameString $DCharset $FileNameCP $_) - (proxtCharPtrToString $FileNameCP $FileName) - (| - (det-if-then - (midstring $FileName $_ .qof 0) - (, - (consult-kb $FileName) - (writeMessage ':- consult-kb(') - (writeMessage $FileName) - (writelnMessage ).))) - (det-if-then otherwise - (, - (init-kb $FileName) - (writeMessage ':- init-kb(') - (writeMessage $FileName) - (writelnMessage ).)))) - (writeMessage '% file "') - (writeMessage $FileName) - (writelnMessage " consulted.) - (refreshKnowledgeList $Widget rules $Calldata) - (refreshKnowledgeList $Widget examples $Calldata) - (updateEvaluationLabel))) -; - + (= (loadKnowledgeEnd $Widget $FileSelectionDialog $CallData) + (xtUnmanageChild $FileSelectionDialog) + (xtRemoveCallback $FileSelectionDialog xmNokCallback loadKnowledgeEnd $FileSelectionDialog) + (xtRemoveCallback $FileSelectionDialog xmNcancelCallback cancelLoadFileSelect $FileSelectionDialog) + (sucheInListe + (value $FileNameString) $CallData) + (proxtGetDefaultCharset $DCharset) + (xmStringGetLtoR $FileNameString $DCharset $FileNameCP $_) + (proxtCharPtrToString $FileNameCP $FileName) + (| + (det-if-then + (midstring $FileName $_ .qof 0) + (, + (consult-kb $FileName) + (writeMessage ':- consult-kb(') + (writeMessage $FileName) + (writelnMessage ).))) + (det-if-then otherwise + (, + (init-kb $FileName) + (writeMessage ':- init-kb(') + (writeMessage $FileName) + (writelnMessage ).)))) + (writeMessage '% file "') + (writeMessage $FileName) + (writelnMessage " consulted.) + (refreshKnowledgeList $Widget rules $Calldata) + (refreshKnowledgeList $Widget examples $Calldata) + (updateEvaluationLabel)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: clearAllKnowledge/3 callback procedure ; -; - +; * ; -; - +; * syntax: clearAllKnowledge(_Widget,_ClientData,_CallData) ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * _ClientData no client data ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: deletes all rules and examples ; -; - +; * ; -; - +; ************************************************************************ - (= - (clearAllKnowledge $Widget $ClientData $CallData) - ( (deleteAllKnowledge $Widget rules $CallData) - (deleteAllKnowledge $Widget examples $CallData) - (clearEditor $_ $_ $_) - (writelnMessage ':- clear-kb.') - (writelnMessage '% knowledgebase cleared.') - (clear-kb) - (updateEvaluationLabel))) -; - + (= (clearAllKnowledge $Widget $ClientData $CallData) + (deleteAllKnowledge $Widget rules $CallData) + (deleteAllKnowledge $Widget examples $CallData) + (clearEditor $_ $_ $_) + (writelnMessage ':- clear-kb.') + (writelnMessage '% knowledgebase cleared.') + (clear-kb) + (updateEvaluationLabel)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: cancelLoadFileSelect/3 callback procedure ; -; - +; * ; -; - +; * syntax: cancelLoadFileSelect(_Widget,_ClientData,_CallData) ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * _ClientData no client data ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Pops down the file selection dialog without loading any ; -; - +; * file. ; -; - +; * ; -; +; ************************************************************************ - - (= - (cancelLoadFileSelect $Widget $FileSelectionDialog $CallData) - ( (xtRemoveCallback $FileSelectionDialog xmNokCallback loadKnowledgeEnd $FileSelectionDialog) - (xtRemoveCallback $FileSelectionDialog xmNcancelCallback cancelLoadFileSelect $FileSelectionDialog) - (xtUnmanageChild $FileSelectionDialog))) -; - + (= (cancelLoadFileSelect $Widget $FileSelectionDialog $CallData) + (xtRemoveCallback $FileSelectionDialog xmNokCallback loadKnowledgeEnd $FileSelectionDialog) + (xtRemoveCallback $FileSelectionDialog xmNcancelCallback cancelLoadFileSelect $FileSelectionDialog) + (xtUnmanageChild $FileSelectionDialog)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: cancelSaveFileSelect/3 callback procedure ; -; - +; * ; -; - +; * syntax: cancelSaveFileSelect(_Widget,_ClientData,_CallData) ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * _ClientData no client data ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Pops down the file selection dialog without saving any ; -; - +; * file. ; -; - +; * ; -; - +; ************************************************************************ - (= - (cancelSaveFileSelect $Widget $FileSelectionDialog $CallData) - ( (xtRemoveCallback $FileSelectionDialog xmNokCallback saveKnowledgeEnd $FileSelectionDialog) - (xtRemoveCallback $FileSelectionDialog xmNcancelCallback cancelSaveFileSelect $FileSelectionDialog) - (xtUnmanageChild $FileSelectionDialog))) -; - + (= (cancelSaveFileSelect $Widget $FileSelectionDialog $CallData) + (xtRemoveCallback $FileSelectionDialog xmNokCallback saveKnowledgeEnd $FileSelectionDialog) + (xtRemoveCallback $FileSelectionDialog xmNcancelCallback cancelSaveFileSelect $FileSelectionDialog) + (xtUnmanageChild $FileSelectionDialog)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: createKbButtons/1 ; -; - +; * ; -; - +; * syntax: createKbButtons(+Parent) ; -; - +; * ; -; - +; * args: Parent Widget ; -; - +; * ; -; - +; * description: Creates the push buttons 'Save', 'Load', 'Clear'. These ; -; - +; * buttons are effecting the whole knowledge base (rules and ; -; - +; * examples). ; -; - +; * ; -; - +; ************************************************************************ - (= - (createKbButtons $Parent) - ( (xmCreateRowColumn $Parent ButtonRowColumn - (:: - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER) - (xmNnumColumns 1) - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN)) $ButtonRowColumn) - (xtManageChild $ButtonRowColumn) - (xmCreateFileSelectionDialog $ButtonRowColumn KBFileSelect Nil $KbFileSelectionDialog) - (xmCreatePushButton $ButtonRowColumn Load Nil $Load) - (xtManageChild $Load) - (xtAddCallback $Load xmNactivateCallback loadKnowledgeBegin $KbFileSelectionDialog) - (xmCreatePushButton $ButtonRowColumn Save Nil $Save) - (xtManageChild $Save) - (xtAddCallback $Save xmNactivateCallback saveKnowledgeBegin $KbFileSelectionDialog) - (xmCreatePushButton $ButtonRowColumn Clear Nil $Clear) - (xtManageChild $Clear) - (createYesNoPopup $Clear $YesNoPopup clearAllKnowledge $_))) -; - + (= (createKbButtons $Parent) + (xmCreateRowColumn $Parent ButtonRowColumn + (:: + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER) + (xmNnumColumns 1) + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN)) $ButtonRowColumn) + (xtManageChild $ButtonRowColumn) + (xmCreateFileSelectionDialog $ButtonRowColumn KBFileSelect Nil $KbFileSelectionDialog) + (xmCreatePushButton $ButtonRowColumn Load Nil $Load) + (xtManageChild $Load) + (xtAddCallback $Load xmNactivateCallback loadKnowledgeBegin $KbFileSelectionDialog) + (xmCreatePushButton $ButtonRowColumn Save Nil $Save) + (xtManageChild $Save) + (xtAddCallback $Save xmNactivateCallback saveKnowledgeBegin $KbFileSelectionDialog) + (xmCreatePushButton $ButtonRowColumn Clear Nil $Clear) + (xtManageChild $Clear) + (createYesNoPopup $Clear $YesNoPopup clearAllKnowledge $_)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: createKbSubButtons/2 ; -; - +; * ; -; - +; * syntax: createKbSubButtons(+Parent,+KindOfKnowledge) ; -; - +; * ; -; - +; * args: +Parent Widget ; -; - +; * +KindOfKnowledge examples or rules ; -; - +; * ; -; - +; * description: Creates the push buttons 'SelectAll', 'Unselect All', ; -; - +; * 'Refresh', 'Delete', 'Delete All' and 'Label' or '+', '-' ; -; - +; * '?'. These buttons are efecting the KindOfKnowledge ; -; - +; * (rules and examples). ; -; - +; * ; -; - +; ************************************************************************ - (= - (createKbSubButtons $Parent $KindOfKnowledge) - ( (xmCreateRowColumn $Parent ButtonRowColumn - (:: - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER) - (xmNnumColumns 2) - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN)) $ButtonRowColumn) - (xtManageChild $ButtonRowColumn) - (xmCreatePushButton $ButtonRowColumn 'View ...' Nil $View) - (xtManageChild $View) - (xmCreatePushButton $ButtonRowColumn 'Select All' Nil $Select) - (xtManageChild $Select) - (xtAddCallback $Select xmNactivateCallback selectAll $KindOfKnowledge) - (xmCreatePushButton $ButtonRowColumn 'Unselect All' Nil $Unselect) - (xtManageChild $Unselect) - (xtAddCallback $Unselect xmNactivateCallback unselectAll $KindOfKnowledge) - (xmCreatePushButton $ButtonRowColumn Refresh Nil $Refresh) - (xtManageChild $Refresh) - (xtAddCallback $Refresh xmNactivateCallback refreshKnowledgeList $KindOfKnowledge) - (xmCreatePushButton $ButtonRowColumn Delete Nil $Delete) - (xtManageChild $Delete) - (xtAddCallback $Delete xmNactivateCallback deleteKnowledge $KindOfKnowledge) - (| - (det-if-then - (= $KindOfKnowledge rules) - (, - (createViewRulesPopup $View) - (createLabelChangeButton $ButtonRowColumn))) - (det-if-then - (= $KindOfKnowledge examples) - (, - (createViewExamplesPopup $View) - (createClassChangeButtons $ButtonRowColumn)))))) -; - + (= (createKbSubButtons $Parent $KindOfKnowledge) + (xmCreateRowColumn $Parent ButtonRowColumn + (:: + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER) + (xmNnumColumns 2) + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN)) $ButtonRowColumn) + (xtManageChild $ButtonRowColumn) + (xmCreatePushButton $ButtonRowColumn 'View ...' Nil $View) + (xtManageChild $View) + (xmCreatePushButton $ButtonRowColumn 'Select All' Nil $Select) + (xtManageChild $Select) + (xtAddCallback $Select xmNactivateCallback selectAll $KindOfKnowledge) + (xmCreatePushButton $ButtonRowColumn 'Unselect All' Nil $Unselect) + (xtManageChild $Unselect) + (xtAddCallback $Unselect xmNactivateCallback unselectAll $KindOfKnowledge) + (xmCreatePushButton $ButtonRowColumn Refresh Nil $Refresh) + (xtManageChild $Refresh) + (xtAddCallback $Refresh xmNactivateCallback refreshKnowledgeList $KindOfKnowledge) + (xmCreatePushButton $ButtonRowColumn Delete Nil $Delete) + (xtManageChild $Delete) + (xtAddCallback $Delete xmNactivateCallback deleteKnowledge $KindOfKnowledge) + (| + (det-if-then + (= $KindOfKnowledge rules) + (, + (createViewRulesPopup $View) + (createLabelChangeButton $ButtonRowColumn))) + (det-if-then + (= $KindOfKnowledge examples) + (, + (createViewExamplesPopup $View) + (createClassChangeButtons $ButtonRowColumn))))) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: createLabelChangeButton/1 ; -; - +; * ; -; - +; * syntax: createLabelChangeButton(+Parent) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: Creates a push button and a editing Dialog for changing ; -; - +; * the label of the selected rules. ; -; - +; * ; -; +; ************************************************************************ + (= (createLabelChangeButton $Parent) + (xmCreatePushButton $Parent Label Nil $Label) + (xtManageChild $Label) + (xmCreateBulletinBoardDialog $Label 'Label Change' Nil $LabelChangeDialog) + (xtAddCallback $Label xmNactivateCallback popupDialog $LabelChangeDialog) + (xmCreateFrame $LabelChangeDialog LabelFrame Nil $LabelFrame) + (xtManageChild $LabelFrame) + (xmCreateRowColumn $LabelFrame labelChangeColumn + (:: + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-COLUMN)) $LabelChangeColumn) + (xtManageChild $LabelChangeColumn) + (proxtGetDefaultCharset $DCharset) + (proxtStringToCharPtr 'Change Label of all selected rules to:' $LCP) + (xmStringCreate $LCP $DCharset $LabelStr) + (xmCreateLabelGadget $LabelChangeColumn labelchange + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $LabelStr)) $KStatus) + (xtManageChild $KStatus) + (xmCreateText $LabelChangeColumn labelChangeText + (:: + (xmNeditable True) + (xmNeditMode xmSINGLE-LINE-EDIT) + (xmNwidth 150) + (xmNautoShowCursorPosition True)) $LabelChangeText) + (xtManageChild $LabelChangeText) + (xtAddActions (:: (action label-ok changeSelectedLabels $LabelChangeDialog))) + (proxtStringToCharPtr 'Return: label-ok()' $TranslationString) + (xtParseTranslationTable $TranslationString $TranslationTable) + (xtOverrideTranslations $LabelChangeText $TranslationTable) + (xmCreateRowColumn $LabelChangeColumn buttonrow + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $ButtonRow) + (xtManageChild $ButtonRow) + (xmCreatePushButton $ButtonRow OK! Nil $OK) + (xtManageChild $OK) + (xtAddCallback $OK xmNactivateCallback changeSelectedLabels + (:: $LabelChangeDialog $LabelChangeText)) + (xmCreatePushButton $ButtonRow Cancel Nil $Cancel) + (xtManageChild $Cancel) + (xtAddCallback $Cancel xmNactivateCallback cancelLabelChange $LabelChangeDialog)) - (= - (createLabelChangeButton $Parent) - ( (xmCreatePushButton $Parent Label Nil $Label) - (xtManageChild $Label) - (xmCreateBulletinBoardDialog $Label 'Label Change' Nil $LabelChangeDialog) - (xtAddCallback $Label xmNactivateCallback popupDialog $LabelChangeDialog) - (xmCreateFrame $LabelChangeDialog LabelFrame Nil $LabelFrame) - (xtManageChild $LabelFrame) - (xmCreateRowColumn $LabelFrame labelChangeColumn - (:: - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-COLUMN)) $LabelChangeColumn) - (xtManageChild $LabelChangeColumn) - (proxtGetDefaultCharset $DCharset) - (proxtStringToCharPtr 'Change Label of all selected rules to:' $LCP) - (xmStringCreate $LCP $DCharset $LabelStr) - (xmCreateLabelGadget $LabelChangeColumn labelchange - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $LabelStr)) $KStatus) - (xtManageChild $KStatus) - (xmCreateText $LabelChangeColumn labelChangeText - (:: - (xmNeditable True) - (xmNeditMode xmSINGLE-LINE-EDIT) - (xmNwidth 150) - (xmNautoShowCursorPosition True)) $LabelChangeText) - (xtManageChild $LabelChangeText) - (xtAddActions (:: (action label-ok changeSelectedLabels $LabelChangeDialog))) - (proxtStringToCharPtr 'Return: label-ok()' $TranslationString) - (xtParseTranslationTable $TranslationString $TranslationTable) - (xtOverrideTranslations $LabelChangeText $TranslationTable) - (xmCreateRowColumn $LabelChangeColumn buttonrow - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $ButtonRow) - (xtManageChild $ButtonRow) - (xmCreatePushButton $ButtonRow OK! Nil $OK) - (xtManageChild $OK) - (xtAddCallback $OK xmNactivateCallback changeSelectedLabels - (:: $LabelChangeDialog $LabelChangeText)) - (xmCreatePushButton $ButtonRow Cancel Nil $Cancel) - (xtManageChild $Cancel) - (xtAddCallback $Cancel xmNactivateCallback cancelLabelChange $LabelChangeDialog))) -; +; +; ************************************************************************ +; +; * +; +; * predicate: createSelectRulesPopup/1 +; +; * +; +; * syntax: createSelectRulesPopup(+Parent) +; +; * +; +; * args: +; +; * +; +; * description: Creates a push button and a editing Dialog for changing +; +; * the label of the selected rules. +; +; * +; +; ************************************************************************ + + + (= (createSelectRulesPopup $Parent) + (xmCreateBulletinBoardDialog $Parent SelectRules Nil $SelectRulesDialog) + (xtAddCallback $Parent xmNactivateCallback popupDialog $SelectRulesDialog) + (xmCreateFrame $SelectRulesDialog SelectRulesFrame Nil $SelectRulesFrame) + (xtManageChild $SelectRulesFrame) + (xmCreateRowColumn $SelectRulesFrame selectRulesColumn + (:: + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-COLUMN)) $SelectRulesColumn) + (xtManageChild $SelectRulesColumn) + (proxtGetDefaultCharset $DCharset) + (proxtStringToCharPtr 'Select rules:' $TitleCP) + (xmStringCreate $TitleCP $DCharset $TitleStr) + (xmCreateLabelGadget $SelectRulesColumn title + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $TitleStr)) $TitleLabel) + (xtManageChild $TitleLabel) + (xmCreateText $SelectRulesColumn selectRulesText + (:: + (xmNeditable True) + (xmNeditMode xmSINGLE-LINE-EDIT) + (xmNwidth 150) + (xmNautoShowCursorPosition True)) $SelectRulesText) + (xtManageChild $SelectRulesText) + (xtAddActions (:: (action select-ok selectRules $SelectRulesDialog))) + (proxtStringToCharPtr 'Return: select-ok()' $TranslationString) + (xtParseTranslationTable $TranslationString $TranslationTable) + (xtOverrideTranslations $SelectRulesText $TranslationTable) + (xmCreateRowColumn $SelectRulesColumn buttonrow + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $ButtonRow) + (xtManageChild $ButtonRow) + (xmCreatePushButton $ButtonRow Select Nil $Select) + (xtManageChild $Select) + (xtAddCallback $Select xmNactivateCallback selectRules $SelectRulesDialog) + (xmCreatePushButton $ButtonRow 'Select All' Nil $SelectAll) + (xtManageChild $SelectAll) + (xtAddCallback $SelectAll xmNactivateCallback selectRules + (:: rules $SelectRulesDialog)) + (xmCreatePushButton $ButtonRow Cancel Nil $Cancel) + (xtManageChild $Cancel) + (xtAddCallback $Cancel xmNactivateCallback yesNoPopdown $SelectRulesDialog)) + + +; +; ************************************************************************ +; +; * +; +; * predicate: createExamineRulesPopup/1 +; +; * +; +; * syntax: createExamineRulesPopup(+Parent) +; +; * +; +; * args: +; +; * +; +; * description: Creates a push button and a Dialog for examining +; +; * the selected rules. +; +; * +; +; ************************************************************************ + + + (= (createExamineRulesPopup $Parent) + (xmCreateBulletinBoardDialog $Parent ExamineRules Nil $ExamineRulesDialog) + (xtAddCallback $Parent xmNactivateCallback popupExamineRules $_) + (recordz rules + (examine dialog $ExamineRulesDialog) $_) + (xmCreateFrame $ExamineRulesDialog ExamineRulesFrame Nil $ExamineRulesFrame) + (xtManageChild $ExamineRulesFrame) + (xmCreateRowColumn $ExamineRulesFrame examineRulesColumn + (:: + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT)) $ExamineRulesColumn) + (xtManageChild $ExamineRulesColumn) + (xmCreateRowColumn $ExamineRulesColumn titlerow + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $TitleRow) + (xtManageChild $TitleRow) + (proxtGetDefaultCharset $DCharset) + (proxtStringToCharPtr 'Examine rule:' $TitleCP) + (xmStringCreate $TitleCP $DCharset $TitleStr) + (xmCreateLabelGadget $TitleRow title + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $TitleStr)) $TitleLabel) + (xtManageChild $TitleLabel) + (xmCreateScrolledWindow $ExamineRulesColumn ruleSW + (:: + (xmNheight 200) + (xmNwidth 250) + (xmNlistSizePolicy xmCONSTANT) + (xmNscrollBarDisplayPolicy xmSTATIC) + (xmNscrollingPolicy xmAUTOMATIC)) $RuleSW) + (xtManageChild $RuleSW) + (xmCreateRowColumn $RuleSW ruleRC + (:: + (xmNadjustLast False) + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $RuleRC) + (recordz rules + (examineRC $RuleRC) $Ref) + (xtGetValues $RuleRC + (:: (xmNbackground $B))) + (xtGetValues $RuleSW + (:: (xmNclipWindow $CW))) + (xtSetValues $CW + (:: (xmNbackground $B))) + (xtManageChild $RuleRC) + (xmCreateRowColumn $ExamineRulesColumn buttonrow + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $ButtonRow) + (xtManageChild $ButtonRow) + (xmCreatePushButton $ButtonRow Examine Nil $Examine) + (xtManageChild $Examine) + (xtAddCallback $Examine xmNactivateCallback showExaminedRule $_) + (showExaminedRule $_ $_ $_) + (xmCreatePushButton $ButtonRow Cancel Nil $Cancel) + (xtManageChild $Cancel) + (xtAddCallback $Cancel xmNactivateCallback cancelExamineRules $_)) -; -; -; -; ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: showExaminedRule/1 ; -; - +; * ; -; - +; * syntax: showExaminedRule(_Widget,_RuleNoText,_CallData) +; +; * +; +; * description: Displays Info on the (first) selected rule +; +; * +; +; ************************************************************************ + + + (= (showExaminedRule $Widget $RuleNoText $CallData) + (proxtGetDefaultCharset $DCharset) + (| + (det-if-then + (recorded rules + (examineText $OldText) $Ref) + (, + (erase $Ref) + (xtDestroyWidget $OldText))) otherwise) + (recorded rules + (examineRC $ExamineRC) $_) + (det-if-then-else + (, + (recorded current + (clause $RuleNo $_ selected) $_) + (get-clause $RuleNo $H $B $S $O)) + (, + (get-evaluation $RuleNo $Evaluation) + (= $Evaluation + (evaluation $E1 $E2 $E3 $E4 $E5 $E6 $E7 $E8 $E9)) + (or + (type-restriction $H $R) + (= $R 'No type restriction found!')) + (numbervars + (, $H $B) 0 $_) + (xxmWriteToString + (, + (show-kb-clause $RuleNo $H $B $O) + (nl) + (write type-restriction:) + (nl) + (write $R) + (nl)) $DCharset $XmS3) + (xxmWriteToString + (, + (nl) + (write evaluation:) + (nl) + (write $E1) + (nl) + (write $E2) + (nl) + (write $E3) + (nl) + (write $E4) + (nl) + (write $E5) + (nl) + (write $E6) + (nl) + (write $E7) + (nl) + (write $E8) + (nl) + (write $E9) + (nl)) $DCharset $XmS4) + (xmStringConcat $XmS3 $XmS4 $XmS) + (xmCreateLabel $ExamineRC anyClause + (:: + (xmNalignment xmALIGNMENT-BEGINNING) + (xmNlabelString $XmS) + (xmNlabelType xmSTRING)) $Label)) + (, + (atom-chars $ASno "No rule selected!") + (proxtStringToCharPtr $ASno $CPno) + (xmStringCreateLtoR $CPno $DCharset $XmSno) + (xmCreateLabel $ExamineRC anyClause + (:: + (xmNalignment xmALIGNMENT-BEGINNING) + (xmNlabelString $XmSno) + (xmNlabelType xmSTRING)) $Label))) + (xtManageChild $Label) + (recordz rules + (examineText $Label) $_) + (set-det)) +; ;;;;Irene + + +; +; ************************************************************************ +; +; * +; +; * predicate: createViewRulesPopup/1 +; +; * +; +; * syntax: createViewRulesPopup(+Parent) +; +; * +; +; * description: creates Dialog for Viewing Rules +; +; * +; +; ************************************************************************ + + + (= (createViewRulesPopup $Parent) + (xmCreateBulletinBoardDialog $Parent ViewRules Nil $ViewRulesDialog) + (xtAddCallback $Parent xmNactivateCallback popupViewRules $_) + (xmCreateFrame $ViewRulesDialog ViewRulesFrame Nil $ViewRulesFrame) + (xtManageChild $ViewRulesFrame) + (xmCreateRowColumn $ViewRulesFrame viewRulesColumn + (:: + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT)) $ViewRulesColumn) + (xtManageChild $ViewRulesColumn) + (proxtGetDefaultCharset $DCharset) + (proxtStringToCharPtr 'View rules:' $TitleCP) + (xmStringCreate $TitleCP $DCharset $TitleStr) + (xmCreateLabelGadget $ViewRulesColumn title + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $TitleStr)) $TitleLabel) + (xtManageChild $TitleLabel) + (xmCreateFrame $ViewRulesColumn ViewLabelsFrame Nil $ViewLabelFrame) + (xtManageChild $ViewLabelFrame) + (xmCreateRowColumn $ViewLabelFrame labelrow + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $LabelRow) + (xtManageChild $LabelRow) + (xmCreateRowColumn $LabelRow exLabColumn + (:: + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT)) $ExLabColumn) + (xtManageChild $ExLabColumn) + (xmCreateRowColumn $LabelRow viewLabColumn + (:: + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT)) $ViewLabColumn) + (xtManageChild $ViewLabColumn) + (proxtStringToCharPtr 'existing labels' $ExLabCP) + (xmStringCreate $ExLabCP $DCharset $ExLabStr) + (xmCreateLabelGadget $ExLabColumn subtitle + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $ExLabStr)) $ExLabLabel) + (xtManageChild $ExLabLabel) + (proxtStringToCharPtr 'viewed labels' $ViewLabCP) + (xmStringCreate $ViewLabCP $DCharset $ViewLabStr) + (xmCreateLabelGadget $ViewLabColumn subtitle + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $ViewLabStr)) $ViewLabLabel) + (xtManageChild $ViewLabLabel) + (xmCreateScrolledWindow $ExLabColumn exLabSW + (:: + (xmNheight 150) + (xmNwidth 140) + (xmNlistSizePolicy xmCONSTANT) + (xmNscrollBarDisplayPolicy xmSTATIC) + (xmNscrollingPolicy xmAUTOMATIC)) $ExLabSW) + (xtManageChild $ExLabSW) + (xmCreateRowColumn $ExLabSW exLabRC + (:: + (xmNadjustLast False) + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $ExLabRC) + (xtGetValues $ExLabRC + (:: (xmNbackground $ExLabB))) + (xtGetValues $ExLabSW + (:: (xmNclipWindow $ExLabCW))) + (xtSetValues $ExLabCW + (:: (xmNbackground $ExLabB))) + (xtManageChild $ExLabRC) + (xmCreateScrolledWindow $ViewLabColumn viewedLabSW + (:: + (xmNheight 150) + (xmNwidth 140) + (xmNlistSizePolicy xmCONSTANT) + (xmNscrollBarDisplayPolicy xmSTATIC) + (xmNscrollingPolicy xmAUTOMATIC)) $ViewLabSW) + (xtManageChild $ViewLabSW) + (xmCreateRowColumn $ViewLabSW viewLabRC + (:: + (xmNadjustLast False) + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $ViewLabRC) + (xtGetValues $ViewLabRC + (:: (xmNbackground $ViewLabB))) + (xtGetValues $ViewLabSW + (:: (xmNclipWindow $ViewLabCW))) + (xtSetValues $ViewLabCW + (:: (xmNbackground $ViewLabB))) + (xtManageChild $ViewLabRC) + (xmCreateFrame $ViewRulesColumn ViewClauseHeadFrame Nil $ViewClauseHeadFrame) + (xtManageChild $ViewClauseHeadFrame) + (xmCreateRowColumn $ViewClauseHeadFrame clauseHeadrow + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $ClauseHeadRow) + (xtManageChild $ClauseHeadRow) + (xmCreateRowColumn $ClauseHeadRow exCHColumn + (:: + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT)) $ExCHColumn) + (xtManageChild $ExCHColumn) + (xmCreateRowColumn $ClauseHeadRow viewCHColumn + (:: + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT)) $ViewCHColumn) + (xtManageChild $ViewCHColumn) + (proxtStringToCharPtr 'existing clause heads' $ExCHCP) + (xmStringCreate $ExCHCP $DCharset $ExCHStr) + (xmCreateLabelGadget $ExCHColumn subtitle + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $ExCHStr)) $ExCHLabel) + (xtManageChild $ExCHLabel) + (proxtStringToCharPtr 'viewed clause heads' $ViewCHCP) + (xmStringCreate $ViewCHCP $DCharset $ViewCHStr) + (xmCreateLabelGadget $ViewCHColumn subtitle + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $ViewCHStr)) $ViewCHLabel) + (xtManageChild $ViewCHLabel) + (xmCreateScrolledWindow $ExCHColumn existingCHSW + (:: + (xmNheight 150) + (xmNwidth 140) + (xmNlistSizePolicy xmCONSTANT) + (xmNscrollBarDisplayPolicy xmSTATIC) + (xmNscrollingPolicy xmAUTOMATIC)) $ExCHSW) + (xtManageChild $ExCHSW) + (xmCreateRowColumn $ExCHSW exCHRC + (:: + (xmNadjustLast False) + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $ExCHRC) + (xtGetValues $ExCHRC + (:: (xmNbackground $ExCHB))) + (xtGetValues $ExCHSW + (:: (xmNclipWindow $ExCHCW))) + (xtSetValues $ExCHCW + (:: (xmNbackground $ExCHB))) + (xtManageChild $ExCHRC) + (xmCreateScrolledWindow $ViewCHColumn viewedCHSW + (:: + (xmNheight 150) + (xmNwidth 140) + (xmNlistSizePolicy xmCONSTANT) + (xmNscrollBarDisplayPolicy xmSTATIC) + (xmNscrollingPolicy xmAUTOMATIC)) $ViewCHSW) + (xtManageChild $ViewCHSW) + (xmCreateRowColumn $ViewCHSW viewCHRC + (:: + (xmNadjustLast False) + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $ViewCHRC) + (xtGetValues $ViewCHRC + (:: (xmNbackground $ViewCHB))) + (xtGetValues $ViewCHSW + (:: (xmNclipWindow $ViewCHCW))) + (xtSetValues $ViewCHCW + (:: (xmNbackground $ViewCHB))) + (xtManageChild $ViewCHRC) + (xmCreateRowColumn $ViewRulesColumn minMaxRow + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $MinMaxRow) + (xtManageChild $MinMaxRow) + (proxtStringToCharPtr 'Min: ' $MinLabelChrPtr) + (xmStringCreate $MinLabelChrPtr $DCharset $MinLabelStr) + (xmCreateLabelGadget $MinMaxRow minLabel + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $MinLabelStr)) $MinLabel) + (xtManageChild $MinLabel) + (xmCreateRowColumn $MinMaxRow Min + (:: + (xmNadjustLast True) + (xmNmarginHeight 0) + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-TIGHT)) $MinRow) + (xtManageChild $MinRow) + (xmCreatePushButton $MinRow < Nil $Lower) + (xtManageChild $Lower) + (xmCreateText $MinRow argumentText + (:: + (xmNeditable True) + (xmNeditMode xmSINGLE-LINE-EDIT) + (xmNwidth 30) + (xmNautoShowCursorPosition True)) $MinText) + (proxtStringToCharPtr 1 $MinChrPtr) + (xmTextSetString $MinText $MinChrPtr) + (xtManageChild $MinText) + (recordz rules + (viewMin $MinText) $_) + (xtAddCallback $Lower xmNactivateCallback lowerMin $MinText) + (xmCreatePushButton $MinRow > Nil $Raise) + (xtManageChild $Raise) + (xtAddCallback $Raise xmNactivateCallback raiseMin $MinText) + (proxtStringToCharPtr 'Max: ' $MaxLabelChrPtr) + (xmStringCreate $MaxLabelChrPtr $DCharset $MaxLabelStr) + (xmCreateLabelGadget $MinMaxRow maxLabel + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $MaxLabelStr)) $MaxLabel) + (xtManageChild $MaxLabel) + (xmCreateRowColumn $MinMaxRow Max + (:: + (xmNadjustLast True) + (xmNmarginHeight 0) + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-TIGHT)) $MaxRow) + (xtManageChild $MaxRow) + (xmCreatePushButton $MaxRow < Nil $LowerMax) + (xtManageChild $LowerMax) + (xmCreateText $MaxRow argumentText + (:: + (xmNeditable True) + (xmNeditMode xmSINGLE-LINE-EDIT) + (xmNwidth 30) + (xmNautoShowCursorPosition True)) $MaxText) + (proxtStringToCharPtr 100 $MaxChrPtr) + (xmTextSetString $MaxText $MaxChrPtr) + (xtManageChild $MaxText) + (recordz rules + (viewMax $MaxText) $_) + (xtAddCallback $LowerMax xmNactivateCallback lowerMax $MaxText) + (xmCreatePushButton $MaxRow > Nil $RaiseMax) + (xtManageChild $RaiseMax) + (xtAddCallback $RaiseMax xmNactivateCallback raiseMax $MaxText) + (recordz rules + (view all) $_) + (recordz rules + (view labels Nil) $_) + (recordz rules + (view clause-heads Nil) $_) + (recordz rules + (view dialog $ViewRulesDialog) $_) + (recordz rules + (view exLabRC $ExLabRC) $_) + (recordz rules + (view viewLabRC $ViewLabRC) $_) + (recordz rules + (view exCHRC $ExCHRC) $_) + (recordz rules + (view viewCHRC $ViewCHRC) $_) + (xmCreateRowColumn $ViewRulesColumn buttonrow + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $ButtonRow) + (xtManageChild $ButtonRow) + (xmCreatePushButton $ButtonRow View Nil $View) + (xtManageChild $View) + (xtAddCallback $View xmNactivateCallback viewRules $_) + (xmCreatePushButton $ButtonRow 'View All' Nil $ViewAll) + (xtManageChild $ViewAll) + (xtAddCallback $ViewAll xmNactivateCallback viewAllRules $_) + (xmCreatePushButton $ButtonRow Cancel Nil $Cancel) + (xtManageChild $Cancel) + (xtAddCallback $Cancel xmNactivateCallback cancelViewRules $_)) + + + + +; +; ************************************************************************ +; +; * +; +; * predicate: createViewExamplesPopup/1 +; +; * +; +; * syntax: createViewExamplesPopup(+parent) +; +; * +; +; * description: Creates creates facilities for selecting the viewed +; +; * examples. +; +; * +; +; ************************************************************************ + + + (= (createViewExamplesPopup $Parent) + (xmCreateBulletinBoardDialog $Parent ViewExamples Nil $ViewExamplesDialog) + (xtAddCallback $Parent xmNactivateCallback popupViewExamples $_) + (xmCreateFrame $ViewExamplesDialog ViewExamplesFrame Nil $ViewExamplesFrame) + (xtManageChild $ViewExamplesFrame) + (xmCreateRowColumn $ViewExamplesFrame viewExamplesColumn + (:: + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT)) $ViewExamplesColumn) + (xtManageChild $ViewExamplesColumn) + (proxtGetDefaultCharset $DCharset) + (proxtStringToCharPtr 'View examples:' $TitleCP) + (xmStringCreate $TitleCP $DCharset $TitleStr) + (xmCreateLabelGadget $ViewExamplesColumn title + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $TitleStr)) $TitleLabel) + (xtManageChild $TitleLabel) + (xmCreateFrame $ViewExamplesColumn ViewClauseHeadFrame Nil $ViewClauseHeadFrame) + (xtManageChild $ViewClauseHeadFrame) + (xmCreateRowColumn $ViewClauseHeadFrame clauseHeadrow + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $ClauseHeadRow) + (xtManageChild $ClauseHeadRow) + (xmCreateRowColumn $ClauseHeadRow exCHColumn + (:: + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT)) $ExCHColumn) + (xtManageChild $ExCHColumn) + (xmCreateRowColumn $ClauseHeadRow viewCHColumn + (:: + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT)) $ViewCHColumn) + (xtManageChild $ViewCHColumn) + (proxtStringToCharPtr 'existing clause heads' $ExCHCP) + (xmStringCreate $ExCHCP $DCharset $ExCHStr) + (xmCreateLabelGadget $ExCHColumn subtitle + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $ExCHStr)) $ExCHLabel) + (xtManageChild $ExCHLabel) + (proxtStringToCharPtr 'viewed clause heads' $ViewCHCP) + (xmStringCreate $ViewCHCP $DCharset $ViewCHStr) + (xmCreateLabelGadget $ViewCHColumn subtitle + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $ViewCHStr)) $ViewCHLabel) + (xtManageChild $ViewCHLabel) + (xmCreateScrolledWindow $ExCHColumn existingCHSW + (:: + (xmNheight 150) + (xmNwidth 140) + (xmNlistSizePolicy xmCONSTANT) + (xmNscrollBarDisplayPolicy xmSTATIC) + (xmNscrollingPolicy xmAUTOMATIC)) $ExCHSW) + (xtManageChild $ExCHSW) + (xmCreateRowColumn $ExCHSW exCHRC + (:: + (xmNadjustLast False) + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $ExCHRC) + (xtGetValues $ExCHRC + (:: (xmNbackground $ExCHB))) + (xtGetValues $ExCHSW + (:: (xmNclipWindow $ExCHCW))) + (xtSetValues $ExCHCW + (:: (xmNbackground $ExCHB))) + (xtManageChild $ExCHRC) + (xmCreateScrolledWindow $ViewCHColumn viewedCHSW + (:: + (xmNheight 150) + (xmNwidth 140) + (xmNlistSizePolicy xmCONSTANT) + (xmNscrollBarDisplayPolicy xmSTATIC) + (xmNscrollingPolicy xmAUTOMATIC)) $ViewCHSW) + (xtManageChild $ViewCHSW) + (xmCreateRowColumn $ViewCHSW viewCHRC + (:: + (xmNadjustLast False) + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $ViewCHRC) + (xtGetValues $ViewCHRC + (:: (xmNbackground $ViewCHB))) + (xtGetValues $ViewCHSW + (:: (xmNclipWindow $ViewCHCW))) + (xtSetValues $ViewCHCW + (:: (xmNbackground $ViewCHB))) + (xtManageChild $ViewCHRC) + (xmCreateRowColumn $ViewExamplesColumn minMaxRow + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $MinMaxRow) + (xtManageChild $MinMaxRow) + (proxtStringToCharPtr 'Min: ' $MinLabelChrPtr) + (xmStringCreate $MinLabelChrPtr $DCharset $MinLabelStr) + (xmCreateLabelGadget $MinMaxRow minLabel + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $MinLabelStr)) $MinLabel) + (xtManageChild $MinLabel) + (xmCreateRowColumn $MinMaxRow Min + (:: + (xmNadjustLast True) + (xmNmarginHeight 0) + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-TIGHT)) $MinRow) + (xtManageChild $MinRow) + (xmCreatePushButton $MinRow < Nil $Lower) + (xtManageChild $Lower) + (xmCreateText $MinRow argumentText + (:: + (xmNeditable True) + (xmNeditMode xmSINGLE-LINE-EDIT) + (xmNwidth 30) + (xmNautoShowCursorPosition True)) $MinText) + (proxtStringToCharPtr 1 $MinChrPtr) + (xmTextSetString $MinText $MinChrPtr) + (xtManageChild $MinText) + (recordz examples + (viewMin $MinText) $_) + (xtAddCallback $Lower xmNactivateCallback lowerMin $MinText) + (xmCreatePushButton $MinRow > Nil $Raise) + (xtManageChild $Raise) + (xtAddCallback $Raise xmNactivateCallback raiseMin $MinText) + (proxtStringToCharPtr 'Max: ' $MaxLabelChrPtr) + (xmStringCreate $MaxLabelChrPtr $DCharset $MaxLabelStr) + (xmCreateLabelGadget $MinMaxRow maxLabel + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $MaxLabelStr)) $MaxLabel) + (xtManageChild $MaxLabel) + (xmCreateRowColumn $MinMaxRow Max + (:: + (xmNadjustLast True) + (xmNmarginHeight 0) + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-TIGHT)) $MaxRow) + (xtManageChild $MaxRow) + (xmCreatePushButton $MaxRow < Nil $LowerMax) + (xtManageChild $LowerMax) + (xmCreateText $MaxRow argumentText + (:: + (xmNeditable True) + (xmNeditMode xmSINGLE-LINE-EDIT) + (xmNwidth 30) + (xmNautoShowCursorPosition True)) $MaxText) + (proxtStringToCharPtr 100 $MaxChrPtr) + (xmTextSetString $MaxText $MaxChrPtr) + (xtManageChild $MaxText) + (recordz examples + (viewMax $MaxText) $_) + (xtAddCallback $LowerMax xmNactivateCallback lowerMax $MaxText) + (xmCreatePushButton $MaxRow > Nil $RaiseMax) + (xtManageChild $RaiseMax) + (xtAddCallback $RaiseMax xmNactivateCallback raiseMax $MaxText) + (recordz examples + (view all) $_) + (recordz examples + (view clause-heads Nil) $_) + (recordz examples + (view dialog $ViewExamplesDialog) $_) + (recordz examples + (view exCHRC $ExCHRC) $_) + (recordz examples + (view viewCHRC $ViewCHRC) $_) + (xmCreateRowColumn $ViewExamplesColumn buttonrow + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $ButtonRow) + (xtManageChild $ButtonRow) + (xmCreatePushButton $ButtonRow View Nil $View) + (xtManageChild $View) + (xtAddCallback $View xmNactivateCallback viewExamples $_) + (xmCreatePushButton $ButtonRow 'View All' Nil $ViewAll) + (xtManageChild $ViewAll) + (xtAddCallback $ViewAll xmNactivateCallback viewAllExamples $_) + (xmCreatePushButton $ButtonRow Cancel Nil $Cancel) + (xtManageChild $Cancel) + (xtAddCallback $Cancel xmNactivateCallback cancelViewExamples $_)) + + +; +; ************************************************************************ +; +; * +; +; * predicate: changeSelectedLabels/1 callback procedure +; +; * +; +; * syntax: changeSelectedLabels(_Widget,+[LabelChangeDialog,LabelText],_CallData) +; +; * +; +; * args: _Widget calling widget +; +; * +[LabelChangeDialog,LabelText] widgets +; +; * _CallData event +; +; * +; +; * description: Removes the LabelChange Dialog from the display, and +; +; * changes the Label of all selected rules. +; +; * +; +; ************************************************************************ + + + (= (changeSelectedLabels $Widget (:: $LabelChangeDialog $LabelText) $CallData) + (xtUnmanageChild $LabelChangeDialog) + (xmTextGetString $LabelText $LabelCP) + (proxtCharPtrToString $LabelCP $LabelAS) + (setSelectedLabels $LabelAS)) + + +; +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: setSelectedLabels/1 ; -; - +; * ; -; - +; * syntax: setSelectedLabels(+Label) ; -; - - +; * +; +; * args: +Label new labelname +; +; * +; +; * description: Sets the label of all selected rules to Label. +; +; * +; +; ************************************************************************ - (= - (createSelectRulesPopup $Parent) - ( (xmCreateBulletinBoardDialog $Parent SelectRules Nil $SelectRulesDialog) - (xtAddCallback $Parent xmNactivateCallback popupDialog $SelectRulesDialog) - (xmCreateFrame $SelectRulesDialog SelectRulesFrame Nil $SelectRulesFrame) - (xtManageChild $SelectRulesFrame) - (xmCreateRowColumn $SelectRulesFrame selectRulesColumn - (:: - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-COLUMN)) $SelectRulesColumn) - (xtManageChild $SelectRulesColumn) - (proxtGetDefaultCharset $DCharset) - (proxtStringToCharPtr 'Select rules:' $TitleCP) - (xmStringCreate $TitleCP $DCharset $TitleStr) - (xmCreateLabelGadget $SelectRulesColumn title - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $TitleStr)) $TitleLabel) - (xtManageChild $TitleLabel) - (xmCreateText $SelectRulesColumn selectRulesText - (:: - (xmNeditable True) - (xmNeditMode xmSINGLE-LINE-EDIT) - (xmNwidth 150) - (xmNautoShowCursorPosition True)) $SelectRulesText) - (xtManageChild $SelectRulesText) - (xtAddActions (:: (action select-ok selectRules $SelectRulesDialog))) - (proxtStringToCharPtr 'Return: select-ok()' $TranslationString) - (xtParseTranslationTable $TranslationString $TranslationTable) - (xtOverrideTranslations $SelectRulesText $TranslationTable) - (xmCreateRowColumn $SelectRulesColumn buttonrow - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $ButtonRow) - (xtManageChild $ButtonRow) - (xmCreatePushButton $ButtonRow Select Nil $Select) - (xtManageChild $Select) - (xtAddCallback $Select xmNactivateCallback selectRules $SelectRulesDialog) - (xmCreatePushButton $ButtonRow 'Select All' Nil $SelectAll) - (xtManageChild $SelectAll) - (xtAddCallback $SelectAll xmNactivateCallback selectRules - (:: rules $SelectRulesDialog)) - (xmCreatePushButton $ButtonRow Cancel Nil $Cancel) - (xtManageChild $Cancel) - (xtAddCallback $Cancel xmNactivateCallback yesNoPopdown $SelectRulesDialog))) -; + (= (setSelectedLabels $Label) + (recorded current + (clause $Id $Widget selected) $Ref) + (erase $Ref) + (get-clause $Id $H $B $CL $_) + (delete-clause $Id) + (store-clause $_ $CL $Label $Id) + (setSelectedLabels $Label) + (recorda current + (clause $Id $Widget selected) $_) + (addRuleItem $Id $H $B $CL $Label) + (updateEvaluationLabel)) + (= (setSelectedLabels $_) + (set-det)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: cancelLabelChange/3 callback procedure ; -; - +; * ; -; - +; * syntax: cancelLabelChange(_Widget,+LabelChangeDialog) ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * +LabelChangeDialog widget ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Removes the LabelChangeDialog from the display. ; -; - - - - (= - (createExamineRulesPopup $Parent) - ( (xmCreateBulletinBoardDialog $Parent ExamineRules Nil $ExamineRulesDialog) - (xtAddCallback $Parent xmNactivateCallback popupExamineRules $_) - (recordz rules - (examine dialog $ExamineRulesDialog) $_) - (xmCreateFrame $ExamineRulesDialog ExamineRulesFrame Nil $ExamineRulesFrame) - (xtManageChild $ExamineRulesFrame) - (xmCreateRowColumn $ExamineRulesFrame examineRulesColumn - (:: - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT)) $ExamineRulesColumn) - (xtManageChild $ExamineRulesColumn) - (xmCreateRowColumn $ExamineRulesColumn titlerow - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $TitleRow) - (xtManageChild $TitleRow) - (proxtGetDefaultCharset $DCharset) - (proxtStringToCharPtr 'Examine rule:' $TitleCP) - (xmStringCreate $TitleCP $DCharset $TitleStr) - (xmCreateLabelGadget $TitleRow title - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $TitleStr)) $TitleLabel) - (xtManageChild $TitleLabel) - (xmCreateScrolledWindow $ExamineRulesColumn ruleSW - (:: - (xmNheight 200) - (xmNwidth 250) - (xmNlistSizePolicy xmCONSTANT) - (xmNscrollBarDisplayPolicy xmSTATIC) - (xmNscrollingPolicy xmAUTOMATIC)) $RuleSW) - (xtManageChild $RuleSW) - (xmCreateRowColumn $RuleSW ruleRC - (:: - (xmNadjustLast False) - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $RuleRC) - (recordz rules - (examineRC $RuleRC) $Ref) - (xtGetValues $RuleRC - (:: (xmNbackground $B))) - (xtGetValues $RuleSW - (:: (xmNclipWindow $CW))) - (xtSetValues $CW - (:: (xmNbackground $B))) - (xtManageChild $RuleRC) - (xmCreateRowColumn $ExamineRulesColumn buttonrow - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $ButtonRow) - (xtManageChild $ButtonRow) - (xmCreatePushButton $ButtonRow Examine Nil $Examine) - (xtManageChild $Examine) - (xtAddCallback $Examine xmNactivateCallback showExaminedRule $_) - (showExaminedRule $_ $_ $_) - (xmCreatePushButton $ButtonRow Cancel Nil $Cancel) - (xtManageChild $Cancel) - (xtAddCallback $Cancel xmNactivateCallback cancelExamineRules $_))) -; - +; * +; +; ************************************************************************ + (= (cancelLabelChange $Widget $LabelChangeDialog $CallData) + (xtUnmanageChild $LabelChangeDialog)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: createClassChangeButtons/1 ; -; - +; * ; -; - +; * syntax: createClassChangeButtons(+Parent) ; -; - +; * ; -; - +; * description: Creates three buttons '+', '-', '?' for changing the ; -; - +; * class of the selected examples. ; -; - - +; * +; +; ************************************************************************ - (= - (showExaminedRule $Widget $RuleNoText $CallData) - ( (proxtGetDefaultCharset $DCharset) - (| - (det-if-then - (recorded rules - (examineText $OldText) $Ref) - (, - (erase $Ref) - (xtDestroyWidget $OldText))) otherwise) - (recorded rules - (examineRC $ExamineRC) $_) - (det-if-then-else - (, - (recorded current - (clause $RuleNo $_ selected) $_) - (get-clause $RuleNo $H $B $S $O)) - (, - (get-evaluation $RuleNo $Evaluation) - (= $Evaluation - (evaluation $E1 $E2 $E3 $E4 $E5 $E6 $E7 $E8 $E9)) - (or - (type-restriction $H $R) - (= $R 'No type restriction found!')) - (numbervars - (, $H $B) 0 $_) - (xxmWriteToString - (, - (show-kb-clause $RuleNo $H $B $O) - (nl) - (write type-restriction:) - (nl) - (write $R) - (nl)) $DCharset $XmS3) - (xxmWriteToString - (, - (nl) - (write evaluation:) - (nl) - (write $E1) - (nl) - (write $E2) - (nl) - (write $E3) - (nl) - (write $E4) - (nl) - (write $E5) - (nl) - (write $E6) - (nl) - (write $E7) - (nl) - (write $E8) - (nl) - (write $E9) - (nl)) $DCharset $XmS4) - (xmStringConcat $XmS3 $XmS4 $XmS) - (xmCreateLabel $ExamineRC anyClause - (:: - (xmNalignment xmALIGNMENT-BEGINNING) - (xmNlabelString $XmS) - (xmNlabelType xmSTRING)) $Label)) - (, - (atom-chars $ASno "No rule selected!") - (proxtStringToCharPtr $ASno $CPno) - (xmStringCreateLtoR $CPno $DCharset $XmSno) - (xmCreateLabel $ExamineRC anyClause - (:: - (xmNalignment xmALIGNMENT-BEGINNING) - (xmNlabelString $XmSno) - (xmNlabelType xmSTRING)) $Label))) - (xtManageChild $Label) - (recordz rules - (examineText $Label) $_) - (set-det))) -; - - - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - - - (= - (createViewRulesPopup $Parent) - ( (xmCreateBulletinBoardDialog $Parent ViewRules Nil $ViewRulesDialog) - (xtAddCallback $Parent xmNactivateCallback popupViewRules $_) - (xmCreateFrame $ViewRulesDialog ViewRulesFrame Nil $ViewRulesFrame) - (xtManageChild $ViewRulesFrame) - (xmCreateRowColumn $ViewRulesFrame viewRulesColumn - (:: - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT)) $ViewRulesColumn) - (xtManageChild $ViewRulesColumn) - (proxtGetDefaultCharset $DCharset) - (proxtStringToCharPtr 'View rules:' $TitleCP) - (xmStringCreate $TitleCP $DCharset $TitleStr) - (xmCreateLabelGadget $ViewRulesColumn title - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $TitleStr)) $TitleLabel) - (xtManageChild $TitleLabel) - (xmCreateFrame $ViewRulesColumn ViewLabelsFrame Nil $ViewLabelFrame) - (xtManageChild $ViewLabelFrame) - (xmCreateRowColumn $ViewLabelFrame labelrow - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $LabelRow) - (xtManageChild $LabelRow) - (xmCreateRowColumn $LabelRow exLabColumn - (:: - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT)) $ExLabColumn) - (xtManageChild $ExLabColumn) - (xmCreateRowColumn $LabelRow viewLabColumn - (:: - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT)) $ViewLabColumn) - (xtManageChild $ViewLabColumn) - (proxtStringToCharPtr 'existing labels' $ExLabCP) - (xmStringCreate $ExLabCP $DCharset $ExLabStr) - (xmCreateLabelGadget $ExLabColumn subtitle - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $ExLabStr)) $ExLabLabel) - (xtManageChild $ExLabLabel) - (proxtStringToCharPtr 'viewed labels' $ViewLabCP) - (xmStringCreate $ViewLabCP $DCharset $ViewLabStr) - (xmCreateLabelGadget $ViewLabColumn subtitle - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $ViewLabStr)) $ViewLabLabel) - (xtManageChild $ViewLabLabel) - (xmCreateScrolledWindow $ExLabColumn exLabSW - (:: - (xmNheight 150) - (xmNwidth 140) - (xmNlistSizePolicy xmCONSTANT) - (xmNscrollBarDisplayPolicy xmSTATIC) - (xmNscrollingPolicy xmAUTOMATIC)) $ExLabSW) - (xtManageChild $ExLabSW) - (xmCreateRowColumn $ExLabSW exLabRC - (:: - (xmNadjustLast False) - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $ExLabRC) - (xtGetValues $ExLabRC - (:: (xmNbackground $ExLabB))) - (xtGetValues $ExLabSW - (:: (xmNclipWindow $ExLabCW))) - (xtSetValues $ExLabCW - (:: (xmNbackground $ExLabB))) - (xtManageChild $ExLabRC) - (xmCreateScrolledWindow $ViewLabColumn viewedLabSW - (:: - (xmNheight 150) - (xmNwidth 140) - (xmNlistSizePolicy xmCONSTANT) - (xmNscrollBarDisplayPolicy xmSTATIC) - (xmNscrollingPolicy xmAUTOMATIC)) $ViewLabSW) - (xtManageChild $ViewLabSW) - (xmCreateRowColumn $ViewLabSW viewLabRC - (:: - (xmNadjustLast False) - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $ViewLabRC) - (xtGetValues $ViewLabRC - (:: (xmNbackground $ViewLabB))) - (xtGetValues $ViewLabSW - (:: (xmNclipWindow $ViewLabCW))) - (xtSetValues $ViewLabCW - (:: (xmNbackground $ViewLabB))) - (xtManageChild $ViewLabRC) - (xmCreateFrame $ViewRulesColumn ViewClauseHeadFrame Nil $ViewClauseHeadFrame) - (xtManageChild $ViewClauseHeadFrame) - (xmCreateRowColumn $ViewClauseHeadFrame clauseHeadrow - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $ClauseHeadRow) - (xtManageChild $ClauseHeadRow) - (xmCreateRowColumn $ClauseHeadRow exCHColumn - (:: - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT)) $ExCHColumn) - (xtManageChild $ExCHColumn) - (xmCreateRowColumn $ClauseHeadRow viewCHColumn - (:: - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT)) $ViewCHColumn) - (xtManageChild $ViewCHColumn) - (proxtStringToCharPtr 'existing clause heads' $ExCHCP) - (xmStringCreate $ExCHCP $DCharset $ExCHStr) - (xmCreateLabelGadget $ExCHColumn subtitle - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $ExCHStr)) $ExCHLabel) - (xtManageChild $ExCHLabel) - (proxtStringToCharPtr 'viewed clause heads' $ViewCHCP) - (xmStringCreate $ViewCHCP $DCharset $ViewCHStr) - (xmCreateLabelGadget $ViewCHColumn subtitle - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $ViewCHStr)) $ViewCHLabel) - (xtManageChild $ViewCHLabel) - (xmCreateScrolledWindow $ExCHColumn existingCHSW - (:: - (xmNheight 150) - (xmNwidth 140) - (xmNlistSizePolicy xmCONSTANT) - (xmNscrollBarDisplayPolicy xmSTATIC) - (xmNscrollingPolicy xmAUTOMATIC)) $ExCHSW) - (xtManageChild $ExCHSW) - (xmCreateRowColumn $ExCHSW exCHRC - (:: - (xmNadjustLast False) - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $ExCHRC) - (xtGetValues $ExCHRC - (:: (xmNbackground $ExCHB))) - (xtGetValues $ExCHSW - (:: (xmNclipWindow $ExCHCW))) - (xtSetValues $ExCHCW - (:: (xmNbackground $ExCHB))) - (xtManageChild $ExCHRC) - (xmCreateScrolledWindow $ViewCHColumn viewedCHSW - (:: - (xmNheight 150) - (xmNwidth 140) - (xmNlistSizePolicy xmCONSTANT) - (xmNscrollBarDisplayPolicy xmSTATIC) - (xmNscrollingPolicy xmAUTOMATIC)) $ViewCHSW) - (xtManageChild $ViewCHSW) - (xmCreateRowColumn $ViewCHSW viewCHRC - (:: - (xmNadjustLast False) - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $ViewCHRC) - (xtGetValues $ViewCHRC - (:: (xmNbackground $ViewCHB))) - (xtGetValues $ViewCHSW - (:: (xmNclipWindow $ViewCHCW))) - (xtSetValues $ViewCHCW - (:: (xmNbackground $ViewCHB))) - (xtManageChild $ViewCHRC) - (xmCreateRowColumn $ViewRulesColumn minMaxRow - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $MinMaxRow) - (xtManageChild $MinMaxRow) - (proxtStringToCharPtr 'Min: ' $MinLabelChrPtr) - (xmStringCreate $MinLabelChrPtr $DCharset $MinLabelStr) - (xmCreateLabelGadget $MinMaxRow minLabel - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $MinLabelStr)) $MinLabel) - (xtManageChild $MinLabel) - (xmCreateRowColumn $MinMaxRow Min - (:: - (xmNadjustLast True) - (xmNmarginHeight 0) - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-TIGHT)) $MinRow) - (xtManageChild $MinRow) - (xmCreatePushButton $MinRow < Nil $Lower) - (xtManageChild $Lower) - (xmCreateText $MinRow argumentText - (:: - (xmNeditable True) - (xmNeditMode xmSINGLE-LINE-EDIT) - (xmNwidth 30) - (xmNautoShowCursorPosition True)) $MinText) - (proxtStringToCharPtr 1 $MinChrPtr) - (xmTextSetString $MinText $MinChrPtr) - (xtManageChild $MinText) - (recordz rules - (viewMin $MinText) $_) - (xtAddCallback $Lower xmNactivateCallback lowerMin $MinText) - (xmCreatePushButton $MinRow > Nil $Raise) - (xtManageChild $Raise) - (xtAddCallback $Raise xmNactivateCallback raiseMin $MinText) - (proxtStringToCharPtr 'Max: ' $MaxLabelChrPtr) - (xmStringCreate $MaxLabelChrPtr $DCharset $MaxLabelStr) - (xmCreateLabelGadget $MinMaxRow maxLabel - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $MaxLabelStr)) $MaxLabel) - (xtManageChild $MaxLabel) - (xmCreateRowColumn $MinMaxRow Max - (:: - (xmNadjustLast True) - (xmNmarginHeight 0) - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-TIGHT)) $MaxRow) - (xtManageChild $MaxRow) - (xmCreatePushButton $MaxRow < Nil $LowerMax) - (xtManageChild $LowerMax) - (xmCreateText $MaxRow argumentText - (:: - (xmNeditable True) - (xmNeditMode xmSINGLE-LINE-EDIT) - (xmNwidth 30) - (xmNautoShowCursorPosition True)) $MaxText) - (proxtStringToCharPtr 100 $MaxChrPtr) - (xmTextSetString $MaxText $MaxChrPtr) - (xtManageChild $MaxText) - (recordz rules - (viewMax $MaxText) $_) - (xtAddCallback $LowerMax xmNactivateCallback lowerMax $MaxText) - (xmCreatePushButton $MaxRow > Nil $RaiseMax) - (xtManageChild $RaiseMax) - (xtAddCallback $RaiseMax xmNactivateCallback raiseMax $MaxText) - (recordz rules - (view all) $_) - (recordz rules - (view labels Nil) $_) - (recordz rules - (view clause-heads Nil) $_) - (recordz rules - (view dialog $ViewRulesDialog) $_) - (recordz rules - (view exLabRC $ExLabRC) $_) - (recordz rules - (view viewLabRC $ViewLabRC) $_) - (recordz rules - (view exCHRC $ExCHRC) $_) - (recordz rules - (view viewCHRC $ViewCHRC) $_) - (xmCreateRowColumn $ViewRulesColumn buttonrow - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $ButtonRow) - (xtManageChild $ButtonRow) - (xmCreatePushButton $ButtonRow View Nil $View) - (xtManageChild $View) - (xtAddCallback $View xmNactivateCallback viewRules $_) - (xmCreatePushButton $ButtonRow 'View All' Nil $ViewAll) - (xtManageChild $ViewAll) - (xtAddCallback $ViewAll xmNactivateCallback viewAllRules $_) - (xmCreatePushButton $ButtonRow Cancel Nil $Cancel) - (xtManageChild $Cancel) - (xtAddCallback $Cancel xmNactivateCallback cancelViewRules $_))) -; - - - - - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - - - (= - (createViewExamplesPopup $Parent) - ( (xmCreateBulletinBoardDialog $Parent ViewExamples Nil $ViewExamplesDialog) - (xtAddCallback $Parent xmNactivateCallback popupViewExamples $_) - (xmCreateFrame $ViewExamplesDialog ViewExamplesFrame Nil $ViewExamplesFrame) - (xtManageChild $ViewExamplesFrame) - (xmCreateRowColumn $ViewExamplesFrame viewExamplesColumn - (:: - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT)) $ViewExamplesColumn) - (xtManageChild $ViewExamplesColumn) - (proxtGetDefaultCharset $DCharset) - (proxtStringToCharPtr 'View examples:' $TitleCP) - (xmStringCreate $TitleCP $DCharset $TitleStr) - (xmCreateLabelGadget $ViewExamplesColumn title - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $TitleStr)) $TitleLabel) - (xtManageChild $TitleLabel) - (xmCreateFrame $ViewExamplesColumn ViewClauseHeadFrame Nil $ViewClauseHeadFrame) - (xtManageChild $ViewClauseHeadFrame) - (xmCreateRowColumn $ViewClauseHeadFrame clauseHeadrow - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $ClauseHeadRow) - (xtManageChild $ClauseHeadRow) - (xmCreateRowColumn $ClauseHeadRow exCHColumn - (:: - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT)) $ExCHColumn) - (xtManageChild $ExCHColumn) - (xmCreateRowColumn $ClauseHeadRow viewCHColumn - (:: - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT)) $ViewCHColumn) - (xtManageChild $ViewCHColumn) - (proxtStringToCharPtr 'existing clause heads' $ExCHCP) - (xmStringCreate $ExCHCP $DCharset $ExCHStr) - (xmCreateLabelGadget $ExCHColumn subtitle - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $ExCHStr)) $ExCHLabel) - (xtManageChild $ExCHLabel) - (proxtStringToCharPtr 'viewed clause heads' $ViewCHCP) - (xmStringCreate $ViewCHCP $DCharset $ViewCHStr) - (xmCreateLabelGadget $ViewCHColumn subtitle - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $ViewCHStr)) $ViewCHLabel) - (xtManageChild $ViewCHLabel) - (xmCreateScrolledWindow $ExCHColumn existingCHSW - (:: - (xmNheight 150) - (xmNwidth 140) - (xmNlistSizePolicy xmCONSTANT) - (xmNscrollBarDisplayPolicy xmSTATIC) - (xmNscrollingPolicy xmAUTOMATIC)) $ExCHSW) - (xtManageChild $ExCHSW) - (xmCreateRowColumn $ExCHSW exCHRC - (:: - (xmNadjustLast False) - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $ExCHRC) - (xtGetValues $ExCHRC - (:: (xmNbackground $ExCHB))) - (xtGetValues $ExCHSW - (:: (xmNclipWindow $ExCHCW))) - (xtSetValues $ExCHCW - (:: (xmNbackground $ExCHB))) - (xtManageChild $ExCHRC) - (xmCreateScrolledWindow $ViewCHColumn viewedCHSW - (:: - (xmNheight 150) - (xmNwidth 140) - (xmNlistSizePolicy xmCONSTANT) - (xmNscrollBarDisplayPolicy xmSTATIC) - (xmNscrollingPolicy xmAUTOMATIC)) $ViewCHSW) - (xtManageChild $ViewCHSW) - (xmCreateRowColumn $ViewCHSW viewCHRC - (:: - (xmNadjustLast False) - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $ViewCHRC) - (xtGetValues $ViewCHRC - (:: (xmNbackground $ViewCHB))) - (xtGetValues $ViewCHSW - (:: (xmNclipWindow $ViewCHCW))) - (xtSetValues $ViewCHCW - (:: (xmNbackground $ViewCHB))) - (xtManageChild $ViewCHRC) - (xmCreateRowColumn $ViewExamplesColumn minMaxRow - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $MinMaxRow) - (xtManageChild $MinMaxRow) - (proxtStringToCharPtr 'Min: ' $MinLabelChrPtr) - (xmStringCreate $MinLabelChrPtr $DCharset $MinLabelStr) - (xmCreateLabelGadget $MinMaxRow minLabel - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $MinLabelStr)) $MinLabel) - (xtManageChild $MinLabel) - (xmCreateRowColumn $MinMaxRow Min - (:: - (xmNadjustLast True) - (xmNmarginHeight 0) - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-TIGHT)) $MinRow) - (xtManageChild $MinRow) - (xmCreatePushButton $MinRow < Nil $Lower) - (xtManageChild $Lower) - (xmCreateText $MinRow argumentText - (:: - (xmNeditable True) - (xmNeditMode xmSINGLE-LINE-EDIT) - (xmNwidth 30) - (xmNautoShowCursorPosition True)) $MinText) - (proxtStringToCharPtr 1 $MinChrPtr) - (xmTextSetString $MinText $MinChrPtr) - (xtManageChild $MinText) - (recordz examples - (viewMin $MinText) $_) - (xtAddCallback $Lower xmNactivateCallback lowerMin $MinText) - (xmCreatePushButton $MinRow > Nil $Raise) - (xtManageChild $Raise) - (xtAddCallback $Raise xmNactivateCallback raiseMin $MinText) - (proxtStringToCharPtr 'Max: ' $MaxLabelChrPtr) - (xmStringCreate $MaxLabelChrPtr $DCharset $MaxLabelStr) - (xmCreateLabelGadget $MinMaxRow maxLabel - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $MaxLabelStr)) $MaxLabel) - (xtManageChild $MaxLabel) - (xmCreateRowColumn $MinMaxRow Max - (:: - (xmNadjustLast True) - (xmNmarginHeight 0) - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-TIGHT)) $MaxRow) - (xtManageChild $MaxRow) - (xmCreatePushButton $MaxRow < Nil $LowerMax) - (xtManageChild $LowerMax) - (xmCreateText $MaxRow argumentText - (:: - (xmNeditable True) - (xmNeditMode xmSINGLE-LINE-EDIT) - (xmNwidth 30) - (xmNautoShowCursorPosition True)) $MaxText) - (proxtStringToCharPtr 100 $MaxChrPtr) - (xmTextSetString $MaxText $MaxChrPtr) - (xtManageChild $MaxText) - (recordz examples - (viewMax $MaxText) $_) - (xtAddCallback $LowerMax xmNactivateCallback lowerMax $MaxText) - (xmCreatePushButton $MaxRow > Nil $RaiseMax) - (xtManageChild $RaiseMax) - (xtAddCallback $RaiseMax xmNactivateCallback raiseMax $MaxText) - (recordz examples - (view all) $_) - (recordz examples - (view clause-heads Nil) $_) - (recordz examples - (view dialog $ViewExamplesDialog) $_) - (recordz examples - (view exCHRC $ExCHRC) $_) - (recordz examples - (view viewCHRC $ViewCHRC) $_) - (xmCreateRowColumn $ViewExamplesColumn buttonrow - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $ButtonRow) - (xtManageChild $ButtonRow) - (xmCreatePushButton $ButtonRow View Nil $View) - (xtManageChild $View) - (xtAddCallback $View xmNactivateCallback viewExamples $_) - (xmCreatePushButton $ButtonRow 'View All' Nil $ViewAll) - (xtManageChild $ViewAll) - (xtAddCallback $ViewAll xmNactivateCallback viewAllExamples $_) - (xmCreatePushButton $ButtonRow Cancel Nil $Cancel) - (xtManageChild $Cancel) - (xtAddCallback $Cancel xmNactivateCallback cancelViewExamples $_))) -; + (= (createClassChangeButtons $Parent) + (xmCreateRowColumn $Parent 'Class Change' + (:: + (xmNadjustLast True) + (xmNmarginHeight 0) + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN) + (xmNrowColumnType xmWORK-AREA)) $ClassChangeRow) + (xtManageChild $ClassChangeRow) + (xmCreatePushButton $ClassChangeRow + Nil $Positive) + (xtManageChild $Positive) + (xtAddCallback $Positive xmNactivateCallback classChangeSelected +) + (xmCreatePushButton $ClassChangeRow - Nil $Negative) + (xtManageChild $Negative) + (xtAddCallback $Negative xmNactivateCallback classChangeSelected -) + (xmCreatePushButton $ClassChangeRow ? Nil $Quest) + (xtManageChild $Quest) + (xtAddCallback $Quest xmNactivateCallback classChangeSelected ?)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: classChangeSelected/3 Callback procedure ; -; - +; * ; -; - +; * syntax: classChangeSelected(_Widget,+Classification,_CallData) ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * +Classification '+' or '-' or '?' ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Sets the classification of the selected examples to ; -; - +; * Classification. ; -; - +; * ; -; +; ************************************************************************ + (= (classChangeSelected $Widget $Classification $CallData) + (recorded current + (example $Id $Label selected) $Ref) + (erase $Ref) + (get-example $Id $Fact $_) + (delete-example $Id) + (store-ex $Fact $Classification $Id) + (classChangeSelected $Widget $Classification $CallData) + (recorda current + (example $Id $Label selected) $_) + (addExampleItem $Id $Fact $Classification) + (updateEvaluationLabel)) + (= (classChangeSelected $_ $_ $_) + (set-det)) - (= - (changeSelectedLabels $Widget - (:: $LabelChangeDialog $LabelText) $CallData) - ( (xtUnmanageChild $LabelChangeDialog) - (xmTextGetString $LabelText $LabelCP) - (proxtCharPtrToString $LabelCP $LabelAS) - (setSelectedLabels $LabelAS))) -; +; +; ************************************************************************ +; +; * +; +; * predicate: createArgumentArea/1 +; +; * +; +; * syntax: createArgumentArea(+Parent) +; +; * +; +; * description: Creates the argument area with five fields for arguments, +; +; * one toggle button for copying rule ids into argument +; +; * fields when selecting or deselecting rules or examples, +; +; * and a clear push button. +; +; * +; +; ************************************************************************ -; -; + (= (createArgumentArea $Parent) + (xmCreateFrame $Parent Arguments Nil $ArgumentFrame) + (xtManageChild $ArgumentFrame) + (xmCreateRowColumn $ArgumentFrame Arguments + (:: + (xmNwidth 300) + (xmNadjustLast True) + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $ArgumentColumn) + (xtManageChild $ArgumentColumn) + (proxtStringToCharPtr Arguments $ArgumentChrPtr) + (proxtGetDefaultCharset $DCharset) + (xmStringCreate $ArgumentChrPtr $DCharset $ArgumentStr) + (xmCreateLabelGadget $ArgumentColumn argumentLabel + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $ArgumentStr)) $ArgumentLabel) + (xtManageChild $ArgumentLabel) + (xmCreateRowColumn $ArgumentColumn kommandoRC + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN) + (xmNnumColumns 2)) $ArgumentRow) + (xtManageChild $ArgumentRow) + (createArguments $ArgumentRow 12) + (xmCreateRowColumn $ArgumentColumn buttonrow + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-TIGHT) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $ButtonRow) + (xtManageChild $ButtonRow) + (xmCreateToggleButton $ButtonRow 'Get Id ' Nil $GetId) + (xtManageChild $GetId) + (recordz state + (getId $GetId) $_) + (xmCreatePushButton $ButtonRow Clear Nil $Clear) + (xtManageChild $Clear) + (xtAddCallback $Clear xmNactivateCallback clearArguments 12) + (proxtStringToCharPtr ' Depth: ' $DepthChrPtr) + (xmStringCreate $DepthChrPtr $DCharset $DepthStr) + (xmCreateLabelGadget $ButtonRow depthLabel + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $DepthStr)) $DepthLabel) + (xtManageChild $DepthLabel) + (xmCreateRowColumn $ButtonRow Depth + (:: + (xmNadjustLast True) + (xmNmarginHeight 0) + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-TIGHT)) $DepthRow) + (xtManageChild $DepthRow) + (xmCreatePushButton $DepthRow < Nil $Lower) + (xtManageChild $Lower) + (xmCreateText $DepthRow argumentText + (:: + (xmNeditable True) + (xmNeditMode xmSINGLE-LINE-EDIT) + (xmNwidth 30) + (xmNautoShowCursorPosition True)) $DText) + (proxtStringToCharPtr 5 $DChrPtr) + (xmTextSetString $DText $DChrPtr) + (xtManageChild $DText) + (recordz state + (argumentWidget depth $DText) $_) + (xtAddCallback $Lower xmNactivateCallback lowerDepth $DText) + (xmCreatePushButton $DepthRow > Nil $Raise) + (xtManageChild $Raise) + (xtAddCallback $Raise xmNactivateCallback raiseDepth $DText)) -; -; ; -; +; ************************************************************************ +; +; * +; +; * predicate: createArguments/2 +; +; * +; +; * syntax: createArguments(+Parent,+Count) +; +; * +; +; * args: +Parent parent widget +; +; * +Count number of argument fields to create +; +; * +; +; * description: Creates Count text widgets for the arguments. +; +; * +; +; ************************************************************************ + + + (= (createArguments $_ 0) + (set-det)) + (= (createArguments $Parent $Count) + (is $C1 + (- $Count 1)) + (createArguments $Parent $C1) + (xmCreateText $Parent argumentText + (:: + (xmNeditable True) + (xmNeditMode xmSINGLE-LINE-EDIT) + (xmNwidth 50) + (xmNautoShowCursorPosition True)) $ArgumentText) + (xtManageChild $ArgumentText) + (recordz state + (argumentWidget $Count $ArgumentText) $_)) -; -; ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: clearArguments/3 callback procedure ; -; - +; * ; -; - +; * syntax: clearArguments(_Widget,+Count,_CallData) ; -; - +; * ; -; - - +; * args: _Widget calling widget +; +; * Count Number of arguments to clear (5) +; +; * _CallData +; +; * +; +; * description: Clears Count argument text widgets +; +; * +; +; ************************************************************************ - (= - (setSelectedLabels $Label) - ( (recorded current - (clause $Id $Widget selected) $Ref) - (erase $Ref) - (get-clause $Id $H $B $CL $_) - (delete-clause $Id) - (store-clause $_ $CL $Label $Id) - (setSelectedLabels $Label) - (recorda current - (clause $Id $Widget selected) $_) - (addRuleItem $Id $H $B $CL $Label) - (updateEvaluationLabel))) -; - - (= - (setSelectedLabels $_) - (set-det)) -; + (= (clearArguments $Widget 0 $CallData) True) + (= (clearArguments $Widget $Count $CallData) + (is $C1 + (- $Count 1)) + (clearArguments $Widget $C1 $CallData) + (recorded state + (argumentWidget $Count $Text) $_) + (proxtStringToCharPtr '' $EmptyChrPtr) + (xmTextSetString $Text $EmptyChrPtr)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: lowerDepth/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * +DepthText TextWidget of Depth ; -; - +; * _CallData ; -; - +; * ; -; - +; * description: 1 decrements xmDepth. ; -; - +; * ; -; - - +; * see also: raiseDepth +; +; * +; +; ************************************************************************ - (= - (cancelLabelChange $Widget $LabelChangeDialog $CallData) - (xtUnmanageChild $LabelChangeDialog)) -; + (= (lowerDepth $Widget $DepthText $CallData) + (xmTextGetString $DepthText $OldDepthCP) + (proxtCharPtrToString $OldDepthCP $OldDepthStr) + (atom-chars $OldDepthStr $OldDepthC) + (number-chars $OldDepth $OldDepthC) + (| + (det-if-then + (= $OldDepth 0) + (is $NewDepth 100)) + (det-if-then otherwise + (is $NewDepth + (- $OldDepth 1)))) + (number-chars $NewDepth $NewDepthC) + (atom-chars $NewDepthStr $NewDepthC) + (proxtStringToCharPtr $NewDepthStr $NewDepthCP) + (xmTextSetString $DepthText $NewDepthCP)) ; -; - +; ************************************************************************ ; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - - - (= - (createClassChangeButtons $Parent) - ( (xmCreateRowColumn $Parent 'Class Change' - (:: - (xmNadjustLast True) - (xmNmarginHeight 0) - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN) - (xmNrowColumnType xmWORK-AREA)) $ClassChangeRow) - (xtManageChild $ClassChangeRow) - (xmCreatePushButton $ClassChangeRow + Nil $Positive) - (xtManageChild $Positive) - (xtAddCallback $Positive xmNactivateCallback classChangeSelected +) - (xmCreatePushButton $ClassChangeRow - Nil $Negative) - (xtManageChild $Negative) - (xtAddCallback $Negative xmNactivateCallback classChangeSelected -) - (xmCreatePushButton $ClassChangeRow ? Nil $Quest) - (xtManageChild $Quest) - (xtAddCallback $Quest xmNactivateCallback classChangeSelected ?))) -; - - - -; -; - -; -; - -; -; - -; -; - -; -; - +; * ; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - +; * predicate: lowerID/3 callback procedure ; -; - +; * ; -; - - - - (= - (classChangeSelected $Widget $Classification $CallData) - ( (recorded current - (example $Id $Label selected) $Ref) - (erase $Ref) - (get-example $Id $Fact $_) - (delete-example $Id) - (store-ex $Fact $Classification $Id) - (classChangeSelected $Widget $Classification $CallData) - (recorda current - (example $Id $Label selected) $_) - (addExampleItem $Id $Fact $Classification) - (updateEvaluationLabel))) -; - - (= - (classChangeSelected $_ $_ $_) - (set-det)) -; - - - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * +DepthText TextWidget containing ID ; -; - +; * _CallData ; -; - +; * ; -; - +; * description: 1 decrements ID. ; -; - +; * ; -; - +; * see also: raiseID ; -; - +; * ; -; +; ************************************************************************ -; -; - -; -; - - - - (= - (createArgumentArea $Parent) - ( (xmCreateFrame $Parent Arguments Nil $ArgumentFrame) - (xtManageChild $ArgumentFrame) - (xmCreateRowColumn $ArgumentFrame Arguments - (:: - (xmNwidth 300) - (xmNadjustLast True) - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $ArgumentColumn) - (xtManageChild $ArgumentColumn) - (proxtStringToCharPtr Arguments $ArgumentChrPtr) - (proxtGetDefaultCharset $DCharset) - (xmStringCreate $ArgumentChrPtr $DCharset $ArgumentStr) - (xmCreateLabelGadget $ArgumentColumn argumentLabel - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $ArgumentStr)) $ArgumentLabel) - (xtManageChild $ArgumentLabel) - (xmCreateRowColumn $ArgumentColumn kommandoRC - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN) - (xmNnumColumns 2)) $ArgumentRow) - (xtManageChild $ArgumentRow) - (createArguments $ArgumentRow 12) - (xmCreateRowColumn $ArgumentColumn buttonrow - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-TIGHT) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $ButtonRow) - (xtManageChild $ButtonRow) - (xmCreateToggleButton $ButtonRow 'Get Id ' Nil $GetId) - (xtManageChild $GetId) - (recordz state - (getId $GetId) $_) - (xmCreatePushButton $ButtonRow Clear Nil $Clear) - (xtManageChild $Clear) - (xtAddCallback $Clear xmNactivateCallback clearArguments 12) - (proxtStringToCharPtr ' Depth: ' $DepthChrPtr) - (xmStringCreate $DepthChrPtr $DCharset $DepthStr) - (xmCreateLabelGadget $ButtonRow depthLabel - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $DepthStr)) $DepthLabel) - (xtManageChild $DepthLabel) - (xmCreateRowColumn $ButtonRow Depth - (:: - (xmNadjustLast True) - (xmNmarginHeight 0) - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-TIGHT)) $DepthRow) - (xtManageChild $DepthRow) - (xmCreatePushButton $DepthRow < Nil $Lower) - (xtManageChild $Lower) - (xmCreateText $DepthRow argumentText - (:: - (xmNeditable True) - (xmNeditMode xmSINGLE-LINE-EDIT) - (xmNwidth 30) - (xmNautoShowCursorPosition True)) $DText) - (proxtStringToCharPtr 5 $DChrPtr) - (xmTextSetString $DText $DChrPtr) - (xtManageChild $DText) - (recordz state - (argumentWidget depth $DText) $_) - (xtAddCallback $Lower xmNactivateCallback lowerDepth $DText) - (xmCreatePushButton $DepthRow > Nil $Raise) - (xtManageChild $Raise) - (xtAddCallback $Raise xmNactivateCallback raiseDepth $DText))) -; - - - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - - - (= - (createArguments $_ 0) - (set-det)) -; - - (= - (createArguments $Parent $Count) - ( (is $C1 - (- $Count 1)) - (createArguments $Parent $C1) - (xmCreateText $Parent argumentText - (:: - (xmNeditable True) - (xmNeditMode xmSINGLE-LINE-EDIT) - (xmNwidth 50) - (xmNautoShowCursorPosition True)) $ArgumentText) - (xtManageChild $ArgumentText) - (recordz state - (argumentWidget $Count $ArgumentText) $_))) -; - - - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - - - (= - (clearArguments $Widget 0 $CallData) True) -; - - (= - (clearArguments $Widget $Count $CallData) - ( (is $C1 - (- $Count 1)) - (clearArguments $Widget $C1 $CallData) - (recorded state - (argumentWidget $Count $Text) $_) - (proxtStringToCharPtr '' $EmptyChrPtr) - (xmTextSetString $Text $EmptyChrPtr))) -; - - - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - - - (= - (lowerDepth $Widget $DepthText $CallData) - ( (xmTextGetString $DepthText $OldDepthCP) - (proxtCharPtrToString $OldDepthCP $OldDepthStr) - (atom-chars $OldDepthStr $OldDepthC) - (number-chars $OldDepth $OldDepthC) - (| - (det-if-then - (= $OldDepth 0) - (is $NewDepth 100)) - (det-if-then otherwise - (is $NewDepth - (- $OldDepth 1)))) - (number-chars $NewDepth $NewDepthC) - (atom-chars $NewDepthStr $NewDepthC) - (proxtStringToCharPtr $NewDepthStr $NewDepthCP) - (xmTextSetString $DepthText $NewDepthCP))) -; - - - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - - - (= - (lowerID $Widget $IDText $CallData) - ( (xmTextGetString $IDText $OldIDCP) - (proxtCharPtrToString $OldIDCP $OldIDStr) - (atom-chars $OldIDStr $OldIDC) - (number-chars $OldID $OldIDC) - (| - (det-if-then - (= $OldID 0) - (is $NewID 9999)) - (det-if-then otherwise - (is $NewID - (- $OldID 1)))) - (number-chars $NewID $NewIDC) - (atom-chars $NewIDStr $NewIDC) - (proxtStringToCharPtr $NewIDStr $NewIDCP) - (xmTextSetString $IDText $NewIDCP))) -; + (= (lowerID $Widget $IDText $CallData) + (xmTextGetString $IDText $OldIDCP) + (proxtCharPtrToString $OldIDCP $OldIDStr) + (atom-chars $OldIDStr $OldIDC) + (number-chars $OldID $OldIDC) + (| + (det-if-then + (= $OldID 0) + (is $NewID 9999)) + (det-if-then otherwise + (is $NewID + (- $OldID 1)))) + (number-chars $NewID $NewIDC) + (atom-chars $NewIDStr $NewIDC) + (proxtStringToCharPtr $NewIDStr $NewIDCP) + (xmTextSetString $IDText $NewIDCP)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: lowerMin/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * +DepthText TextWidget of Depth ; -; - +; * _CallData ; -; - +; * ; -; - +; * description: 1 decrements MinId of viewed rules or examples. ; -; - +; * ; -; +; ************************************************************************ - - (= - (lowerMin $Widget $MinText $CallData) - ( (| - (det-if-then - (recorded rules - (viewMin $MinText) $_) - (= $KindOfKnowledge rules)) - (det-if-then otherwise - (= $KindOfKnowledge examples))) - (xmTextGetString $MinText $OldMinCP) - (proxtCharPtrToString $OldMinCP $OldMinStr) - (atom-chars $OldMinStr $OldMinC) - (number-chars $OldMin $OldMinC) - (recorded $KindOfKnowledge - (viewMax $MaxText) $_) - (xmTextGetString $MaxText $MaxCP) - (proxtCharPtrToString $MaxCP $MaxStr) - (atom-chars $MaxStr $MaxC) - (number-chars $Max $MaxC) - (| - (det-if-then - (=< $OldMin 1) - (is $NewMin $Max)) - (det-if-then otherwise - (is $NewMin - (- $OldMin 1)))) - (number-chars $NewMin $NewMinC) - (atom-chars $NewMinStr $NewMinC) - (proxtStringToCharPtr $NewMinStr $NewMinCP) - (xmTextSetString $MinText $NewMinCP))) -; - + (= (lowerMin $Widget $MinText $CallData) + (| + (det-if-then + (recorded rules + (viewMin $MinText) $_) + (= $KindOfKnowledge rules)) + (det-if-then otherwise + (= $KindOfKnowledge examples))) + (xmTextGetString $MinText $OldMinCP) + (proxtCharPtrToString $OldMinCP $OldMinStr) + (atom-chars $OldMinStr $OldMinC) + (number-chars $OldMin $OldMinC) + (recorded $KindOfKnowledge + (viewMax $MaxText) $_) + (xmTextGetString $MaxText $MaxCP) + (proxtCharPtrToString $MaxCP $MaxStr) + (atom-chars $MaxStr $MaxC) + (number-chars $Max $MaxC) + (| + (det-if-then + (=< $OldMin 1) + (is $NewMin $Max)) + (det-if-then otherwise + (is $NewMin + (- $OldMin 1)))) + (number-chars $NewMin $NewMinC) + (atom-chars $NewMinStr $NewMinC) + (proxtStringToCharPtr $NewMinStr $NewMinCP) + (xmTextSetString $MinText $NewMinCP)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: lowerMax/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * +DepthText TextWidget of Depth ; -; - +; * _CallData ; -; - +; * ; -; - +; * description: 1 decrements MaxId of viewed rules or examples. ; -; - +; * ; -; - +; ************************************************************************ - (= - (lowerMax $Widget $MaxText $CallData) - ( (| - (det-if-then - (recorded rules - (viewMin $MinText) $_) - (= $KindOfKnowledge rules)) - (det-if-then otherwise - (= $KindOfKnowledge examples))) - (xmTextGetString $MaxText $OldMaxCP) - (proxtCharPtrToString $OldMaxCP $OldMaxStr) - (atom-chars $OldMaxStr $OldMaxC) - (number-chars $OldMax $OldMaxC) - (recorded $KindOfKnowledge - (viewMin $MinText) $_) - (xmTextGetString $MinText $MinCP) - (proxtCharPtrToString $MinCP $MinStr) - (atom-chars $MinStr $MinC) - (number-chars $Min $MinC) - (| - (det-if-then - (=< $OldMax $Min) - (is $NewMax 9999)) - (det-if-then otherwise - (is $NewMax - (- $OldMax 1)))) - (number-chars $NewMax $NewMaxC) - (atom-chars $NewMaxStr $NewMaxC) - (proxtStringToCharPtr $NewMaxStr $NewMaxCP) - (xmTextSetString $MaxText $NewMaxCP))) -; - + (= (lowerMax $Widget $MaxText $CallData) + (| + (det-if-then + (recorded rules + (viewMin $MinText) $_) + (= $KindOfKnowledge rules)) + (det-if-then otherwise + (= $KindOfKnowledge examples))) + (xmTextGetString $MaxText $OldMaxCP) + (proxtCharPtrToString $OldMaxCP $OldMaxStr) + (atom-chars $OldMaxStr $OldMaxC) + (number-chars $OldMax $OldMaxC) + (recorded $KindOfKnowledge + (viewMin $MinText) $_) + (xmTextGetString $MinText $MinCP) + (proxtCharPtrToString $MinCP $MinStr) + (atom-chars $MinStr $MinC) + (number-chars $Min $MinC) + (| + (det-if-then + (=< $OldMax $Min) + (is $NewMax 9999)) + (det-if-then otherwise + (is $NewMax + (- $OldMax 1)))) + (number-chars $NewMax $NewMaxC) + (atom-chars $NewMaxStr $NewMaxC) + (proxtStringToCharPtr $NewMaxStr $NewMaxCP) + (xmTextSetString $MaxText $NewMaxCP)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: raiseDepth/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * +DepthText TextWidget of Depth ; -; - +; * _CallData ; -; - +; * ; -; - +; * description: 1 inrements xmDepth. ; -; - +; * ; -; - +; ************************************************************************ - (= - (raiseDepth $Widget $DepthText $CallData) - ( (xmTextGetString $DepthText $OldDepthCP) - (proxtCharPtrToString $OldDepthCP $OldDepthStr) - (atom-chars $OldDepthStr $OldDepthC) - (number-chars $OldDepth $OldDepthC) - (| - (det-if-then - (= $OldDepth 100) - (is $NewDepth 0)) - (det-if-then otherwise - (is $NewDepth - (+ $OldDepth 1)))) - (number-chars $NewDepth $NewDepthC) - (atom-chars $NewDepthStr $NewDepthC) - (proxtStringToCharPtr $NewDepthStr $NewDepthCP) - (xmTextSetString $DepthText $NewDepthCP))) -; - + (= (raiseDepth $Widget $DepthText $CallData) + (xmTextGetString $DepthText $OldDepthCP) + (proxtCharPtrToString $OldDepthCP $OldDepthStr) + (atom-chars $OldDepthStr $OldDepthC) + (number-chars $OldDepth $OldDepthC) + (| + (det-if-then + (= $OldDepth 100) + (is $NewDepth 0)) + (det-if-then otherwise + (is $NewDepth + (+ $OldDepth 1)))) + (number-chars $NewDepth $NewDepthC) + (atom-chars $NewDepthStr $NewDepthC) + (proxtStringToCharPtr $NewDepthStr $NewDepthCP) + (xmTextSetString $DepthText $NewDepthCP)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: raiseID/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * +DepthText TextWidget containing ID ; -; - +; * _CallData ; -; - +; * ; -; - +; * description: 1 increments ID. ; -; - +; * ; -; - - +; ************************************************************************ - (= - (raiseID $Widget $IDText $CallData) - ( (xmTextGetString $IDText $OldIDCP) - (proxtCharPtrToString $OldIDCP $OldIDStr) - (atom-chars $OldIDStr $OldIDC) - (number-chars $OldID $OldIDC) - (| - (det-if-then - (= $OldID 9999) - (is $NewID 0)) - (det-if-then otherwise - (is $NewID - (+ $OldID 1)))) - (number-chars $NewID $NewIDC) - (atom-chars $NewIDStr $NewIDC) - (proxtStringToCharPtr $NewIDStr $NewIDCP) - (xmTextSetString $IDText $NewIDCP))) -; + (= (raiseID $Widget $IDText $CallData) + (xmTextGetString $IDText $OldIDCP) + (proxtCharPtrToString $OldIDCP $OldIDStr) + (atom-chars $OldIDStr $OldIDC) + (number-chars $OldID $OldIDC) + (| + (det-if-then + (= $OldID 9999) + (is $NewID 0)) + (det-if-then otherwise + (is $NewID + (+ $OldID 1)))) + (number-chars $NewID $NewIDC) + (atom-chars $NewIDStr $NewIDC) + (proxtStringToCharPtr $NewIDStr $NewIDCP) + (xmTextSetString $IDText $NewIDCP)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: raiseMin/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * +DepthText TextWidget of Depth ; -; - +; * _CallData ; -; - +; * ; -; - +; * description: 1 increments MinId of viewed rules or examples. ; -; - +; * ; -; - +; ************************************************************************ - (= - (raiseMin $Widget $MinText $CallData) - ( (| - (det-if-then - (recorded rules - (viewMin $MinText) $_) - (= $KindOfKnowledge rules)) - (det-if-then otherwise - (= $KindOfKnowledge examples))) - (xmTextGetString $MinText $OldMinCP) - (proxtCharPtrToString $OldMinCP $OldMinStr) - (atom-chars $OldMinStr $OldMinC) - (number-chars $OldMin $OldMinC) - (recorded $KindOfKnowledge - (viewMax $MaxText) $_) - (xmTextGetString $MaxText $MaxCP) - (proxtCharPtrToString $MaxCP $MaxStr) - (atom-chars $MaxStr $MaxC) - (number-chars $Max $MaxC) - (| - (det-if-then - (>= $OldMin $Max) - (is $NewMin 1)) - (det-if-then otherwise - (is $NewMin - (+ $OldMin 1)))) - (number-chars $NewMin $NewMinC) - (atom-chars $NewMinStr $NewMinC) - (proxtStringToCharPtr $NewMinStr $NewMinCP) - (xmTextSetString $MinText $NewMinCP))) -; - + (= (raiseMin $Widget $MinText $CallData) + (| + (det-if-then + (recorded rules + (viewMin $MinText) $_) + (= $KindOfKnowledge rules)) + (det-if-then otherwise + (= $KindOfKnowledge examples))) + (xmTextGetString $MinText $OldMinCP) + (proxtCharPtrToString $OldMinCP $OldMinStr) + (atom-chars $OldMinStr $OldMinC) + (number-chars $OldMin $OldMinC) + (recorded $KindOfKnowledge + (viewMax $MaxText) $_) + (xmTextGetString $MaxText $MaxCP) + (proxtCharPtrToString $MaxCP $MaxStr) + (atom-chars $MaxStr $MaxC) + (number-chars $Max $MaxC) + (| + (det-if-then + (>= $OldMin $Max) + (is $NewMin 1)) + (det-if-then otherwise + (is $NewMin + (+ $OldMin 1)))) + (number-chars $NewMin $NewMinC) + (atom-chars $NewMinStr $NewMinC) + (proxtStringToCharPtr $NewMinStr $NewMinCP) + (xmTextSetString $MinText $NewMinCP)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: raiseMax/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * +DepthText TextWidget of Depth ; -; - +; * _CallData ; -; - +; * ; -; - +; * description: 1 increments MaxId of viewed rules or examples. ; -; - +; * ; -; +; ************************************************************************ - - (= - (raiseMax $Widget $MaxText $CallData) - ( (| - (det-if-then - (recorded rules - (viewMin $MinText) $_) - (= $KindOfKnowledge rules)) - (det-if-then otherwise - (= $KindOfKnowledge examples))) - (xmTextGetString $MaxText $OldMaxCP) - (proxtCharPtrToString $OldMaxCP $OldMaxStr) - (atom-chars $OldMaxStr $OldMaxC) - (number-chars $OldMax $OldMaxC) - (recorded $KindOfKnowledge - (viewMin $MinText) $_) - (xmTextGetString $MinText $MinCP) - (proxtCharPtrToString $MinCP $MinStr) - (atom-chars $MinStr $MinC) - (number-chars $Min $MinC) - (| - (det-if-then - (>= $OldMax 9999) - (is $NewMax $Min)) - (det-if-then otherwise - (is $NewMax - (+ $OldMax 1)))) - (number-chars $NewMax $NewMaxC) - (atom-chars $NewMaxStr $NewMaxC) - (proxtStringToCharPtr $NewMaxStr $NewMaxCP) - (xmTextSetString $MaxText $NewMaxCP))) -; - + (= (raiseMax $Widget $MaxText $CallData) + (| + (det-if-then + (recorded rules + (viewMin $MinText) $_) + (= $KindOfKnowledge rules)) + (det-if-then otherwise + (= $KindOfKnowledge examples))) + (xmTextGetString $MaxText $OldMaxCP) + (proxtCharPtrToString $OldMaxCP $OldMaxStr) + (atom-chars $OldMaxStr $OldMaxC) + (number-chars $OldMax $OldMaxC) + (recorded $KindOfKnowledge + (viewMin $MinText) $_) + (xmTextGetString $MinText $MinCP) + (proxtCharPtrToString $MinCP $MinStr) + (atom-chars $MinStr $MinC) + (number-chars $Min $MinC) + (| + (det-if-then + (>= $OldMax 9999) + (is $NewMax $Min)) + (det-if-then otherwise + (is $NewMax + (+ $OldMax 1)))) + (number-chars $NewMax $NewMaxC) + (atom-chars $NewMaxStr $NewMaxC) + (proxtStringToCharPtr $NewMaxStr $NewMaxCP) + (xmTextSetString $MaxText $NewMaxCP)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: copyId/2 ; -; - +; * ; -; - +; * syntax: copyId(+Id,+Count) ; -; - +; * ; -; - +; * args: +Id Id of rule or example to copy ; -; - +; * +Count First argument to proove if empty ; -; - +; * ; -; - +; * ; -; - +; * description: Copies the specified rule or example to the textwidget ; -; - +; * of the count argument. ; -; - +; * ; -; +; ************************************************************************ - - (= - (copyId $_ 13) + (= (copyId $_ 13) (set-det)) -; - - (= - (copyId $Id $Count) - ( (recorded state - (argumentWidget $Count $Text) $_) - (xmTextGetLastPosition $Text $Length) - (= $Length 0) - (set-det) - (number-chars $Id $IdChars) - (atom-chars $IdStr $IdChars) - (proxtStringToCharPtr $IdStr $IdCharPtr) - (xmTextSetString $Text $IdCharPtr))) -; - - (= - (copyId $Id $Count) - ( (is $C1 - (+ $Count 1)) (copyId $Id $C1))) -; - - - + (= (copyId $Id $Count) + (recorded state + (argumentWidget $Count $Text) $_) + (xmTextGetLastPosition $Text $Length) + (= $Length 0) + (set-det) + (number-chars $Id $IdChars) + (atom-chars $IdStr $IdChars) + (proxtStringToCharPtr $IdStr $IdCharPtr) + (xmTextSetString $Text $IdCharPtr)) + (= (copyId $Id $Count) + (is $C1 + (+ $Count 1)) + (copyId $Id $C1)) + + +; +; ************************************************************************ +; +; * +; +; * predicate: createCommandArea/1 +; +; * +; +; * syntax: createCommandArea(+Parent) +; +; * +; +; * description: Creates the area for direct command input. +; +; * +; +; ************************************************************************ + + + (= (createCommandArea $Parent) + (xmCreateFrame $Parent Controll Nil $ControllFrame) + (xtManageChild $ControllFrame) + (xmCreateRowColumn $ControllFrame controll + (:: + (xmNwidth 300) + (xmNadjustLast True) + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $ControllRowColumn) + (xtManageChild $ControllRowColumn) + (xmCreateRowColumn $ControllRowColumn kommandoRC + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN)) $KommandoRowColumn) + (xtManageChild $KommandoRowColumn) + (proxtStringToCharPtr Comand: $KommandoChrPtr) + (proxtGetDefaultCharset $DCharset) + (xmStringCreate $KommandoChrPtr $DCharset $KommandoStr) + (xmCreateLabelGadget $KommandoRowColumn kommandoLabel + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $KommandoStr)) $Klabel) + (xtManageChild $Klabel) + (proxtStringToCharPtr ' Input' $StatusCP) + (xmStringCreate $StatusCP $DCharset $StatusStr) + (xmCreateLabelGadget $KommandoRowColumn kommandoStatus + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $StatusStr)) $KStatus) + (xtManageChild $KStatus) + (xmCreateText $ControllRowColumn kommandotext + (:: + (xmNeditable True) + (xmNeditMode xmSINGLE-LINE-EDIT) + (xmNwidth 290) + (xmNautoShowCursorPosition True)) $Ktext) + (xtManageChild $Ktext) + (xtAddActions (:: (action ok doKommando (:: $Ktext $KStatus)))) + (proxtStringToCharPtr 'Return: ok()' $TranslationString) + (xtParseTranslationTable $TranslationString $TranslationTable) + (xtOverrideTranslations $Ktext $TranslationTable) + (xmCreateRowColumn $ControllRowColumn buttonrow + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $ButtonRow) + (xtManageChild $ButtonRow) + (xmCreatePushButton $ButtonRow OK! Nil $OK) + (xtManageChild $OK) + (xmCreatePushButton $ButtonRow Clear Nil $Clear) + (xtManageChild $Clear) + (xmCreatePushButton $ButtonRow 'Quit X-Miles' Nil $Beenden) + (createYesNoPopup $Beenden $YesNoPopup beenden $_) + (xtManageChild $Beenden) + (xtSetValues $ControllRowColumn + (:: (xmNdefaultButton $OK))) + (xtAddCallback $OK xmNactivateCallback doKommando + (:: $Ktext $KStatus)) + (xtAddCallback $Clear xmNactivateCallback doEmptyKommando $Ktext)) + + +; +; ************************************************************************ +; +; * +; +; * predicate: createFunctionArea/1 ; -; - +; * ; -; - +; * syntax: createFunctionArea(+Parent) ; -; - +; * ; -; - +; * description: Creates the area for the pulldown menus for calling the ; -; - +; * learning functions of miles. ; -; - +; * ; -; - +; * see also: file: 'xmiles_functions.pl' ; -; - +; * ; -; - - +; ************************************************************************ - (= - (createCommandArea $Parent) - ( (xmCreateFrame $Parent Controll Nil $ControllFrame) - (xtManageChild $ControllFrame) - (xmCreateRowColumn $ControllFrame controll - (:: - (xmNwidth 300) - (xmNadjustLast True) - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $ControllRowColumn) - (xtManageChild $ControllRowColumn) - (xmCreateRowColumn $ControllRowColumn kommandoRC - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN)) $KommandoRowColumn) - (xtManageChild $KommandoRowColumn) - (proxtStringToCharPtr Comand: $KommandoChrPtr) - (proxtGetDefaultCharset $DCharset) - (xmStringCreate $KommandoChrPtr $DCharset $KommandoStr) - (xmCreateLabelGadget $KommandoRowColumn kommandoLabel - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $KommandoStr)) $Klabel) - (xtManageChild $Klabel) - (proxtStringToCharPtr ' Input' $StatusCP) - (xmStringCreate $StatusCP $DCharset $StatusStr) - (xmCreateLabelGadget $KommandoRowColumn kommandoStatus - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $StatusStr)) $KStatus) - (xtManageChild $KStatus) - (xmCreateText $ControllRowColumn kommandotext - (:: - (xmNeditable True) - (xmNeditMode xmSINGLE-LINE-EDIT) - (xmNwidth 290) - (xmNautoShowCursorPosition True)) $Ktext) - (xtManageChild $Ktext) - (xtAddActions (:: (action ok doKommando (:: $Ktext $KStatus)))) - (proxtStringToCharPtr 'Return: ok()' $TranslationString) - (xtParseTranslationTable $TranslationString $TranslationTable) - (xtOverrideTranslations $Ktext $TranslationTable) - (xmCreateRowColumn $ControllRowColumn buttonrow - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $ButtonRow) - (xtManageChild $ButtonRow) - (xmCreatePushButton $ButtonRow OK! Nil $OK) - (xtManageChild $OK) - (xmCreatePushButton $ButtonRow Clear Nil $Clear) - (xtManageChild $Clear) - (xmCreatePushButton $ButtonRow 'Quit X-Miles' Nil $Beenden) - (createYesNoPopup $Beenden $YesNoPopup beenden $_) - (xtManageChild $Beenden) - (xtSetValues $ControllRowColumn - (:: (xmNdefaultButton $OK))) - (xtAddCallback $OK xmNactivateCallback doKommando - (:: $Ktext $KStatus)) - (xtAddCallback $Clear xmNactivateCallback doEmptyKommando $Ktext))) -; + (= (createFunctionArea $Parent) + (xmCreateFrame $Parent Functions Nil $FunctionFrame) + (xtManageChild $FunctionFrame) + (xmCreateRowColumn $FunctionFrame Function + (:: + (xmNwidth 300) + (xmNadjustLast True) + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $FunctionColumn) + (xtManageChild $FunctionColumn) + (proxtStringToCharPtr 'Learning Operators' $FunctionChrPtr) + (proxtGetDefaultCharset $DCharset) + (xmStringCreate $FunctionChrPtr $DCharset $FunctionStr) + (xmCreateLabelGadget $FunctionColumn functionLabel + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $FunctionStr)) $FunctionLabel) + (xtManageChild $FunctionLabel) + (xmCreateRowColumn $FunctionColumn functionRC + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN) + (xmNnumColumns 2) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $FunctionRowColumn) + (xtManageChild $FunctionRowColumn) + (groups $ListOfGroups) + (createFunctionGroups $FunctionRowColumn $ListOfGroups)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: createFunctionGroups/2 ; -; - +; * ; -; - +; * syntax: createFunctionGroups(+Parent,+[Groupname|ListOfGroups]) ; -; - +; * ; -; - +; * args: +Parent parent widget ; -; - +; * +[Groupname|ListOfGroups] list of groupnames ; -; - +; * ; -; - +; * description: Creates one pull down menu for every group of learning ; -; - +; * functions. ; -; - - - - (= - (createFunctionArea $Parent) - ( (xmCreateFrame $Parent Functions Nil $FunctionFrame) - (xtManageChild $FunctionFrame) - (xmCreateRowColumn $FunctionFrame Function - (:: - (xmNwidth 300) - (xmNadjustLast True) - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $FunctionColumn) - (xtManageChild $FunctionColumn) - (proxtStringToCharPtr 'Learning Operators' $FunctionChrPtr) - (proxtGetDefaultCharset $DCharset) - (xmStringCreate $FunctionChrPtr $DCharset $FunctionStr) - (xmCreateLabelGadget $FunctionColumn functionLabel - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $FunctionStr)) $FunctionLabel) - (xtManageChild $FunctionLabel) - (xmCreateRowColumn $FunctionColumn functionRC - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN) - (xmNnumColumns 2) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $FunctionRowColumn) - (xtManageChild $FunctionRowColumn) - (groups $ListOfGroups) - (createFunctionGroups $FunctionRowColumn $ListOfGroups))) -; - - - +; * ; -; +; ************************************************************************ -; -; -; -; + (= (createFunctionGroups $_ ()) True) + (= (createFunctionGroups $Parent (Cons $Groupname $ListOfGroups)) + (xmCreatePushButton $Parent $Groupname Nil $ButtonWidget) + (xtManageChild $ButtonWidget) + (xmCreatePopupMenu $ButtonWidget 'Learning functions' + (:: + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-COLUMN) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $LearningFunctions) + (xtAddEventHandler $LearningFunctions + (:: buttonReleaseMask) False functionsPopdown $_) + (xtAddCallback $ButtonWidget xmNactivateCallback popupFunctions $LearningFunctions) + (groupdef $Groupname $ListOfButtons) + (createFunctionButtons $LearningFunctions $ListOfButtons) + (createFunctionGroups $Parent $ListOfGroups)) -; -; ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: createFunctionButtons/2 ; -; - +; * ; -; - +; * syntax: createFunctionButtons(+Parent,+[Button|ListOfButtons]) ; -; - +; * ; -; - +; * args: +Parent parent widget ; -; - +; * +[Button|ListOfButtons] list of buttonnames ; -; - - - - (= - (createFunctionGroups $_ ()) True) -; - - (= - (createFunctionGroups $Parent - (Cons $Groupname $ListOfGroups)) - ( (xmCreatePushButton $Parent $Groupname Nil $ButtonWidget) - (xtManageChild $ButtonWidget) - (xmCreatePopupMenu $ButtonWidget 'Learning functions' - (:: - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-COLUMN) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $LearningFunctions) - (xtAddEventHandler $LearningFunctions - (:: buttonReleaseMask) False functionsPopdown $_) - (xtAddCallback $ButtonWidget xmNactivateCallback popupFunctions $LearningFunctions) - (groupdef $Groupname $ListOfButtons) - (createFunctionButtons $LearningFunctions $ListOfButtons) - (createFunctionGroups $Parent $ListOfGroups))) -; - - - -; -; - -; -; - -; -; - +; * ; -; - +; * description: Creates one pushbutton for every button name in the second ; -; - +; * argument. ; -; - +; * ; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - - - (= - (createFunctionButtons $_ ()) True) -; +; ************************************************************************ - (= - (createFunctionButtons $Parent - (Cons $Button $ListOfButtons)) - ( (xmCreatePushButton $Parent $Button Nil $ButtonWidget) - (xtManageChild $ButtonWidget) - (xtAddCallback $ButtonWidget xmNactivateCallback callFunction $Button) - (createFunctionButtons $Parent $ListOfButtons))) -; + (= (createFunctionButtons $_ ()) True) + (= (createFunctionButtons $Parent (Cons $Button $ListOfButtons)) + (xmCreatePushButton $Parent $Button Nil $ButtonWidget) + (xtManageChild $ButtonWidget) + (xtAddCallback $ButtonWidget xmNactivateCallback callFunction $Button) + (createFunctionButtons $Parent $ListOfButtons)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: callFunction/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * +Buttonname determines the function ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: calls the function defined for the specified button ; -; - +; * in the file xmiles_functions.pl ; -; - +; * ; -; - +; ************************************************************************ - (= - (callFunction $Widget $Buttonname $CallData) - ( (recorded learnfuncs - (popedup $PopupShell) $Ref) - (erase $Ref) - (xtUnmanageChild $PopupShell) - (operatordef $Buttonname $Funcname $InOutPattern $InChecks $XOuts $Refresh) - (writeMessage :- ) - (writeMessage $Funcname) - (| - (det-if-then - (= $InOutPattern Nil) - (, - (writelnMessage .) - (= $Fails Nil) - (= $Args Nil))) - (det-if-then otherwise - (, - (writeMessage () - (replaceXmVars $InOutPattern $InChecks $Args $Fails)))) - (flushErrorBuffer) - (| - (det-if-then + (= (callFunction $Widget $Buttonname $CallData) + (recorded learnfuncs + (popedup $PopupShell) $Ref) + (erase $Ref) + (xtUnmanageChild $PopupShell) + (operatordef $Buttonname $Funcname $InOutPattern $InChecks $XOuts $Refresh) + (writeMessage :- ) + (writeMessage $Funcname) + (| + (det-if-then + (= $InOutPattern Nil) + (, + (writelnMessage .) (= $Fails Nil) - (, - (=.. $F - (Cons $Funcname $Args)) - (| - (det-if-then - (call $F) - (, - (writelnMessage '% yes') - (outVars $Args $InOutPattern $XOuts) - (refresh $Refresh))) - (det-if-then otherwise - (writelnMessage '% no'))))) - (det-if-then otherwise - (writelnMessage '% Error occured, function not executed!'))) - (updateEvaluationLabel))) -; - + (= $Args Nil))) + (det-if-then otherwise + (, + (writeMessage () + (replaceXmVars $InOutPattern $InChecks $Args $Fails)))) + (flushErrorBuffer) + (| + (det-if-then + (= $Fails Nil) + (, + (=.. $F + (Cons $Funcname $Args)) + (| + (det-if-then + (call $F) + (, + (writelnMessage '% yes') + (outVars $Args $InOutPattern $XOuts) + (refresh $Refresh))) + (det-if-then otherwise + (writelnMessage '% no'))))) + (det-if-then otherwise + (writelnMessage '% Error occured, function not executed!'))) + (updateEvaluationLabel)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: replaceXmVars/3 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +[Pat|InOutPattern] List of argument patterns ; -; - +; * +InChecks List of checking functions ; -; - +; * -Args arguments the learning function is ; -; - +; * to be called with ; -; - +; * ; -; - +; * description: replaces the InOutPattern through constant values for ; -; - +; * input arguments and unbound variables for output arguments ; -; - +; * ; -; - +; ************************************************************************ - (= - (replaceXmVars Nil $_ Nil Nil) - ( (set-det) (writelnMessage ).))) -; - - (= - (replaceXmVars - (Cons $Pat $InOutPattern) $InChecks $Args $Fails) - ( (| - (det-if-then - (atom $Pat) - (atom-chars $Pat $PatC)) - (det-if-then otherwise - (= $PatC "constant"))) - (append "xmarg" - (:: $M1) $Argstr) - (append "xmarg" - (:: $M3 $M4) $Argstr2) - (append "xmopt" - (:: $M2) $Optstr) - (append "xmopt" - (:: $M5 $M6) $Optstr2) - (append "xmout" - (:: $_) $Outstr) + (= (replaceXmVars Nil $_ Nil Nil) + (set-det) + (writelnMessage ).)) + (= (replaceXmVars (Cons $Pat $InOutPattern) $InChecks $Args $Fails) + (| + (det-if-then + (atom $Pat) + (atom-chars $Pat $PatC)) + (det-if-then otherwise + (= $PatC "constant"))) + (append "xmarg" + (:: $M1) $Argstr) + (append "xmarg" + (:: $M3 $M4) $Argstr2) + (append "xmopt" + (:: $M2) $Optstr) + (append "xmopt" + (:: $M5 $M6) $Optstr2) + (append "xmout" + (:: $_) $Outstr) + (| + (det-if-then + (= $PatC "xmdepth") + (, + (recorded state + (argumentWidget depth $Text) $_) + (xmTextGetString $Text $ArgCP) + (proxtCharPtrToString $ArgCP $ArgStr) + (atom-chars $ArgStr $ArgChars) + (| + (number-chars $Value $ArgChars) + (= $Value $ArgStr)) + (= $InChecks + (Cons $IC $ICs)) + (=.. $C + (:: $IC $Value)) + (| + (det-if-then + (call $C) + (= $Fail Nil)) + (= $Fail + (:: 0))) + (writeMessage $ArgStr) + (| + (= $InOutPattern Nil) + (writeMessage ,)))) (| (det-if-then - (= $PatC "xmdepth") + (= $PatC $Argstr) (, + (number-chars $N + (:: $M1)) (recorded state - (argumentWidget depth $Text) $_) + (argumentWidget $N $Text) $_) (xmTextGetString $Text $ArgCP) (proxtCharPtrToString $ArgCP $ArgStr) (atom-chars $ArgStr $ArgChars) @@ -4862,17 +3857,17 @@ (call $C) (= $Fail Nil)) (= $Fail - (:: 0))) + (:: $N))) (writeMessage $ArgStr) (| (= $InOutPattern Nil) (writeMessage ,)))) (| (det-if-then - (= $PatC $Argstr) + (= $PatC $Argstr2) (, (number-chars $N - (:: $M1)) + (:: $M3 $M4)) (recorded state (argumentWidget $N $Text) $_) (xmTextGetString $Text $ArgCP) @@ -4897,38 +3892,44 @@ (writeMessage ,)))) (| (det-if-then - (= $PatC $Argstr2) + (= $PatC "xmoptdepth") (, - (number-chars $N - (:: $M3 $M4)) (recorded state - (argumentWidget $N $Text) $_) + (argumentWidget depth $Text) $_) (xmTextGetString $Text $ArgCP) (proxtCharPtrToString $ArgCP $ArgStr) (atom-chars $ArgStr $ArgChars) - (| - (number-chars $Value $ArgChars) - (= $Value $ArgStr)) (= $InChecks (Cons $IC $ICs)) - (=.. $C - (:: $IC $Value)) (| (det-if-then - (call $C) - (= $Fail Nil)) - (= $Fail - (:: $N))) - (writeMessage $ArgStr) - (| - (= $InOutPattern Nil) - (writeMessage ,)))) + (= $ArgChars Nil) + (= $Value novalue)) + (det-if-then otherwise + (, + (| + (number-chars $Value $ArgChars) + (= $Value $ArgStr)) + (=.. $C + (:: $IC $Value)) + (| + (det-if-then + (call $C) + (= $Fail Nil)) + (= $Fail + (:: 0))) + (writeMessage $ArgStr) + (| + (= $InOutPattern Nil) + (writeMessage ,))))))) (| (det-if-then - (= $PatC "xmoptdepth") + (= $PatC $Optstr) (, + (number-chars $N + (:: $M2)) (recorded state - (argumentWidget depth $Text) $_) + (argumentWidget $N $Text) $_) (xmTextGetString $Text $ArgCP) (proxtCharPtrToString $ArgCP $ArgStr) (atom-chars $ArgStr $ArgChars) @@ -4950,17 +3951,17 @@ (call $C) (= $Fail Nil)) (= $Fail - (:: 0))) + (:: $N))) (writeMessage $ArgStr) (| (= $InOutPattern Nil) (writeMessage ,))))))) (| (det-if-then - (= $PatC $Optstr) + (= $PatC $Optstr2) (, (number-chars $N - (:: $M2)) + (:: $M5 $M6)) (recorded state (argumentWidget $N $Text) $_) (xmTextGetString $Text $ArgCP) @@ -4991,2068 +3992,1497 @@ (writeMessage ,))))))) (| (det-if-then - (= $PatC $Optstr2) + (= $PatC $Outstr) (, - (number-chars $N - (:: $M5 $M6)) - (recorded state - (argumentWidget $N $Text) $_) - (xmTextGetString $Text $ArgCP) - (proxtCharPtrToString $ArgCP $ArgStr) - (atom-chars $ArgStr $ArgChars) - (= $InChecks - (Cons $IC $ICs)) + (= $InChecks $ICs) + (= $PatC + (Cons $_ $P1)) + (append "X" $P1 $P2) + (atom-chars $P3 $P2) + (writeMessage $P3) + (= $Fail Nil) + (= $Value variable) (| - (det-if-then - (= $ArgChars Nil) - (= $Value novalue)) - (det-if-then otherwise - (, - (| - (number-chars $Value $ArgChars) - (= $Value $ArgStr)) - (=.. $C - (:: $IC $Value)) - (| - (det-if-then - (call $C) - (= $Fail Nil)) - (= $Fail - (:: $N))) - (writeMessage $ArgStr) - (| - (= $InOutPattern Nil) - (writeMessage ,))))))) - (| - (det-if-then - (= $PatC $Outstr) - (, - (= $InChecks $ICs) - (= $PatC - (Cons $_ $P1)) - (append "X" $P1 $P2) - (atom-chars $P3 $P2) - (writeMessage $P3) - (= $Fail Nil) - (= $Value variable) - (| - (= $InOutPattern Nil) - (writeMessage ,)))) - (det-if-then otherwise - (, - (= $Value $Pat) - (= $InChecks $ICs) - (= $Fail Nil) - (writeMessage $Pat) - (| - (= $InOutPattern Nil) - (writeMessage ,))))))))))) - (set-det) - (replaceXmVars $InOutPattern $ICs $Values $F) - (append $Fail $F $Fails) + (= $InOutPattern Nil) + (writeMessage ,)))) + (det-if-then otherwise + (, + (= $Value $Pat) + (= $InChecks $ICs) + (= $Fail Nil) + (writeMessage $Pat) + (| + (= $InOutPattern Nil) + (writeMessage ,))))))))))) + (set-det) + (replaceXmVars $InOutPattern $ICs $Values $F) + (append $Fail $F $Fails) + (| + (det-if-then + (= $Value novalue) + (= $Args $Values)) (| (det-if-then - (= $Value novalue) - (= $Args $Values)) - (| - (det-if-then - (= $Value variable) - (= $Args - (Cons $Var $Values))) - (det-if-then otherwise - (= $Args - (Cons $Value $Values))))))) -; - + (= $Value variable) + (= $Args + (Cons $Var $Values))) + (det-if-then otherwise + (= $Args + (Cons $Value $Values)))))) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: outVars/3 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +[Arg1|Args] arguments returned by a learnin f. ; -; - +; * +[Pat|InOutPattern] list of InOutPatterns ; -; - +; * +XOuts list of output functions ; -; - +; * ; -; - +; * description: Calls the spezified output functions with the values ; -; - +; * returned by a learning function. ; -; - +; * ; -; - - +; ************************************************************************ - (= - (outVars $_ $_ ()) True) -; - - (= - (outVars - (Cons $Arg1 $Args) - (Cons $Pat $InOutPattern) $XOuts) - ( (atom-chars $Pat $PatC) - (append "xmout" - (:: $_) $Outstr) - (| - (det-if-then - (= $PatC $Outstr) - (, - (= $XOuts - (Cons $XO $XOs)) - (=.. $C - (:: $XO $Arg1)) - (call $C))) - (det-if-then otherwise - (= $XOuts $XOs))) - (set-det) - (outVars $Args $InOutPattern $XOs))) -; + (= (outVars $_ $_ ()) True) + (= (outVars (Cons $Arg1 $Args) (Cons $Pat $InOutPattern) $XOuts) + (atom-chars $Pat $PatC) + (append "xmout" + (:: $_) $Outstr) + (| + (det-if-then + (= $PatC $Outstr) + (, + (= $XOuts + (Cons $XO $XOs)) + (=.. $C + (:: $XO $Arg1)) + (call $C))) + (det-if-then otherwise + (= $XOuts $XOs))) + (set-det) + (outVars $Args $InOutPattern $XOs)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: refresh/1 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +[KindOfKnowledge|R] ; -; - +; * ; -; - +; * description: Refreshes the visual part of the knowledge base of the ; -; - +; * specified kinds of knowledge. ; -; - +; * ; -; +; ************************************************************************ - - (= - (refresh ()) True) -; - - (= - (refresh (Cons $KindOfKnowledge $R)) - ( (refreshKnowledgeList $_ $KindOfKnowledge $_) (refresh $R))) -; - + (= (refresh ()) True) + (= (refresh (Cons $KindOfKnowledge $R)) + (refreshKnowledgeList $_ $KindOfKnowledge $_) + (refresh $R)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: createYesNoPopup/4 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +Parent parent widget, which is a push button ; -; - +; * -YesNoPopup created widget, popupMenu ; -; - +; * +YesPred callback procedure for Yes button ; -; - +; * +YesArg argument for callback procedure ; -; - +; * ; -; - +; * description: Creates a popupMenu which is poped up, whenever the ; -; - +; * parent button is pressed. This popupMenu consists of two ; -; - +; * push buttons 'Yes' and 'No'. ; -; - +; * ; -; - - +; ************************************************************************ - (= - (createYesNoPopup $Parent $YesNoPopup $YesPred $YesArg) - ( (xmCreatePopupMenu $Parent YesNo - (:: - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-COLUMN) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $YesNoPopup) - (xmCreatePushButton $YesNoPopup Yes Nil $Yes) - (xmCreatePushButton $YesNoPopup No Nil $No) - (xtAddCallback $Parent xmNactivateCallback popupDialog $YesNoPopup) - (xtAddCallback $Yes xmNactivateCallback $YesPred $YesArg) - (xtAddCallback $No xmNactivateCallback yesNoPopdown $YesNoPopup) - (xtAddEventHandler $YesNoPopup - (:: buttonReleaseMask) False yesNoPopdown $YesNoPopup) - (xtManageChildren (:: $Yes $No)))) -; + (= (createYesNoPopup $Parent $YesNoPopup $YesPred $YesArg) + (xmCreatePopupMenu $Parent YesNo + (:: + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-COLUMN) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $YesNoPopup) + (xmCreatePushButton $YesNoPopup Yes Nil $Yes) + (xmCreatePushButton $YesNoPopup No Nil $No) + (xtAddCallback $Parent xmNactivateCallback popupDialog $YesNoPopup) + (xtAddCallback $Yes xmNactivateCallback $YesPred $YesArg) + (xtAddCallback $No xmNactivateCallback yesNoPopdown $YesNoPopup) + (xtAddEventHandler $YesNoPopup + (:: buttonReleaseMask) False yesNoPopdown $YesNoPopup) + (xtManageChildren (:: $Yes $No))) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: popupDialog/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +Widget calling widget ; -; - +; * +PopupShell widget, to manage ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Manages the specified widget beneath the calling widget. ; -; - +; * ; -; +; ************************************************************************ - - (= - (popupDialog $Widget $PopupShell $CallData) - ( (xtGetValues $Widget - (:: (xmNwidth $Xs))) - (xtTranslateCoords $Widget $Xs 0 $X $Y) - (xtSetValues $PopupShell - (:: - (xmNx $X) - (xmNy $Y))) - (xtManageChild $PopupShell))) -; - + (= (popupDialog $Widget $PopupShell $CallData) + (xtGetValues $Widget + (:: (xmNwidth $Xs))) + (xtTranslateCoords $Widget $Xs 0 $X $Y) + (xtSetValues $PopupShell + (:: + (xmNx $X) + (xmNy $Y))) + (xtManageChild $PopupShell)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: popupViewRules/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +Widget calling widget ; -; - +; * _ClientData client data ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Manages the specified widget beneath the calling widget ; -; - +; * ; -; - - +; ************************************************************************ - (= - (popupViewRules $Widget $ClientData $CallData) - ( (recorded rules - (view dialog $VRDialog) $_) - (xtGetValues $Widget - (:: (xmNwidth $Xs))) - (xtTranslateCoords $Widget $Xs 0 $X $Y) - (xtSetValues $VRDialog - (:: - (xmNx $X) - (xmNy $Y))) - (xtManageChild $VRDialog) - (fillExistingLabels) - (fillViewedLabels) - (fillExistingClauseHeads) - (fillViewedClauseHeads))) -; + (= (popupViewRules $Widget $ClientData $CallData) + (recorded rules + (view dialog $VRDialog) $_) + (xtGetValues $Widget + (:: (xmNwidth $Xs))) + (xtTranslateCoords $Widget $Xs 0 $X $Y) + (xtSetValues $VRDialog + (:: + (xmNx $X) + (xmNy $Y))) + (xtManageChild $VRDialog) + (fillExistingLabels) + (fillViewedLabels) + (fillExistingClauseHeads) + (fillViewedClauseHeads)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: popupExamineRules/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +Widget calling widget ; -; - +; * _ClientData client data ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Manages the specified widget beneath the calling widget. ; -; - +; * ; -; +; ************************************************************************ - - (= - (popupExamineRules $Widget $ClientData $CallData) - ( (recorded rules - (examine dialog $ERDialog) $_) - (xtGetValues $Widget - (:: (xmNwidth $Xs))) - (xtTranslateCoords $Widget $Xs 0 $X $Y) - (xtSetValues $ERDialog - (:: - (xmNx $X) - (xmNy $Y))) - (showExaminedRule $_ $_ $_) - (xtManageChild $ERDialog))) -; - + (= (popupExamineRules $Widget $ClientData $CallData) + (recorded rules + (examine dialog $ERDialog) $_) + (xtGetValues $Widget + (:: (xmNwidth $Xs))) + (xtTranslateCoords $Widget $Xs 0 $X $Y) + (xtSetValues $ERDialog + (:: + (xmNx $X) + (xmNy $Y))) + (showExaminedRule $_ $_ $_) + (xtManageChild $ERDialog)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: popupViewExamples/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +Widget calling widget ; -; - +; * _ClientData client data ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Manages the specified widget beneath the calling widget. ; -; - +; * ; -; - - +; ************************************************************************ - (= - (popupViewExamples $Widget $ClientData $CallData) - ( (recorded examples - (view dialog $VRDialog) $_) - (xtGetValues $Widget - (:: (xmNwidth $Xs))) - (xtTranslateCoords $Widget $Xs 0 $X $Y) - (xtSetValues $VRDialog - (:: - (xmNx $X) - (xmNy $Y))) - (xtManageChild $VRDialog) - (fillExistingExampleCHs) - (fillViewedExampleCHs))) -; + (= (popupViewExamples $Widget $ClientData $CallData) + (recorded examples + (view dialog $VRDialog) $_) + (xtGetValues $Widget + (:: (xmNwidth $Xs))) + (xtTranslateCoords $Widget $Xs 0 $X $Y) + (xtSetValues $VRDialog + (:: + (xmNx $X) + (xmNy $Y))) + (xtManageChild $VRDialog) + (fillExistingExampleCHs) + (fillViewedExampleCHs)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: fillExistingLabels/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: - ; -; - +; * ; -; - +; * description: Finds all existing Labels. ; -; - +; * ; -; - - +; ************************************************************************ - (= - (fillExistingLabels) - ( (recorded rules - (view exLabRC $ExLabRC) $_) - (listLabels $LabelList) - (createLabelWidgets $ExLabRC $LabelList))) -; + (= (fillExistingLabels) + (recorded rules + (view exLabRC $ExLabRC) $_) + (listLabels $LabelList) + (createLabelWidgets $ExLabRC $LabelList)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: fillViewedLabels/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: - ; -; - +; * ; -; - +; * description: Finds all viewed Labels. ; -; - +; * ; -; - - +; ************************************************************************ - (= - (fillViewedLabels) - ( (recorded rules - (view viewLabRC $ViewLabRC) $_) - (recorded rules - (view labels $LabelList) $_) - (createLabelWidgets $ViewLabRC $LabelList))) -; + (= (fillViewedLabels) + (recorded rules + (view viewLabRC $ViewLabRC) $_) + (recorded rules + (view labels $LabelList) $_) + (createLabelWidgets $ViewLabRC $LabelList)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: fillExistingClauseHeads/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: - ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; ************************************************************************ - (= - (fillExistingClauseHeads) - ( (recorded rules - (view exCHRC $ExCHRC) $_) - (listClauseHeads $LabelList) - (createLabelWidgets $ExCHRC $LabelList))) -; - + (= (fillExistingClauseHeads) + (recorded rules + (view exCHRC $ExCHRC) $_) + (listClauseHeads $LabelList) + (createLabelWidgets $ExCHRC $LabelList)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: fillViewedClauseHeads/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: - ; -; - +; * ; -; - +; * description: Finds all existing Labels ; -; - +; * ; -; - +; ************************************************************************ - (= - (fillViewedClauseHeads) - ( (recorded rules - (view viewCHRC $ViewCHRC) $_) - (recorded rules - (view clause-heads $CHList) $_) - (createLabelWidgets $ViewCHRC $CHList))) -; - + (= (fillViewedClauseHeads) + (recorded rules + (view viewCHRC $ViewCHRC) $_) + (recorded rules + (view clause-heads $CHList) $_) + (createLabelWidgets $ViewCHRC $CHList)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: fillExistingExampleCHs/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: - ; -; - +; * ; -; - +; * description: Finds all existing Labels. ; -; - +; * ; -; +; ************************************************************************ - - (= - (fillExistingExampleCHs) - ( (recorded examples - (view exCHRC $ExCHRC) $_) - (listExampleCHs $LabelList) - (createLabelWidgets $ExCHRC $LabelList))) -; - + (= (fillExistingExampleCHs) + (recorded examples + (view exCHRC $ExCHRC) $_) + (listExampleCHs $LabelList) + (createLabelWidgets $ExCHRC $LabelList)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: fillViewedExampleCs/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: - ; -; - +; * ; -; - +; * description: Finds all existing Clause Heads of examples. ; -; - +; * ; -; +; ************************************************************************ - - (= - (fillViewedExampleCHs) - ( (recorded examples - (view viewCHRC $ViewCHRC) $_) - (recorded examples - (view clause-heads $CHList) $_) - (createLabelWidgets $ViewCHRC $CHList))) -; - + (= (fillViewedExampleCHs) + (recorded examples + (view viewCHRC $ViewCHRC) $_) + (recorded examples + (view clause-heads $CHList) $_) + (createLabelWidgets $ViewCHRC $CHList)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: createLabelWidgets/2 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +Parent widget ; -; - +; * +NameList atomList ; -; - +; * ; -; - +; * description: creates a label for each name in NameList. ; -; - +; * ; -; - - +; ************************************************************************ - (= - (createLabelWidgets $Parent - (Cons $Name $NameList)) - ( (proxtStringToCharPtr $Name $NameChrPtr) - (proxtGetDefaultCharset $DCharset) - (xmStringCreate $NameChrPtr $DCharset $NameStr) - (xmCreateLabel $Parent nameLabel - (:: - (xmNalignment xmALIGNMENT-BEGINNING) - (xmNlabelType xmSTRING) - (xmNlabelString $NameStr)) $NameLabel) - (xtManageChild $NameLabel) - (recordz labels - (parent-child $Parent $NameLabel $NameStr) $_) - (xtAddEventHandler $NameLabel - (:: buttonReleaseMask) False selectLabel $_) - (set-det) - (createLabelWidgets $Parent $NameList))) -; - (= - (createLabelWidgets $_ Nil) + (= (createLabelWidgets $Parent (Cons $Name $NameList)) + (proxtStringToCharPtr $Name $NameChrPtr) + (proxtGetDefaultCharset $DCharset) + (xmStringCreate $NameChrPtr $DCharset $NameStr) + (xmCreateLabel $Parent nameLabel + (:: + (xmNalignment xmALIGNMENT-BEGINNING) + (xmNlabelType xmSTRING) + (xmNlabelString $NameStr)) $NameLabel) + (xtManageChild $NameLabel) + (recordz labels + (parent-child $Parent $NameLabel $NameStr) $_) + (xtAddEventHandler $NameLabel + (:: buttonReleaseMask) False selectLabel $_) + (set-det) + (createLabelWidgets $Parent $NameList)) + (= (createLabelWidgets $_ Nil) (set-det)) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: destroyLabelWidgets/1 ; -; - +; * ; -; - +; * syntax: destroyLabelWidgets(+Parent) ; -; - +; * ; -; - +; * description: destroys each sublabel of Parent. ; -; - +; * ; -; - +; ************************************************************************ - (= - (destroyLabelWidgets $Parent) - ( (var $Parent) - (recorded labels - (parent-child $Parent $L $_) $Ref) - (set-det) - (erase $Ref) - (xtDestroyWidget $L) - (destroyLabelWidgets $_))) -; - - (= - (destroyLabelWidgets $Parent) - ( (recorded labels - (parent-child $Parent $L $_) $Ref) - (set-det) - (erase $Ref) - (xtDestroyWidget $L) - (destroyLabelWidgets $Parent))) -; - - (= - (destroyLabelWidgets $_) + (= (destroyLabelWidgets $Parent) + (var $Parent) + (recorded labels + (parent-child $Parent $L $_) $Ref) + (set-det) + (erase $Ref) + (xtDestroyWidget $L) + (destroyLabelWidgets $_)) + (= (destroyLabelWidgets $Parent) + (recorded labels + (parent-child $Parent $L $_) $Ref) + (set-det) + (erase $Ref) + (xtDestroyWidget $L) + (destroyLabelWidgets $Parent)) + (= (destroyLabelWidgets $_) (set-det)) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: listLabel/1 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: LabelList atomList ; -; - +; * ; -; - +; * description: lists each label of rules of knowledgebase. ; -; - +; * ; -; +; ************************************************************************ - - (= - (listLabels $LabelList) - ( (recorded rules - (view labels $ViewedLabels) $_) - (listLabels $ViewedLabels $LL1) - (append $LabelList $ViewedLabels $LL1) - (set-det))) -; - - (= - (listLabels $LLin $LLout) - ( (get-clause $_ $_ $_ $_ $Label) - (nonmember $Label $LLin) - (set-det) - (= $LLin2 - (Cons $Label $LLin)) - (listLabels $LLin2 $LLout))) -; - - (= - (listLabels $A $A) + (= (listLabels $LabelList) + (recorded rules + (view labels $ViewedLabels) $_) + (listLabels $ViewedLabels $LL1) + (append $LabelList $ViewedLabels $LL1) + (set-det)) + (= (listLabels $LLin $LLout) + (get-clause $_ $_ $_ $_ $Label) + (nonmember $Label $LLin) + (set-det) + (= $LLin2 + (Cons $Label $LLin)) + (listLabels $LLin2 $LLout)) + (= (listLabels $A $A) (set-det)) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: listClauseHeads/1 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: LabelList atomList ; -; - +; * ; -; - +; * description: lists each clausehead of rules of knowledgebase. ; -; - +; * ; -; - +; ************************************************************************ - (= - (listClauseHeads $LabelList) - ( (recorded rules - (view clause-heads $ViewedCHs) $_) - (listClauseHeads $ViewedCHs $LL1) - (append $LabelList $ViewedCHs $LL1) - (set-det))) -; - - (= - (listClauseHeads $LLin $LLout) - ( (get-clause $_ $C $_ $_ $_) - (functor $C $CH $_) - (nonmember $CH $LLin) - (set-det) - (= $LLin2 - (Cons $CH $LLin)) - (listClauseHeads $LLin2 $LLout))) -; - - (= - (listClauseHeads $A $A) + (= (listClauseHeads $LabelList) + (recorded rules + (view clause-heads $ViewedCHs) $_) + (listClauseHeads $ViewedCHs $LL1) + (append $LabelList $ViewedCHs $LL1) + (set-det)) + (= (listClauseHeads $LLin $LLout) + (get-clause $_ $C $_ $_ $_) + (functor $C $CH $_) + (nonmember $CH $LLin) + (set-det) + (= $LLin2 + (Cons $CH $LLin)) + (listClauseHeads $LLin2 $LLout)) + (= (listClauseHeads $A $A) (set-det)) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: listExampleCHs/1 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: LabelList atomList ; -; - +; * ; -; - +; * description: lists each clausehead of examples of knowledgebase. ; -; - +; * ; -; - - +; ************************************************************************ - (= - (listExampleCHs $LabelList) - ( (recorded examples - (view clause-heads $ViewedCHs) $_) - (listExampleCHs $ViewedCHs $LL1) - (append $LabelList $ViewedCHs $LL1) - (set-det))) -; - (= - (listExampleCHs $LLin $LLout) - ( (get-example $_ $C $_) - (functor $C $CH $_) - (nonmember $CH $LLin) - (set-det) - (= $LLin2 - (Cons $CH $LLin)) - (listExampleCHs $LLin2 $LLout))) -; - - (= - (listExampleCHs $A $A) + (= (listExampleCHs $LabelList) + (recorded examples + (view clause-heads $ViewedCHs) $_) + (listExampleCHs $ViewedCHs $LL1) + (append $LabelList $ViewedCHs $LL1) + (set-det)) + (= (listExampleCHs $LLin $LLout) + (get-example $_ $C $_) + (functor $C $CH $_) + (nonmember $CH $LLin) + (set-det) + (= $LLin2 + (Cons $CH $LLin)) + (listExampleCHs $LLin2 $LLout)) + (= (listExampleCHs $A $A) (set-det)) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: selectLabel/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +Widget calling widget ; -; - +; * _ClientData client data ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Toggles the parent of the calling widget. (exist./view.) ; -; - +; * ; -; - +; ************************************************************************ - (= - (selectLabel $Widget $ClientData $CallData) - ( (recorded labels - (parent-child $P $Widget $N) $Ref) - (set-det) - (erase $Ref) - (xtDestroyWidget $Widget) + (= (selectLabel $Widget $ClientData $CallData) + (recorded labels + (parent-child $P $Widget $N) $Ref) + (set-det) + (erase $Ref) + (xtDestroyWidget $Widget) + (| + (det-if-then + (recorded rules + (view exLabRC $P) $_) + (recorded rules + (view viewLabRC $P2) $_)) (| (det-if-then (recorded rules - (view exLabRC $P) $_) + (view viewLabRC $P) $_) (recorded rules - (view viewLabRC $P2) $_)) + (view exLabRC $P2) $_)) (| (det-if-then (recorded rules - (view viewLabRC $P) $_) + (view exCHRC $P) $_) (recorded rules - (view exLabRC $P2) $_)) + (view viewCHRC $P2) $_)) (| (det-if-then (recorded rules - (view exCHRC $P) $_) + (view viewCHRC $P) $_) (recorded rules - (view viewCHRC $P2) $_)) + (view exCHRC $P2) $_)) (| (det-if-then - (recorded rules - (view viewCHRC $P) $_) - (recorded rules - (view exCHRC $P2) $_)) + (recorded examples + (view exCHRC $P) $_) + (recorded examples + (view viewCHRC $P2) $_)) (| (det-if-then (recorded examples - (view exCHRC $P) $_) + (view viewCHRC $P) $_) (recorded examples - (view viewCHRC $P2) $_)) + (view exCHRC $P2) $_)) (| + (det-if-then + (recorded examples + (view exCHRC $P) $_) + (recorded examples + (view viewCHRC $P2) $_)) (det-if-then (recorded examples (view viewCHRC $P) $_) (recorded examples - (view exCHRC $P2) $_)) - (| - (det-if-then - (recorded examples - (view exCHRC $P) $_) - (recorded examples - (view viewCHRC $P2) $_)) - (det-if-then - (recorded examples - (view viewCHRC $P) $_) - (recorded examples - (view exCHRC $P2) $_))))))))) - (xmCreateLabel $P2 nameLabel - (:: - (xmNalignment xmALIGNMENT-BEGINNING) - (xmNlabelType xmSTRING) - (xmNlabelString $N)) $NameLabel) - (xtManageChild $NameLabel) - (recordz labels - (parent-child $P2 $NameLabel $N) $_) - (xtAddEventHandler $NameLabel - (:: buttonReleaseMask) False selectLabel $_) - (set-det))) -; - - - - - (= - (viewRules $Widget $ClientData $CallData) - ( (| - (det-if-then - (recorded rules - (view all) $R1) - (erase $R1)) otherwise) - (recorded rules - (view labels $_) $R2) - (erase $R2) - (recorded rules - (view clause-heads $_) $R3) - (erase $R3) - (recorded rules - (view viewLabRC $ViewLabRC) $_) - (recorded rules - (view viewCHRC $ViewCHRC) $_) - (viewRules $ViewLabRC $LabelList) - (recordz rules - (view labels $LabelList) $_) - (viewRules $ViewCHRC $CHList) - (recordz rules - (view clause-heads $CHList) $_) - (destroyLabelWidgets $_) - (refresh (:: rules)) - (recorded rules - (view dialog $X) $_) - (xtUnmanageChild $X))) -; - - (= - (viewRules $P $List) - ( (recorded labels - (parent-child $P $C $N) $Ref) - (xtDestroyWidget $C) - (erase $Ref) - (proxtGetDefaultCharset $DCharset) - (xmStringGetLtoR $N $DCharset $NCP $_) - (proxtCharPtrToString $NCP $Name) - (viewRules $P $L2) - (= $List - (Cons $Name $L2)))) -; - - (= - (viewRules $_ Nil) + (view exCHRC $P2) $_))))))))) + (xmCreateLabel $P2 nameLabel + (:: + (xmNalignment xmALIGNMENT-BEGINNING) + (xmNlabelType xmSTRING) + (xmNlabelString $N)) $NameLabel) + (xtManageChild $NameLabel) + (recordz labels + (parent-child $P2 $NameLabel $N) $_) + (xtAddEventHandler $NameLabel + (:: buttonReleaseMask) False selectLabel $_) (set-det)) -; - - (= - (viewAllRules $Widget $ClientData $CallData) - ( (| + (= (viewRules $Widget $ClientData $CallData) + (| + (det-if-then (recorded rules - (view all) $_) - (recordz rules - (view all) $_)) - (refresh (:: rules)) - (destroyLabelWidgets $_) - (recorded rules - (view dialog $X) $_) - (xtUnmanageChild $X))) -; - + (view all) $R1) + (erase $R1)) otherwise) + (recorded rules + (view labels $_) $R2) + (erase $R2) + (recorded rules + (view clause-heads $_) $R3) + (erase $R3) + (recorded rules + (view viewLabRC $ViewLabRC) $_) + (recorded rules + (view viewCHRC $ViewCHRC) $_) + (viewRules $ViewLabRC $LabelList) + (recordz rules + (view labels $LabelList) $_) + (viewRules $ViewCHRC $CHList) + (recordz rules + (view clause-heads $CHList) $_) + (destroyLabelWidgets $_) + (refresh (:: rules)) + (recorded rules + (view dialog $X) $_) + (xtUnmanageChild $X)) + (= (viewRules $P $List) + (recorded labels + (parent-child $P $C $N) $Ref) + (xtDestroyWidget $C) + (erase $Ref) + (proxtGetDefaultCharset $DCharset) + (xmStringGetLtoR $N $DCharset $NCP $_) + (proxtCharPtrToString $NCP $Name) + (viewRules $P $L2) + (= $List + (Cons $Name $L2))) + (= (viewRules $_ Nil) + (set-det)) - (= - (cancelViewRules $Widget $ClientData $CallData) - ( (destroyLabelWidgets $_) + (= (viewAllRules $Widget $ClientData $CallData) + (| (recorded rules - (view dialog $X) $_) - (xtUnmanageChild $X))) -; + (view all) $_) + (recordz rules + (view all) $_)) + (refresh (:: rules)) + (destroyLabelWidgets $_) + (recorded rules + (view dialog $X) $_) + (xtUnmanageChild $X)) + (= (cancelViewRules $Widget $ClientData $CallData) + (destroyLabelWidgets $_) + (recorded rules + (view dialog $X) $_) + (xtUnmanageChild $X)) - (= - (cancelExamineRules $Widget $ClientData $CallData) - ( (destroyLabelWidgets $_) - (recorded rules - (examine dialog $X) $_) - (xtUnmanageChild $X))) -; + (= (cancelExamineRules $Widget $ClientData $CallData) + (destroyLabelWidgets $_) + (recorded rules + (examine dialog $X) $_) + (xtUnmanageChild $X)) - (= - (viewExamples $Widget $ClientData $CallData) - ( (| - (det-if-then - (recorded examples - (view all) $R1) - (erase $R1)) otherwise) - (recorded examples - (view clause-heads $_) $R3) - (erase $R3) - (recorded examples - (view viewCHRC $ViewCHRC) $_) - (viewExamples $ViewCHRC $CHList) - (recordz examples - (view clause-heads $CHList) $_) - (destroyLabelWidgets $_) - (refresh (:: examples)) - (recorded examples - (view dialog $X) $_) - (xtUnmanageChild $X))) -; - - (= - (viewExamples $P $List) - ( (recorded labels - (parent-child $P $C $N) $Ref) - (xtDestroyWidget $C) - (erase $Ref) - (proxtGetDefaultCharset $DCharset) - (xmStringGetLtoR $N $DCharset $NCP $_) - (proxtCharPtrToString $NCP $Name) - (viewExamples $P $L2) - (= $List - (Cons $Name $L2)))) -; - - (= - (viewExamples $_ Nil) - (set-det)) -; + (= (viewExamples $Widget $ClientData $CallData) + (| + (det-if-then + (recorded examples + (view all) $R1) + (erase $R1)) otherwise) + (recorded examples + (view clause-heads $_) $R3) + (erase $R3) + (recorded examples + (view viewCHRC $ViewCHRC) $_) + (viewExamples $ViewCHRC $CHList) + (recordz examples + (view clause-heads $CHList) $_) + (destroyLabelWidgets $_) + (refresh (:: examples)) + (recorded examples + (view dialog $X) $_) + (xtUnmanageChild $X)) + (= (viewExamples $P $List) + (recorded labels + (parent-child $P $C $N) $Ref) + (xtDestroyWidget $C) + (erase $Ref) + (proxtGetDefaultCharset $DCharset) + (xmStringGetLtoR $N $DCharset $NCP $_) + (proxtCharPtrToString $NCP $Name) + (viewExamples $P $L2) + (= $List + (Cons $Name $L2))) + (= (viewExamples $_ Nil) + (set-det)) - (= - (viewAllExamples $Widget $ClientData $CallData) - ( (| - (recorded examples - (view all) $_) - (recordz examples - (view all) $_)) - (refresh (:: examples)) - (destroyLabelWidgets $_) + (= (viewAllExamples $Widget $ClientData $CallData) + (| (recorded examples - (view dialog $X) $_) - (xtUnmanageChild $X))) -; - - + (view all) $_) + (recordz examples + (view all) $_)) + (refresh (:: examples)) + (destroyLabelWidgets $_) + (recorded examples + (view dialog $X) $_) + (xtUnmanageChild $X)) - (= - (cancelViewExamples $Widget $ClientData $CallData) - ( (destroyLabelWidgets $_) - (recorded examples - (view dialog $X) $_) - (xtUnmanageChild $X))) -; + (= (cancelViewExamples $Widget $ClientData $CallData) + (destroyLabelWidgets $_) + (recorded examples + (view dialog $X) $_) + (xtUnmanageChild $X)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: popupFunctions/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +Widget calling widget ; -; - +; * +PopupShell widget, to manage ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Manages the specified child of the calling widget. ; -; - +; * ; -; - +; ************************************************************************ - (= - (popupFunctions $Widget $PopupShell $CallData) - ( (xtGetValues $Widget - (:: (xmNheight $Ys))) - (xtTranslateCoords $Widget 0 $Ys $X $Y) - (xtSetValues $PopupShell - (:: - (xmNx $X) - (xmNy $Y))) - (xtManageChild $PopupShell) - (recordz learnfuncs - (popedup $PopupShell) $_))) -; - + (= (popupFunctions $Widget $PopupShell $CallData) + (xtGetValues $Widget + (:: (xmNheight $Ys))) + (xtTranslateCoords $Widget 0 $Ys $X $Y) + (xtSetValues $PopupShell + (:: + (xmNx $X) + (xmNy $Y))) + (xtManageChild $PopupShell) + (recordz learnfuncs + (popedup $PopupShell) $_)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: yesNoPopdown/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * +JaNeinPopup widget, to unmanage ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Unmanages a popup widget. ; -; - +; * ; -; - +; ************************************************************************ - (= - (yesNoPopdown $Widget $JaNeinPopup $CallData) + (= (yesNoPopdown $Widget $JaNeinPopup $CallData) (xtUnmanageChild $JaNeinPopup)) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: functionsPopdown/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * _ClientData client data ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Unmanages a popup widget. ; -; - +; * ; -; - +; ************************************************************************ - (= - (functionsPopdown $Widget $ClientData $CallData) - ( (recorded learnfuncs - (popedup $PopupShell) $Ref) - (erase $Ref) - (xtUnmanageChild $PopupShell))) -; - + (= (functionsPopdown $Widget $ClientData $CallData) + (recorded learnfuncs + (popedup $PopupShell) $Ref) + (erase $Ref) + (xtUnmanageChild $PopupShell)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: doKommando/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling procedure ; -; - +; * +[KommandoText,KStatus] widgets ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Executes the command given by the user. ; -; - +; * ; -; +; ************************************************************************ - - (= - (doKommando $Widget - (:: $KommandoText $KStatus) $CallData) - ( (proxtGetDefaultCharset $DCharset) - (proxtStringToCharPtr '-EXIT- Input' $ACP) - (xmStringCreate $ACP $DCharset $AXmS) - (xtSetValues $KStatus - (:: (xmNlabelString $AXmS))) - (xmTextGetString $KommandoText $KcharPtr) - (proxtCharPtrToString $KcharPtr $KS) - (xxmStringToTerm $KcharPtr $Charset $Term) - (writeMessage :- ) - (writelnMessage $KS) - (| - (det-if-then - (call $Term) - (, - (proxtStringToCharPtr '- yes - Input' $YesCP) - (xmStringCreate $YesCP $DCharset $YesXmS) - (xtSetValues $KStatus - (:: (xmNlabelString $YesXmS))) - (writelnMessage '% yes'))) - (det-if-then otherwise - (, - (proxtStringToCharPtr '- no - Input' $NoCP) - (xmStringCreate $NoCP $DCharset $NoXmS) - (xtSetValues $KStatus - (:: (xmNlabelString $NoXmS))) - (writelnMessage '% no')))) - (doEmptyKommando $_ $KommandoText $_))) -; - + (= (doKommando $Widget (:: $KommandoText $KStatus) $CallData) + (proxtGetDefaultCharset $DCharset) + (proxtStringToCharPtr '-EXIT- Input' $ACP) + (xmStringCreate $ACP $DCharset $AXmS) + (xtSetValues $KStatus + (:: (xmNlabelString $AXmS))) + (xmTextGetString $KommandoText $KcharPtr) + (proxtCharPtrToString $KcharPtr $KS) + (xxmStringToTerm $KcharPtr $Charset $Term) + (writeMessage :- ) + (writelnMessage $KS) + (| + (det-if-then + (call $Term) + (, + (proxtStringToCharPtr '- yes - Input' $YesCP) + (xmStringCreate $YesCP $DCharset $YesXmS) + (xtSetValues $KStatus + (:: (xmNlabelString $YesXmS))) + (writelnMessage '% yes'))) + (det-if-then otherwise + (, + (proxtStringToCharPtr '- no - Input' $NoCP) + (xmStringCreate $NoCP $DCharset $NoXmS) + (xtSetValues $KStatus + (:: (xmNlabelString $NoXmS))) + (writelnMessage '% no')))) + (doEmptyKommando $_ $KommandoText $_)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: doEmptyKommando/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * +KommandoText widget ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Sets the command text to an empty string. ; -; - +; * ; -; - +; ************************************************************************ - (= - (doEmptyKommando $Widget $KommandoText $CallData) - ( (proxtStringToCharPtr '' $KommandoChrPtr) - (xmTextSetString $KommandoText $KommandoChrPtr) - (refreshKnowledgeList $Widget rules $Calldata) - (refreshKnowledgeList $Widget examples $Calldata) - (updateEvaluationLabel))) -; - + (= (doEmptyKommando $Widget $KommandoText $CallData) + (proxtStringToCharPtr '' $KommandoChrPtr) + (xmTextSetString $KommandoText $KommandoChrPtr) + (refreshKnowledgeList $Widget rules $Calldata) + (refreshKnowledgeList $Widget examples $Calldata) + (updateEvaluationLabel)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: beenden/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * _ClientData client data ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Quits XMILES, returns to MeTTa toplevel. ; -; - +; * ; -; - +; ************************************************************************ - (= - (beenden $Widget $ClientData $CallData) + (= (beenden $Widget $ClientData $CallData) ( (recorded messages (file $F) $Ref) (erase $Ref) (close $F) (write 'X-MILES korrekt beendet!') (nl) - (remove-symbol &self + (remove-is-symbol &self (my_exit_loop no)) - (add-symbol &self + (add-is-symbol &self (my_exit_loop yes)))) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: createMessageArea/1 ; -; - +; * ; -; - +; * syntax: createMessageArea(+Parent) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: Creates the area for the messages from XMILES to the user. ; -; - +; * ; -; - +; ************************************************************************ - (= - (createMessageArea $Parent) - ( (xmCreateFrame $Parent Messages Nil $MessageFrame) - (xtManageChild $MessageFrame) - (xmCreateRowColumn $MessageFrame messages - (:: - (xmNadjustLast True) - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $MessageColumn) - (xtManageChild $MessageColumn) - (proxtStringToCharPtr Messages $MessageTitleChrPtr) - (proxtGetDefaultCharset $DCharset) - (xmStringCreate $MessageTitleChrPtr $DCharset $MessageTitleStr) - (xmCreateLabelGadget $MessageColumn messageLabel - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $MessageTitleStr)) $MessageLabel) - (xtManageChild $MessageLabel) - (xmCreateScrolledText $MessageColumn messageText - (:: - (xmNeditable False) - (xmNeditMode xmMULTI-LINE-EDIT) - (xmNrows 8) - (xmNlistSizePolicy xmCONSTANT) - (xmNscrollBarDisplayPolicy xmSTATIC) - (xmNscrollingPolicy xmAUTOMATIC) - (xmNautoShowCursorPosition True)) $MessageText) - (xtManageChild $MessageText) - (recordz messages - (textWidget $MessageText) $_) - (xmCreateRowColumn $MessageColumn ButtonRow - (:: - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER) - (xmNnumColumns 1) - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN)) $ButtonRow) - (xtManageChild $ButtonRow) - (xmCreatePushButton $ButtonRow Save Nil $Save) - (xtManageChild $Save) - (xtAddCallback $Save xmNactivateCallback saveMessages $_) - (xmCreatePushButton $ButtonRow Clear Nil $Clear) - (xtManageChild $Clear) - (xtAddCallback $Clear xmNactivateCallback clearMessages $_) - (open xmProtocol.tmp write $F) - (recordz messages - (file $F) $_))) -; - + (= (createMessageArea $Parent) + (xmCreateFrame $Parent Messages Nil $MessageFrame) + (xtManageChild $MessageFrame) + (xmCreateRowColumn $MessageFrame messages + (:: + (xmNadjustLast True) + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $MessageColumn) + (xtManageChild $MessageColumn) + (proxtStringToCharPtr Messages $MessageTitleChrPtr) + (proxtGetDefaultCharset $DCharset) + (xmStringCreate $MessageTitleChrPtr $DCharset $MessageTitleStr) + (xmCreateLabelGadget $MessageColumn messageLabel + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $MessageTitleStr)) $MessageLabel) + (xtManageChild $MessageLabel) + (xmCreateScrolledText $MessageColumn messageText + (:: + (xmNeditable False) + (xmNeditMode xmMULTI-LINE-EDIT) + (xmNrows 8) + (xmNlistSizePolicy xmCONSTANT) + (xmNscrollBarDisplayPolicy xmSTATIC) + (xmNscrollingPolicy xmAUTOMATIC) + (xmNautoShowCursorPosition True)) $MessageText) + (xtManageChild $MessageText) + (recordz messages + (textWidget $MessageText) $_) + (xmCreateRowColumn $MessageColumn ButtonRow + (:: + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER) + (xmNnumColumns 1) + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN)) $ButtonRow) + (xtManageChild $ButtonRow) + (xmCreatePushButton $ButtonRow Save Nil $Save) + (xtManageChild $Save) + (xtAddCallback $Save xmNactivateCallback saveMessages $_) + (xmCreatePushButton $ButtonRow Clear Nil $Clear) + (xtManageChild $Clear) + (xtAddCallback $Clear xmNactivateCallback clearMessages $_) + (open xmProtocol.tmp write $F) + (recordz messages + (file $F) $_)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: saveMessages/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * _ClientData client data ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Saves the scrolled text widet holding the XMILES messages ; -; - +; * ; -; - +; ************************************************************************ - (= - (saveMessages $Widget $ClientData $CallData) - ( (recorded messages - (textWidget $MessageText) $_) - (proxtStringToCharPtr '' $EmptyCharPtr) - (xmTextSetString $MessageText $EmptyCharPtr) - (recorded messages - (file $F) $Ref) - (erase $Ref) - (close $F) - (unix (shell 'mv xmProtocol.tmp xmProtocol.sav')) - (open xmProtocol.tmp write $Fnew) - (recordz messages - (file $Fnew) $_) - (writelnMessage '% wrote "xmProtocol.sav"'))) -; - + (= (saveMessages $Widget $ClientData $CallData) + (recorded messages + (textWidget $MessageText) $_) + (proxtStringToCharPtr '' $EmptyCharPtr) + (xmTextSetString $MessageText $EmptyCharPtr) + (recorded messages + (file $F) $Ref) + (erase $Ref) + (close $F) + (unix (shell 'mv xmProtocol.tmp xmProtocol.sav')) + (open xmProtocol.tmp write $Fnew) + (recordz messages + (file $Fnew) $_) + (writelnMessage '% wrote "xmProtocol.sav"')) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: clearMessages/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * _ClientData client data ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Clears the scrolled text widet holding the XMILES messages ; -; - +; * ; -; - - - - (= - (clearMessages $Widget $ClientData $CallData) - ( (recorded messages - (textWidget $MessageText) $_) - (proxtStringToCharPtr '' $EmptyCharPtr) - (xmTextSetString $MessageText $EmptyCharPtr) - (recorded messages - (file $F) $Ref) - (erase $Ref) - (close $F) - (open xmProtocol.tmp write $Fnew) - (recordz messages - (file $Fnew) $_))) -; +; ************************************************************************ + (= (clearMessages $Widget $ClientData $CallData) + (recorded messages + (textWidget $MessageText) $_) + (proxtStringToCharPtr '' $EmptyCharPtr) + (xmTextSetString $MessageText $EmptyCharPtr) + (recorded messages + (file $F) $Ref) + (erase $Ref) + (close $F) + (open xmProtocol.tmp write $Fnew) + (recordz messages + (file $Fnew) $_)) -; -; ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: writeError/1 ; -; - +; * ; -; - +; * syntax: writeError(+Message) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: Appends the Message to the ErrorText buffer. ; -; - - - - (= - (writeError $Message) - ( (| - (det-if-then - (number $Message) - (, - (number-chars $Message $MsgChars) - (atom-chars $MsgStr $MsgChars))) - (det-if-then otherwise - (= $MsgStr $Message))) - (| - (det-if-then - (recorded error - (errorText $EText) $Ref) - (, - (erase $Ref) - (concat $EText $MsgStr $NewEText))) - (det-if-then otherwise - (= $NewEText $MsgStr))) - (recordz error - (errorText $NewEText) $_))) -; +; * +; +; ************************************************************************ + (= (writeError $Message) + (| + (det-if-then + (number $Message) + (, + (number-chars $Message $MsgChars) + (atom-chars $MsgStr $MsgChars))) + (det-if-then otherwise + (= $MsgStr $Message))) + (| + (det-if-then + (recorded error + (errorText $EText) $Ref) + (, + (erase $Ref) + (concat $EText $MsgStr $NewEText))) + (det-if-then otherwise + (= $NewEText $MsgStr))) + (recordz error + (errorText $NewEText) $_)) -; -; ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: writelnError/1 ; -; - +; * ; -; - +; * syntax: writelnError(+Message) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: Appends the Message to the ErrorText buffer. ; -; - - +; * +; +; ************************************************************************ - (= - (writelnError $Message) - ( (| - (det-if-then - (number $Message) - (, - (number-chars $Message $MsgChars) - (append $MsgChars - (:: 10) $MC) - (atom-chars $MsgStr $MC))) - (det-if-then otherwise - (, - (atom-chars $Message $MsgChars) - (append $MsgChars - (:: 10) $MC) - (atom-chars $MsgStr $MC)))) - (| - (det-if-then - (recorded error - (errorText $EText) $Ref) - (, - (erase $Ref) - (concat $EText $MsgStr $NewEText))) - (det-if-then otherwise - (= $NewEText $MsgStr))) - (recordz error - (errorText $NewEText) $_))) -; + (= (writelnError $Message) + (| + (det-if-then + (number $Message) + (, + (number-chars $Message $MsgChars) + (append $MsgChars + (:: 10) $MC) + (atom-chars $MsgStr $MC))) + (det-if-then otherwise + (, + (atom-chars $Message $MsgChars) + (append $MsgChars + (:: 10) $MC) + (atom-chars $MsgStr $MC)))) + (| + (det-if-then + (recorded error + (errorText $EText) $Ref) + (, + (erase $Ref) + (concat $EText $MsgStr $NewEText))) + (det-if-then otherwise + (= $NewEText $MsgStr))) + (recordz error + (errorText $NewEText) $_)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: flushErrorBuffer/1 ; -; - +; * ; -; - +; * syntax: flushErrorBuffer(+Message) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: Appends the ErrorText buffer to the MessageText. ; -; - +; * ; -; +; ************************************************************************ - - (= - (flushErrorBuffer) + (= (flushErrorBuffer) (| (det-if-then (recorded error @@ -7060,593 +5490,472 @@ (, (erase $Ref) (writeMessage $EText))) otherwise)) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: writeMessage/1 ; -; - +; * ; -; - +; * syntax: writeMessage(+Message) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: Appends the Message to the MessageText. ; -; - +; * ; -; +; ************************************************************************ - - (= - (writeMessage $Message) - ( (recorded messages - (textWidget $MessageText) $_) + (= (writeMessage $Message) + (recorded messages + (textWidget $MessageText) $_) + (| + (det-if-then + (number $Message) + (, + (number-chars $Message $MsgChars) + (atom-chars $MsgStr $MsgChars) + (proxtStringToCharPtr $MsgStr $MessageCharPtr))) (| (det-if-then - (number $Message) - (, - (number-chars $Message $MsgChars) - (atom-chars $MsgStr $MsgChars) - (proxtStringToCharPtr $MsgStr $MessageCharPtr))) - (| - (det-if-then - (atom $Message) - (proxtStringToCharPtr $Message $MessageCharPtr)) - (det-if-then otherwise - (xxmWriteToCharPtr - (write $Message) $MessageCharPtr)))) - (xmTextGetLastPosition $MessageText $LastPos) - (xmTextReplace $MessageText $LastPos $LastPos $MessageCharPtr) - (recorded messages - (file $F) $_) - (write $F $Message))) -; - + (atom $Message) + (proxtStringToCharPtr $Message $MessageCharPtr)) + (det-if-then otherwise + (xxmWriteToCharPtr + (write $Message) $MessageCharPtr)))) + (xmTextGetLastPosition $MessageText $LastPos) + (xmTextReplace $MessageText $LastPos $LastPos $MessageCharPtr) + (recorded messages + (file $F) $_) + (write $F $Message)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: writelnMessage/1 ; -; - +; * ; -; - +; * syntax: writelnMessage(+Message) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: Appends the Message to the MessageText. ; -; - +; * ; -; +; ************************************************************************ - - (= - (writelnMessage $Message) - ( (recorded messages - (textWidget $MessageText) $_) + (= (writelnMessage $Message) + (recorded messages + (textWidget $MessageText) $_) + (| + (det-if-then + (number $Message) + (, + (number-chars $Message $MsgChars) + (append $MsgChars + (:: 10) $MC2) + (atom-chars $MsgStr $MC2) + (proxtStringToCharPtr $MsgStr $MessageCharPtr))) (| (det-if-then - (number $Message) + (atom $Message) (, - (number-chars $Message $MsgChars) + (atom-chars $Message $MsgChars) (append $MsgChars (:: 10) $MC2) (atom-chars $MsgStr $MC2) (proxtStringToCharPtr $MsgStr $MessageCharPtr))) - (| - (det-if-then - (atom $Message) + (det-if-then otherwise + (xxmWriteToCharPtr (, - (atom-chars $Message $MsgChars) - (append $MsgChars - (:: 10) $MC2) - (atom-chars $MsgStr $MC2) - (proxtStringToCharPtr $MsgStr $MessageCharPtr))) - (det-if-then otherwise - (xxmWriteToCharPtr - (, - (write $Message) - (nl)) $MessageCharPtr)))) - (xmTextGetLastPosition $MessageText $LastPos) - (xmTextReplace $MessageText $LastPos $LastPos $MessageCharPtr) - (xmTextScroll $MessageText 1) - (recorded messages - (file $F) $_) - (write $F $Message) - (nl $F))) -; - - - -; -; + (write $Message) + (nl)) $MessageCharPtr)))) + (xmTextGetLastPosition $MessageText $LastPos) + (xmTextReplace $MessageText $LastPos $LastPos $MessageCharPtr) + (xmTextScroll $MessageText 1) + (recorded messages + (file $F) $_) + (write $F $Message) + (nl $F)) + ; -; - +; ************************************************************************ +; +; * ; -; - +; * predicate: createEditorArea/1 ; -; - +; * ; -; - +; * syntax: createEditorArea(+Parent) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: Creates the area for the editior for editing rules and ; -; - +; * examples. ; -; - +; * ; -; - +; ************************************************************************ - (= - (createEditorArea $Parent) - ( (xmCreateFrame $Parent Editor Nil $EditorFrame) - (xtManageChild $EditorFrame) - (xmCreateRowColumn $EditorFrame editor - (:: - (xmNadjustLast True) - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $EditorRowColumn) - (xtManageChild $EditorRowColumn) - (proxtStringToCharPtr Editor $EditorTitleChrPtr) - (proxtGetDefaultCharset $DCharset) - (xmStringCreate $EditorTitleChrPtr $DCharset $EditorTitleStr) - (xmCreateLabelGadget $EditorRowColumn editorLabel - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $EditorTitleStr)) $EditorLabel) - (xtManageChild $EditorLabel) - (recordz editor - (label $EditorLabel) $_) - (xmCreateScrolledText $EditorRowColumn kommandotext - (:: - (xmNeditable True) - (xmNeditMode xmMULTI-LINE-EDIT) - (xmNrows 5) - (xmNlistSizePolicy xmCONSTANT) - (xmNscrollBarDisplayPolicy xmSTATIC) - (xmNscrollingPolicy xmAUTOMATIC) - (xmNautoShowCursorPosition True)) $EditorText) - (xtManageChild $EditorText) - (recordz editor - (textWidget $EditorText) $Ref) - (xmCreateRowColumn $EditorRowColumn ButtonRowColumn - (:: - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER) - (xmNnumColumns 1) - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN)) $ButtonRowColumn) - (xtManageChild $ButtonRowColumn) - (xmCreatePushButton $ButtonRowColumn 'Add rule' Nil $AddRule) - (xtManageChild $AddRule) - (xmCreatePushButton $ButtonRowColumn 'Change rule' Nil $ChangeRule) - (createYesNoPopup $ChangeRule $YesNoPopup changeRule $_) - (xtManageChild $ChangeRule) - (xmCreatePushButton $ButtonRowColumn 'Add example' Nil $AddExample) - (xtManageChild $AddExample) - (xmCreatePushButton $ButtonRowColumn 'Change example' Nil $ChangeExample) - (createYesNoPopup $ChangeExample $YesNoPopup2 changeExample $_) - (xtManageChild $ChangeExample) - (xmCreatePushButton $ButtonRowColumn Clear Nil $Clear) - (xtManageChild $Clear) - (xtAddCallback $Clear xmNactivateCallback clearEditor $_) - (xtAddCallback $AddRule xmNactivateCallback addRule $_) - (xtAddCallback $AddExample xmNactivateCallback addExample $_))) -; - + (= (createEditorArea $Parent) + (xmCreateFrame $Parent Editor Nil $EditorFrame) + (xtManageChild $EditorFrame) + (xmCreateRowColumn $EditorFrame editor + (:: + (xmNadjustLast True) + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $EditorRowColumn) + (xtManageChild $EditorRowColumn) + (proxtStringToCharPtr Editor $EditorTitleChrPtr) + (proxtGetDefaultCharset $DCharset) + (xmStringCreate $EditorTitleChrPtr $DCharset $EditorTitleStr) + (xmCreateLabelGadget $EditorRowColumn editorLabel + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $EditorTitleStr)) $EditorLabel) + (xtManageChild $EditorLabel) + (recordz editor + (label $EditorLabel) $_) + (xmCreateScrolledText $EditorRowColumn kommandotext + (:: + (xmNeditable True) + (xmNeditMode xmMULTI-LINE-EDIT) + (xmNrows 5) + (xmNlistSizePolicy xmCONSTANT) + (xmNscrollBarDisplayPolicy xmSTATIC) + (xmNscrollingPolicy xmAUTOMATIC) + (xmNautoShowCursorPosition True)) $EditorText) + (xtManageChild $EditorText) + (recordz editor + (textWidget $EditorText) $Ref) + (xmCreateRowColumn $EditorRowColumn ButtonRowColumn + (:: + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER) + (xmNnumColumns 1) + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN)) $ButtonRowColumn) + (xtManageChild $ButtonRowColumn) + (xmCreatePushButton $ButtonRowColumn 'Add rule' Nil $AddRule) + (xtManageChild $AddRule) + (xmCreatePushButton $ButtonRowColumn 'Change rule' Nil $ChangeRule) + (createYesNoPopup $ChangeRule $YesNoPopup changeRule $_) + (xtManageChild $ChangeRule) + (xmCreatePushButton $ButtonRowColumn 'Add example' Nil $AddExample) + (xtManageChild $AddExample) + (xmCreatePushButton $ButtonRowColumn 'Change example' Nil $ChangeExample) + (createYesNoPopup $ChangeExample $YesNoPopup2 changeExample $_) + (xtManageChild $ChangeExample) + (xmCreatePushButton $ButtonRowColumn Clear Nil $Clear) + (xtManageChild $Clear) + (xtAddCallback $Clear xmNactivateCallback clearEditor $_) + (xtAddCallback $AddRule xmNactivateCallback addRule $_) + (xtAddCallback $AddExample xmNactivateCallback addExample $_)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: clearEditor/3 callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * _ClientData client data ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Clears the scrolled text widget holding the edited object ; -; - +; * ; -; - +; ************************************************************************ + - - (= - (clearEditor $Widget $ClientData $CallData) - ( (recorded editor - (textWidget $EditorText) $_) - (recorded editor - (label $Label) $_) - (proxtGetDefaultCharset $DCharset) - (| - (det-if-then - (recorded editor - (editing $_ $_) $Ref) - (, - (erase $Ref) - (proxtStringToCharPtr Editor $LblCP) - (xmStringCreate $LblCP $DCharset $LblS) - (xtSetValues $Label - (:: (xmNlabelString $LblS))))) otherwise) - (proxtStringToCharPtr '' $EmptyChrPtr) - (xmTextSetString $EditorText $EmptyChrPtr))) -; - + (= (clearEditor $Widget $ClientData $CallData) + (recorded editor + (textWidget $EditorText) $_) + (recorded editor + (label $Label) $_) + (proxtGetDefaultCharset $DCharset) + (| + (det-if-then + (recorded editor + (editing $_ $_) $Ref) + (, + (erase $Ref) + (proxtStringToCharPtr Editor $LblCP) + (xmStringCreate $LblCP $DCharset $LblS) + (xtSetValues $Label + (:: (xmNlabelString $LblS))))) otherwise) + (proxtStringToCharPtr '' $EmptyChrPtr) + (xmTextSetString $EditorText $EmptyChrPtr)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: addRule/3 Callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * _ClientData ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Adds the rule in the editor to the rule list. ; -; - +; * ; -; - - +; ************************************************************************ - (= - (addRule $Widget $ClientData $CallData) - ( (recorded editor - (textWidget $EditorText) $Ref) - (xmTextGetString $EditorText $RuleCP) - (xxmStringToTerm $RuleCP $_ $RuleTerm) - (proxtCharPtrToString $RuleCP $RulePString) - (span-left $RulePString "." $N) - (substring $RulePString $RuleString 0 $N $_) - (store-clause $RuleTerm $_ user $ID) - (writeMessage ':- store-clause(') - (writeMessage $RuleString) - (writeMessage ',-,user,') - (writeMessage $ID) - (writelnMessage ).) - (writelnMessage '% rule added.') - (updateEvaluationLabel) - (get-clause $ID $H $B $S $L) - (addRuleItem $ID $H $B $S $L))) -; + (= (addRule $Widget $ClientData $CallData) + (recorded editor + (textWidget $EditorText) $Ref) + (xmTextGetString $EditorText $RuleCP) + (xxmStringToTerm $RuleCP $_ $RuleTerm) + (proxtCharPtrToString $RuleCP $RulePString) + (span-left $RulePString "." $N) + (substring $RulePString $RuleString 0 $N $_) + (store-clause $RuleTerm $_ user $ID) + (writeMessage ':- store-clause(') + (writeMessage $RuleString) + (writeMessage ',-,user,') + (writeMessage $ID) + (writelnMessage ).) + (writelnMessage '% rule added.') + (updateEvaluationLabel) + (get-clause $ID $H $B $S $L) + (addRuleItem $ID $H $B $S $L)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: resultAddRule/1 result procedure ; -; - +; * ; -; - +; * syntax: resultAddRule(Id) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: Adds the rule specified by Id to the rule list. ; -; - +; * ; -; - - +; ************************************************************************ - (= - (resultAddRule $Id) - ( (get-clause $Id $H $B $S $L) - (addRuleItem $Id $H $B $S $L) - (writeMessage '% rule ') - (number-chars $Id $IdChars) - (atom-chars $IdString $IdChars) - (writeMessage $IdString) - (writelnMessage ' created.'))) -; + (= (resultAddRule $Id) + (get-clause $Id $H $B $S $L) + (addRuleItem $Id $H $B $S $L) + (writeMessage '% rule ') + (number-chars $Id $IdChars) + (atom-chars $IdString $IdChars) + (writeMessage $IdString) + (writelnMessage ' created.')) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: resultAddNewpreds/1 result procedure ; -; - +; * ; -; - +; * syntax: resultAddNewpreds(Reflist) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: Displays a window with alternative specialisations ; -; - +; * through new predicates, and allows to choose one to add to the kb ; -; - +; * ; -; - - - - (= - (resultAddNewpreds (, $ID $Reflist)) - ( (toplevel $Shell) - (xmCreateBulletinBoardDialog $Shell Newpreds Nil $NewpredDialog) - (recordz newpreddialog - (with_self $ID $NewpredDialog) $_) - (xtManageChild $NewpredDialog) - (xmCreateFrame $NewpredDialog 'Newpred Frame' Nil $NewpredFrame) - (xtManageChild $NewpredFrame) - (xmCreateRowColumn $NewpredFrame newpredColumn - (:: - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT)) $NewpredColumn) - (xtManageChild $NewpredColumn) - (xmCreateRowColumn $NewpredColumn titlerow - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $TitleRow) - (xtManageChild $TitleRow) - (proxtGetDefaultCharset $DCharset) - (proxtStringToCharPtr 'Choose Specialisation' $TitleCP) - (xmStringCreate $TitleCP $DCharset $TitleStr) - (xmCreateLabelGadget $TitleRow title - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $TitleStr)) $TitleLabel) - (xtManageChild $TitleLabel) - (xmCreateScrolledWindow $NewpredColumn newpredSW - (:: - (xmNheight 300) - (xmNwidth 300) - (xmNlistSizePolicy xmCONSTANT) - (xmNscrollBarDisplayPolicy xmSTATIC) - (xmNscrollingPolicy xmAUTOMATIC)) $NewpredSW) - (xtManageChild $NewpredSW) - (xmCreateRowColumn $NewpredSW newpredRC - (:: - (xmNadjustLast False) - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $NewpredRC) - (xtGetValues $NewpredRC - (:: (xmNbackground $B))) - (xtGetValues $NewpredSW - (:: (xmNclipWindow $CW))) - (xtSetValues $CW - (:: (xmNbackground $B))) - (xtManageChild $NewpredRC) - (addnewpredclauses $Reflist $NewpredRC) - (xmCreateRowColumn $NewpredColumn buttonrow - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $ButtonRow) - (xtManageChild $ButtonRow) - (xmCreatePushButton $ButtonRow 'Add Rule' Nil $AddRule) - (xtManageChild $AddRule) - (xtAddCallback $AddRule xmNactivateCallback addselectedRule $_) - (xmCreatePushButton $ButtonRow None Nil $None) - (xtManageChild $None) - (xtAddCallback $None xmNactivateCallback addnorule $_))) -; - - - - - (= - (addnewpredclauses () $_) True) -; - - (= - (addnewpredclauses - (Cons - (, $NC $Pos $Neg $TR) $R) $Widget) - ( (proxtGetDefaultCharset $DCharset) - (xxmWriteToString - (portray-clause $NC) $DCharset $XmS) - (xmCreateLabel $Widget newpredClause - (:: - (xmNalignment xmALIGNMENT-BEGINNING) - (xmNlabelString $XmS) - (xmNlabelType xmSTRING)) $Label) - (xtManageChild $Label) - (recordz newpred - (np $Label $NC $Pos $Neg $TR notselected) $Ref) - (xtAddEventHandler $Label - (:: buttonReleaseMask) False selectnpclause $_) - (addnewpredclauses $R $Widget))) -; - - - - - (= - (selectnpclause $Widget $_ $CallData) - ( (recorded newpred - (np $Widget $NC $Pos $Neg $TR notselected) $Ref) - (turnoff-other-selected) - (xtGetValues $Widget - (:: - (xmNbackground $B) - (xmNforeground $F))) - (xtSetValues $Widget - (:: - (xmNbackground $F) - (xmNforeground $B))) - (erase $Ref) - (recordz newpred - (np $Widget $NC $Pos $Neg $TR selected) $_))) -; - - - (= - (selectnpclause $Widget rules $CallData) - ( (recorded newpred - (np $Widget $NC $Pos $Neg $TR selected) $Ref) - (xtGetValues $Widget - (:: - (xmNbackground $B) - (xmNforeground $F))) - (xtSetValues $Widget - (:: - (xmNbackground $F) - (xmNforeground $B))) - (erase $Ref) - (recordz newpred - (np $Widget $NC $Pos $Neg $TR notselected) $_))) -; - - - - (= - (turnoff-other-selected) +; ************************************************************************ + + + (= (resultAddNewpreds (, $ID $Reflist)) + (toplevel $Shell) + (xmCreateBulletinBoardDialog $Shell Newpreds Nil $NewpredDialog) + (recordz newpreddialog + (with_self $ID $NewpredDialog) $_) + (xtManageChild $NewpredDialog) + (xmCreateFrame $NewpredDialog 'Newpred Frame' Nil $NewpredFrame) + (xtManageChild $NewpredFrame) + (xmCreateRowColumn $NewpredFrame newpredColumn + (:: + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT)) $NewpredColumn) + (xtManageChild $NewpredColumn) + (xmCreateRowColumn $NewpredColumn titlerow + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $TitleRow) + (xtManageChild $TitleRow) + (proxtGetDefaultCharset $DCharset) + (proxtStringToCharPtr 'Choose Specialisation' $TitleCP) + (xmStringCreate $TitleCP $DCharset $TitleStr) + (xmCreateLabelGadget $TitleRow title + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $TitleStr)) $TitleLabel) + (xtManageChild $TitleLabel) + (xmCreateScrolledWindow $NewpredColumn newpredSW + (:: + (xmNheight 300) + (xmNwidth 300) + (xmNlistSizePolicy xmCONSTANT) + (xmNscrollBarDisplayPolicy xmSTATIC) + (xmNscrollingPolicy xmAUTOMATIC)) $NewpredSW) + (xtManageChild $NewpredSW) + (xmCreateRowColumn $NewpredSW newpredRC + (:: + (xmNadjustLast False) + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $NewpredRC) + (xtGetValues $NewpredRC + (:: (xmNbackground $B))) + (xtGetValues $NewpredSW + (:: (xmNclipWindow $CW))) + (xtSetValues $CW + (:: (xmNbackground $B))) + (xtManageChild $NewpredRC) + (addnewpredclauses $Reflist $NewpredRC) + (xmCreateRowColumn $NewpredColumn buttonrow + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $ButtonRow) + (xtManageChild $ButtonRow) + (xmCreatePushButton $ButtonRow 'Add Rule' Nil $AddRule) + (xtManageChild $AddRule) + (xtAddCallback $AddRule xmNactivateCallback addselectedRule $_) + (xmCreatePushButton $ButtonRow None Nil $None) + (xtManageChild $None) + (xtAddCallback $None xmNactivateCallback addnorule $_)) + + + + (= (addnewpredclauses () $_) True) + (= (addnewpredclauses (Cons (, $NC $Pos $Neg $TR) $R) $Widget) + (proxtGetDefaultCharset $DCharset) + (xxmWriteToString + (portray-clause $NC) $DCharset $XmS) + (xmCreateLabel $Widget newpredClause + (:: + (xmNalignment xmALIGNMENT-BEGINNING) + (xmNlabelString $XmS) + (xmNlabelType xmSTRING)) $Label) + (xtManageChild $Label) + (recordz newpred + (np $Label $NC $Pos $Neg $TR notselected) $Ref) + (xtAddEventHandler $Label + (:: buttonReleaseMask) False selectnpclause $_) + (addnewpredclauses $R $Widget)) + + + + (= (selectnpclause $Widget $_ $CallData) + (recorded newpred + (np $Widget $NC $Pos $Neg $TR notselected) $Ref) + (turnoff-other-selected) + (xtGetValues $Widget + (:: + (xmNbackground $B) + (xmNforeground $F))) + (xtSetValues $Widget + (:: + (xmNbackground $F) + (xmNforeground $B))) + (erase $Ref) + (recordz newpred + (np $Widget $NC $Pos $Neg $TR selected) $_)) + + (= (selectnpclause $Widget rules $CallData) + (recorded newpred + (np $Widget $NC $Pos $Neg $TR selected) $Ref) + (xtGetValues $Widget + (:: + (xmNbackground $B) + (xmNforeground $F))) + (xtSetValues $Widget + (:: + (xmNbackground $F) + (xmNforeground $B))) + (erase $Ref) + (recordz newpred + (np $Widget $NC $Pos $Neg $TR notselected) $_)) + + + (= (turnoff-other-selected) (mysetof $Ref (^ $Widget (^ $NC @@ -7669,28 +5978,22 @@ (:: (xmNbackground $F) (xmNforeground $B))))))))))) $_)) -; - - (= - (addnorule $_ $_ $_) - ( (recorded newpreddialog - (with_self $_ $Widget) $Ref) - (erase $Ref) - (mysetof $Ref1 - (^ $X - (, - (recorded newpred $X $Ref1) - (erase $Ref1))) $_) - (xtDestroyWidget $Widget))) -; - + (= (addnorule $_ $_ $_) + (recorded newpreddialog + (with_self $_ $Widget) $Ref) + (erase $Ref) + (mysetof $Ref1 + (^ $X + (, + (recorded newpred $X $Ref1) + (erase $Ref1))) $_) + (xtDestroyWidget $Widget)) - (= - (addselectedRule $_ $_ $_) + (= (addselectedRule $_ $_ $_) (det-if-then-else (recorded newpred (np $_ $NC $Pos $Neg $TR selected) $_) @@ -7709,7 +6012,7 @@ (, (member $N $Neg) (store-ex $N - $NID))) $_) - (add-symbol &self + (add-is-symbol &self (: kb $TR)) (erase $Ref0) (mysetof $Ref1 @@ -7718,185 +6021,154 @@ (recorded newpred $X $Ref1) (erase $Ref1))) $_) (xtDestroyWidget $Widget) - (refresh (:: rules examples))) True)) -; - - - - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - - - (= - (resultAddSpec (, $ID $Reflist)) - ( (toplevel $Shell) - (xmCreateBulletinBoardDialog $Shell Specs Nil $SpecsDialog) - (recordz specsdialog - (with_self $ID $SpecsDialog) $_) - (xtManageChild $SpecsDialog) - (xmCreateFrame $SpecsDialog 'Specs Frame' Nil $SpecsFrame) - (xtManageChild $SpecsFrame) - (xmCreateRowColumn $SpecsFrame specsColumn - (:: - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT)) $SpecsColumn) - (xtManageChild $SpecsColumn) - (xmCreateRowColumn $SpecsColumn titlerow - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $TitleRow) - (xtManageChild $TitleRow) - (proxtGetDefaultCharset $DCharset) - (proxtStringToCharPtr 'Choose Specialisation' $TitleCP) - (xmStringCreate $TitleCP $DCharset $TitleStr) - (xmCreateLabelGadget $TitleRow title - (:: - (xmNlabelType xmSTRING) - (xmNlabelString $TitleStr)) $TitleLabel) - (xtManageChild $TitleLabel) - (xmCreateScrolledWindow $SpecsColumn specsSW - (:: - (xmNheight 300) - (xmNwidth 300) - (xmNlistSizePolicy xmCONSTANT) - (xmNscrollBarDisplayPolicy xmSTATIC) - (xmNscrollingPolicy xmAUTOMATIC)) $SpecsSW) - (xtManageChild $SpecsSW) - (xmCreateRowColumn $SpecsSW newpredRC - (:: - (xmNadjustLast False) - (xmNorientation xmVERTICAL) - (xmNpacking xmPACK-TIGHT) - (xmNrowColumnType xmWORK-AREA)) $SpecsRC) - (xtGetValues $SpecsRC - (:: (xmNbackground $B))) - (xtGetValues $SpecsSW - (:: (xmNclipWindow $CW))) - (xtSetValues $CW - (:: (xmNbackground $B))) - (xtManageChild $SpecsRC) - (addspecclauses $Reflist $SpecsRC) - (xmCreateRowColumn $SpecsColumn buttonrow - (:: - (xmNorientation xmHORIZONTAL) - (xmNpacking xmPACK-COLUMN) - (xmNisAligned True) - (xmNentryAlignment xmALIGNMENT-CENTER)) $ButtonRow) - (xtManageChild $ButtonRow) - (xmCreatePushButton $ButtonRow 'Add Rule' Nil $AddRule) - (xtManageChild $AddRule) - (xtAddCallback $AddRule xmNactivateCallback addselectedSpec $_) - (xmCreatePushButton $ButtonRow None Nil $None) - (xtManageChild $None) - (xtAddCallback $None xmNactivateCallback addnospec $_))) -; - - - - - (= - (addspecclauses () $_) True) -; - - (= - (addspecclauses - (Cons $NC $R) $Widget) - ( (proxtGetDefaultCharset $DCharset) - (xxmWriteToString - (portray-clause $NC) $DCharset $XmS) - (xmCreateLabel $Widget specClause - (:: - (xmNalignment xmALIGNMENT-BEGINNING) - (xmNlabelString $XmS) - (xmNlabelType xmSTRING)) $Label) - (xtManageChild $Label) - (recordz spec - (np $Label $NC notselected) $Ref) - (xtAddEventHandler $Label - (:: buttonReleaseMask) False selectspecclause $_) - (addspecclauses $R $Widget))) -; - - - - - (= - (selectspecclause $Widget $_ $CallData) - ( (recorded spec - (np $Widget $NC notselected) $Ref) - (turnoff-other-selected-spec) - (xtGetValues $Widget - (:: - (xmNbackground $B) - (xmNforeground $F))) - (xtSetValues $Widget - (:: - (xmNbackground $F) - (xmNforeground $B))) - (erase $Ref) - (recordz spec - (np $Widget $NC selected) $_))) -; - - - (= - (selectspecclause $Widget rules $CallData) - ( (recorded spec - (np $Widget $NC selected) $Ref) - (xtGetValues $Widget - (:: - (xmNbackground $B) - (xmNforeground $F))) - (xtSetValues $Widget - (:: - (xmNbackground $F) - (xmNforeground $B))) - (erase $Ref) - (recordz spec - (np $Widget $NC notselected) $_))) -; - - - - (= - (turnoff-other-selected-spec) + (refresh (:: rules examples))) True)) + + + +; +; ************************************************************************ +; +; * +; +; * predicate: resultAddSpec/1 result procedure +; +; * +; +; * syntax: resultAddNewpreds(Reflist) +; +; * +; +; * args: +; +; * +; +; * description: Displays a window with alternative specialisations +; +; * through new predicates, and allows to choose one to add to the kb +; +; * +; +; ************************************************************************ + + + (= (resultAddSpec (, $ID $Reflist)) + (toplevel $Shell) + (xmCreateBulletinBoardDialog $Shell Specs Nil $SpecsDialog) + (recordz specsdialog + (with_self $ID $SpecsDialog) $_) + (xtManageChild $SpecsDialog) + (xmCreateFrame $SpecsDialog 'Specs Frame' Nil $SpecsFrame) + (xtManageChild $SpecsFrame) + (xmCreateRowColumn $SpecsFrame specsColumn + (:: + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT)) $SpecsColumn) + (xtManageChild $SpecsColumn) + (xmCreateRowColumn $SpecsColumn titlerow + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $TitleRow) + (xtManageChild $TitleRow) + (proxtGetDefaultCharset $DCharset) + (proxtStringToCharPtr 'Choose Specialisation' $TitleCP) + (xmStringCreate $TitleCP $DCharset $TitleStr) + (xmCreateLabelGadget $TitleRow title + (:: + (xmNlabelType xmSTRING) + (xmNlabelString $TitleStr)) $TitleLabel) + (xtManageChild $TitleLabel) + (xmCreateScrolledWindow $SpecsColumn specsSW + (:: + (xmNheight 300) + (xmNwidth 300) + (xmNlistSizePolicy xmCONSTANT) + (xmNscrollBarDisplayPolicy xmSTATIC) + (xmNscrollingPolicy xmAUTOMATIC)) $SpecsSW) + (xtManageChild $SpecsSW) + (xmCreateRowColumn $SpecsSW newpredRC + (:: + (xmNadjustLast False) + (xmNorientation xmVERTICAL) + (xmNpacking xmPACK-TIGHT) + (xmNrowColumnType xmWORK-AREA)) $SpecsRC) + (xtGetValues $SpecsRC + (:: (xmNbackground $B))) + (xtGetValues $SpecsSW + (:: (xmNclipWindow $CW))) + (xtSetValues $CW + (:: (xmNbackground $B))) + (xtManageChild $SpecsRC) + (addspecclauses $Reflist $SpecsRC) + (xmCreateRowColumn $SpecsColumn buttonrow + (:: + (xmNorientation xmHORIZONTAL) + (xmNpacking xmPACK-COLUMN) + (xmNisAligned True) + (xmNentryAlignment xmALIGNMENT-CENTER)) $ButtonRow) + (xtManageChild $ButtonRow) + (xmCreatePushButton $ButtonRow 'Add Rule' Nil $AddRule) + (xtManageChild $AddRule) + (xtAddCallback $AddRule xmNactivateCallback addselectedSpec $_) + (xmCreatePushButton $ButtonRow None Nil $None) + (xtManageChild $None) + (xtAddCallback $None xmNactivateCallback addnospec $_)) + + + + (= (addspecclauses () $_) True) + (= (addspecclauses (Cons $NC $R) $Widget) + (proxtGetDefaultCharset $DCharset) + (xxmWriteToString + (portray-clause $NC) $DCharset $XmS) + (xmCreateLabel $Widget specClause + (:: + (xmNalignment xmALIGNMENT-BEGINNING) + (xmNlabelString $XmS) + (xmNlabelType xmSTRING)) $Label) + (xtManageChild $Label) + (recordz spec + (np $Label $NC notselected) $Ref) + (xtAddEventHandler $Label + (:: buttonReleaseMask) False selectspecclause $_) + (addspecclauses $R $Widget)) + + + + (= (selectspecclause $Widget $_ $CallData) + (recorded spec + (np $Widget $NC notselected) $Ref) + (turnoff-other-selected-spec) + (xtGetValues $Widget + (:: + (xmNbackground $B) + (xmNforeground $F))) + (xtSetValues $Widget + (:: + (xmNbackground $F) + (xmNforeground $B))) + (erase $Ref) + (recordz spec + (np $Widget $NC selected) $_)) + + (= (selectspecclause $Widget rules $CallData) + (recorded spec + (np $Widget $NC selected) $Ref) + (xtGetValues $Widget + (:: + (xmNbackground $B) + (xmNforeground $F))) + (xtSetValues $Widget + (:: + (xmNbackground $F) + (xmNforeground $B))) + (erase $Ref) + (recordz spec + (np $Widget $NC notselected) $_)) + + + (= (turnoff-other-selected-spec) (mysetof $Ref (^ $Widget (^ $NC @@ -7916,28 +6188,22 @@ (:: (xmNbackground $F) (xmNforeground $B)))))))) $_)) -; - - (= - (addnospec $_ $_ $_) - ( (recorded specsdialog - (with_self $_ $Widget) $Ref) - (erase $Ref) - (mysetof $Ref1 - (^ $X - (, - (recorded spec $X $Ref1) - (erase $Ref1))) $_) - (xtDestroyWidget $Widget))) -; - + (= (addnospec $_ $_ $_) + (recorded specsdialog + (with_self $_ $Widget) $Ref) + (erase $Ref) + (mysetof $Ref1 + (^ $X + (, + (recorded spec $X $Ref1) + (erase $Ref1))) $_) + (xtDestroyWidget $Widget)) - (= - (addselectedSpec $_ $_ $_) + (= (addselectedSpec $_ $_ $_) (det-if-then-else (recorded spec (np $_ $NC selected) $_) @@ -7953,748 +6219,547 @@ (recorded spec $X $Ref1) (erase $Ref1))) $_) (xtDestroyWidget $Widget) - (refresh (:: rules))) True)) -; - + (refresh (:: rules))) True)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: resultAddRuleList/1 result procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +IdList rule ids to add ; -; - +; * ; -; - +; * description: Adds the rules specified by IdList to the rule list ; -; - +; * ; -; - +; ************************************************************************ - (= - (resultAddRuleList Nil) + (= (resultAddRuleList Nil) (set-det)) -; - - (= - (resultAddRuleList (Cons $Id $IdList)) - ( (resultAddRule $Id) (resultAddRuleList $IdList))) -; - + (= (resultAddRuleList (Cons $Id $IdList)) + (resultAddRule $Id) + (resultAddRuleList $IdList)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: resultSelectRules/1 result procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +IdList rule ids to select ; -; - +; * ; -; - +; * description: Selects the rules specified by IdList in the rule list. ; -; - +; * ; -; - - +; ************************************************************************ - (= - (resultSelectRules Nil) - ( (unselectAll $_ rules $_) - (set-det) - (writelnMessage '% resulting rules selected'))) -; - - (= - (resultSelectRules (Cons (with_self $Id $_) $IdList)) - ( (resultSelectRules $IdList) - (recorded current - (clause $Id $Widget notselected) $_) - (selectClause $Widget rules $_))) -; + (= (resultSelectRules Nil) + (unselectAll $_ rules $_) + (set-det) + (writelnMessage '% resulting rules selected')) + (= (resultSelectRules (Cons (with_self $Id $_) $IdList)) + (resultSelectRules $IdList) + (recorded current + (clause $Id $Widget notselected) $_) + (selectClause $Widget rules $_)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: resultSelectExamples/1 result procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +IdList rule ids to select ; -; - +; * ; -; - +; * description: Selects the examples specified by IdList in the rule list ; -; - +; * ; -; +; ************************************************************************ - - (= - (resultSelectExamples Nil) - ( (unselectAll $_ examples $_) - (set-det) - (writelnMessage '% resulting examples selected'))) -; - - (= - (resultSelectExamples (Cons $Id $IdList)) - ( (resultSelectExamples $IdList) - (recorded current - (example $Id $Widget notselected) $_) - (selectClause $Widget examples $_))) -; - + (= (resultSelectExamples Nil) + (unselectAll $_ examples $_) + (set-det) + (writelnMessage '% resulting examples selected')) + (= (resultSelectExamples (Cons $Id $IdList)) + (resultSelectExamples $IdList) + (recorded current + (example $Id $Widget notselected) $_) + (selectClause $Widget examples $_)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: changeRule/3 Callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * _ClientData ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Changes the rule in the editor to the rule list. ; -; - +; * ; -; +; ************************************************************************ - - (= - (changeRule $Widget $ClientData $CallData) - ( (recorded editor - (textWidget $EditorText) $Ref) - (recorded editor - (editing rules $ID) $_) - (delete-clause $ID) - (xmTextGetString $EditorText $RuleCP) - (xxmStringToTerm $RuleCP $_ $RuleTerm) - (store-clause $RuleTerm $_ user $ID) - (proxtCharPtrToString $RuleCP $RulePString) - (span-left $RulePString "." $N) - (substring $RulePString $RuleString 0 $N $_) - (writeMessage ':- delete-clause(') - (writeMessage $ID) - (writelnMessage ).) - (writeMessage ':- store-clause(') - (writeMessage $RuleString) - (writeMessage ',-,user,') - (writeMessage $ID) - (writelnMessage ).) - (writelnMessage '% rule changed.') - (get-clause $ID $H $B $S $L) - (addRuleItem $ID $H $B $S $L) - (updateEvaluationLabel))) -; - + (= (changeRule $Widget $ClientData $CallData) + (recorded editor + (textWidget $EditorText) $Ref) + (recorded editor + (editing rules $ID) $_) + (delete-clause $ID) + (xmTextGetString $EditorText $RuleCP) + (xxmStringToTerm $RuleCP $_ $RuleTerm) + (store-clause $RuleTerm $_ user $ID) + (proxtCharPtrToString $RuleCP $RulePString) + (span-left $RulePString "." $N) + (substring $RulePString $RuleString 0 $N $_) + (writeMessage ':- delete-clause(') + (writeMessage $ID) + (writelnMessage ).) + (writeMessage ':- store-clause(') + (writeMessage $RuleString) + (writeMessage ',-,user,') + (writeMessage $ID) + (writelnMessage ).) + (writelnMessage '% rule changed.') + (get-clause $ID $H $B $S $L) + (addRuleItem $ID $H $B $S $L) + (updateEvaluationLabel)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: addExample/3 Callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * _ClientData ; -; - +; * _CallData event ; -; - +; * ; -; - +; * ; -; - +; * description: Adds the example in the editor to the example list. ; -; - +; * ; -; - +; ************************************************************************ - (= - (addExample $Widget $ClientData $CallData) - ( (recorded editor - (textWidget $EditorText) $Ref) - (xmTextGetString $EditorText $ExampleCP) - (xxmStringToTerm $ExampleCP $_ $ExampleTerm) - (store-ex $ExampleTerm ? $ID) - (proxtCharPtrToString $ExampleCP $ExamplePString) - (span-left $ExamplePString "." $N) - (substring $ExamplePString $ExampleString 0 $N $_) - (writeMessage ':- store-ex(') - (writeMessage $ExampleString) - (writeMessage ,?,) - (writeMessage $ID) - (writelnMessage ).) - (writelnMessage '% example added.') - (get-example $ID $F $C) - (addExampleItem $ID $F $C) - (updateEvaluationLabel))) -; - + (= (addExample $Widget $ClientData $CallData) + (recorded editor + (textWidget $EditorText) $Ref) + (xmTextGetString $EditorText $ExampleCP) + (xxmStringToTerm $ExampleCP $_ $ExampleTerm) + (store-ex $ExampleTerm ? $ID) + (proxtCharPtrToString $ExampleCP $ExamplePString) + (span-left $ExamplePString "." $N) + (substring $ExamplePString $ExampleString 0 $N $_) + (writeMessage ':- store-ex(') + (writeMessage $ExampleString) + (writeMessage ,?,) + (writeMessage $ID) + (writelnMessage ).) + (writelnMessage '% example added.') + (get-example $ID $F $C) + (addExampleItem $ID $F $C) + (updateEvaluationLabel)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: changeExample/3 Callback procedure ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: _Widget calling widget ; -; - +; * _ClientData ; -; - +; * _CallData event ; -; - +; * ; -; - +; * description: Changes the example in the editor to the example list. ; -; - +; * ; -; - +; ************************************************************************ - (= - (changeExample $Widget $ClientData $CallData) - ( (recorded editor - (textWidget $EditorText) $Ref) - (recorded editor - (editing examples $ID) $_) - (get-example $ID $_ $C) - (delete-example $ID) - (xmTextGetString $EditorText $ExampleCP) - (xxmStringToTerm $ExampleCP $_ $ExampleTerm) - (proxtCharPtrToString $ExampleCP $ExamplePString) - (span-left $ExamplePString "." $N) - (substring $ExamplePString $ExampleString 0 $N $_) - (store-ex $ExampleTerm $C $ID) - (writeMessage ':- delete-example(') - (writeMessage $ID) - (writelnMessage ).) - (writeMessage ':- store-ex(') - (writeMessage $ExampleString) - (writeMessage ,?,) - (writeMessage $ID) - (writelnMessage ).) - (writelnMessage '% example changed.') - (get-example $ID $F $C) - (addExampleItem $ID $F $C) - (updateEvaluationLabel))) -; - + (= (changeExample $Widget $ClientData $CallData) + (recorded editor + (textWidget $EditorText) $Ref) + (recorded editor + (editing examples $ID) $_) + (get-example $ID $_ $C) + (delete-example $ID) + (xmTextGetString $EditorText $ExampleCP) + (xxmStringToTerm $ExampleCP $_ $ExampleTerm) + (proxtCharPtrToString $ExampleCP $ExamplePString) + (span-left $ExamplePString "." $N) + (substring $ExamplePString $ExampleString 0 $N $_) + (store-ex $ExampleTerm $C $ID) + (writeMessage ':- delete-example(') + (writeMessage $ID) + (writelnMessage ).) + (writeMessage ':- store-ex(') + (writeMessage $ExampleString) + (writeMessage ,?,) + (writeMessage $ID) + (writelnMessage ).) + (writelnMessage '% example changed.') + (get-example $ID $F $C) + (addExampleItem $ID $F $C) + (updateEvaluationLabel)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: xxmStringToTerm/3 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +S xmCharPtr ; -; - +; * Charset xmCharset ; -; - +; * +T Term ; -; - +; * ; -; - +; * description: Conversion of xmCharPtrs and MeTTa Terms. ; -; - +; * ; -; - +; ************************************************************************ - (= - (xxmStringToTerm $S $Charset $T) - ( (var $T) - (nonvar $S) - (proxtCharPtrToString $S $X1) - (tell xmTemporary) - (write $X1) - (nl) - (told) - (see xmTemporary) - (read $T) - (seen) - (set-det))) -; - - - (= - (xxmStringToTerm $XmS $Charset $T) - ( (var $XmS) - (nonvar $T) - (tell xmTemporary) - (write $T) - (told) - (see xmTemporary) - (xxmStringRead $XmS $Charset) - (seen) - (set-det))) -; + (= (xxmStringToTerm $S $Charset $T) + (var $T) + (nonvar $S) + (proxtCharPtrToString $S $X1) + (tell xmTemporary) + (write $X1) + (nl) + (told) + (see xmTemporary) + (read $T) + (seen) + (set-det)) + (= (xxmStringToTerm $XmS $Charset $T) + (var $XmS) + (nonvar $T) + (tell xmTemporary) + (write $T) + (told) + (see xmTemporary) + (xxmStringRead $XmS $Charset) + (seen) + (set-det)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: xxmStringRead/2 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +S xmString ; -; - +; * +Charset xmCharset ; -; - +; * ; -; - +; * ; -; - +; * description: Reads a string from current input. ; -; - +; * ; -; - +; ************************************************************************ - (= - (xxmStringRead $S $Charset) - ( (stringRead 100 $S1) - (atom-chars $AS $S1) - (proxtStringToCharPtr $AS $CP) - (xmStringCreateLtoR $CP $Charset $XmS) - (| - (det-if-then - (length $S1 100) - (xxmStringAppendRead $XmS $S $Charset)) - (det-if-then otherwise - (= $S $XmS))) - (set-det))) -; - + (= (xxmStringRead $S $Charset) + (stringRead 100 $S1) + (atom-chars $AS $S1) + (proxtStringToCharPtr $AS $CP) + (xmStringCreateLtoR $CP $Charset $XmS) + (| + (det-if-then + (length $S1 100) + (xxmStringAppendRead $XmS $S $Charset)) + (det-if-then otherwise + (= $S $XmS))) + (set-det)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: xxmStringAppendRead/3 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +S1 xmString, prefix ; -; - +; * +S xmString ; -; - +; * Charset xmCharset ; -; - +; * ; -; - +; * description: Reads an xmString from the current input and appends it ; -; - +; * to S1. ; -; - +; * ; -; - - +; ************************************************************************ - (= - (xxmStringAppendRead $S1 $S $Charset) - ( (stringRead 100 $S2) - (atom-chars $AS $S2) - (proxtStringToCharPtr $AS $CP) - (xmStringCreateLtoR $CP $Charset $XmS) - (xmStringConcat $S1 $XmS $XmS1) - (| - (det-if-then - (length $S2 100) - (xxmStringAppendRead $XmS1 $S $Charset)) - (det-if-then otherwise - (= $S $XmS1))) - (set-det))) -; + (= (xxmStringAppendRead $S1 $S $Charset) + (stringRead 100 $S2) + (atom-chars $AS $S2) + (proxtStringToCharPtr $AS $CP) + (xmStringCreateLtoR $CP $Charset $XmS) + (xmStringConcat $S1 $XmS $XmS1) + (| + (det-if-then + (length $S2 100) + (xxmStringAppendRead $XmS1 $S $Charset)) + (det-if-then otherwise + (= $S $XmS1))) + (set-det)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: stringRead/2 ; -; - +; * ; -; - +; * syntax: stringRead(+N,+S) ; -; - +; * ; -; - +; * description: Reads N characters from the current input. ; -; - +; * ; -; - - +; ************************************************************************ - (= - (stringRead 0 ()) True) -; - - (= - (stringRead $N $S) - ( (get0 $Char) (| (det-if-then (=:= $Char -1) (= $S Nil)) (det-if-then otherwise (, (is $M (- $N 1)) (stringRead $M $S1) (= $S (Cons $Char $S1))))))) -; + (= (stringRead 0 ()) True) + (= (stringRead $N $S) + (get0 $Char) + (| + (det-if-then + (=:= $Char -1) + (= $S Nil)) + (det-if-then otherwise + (, + (is $M + (- $N 1)) + (stringRead $M $S1) + (= $S + (Cons $Char $S1)))))) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: xxmWriteToString/3 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +W writing procedure ; -; - +; * +Charset xmCharset ; -; - +; * -XmS xmString ; -; - +; * ; -; - +; * description: Uses the writing procedure W to generate XmS. ; -; - +; * ; -; +; ************************************************************************ - - (= - (xxmWriteToString $W $Charset $XmS) - ( (tell xmTemporary) - (call $W) - (told) - (see xmTemporary) - (xxmStringRead $XmS $Charset) - (seen) - (set-det))) -; - + (= (xxmWriteToString $W $Charset $XmS) + (tell xmTemporary) + (call $W) + (told) + (see xmTemporary) + (xxmStringRead $XmS $Charset) + (seen) + (set-det)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: xxmWriteToCharPtr/3 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +W writing procedure ; -; - +; * +Charset xmCharset ; -; - +; * -CP xmCharPtr ; -; - +; * ; -; - +; * description: Uses the writing procedure W to generate CP. ; -; - +; * ; -; - +; ************************************************************************ - (= - (xxmWriteToCharPtr $W $CP) - ( (tell xmTemporary) - (call $W) - (told) - (see xmTemporary) - (stringRead 1023 $S) - (seen) - (atom-chars $AS $S) - (proxtStringToCharPtr $AS $CP) - (set-det))) -; - + (= (xxmWriteToCharPtr $W $CP) + (tell xmTemporary) + (call $W) + (told) + (see xmTemporary) + (stringRead 1023 $S) + (seen) + (atom-chars $AS $S) + (proxtStringToCharPtr $AS $CP) + (set-det)) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: isDepth/1 ; -; - +; * ; -; - +; * syntax: isDepth(+D) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: Checks if D is within the range of 1-100. ; -; - +; * ; -; +; ************************************************************************ - - (= - (isDepth $D) + (= (isDepth $D) (| (, (number $D) @@ -8714,47 +6779,33 @@ (writelnError $Message) (set-det) (fail)))) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: isExample/1 ; -; - +; * ; -; - +; * syntax: isExample(+Id) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: checks whether Id specifies an example ; -; - +; * ; -; +; ************************************************************************ - - (= - (isExample $Id) + (= (isExample $Id) (| (get-example $Id $_ $_) (, @@ -8771,47 +6822,33 @@ (writelnError $Message) (set-det) (fail)))) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: isRule ; -; - +; * ; -; - +; * syntax: isRule(+Id) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: checks whether Id specifies a rule ; -; - +; * ; -; +; ************************************************************************ - - (= - (isRule $Id) + (= (isRule $Id) (| (get-clause $Id $_ $_ $_ $_) (, @@ -8828,47 +6865,33 @@ (writelnError $Message) (set-det) (fail)))) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: isExOrRule/1 ; -; - +; * ; -; - +; * syntax: isExOrRule(+Id) ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: checks whether Id specifies a rule or an example ; -; - +; * ; -; +; ************************************************************************ - - (= - (isExOrRule $Id) + (= (isExOrRule $Id) (| (get-clause $Id $_ $_ $_ $_) (| @@ -8886,170 +6909,111 @@ (atom-chars $Message $M3) (writelnError $Message) (fail))))) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: sucheInListe/1 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: +Element term ; -; - +; * +List list of terms ; -; - +; * ; -; - +; * description: searches Element in List ; -; - +; * ; -; - - - - (= - (sucheInListe $A - (Cons $A $_)) True) -; +; ************************************************************************ - (= - (sucheInListe $_ ()) True) -; - (= - (sucheInListe $A - (Cons $_ $Rest)) + (= (sucheInListe $A (Cons $A $_)) True) + (= (sucheInListe $_ ()) True) + (= (sucheInListe $A (Cons $_ $Rest)) (sucheInListe $A $Rest)) -; + (= (writeFullstop $X) + (write $X) + (write .)) - (= - (writeFullstop $X) - ( (write $X) (write .))) -; - - - (= - (true $_) True) -; - + (= (true $_) True) ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: createEvaluationString/1 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: -String list of terms ; -; - +; * ; -; - +; * description: ; -; - +; * ; -; - +; ************************************************************************ - (= - (createEvaluationString $S) + (= (createEvaluationString $S) (det-if-then-else (evaluated no) (= $S '(not evaluated)') (= $S ' (evaluated)'))) -; - ; -; - +; ************************************************************************ ; -; - +; * ; -; - +; * predicate: updateEvaluationLabel/0 ; -; - +; * ; -; - +; * syntax: ; -; - +; * ; -; - +; * args: ; -; - +; * ; -; - +; * description: updates the label that indicates whether the kb is ; -; - +; * evaluated ; -; - +; * ; -; - - +; ************************************************************************ - (= - (updateEvaluationLabel) - ( (recorded irene $Widget $_) - (createEvaluationString $S) - (proxtGetDefaultCharset $DCharset) - (proxtStringToCharPtr $S $ACP) - (xmStringCreate $ACP $DCharset $AXmS) - (xtSetValues $Widget - (:: (xmNlabelString $AXmS))))) -; + (= (updateEvaluationLabel) + (recorded irene $Widget $_) + (createEvaluationString $S) + (proxtGetDefaultCharset $DCharset) + (proxtStringToCharPtr $S $ACP) + (xmStringCreate $ACP $DCharset $AXmS) + (xtSetValues $Widget + (:: (xmNlabelString $AXmS)))) diff --git a/miles/xmiles_functions.metta b/miles/xmiles_functions.metta index c56ef2a..7d597d6 100644 --- a/miles/xmiles_functions.metta +++ b/miles/xmiles_functions.metta @@ -1,423 +1,132 @@ +; (convert_to_metta_file xmiles_functions $_290964 miles/xmiles_functions.pl miles/xmiles_functions.metta) ; -; - +; ****************************************************************************** ; -; - +; * ; -; - +; * ; -; - +; * This file describes the learning operators of miles called by xmiles ; -; - +; * when a specific button is pressed ; -; - +; * ; -; - +; * ; -; - +; ****************************************************************************** ; -; - +; ****************************************************************************** ; -; - +; * ; -; - +; * groups(). ; -; - +; * ; -; +; ****************************************************************************** - - (= - (groups - (preprocess g1 g2 gencon lgg refinement evaluation truncation)) True) -; - + (= (groups (preprocess g1 g2 gencon lgg refinement evaluation truncation)) True) ; -; - +; ****************************************************************************** ; -; - +; * ; -; - +; * groupdef(,). ; -; - +; * ; -; - - +; ****************************************************************************** - (= - (groupdef preprocess - ('argument types' 'clause heads' 'flatten kb' 'flatten rules' 'unflatten kb')) True) -; - - (= - (groupdef g1 - ('g1 op' 'apply g1' identify absorb 'inv derivate' 'most spec v' saturate 'elem saturate')) True) -; - - (= - (groupdef g2 - ('intraconstruct 1' 'intraconstruct 2' 'g2 op' 'apply g2')) True) -; - - (= - (groupdef gencon - ('learn constrained' 'learn foil' 'learn rul')) True) -; - - (= - (groupdef lgg - ('gen msg' rlgg lgg 'headed lgg' 'nr lgg' gti)) True) -; - - (= - (groupdef refinement - ('unify vars' 'instantiate vars' 'add body lit' 'new predicate')) True) -; - - (= - (groupdef evaluation - ('correct check' 'complete check' 'evaluate examples' fp 'covered examples')) True) -; - - (= - (groupdef truncation - (reduce unconnected redundant 'flat redundant' unconnecting 'negation based' 'flat negation based' facts)) True) -; + (= (groupdef preprocess ('argument types' 'clause heads' 'flatten kb' 'flatten rules' 'unflatten kb')) True) + (= (groupdef g1 ('g1 op' 'apply g1' identify absorb 'inv derivate' 'most spec v' saturate 'elem saturate')) True) + (= (groupdef g2 ('intraconstruct 1' 'intraconstruct 2' 'g2 op' 'apply g2')) True) + (= (groupdef gencon ('learn constrained' 'learn foil' 'learn rul')) True) + (= (groupdef lgg ('gen msg' rlgg lgg 'headed lgg' 'nr lgg' gti)) True) + (= (groupdef refinement ('unify vars' 'instantiate vars' 'add body lit' 'new predicate')) True) + (= (groupdef evaluation ('correct check' 'complete check' 'evaluate examples' fp 'covered examples')) True) + (= (groupdef truncation (reduce unconnected redundant 'flat redundant' unconnecting 'negation based' 'flat negation based' facts)) True) ; -; - +; ****************************************************************************** ; -; - +; * ; -; - +; * operatordef(,,, ; -; - +; * ,, ; -; - +; * ,). ; -; - +; * ; -; - - - - (= - (operatordef 'argument types' argument_types () () () - (rules)) True) -; - - (= - (operatordef 'clause heads' clause_heads () () () - (rules)) True) -; - - (= - (operatordef 'flatten kb' flatten_kb () () () - (rules)) True) -; - - (= - (operatordef 'flatten rules' flatten_rules () () () - (rules)) True) -; - - (= - (operatordef 'unflatten kb' unflatten_kb () () () - (rules)) True) -; - - - (= - (operatordef 'g1 op' g1_op - (xmarg1 xmarg2 xmout1) - (isRule isRule) - (resultAddRule) ()) True) -; - - (= - (operatordef 'apply g1' apply_g1 - (xmarg1 xmout1) - (isRule) - (resultAddRuleList) ()) True) -; - - (= - (operatordef identify identify - (xmarg1 xmarg2 xmout1) - (isExOrRule true) - (resultAddRule) ()) True) -; - - (= - (operatordef absorb absorb - (xmarg1 xmarg2 xmout1) - (isExOrRule isExOrRule) - (resultAddRule) ()) True) -; - - - (= - (operatordef 'inv derivate' inv_derivate - (xmarg1 xmout1) - (isExOrRule) - (resultAddRule) ()) True) -; - - (= - (operatordef 'most spec v' most_spec_v - (xmarg1 xmarg2 xmout1) - (isExOrRule isExOrRule) - (resultAddRule) ()) True) -; - - (= - (operatordef saturate saturate - (xmarg1 xmout1 xmoptdepth) - (isExOrRule isDepth) - (resultAddRule) ()) True) -; - - (= - (operatordef 'elem saturate' elem_saturate - (xmarg1 xmarg2 xmout1) - (isExOrRule true) - (resultAddRule) ()) True) -; - - - (= - (operatordef 'intraconstruct 1' intra_construct1 - (xmarg1 xmarg2 xmout1 xmout2 xmout3) - (isRule isRule) - (resultAddRule resultAddRule resultAddRule) ()) True) -; - - (= - (operatordef 'intraconstruct 2' intra_construct2 - (xmarg1 xmarg2 xmout1 xmout2 xmout3) - (isRule isRule) - (resultAddRule resultAddRule resultAddRule) ()) True) -; - - (= - (operatordef 'g2 op' g2_op - (xmarg1 xmarg2 xmout1 xmout2 xmout3) - (isRule isRule) - (resultAddRule resultAddRule resultAddRule) ()) True) -; - - (= - (operatordef 'apply g2' apply_g2 - (xmarg1 xmarg2 xmout1 xmout2 xmout3) - (isRule isRule) - (resultAddRule resultAddRule resultAddRule) ()) True) -; - - - (= - (operatordef 'learn constrained' learn_constrained () () () - (rules)) True) -; - - (= - (operatordef 'learn foil' learn_foil () () () - (rules)) True) -; - - (= - (operatordef 'learn rul' learn_rul () () () - (rules)) True) -; - - - - (= - (operatordef 'gen msg' gen_msg - (xmarg1 xmarg2 xmout1) - (isRule isRule) - (resultAddRule) ()) True) -; - - (= - (operatordef rlgg rlgg - (xmarg1 xmarg2 xmout1) - (isRule isRule) - (resultAddRule) ()) True) -; - - (= - (operatordef lgg lgg - (xmarg1 xmarg2 xmout1) - (isRule isRule) - (resultAddRule) ()) True) -; - - (= - (operatordef 'headed lgg' headed_lgg - (xmarg1 xmarg2 xmout1) - (isRule true) - (resultAddRule) ()) True) -; - - (= - (operatordef 'nr lgg' nr_lgg - (xmarg1 xmarg2 xmout1) - (isRule isRule) - (resultAddRule) ()) True) -; - - (= - (operatordef gti gti - (xmarg1 xmarg2 xmout1) - (isRule isRule) - (resultAddRule) ()) True) -; - - - (= - (operatordef 'unify vars' refinement_unify_variables - (xmarg1 xmout1) - (isRule) - (resultAddSpec) ()) True) -; - - (= - (operatordef 'instantiate vars' refinement_instantiate_variables - (xmarg1 xmout1) - (isRule) - (resultAddSpec) ()) True) -; - - (= - (operatordef 'add body lit' refinement_add_body_literal - (xmarg1 xmout1) - (isRule) - (resultAddSpec) ()) True) -; - - (= - (operatordef 'new predicate' specialize_with_newpred - (xmarg1 xmout1) - (isRule) - (resultAddNewpreds) ()) True) -; - - - (= - (operatordef 'correct check' correct_chk () () () ()) True) -; - - (= - (operatordef 'complete check' complete_chk () () () ()) True) -; - - (= - (operatordef 'evaluate examples' eval_examples () () () ()) True) -; - - (= - (operatordef fp fp - (xmout1) () - (resultSelectRules) ()) True) -; +; ****************************************************************************** - (= - (operatordef 'covered examples' all_covered_examples - (xmout1) () - (resultSelectExamples) ()) True) -; + (= (operatordef 'argument types' argument_types () () () (rules)) True) + (= (operatordef 'clause heads' clause_heads () () () (rules)) True) + (= (operatordef 'flatten kb' flatten_kb () () () (rules)) True) + (= (operatordef 'flatten rules' flatten_rules () () () (rules)) True) + (= (operatordef 'unflatten kb' unflatten_kb () () () (rules)) True) - (= - (operatordef reduce reduce_complete - (xmarg1) - (isRule) () - (rules)) True) -; + (= (operatordef 'g1 op' g1_op (xmarg1 xmarg2 xmout1) (isRule isRule) (resultAddRule) ()) True) + (= (operatordef 'apply g1' apply_g1 (xmarg1 xmout1) (isRule) (resultAddRuleList) ()) True) + (= (operatordef identify identify (xmarg1 xmarg2 xmout1) (isExOrRule true) (resultAddRule) ()) True) + (= (operatordef absorb absorb (xmarg1 xmarg2 xmout1) (isExOrRule isExOrRule) (resultAddRule) ()) True) - (= - (operatordef unconnected truncate_unconnected - (xmarg1) - (isRule) () - (rules)) True) -; + (= (operatordef 'inv derivate' inv_derivate (xmarg1 xmout1) (isExOrRule) (resultAddRule) ()) True) + (= (operatordef 'most spec v' most_spec_v (xmarg1 xmarg2 xmout1) (isExOrRule isExOrRule) (resultAddRule) ()) True) + (= (operatordef saturate saturate (xmarg1 xmout1 xmoptdepth) (isExOrRule isDepth) (resultAddRule) ()) True) + (= (operatordef 'elem saturate' elem_saturate (xmarg1 xmarg2 xmout1) (isExOrRule true) (resultAddRule) ()) True) - (= - (operatordef redundant truncate_r - (xmarg1) - (isRule) () - (rules)) True) -; + (= (operatordef 'intraconstruct 1' intra_construct1 (xmarg1 xmarg2 xmout1 xmout2 xmout3) (isRule isRule) (resultAddRule resultAddRule resultAddRule) ()) True) + (= (operatordef 'intraconstruct 2' intra_construct2 (xmarg1 xmarg2 xmout1 xmout2 xmout3) (isRule isRule) (resultAddRule resultAddRule resultAddRule) ()) True) + (= (operatordef 'g2 op' g2_op (xmarg1 xmarg2 xmout1 xmout2 xmout3) (isRule isRule) (resultAddRule resultAddRule resultAddRule) ()) True) + (= (operatordef 'apply g2' apply_g2 (xmarg1 xmarg2 xmout1 xmout2 xmout3) (isRule isRule) (resultAddRule resultAddRule resultAddRule) ()) True) - (= - (operatordef 'flat redundant' truncate_flat_r - (xmarg1) - (isRule) () - (rules)) True) -; + (= (operatordef 'learn constrained' learn_constrained () () () (rules)) True) + (= (operatordef 'learn foil' learn_foil () () () (rules)) True) + (= (operatordef 'learn rul' learn_rul () () () (rules)) True) - (= - (operatordef unconnecting truncate_unconnecting - (xmarg1) - (isRule) () - (rules)) True) -; - (= - (operatordef 'negation based' truncate_neg_based - (xmarg1) - (isRule) () - (rules)) True) -; + (= (operatordef 'gen msg' gen_msg (xmarg1 xmarg2 xmout1) (isRule isRule) (resultAddRule) ()) True) + (= (operatordef rlgg rlgg (xmarg1 xmarg2 xmout1) (isRule isRule) (resultAddRule) ()) True) + (= (operatordef lgg lgg (xmarg1 xmarg2 xmout1) (isRule isRule) (resultAddRule) ()) True) + (= (operatordef 'headed lgg' headed_lgg (xmarg1 xmarg2 xmout1) (isRule true) (resultAddRule) ()) True) + (= (operatordef 'nr lgg' nr_lgg (xmarg1 xmarg2 xmout1) (isRule isRule) (resultAddRule) ()) True) + (= (operatordef gti gti (xmarg1 xmarg2 xmout1) (isRule isRule) (resultAddRule) ()) True) - (= - (operatordef 'flat negation based' truncate_flat_neg_based - (xmarg1) - (isRule) () - (rules)) True) -; + (= (operatordef 'unify vars' refinement_unify_variables (xmarg1 xmout1) (isRule) (resultAddSpec) ()) True) + (= (operatordef 'instantiate vars' refinement_instantiate_variables (xmarg1 xmout1) (isRule) (resultAddSpec) ()) True) + (= (operatordef 'add body lit' refinement_add_body_literal (xmarg1 xmout1) (isRule) (resultAddSpec) ()) True) + (= (operatordef 'new predicate' specialize_with_newpred (xmarg1 xmout1) (isRule) (resultAddNewpreds) ()) True) - (= - (operatordef facts truncate_facts - (xmarg1) - (isRule) () - (rules)) True) -; + (= (operatordef 'correct check' correct_chk () () () ()) True) + (= (operatordef 'complete check' complete_chk () () () ()) True) + (= (operatordef 'evaluate examples' eval_examples () () () ()) True) + (= (operatordef fp fp (xmout1) () (resultSelectRules) ()) True) + (= (operatordef 'covered examples' all_covered_examples (xmout1) () (resultSelectExamples) ()) True) + (= (operatordef reduce reduce_complete (xmarg1) (isRule) () (rules)) True) + (= (operatordef unconnected truncate_unconnected (xmarg1) (isRule) () (rules)) True) + (= (operatordef redundant truncate_r (xmarg1) (isRule) () (rules)) True) + (= (operatordef 'flat redundant' truncate_flat_r (xmarg1) (isRule) () (rules)) True) + (= (operatordef unconnecting truncate_unconnecting (xmarg1) (isRule) () (rules)) True) + (= (operatordef 'negation based' truncate_neg_based (xmarg1) (isRule) () (rules)) True) + (= (operatordef 'flat negation based' truncate_flat_neg_based (xmarg1) (isRule) () (rules)) True) + (= (operatordef facts truncate_facts (xmarg1) (isRule) () (rules)) True) diff --git a/multagnt/calls_1.metta b/multagnt/calls_1.metta index b3644f6..d87c21d 100644 --- a/multagnt/calls_1.metta +++ b/multagnt/calls_1.metta @@ -1,253 +1,43 @@ - - (= - (?- - (teacher)) True) -; - - (= - (?- - (learner1)) True) -; - - - (= - (?- - (demo - (: teacher gilchrist_family) - (parent warren david) $L)) True) -; - - (= - (?- - (demo - (: teacher gilchrist_family) - (parent charles julia) $L)) True) -; - - (= - (?- - (demo - (: teacher gilchrist_family) - (parent warren - (variable a)) $L)) True) -; - - (= - (?- - (demo - (: teacher gilchrist_family) - (parent - (variable parent) - (variable child)) $L)) True) -; - - - (= - (?- - (demo - (: teacher entropy) - (entropy_increases kitchen fridge) $L)) True) -; - - (= - (?- - (demo - (: teacher entropy) - (entropy_increases kitchen living_room) $L)) True) -; - - (= - (?- - (demo - (: teacher entropy) - (entropy_increases - (variable a) - (variable b)) $L)) True) -; - - - (= - (?- - (demo - (: teacher t_member) - (member a - (a b c)) $L)) True) -; - - (= - (?- - (demo - (: teacher t_member) - (member b - (a b c)) $L)) True) -; - - (= - (?- - (demo - (: teacher t_member) - (member e - (q w e r t z t r e w q)) $L)) True) -; - - (= - (?- - (demo - (: teacher t_member) - (member o - (q w e r t z t r e w q)) $L)) True) -; - - (= - (?- - (demo - (: teacher t_member) - (member - (variable a) - (a b c)) $L)) True) -; - - (= - (?- - (demo - (: teacher t_member) - (member - (variable a) - (variable list)) $L)) True) -; - - (= - (?- - (demo - (: teacher t_member) - (member a - (variable list)) $L)) True) -; - - - (= - (?- - (demo - (: teacher t_reverse) - (reverse - (a b c) - (c b a)) $L)) True) -; - - (= - (?- - (demo - (: teacher t_reverse) - (reverse - (b a c) - (c b a)) $L)) True) -; - - (= - (?- - (demo - (: teacher t_reverse) - (reverse - (variable a) - (c b a)) $L)) True) -; - - - (= - (?- - (can_do $Tl $Tt - (parent warren david) $C)) True) -; - - (= - (?- - (can_do $Tl $Tt - (parent charles julia) $C)) True) -; - - (= - (?- - (can_do $Tl $Tt - (parent - (variable parent) - (variable child)) $C)) True) -; - - - (= - (?- - (demo $Tl $Tt - (entropy_increases kitchen fridge) $C)) True) -; - - (= - (?- - (can_do $Tl $Tt - (entropy_increases kitchen fridge) $C)) True) -; - - (= - (?- - (can_do $Tl $Tt - (entropy_increases - (variable a) - (variable b)) $C)) True) -; - - - (= - (?- - (can_do $Tl $Tt - (member a - (g f d s a)) $C)) True) -; - - (= - (?- - (can_do $Tl $Tt - (member e - (q w e r t z t r e w q)) $C)) True) -; - - (= - (?- - (can_do $Tl $Tt - (member - (variable a) - (g f d s a)) $C)) True) -; - - (= - (?- - (can_do $Tl $Tt - (member - (variable a) - (variable list)) $C)) True) -; - - - (= - (?- - (can_do $Tl $Tt - (reverse - (a b c) - (c b a)) $C)) True) -; - - (= - (?- - (can_do $Tl $Tt - (reverse - (b a c) - (c b a)) $C)) True) -; - - (= - (?- - (can_do $Tl $Tt - (reverse - (variable c) - (c b a)) $C)) True) -; - +; (convert_to_metta_file calls_1 $_398852 multagnt/calls_1.pl multagnt/calls_1.metta) + + (= (?- (teacher)) True) + (= (?- (learner1)) True) + + (= (?- (demo (: teacher gilchrist_family) (parent warren david) $L)) True) + (= (?- (demo (: teacher gilchrist_family) (parent charles julia) $L)) True) + (= (?- (demo (: teacher gilchrist_family) (parent warren (variable a)) $L)) True) + (= (?- (demo (: teacher gilchrist_family) (parent (variable parent) (variable child)) $L)) True) + + (= (?- (demo (: teacher entropy) (entropy_increases kitchen fridge) $L)) True) + (= (?- (demo (: teacher entropy) (entropy_increases kitchen living_room) $L)) True) + (= (?- (demo (: teacher entropy) (entropy_increases (variable a) (variable b)) $L)) True) + + (= (?- (demo (: teacher t_member) (member a (a b c)) $L)) True) + (= (?- (demo (: teacher t_member) (member b (a b c)) $L)) True) + (= (?- (demo (: teacher t_member) (member e (q w e r t z t r e w q)) $L)) True) + (= (?- (demo (: teacher t_member) (member o (q w e r t z t r e w q)) $L)) True) + (= (?- (demo (: teacher t_member) (member (variable a) (a b c)) $L)) True) + (= (?- (demo (: teacher t_member) (member (variable a) (variable list)) $L)) True) + (= (?- (demo (: teacher t_member) (member a (variable list)) $L)) True) + + (= (?- (demo (: teacher t_reverse) (reverse (a b c) (c b a)) $L)) True) + (= (?- (demo (: teacher t_reverse) (reverse (b a c) (c b a)) $L)) True) + (= (?- (demo (: teacher t_reverse) (reverse (variable a) (c b a)) $L)) True) + + (= (?- (can_do $Tl $Tt (parent warren david) $C)) True) + (= (?- (can_do $Tl $Tt (parent charles julia) $C)) True) + (= (?- (can_do $Tl $Tt (parent (variable parent) (variable child)) $C)) True) + + (= (?- (demo $Tl $Tt (entropy_increases kitchen fridge) $C)) True) + (= (?- (can_do $Tl $Tt (entropy_increases kitchen fridge) $C)) True) + (= (?- (can_do $Tl $Tt (entropy_increases (variable a) (variable b)) $C)) True) + + (= (?- (can_do $Tl $Tt (member a (g f d s a)) $C)) True) + (= (?- (can_do $Tl $Tt (member e (q w e r t z t r e w q)) $C)) True) + (= (?- (can_do $Tl $Tt (member (variable a) (g f d s a)) $C)) True) + (= (?- (can_do $Tl $Tt (member (variable a) (variable list)) $C)) True) + + (= (?- (can_do $Tl $Tt (reverse (a b c) (c b a)) $C)) True) + (= (?- (can_do $Tl $Tt (reverse (b a c) (c b a)) $C)) True) + (= (?- (can_do $Tl $Tt (reverse (variable c) (c b a)) $C)) True) diff --git a/multagnt/calls_2.metta b/multagnt/calls_2.metta index 8db825f..434657a 100644 --- a/multagnt/calls_2.metta +++ b/multagnt/calls_2.metta @@ -1,139 +1,25 @@ - (= - (?- - (teacher)) True) -; - - (= - (?- - (learner2)) True) -; - - - (= - (?- - (cannot_do $Tl $Tt - (parent warren catherine) $C)) True) -; - - (= - (?- - (cannot_do $Tl $Tt - (parent warren david) $C)) True) -; - - (= - (?- - (cannot_do $Tl $Tt - (parent warren - (variable child)) $C)) True) -; - - (= - (?- - (can_do $Tl $Tt - (parent - (variable parent) - (variable child)) $C)) True) -; - - - (= - (?- - (cannot_do $Tl $Tt - (entropy_increases - (variable a) - (variable b)) $C)) True) -; - - - (= - (?- - (cannot_do $Tl $Tt - (t_member f - (g f d s a)) $C)) True) -; - - (= - (?- - (cannot_do $Tl $Tt - (t_member e - (q w e r t z t r e w q)) $C)) True) -; - - (= - (?- - (cannot_do $Tl $Tt - (t_member - (variable a) - (g f d s a)) $C)) True) -; - - (= - (?- - (can_do $Tl $Tt - (t_member - (variable a) - (variable list)) $C)) True) -; - - - (= - (?- - (cannot_do $Tl $Tt - (reverse - (c b a) - (variable c)) $C)) True) -; - - (= - (?- - (cannot_do $Tl $Tt - (reverse - (a b c) - (c b a)) $C)) True) -; - - - (= - (?- - (what_cannot_do $Ls $Ts - (<- $Q $Ans) () $F)) True) -; - - (= - (?- - (what_cannot_do $Ls $Ts - (<- - (qsort - (1 2) - (variable a)) $Ans) () $F)) True) -; - - (= - (?- - (what_cannot_do $Ls $Ts - (<- - (qsort - (2 1) - (variable a)) $Ans) () $F)) True) -; - - (= - (?- - (what_cannot_do $Ls $Ts - (<- - (qsort - (2 3 1) - (variable a)) $Ans) () $F)) True) -; - - (= - (?- - (what_cannot_do $Ls $Ts - (<- - (qsort - (3 2 1) - (variable a)) $Ans) () $F)) True) -; - +; (convert_to_metta_file calls_2 $_478044 multagnt/calls_2.pl multagnt/calls_2.metta) + (= (?- (teacher)) True) + (= (?- (learner2)) True) + + (= (?- (cannot_do $Tl $Tt (parent warren catherine) $C)) True) + (= (?- (cannot_do $Tl $Tt (parent warren david) $C)) True) + (= (?- (cannot_do $Tl $Tt (parent warren (variable child)) $C)) True) + (= (?- (can_do $Tl $Tt (parent (variable parent) (variable child)) $C)) True) + + (= (?- (cannot_do $Tl $Tt (entropy_increases (variable a) (variable b)) $C)) True) + + (= (?- (cannot_do $Tl $Tt (t_member f (g f d s a)) $C)) True) + (= (?- (cannot_do $Tl $Tt (t_member e (q w e r t z t r e w q)) $C)) True) + (= (?- (cannot_do $Tl $Tt (t_member (variable a) (g f d s a)) $C)) True) + (= (?- (can_do $Tl $Tt (t_member (variable a) (variable list)) $C)) True) + + (= (?- (cannot_do $Tl $Tt (reverse (c b a) (variable c)) $C)) True) + (= (?- (cannot_do $Tl $Tt (reverse (a b c) (c b a)) $C)) True) + + (= (?- (what_cannot_do $Ls $Ts (<- $Q $Ans) () $F)) True) + (= (?- (what_cannot_do $Ls $Ts (<- (qsort (1 2) (variable a)) $Ans) () $F)) True) + (= (?- (what_cannot_do $Ls $Ts (<- (qsort (2 1) (variable a)) $Ans) () $F)) True) + (= (?- (what_cannot_do $Ls $Ts (<- (qsort (2 3 1) (variable a)) $Ans) () $F)) True) + (= (?- (what_cannot_do $Ls $Ts (<- (qsort (3 2 1) (variable a)) $Ans) () $F)) True) diff --git a/multagnt/learner1.metta b/multagnt/learner1.metta index e3c6bed..a7e9247 100644 --- a/multagnt/learner1.metta +++ b/multagnt/learner1.metta @@ -1,304 +1,67 @@ +; (convert_to_metta_file learner1 $_54592 multagnt/learner1.pl multagnt/learner1.metta) ; -; - +; Right knowledge of a learner about different topics ; -; - - - - (= - (db_entry - (: learner gilchrist_family) - (parent euan warren) ()) True) -; - - (= - (db_entry - (: learner gilchrist_family) - (parent berenice warren) ()) True) -; - - (= - (db_entry - (: learner gilchrist_family) - (parent warren catherine) ()) True) -; - - (= - (db_entry - (: learner gilchrist_family) - (parent warren charles) ()) True) -; - - (= - (db_entry - (: learner gilchrist_family) - (parent warren david) ()) True) -; - - (= - (db_entry - (: learner gilchrist_family) - (parent warren julia) ()) True) -; - - (= - (db_entry - (: learner gilchrist_family) - (parent kate catherine) ()) True) -; - - (= - (db_entry - (: learner gilchrist_family) - (parent kate charles) ()) True) -; - - (= - (db_entry - (: learner gilchrist_family) - (parent kate david) ()) True) -; +; Fact theory - (= - (db_entry - (: learner gilchrist_family) - (parent kate julia) ()) True) -; - - (= - (db_entry - (: learner gilchrist_family) - (parent charles lucinda) ()) True) -; + (= (db_entry (: learner gilchrist_family) (parent euan warren) ()) True) + (= (db_entry (: learner gilchrist_family) (parent berenice warren) ()) True) + (= (db_entry (: learner gilchrist_family) (parent warren catherine) ()) True) + (= (db_entry (: learner gilchrist_family) (parent warren charles) ()) True) + (= (db_entry (: learner gilchrist_family) (parent warren david) ()) True) + (= (db_entry (: learner gilchrist_family) (parent warren julia) ()) True) + (= (db_entry (: learner gilchrist_family) (parent kate catherine) ()) True) + (= (db_entry (: learner gilchrist_family) (parent kate charles) ()) True) + (= (db_entry (: learner gilchrist_family) (parent kate david) ()) True) + (= (db_entry (: learner gilchrist_family) (parent kate julia) ()) True) + (= (db_entry (: learner gilchrist_family) (parent charles lucinda) ()) True) ; -; - - - - (= - (def_theory - (: learner entropy) - ( (: learner warm) - (: learner cold) - (: learner door))) True) -; - - - (= - (db_entry - (: learner warm) - (warm kitchen) ()) True) -; - - (= - (db_entry - (: learner warm) - (warm living_room) ()) True) -; - - (= - (db_entry - (: learner cold) - (cold fridge) ()) True) -; - - (= - (db_entry - (: learner cold) - (cold street) ()) True) -; - - (= - (db_entry - (: learner cold) - (cold garden) ()) True) -; - - (= - (db_entry - (: learner door) - (door living_room kitchen) ()) True) -; - - (= - (db_entry - (: learner door) - (door living_room street) ()) True) -; - - (= - (db_entry - (: learner door) - (door living_room garden) ()) True) -; - - (= - (db_entry - (: learner door) - (door kitchen garden) ()) True) -; - - (= - (db_entry - (: learner door) - (door kitchen fridge) ()) True) -; - - (= - (db_entry - (: learner door) - (door street garden) ()) True) -; - - (= - (db_entry - (: learner entropy) - (entropy_increases $A $B) - ( (warm $A) - (cold $B) - (door $A $B))) True) -; - - (= - (db_entry - (: learner entropy) - (entropy_increases $A $B) - ( (cold $A) - (warm $B) - (door $A $B))) True) -; - - (= - (db_entry - (: learner entropy) - (entropy_increases $A $B) - ( (warm $A) - (cold $B) - (door $B $A))) True) -; - - (= - (db_entry - (: learner entropy) - (entropy_increases $A $B) - ( (cold $A) - (warm $B) - (door $B $A))) True) -; - +; Fact and Rule Theory + + + (= (def_theory (: learner entropy) ((: learner warm) (: learner cold) (: learner door))) True) + + (= (db_entry (: learner warm) (warm kitchen) ()) True) + (= (db_entry (: learner warm) (warm living_room) ()) True) + (= (db_entry (: learner cold) (cold fridge) ()) True) + (= (db_entry (: learner cold) (cold street) ()) True) + (= (db_entry (: learner cold) (cold garden) ()) True) + (= (db_entry (: learner door) (door living_room kitchen) ()) True) + (= (db_entry (: learner door) (door living_room street) ()) True) + (= (db_entry (: learner door) (door living_room garden) ()) True) + (= (db_entry (: learner door) (door kitchen garden) ()) True) + (= (db_entry (: learner door) (door kitchen fridge) ()) True) + (= (db_entry (: learner door) (door street garden) ()) True) + (= (db_entry (: learner entropy) (entropy_increases $A $B) ((warm $A) (cold $B) (door $A $B))) True) + (= (db_entry (: learner entropy) (entropy_increases $A $B) ((cold $A) (warm $B) (door $A $B))) True) + (= (db_entry (: learner entropy) (entropy_increases $A $B) ((warm $A) (cold $B) (door $B $A))) True) + (= (db_entry (: learner entropy) (entropy_increases $A $B) ((cold $A) (warm $B) (door $B $A))) True) ; -; - - - (= - (db_entry - (: learner t_member) - (member $A - (Cons $A $_)) ()) True) -; - - (= - (db_entry - (: learner t_member) - (member $A - (Cons $_ $B)) - ( (member $A $B))) True) -; - - - (= - (db_entry - (: learner t_append) - (append () $List $List) ()) True) -; - - (= - (db_entry - (: learner t_append) - (append - (Cons $First $Rest) $List - (Cons $First $TempList)) - ( (append $Rest $List $TempList))) True) -; - - - - (= - (def_theory - (: learner t_reverse) - ( (: learner t_append))) True) -; - - - (= - (db_entry - (: learner t_reverse) - (reverse () ()) ()) True) -; - - (= - (db_entry - (: learner t_reverse) - (reverse - (Cons $X $Y) $Z) - ( (reverse $Y $Y1) (append $Y1 ($X) $Z))) True) -; - - +; Recusive Theory - (= - (def_theory - (: learner qsort) - ( (: learner partition) (: learner t_append))) True) -; + (= (db_entry (: learner t_member) (member $A (Cons $A $_)) ()) True) + (= (db_entry (: learner t_member) (member $A (Cons $_ $B)) ((member $A $B))) True) + (= (db_entry (: learner t_append) (append () $List $List) ()) True) + (= (db_entry (: learner t_append) (append (Cons $First $Rest) $List (Cons $First $TempList)) ((append $Rest $List $TempList))) True) - (= - (db_entry - (: learner qsort) - (qsort () ()) ()) True) -; - (= - (db_entry - (: learner qsort) - (qsort - (Cons $X $L) $L5) - ( (partition $L $X $L1 $L2) - (qsort $L1 $L3) - (qsort $L2 $L4) - (append $L3 - (Cons $X $L4) $L5))) True) -; + (= (def_theory (: learner t_reverse) ((: learner t_append))) True) + (= (db_entry (: learner t_reverse) (reverse () ()) ()) True) + (= (db_entry (: learner t_reverse) (reverse (Cons $X $Y) $Z) ((reverse $Y $Y1) (append $Y1 ($X) $Z))) True) - (= - (db_entry - (: learner partition) - (partition () $_ () ()) ()) True) -; - (= - (db_entry - (: learner partition) - (partition - (Cons $X $L) $Y - (Cons $X $L1) $L2) - ( (< $X $Y) (partition $L $Y $L1 $L2))) True) -; + (= (def_theory (: learner qsort) ((: learner partition) (: learner t_append))) True) - (= - (db_entry - (: learner partition) - (partition - (Cons $X $L) $Y $L1 - (Cons $X $L2)) - ( (>= $X $Y) (partition $L $Y $L1 $L2))) True) -; + (= (db_entry (: learner qsort) (qsort () ()) ()) True) + (= (db_entry (: learner qsort) (qsort (Cons $X $L) $L5) ((partition $L $X $L1 $L2) (qsort $L1 $L3) (qsort $L2 $L4) (append $L3 (Cons $X $L4) $L5))) True) + (= (db_entry (: learner partition) (partition () $_ () ()) ()) True) + (= (db_entry (: learner partition) (partition (Cons $X $L) $Y (Cons $X $L1) $L2) ((< $X $Y) (partition $L $Y $L1 $L2))) True) + (= (db_entry (: learner partition) (partition (Cons $X $L) $Y $L1 (Cons $X $L2)) ((>= $X $Y) (partition $L $Y $L1 $L2))) True) diff --git a/multagnt/learner2.metta b/multagnt/learner2.metta index b11bd92..1b4f387 100644 --- a/multagnt/learner2.metta +++ b/multagnt/learner2.metta @@ -1,364 +1,106 @@ +; (convert_to_metta_file learner2 $_140198 multagnt/learner2.pl multagnt/learner2.metta) ; -; - +; Wrong knowledge of a learner about different topics ; -; - +; Differences to Learner1 are enclosed in comments ; -; - - - (= - (db_entry - (: learner gilchrist_family) - (parent euan warren) ()) True) -; - - (= - (db_entry - (: learner gilchrist_family) - (parent berenice warren) ()) True) -; +; Fact theory + (= (db_entry (: learner gilchrist_family) (parent euan warren) ()) True) + (= (db_entry (: learner gilchrist_family) (parent berenice warren) ()) True) ; ; - ; -; - +; db_entry(learner:gilchrist_family,parent(warren,catherine),[]). ; ; - - (= - (db_entry - (: learner gilchrist_family) - (parent warren charles) ()) True) -; - - (= - (db_entry - (: learner gilchrist_family) - (parent warren david) ()) True) -; - - (= - (db_entry - (: learner gilchrist_family) - (parent warren julia) ()) True) -; - - (= - (db_entry - (: learner gilchrist_family) - (parent kate catherine) ()) True) -; - - (= - (db_entry - (: learner gilchrist_family) - (parent kate charles) ()) True) -; - - (= - (db_entry - (: learner gilchrist_family) - (parent kate david) ()) True) -; - - (= - (db_entry - (: learner gilchrist_family) - (parent kate julia) ()) True) -; - + (= (db_entry (: learner gilchrist_family) (parent warren charles) ()) True) + (= (db_entry (: learner gilchrist_family) (parent warren david) ()) True) + (= (db_entry (: learner gilchrist_family) (parent warren julia) ()) True) + (= (db_entry (: learner gilchrist_family) (parent kate catherine) ()) True) + (= (db_entry (: learner gilchrist_family) (parent kate charles) ()) True) + (= (db_entry (: learner gilchrist_family) (parent kate david) ()) True) + (= (db_entry (: learner gilchrist_family) (parent kate julia) ()) True) ; ; - ; -; - +; db_entry(learner:gilchrist_family,parent(charles,lucinda),[]). ; ; - ; -; - +; Fact and Rule Theory - (= - (def_theory - (: learner entropy) - ( (: learner warm) - (: learner cold) - (: learner door))) True) -; - - - (= - (db_entry - (: learner warm) - (warm living_room) ()) True) -; - - (= - (db_entry - (: learner warm) - (warm kitchen) ()) True) -; - - (= - (db_entry - (: learner cold) - (cold street) ()) True) -; - - (= - (db_entry - (: learner cold) - (cold garden) ()) True) -; - - (= - (db_entry - (: learner cold) - (cold fridge) ()) True) -; + (= (def_theory (: learner entropy) ((: learner warm) (: learner cold) (: learner door))) True) + (= (db_entry (: learner warm) (warm living_room) ()) True) + (= (db_entry (: learner warm) (warm kitchen) ()) True) + (= (db_entry (: learner cold) (cold street) ()) True) + (= (db_entry (: learner cold) (cold garden) ()) True) + (= (db_entry (: learner cold) (cold fridge) ()) True) ; ; - ; -; - +; The following entries are incorrect ; ; - - (= - (db_entry - (: learner door) - (door a_living_room a_kitchen) ()) True) -; - - (= - (db_entry - (: learner door) - (door a_living_room a_street) ()) True) -; - - (= - (db_entry - (: learner door) - (door a_living_room a_garden) ()) True) -; - - (= - (db_entry - (: learner door) - (door a_kitchen a_garden) ()) True) -; - - (= - (db_entry - (: learner door) - (door a_kitchen a_fridge) ()) True) -; - - (= - (db_entry - (: learner door) - (door a_street a_garden) ()) True) -; - + (= (db_entry (: learner door) (door a_living_room a_kitchen) ()) True) + (= (db_entry (: learner door) (door a_living_room a_street) ()) True) + (= (db_entry (: learner door) (door a_living_room a_garden) ()) True) + (= (db_entry (: learner door) (door a_kitchen a_garden) ()) True) + (= (db_entry (: learner door) (door a_kitchen a_fridge) ()) True) + (= (db_entry (: learner door) (door a_street a_garden) ()) True) ; ; - ; -; - +; Now the theory continues correctly ; ; - - (= - (db_entry - (: learner entropy) - (entropy_increases $A $B) - ( (warm $A) - (cold $B) - (door $A $B))) True) -; - - (= - (db_entry - (: learner entropy) - (entropy_increases $A $B) - ( (cold $A) - (warm $B) - (door $A $B))) True) -; - - (= - (db_entry - (: learner entropy) - (entropy_increases $A $B) - ( (warm $A) - (cold $B) - (door $B $A))) True) -; - - (= - (db_entry - (: learner entropy) - (entropy_increases $A $B) - ( (cold $A) - (warm $B) - (door $B $A))) True) -; - + (= (db_entry (: learner entropy) (entropy_increases $A $B) ((warm $A) (cold $B) (door $A $B))) True) + (= (db_entry (: learner entropy) (entropy_increases $A $B) ((cold $A) (warm $B) (door $A $B))) True) + (= (db_entry (: learner entropy) (entropy_increases $A $B) ((warm $A) (cold $B) (door $B $A))) True) + (= (db_entry (: learner entropy) (entropy_increases $A $B) ((cold $A) (warm $B) (door $B $A))) True) ; -; - +; Recusive Theory ; -; - - (= - (db_entry - (: learner t_member) - (member $A ()) ()) True) -; - - (= - (db_entry - (: learner t_member) - (member $A - (Cons $B $T)) - ( (not - (= $A $B)) (member $A $T))) True) -; - +; incorrect t_member + (= (db_entry (: learner t_member) (member $A ()) ()) True) + (= (db_entry (: learner t_member) (member $A (Cons $B $T)) ((not (= $A $B)) (member $A $T))) True) ; -; - +; | | ; -; - +; +--------+ this is a fault ! ; ; - - (= - (db_entry - (: learner t_append) - (append () $List ()) ()) True) -; - + (= (db_entry (: learner t_append) (append () $List ()) ()) True) ; -; - +; || ; -; +; ++ this is a fault ! + (= (db_entry (: learner t_append) (append (Cons $First $Rest) $List (Cons $First $TempList)) ((append $Rest $List $TempList))) True) - (= - (db_entry - (: learner t_append) - (append - (Cons $First $Rest) $List - (Cons $First $TempList)) - ( (append $Rest $List $TempList))) True) -; + (= (def_theory (: learner t_reverse) ((: learner t_append))) True) + (= (db_entry (: learner t_reverse) (reverse () ()) ()) True) + (= (db_entry (: learner t_reverse) (reverse (Cons $X $Y) $Z) ((reverse $Y $Y1) (append $Y1 ($X) $Z))) True) - (= - (def_theory - (: learner t_reverse) - ( (: learner t_append))) True) -; + (= (def_theory (: learner qsort) ((: learner partition) (: learner t_append1))) True) - (= - (db_entry - (: learner t_reverse) - (reverse () ()) ()) True) -; + (= (db_entry (: learner qsort) (qsort () ()) ()) True) + (= (db_entry (: learner qsort) (qsort (Cons $X $L) $L5) ((partition $L $X $L1 $L2) (qsort $L1 $L3) (qsort $L2 $L4) (append1 $L3 (Cons $X $L4) $L5))) True) - (= - (db_entry - (: learner t_reverse) - (reverse - (Cons $X $Y) $Z) - ( (reverse $Y $Y1) (append $Y1 ($X) $Z))) True) -; - - - - (= - (def_theory - (: learner qsort) - ( (: learner partition) (: learner t_append1))) True) -; - - - (= - (db_entry - (: learner qsort) - (qsort () ()) ()) True) -; - - (= - (db_entry - (: learner qsort) - (qsort - (Cons $X $L) $L5) - ( (partition $L $X $L1 $L2) - (qsort $L1 $L3) - (qsort $L2 $L4) - (append1 $L3 - (Cons $X $L4) $L5))) True) -; - - - (= - (db_entry - (: learner partition) - (partition - (Cons $X $L) $Y - ($L1) $L2) - ( (< $X $Y) (partition $L $Y $L1 $L2))) True) -; - - (= - (db_entry - (: learner partition) - (partition - (Cons $X $L) $Y $L1 - (Cons $X $L2)) - ( (>= $X $Y) (partition $L $Y $L1 $L2))) True) -; - - (= - (db_entry - (: learner partition) - (partition () $_ () ()) ()) True) -; - - - (= - (db_entry - (: learner t_append1) - (append1 () $List $List) ()) True) -; - - (= - (db_entry - (: learner t_append1) - (append1 - (Cons $First $Rest) $List - (Cons $First $TempList)) - ( (append1 $Rest $List $TempList))) True) -; + (= (db_entry (: learner partition) (partition (Cons $X $L) $Y ($L1) $L2) ((< $X $Y) (partition $L $Y $L1 $L2))) True) +; ; | | ; +--+ this is a fault ! + (= (db_entry (: learner partition) (partition (Cons $X $L) $Y $L1 (Cons $X $L2)) ((>= $X $Y) (partition $L $Y $L1 $L2))) True) + (= (db_entry (: learner partition) (partition () $_ () ()) ()) True) + (= (db_entry (: learner t_append1) (append1 () $List $List) ()) True) + (= (db_entry (: learner t_append1) (append1 (Cons $First $Rest) $List (Cons $First $TempList)) ((append1 $Rest $List $TempList))) True) diff --git a/multagnt/multagnt.metta b/multagnt/multagnt.metta index 411e0fb..268588e 100644 --- a/multagnt/multagnt.metta +++ b/multagnt/multagnt.metta @@ -1,1255 +1,940 @@ +; (convert_to_metta_file multagnt $_234414 multagnt/multagnt.pl multagnt/multagnt.metta) !(dynamic (/ parent 2)) -; - +; /******************************************************************/ +; /* MULTAGNT.PRO */ +; /* Brazdil's Simulation of a tutoring setting between two agents */ +; /******************************************************************/ +; /* impl. by : Yiu Cheung HO */ +; /* Department of Computing */ +; /* King's College London */ +; /* 1989 */ +; /* */ +; /* Thomas Hoppe */ +; /* Mommsenstr. 50 */ +; /* 1000 Berlin 12 */ +; /* F.R.G. */ +; /* E-Mail: hoppet@db0tui11.pro */ +; /* 1990 */ +; /* */ +; /* reference : Transfer of Knowledge between Systems, */ +; /* Brazdil, P., Associacao Portuguesa para a Intel-*/ +; /* igencia Artificial, Working Paper 87-1, Uni- */ +; /* versity of Porto, 1987. */ +; /* */ +; /* Diagnosis of Misunderstanding, Yiu Cheung HO, */ +; /* Project Report, Final Year One Unit Project */ +; /* 88/89, Department of Computing, King's College */ +; /* London, 1989. */ +; /* */ +; /* call : diagnosis */ +; /* */ +; /******************************************************************/ !(dynamic (/ db-entry 3)) -; - +; /******************************************************************/ +; /* YAP-, C- and M-MeTTa specific declaration of dynamical */ +; /* clauses. */ +; /******************************************************************/ !(dynamic (/ def-theory 2)) -; - !(dynamic (/ digits-of-next-sym 1)) -; - !(op 999 xfx :) -; - !(op 998 xfx <-) -; - - (= - (diagnosis) - ( (init) - (get-teacher teacher) - (nl) - (nl) - (get-learner) - (locate-error))) -; - + (= (diagnosis) + (init) + (get-teacher teacher) + (nl) + (nl) + (get-learner) + (locate-error)) +; /******************************************************************/ +; /* User Interface */ +; /******************************************************************/ - (= - (init) - ( (abolish db-entry 3) - (abolish def-theory 2) - (multifile (/ db-entry 3)) - (multifile (/ def-theory 2)) - (dynamic (/ db-entry 3)) - (dynamic (/ def-theory 2)))) -; - + (= (init) + (abolish db-entry 3) + (abolish def-theory 2) + (multifile (/ db-entry 3)) + (multifile (/ def-theory 2)) + (dynamic (/ db-entry 3)) + (dynamic (/ def-theory 2))) !(init *) -; - !(:: (teacher *)) -; - !(:: (learner1 *)) -; - - (= - (locate-error) - ( (repeat) - (mode $Mode) - (generate-error $Mode))) -; - + (= (locate-error) + (repeat) + (mode $Mode) + (generate-error $Mode)) - (= - (generate-error manual) - ( (repeat) - (get-question $Question) - (process-question $Question) - (exit-manual) - (set-det) - (exit))) -; - - (= - (generate-error auto) - ( (select-question $Question) - (process-question $Question) - (exit-auto) - (set-det) - (exit))) -; - - (= - (generate-error $_) + (= (generate-error manual) + (repeat) + (get-question $Question) + (process-question $Question) + (exit-manual) + (set-det) (exit)) -; - - - - (= - (process-question $Question) - ( (what-cannot-do $Ls $Ts - (<- $Question $Answer) Nil $FaultyStep) - (output-error $Ls $Ts - (<- $Question $Answer) $FaultyStep) - (set-det))) -; - - (= - (process-question $Question) - ( (write ' *** The teacher cannot answer the question: ') - (write $Question) - (nl))) -; - - - - (= - (output-error $Tl $Tt - (<- $Question $Answer) $FaultyStep) - ( (nl) - (write ' Result of Diagnosis:') - (nl) - (write --------------------) - (nl) - (nl) - (write ' The query is: ') - (write $Question) - (nl) - (write ' Teachers answer is: ') - (out-answer $Answer) - (nl) - (write ' Learners theory: ') - (write $Tl) - (nl) - (write ' Teachers theory: ') - (write $Tt) - (nl) - (write ' Faulty Steps: ') - (out-faulty $FaultyStep) - (nl) - (set-det))) -; - - - - (= - (out-faulty Nil) - ( (write 'no faulty step') (nl))) -; - - (= - (out-faulty $Steps) - ( (out-step $Steps) (nl))) -; - - - - (= - (out-step Nil) - (nl)) -; - - (= - (out-step (Cons $Step $Steps)) - ( (write ) - (write $Step) - (nl) - (write $Steps))) -; + (= (generate-error auto) + (select-question $Question) + (process-question $Question) + (exit-auto) + (set-det) + (exit)) + (= (generate-error $_) + (exit)) + + (= (process-question $Question) + (what-cannot-do $Ls $Ts + (<- $Question $Answer) Nil $FaultyStep) + (output-error $Ls $Ts + (<- $Question $Answer) $FaultyStep) + (set-det)) + (= (process-question $Question) + (write ' *** The teacher cannot answer the question: ') + (write $Question) + (nl)) - (= - (out-answer Nil) - ( (write True) (nl))) -; + (= (output-error $Tl $Tt (<- $Question $Answer) $FaultyStep) + (nl) + (write ' Result of Diagnosis:') + (nl) + (write --------------------) + (nl) + (nl) + (write ' The query is: ') + (write $Question) + (nl) + (write ' Teachers answer is: ') + (out-answer $Answer) + (nl) + (write ' Learners theory: ') + (write $Tl) + (nl) + (write ' Teachers theory: ') + (write $Tt) + (nl) + (write ' Faulty Steps: ') + (out-faulty $FaultyStep) + (nl) + (set-det)) - (= - (out-answer $Ans) - (out-ans $Ans)) -; + (= (out-faulty Nil) + (write 'no faulty step') + (nl)) + (= (out-faulty $Steps) + (out-step $Steps) + (nl)) - (= - (out-ans Nil) + (= (out-step Nil) (nl)) -; - - (= - (out-ans (Cons (val $Var $Val) $T)) - ( (write (= $Var $Val)) - (nl) - (write ) - (out-ans $T))) -; - + (= (out-step (Cons $Step $Steps)) + (write ) + (write $Step) + (nl) + (write $Steps)) - (= - (select-question $Question) - ( (generate-question $Question) - (yes-no yes confirm $Reply) - (= $Reply yes))) -; - - (= - (select-question $_) - ( (write ' no more questions') - (nl) - (set-det) - (fail))) -; - + (= (out-answer Nil) + (write True) + (nl)) + (= (out-answer $Ans) + (out-ans $Ans)) - (= - (generate-question $Question) - ( (db-entry - (with_self - (teacher *) $_) $Question $_) - (make-ground-term $Question) - (nl) - (write ' Question generated: ') - (write $Question) - (nl))) -; - + (= (out-ans Nil) + (nl)) + (= (out-ans (Cons (val $Var $Val) $T)) + (write (= $Var $Val)) + (nl) + (write ) + (out-ans $T)) + + + (= (select-question $Question) + (generate-question $Question) + (yes-no yes confirm $Reply) + (= $Reply yes)) + (= (select-question $_) + (write ' no more questions') + (nl) + (set-det) + (fail)) + + + (= (generate-question $Question) + (db-entry + (with_self + (teacher *) $_) $Question $_) + (make-ground-term $Question) + (nl) + (write ' Question generated: ') + (write $Question) + (nl)) - (= - (get-question $Question) - ( (write ' Input question: ') (read $Question))) -; - + (= (get-question $Question) + (write ' Input question: ') + (read $Question)) - (= - (mode auto) - ( (nl) - (nl) - (yes-no yes ' Do you want the system to generate questions ? ' $Reply) - (nl) - (= $Reply yes) - (set-det))) -; - - (= - (mode manual) True) -; - + (= (mode auto) + (nl) + (nl) + (yes-no yes ' Do you want the system to generate questions ? ' $Reply) + (nl) + (= $Reply yes) + (set-det)) + (= (mode manual) True) - (= - (exit-manual) - ( (yes-no no ' Exit manual mode ? ' $Reply) (= $Reply yes))) -; - + (= (exit-manual) + (yes-no no ' Exit manual mode ? ' $Reply) + (= $Reply yes)) - (= - (exit-auto) - ( (yes-no no ' Exit auto mode ? ' $Reply) (= $Reply yes))) -; - + (= (exit-auto) + (yes-no no ' Exit auto mode ? ' $Reply) + (= $Reply yes)) - (= - (exit) - ( (yes-no no ' Quit ? ' $Reply) (= $Reply yes))) -; - + (= (exit) + (yes-no no ' Quit ? ' $Reply) + (= $Reply yes)) - (= - (get-teacher $Teacher) - ( (yes-no yes ' Do you want to load the provided teacher KB ? ' $Reply) - (load-knowledge-base $Reply $Teacher) - (knowledge-base-list $Reply Nil $Teacher $FileList) - (yes-no no ' Do you want to load another teacher KB ? ' $Reply2) - (more-knowledge $Reply2 $FileList))) -; - + (= (get-teacher $Teacher) + (yes-no yes ' Do you want to load the provided teacher KB ? ' $Reply) + (load-knowledge-base $Reply $Teacher) + (knowledge-base-list $Reply Nil $Teacher $FileList) + (yes-no no ' Do you want to load another teacher KB ? ' $Reply2) + (more-knowledge $Reply2 $FileList)) - (= - (load_knowledge_base no $_) True) -; - - (= - (load-knowledge-base yes $File) - ( (nl) - (consult $File) - (nl) - (set-det))) -; - + (= (load_knowledge_base no $_) True) + (= (load-knowledge-base yes $File) + (nl) + (consult $File) + (nl) + (set-det)) - (= - (more_knowledge no - (Cons $_ $_)) True) -; - - (= - (more-knowledge no Nil) - ( (write ' *** You have not load any knowledge base yet !') - (nl) - (more-knowledge yes Nil))) -; - - (= - (more-knowledge yes $FileList) - ( (repeat) - (ask-file ' Please input the filename of the KB: ' $File) - (not-loaded $File $FileList $Load) - (load-knowledge-base $Load $File) - (knowledge-base-list $Load $FileList $File $NewList) - (yes-no no ' Do you want to consult more KBs ? ' $Reply) - (more-knowledge $Reply $NewList))) -; - + (= (more_knowledge no (Cons $_ $_)) True) + (= (more-knowledge no Nil) + (write ' *** You have not load any knowledge base yet !') + (nl) + (more-knowledge yes Nil)) + (= (more-knowledge yes $FileList) + (repeat) + (ask-file ' Please input the filename of the KB: ' $File) + (not-loaded $File $FileList $Load) + (load-knowledge-base $Load $File) + (knowledge-base-list $Load $FileList $File $NewList) + (yes-no no ' Do you want to consult more KBs ? ' $Reply) + (more-knowledge $Reply $NewList)) - (= - (not-loaded $File $List no) - ( (member $File $List) (set-det))) -; - - (= - (not_loaded $_ $_ yes) True) -; - + (= (not-loaded $File $List no) + (member $File $List) + (set-det)) + (= (not_loaded $_ $_ yes) True) ; -; - +; yesno(Question):- yesno(Question,no). ; -; - - - - (= - (yes-no $Default $Message $Reply) - ( (repeat) - (write ' ') - (write $Message) - (det-if-then-else - (== $Default yes) - (write ' (Yes/no) ') - (write ' (yes/No) ')) - (get-single-char $In) +; yesno(Question, Default):- format('~N~w? (~w): ',[Question,Default]),get_single_char(YN), (YN = 13 -> Default==yes; member(YN, `yY`)). + + + (= (yes-no $Default $Message $Reply) + (repeat) + (write ' ') + (write $Message) + (det-if-then-else + (== $Default yes) + (write ' (Yes/no) ') + (write ' (yes/No) ')) + (get-single-char $In) + (det-if-then-else + (= + (:: $In) + (:: 101)) + (, + (set-det) + (halt 4)) (det-if-then-else (= (:: $In) - (:: 101)) + (:: 97)) (, (set-det) - (halt 4)) + (abort)) (det-if-then-else - (= - (:: $In) - (:: 97)) - (, - (set-det) - (abort)) - (det-if-then-else - (= $In 13) - (= $Reply $Default) - (reply $In $Reply)))) - (set-det))) -; - - - - (= - (reply $Reply yes) + (= $In 13) + (= $Reply $Default) + (reply $In $Reply)))) + (set-det)) + + + (= (reply $Reply yes) (member $Reply (:: yes y yes. y. 89 121))) -; - - (= - (reply $Reply no) + (= (reply $Reply no) (member $Reply (:: no n no. n. 78 110))) -; - - (= - (ask-file $Message $File) - ( (repeat) - (write ' ') - (write $Message) - (read-in $File) - (set-det))) -; - + (= (ask-file $Message $File) + (repeat) + (write ' ') + (write $Message) + (read-in $File) + (set-det)) - (= - (knowledge_base_list yes $List $File - (Cons $File $List)) True) -; - - (= - (knowledge_base_list no $List $_ $List) True) -; - + (= (knowledge_base_list yes $List $File (Cons $File $List)) True) + (= (knowledge_base_list no $List $_ $List) True) - (= - (no-knowledge Nil) - ( (write ' *** You have not load any knowledge base yet !') (nl))) -; - + (= (no-knowledge Nil) + (write ' *** You have not load any knowledge base yet !') + (nl)) - (= - (get-learner) - ( (ask-file ' Please input the filename for the learner KB: ' $File) - (load-knowledge-base yes $File) - (knowledge-base-list yes Nil $File $List) - (yes-no no ' Do you want to load another KB for the learner ? ' $Reply) - (more-knowledge $Reply $List))) -; - + (= (get-learner) + (ask-file ' Please input the filename for the learner KB: ' $File) + (load-knowledge-base yes $File) + (knowledge-base-list yes Nil $File $List) + (yes-no no ' Do you want to load another KB for the learner ? ' $Reply) + (more-knowledge $Reply $List)) - (= - (can-do + (= (can-do (with_self (learner *) $Tl) (with_self (teacher *) $Tt) $Question $TeachersAnswer) + (demo (with_self - (learner *) $Tl) + (learner *) $Tl) $Question $LearnersAnswer) + (can-do-1 (with_self - (teacher *) $Tt) $Question $TeachersAnswer) - ( (demo - (with_self - (learner *) $Tl) $Question $LearnersAnswer) (can-do-1 (with_self (teacher *) $Tt) $Question $TeachersAnswer $LearnersAnswer))) -; - + (teacher *) $Tt) $Question $TeachersAnswer $LearnersAnswer)) +; /******************************************************************/ +; /* Brazdil's predicates for evaluating the behavior of "LEARNER" */ +; /* and "TEACHER". */ +; /******************************************************************/ - (= - (can-do-1 $Teacher $Question $TeachersAnswer $LearnersAnswer) - ( (demo $Teacher $Question $TeachersAnswer) - (demo $Teacher $LearnersAnswer $TeachersAnswer) - (demo $Teacher $TeachersAnswer $LearnersAnswer))) -; - + (= (can-do-1 $Teacher $Question $TeachersAnswer $LearnersAnswer) + (demo $Teacher $Question $TeachersAnswer) + (demo $Teacher $LearnersAnswer $TeachersAnswer) + (demo $Teacher $TeachersAnswer $LearnersAnswer)) - (= - (cannot-do - (with_self - (learner *) $Tl) + (= (cannot-do (with_self (learner *) $Tl) (with_self (teacher *) $Tt) $Question $TeachersAnswer) + (not (demo (with_self (learner *) $Tl) $Question $LearnersAnswer)) + (demo (with_self - (teacher *) $Tt) $Question $TeachersAnswer) - ( (not (demo (with_self (learner *) $Tl) $Question $LearnersAnswer)) (demo (with_self (teacher *) $Tt) $Question $TeachersAnswer))) -; - - (= - (cannot-do $Learner $Teacher $Question $_) - ( (can-do $Learner $Teacher $Question $_) - (set-det) - (fail))) -; - - (= - (cannot-do + (teacher *) $Tt) $Question $TeachersAnswer)) + (= (cannot-do $Learner $Teacher $Question $_) + (can-do $Learner $Teacher $Question $_) + (set-det) + (fail)) + (= (cannot-do (with_self (learner *) $Tl) (with_self (teacher *) $Tt) $Question $TeachersAnswer) + (demo (with_self - (learner *) $Tl) + (learner *) $Tl) $Question $_) + (demo (with_self - (teacher *) $Tt) $Question $TeachersAnswer) - ( (demo - (with_self - (learner *) $Tl) $Question $_) (demo (with_self (teacher *) $Tt) $Question $TeachersAnswer))) -; - - - - (= - (what-cannot-do $_ $_ - (<- $Q $_) $_ $_) - ( (not (all-ground-term $Q)) - (nl) - (write ' *** You asked a non ground question !') - (nl) - (set-det) - (fail))) -; - - (= - (what-cannot-do $Ls $Ts - (<- $Q $A) $FaultyStep $FaultyStep) + (teacher *) $Tt) $Question $TeachersAnswer)) +; ; It seems that the condition LearnersAnswer <> TeachersAnswer is missing ! + + + (= (what-cannot-do $_ $_ (<- $Q $_) $_ $_) + (not (all-ground-term $Q)) + (nl) + (write ' *** You asked a non ground question !') + (nl) + (set-det) + (fail)) + (= (what-cannot-do $Ls $Ts (<- $Q $A) $FaultyStep $FaultyStep) (can-do $Ls $Ts $Q $A)) -; - - (= - (what-cannot-do $Ls $Ts - (<- $Q $A) $F1 - (Cons - (<- $Q $A) $F1)) + (= (what-cannot-do $Ls $Ts (<- $Q $A) $F1 (Cons (<- $Q $A) $F1)) (is-faulty-step $Ls $Ts $Q $A)) -; + (= (what-cannot-do $Ls $Ts (<- $Q $A) $F1 $F2) + (cannot-do $Ls $Ts $Q $A) + (demo-trace2 $Ls $Ts $Q $A $SubSteps) + (what-cannot-do-list $Ls $Ts $SubSteps $F1 $F3) + (faulty-step $Q $A $F1 $F3 $F2)) + + + (= (is-faulty-step $Ls $Ts $Q $A) + (cannot-do $Ls $Ts $Q $A) + (set-det) + (not (demo-trace2 $Ls $Ts $Q $A $_))) + + + (= (faulty_step $Q $A $F1 $F1 (Cons (<- $Q $A) $F1)) True) + (= (faulty_step $Q $A $F1 $F3 $F3) True) + + + (= (what_cannot_do_list $_ $_ () $F $F) True) + (= (what-cannot-do-list $Ls $Ts (Cons $Step1 $RestSteps) $F1 $F3) + (what-cannot-do $Ls $Ts $Step1 $F1 $F2) + (what-cannot-do-list $Ls $Ts $RestSteps $F2 $F3)) + + + (= (demo $Theory $Goal $Conditions) + (var $Conditions) + (set-det) + (check-goal $Goal) + (copy-vars $Goal $LVars $Goal2 $LVars2) + (set-det) + (show $Theory $Goal2) + (link-vals $LVars $LVars2 $Conditions) + (make-ground-term $Conditions)) +; /******************************************************************/ +; /* */ +; /* call : demo(+Theory,+Goal,Conditions) */ +; /* */ +; /* arguments : Theory = ground term denoting a theory */ +; /* Goal = ground term or list of ground terms*/ +; /* Conditions = substitutions */ +; /* */ +; /* property : backtrackable */ +; /* */ +; /******************************************************************/ +; /* 'demo' is used to prove the Goal in the background of a Theory */ +; /* delivering a substitution in Conditions. */ +; /* Bindings of variables and values are explicitly maintained by */ +; /* this implementation, thus any subterm of the form "variable(S)"*/ +; /* must actually be of the form "variabl()" where is */ +; /* the name of a variable in the Goal. */ +; /* The substitutions in Condition may be either a variable or a */ +; /* list of terms which all have the form val(variable(X),Y) where */ +; /* X is the name of a variable (an atom) and Y is any term. */ +; /* In the case Condition is uninstantiated, demo succeeds iff */ +; /* Goal can be proven within the Theory. Condition is then instan-*/ +; /* tiated with the corresponding substitutions in the form */ +; /* described above. On backtracking it will deliver the next */ +; /* possible proof with the corresponding substitution, if it */ +; /* exists. */ +; /* If Condition is instantiated in the form described above, demo */ +; /* succeeds, if Goal can be proven with the given substitution. */ +; /******************************************************************/ + (= (demo $Theory $Goal $Conditions) + (nonvar $Conditions) + (check-conditions $Conditions) + (check-goal $Goal) + (set-vars $Goal $Conditions $Goal2) + (copy-vars $Goal2 $_ $Goal3 $LVars3) + (set-det) + (show $Theory $Goal3) + (no-new-values $LVars3) + (not (identified-vars $LVars3)) + (set-det)) + - (= - (what-cannot-do $Ls $Ts - (<- $Q $A) $F1 $F2) - ( (cannot-do $Ls $Ts $Q $A) - (demo-trace2 $Ls $Ts $Q $A $SubSteps) - (what-cannot-do-list $Ls $Ts $SubSteps $F1 $F3) - (faulty-step $Q $A $F1 $F3 $F2))) -; - - - - (= - (is-faulty-step $Ls $Ts $Q $A) - ( (cannot-do $Ls $Ts $Q $A) - (set-det) - (not (demo-trace2 $Ls $Ts $Q $A $_)))) -; - - - - (= - (faulty_step $Q $A $F1 $F1 - (Cons - (<- $Q $A) $F1)) True) -; - - (= - (faulty_step $Q $A $F1 $F3 $F3) True) -; - - - - (= - (what_cannot_do_list $_ $_ () $F $F) True) -; - - (= - (what-cannot-do-list $Ls $Ts - (Cons $Step1 $RestSteps) $F1 $F3) - ( (what-cannot-do $Ls $Ts $Step1 $F1 $F2) (what-cannot-do-list $Ls $Ts $RestSteps $F2 $F3))) -; - - - - (= - (demo $Theory $Goal $Conditions) - ( (var $Conditions) - (set-det) - (check-goal $Goal) - (copy-vars $Goal $LVars $Goal2 $LVars2) - (set-det) - (show $Theory $Goal2) - (link-vals $LVars $LVars2 $Conditions) - (make-ground-term $Conditions))) -; - - (= - (demo $Theory $Goal $Conditions) - ( (nonvar $Conditions) - (check-conditions $Conditions) - (check-goal $Goal) - (set-vars $Goal $Conditions $Goal2) - (copy-vars $Goal2 $_ $Goal3 $LVars3) - (set-det) - (show $Theory $Goal3) - (no-new-values $LVars3) - (not (identified-vars $LVars3)) - (set-det))) -; - - - - (= - (demo-trace2 $Ls $Ts $Goal $Conditions $Steps) - ( (set-vars $Goal $Conditions $Goal2) - (copy-vars $Goal2 $_ $Goal3 $_) - (copy-vars $Goal2 $_ $Goal4 $_) - (set-det) - (db-entry $Ls $Goal3 $_) - (set-det) - (db-entry $Ts $Goal4 $Body) - (make-ground-term $Body) - (set-vars $Body $Conditions $Body2) - (copy-vars $Body2 $_ $Body3 $_) - (show $Ts $Body3) - (make-ground-term $Body3) - (trace-list $Body3 $Steps))) -; - - - - (= - (trace_list () ()) True) -; - - (= - (trace-list - (Cons $SubGoal $Rest) - (Cons - (<- $SubGoal $_) $Steps)) + (= (demo-trace2 $Ls $Ts $Goal $Conditions $Steps) + (set-vars $Goal $Conditions $Goal2) + (copy-vars $Goal2 $_ $Goal3 $_) + (copy-vars $Goal2 $_ $Goal4 $_) + (set-det) + (db-entry $Ls $Goal3 $_) + (set-det) + (db-entry $Ts $Goal4 $Body) + (make-ground-term $Body) + (set-vars $Body $Conditions $Body2) + (copy-vars $Body2 $_ $Body3 $_) + (show $Ts $Body3) + (make-ground-term $Body3) + (trace-list $Body3 $Steps)) +; /******************************************************************/ +; /* Brazdil's predicate for locating erroneous LEARNER's knowledge */ +; /******************************************************************/ + + + (= (trace_list () ()) True) + (= (trace-list (Cons $SubGoal $Rest) (Cons (<- $SubGoal $_) $Steps)) (trace-list $Rest $Steps)) -; - - (= - (show $_ Nil) + (= (show $_ Nil) + (set-det)) +; /******************************************************************/ +; /* */ +; /* call : show(+Theory,+Goal) */ +; /* */ +; /* arguments : Theory = ground term denoting a theory */ +; /* Goal = ground term or list of ground terms*/ +; /* */ +; /* property : backtrackable */ +; /* */ +; /******************************************************************/ +; /* 'show' is nothing else than an MeTTa meta-interpreter working */ +; /* in the traditional way, except that substitutions are explicit-*/ +; /* ly represented through terms in the form 'val(,)'. */ +; /******************************************************************/ + (= (show $Th (not $G)) + (set-det) + (not (show $Th $G))) + (= (show $Th (not $G)) + (set-det) + (not (show $Th $G))) + (= (show $Th (val $X $Y)) + (set-det) + (is-value $X $Y)) + (= (show $Th (Cons $G $Gs)) + (set-det) + (show $Th $G) + (show $Th $Gs)) + (= (show $Th $G) + (db-entry $Th $G $B) + (show $Th $B)) + (= (show $Th $G) + (def-theory $Th $ThList) + (member $SubTh $ThList) + (show $SubTh $G)) + (= (show $_ $G) + (predicate-property $G built-in) + (set-det) + (call $G)) + (= (show $_ $G) + (predicate-property $G unknown) + (dynamic $G) + (fail)) + (= (show $_ $G) + (not (== (= $G $_) (get-atoms &self))) + (call $G) (set-det)) -; - - (= - (show $Th - (not $G)) - ( (set-det) (not (show $Th $G)))) -; - - (= - (show $Th - (not $G)) - ( (set-det) (not (show $Th $G)))) -; - - (= - (show $Th - (val $X $Y)) - ( (set-det) (is-value $X $Y))) -; - - (= - (show $Th - (Cons $G $Gs)) - ( (set-det) - (show $Th $G) - (show $Th $Gs))) -; - - (= - (show $Th $G) - ( (db-entry $Th $G $B) (show $Th $B))) -; - - (= - (show $Th $G) - ( (def-theory $Th $ThList) - (member $SubTh $ThList) - (show $SubTh $G))) -; - - (= - (show $_ $G) - ( (predicate-property $G built-in) - (set-det) - (call $G))) -; - - (= - (show $_ $G) - ( (predicate-property $G unknown) - (dynamic $G) - (fail))) -; - - (= - (show $_ $G) - ( (not (get-symbols &self (= $G $_))) - (call $G) - (set-det))) -; - - - - (= - (is-value $X $Y) - ( (var $X) - (var $Y) - (set-det))) -; - - (= - (is-value $X $_) - ( (var $X) - (set-det) - (fail))) -; - - (= - (is-value $_ $Y) - ( (var $Y) - (set-det) - (fail))) -; - - (= - (is-value $X $X) - ( (atomic $X) (set-det))) -; - - (= - (is-value - (Cons $Head1 $Tail1) - (Cons $Head2 $Tail2)) - ( (set-det) - (is-value $Head1 $Head2) - (is-value $Tail1 $Tail2))) -; - - (= - (is-value $X $Y) - ( (not (atomic $X)) - (not (atomic $Y)) - (=.. $X - (Cons $F $ArgsX)) - (=.. $Y - (Cons $F $ArgsY)) - (set-det) - (is-value $ArgsX $ArgsY))) -; - - - - (= - (copy_vars - (variable $G) - ($G) $G2 - ($G2)) True) -; - - (= - (copy-vars $G Nil $G Nil) - (atomic $G)) -; - - (= - (copy-vars $G $LVars $G2 $LVars2) - ( (=.. $G - (Cons $F $Args)) - (copy-vars-list $Args Nil $LVars $Args2 Nil $LVars2) - (=.. $G2 - (Cons $F $Args2)))) -; - - - - (= - (copy_vars_list () $LVars $LVars () $LVars2 $LVars2) True) -; - - (= - (copy-vars-list - (Cons $A $As) $PV $LV - (Cons $A2 $A2s) $PV2 $LV2) - ( (copy-vars $A $AVL $A2 $AVL2) - (join-vars $AVL $PV $PVplus $AVL2 $PV2 $PV2plus) - (copy-vars-list $As $PVplus $LV $A2s $PV2plus $LV2))) -; - - (= - (join_vars () $PV $PV () $PV2 $PV2) True) -; - - (= - (join-vars - (Cons $X $AVL) $PVin $PVout - (Cons $X2 $AVL2) $PV2in $PV2out) - ( (twin-member $X $PVin $X2 $PV2in) (join-vars $AVL $PVin $PVout $AVL2 $PV2in $PV2out))) -; - - (= - (join-vars - (Cons $X $AVL) $PVin $PVout - (Cons $X2 $AVL2) $PV2in $PV2out) + (= (is-value $X $Y) + (var $X) + (var $Y) + (set-det)) + (= (is-value $X $_) + (var $X) + (set-det) + (fail)) + (= (is-value $_ $Y) + (var $Y) + (set-det) + (fail)) + (= (is-value $X $X) + (atomic $X) + (set-det)) + (= (is-value (Cons $Head1 $Tail1) (Cons $Head2 $Tail2)) + (set-det) + (is-value $Head1 $Head2) + (is-value $Tail1 $Tail2)) + (= (is-value $X $Y) + (not (atomic $X)) + (not (atomic $Y)) + (=.. $X + (Cons $F $ArgsX)) + (=.. $Y + (Cons $F $ArgsY)) + (set-det) + (is-value $ArgsX $ArgsY)) + + + (= (copy_vars (variable $G) ($G) $G2 ($G2)) True) +; /******************************************************************/ +; /* Variable handling procedures */ +; /******************************************************************/ +; /* */ +; /* call : copy_vars(+G,+LVars,-G2,-LVars2) */ +; /* */ +; /* arguments : G = ground term */ +; /* LVars = list of variables in G */ +; /* G2 = variablelized term */ +; /* LVars2 = list of variables in G2 */ +; /* */ +; /******************************************************************/ +; /* 'copy_vars' sets G2 to a copy of G with all variables of the */ +; /* form 'variable()' replaced with uninstantiated MeTTa */ +; /* variables. */ +; /******************************************************************/ + (= (copy-vars $G Nil $G Nil) + (atomic $G)) + (= (copy-vars $G $LVars $G2 $LVars2) + (=.. $G + (Cons $F $Args)) + (copy-vars-list $Args Nil $LVars $Args2 Nil $LVars2) + (=.. $G2 + (Cons $F $Args2))) + + + (= (copy_vars_list () $LVars $LVars () $LVars2 $LVars2) True) + (= (copy-vars-list (Cons $A $As) $PV $LV (Cons $A2 $A2s) $PV2 $LV2) + (copy-vars $A $AVL $A2 $AVL2) + (join-vars $AVL $PV $PVplus $AVL2 $PV2 $PV2plus) + (copy-vars-list $As $PVplus $LV $A2s $PV2plus $LV2)) + + + (= (join_vars () $PV $PV () $PV2 $PV2) True) + (= (join-vars (Cons $X $AVL) $PVin $PVout (Cons $X2 $AVL2) $PV2in $PV2out) + (twin-member $X $PVin $X2 $PV2in) + (join-vars $AVL $PVin $PVout $AVL2 $PV2in $PV2out)) + (= (join-vars (Cons $X $AVL) $PVin $PVout (Cons $X2 $AVL2) $PV2in $PV2out) (join-vars $AVL (Cons $X $PVin) $PVout $AVL2 (Cons $X2 $PV2in) $PV2out)) -; - - (= - (twin_member $Var - (Cons $Var $_) $Val - (Cons $Val $_)) True) -; - - (= - (twin-member $Var - (Cons $_ $Tail1) $Val - (Cons $_ $Tail2)) + (= (twin_member $Var (Cons $Var $_) $Val (Cons $Val $_)) True) + (= (twin-member $Var (Cons $_ $Tail1) $Val (Cons $_ $Tail2)) (twin-member $Var $Tail1 $Val $Tail2)) -; - - (= - (link-vals - (Cons $X $LV) - (Cons $X2 $LV2) - (Cons - (val - (variable $X) $X2) $Conditions)) + (= (link-vals (Cons $X $LV) (Cons $X2 $LV2) (Cons (val (variable $X) $X2) $Conditions)) (link-vals $LV $LV2 $Conditions)) -; - - (= - (link_vals () () ()) True) -; - - - - (= - (set_vars $Goal () $Goal) True) -; - - (= - (set-vars $Goal - (Cons - (val - (variable $Var) $Val) $Rest) $ResultGoal) - ( (atomic $Var) - (substitute $Goal - (variable $Var) $Val $Goal2) - (set-det) - (set-vars $Goal2 $Rest $ResultGoal))) -; - - - - (= - (substitute $Var $Var $Val $Val) True) -; - - (= - (substitute $Goal $_ $_ $Goal) - ( (atomic $Goal) (set-det))) -; - - (= - (substitute - (Cons $Arg $Tail) $Var $Val - (Cons $NewArg $NewTail)) - ( (set-det) - (substitute $Arg $Var $Val $NewArg) - (substitute $Tail $Var $Val $NewTail))) -; - - (= - (substitute $Goal $Var $Val $FinalGoal) - ( (=.. $Goal - (Cons $F $Args)) - (substitute $Args $Var $Val $NewArgs) - (=.. $FinalGoal - (Cons $F $NewArgs)))) -; - - - - (= - (all-ground-term $Variable) - ( (var $Variable) - (set-det) - (fail))) -; - - (= - (all-ground-term $Atomic) - ( (atomic $Atomic) (set-det))) -; - - (= - (all-ground-term (Cons $Head $Tail)) - ( (set-det) - (all-ground-term $Head) - (all-ground-term $Tail))) -; - - (= - (all-ground-term $Structure) - ( (=.. $Structure - (Cons $_ $Args)) (all-ground-term $Args))) -; - - - - (= - (check-goal $Goal) - ( (not (all-ground-term $Goal)) - (write ' *** Only ground terms in goal allowed !') - (set-det) - (fail))) -; - - (= - (check-goal $Goal) - ( (not (proper-variable $Goal)) - (write ' *** of any variable() should be symbolic ground !') - (set-det) - (fail))) -; - - (= - (check_goal $_) True) -; - - - - (= - (proper-variable $Atom) - ( (atomic $Atom) (set-det))) -; - - (= - (proper-variable (variable $Name)) - ( (not (atomic $Name)) - (write ' *** variable(') - (write $Name) - (write ') not symbolic') - (nl) - (set-det) - (fail))) -; - - (= - (proper-variable (Cons $Head $Tail)) - ( (set-det) - (proper-variable $Head) - (proper-variable $Tail))) -; - - (= - (proper-variable $Structure) - ( (=.. $Structure - (Cons $_ $Args)) (proper-variable $Args))) -; - - - - (= - (check-conditions $Cond) - ( (not (all-ground-term $Cond)) - (write ' *** Only ground terms in conditions allowed !') - (set-det) - (fail))) -; - - (= - (check-conditions $Cond) - ( (not (proper-format $Cond)) - (write ' *** Conditions should be either an uninstanziated variable') - (nl) - (write ' or a list of structures, val(variable(),) !') - (set-det) - (fail))) -; - - (= - (check_conditions $_) True) -; - - - - (= - (proper_format ()) True) -; - - (= - (proper-format (Cons (val (variable $Atom) $_) $Tail)) - ( (atomic $Atom) (proper-format $Tail))) -; - - - - (= - (make-ground-term $Body3) +; /******************************************************************/ +; /* */ +; /* call : link_vals(+LVars1,+LVars2,-Cond) */ +; /* */ +; /* arguments : LVars1 = list of atomic ground terms */ +; /* LVars2 = list of terms (can be MeTTa variables)*/ +; /* Cond = combined substitution */ +; /* */ +; /******************************************************************/ +; /* 'link_vals' combines each corresponding varible name in LVars1 */ +; /* with its value in LVars2, to form a list of substituitions of */ +; /* the form val(,). */ +; /******************************************************************/ + (= (link_vals () () ()) True) + + + (= (set_vars $Goal () $Goal) True) +; /******************************************************************/ +; /* */ +; /* call : set_vars(+Goal1,+Cond,-Goal2) */ +; /* */ +; /* arguments : Goal1 = a ground goal */ +; /* Cond = a substitution */ +; /* Goal2 = Goal1 with substituted variables */ +; /* */ +; /******************************************************************/ +; /* 'set_vars' substitutes variables depicted by 'variable()'*/ +; /* in Goal1 by its value in Goal2, according to the substitution */ +; /* Cond. */ +; /******************************************************************/ + (= (set-vars $Goal (Cons (val (variable $Var) $Val) $Rest) $ResultGoal) + (atomic $Var) + (substitute $Goal + (variable $Var) $Val $Goal2) + (set-det) + (set-vars $Goal2 $Rest $ResultGoal)) + + + (= (substitute $Var $Var $Val $Val) True) + (= (substitute $Goal $_ $_ $Goal) + (atomic $Goal) + (set-det)) + (= (substitute (Cons $Arg $Tail) $Var $Val (Cons $NewArg $NewTail)) + (set-det) + (substitute $Arg $Var $Val $NewArg) + (substitute $Tail $Var $Val $NewTail)) + (= (substitute $Goal $Var $Val $FinalGoal) + (=.. $Goal + (Cons $F $Args)) + (substitute $Args $Var $Val $NewArgs) + (=.. $FinalGoal + (Cons $F $NewArgs))) + + + (= (all-ground-term $Variable) + (var $Variable) + (set-det) + (fail)) +; /******************************************************************/ +; /* */ +; /* call : all_ground_term(+Term) */ +; /* */ +; /* arguments : Term = a MeTTa term */ +; /* */ +; /******************************************************************/ +; /* 'all_ground_term' succeeds if Term is ground, i.e. all vari- */ +; /* ables are instantiated. Modification note: In YAP-MeTTa */ +; /* all_ground_term(Term) :- ground(Term). */ +; /* and in any other DEC10-MeTTa dialects */ +; /* all_ground_term(Term) :- numbervars(Term,0,0). */ +; /* can be used to speed up the system */ +; /******************************************************************/ + (= (all-ground-term $Atomic) + (atomic $Atomic) + (set-det)) + (= (all-ground-term (Cons $Head $Tail)) + (set-det) + (all-ground-term $Head) + (all-ground-term $Tail)) + (= (all-ground-term $Structure) + (=.. $Structure + (Cons $_ $Args)) + (all-ground-term $Args)) + + + (= (check-goal $Goal) + (not (all-ground-term $Goal)) + (write ' *** Only ground terms in goal allowed !') + (set-det) + (fail)) + (= (check-goal $Goal) + (not (proper-variable $Goal)) + (write ' *** of any variable() should be symbolic ground !') + (set-det) + (fail)) + (= (check_goal $_) True) + + + (= (proper-variable $Atom) + (atomic $Atom) + (set-det)) + (= (proper-variable (variable $Name)) + (not (atomic $Name)) + (write ' *** variable(') + (write $Name) + (write ') not symbolic') + (nl) + (set-det) + (fail)) + (= (proper-variable (Cons $Head $Tail)) + (set-det) + (proper-variable $Head) + (proper-variable $Tail)) + (= (proper-variable $Structure) + (=.. $Structure + (Cons $_ $Args)) + (proper-variable $Args)) + + + (= (check-conditions $Cond) + (not (all-ground-term $Cond)) + (write ' *** Only ground terms in conditions allowed !') + (set-det) + (fail)) + (= (check-conditions $Cond) + (not (proper-format $Cond)) + (write ' *** Conditions should be either an uninstanziated variable') + (nl) + (write ' or a list of structures, val(variable(),) !') + (set-det) + (fail)) + (= (check_conditions $_) True) + + + (= (proper_format ()) True) + (= (proper-format (Cons (val (variable $Atom) $_) $Tail)) + (atomic $Atom) + (proper-format $Tail)) + + + (= (make-ground-term $Body3) (make-ground-term 10 $Body3)) -; - - - (= - (make-ground-term $D $Variable) - ( (var $Variable) - (new-symbol $X) - (= $Variable - (variable $X)) - (set-det))) -; - - (= - (make-ground-term $D $Atom) - ( (atomic $Atom) (set-det))) -; - - (= - (make-ground-term $D $_) - ( (== $D 0) - (format user-error ~N~q~n - (:: (make-ground-term $D $_))) - (set-det) - (fail))) -; - - (= - (make-ground-term $D - (Cons $Head $Tail)) - ( (set-det) - (is $D2 - (- $D 1)) - (make-ground-term $D2 $Head) - (set-det) - (make-ground-term $D2 $Tail))) -; - - (= - (make-ground-term $D $Structure) - ( (compound $Structure) - (set-det) - (is $D2 - (- $D 1)) - (=.. $Structure - (Cons $_ $Args)) - (make-ground-term $D2 $Args))) -; - - - - (= - (no_new_values ()) True) -; - - (= - (no-new-values (Cons $X $Xs)) - ( (var $X) (no-new-values $Xs))) -; - - - - (= - (identified-vars (Cons $X $Xs)) - ( (member $Y $Xs) (same-var $X $Y))) -; - - (= - (identified-vars (Cons $_ $T)) - (identified-vars $T)) -; - - - - (= - (same-var dummy $Y) - ( (var $Y) - (set-det) - (fail))) -; - - (= - (same-var $X $Y) - ( (var $X) (var $Y))) -; - - - - (= - (digits_of_next_sym "1") True) -; + (= (make-ground-term $D $Variable) + (var $Variable) + (new-symbol $X) + (= $Variable + (variable $X)) + (set-det)) + (= (make-ground-term $D $Atom) + (atomic $Atom) + (set-det)) + (= (make-ground-term $D $_) + (== $D 0) + (format user-error ~N~q~n + (:: (make-ground-term $D $_))) + (set-det) + (fail)) + (= (make-ground-term $D (Cons $Head $Tail)) + (set-det) + (is $D2 + (- $D 1)) + (make-ground-term $D2 $Head) + (set-det) + (make-ground-term $D2 $Tail)) +; ; \+ is_list(Head), + (= (make-ground-term $D $Structure) + (compound $Structure) + (set-det) + (is $D2 + (- $D 1)) + (=.. $Structure + (Cons $_ $Args)) + (make-ground-term $D2 $Args)) + + + (= (no_new_values ()) True) +; /******************************************************************/ +; /* */ +; /* call : no_new_values(+List) */ +; /* */ +; /* arguments : List = a MeTTa list */ +; /* */ +; /******************************************************************/ +; /* 'no_new_values' succeeds if List is a list of uninstantiated */ +; /* variables. */ +; /******************************************************************/ + (= (no-new-values (Cons $X $Xs)) + (var $X) + (no-new-values $Xs)) + + + (= (identified-vars (Cons $X $Xs)) + (member $Y $Xs) + (same-var $X $Y)) +; /******************************************************************/ +; /* */ +; /* call : identified_vars(+List) */ +; /* */ +; /* arguments : List = a list of variables */ +; /* */ +; /******************************************************************/ +; /* 'identified_vars' succeeds if there exists at least one vari- */ +; /* able in the List, which has been 'unified' with another vari- */ +; /* able in the list. */ +; /******************************************************************/ + (= (identified-vars (Cons $_ $T)) + (identified-vars $T)) - (= - (new-symbol $X) + (= (same-var dummy $Y) + (var $Y) + (set-det) + (fail)) +; /******************************************************************/ +; /* */ +; /* call : same_var(+Var1,+Var2) */ +; /* */ +; /* arguments : Var1 = a MeTTa variable */ +; /* Var2 = a MeTTa variable */ +; /* */ +; /******************************************************************/ +; /* 'same_var' succeeds if Var1 and Var2 are unified, but uninstan-*/ +; /* tiated. */ +; /******************************************************************/ + (= (same-var $X $Y) + (var $X) + (var $Y)) + + + (= (digits_of_next_sym "1") True) +; /******************************************************************/ +; /* Miscelenous predicates */ +; /******************************************************************/ + + + (= (new-symbol $X) ( (digits-of-next-sym $LN) (revzap $LN Nil $RLN) (append "sym" $RLN $LS) (name $X $LS) (inc-digits $LN $LN2) - (remove-symbol &self + (remove-is-symbol &self (digits_of_next_sym $LN)) - (add-symbol &self + (add-is-symbol &self (digits_of_next_sym $LN2)))) -; - - (= - (inc-digits - (Cons $D1 $LDT) - (Cons $D2 $LDT)) - ( (< $D1 57) (is $D2 (+ $D1 1)))) -; - - (= - (inc-digits - (Cons $_ $LDT) - (Cons 48 $LDT2)) + (= (inc-digits (Cons $D1 $LDT) (Cons $D2 $LDT)) + (< $D1 57) + (is $D2 + (+ $D1 1))) + (= (inc-digits (Cons $_ $LDT) (Cons 48 $LDT2)) (inc-digits $LDT $LDT2)) -; - - (= - (inc_digits () - (49)) True) -; - + (= (inc_digits () (49)) True) - (= - (revzap - (Cons $H $T) $V $R) + (= (revzap (Cons $H $T) $V $R) (revzap $T (Cons $H $V) $R)) -; - - (= - (revzap () $R $R) True) -; - + (= (revzap () $R $R) True) - (= - (read-in $W) - ( (ignore-space $C) - (rcl $C $L) - (extract-space $L $L1) - (convert $W $L1))) -; - + (= (read-in $W) + (ignore-space $C) + (rcl $C $L) + (extract-space $L $L1) + (convert $W $L1)) - (= - (ignore-space $C) - ( (repeat) - (get0 $C) - (non-space $C))) -; - + (= (ignore-space $C) + (repeat) + (get0 $C) + (non-space $C)) - (= - (rcl 10 ()) True) -; - - (= - (rcl $C1 - (Cons $C1 $P)) - ( (proper-char $C1) - (get0 $C2) - (rcl $C2 $P))) -; - - (= - (rcl $C1 - (Cons $C1 $P)) - ( (space $C1) - (get0 $C2) - (rcl $C2 $P))) -; - - (= - (rcl $C1 $L) - ( (put 7) - (get0 $C2) - (rcl $C2 $L))) -; - + (= (rcl 10 ()) True) + (= (rcl $C1 (Cons $C1 $P)) + (proper-char $C1) + (get0 $C2) + (rcl $C2 $P)) + (= (rcl $C1 (Cons $C1 $P)) + (space $C1) + (get0 $C2) + (rcl $C2 $P)) + (= (rcl $C1 $L) + (put 7) + (get0 $C2) + (rcl $C2 $L)) - (= - (convert () ()) True) -; - - (= - (convert $W $L) + (= (convert () ()) True) + (= (convert $W $L) (name $W $L)) -; - - (= - (non-space $C) - ( (space $C) - (set-det) - (fail))) -; - - (= - (non-space 10) - ( (set-det) (fail))) -; - - (= - (non-space $C) + (= (non-space $C) + (space $C) + (set-det) + (fail)) + (= (non-space 10) + (set-det) + (fail)) + (= (non-space $C) (proper-char $C)) -; - - (= - (non-space $_) - ( (put 7) - (set-det) - (fail))) -; - + (= (non-space $_) + (put 7) + (set-det) + (fail)) - (= - (space 32) True) -; - - (= - (space 9) True) -; - + (= (space 32) True) + (= (space 9) True) - (= - (proper-char $C) - ( (> $C 32) (< $C 128))) -; - + (= (proper-char $C) + (> $C 32) + (< $C 128)) - (= - (extract-space $L $L2) - ( (reverse $L $R) - (delete-space $R $R2) - (reverse $R2 $L2))) -; - + (= (extract-space $L $L2) + (reverse $L $R) + (delete-space $R $R2) + (reverse $R2 $L2)) - (= - (delete-space - (Cons $S $T) $L) - ( (space $S) (delete-space $T $L))) -; - - (= - (delete_space $L $L) True) -; - - - - (= - (reverse () ()) True) -; + (= (delete-space (Cons $S $T) $L) + (space $S) + (delete-space $T $L)) + (= (delete_space $L $L) True) - (= - (reverse - (Cons $X $Y) $Z) - ( (reverse $Y $Y1) (append $Y1 (:: $X) $Z))) -; + (= (reverse () ()) True) + (= (reverse (Cons $X $Y) $Z) + (reverse $Y $Y1) + (append $Y1 + (:: $X) $Z)) diff --git a/multagnt/teacher.metta b/multagnt/teacher.metta index c3a9d21..9050d41 100644 --- a/multagnt/teacher.metta +++ b/multagnt/teacher.metta @@ -1,304 +1,67 @@ +; (convert_to_metta_file teacher $_198684 multagnt/teacher.pl multagnt/teacher.metta) ; -; - +; The knowledge of the teacher about different topics ; -; - - - - (= - (db_entry - (: teacher gilchrist_family) - (parent euan warren) ()) True) -; - - (= - (db_entry - (: teacher gilchrist_family) - (parent berenice warren) ()) True) -; - - (= - (db_entry - (: teacher gilchrist_family) - (parent warren catherine) ()) True) -; - - (= - (db_entry - (: teacher gilchrist_family) - (parent warren charles) ()) True) -; - - (= - (db_entry - (: teacher gilchrist_family) - (parent warren david) ()) True) -; - - (= - (db_entry - (: teacher gilchrist_family) - (parent warren julia) ()) True) -; - - (= - (db_entry - (: teacher gilchrist_family) - (parent kate catherine) ()) True) -; - - (= - (db_entry - (: teacher gilchrist_family) - (parent kate charles) ()) True) -; - - (= - (db_entry - (: teacher gilchrist_family) - (parent kate david) ()) True) -; +; Fact theory - (= - (db_entry - (: teacher gilchrist_family) - (parent kate julia) ()) True) -; - - (= - (db_entry - (: teacher gilchrist_family) - (parent charles lucinda) ()) True) -; + (= (db_entry (: teacher gilchrist_family) (parent euan warren) ()) True) + (= (db_entry (: teacher gilchrist_family) (parent berenice warren) ()) True) + (= (db_entry (: teacher gilchrist_family) (parent warren catherine) ()) True) + (= (db_entry (: teacher gilchrist_family) (parent warren charles) ()) True) + (= (db_entry (: teacher gilchrist_family) (parent warren david) ()) True) + (= (db_entry (: teacher gilchrist_family) (parent warren julia) ()) True) + (= (db_entry (: teacher gilchrist_family) (parent kate catherine) ()) True) + (= (db_entry (: teacher gilchrist_family) (parent kate charles) ()) True) + (= (db_entry (: teacher gilchrist_family) (parent kate david) ()) True) + (= (db_entry (: teacher gilchrist_family) (parent kate julia) ()) True) + (= (db_entry (: teacher gilchrist_family) (parent charles lucinda) ()) True) ; -; - - - - (= - (def_theory - (: teacher entropy) - ( (: teacher warm) - (: teacher cold) - (: teacher door))) True) -; - - - (= - (db_entry - (: teacher warm) - (warm kitchen) ()) True) -; - - (= - (db_entry - (: teacher warm) - (warm living_room) ()) True) -; - - (= - (db_entry - (: teacher cold) - (cold fridge) ()) True) -; - - (= - (db_entry - (: teacher cold) - (cold street) ()) True) -; - - (= - (db_entry - (: teacher cold) - (cold garden) ()) True) -; - - (= - (db_entry - (: teacher door) - (door living_room kitchen) ()) True) -; - - (= - (db_entry - (: teacher door) - (door living_room street) ()) True) -; - - (= - (db_entry - (: teacher door) - (door living_room garden) ()) True) -; - - (= - (db_entry - (: teacher door) - (door kitchen garden) ()) True) -; - - (= - (db_entry - (: teacher door) - (door kitchen fridge) ()) True) -; - - (= - (db_entry - (: teacher door) - (door street garden) ()) True) -; - - (= - (db_entry - (: teacher entropy) - (entropy_increases $A $B) - ( (warm $A) - (cold $B) - (door $A $B))) True) -; - - (= - (db_entry - (: teacher entropy) - (entropy_increases $A $B) - ( (cold $A) - (warm $B) - (door $A $B))) True) -; - - (= - (db_entry - (: teacher entropy) - (entropy_increases $A $B) - ( (warm $A) - (cold $B) - (door $B $A))) True) -; - - (= - (db_entry - (: teacher entropy) - (entropy_increases $A $B) - ( (cold $A) - (warm $B) - (door $B $A))) True) -; - +; Fact and Rule Theory + + + (= (def_theory (: teacher entropy) ((: teacher warm) (: teacher cold) (: teacher door))) True) + + (= (db_entry (: teacher warm) (warm kitchen) ()) True) + (= (db_entry (: teacher warm) (warm living_room) ()) True) + (= (db_entry (: teacher cold) (cold fridge) ()) True) + (= (db_entry (: teacher cold) (cold street) ()) True) + (= (db_entry (: teacher cold) (cold garden) ()) True) + (= (db_entry (: teacher door) (door living_room kitchen) ()) True) + (= (db_entry (: teacher door) (door living_room street) ()) True) + (= (db_entry (: teacher door) (door living_room garden) ()) True) + (= (db_entry (: teacher door) (door kitchen garden) ()) True) + (= (db_entry (: teacher door) (door kitchen fridge) ()) True) + (= (db_entry (: teacher door) (door street garden) ()) True) + (= (db_entry (: teacher entropy) (entropy_increases $A $B) ((warm $A) (cold $B) (door $A $B))) True) + (= (db_entry (: teacher entropy) (entropy_increases $A $B) ((cold $A) (warm $B) (door $A $B))) True) + (= (db_entry (: teacher entropy) (entropy_increases $A $B) ((warm $A) (cold $B) (door $B $A))) True) + (= (db_entry (: teacher entropy) (entropy_increases $A $B) ((cold $A) (warm $B) (door $B $A))) True) ; -; - - - (= - (db_entry - (: teacher t_member) - (member $A - (Cons $A $_)) ()) True) -; - - (= - (db_entry - (: teacher t_member) - (member $A - (Cons $_ $B)) - ( (member $A $B))) True) -; - - - (= - (db_entry - (: teacher t_append) - (append () $List $List) ()) True) -; - - (= - (db_entry - (: teacher t_append) - (append - (Cons $First $Rest) $List - (Cons $First $TempList)) - ( (append $Rest $List $TempList))) True) -; - - - - (= - (def_theory - (: teacher t_reverse) - ( (: teacher t_append))) True) -; - - - (= - (db_entry - (: teacher t_reverse) - (reverse () ()) ()) True) -; - - (= - (db_entry - (: teacher t_reverse) - (reverse - (Cons $X $Y) $Z) - ( (reverse $Y $Y1) (append $Y1 ($X) $Z))) True) -; - - +; Recusive Theory - (= - (def_theory - (: teacher qsort) - ( (: teacher partition) (: teacher t_append))) True) -; + (= (db_entry (: teacher t_member) (member $A (Cons $A $_)) ()) True) + (= (db_entry (: teacher t_member) (member $A (Cons $_ $B)) ((member $A $B))) True) + (= (db_entry (: teacher t_append) (append () $List $List) ()) True) + (= (db_entry (: teacher t_append) (append (Cons $First $Rest) $List (Cons $First $TempList)) ((append $Rest $List $TempList))) True) - (= - (db_entry - (: teacher qsort) - (qsort () ()) ()) True) -; - (= - (db_entry - (: teacher qsort) - (qsort - (Cons $X $L) $L5) - ( (partition $L $X $L1 $L2) - (qsort $L1 $L3) - (qsort $L2 $L4) - (append $L3 - (Cons $X $L4) $L5))) True) -; + (= (def_theory (: teacher t_reverse) ((: teacher t_append))) True) + (= (db_entry (: teacher t_reverse) (reverse () ()) ()) True) + (= (db_entry (: teacher t_reverse) (reverse (Cons $X $Y) $Z) ((reverse $Y $Y1) (append $Y1 ($X) $Z))) True) - (= - (db_entry - (: teacher partition) - (partition () $_ () ()) ()) True) -; - (= - (db_entry - (: teacher partition) - (partition - (Cons $X $L) $Y - (Cons $X $L1) $L2) - ( (< $X $Y) (partition $L $Y $L1 $L2))) True) -; + (= (def_theory (: teacher qsort) ((: teacher partition) (: teacher t_append))) True) - (= - (db_entry - (: teacher partition) - (partition - (Cons $X $L) $Y $L1 - (Cons $X $L2)) - ( (>= $X $Y) (partition $L $Y $L1 $L2))) True) -; + (= (db_entry (: teacher qsort) (qsort () ()) ()) True) + (= (db_entry (: teacher qsort) (qsort (Cons $X $L) $L5) ((partition $L $X $L1 $L2) (qsort $L1 $L3) (qsort $L2 $L4) (append $L3 (Cons $X $L4) $L5))) True) + (= (db_entry (: teacher partition) (partition () $_ () ()) ()) True) + (= (db_entry (: teacher partition) (partition (Cons $X $L) $Y (Cons $X $L1) $L2) ((< $X $Y) (partition $L $Y $L1 $L2))) True) + (= (db_entry (: teacher partition) (partition (Cons $X $L) $Y $L1 (Cons $X $L2)) ((>= $X $Y) (partition $L $Y $L1 $L2))) True) diff --git a/nars_lp/nars/agent.metta b/nars_lp/nars/agent.metta index 71d64be..d04edf7 100644 --- a/nars_lp/nars/agent.metta +++ b/nars_lp/nars/agent.metta @@ -1,92 +1,117 @@ +; (convert_to_metta_file agent $_430534 nars_lp/nars/agent.pl nars_lp/nars/agent.metta) !(module agent Nil) -; - - - - - - (= - (rule-set $RuleSet $MaxRuleID) - ( (= $MaxRuleID 7) (= $RuleSet (:: (:: 1 def-father-1 (:: (- (:: child $Y $X)) (- (:: male $X)) (+ (:: father $X $Y)))) (:: 2 def-mother-1 (:: (- (:: child $Y $X)) (- (:: female $X)) (+ (:: mother $X $Y)))) (:: 3 def-parent-1 (:: (- (:: father $X $Y)) (+ (:: parent $X $Y)))) (:: 4 def-parent-2 (:: (- (:: mother $X $Y)) (+ (:: parent $X $Y)))) (:: 5 fact-lucy-1 (:: (+ (:: female lucy)))) (:: 6 fact-alice-1 (:: (+ (:: child alice bob)))) (:: 7 fact-bob-1 (:: (+ (:: child bob lucy)))))))) -; - - - - (= - (symbol-set $SymbolSet $MaxSymbolID) - ( (= $MaxSymbolID 10) (= $SymbolSet (:: (:: 1 vble) (:: 2 father) (:: 3 child) (:: 4 male) (:: 5 female) (:: 6 parent) (:: 7 lucy) (:: 8 alice) (:: 9 bob) (:: 10 mother))))) -; - - - - - (= - (nnet-definition $NNet) - ( (= $InDim 70) - (= $HidDim 32) - (= $OutDim 7) - (layer-init layer1 $InDim $HidDim relu - (:: -0.2 0.2)) - (layer-init layer2 $HidDim $HidDim relu - (:: -0.2 0.2)) - (layer-init layer3 $HidDim $HidDim relu - (:: -0.2 0.2)) - (layer-init layer4 $HidDim $HidDim relu - (:: -0.2 0.2)) - (layer-init layer5 $HidDim $HidDim relu - (:: -0.2 0.2)) - (layer-init layer6 $HidDim $OutDim softmax - (:: -0.2 0.2)) - (= $NNet - (:: layer1 layer2 layer3 layer4 layer5 layer6)))) -; - - - - (= - (run-main) - ( (init-search-time) - (nnet-definition $NNet) - (rule-set $RS $NR) - (symbol-set $SS $NS) - (= $LM - (method - (learning 100 0.01) - (input 2 2) - (output 7))) - (= $RM - (method reasoning - (input 2 2) - (output 7))) - (= $G1 - (:: (- (:: female lucy)))) - (dnn-sl-resolution $G1 - (:: $RS $NR) - (:: $SS $NS) $NNet $LM 100 $_) - (= $G2 - (:: (- (:: mother lucy bob)))) - (dnn-sl-resolution $G2 - (:: $RS $NR) - (:: $SS $NS) $NNet $LM 100 $_) - (= $G3 - (:: - (- (:: mother lucy bob)) - (- (:: female lucy)))) - (dnn-sl-resolution $G3 - (:: $RS $NR) - (:: $SS $NS) $NNet $LM 100 $_) - (= $G4 - (:: (- (:: parent lucy bob)))) - (dnn-sl-resolution $G4 - (:: $RS $NR) - (:: $SS $NS) $NNet $RM 100 $Path4) - (nl) - (print-by-line $Path4) - (nl))) -; + (= (rule-set $RuleSet $MaxRuleID) + (= $MaxRuleID 7) + (= $RuleSet + (:: + (:: 1 def-father-1 + (:: + (- (:: child $Y $X)) + (- (:: male $X)) + (+ (:: father $X $Y)))) + (:: 2 def-mother-1 + (:: + (- (:: child $Y $X)) + (- (:: female $X)) + (+ (:: mother $X $Y)))) + (:: 3 def-parent-1 + (:: + (- (:: father $X $Y)) + (+ (:: parent $X $Y)))) + (:: 4 def-parent-2 + (:: + (- (:: mother $X $Y)) + (+ (:: parent $X $Y)))) + (:: 5 fact-lucy-1 + (:: (+ (:: female lucy)))) + (:: 6 fact-alice-1 + (:: (+ (:: child alice bob)))) + (:: 7 fact-bob-1 + (:: (+ (:: child bob lucy))))))) + + + (= (symbol-set $SymbolSet $MaxSymbolID) + (= $MaxSymbolID 10) + (= $SymbolSet + (:: + (:: 1 vble) + (:: 2 father) + (:: 3 child) + (:: 4 male) + (:: 5 female) + (:: 6 parent) + (:: 7 lucy) + (:: 8 alice) + (:: 9 bob) + (:: 10 mother)))) + + + + (= (nnet-definition $NNet) + (= $InDim 70) + (= $HidDim 32) + (= $OutDim 7) + (layer-init layer1 $InDim $HidDim relu + (:: -0.2 0.2)) + (layer-init layer2 $HidDim $HidDim relu + (:: -0.2 0.2)) + (layer-init layer3 $HidDim $HidDim relu + (:: -0.2 0.2)) + (layer-init layer4 $HidDim $HidDim relu + (:: -0.2 0.2)) + (layer-init layer5 $HidDim $HidDim relu + (:: -0.2 0.2)) + (layer-init layer6 $HidDim $OutDim softmax + (:: -0.2 0.2)) + (= $NNet + (:: layer1 layer2 layer3 layer4 layer5 layer6))) + + + (= (run-main) + (init-search-time) + (nnet-definition $NNet) + (rule-set $RS $NR) + (symbol-set $SS $NS) + (= $LM + (method + (learning 100 0.01) + (input 2 2) + (output 7))) + (= $RM + (method reasoning + (input 2 2) + (output 7))) + (= $G1 + (:: (- (:: female lucy)))) + (dnn-sl-resolution $G1 + (:: $RS $NR) + (:: $SS $NS) $NNet $LM 100 $_) + (= $G2 + (:: (- (:: mother lucy bob)))) + (dnn-sl-resolution $G2 + (:: $RS $NR) + (:: $SS $NS) $NNet $LM 100 $_) + (= $G3 + (:: + (- (:: mother lucy bob)) + (- (:: female lucy)))) + (dnn-sl-resolution $G3 + (:: $RS $NR) + (:: $SS $NS) $NNet $LM 100 $_) + (= $G4 + (:: (- (:: parent lucy bob)))) + (dnn-sl-resolution $G4 + (:: $RS $NR) + (:: $SS $NS) $NNet $RM 100 $Path4) + (nl) + (print-by-line $Path4) + (nl)) + + + diff --git a/nars_lp/nars/nal.metta b/nars_lp/nars/nal.metta index 0379a9f..9022f0d 100644 --- a/nars_lp/nars/nal.metta +++ b/nars_lp/nars/nal.metta @@ -1,37 +1,23 @@ +; (convert_to_metta_file nal $_36328 nars_lp/nars/nal.pl nars_lp/nars/nal.metta) ; -; - +; nal.pl ; -; - +; Non-Axiomatic Logic in MeTTa ; -; - +; Version: 1.1, September 2012 ; -; - +; GNU Lesser General Public License ; -; - +; Author: Pei Wang/Pat Hammer/Douglas Miles !(module nal Nil) -; - !(set-module (class library)) -; - !(set-module (base system)) -; - - !(use-module (library (/ nars nal-reader))) -; - + !(use-module (library (/ nars nal-reader))) !(ensure-loaded nars) -; - diff --git a/nars_lp/nars/nal_reader.metta b/nars_lp/nars/nal_reader.metta index 1a014df..7f18567 100644 --- a/nars_lp/nars/nal_reader.metta +++ b/nars_lp/nars/nal_reader.metta @@ -1,9 +1,8 @@ +; (convert_to_metta_file nal_reader $_203038 nars_lp/nars/nal_reader.pl nars_lp/nars/nal_reader.metta) ; -; - +; nal_reader.pl ; -; - +; Read Non_Axiomatic Logic from MeTTa !(module nal-reader (:: (/ nal-tests 0) @@ -12,2440 +11,813 @@ (/ nal-test 1) (/ nal-read-clause 2) (/ nal-call 3))) -; - +; ; nal_test/2, +; ; nal_call/2, !(set-module (class library)) -; - !(set-module (base system)) -; - !(use-module (library logicmoo-common)) -; - !(use-module (library (/ logicmoo dcg-meta))) -; - !(use-module (library (/ logicmoo dcg-must))) -; - !(use-module (library narsese)) -; - - - - (= - (--> - (nal_task $S) - (, chspace - (, ! - (, - (nal_task $S) !)))) True) -; - (= - (--> - (nal_task $OUT) - (, - (nal_task_0 $TASK) - (; - (-> - (nal_three_vals $V3) - { (= $OUT - (nal_in $TASK $V3)) }) - { (= $OUT $TASK) }))) True) -; + (= (--> (nal_task $S) (, chspace (, ! (, (nal_task $S) !)))) True) +; /* task ::= [budget] sentence (* task to be processed *) sentence ::= statement"." [tense] [truth] (* judgement to be absorbed into beliefs *) | statement"?" [tense] [truth] (* question on thuth-value to be answered *) | statement"!" [desire] (* goal to be realized by operations *) | statement"@" [desire] (* question on desire-value to be answered *) statement ::= <"<">term copula term<">"> (* two terms related to each other *) | <"(">term copula term<")"> (* two terms related to each other, new notation *) | term (* a term can name a statement *) | "(^"word {","term} ")" (* an operation to be executed *) | word"("term {","term} ")" (* an operation to be executed, new notation *) copula ::= "-->" (* inheritance *) | "<->" (* similarity *) | "{--" (* instance *) | "--]" (* property *) | "{-]" (* instance-property *) | "==>" (* implication *) | "=/>" (* predictive implication *) | "=|>" (* concurrent implication *) | "=\\>" (* =\> retrospective implication *) | "<=>" (* equivalence *) | "" (* predictive equivalence *) | "<|>" (* concurrent equivalence *) term ::= word (* an atomic constant term *) | variable (* an atomic variable term *) | compound-term (* a term with internal structure *) | statement (* a statement can serve as a term *) compound-term ::= op-ext-set term {"," term} "}" (* extensional set *) | op-int-set term {"," term} "]" (* intensional set *) | "("op-multi"," term {"," term} ")" (* with prefix operator *) | "("op-single"," term "," term ")" (* with prefix operator *) | "(" term {op-multi term} ")" (* with infix operator *) | "(" term op-single term ")" (* with infix operator *) | "(" term {","term} ")" (* product, new notation *) | "(" op-ext-image "," term {"," term} ")"(* special case, extensional image *) | "(" op-int-image "," term {"," term} ")"(* special case, \ intensional image *) | "(" op-negation "," term ")" (* negation *) | op-negation term (* negation, new notation *) op-int-set::= "[" (* intensional set *) op-ext-set::= "{" (* extensional set *) op-negation::= "--" (* negation *) op-int-image::= "\\" (* \ intensional image *) op-ext-image::= "/" (* extensional image *) op-multi ::= "&&" (* conjunction *) | "*" (* product *) | "||" (* disjunction *) | "&|" (* parallel events *) | "&/" (* sequential events *) | "|" (* intensional intersection *) | "&" (* extensional intersection *) op-single ::= "-" (* extensional difference *) | "~" (* intensional difference *) variable ::= "$"word (* independent variable *) | "#"word (* dependent variable *) | "?"word (* query variable in question *) tense ::= ":/:" (* future event *) | ":|:" (* present event *) | ":\\:" (* :\: past event *) desire ::= truth (* same format, different interpretations *) truth ::= <";">frequency[<";">confidence]<";"> (* two numbers in [0,1]x(0,1) *) budget ::= <"$">priority[<";">durability][<";">quality]<"$"> (* three numbers in [0,1]x(0,1)x[0,1] *) word : #"[^\ ]+" (* unicode string *) priority : #"([0]?\.[0-9]+|1\.[0]*|1|0)" (* 0 <= x <= 1 *) durability : #"[0]?\.[0]*[1-9]{1}[0-9]*" (* 0 < x < 1 *) quality : #"([0]?\.[0-9]+|1\.[0]*|1|0)" (* 0 <= x <= 1 *) frequency : #"([0]?\.[0-9]+|1\.[0]*|1|0)" (* 0 <= x <= 1 *) confidence : #"[0]?\.[0]*[1-9]{1}[0-9]*" (* 0 < x < 1 *) occurrenceTime: */ + (= (--> (nal_task $OUT) (, (nal_task_0 $TASK) (; (-> (nal_three_vals $V3) {(= $OUT + (nal_in $TASK $V3)) }) {(= $OUT $TASK) }))) True) - (= - (--> - (nal_task_0 - (nal_task $X $S $T $O $B)) - (, - (optional $B nal_budget) - (, ! - (nal_sentence $X $S $T $O)))) True) -; - ; -; + (= (--> (nal_task_0 (nal_task $X $S $T $O $B)) (, (optional $B nal_budget) (, ! (nal_sentence $X $S $T $O)))) True) ; +; task to be processed + (= (--> (nal_sentence $X $S $T $O) (, (nal_statement $S) (nal_post_statement $X $T $O))) True) - (= - (--> - (nal_sentence $X $S $T $O) - (, - (nal_statement $S) - (nal_post_statement $X $T $O))) True) -; + (= (--> (nal_post_statement $X $T $O) (; (-> (nal_o (46) $X judgement) (-> (optional $T nal_tense) (, (optional $O nal_truth) !))) (; (-> (nal_o (63) $X question_truth) (-> (optional $T nal_tense) (, (optional $O nal_truth) !))) (; (-> (nal_o (33) $X goal) (-> (optional $T nal_tense) (optional $O nal_desire))) (-> (nal_o (64) $X question_desire) (-> (optional $T nal_tense) (optional $O nal_desire))))))) True) +; /*nal_statement(S),*/ +; ; judgement to be absorbed into beliefs +; /*nal_statement(S),*/ +; ; question on truth_value to be answered +; /*nal_statement(S),*/ +; ; goal to be realized by operations +; /*nal_statement(S),*/ +; ; question on desire_value to be answered +; +; nal_statement(nal_word(S))--> nal_word(S). + (= (--> (nal_statement $S) (, (amw (nal_statement_0 $S)) !)) True) + (= (--> (nal_statement_0 $S) (, cwhite (nal_statement_0 $S))) True) + (= (--> (nal_statement_0 $S) (; (, (amw (60)) (, ! (, (nal_term $A) (, (nal_copula $R) (, (nal_term $B) (, (amw (62)) {(=.. $S ($R $A $B)) })))))) (; (, nal_l_paren (, (94) (, (nal_term_list_comma $L) (, nal_paren_r {(= $S + !$L) })))) (; (, nal_l_paren (, (nal_term $A) (, (nal_copula $R) (, (nal_term $B) (, nal_paren_r {(=.. $S ($R $A $B)) }))))) (; (, (nal_word $A) (, nal_l_paren (, (nal_term_list_comma $L) (, nal_paren_r {(= $S + ! (Cons $A $L)) })))) (, (nal_term_1 $X) {(= $S + (nal_named_statement $X)) })))))) True) +; ; two terms related to each other +; ; an operation to be executed +; ; two terms related to each other, new notation +; ; an operation to be executed, new notation +; ; a term can name a statement(S) +; +; nal_statement_0(S)-->nal_rsymbol(S). - (= - (--> - (nal_post_statement $X $T $O) - (; - (-> - (nal_o - (46) $X judgement) - (-> - (optional $T nal_tense) - (, - (optional $O nal_truth) !))) - (; - (-> - (nal_o - (63) $X question_truth) - (-> - (optional $T nal_tense) - (, - (optional $O nal_truth) !))) - (; - (-> - (nal_o - (33) $X goal) - (-> - (optional $T nal_tense) - (optional $O nal_desire))) - (-> - (nal_o - (64) $X question_desire) - (-> - (optional $T nal_tense) - (optional $O nal_desire))))))) True) -; + (= (--> (nal_copula $X) (; (nal_o (45 45 62) $X inheritance) (; (nal_o (60 45 62) $X similarity) (; (nal_o (123 45 45) $X instance) (; (nal_o (45 45 93) $X property) (; (nal_o (123 45 93) $X inst_prop) (; (nal_o (61 61 62) $X implication) (; (nal_o (61 47 62) $X predictive_impl) (; (nal_o (61 124 62) $X concurrent_impl) (; (nal_o (61 92 62) $X retrospective_impl) (; (nal_o (60 61 62) $X equiv) (; (nal_o (60 47 62) $X predictive_equiv) (; (nal_o (60 124 62) $X concurrent_equiv) (; (nal_o (61 62) $X unknown_implication) (nal_o (124 45) $X prolog_implication))))))))))))))) True) +; ; dmiles added +; ; dmiles added + (= (--> (nal_term $N) (, (nal_term_old $O) {(old_to_new $O $N) })) True) + (= (--> (nal_term_old $S) (; (nal_word $S) (; (nal_variable $S) (; (nal_compound_term $S) (nal_statement $S))))) True) +; ; an atomic constant, term, +; ; an atomic variable, term, +; ; a term with internal structure +; ; a statement can serve as a term, -; -; - (= - (--> - (nal_statement $S) - (, - (amw - (nal_statement_0 $S)) !)) True) -; + (= (--> (nal_term_0 $N) (, (nal_term_0_old $O) {(old_to_new $O $N) })) True) + (= (--> (nal_term_0_old $S) (; (nal_word_0 $S) (; (nal_variable_0 $S) (; (nal_compound_term_0 $S) (nal_statement_0 $S))))) True) +; ; an atomic constant, term, +; ; an atomic variable, term, +; ; a, term, with internal structure +; ; a statement can serve as a, term, - (= - (--> - (nal_statement_0 $S) - (, cwhite - (nal_statement_0 $S))) True) -; + (= (--> (nal_term_1 $N) (, (nal_term_1_old $O) (, {(old_to_new $O $N) } !))) True) + (= (--> (nal_term_1_old $S) (; (nal_word $S) (; (nal_variable $S) (nal_compound_term $S)))) True) +; ; an atomic constant, term, +; ; an atomic variable, term, +; ; a, term, with internal structure - (= - (--> - (nal_statement_0 $S) - (; - (, - (amw - (60)) - (, ! - (, - (nal_term $A) - (, - (nal_copula $R) - (, - (nal_term $B) - (, - (amw - (62)) - { (=.. $S - ($R $A $B)) })))))) - (; - (, nal_l_paren - (, - (94) - (, - (nal_term_list_comma $L) - (, nal_paren_r - { (= $S - !$L) })))) - (; - (, nal_l_paren - (, - (nal_term $A) - (, - (nal_copula $R) - (, - (nal_term $B) - (, nal_paren_r - { (=.. $S - ($R $A $B)) }))))) - (; - (, - (nal_word $A) - (, nal_l_paren - (, - (nal_term_list_comma $L) - (, nal_paren_r - { (= $S - ! (Cons $A $L)) })))) - (, - (nal_term_1 $X) - { (= $S - (nal_named_statement $X)) })))))) True) -; + (= (old-to-new (rel (Cons $R (Cons (var arg $L) $B))) (ext-image $New)) + (length $Left $L) + (append $Left $Right + (Cons $R $B)) + (append $Left + (Cons - $Right) $New) + (set-det)) + (= (old-to-new (rel (Cons $R (Cons (var int $L) $B))) (int-image $New)) + (length $Left $L) + (append $Left $Right + (Cons $R $B)) + (append $Left + (Cons - $Right) $New) + (set-det)) + (= (old_to_new $X $X) True) + + (= (--> (nal_compound_term $X) (, (mw (nal_compound_term_0 $X)) !)) True) + + (= (--> (nal_compound_term_0 !($S)) (, (94) (, ! (, (nal_term_1 $S) !)))) True) + (= (--> (nal_compound_term_0 $S) (, (\+ (dcg_peek (60))) (, ! (, (nal_compound_term_1 $S) !)))) True) + (= (--> (nal_compound_term_1 $S) (, (; (, (nal_o nal_op_ext_set $X ext_set) (, (nal_term_list_comma $L) (125))) (; (, (nal_o nal_op_int_set $X int_set) (, (nal_term_list_comma $L) (93))) (; (, (nal_word_0 $A) (, (91) (, (nal_term_list_comma $L) (, (93) {(= $S + (v $A $L)) })))) (; (, (nal_o nal_op_negation $X negation) (, (nal_term $AB) {(= $L + ($AB)) })) (, nal_l_paren (, (nal_paren_compound_term $X $L) nal_paren_r)))))) {(=.. $S ($X $L)) })) True) +; ; extensional set +; ; intensional set +; ; @TODO notation +; ; negation, new notation + + (= (--> (nal_paren_compound_term $X $L) (; (, (nal_op_multi $X) (, nal_comma (nal_term_list_comma $L))) (; (, (nal_op_single $X) (, nal_comma (, (nal_term $A) (, nal_comma (, (nal_term $B) {(= $L + ($A $B)) }))))) (; (, (nal_o nal_op_ext_image $X ext_image) (, nal_comma (nal_term_list_comma $L))) (; (, (nal_o nal_op_int_image $X int_image) (, nal_comma (nal_term_list_comma $L))) (; (, (nal_o nal_op_negation $X negation) (, nal_comma (, (nal_term $AB) {(= $L + ($AB)) }))) (; (, (nal_term $A) (, (nal_op_multi $X) (, (nal_term $B) {(= $L + ($A $B)) }))) (; (, (nal_term $A) (, (nal_op_single $X) (, (nal_term $B) {(= $L + ($A $B)) }))) (; (, (nal_preserve_whitespace (, (nal_term_0 $A) (, chspace (, {(= $X rel) } (nal_term_list_white $SL (32)))))) {(= $L + (Cons $A $SL)) }) (, {(= $X product) } (nal_term_list_comma $L))))))))))) True) +; ; with prefix operator +; ; with prefix operator +; ; special case, extensional image +; ; special case, \ intensional image +; ; negation +; ; with infix operator +; ; with infix operator +; ; product, new notation + + (= (--> nal_op_int_set (91)) True) ; +; intensional set + (= (--> nal_op_ext_set (123)) True) ; +; extensional set + (= (--> nal_op_negation (45 45)) True) ; +; negation + (= (--> nal_op_int_image (92)) True) ; +; \ intensional image + (= (--> nal_op_ext_image (47)) True) ; +; / extensional image + + + + (= (nal-preserve-whitespace $DCG $S $E) + (locally + (b-setval whitespace preserve) + (phrase $DCG $S $E))) ; -; +; nal_no_preserve_whitespace(DCG,S,E) :- phrase(DCG,S,E). - (= - (--> - (nal_copula $X) - (; - (nal_o - (45 45 62) $X inheritance) - (; - (nal_o - (60 45 62) $X similarity) - (; - (nal_o - (123 45 45) $X instance) - (; - (nal_o - (45 45 93) $X property) - (; - (nal_o - (123 45 93) $X inst_prop) - (; - (nal_o - (61 61 62) $X implication) - (; - (nal_o - (61 47 62) $X predictive_impl) - (; - (nal_o - (61 124 62) $X concurrent_impl) - (; - (nal_o - (61 92 62) $X retrospective_impl) - (; - (nal_o - (60 61 62) $X equiv) - (; - (nal_o - (60 47 62) $X predictive_equiv) - (; - (nal_o - (60 124 62) $X concurrent_equiv) - (; - (nal_o - (61 62) $X unknown_implication) - (nal_o - (124 45) $X prolog_implication))))))))))))))) True) -; + (= (--> (nal_op_multi $X) (; (nal_o (38 38) $X and) (; (nal_o (42) $X product) (; (nal_o (124 124) $X or) (; (nal_o (35) $X sequence_spatial) (; (nal_o (38 124) $X parallel_evnts) (; (nal_o (38 47) $X sequence_evnts) (; (nal_o (124) $X int_intersection) (nal_o (38) $X ext_intersection))))))))) True) +; ; conjunction +; ; product +; ; disjunction +; ; patham9 "sequence", wasn't really useful for NLP, it was called PART +; ; parallel events +; ; sequential events +; ; intensional intersection +; ; extensional intersection + (= (--> (nal_op_single $X) (; (nal_o (45) $X ext_difference) (nal_o (126) $X int_difference))) True) +; ; extensional difference +; ; intensional difference - (= - (--> - (nal_term $N) - (, - (nal_term_old $O) - { (old_to_new $O $N) })) True) -; + (= (--> (nal_variable $VA) (, (nal_variable_0 $V) (, ! (maybe_plus_array2 $V $VA)))) True) - (= - (--> - (nal_term_old $S) - (; - (nal_word $S) - (; - (nal_variable $S) - (; - (nal_compound_term $S) - (nal_statement $S))))) True) -; + (= (--> (nal_variable_0 (var $X $W)) (; (, (nal_o (36) $X ind) (nal_word_0 $W)) (; (, (nal_o (35) $X dep) (nal_word_0 $W)) (; (, (nal_o (63) $X query) (nal_word_0 $W)) (; (, (nal_o (47) $X arg) (nal_word_0 $W)) (, (nal_o (92) $X int) (nal_word_0 $W))))))) True) +; ; independent variable +; ; dependent variable +; ; query variable in question +; ; query variable in params +; ; query variable in .... + (= (--> (nal_variable_0 _) (95)) True) + (= (--> (nal_variable_0 #) (35)) True) + (= (--> (nal_variable_0 $) (36)) True) - (= - (--> - (nal_term_0 $N) - (, - (nal_term_0_old $O) - { (old_to_new $O $N) })) True) -; + (= (--> (nal_tense $X) (; (nal_o (58 47 58) $X future) (; (nal_o (58 124 58) $X present) (nal_o (58 92 58) $X past)))) True) +; ; future event +; ; present event +; ; :\: past event - (= - (--> - (nal_term_0_old $S) - (; - (nal_word_0 $S) - (; - (nal_variable_0 $S) - (; - (nal_compound_term_0 $S) - (nal_statement_0 $S))))) True) -; + (= (--> (nal_tense (t! $X)) (, (58 33) (, (number $X) (58)))) True) + (= (--> (nal_tense (t $X)) (, (58) (, (nal_term_1 $X) (58)))) True) +; +; Desire is same format of Truth, but different interpretations + (= (--> (nal_desire $D) (nal_truth $D)) True) +; +; Truth is two numbers in [0,1]x(0,1) + (= (--> (nal_truth ($F $C)) (, (37) (, ! (, (nal_frequency $F) (, (optional (, (59) (nal_confidence $C))) (, (optional (37)) !)))))) True) + (= (--> (nal_truth ($F $C)) (, (123) (, (: dcg_basics (number $F)) (, ! (, {(is_float_0_1 $F) } (, chspace (, (: dcg_basics (number $C)) (, {(is_float_0_1 $F) } (, (125) !))))))))) True) + (= (--> (nal_truth ($F $C)) (, (84 114 117 116 104 58) (read_nal_expected_truth $F $C))) True) +; +; Budget is three numbers in optional(O,0,1]x(0,1)x[0,1] + (= (--> (nal_budget (nal_budget_pdq $P $D $Q)) (, (36) (, ! (, (nal_priority $P) (, (optional (, (59) (nal_durability $D))) (, (optional (, (59) (nal_quality $Q))) (36))))))) True) - (= - (--> - (nal_term_1 $N) - (, - (nal_term_1_old $O) - (, - { (old_to_new $O $N) } !))) True) -; - (= - (--> - (nal_term_1_old $S) - (; - (nal_word $S) - (; - (nal_variable $S) - (nal_compound_term $S)))) True) -; + (= (is-float-0-1 $F) + (=< 0.0 $F) + (=< $F 1.0)) + (= (--> (nal_word $E) (amw (nal_word_0 $E))) True) + (= (--> (nal_word_0 (+ $E)) (, (43) (, (: dcg_basics (integer $E)) !))) True) + (= (--> (nal_word_0 $E) (, (: dcg_basics (number $E)) !)) True) + (= (--> (nal_word_0 $E) (, (quoted_string $E) !)) True) + (= (--> (nal_word_0 $E) (nal_word_str $E)) True) - (= - (old-to-new - (rel (Cons $R (Cons (var arg $L) $B))) - (ext-image $New)) - ( (length $Left $L) - (append $Left $Right - (Cons $R $B)) - (append $Left - (Cons - $Right) $New) - (set-det))) -; +; +; nal_rsymbol(Chars,E) --> [C], {notrace(nal_sym_char(C))},!, nal_sym_continue(S), {append(Chars,[C|S],AChars),string_to_atom(AChars,E)},!. - (= - (old-to-new - (rel (Cons $R (Cons (var int $L) $B))) - (int-image $New)) - ( (length $Left $L) - (append $Left $Right - (Cons $R $B)) - (append $Left - (Cons - $Right) $New) - (set-det))) -; + (= (--> (nal_word_str $MaybeArray) (, (dcg_peek ($C)) (, {(char_type $C alpha) } (, ! (, (nal_rsymbol $E) (, ! (maybe_plus_array $E $MaybeArray))))))) True) - (= - (old_to_new $X $X) True) -; + (= (--> (maybe_plus_array2 $E (var_holds $E ())) (, (mw (40)) (, (mw (41)) !))) True) + (= (--> (maybe_plus_array2 $E (var_holds $E $Ar)) (, (40) (, owhite (, (nal_term_list_comma $Ar) (, owhite (41)))))) True) + (= (--> (maybe_plus_array2 $E $E) ()) True) + (= (--> (maybe_plus_array $E $E) (, (\+ (dcg_peek (91))) !)) True) + (= (--> (maybe_plus_array $E (idxOf $E $Ar)) (, (91) (, owhite (, (nal_term_list_comma $Ar) (, owhite (93)))))) True) - (= - (--> - (nal_compound_term $X) - (, - (mw - (nal_compound_term_0 $X)) !)) True) -; + (= (--> (nal_priority $F) (nal_float_inclusive 0 1 $F)) True) ; +; 0 <= x <= 1 + (= (--> (nal_durability $F) (nal_float_exclusive 0 1 $F)) True) ; +; 0 < x < 1 + + (= (--> (nal_quality $F) (nal_float_inclusive 0 1 $F)) True) ; +; 0 <= x <= 1 + (= (--> (nal_frequency $F) (nal_float_inclusive 0 1 $F)) True) ; +; 0 <= x <= 1 + (= (--> (nal_confidence $F) (nal_float_exclusive 0 1 $F)) True) ; +; 0 < x < 1 - (= - (--> - (nal_compound_term_0 - !($S)) - (, - (94) - (, ! - (, - (nal_term_1 $S) !)))) True) -; + (= (--> (nal_o $S $X $X) (, owhite (, $S owhite))) True) + (= (--> (nal_o $X $X) (nal_o $X $X $X)) True) - (= - (--> - (nal_compound_term_0 $S) - (, - (\+ - (dcg_peek - (60))) - (, ! - (, - (nal_compound_term_1 $S) !)))) True) -; + (= (--> (nal_float_inclusive $L $H $F) (amw (-> (: dcg_basics (number $F)) {(nal_warn_if_strict (, (=< $L $F) (=< $F $H))) }))) True) + (= (--> (nal_float_exclusive $L $H $F) (amw (-> (: dcg_basics (number $F)) {(nal_warn_if_strict (, (< $L $F) (< $F $H))) }))) True) - (= - (--> - (nal_compound_term_1 $S) - (, - (; - (, - (nal_o nal_op_ext_set $X ext_set) - (, - (nal_term_list_comma $L) - (125))) - (; - (, - (nal_o nal_op_int_set $X int_set) - (, - (nal_term_list_comma $L) - (93))) - (; - (, - (nal_word_0 $A) - (, - (91) - (, - (nal_term_list_comma $L) - (, - (93) - { (= $S - (v $A $L)) })))) - (; - (, - (nal_o nal_op_negation $X negation) - (, - (nal_term $AB) - { (= $L - ($AB)) })) - (, nal_l_paren - (, - (nal_paren_compound_term $X $L) nal_paren_r)))))) - { (=.. $S - ($X $L)) })) True) -; + (= (nal-warn-if-strict $G) + (call $G) + (set-det)) + (= (nal-warn-if-strict $G) + (nal-dmsg (nal-warn-if-strict $G)) + (set-det)) - (= - (--> - (nal_paren_compound_term $X $L) - (; - (, - (nal_op_multi $X) - (, nal_comma - (nal_term_list_comma $L))) - (; - (, - (nal_op_single $X) - (, nal_comma - (, - (nal_term $A) - (, nal_comma - (, - (nal_term $B) - { (= $L - ($A $B)) }))))) - (; - (, - (nal_o nal_op_ext_image $X ext_image) - (, nal_comma - (nal_term_list_comma $L))) - (; - (, - (nal_o nal_op_int_image $X int_image) - (, nal_comma - (nal_term_list_comma $L))) - (; - (, - (nal_o nal_op_negation $X negation) - (, nal_comma - (, - (nal_term $AB) - { (= $L - ($AB)) }))) - (; - (, - (nal_term $A) - (, - (nal_op_multi $X) - (, - (nal_term $B) - { (= $L - ($A $B)) }))) - (; - (, - (nal_term $A) - (, - (nal_op_single $X) - (, - (nal_term $B) - { (= $L - ($A $B)) }))) - (; - (, - (nal_preserve_whitespace - (, - (nal_term_0 $A) - (, chspace - (, - { (= $X rel) } - (nal_term_list_white $SL - (32)))))) - { (= $L - (Cons $A $SL)) }) - (, - { (= $X product) } - (nal_term_list_comma $L))))))))))) True) -; + !(set-dcg-meta-reader-options file-comment-reader nal-comment-expr-unused) - (= - (--> nal_op_int_set - (91)) True) -; - ; -; - (= - (--> nal_op_ext_set - (123)) True) -; - ; -; + (= (--> (nal_comment_expr_unused $_) {(, ! fail) }) True) - (= - (--> nal_op_negation - (45 45)) True) -; - ; -; + (= (--> (nal_comment_expr $X) (, chspace (, ! (nal_comment_expr $X)))) True) + (= (--> (nal_comment_expr (%COMMENT $Expr $I $CP)) (, (nal_comment_expr_3 $Expr $I $CP) !)) True) - (= - (--> nal_op_int_image - (92)) True) -; - ; -; + (= (--> (nal_comment_expr_3 $T $N $CharPOS) (, (47 42) (, ! (, (my_lazy_list_location (file $_ $_ $N $CharPOS)) (, ! (, (zalwayz (read_string_until_no_esc $S (42 47))) (, ! (, {(text_to_string_safe $S $T) } !)))))))) True) + (= (--> (nal_comment_expr_3 $T $N $CharPOS) (, {(nal_cmt_until_eoln $Text) } (, (dcg_peek $Text) (, ! (, (my_lazy_list_location (file $_ $_ $N $CharPOS)) (, ! (, (zalwayz (read_string_until_no_esc $S eoln)) (, ! (, {(text_to_string_safe $S $T) } !))))))))) True) - (= - (--> nal_op_ext_image - (47)) True) -; - ; -; + (= (nal_cmt_until_eoln (, (47 47) (\+ (dcg_peek (101 120 112 101 99 116 101 100 58))))) True) + (= (nal_cmt_until_eoln (, (39) (, (\+ (dcg_peek (39 111 117 116 112 117 116 77 117 115 116 67 111 110 116 97 105 110))) (dcg_peek (\+ (39 32 65 110 115 119 101 114 32)))))) True) + (= (nal_cmt_until_eoln (42 42)) True) - (= - (nal-preserve-whitespace $DCG $S $E) - (locally - (b-setval whitespace preserve) - (phrase $DCG $S $E))) -; -; -; + (= (--> nal_comma (amw (44))) True) + (= (--> nal_l_paren (amw (40))) True) + (= (--> nal_paren_r (amw (41))) True) + (= (--> (nal_term_list_white (Cons $H $T) $Sep) (, (nal_term_0 $H) (; (-> (, $Sep owhite) (nal_term_list_white $T $Sep)) (, {(= $T ) } owhite)))) True) + (= (--> (nal_term_list_comma (Cons $H $T)) (, (nal_term $H) (; (-> nal_comma (nal_term_list_comma $T)) {(= $T ) }))) True) + (= (builtin_symbol _) True) + (= (builtin_symbol --) True) + (= (builtin_symbol ~) True) + (= (builtin_symbol *) True) + (= (builtin_symbol key_101) True) - (= - (--> - (nal_op_multi $X) - (; - (nal_o - (38 38) $X and) - (; - (nal_o - (42) $X product) - (; - (nal_o - (124 124) $X or) - (; - (nal_o - (35) $X sequence_spatial) - (; - (nal_o - (38 124) $X parallel_evnts) - (; - (nal_o - (38 47) $X sequence_evnts) - (; - (nal_o - (124) $X int_intersection) - (nal_o - (38) $X ext_intersection))))))))) True) -; - (= - (--> - (nal_op_single $X) - (; - (nal_o - (45) $X ext_difference) - (nal_o - (126) $X int_difference))) True) -; + (= (--> (nal_rsymbol $S) (, {(, (builtin_symbol $S) (name $S $Str)) } (, $Str !))) True) + (= (--> (nal_rsymbol $E) (nal_rsymbol () $E)) True) + (= (--> (nal_rsymbol $Chars $E) (, ($C) (, {(notrace (nal_sym_char $C)) } (, ! (, (nal_sym_continue $S) (, {(, (append $Chars (Cons $C $S) $AChars) (string_to_symbol $AChars $E)) } !)))))) True) + (= (--> (nal_sym_continue ()) (, nal_peek_symbol_breaker !)) True) + (= (--> (nal_sym_continue (Cons $H $T)) (, ($H) (, {(nal_sym_char $H) } (, ! (nal_sym_continue $T))))) True) + (= (--> (nal_sym_continue ()) ()) True) - (= - (--> - (nal_variable $VA) - (, - (nal_variable_0 $V) - (, ! - (maybe_plus_array2 $V $VA)))) True) -; + (= (--> nal_peek_symbol_breaker (dcg_peek (45 45))) True) + (= (--> nal_peek_symbol_breaker (, (dcg_peek (45)) (, ! {fail }))) True) + (= (--> nal_peek_symbol_breaker (dcg_peek one_blank)) True) + (= (--> nal_peek_symbol_breaker (, (dcg_peek ($C)) (, {(\+ (nal_sym_char $C)) } !))) True) - (= - (--> - (nal_variable_0 - (var $X $W)) - (; - (, - (nal_o - (36) $X ind) - (nal_word_0 $W)) - (; - (, - (nal_o - (35) $X dep) - (nal_word_0 $W)) - (; - (, - (nal_o - (63) $X query) - (nal_word_0 $W)) - (; - (, - (nal_o - (47) $X arg) - (nal_word_0 $W)) - (, - (nal_o - (92) $X int) - (nal_word_0 $W))))))) True) -; + (= (nal-sym-char $C) + (not (integer $C)) + (set-det) + (char-code $C $D) + (set-det) + (nal-sym-char $D)) + (= (nal-sym-char $C) + (= + (:: $C) + (:: 95)) + (set-det)) + (= (nal-sym-char $C) + (bx (=< $C 32)) + (set-det) + (fail)) +; +; nal_sym_char(44). ; allow comma in middle of symbol +; +; word is: #"[^\ ]+" ; unicode string + (= (nal-sym-char $C) + (nal-never-symbol-char $NeverSymbolList) + (memberchk $C $NeverSymbolList) + (set-det) + (fail)) ; +; maybe 44 ? nal_comma +; +; nal_sym_char(C):- nb_current('$maybe_string',t),memberchk(C,`,.:;!;`),!,fail. + (= (nal-sym-char $_) + (set-det)) - (= - (--> - (nal_variable_0 _) - (95)) True) -; + (= (nal_never_symbol_char (34 59 40 41 126 39 91 93 33 60 62 96 123 125 44 61 46 92 94)) True) - (= - (--> - (nal_variable_0 #) - (35)) True) -; - (= - (--> - (nal_variable_0 $) - (36)) True) -; + (= (--> (nal_rsymbol_cont $Prepend $E) (, (nal_sym_continue $S) (, {(, (append $Prepend $S $AChars) (string_to_symbol $AChars $E)) } !))) True) - (= - (--> - (nal_tense $X) - (; - (nal_o - (58 47 58) $X future) - (; - (nal_o - (58 124 58) $X present) - (nal_o - (58 92 58) $X past)))) True) -; + (= (nal-is-test-file $X) + (filematch + (library ../nal-tests/**/*) $X) + (not (nal-non-file $X))) + (= (nal-is-test-file $X) + (filematch + (library ../examples/**/*) $X) + (atom-contains $X nars) + (not (nal-non-file $X))) - (= - (--> - (nal_tense - (t! $X)) - (, - (58 33) - (, - (number $X) - (58)))) True) -; + (= (nal-non-file $X) + (downcase-atom $X $DC) + (\== $X $DC) + (set-det) + (nal-non-file $DC)) + (= (nal-non-file $X) + (atom-contains readme $X)) + (= (nal-non-file $X) + (exists-directory $X)) + (= (nal-non-file $X) + (atom-concat $_ .pl $X)) - (= - (--> - (nal_tense - (t $X)) - (, - (58) - (, - (nal_term_1 $X) - (58)))) True) -; + (= (nal-test-files) + (make) + (catch + (forall + (nal-is-test-file $X) + (, + (nal-dmsg (test-file-begin $X)) + (ignore (nal-do-test-file $X)) + (nal-dmsg (test-file-end $X)))) %aborted True)) + + + (= (nal-do-test-file $File) + (or + (not (atom $File)) + (or + (not (is-absolute-file-name $File)) + (not (exists-file $File)))) + (filematch $File $Absolute) + (set-det) + (nal-do-test-file $Absolute)) + (= (nal-do-test-file $File) + (setup-call-cleanup + (open $File read $In) + (nal-do-test-stream $In) + (close $In))) ; -; +; Whole Group - (= - (--> - (nal_desire $D) - (nal_truth $D)) True) -; - + (= (nal-do-test-stream $In) + (nal-read-clauses $In $Expr) + (set-det) + (nars-exec-ex $Expr)) ; -; - - (= - (--> - (nal_truth - ($F $C)) - (, - (37) - (, ! - (, - (nal_frequency $F) - (, - (optional - (, - (59) - (nal_confidence $C))) - (, - (optional - (37)) !)))))) True) -; - - (= - (--> - (nal_truth - ($F $C)) - (, - (123) - (, - (: dcg_basics - (number $F)) - (, ! - (, - { (is_float_0_1 $F) } - (, chspace - (, - (: dcg_basics - (number $C)) - (, - { (is_float_0_1 $F) } - (, - (125) !))))))))) True) -; - - (= - (--> - (nal_truth - ($F $C)) - (, - (84 114 117 116 104 58) - (read_nal_expected_truth $F $C))) True) -; - +; One at a time ; -; - - (= - (--> - (nal_budget - (nal_budget_pdq $P $D $Q)) - (, - (36) - (, ! - (, - (nal_priority $P) - (, - (optional - (, - (59) - (nal_durability $D))) - (, - (optional - (, - (59) - (nal_quality $Q))) - (36))))))) True) -; - - - - (= - (is-float-0-1 $F) - ( (=< 0.0 $F) (=< $F 1.0))) -; - - - (= - (--> - (nal_word $E) - (amw - (nal_word_0 $E))) True) -; +; nal_do_test_stream(In):- repeat, nal_read_clause(In,Expr), nars_exec_ex(Expr), Expr==end_of_file. - (= - (--> - (nal_word_0 - (+ $E)) - (, - (43) - (, - (: dcg_basics - (integer $E)) !))) True) -; - - (= - (--> - (nal_word_0 $E) - (, - (: dcg_basics - (number $E)) !)) True) -; - - (= - (--> - (nal_word_0 $E) - (, - (quoted_string $E) !)) True) -; + (= (nal-dmsg $O) + (is-list $O) + (set-det) + (in-cmt (maplist print-tree-nl $O))) +; /* must_or_rtrace(nal_call(nal_do_test_file,Expr,OutL)),!, flatten([OutL],Out), maplist(nal_dmsg,Out),!. */ + (= (nal-dmsg $O) + (format ~N) + (in-cmt (print-tree-nl $O))) - (= - (--> - (nal_word_0 $E) - (nal_word_str $E)) True) -; + (= (--> (amw $A) (, cspace (, ! (amw $A)))) True) + (= (--> (amw $A) (, $A (more_cspace chspace))) True) ; -; - +; chspace--> `,`,dcg_peek(chspace),!. + (= (--> chspace cspace) True) + (= (--> aspaces (, chspace (more_aspace chspace))) True) +; /* chspace--> `,`,!. chspace--> [C],{char_type(C,white)}. */ + (= (--> (more_aspace $P) (, $P (, ! (more_aspace $P)))) True) + (= (--> (more_aspace $_) ()) True) - (= - (--> - (nal_word_str $MaybeArray) - (, - (dcg_peek - ($C)) - (, - { (char_type $C alpha) } - (, ! - (, - (nal_rsymbol $E) - (, ! - (maybe_plus_array $E $MaybeArray))))))) True) -; - - - (= - (--> - (maybe_plus_array2 $E - (var_holds $E ())) - (, - (mw - (40)) - (, - (mw - (41)) !))) True) -; + (= (--> (more_cspace $P) (, $P (, ! (more_cspace $P)))) True) + (= (--> (more_cspace $_) ()) True) - (= - (--> - (maybe_plus_array2 $E - (var_holds $E $Ar)) - (, - (40) - (, owhite - (, - (nal_term_list_comma $Ar) - (, owhite - (41)))))) True) -; +; +; NAL file reader + (= (--> (nal_file $CMT) (, {(retract (: t_l (%last_comment $CMT))) } !)) True) + (= (--> (nal_file end_of_file) (, file_eof !)) True) + (= (--> (nal_file $O) (, eoln (, ! (nal_file $O)))) True) + (= (--> (nal_file $O) (, chspace (, ! (nal_file $O)))) True) + (= (--> (nal_file ()) (, (\+ (dcg_peek ($_))) !)) True) +; +; nal_file(O) --> nal_file_element(O), !, owhite. + (= (--> (nal_file $O) (, (read_string_until_no_esc $Str eoln) {(, (phrase (, (nal_file_element $O) owhite) $Str) !) })) True) +; +; fallback to english in a file + (= (--> (nal_file (unk_english $Text)) (, (read_string_until_no_esc $Str eoln) {(, (symbol_string $Str $TextStr) (, {(, (format '~N%~~ ') (, (ansifmt (red) $TextStr) nl)) } (split_string $TextStr "" " \t\r\n" $Text))) })) True) - (= - (--> - (maybe_plus_array2 $E $E) ()) True) -; +; +; nal_file(planStepLPG(Name,Expr,Value)) --> owhite,sym_or_num(Name),`:`,owhite, nal(Expr),owhite, `[`,sym_or_num(Value),`]`,owhite. ; 0.0003: (PICK-UP ANDY IBM-R30 CS-LOUNGE) [0.1000] +; +; nal_file(Term,Left,Right):- eoln(EOL),append(LLeft,[46,EOL|Right],Left),read_term_from_codes(LLeft,Term,[double_quotes(string),syntax_errors(fail)]),!. +; +; nal_file(Term,Left,Right):- append(LLeft,[46|Right],Left), ( \+ member(46,Right)),read_term_from_codes(LLeft,Term,[double_quotes(string),syntax_errors(fail)]),!. +; +; non-standard + (= (--> (nal_file_element $O) (, chspace (, ! (nal_file_element $O)))) True) + (= (--> (nal_file_element (expected $O)) (, (47 47 101 120 112 101 99 116 101 100 58) (, (read_string_until $Str eoln) (, ! {(phrase (read_nal_expected $O) $Str) })))) True) + (= (--> (nal_file_element (outputMustContain $O)) (, (39 39 111 117 116 112 117 116 77 117 115 116 67 111 110 116 97 105 110 40 39) (, (amw (nal_file_element $O)) (, (39 41) !)))) True) +; +; nal_file_element(outputMustContain(O)) --> `''outputMustContain('`, !, read_string_until(Str,`')`),`')`,{fmt(Str),phrase(nal_file_element(O),Str,[])}. + (= (--> (nal_file_element (oneAnswer $O)) (, (39 32 65 110 115 119 101 114 32) (, (read_string_until $Str (, (123) eoln)) {(phrase (nal_task $O) $Str ()) }))) True) - (= - (--> - (maybe_plus_array $E $E) - (, - (\+ - (dcg_peek - (91))) !)) True) -; + (= (--> (nal_file_element $Comment) (, (nal_comment_expr $Comment) !)) True) - (= - (--> - (maybe_plus_array $E - (idxOf $E $Ar)) - (, - (91) - (, owhite - (, - (nal_term_list_comma $Ar) - (, owhite - (93)))))) True) -; + (= (--> (nal_file_element (= $N $V)) (, (42) (, (nal_word $N) (, (amw (61)) (nal_term $V))))) True) + (= (--> (nal_file_element (nal_in $H $V3)) (, (73 78 58) (, (nal_task_0 $H) (optional (nal_three_vals $V3))))) True) + (= (--> (nal_file_element (nal_out $H $V3)) (, (79 85 84 58) (, (nal_task_0 $H) (optional (nal_three_vals $V3))))) True) +; +; standard + (= (--> (nal_file_element (do_steps $N)) (, (: dcg_basics (number $N)) !)) True) + (= (--> (nal_file_element $H) (, (nal_task $H) !)) True) + (= (--> (nal_file_element (nal_term $H)) (nal_term $H)) True) +; +; nal_read_clause("'the detective claims that tim lives in graz",A) + (= (--> ospace (, chspace (, ! ospace))) True) + (= (--> ospace ()) True) + (= (--> (read_nal_expected $O) (, chspace (, ! (read_nal_expected $O)))) True) + (= (--> (read_nal_expected (Cons $H $T)) (, (read_nal_expected_ele $H) (read_nal_expected $T))) True) + (= (--> (read_nal_expected ()) ()) True) + (= (--> (read_nal_expected_ele $O) (, chspace (, ! (read_nal_expected_ele $O)))) True) +; +; ^say executed with args ({SELF} * bedroom) + (= (--> (read_nal_expected_ele (executed_with_args $T $A)) (, (amw (nal_term $T)) (, (101 120 101 99 117 116 101 100 32 119 105 116 104 32 97 114 103 115) (amw (nal_term $A))))) True) + (= (--> (read_nal_expected_ele (answer $O)) (, (65 110 115 119 101 114 58) (nal_file_element $O))) True) + (= (--> (read_nal_expected_ele (occurrenceTime $T)) (, (111 99 99 117 114 114 101 110 99 101 84 105 109 101 61) (, ospace (: dcg_basics (number $T))))) True) + (= (--> (read_nal_expected_ele (truth $F $C)) (, (84 114 117 116 104 58) (read_nal_expected_truth $F $C))) True) - (= - (--> - (nal_priority $F) - (nal_float_inclusive 0 1 $F)) True) -; - ; -; + (= (--> (read_nal_expected_truth $F $C) (, chspace (, ! (read_nal_expected_truth $F $C)))) True) + (= (--> (read_nal_expected_truth $_ $_) (, (46) !)) True) + (= (--> (read_nal_expected_truth $_ $_) (, (\+ (dcg_peek ($_))) !)) True) + (= (--> (read_nal_expected_truth $F $C) (, (read_nal_expected_truth_ele $F $C) (, ! (read_nal_expected_truth $F $C)))) True) + (= (--> (read_nal_expected_truth_ele $F $C) (, (; chspace (44)) (, ! (read_nal_expected_truth_ele $F $C)))) True) + (= (--> (read_nal_expected_truth_ele $F $_) (, (102 114 101 113 117 101 110 99 121 61) (, ospace (nal_frequency $F)))) True) + (= (--> (read_nal_expected_truth_ele $_ $C) (, (99 111 110 102 105 100 101 110 99 101 61) (, ospace (nal_confidence $C)))) True) - (= - (--> - (nal_durability $F) - (nal_float_exclusive 0 1 $F)) True) -; - ; -; +; +; {1 : 4;3} + (= (--> (nal_three_vals $V3) (, (123) (, (read_string_until_no_esc $Str (; (125) eoln)) (, {(read_term_from_codes $Str $V3 ((double_quotes string) (syntax_errors fail))) } !)))) True) - - (= - (--> - (nal_quality $F) - (nal_float_inclusive 0 1 $F)) True) -; - ; -; - (= - (--> - (nal_frequency $F) - (nal_float_inclusive 0 1 $F)) True) -; - ; -; +; +; nal_file_with_comments(O,with_text(O,Txt),S,E):- copy_until_tail(S,Copy),text_to_string_safe(Copy,Txt),!. - (= - (--> - (nal_confidence $F) - (nal_float_exclusive 0 1 $F)) True) -; - ; -; - (= - (--> - (nal_o $S $X $X) - (, owhite - (, $S owhite))) True) -; + !(thread-local (with_self (t-l *) (/ sreader-options 2))) - (= - (--> - (nal_o $X $X) - (nal_o $X $X $X)) True) -; + (= (nars-tests) + (nal-tests) + (nal-test-files)) - (= - (--> - (nal_float_inclusive $L $H $F) - (amw - (-> - (: dcg_basics - (number $F)) - { (nal_warn_if_strict - (, - (=< $L $F) - (=< $F $H))) }))) True) -; - (= - (--> - (nal_float_exclusive $L $H $F) - (amw - (-> - (: dcg_basics - (number $F)) - { (nal_warn_if_strict - (, - (< $L $F) - (< $F $H))) }))) True) -; + (= (nal-tests) + ( (make) + (fmt ' +NAL TEST') + (with_self + (nal-reader *) + (forall + (nal-is-test $_ $Test) + (nal-test $Test))))) - (= - (nal-warn-if-strict $G) - ( (call $G) (set-det))) -; - (= - (nal-warn-if-strict $G) - ( (nal-dmsg (nal-warn-if-strict $G)) (set-det))) -; + !(use-module (library (/ dcg basics))) +; +; try_reader_test(Test):- is_stream(Test), !, \+ is_compound(Test), open_string(Test,Stream), try_reader_test(Stream). + (= (nal-test $Test) + (in-cmt (, (fmt "\n-----------------------------\n") (fmt $Test) (fmt "-----------------------------\n"))) + (nal-call nal-dmsg $Test $Out) + (nal-dmsg $Out)) - !(set-dcg-meta-reader-options file-comment-reader nal-comment-expr-unused) -; + (= (nal-zave-varname $N $V) + (debug-var $N $V) + (set-det)) +; +; nal_zave_varname(N,V):- V = '$VAR'(N). - (= - (--> - (nal_comment_expr_unused $_) - { (, ! fail) }) True) -; + (= (nal-read-clauses $Text $Out) + (findall $Cl + (nal-read-clause $Text $Cl) $OutL) + (flatten + (:: $OutL) $Out)) +; /* implode_varnames(Vs):- (var(Vs) ; Vs==[]),!. implode_varnames([NV|Vs]) :- implode_varnames(Vs), (var(NV) -> ignore((nal_variable_name(NV,Name),nal_zave_varname(Name,NV))); ignore((NV=(N=V),nal_zave_varname(N,V)))). */ - (= - (--> - (nal_comment_expr $X) - (, chspace - (, ! - (nal_comment_expr $X)))) True) -; - (= - (--> - (nal_comment_expr - ($COMMENT $Expr $I $CP)) - (, - (nal_comment_expr_3 $Expr $I $CP) !)) True) -; + (= (nal-read-clause $NonStream $Out) + (not (is-stream $NonStream)) + (set-det) + (must-or-rtrace (, (open-string $NonStream $Stream) (nal-read-clause $Stream $Out)))) +; ; nal_dmsg(NonStream), + (= (nal-read-clause $Stream $Out) + ($current-typein-module $M) + (\== $M input) + (set-det) + (setup-call-cleanup + ($set-typein-module input) + (nal-read-clause $Stream $Out) + ($set-typein-module $M))) - (= - (--> - (nal_comment_expr_3 $T $N $CharPOS) - (, - (47 42) - (, ! - (, - (my_lazy_list_location - (file $_ $_ $N $CharPOS)) - (, ! - (, - (zalwayz - (read_string_until_no_esc $S - (42 47))) - (, ! - (, - { (text_to_string_safe $S $T) } !)))))))) True) -; + (= (nal-read-clause $Stream $Out) + (op 601 xfx + (with_self + (input *) + (/))) + (op 601 xfx + (with_self + (input *) + (\\))) + (det-if-then-else + (at-end-of-stream $Stream) + (= $Out Nil) + (, + (remove-all-atoms &self + (: t_l + (%last_comment $_))) + (nal-read-term $Stream $Term) + (det-if-then-else + (== $Term end-of-file) + (= $Out Nil) + (, + (det-if-then-else + (= $Term + !$Exec) + (, + (with_self + (input *) + (call $Exec)) + (= $Out $More)) + (= $Out + (Cons $Term $More))) + (nal-read-clause $Stream $More)))))) + + + (= (nal-read-term $In $Expr) + (notrace (, (is-stream $In) (remove-pending-buffer-codes $In $Codes) (read-codes-from-pending-input $In $Text) (\== $Text Nil))) + (set-det) + (call-cleanup + (parse-meta-ascii-nal nal-file $Text $Expr) + (append-buffer-codes $In $Codes))) + (= (nal-read-term $Text $Expr) + (notrace (, (= ascii- $In) (remove-pending-buffer-codes $In $Codes))) + (call-cleanup + (parse-meta-ascii-nal nal-file $Text $Expr) + (append-buffer-codes $In $Codes))) + + + (= (parse-meta-ascii-nal nal-file $Text $Expr) + ( (parse-meta-ascii nal-file $Text $Expr) (remove-all-atoms &self (: t_l (%last_comment $_))))) + + + (= (with_self (nal-reader *) {$X }) + (call $X)) - (= - (--> - (nal_comment_expr_3 $T $N $CharPOS) - (, - { (nal_cmt_until_eoln $Text) } - (, - (dcg_peek $Text) - (, ! - (, - (my_lazy_list_location - (file $_ $_ $N $CharPOS)) - (, ! - (, - (zalwayz - (read_string_until_no_esc $S eoln)) - (, ! - (, - { (text_to_string_safe $S $T) } !))))))))) True) -; +; +; Expand Stream or String + + (= (nal-call $Ctx $Stream $Out) + (not (compound $Stream)) + (must-or-rtrace (nal-read-clauses $Stream $List)) + (set-det) + (nal-call $Ctx $List $Out)) + + (= (nal-call $Ctx $List $Out) + (is-list $List) + (set-det) + (maplist + (nal-call $Ctx) $List $OutL) + (flatten $OutL $Out)) + (= (nal-call $Ctx (= $InnerCtx (json $List)) $Out) + (set-det) + (nal-call + (Cons $InnerCtx $Ctx) $List $Out)) + + (= (nal-call $Ctx $List $Out) + (sub-term $Sub $List) + (nonvar $Sub) + (nal-rule-rewrite $Ctx $Sub $NewSub) + (nonvar $NewSub) + (\== $Sub $NewSub) + (subst $List $Sub $NewSub $NewList) + (\== $List $NewList) + (set-det) + (nal-call $Ctx $NewList $Out)) +; ; ignore((NewSub=='$',nal_dmsg(nal_rule_rewrite(_Ctx, Sub, NewSub)))), + + (= (nal-call $Ctx $List $Out) + (flatten + (:: $List) $Out) + (set-det)) - (= - (nal_cmt_until_eoln - (, - (47 47) - (\+ - (dcg_peek - (101 120 112 101 99 116 101 100 58))))) True) -; - (= - (nal_cmt_until_eoln - (, - (39) - (, - (\+ - (dcg_peek - (39 111 117 116 112 117 116 77 117 115 116 67 111 110 116 97 105 110))) - (dcg_peek - (\+ - (39 32 65 110 115 119 101 114 32)))))) True) -; + (= (nal-rule-rewrite $Ctx (json $Replace) $Replace) + (nonvar $Replace) + (set-det)) - (= - (nal_cmt_until_eoln - (42 42)) True) -; + (= (nal-join-atomics $Sep $List $Joined) + (atomics-to-string $List $Sep $Joined)) - (= - (--> nal_comma - (amw - (44))) True) -; + !(fixup-exports *) +; /* nal_into_tokenized(Text,TokenizedText):- \+ string(Text),!, any_to_string(Text,String), nal_into_tokenized(String,TokenizedText). nal_into_tokenized(Text,TokenizedText):- split_string(Text, "", "\s\t\r\n", [L]), L\==Text,!, nal_into_tokenized(L,M), ;string_concat(M,"\n",TokenizedText). string_concat(M,"",TokenizedText). nal_into_tokenized(Text,TokenizedText):- L=[_S1,_S2|_SS], member(Split,["\n'","'\n","'","","\n"]), atomic_list_concat(L,Split,Text), maplist(nal_into_tokenized,L,LO), atomics_to_string(LO,Split, TokenizedText). nal_into_tokenized(Text,TokenizedText):- split_string(Text, "\n", "\s\t\n\r",StringList), maplist(into_text80_atoms,StringList,SentenceList), maplist(nal_join_atomics(' '),SentenceList,ListOfStrings), nal_join_atomics('\n',ListOfStrings,TokenizedText),!. */ - (= - (--> nal_l_paren - (amw - (40))) True) -; - (= - (--> nal_paren_r - (amw - (41))) True) -; + (= (nal_is_test read "'the detective claims that tim lives in graz") True) + (= (nal_is_test read "<{tim} --> (/,livingIn,_,{graz})>.") True) + (= (nal_is_test read " swimmer>. %0.87;0.91%") True) + (= (nal_is_test read "''outputMustContain(' swimmer>. %0.87;0.91%')") True) + (= (nal_is_test read "1") True) + (= (nal_is_test read "$1") True) + (= (nal_is_test read "#1") True) + (= (nal_is_test read "?1") True) + (= (nal_is_test read "/1") True) + (= (nal_is_test read "\\1") True) +; +; to distinguish +; +; "eaten by tiger" vs. "eating tiger" +; +; before: (/,eat,tiger,_) vs. (/,eat,_,tiger) +; +; now: (eat /2 tiger) vs. (eat /1 tiger) + (= (nal_is_test read "'eating tiger") True) + (= (nal_is_test read "(eat /1 tiger)") True) + (= (nal_is_test read "(/,eat,_,tiger)") True) + (= (nal_is_test read "'eaten by tiger") True) + (= (nal_is_test read "(eat /2 tiger)") True) + (= (nal_is_test read "(/,eat,tiger,_)") True) + (= (nal_is_test read "'intensional eating") True) + (= (nal_is_test read "(eat \\1 tiger)") True) + (= (nal_is_test read "(\\,eat,_,tiger)") True) + (= (nal_is_test read "(eat \\2 tiger)") True) + (= (nal_is_test read "(\\,eat,tiger,_)") True) - (= - (--> - (nal_term_list_white - (Cons $H $T) $Sep) - (, - (nal_term_0 $H) - (; - (-> - (, $Sep owhite) - (nal_term_list_white $T $Sep)) - (, - { (= $T ()) } owhite)))) True) -; - (= - (--> - (nal_term_list_comma - (Cons $H $T)) - (, - (nal_term $H) - (; - (-> nal_comma - (nal_term_list_comma $T)) - { (= $T ()) }))) True) +; ; + (= (nal_is_test exec "'Revision ------\n\n'Bird is a type of swimmer.\n swimmer>.\n\n'Bird is probably not a type of swimmer.\n swimmer>. %0.10;0.60%\n\n1\n\n'Bird is very likely to be a type of swimmer.\n''outputMustContain(' swimmer>. %0.87;0.91%')") True) + (= (nal_is_test exec "\n********** revision\n IN: swimmer>. %1.00;0.90% {0 : 1} \n IN: swimmer>. %0.10;0.60% {0 : 2} \n1\n OUT: swimmer>. %0.87;0.91% {1 : 1;2} \n") True) - (= - (builtin_symbol _) True) -; - - (= - (builtin_symbol --) True) -; - - (= - (builtin_symbol ~) True) -; + (= (nal_is_test exec "\n********** abduction\n IN: competition>. %1.00;0.90% {0 : 1} \n IN: competition>. %0.90;0.90% {0 : 2} \n1\n OUT: chess>. %1.00;0.42% {1 : 2;1} \n OUT: sport>. %0.90;0.45% {1 : 2;1} \n OUT: sport>. %0.90;0.45% {1 : 2;1} \n OUT: <(&,chess,sport) --> competition>. %1.00;0.81% {1 : 2;1} \n OUT: <(|,chess,sport) --> competition>. %0.90;0.81% {1 : 2;1} \n OUT: < $1> ==> $1>>. %0.90;0.45% {1 : 2;1} \n OUT: < $1> ==> $1>>. %1.00;0.42% {1 : 2;1} \n OUT: < $1> <=> $1>>. %0.90;0.45% {1 : 2;1} \n OUT: (&&, #1>, #1>). %0.90;0.81% {1 : 2;1} \n") True) - (= - (builtin_symbol *) True) -; + (= (nal_is_test exec "\n********* induction\n IN: swimmer>. %0.90;0.90% {0 : 1} \n IN: bird>. %1.00;0.90% {0 : 2} \n1\n OUT: swimmer>. %0.90;0.45% {1 : 2;1} \n OUT: bird>. %1.00;0.42% {1 : 2;1} \n OUT: swimmer>. %0.90;0.45% {1 : 2;1} \n OUT: (|,bird,swimmer)>. %1.00;0.81% {1 : 2;1} \n OUT: (&,bird,swimmer)>. %0.90;0.81% {1 : 2;1} \n OUT: <<$1 --> swimmer> ==> <$1 --> bird>>. %1.00;0.42% {1 : 2;1} \n OUT: <<$1 --> bird> ==> <$1 --> swimmer>>. %0.90;0.45% {1 : 2;1} \n OUT: <<$1 --> bird> <=> <$1 --> swimmer>>. %0.90;0.45% {1 : 2;1} \n OUT: (&&,<#1 --> bird>,<#1 --> swimmer>). %0.90;0.81% {1 : 2;1} \n") True) - (= - (builtin_symbol key_101) True) -; + (= (nal_is_test exec "\n********** exemplification\n IN: bird>. %1.00;0.90% {0 : 1} \n IN: animal>. %1.00;0.90% {0 : 2} \n1\n OUT: animal>. %1.00;0.81% {1 : 2;1} \n OUT: robin>. %1.00;0.45% {1 : 2;1} \n") True) + (= (nal_is_test exec "\n********** conversion\n IN: swimmer>. %1.00;0.90% {0 : 1} \n IN: bird>? {0 : 2} \n2\n OUT: bird>. %1.00;0.47% {2 : 1} \n") True) + (= (nal_is_test exec "\n********** y/n question\n IN: swimmer>. %1.00;0.90% {0 : 1} \n IN: swimmer>? {0 : 2} \n1\n OUT: swimmer>. %1.00;0.90% {0 : 1} \n") True) + (= (nal_is_test exec "\n********** wh-question\n IN: swimmer>. %1.00;0.80% {0 : 1} \n IN: swimmer>? {0 : 2} \n1\n OUT: swimmer>. %1.00;0.80% {0 : 1} \n") True) - (= - (--> - (nal_rsymbol $S) - (, - { (, - (builtin_symbol $S) - (name $S $Str)) } - (, $Str !))) True) -; + (= (nal_is_test exec "\n\n'the detective claims that tim lives in graz\n'<{tim} --> (/,livingIn,_,{graz})>.\n'and lawyer claims that this is not the case\n<{tim} --> (/,livingIn,_,{graz})>. %0%\n100\n'the first deponent, a psychologist,\n'claims that people with sunglasses are more aggressive\n<<(*,$1,sunglasses) --> own> ==> <$1 --> [aggressive]>>.\n'the third deponent claims, that he has seen tom with sunglasses on:\n<(*,{tom},sunglasses) --> own>.\n'the teacher claims, that people who are aggressive tend to be murders\n<<$1 --> [aggressive]> ==> <$1 --> murder>>.\n'the second deponent claims, that if the person lives in Graz, he is surely the murder\n<<$1 --> (/,livingIn,_,{graz})> ==> <$1 --> murder>>.\n'who is the murder?\n<{?who} --> murder>?\n''outputMustContain('<{tom} --> murder>. %1.00;0.73%')\n\n") True) - (= - (--> - (nal_rsymbol $E) - (nal_rsymbol () $E)) True) -; + (= (nal_is_test read "\n' Custom truth values These are added by appending {0.0 0.9} instead of %0.0;0.9% as we believe this increased the readability.\n\n' Example\n\n********** wh-question\n IN: swimmer>. %1.00;0.80% {0 : 1} \n IN: swimmer>? {0 : 2} \n1\n OUT: swimmer>. %1.00;0.80% {0 : 1} \n\n' can now be\n\n\n********** wh-question\n IN: swimmer>. {1.0 0.80} {0 : 1} \n IN: swimmer>? {0 : 2} \n1\n OUT: swimmer>. {1.0 0.80} {0 : 1} \n\n") True) - (= - (--> - (nal_rsymbol $Chars $E) - (, - ($C) - (, - { (notrace - (nal_sym_char $C)) } - (, ! - (, - (nal_sym_continue $S) - (, - { (, - (append $Chars - (Cons $C $S) $AChars) - (string_to_symbol $AChars $E)) } !)))))) True) -; + (= (nal_is_test read "\n'Images\n\n(/,rel,_,b) \n\n' has to be written as\n\n(rel /1 b)\n\n' and image as\n\n(/,rel,a,_) \n\n' as\n\n(rel /2 a)\n\n' same for \\ with \\1 and \\2.\n\n") True) - (= - (--> - (nal_sym_continue ()) - (, nal_peek_symbol_breaker !)) True) -; + (= (nal_is_test read "\n'Intervals, to measure expected time distances between events, are always learned by ONA and stored as meta-data, they are not part of the Narsese I/O format anymore. Hence a sequence\n\n(&/,a,+5,b)\n\n' becomes\n\n(&/,a,b)\n\n' or\n\n(a &/ b)\n\n' and also the interval for implications is not used anymore.\n\n") True) - (= - (--> - (nal_sym_continue - (Cons $H $T)) - (, - ($H) - (, - { (nal_sym_char $H) } - (, ! - (nal_sym_continue $T))))) True) -; + (= (nal_is_test read "\n'Operators The syntactic sugar\n\n(^op,arg_1,arg_2,arg_3,arg_n)\n\n' is not supported anymore, instead the full notation has to be used which is supported by both systems:\n\n<(*,arg_1,arg_2,arg_3,arg_n) --> ^op>\n\n' though for operations without arguments, the following shortcut can be used:\n\n^op\n\n") True) - (= - (--> - (nal_sym_continue ()) ()) True) -; + (= (nal_is_test read "\n'Restrictions\n\n'1. Copulas in ONA are binary, since it's using an array-based heap for terms. \n' While there are ways to encode n-ary relations in a binary heap, the ONA philosophy, following KISS, \n' encourages the use of left-nesting, which is also used by the system itself to compose sequences of events:\n\n((a &/ b) &/ c).\n\n") True) + (= (nal_is_test read "\n'2. The parallel temporal copula &| is not implemented, please use &/ for now, again due to KISS. \n' If the order does not matter in some background knowledge we want to give the system, in addition to\n\n<(a &/ b) =/> c>\n\n' also give it\n\n<(b &/ a) =/> c>\n\n' to achieve the same as with &| for now.\n") True) - (= - (--> nal_peek_symbol_breaker - (dcg_peek - (45 45))) True) -; + (= (nal_is_test read "\n'Optional syntactic improvements\n' The ONA parser does not require commas, and doesn't distinguish between < and (, also it supports infix format.\n\n<(|,a,b) --> M>. \n\n' can be written as\n\n<(a | b) --> M>. \n\n' or even as\n\n((a | b) --> M).\n\n' Note: Spaces cannot be omitted.\n") True) - (= - (--> nal_peek_symbol_breaker - (, - (dcg_peek - (45)) - (, ! - {fail }))) True) -; + (= (nal_is_test read "\n'Tim is alive.\n\n<{Tim} --> [alive]>.\n\n'Tim is a human.\n\n<{Tim} --> human>.\n") True) - (= - (--> nal_peek_symbol_breaker - (dcg_peek one_blank)) True) -; + (= (nal_is_test read "\n'Humans are a lifeform.\n\n lifeform>.\n\n'Lifeforms are like machines.\n\n machine>.\n") True) - (= - (--> nal_peek_symbol_breaker - (, - (dcg_peek - ($C)) - (, - { (\+ - (nal_sym_char $C)) } !))) True) -; + (= (nal_is_test read "\n'Tom eats chocolate.\n\n<(*,{Tom},chocolate) --> eat>.\n\n<{Tom} --> (/,eat,_,chocolate)>.\n\n (/,eat,{Tom},_)>.\n") True) + (= (nal_is_test read "\n*volume=0\n*motorbabbling=false\n in>. :|:\n<({SELF} * kitchen) --> ^go>. :|:\n<({cat} * kitchen) --> in>. :|:\n100\n in>. :|:\n<({SELF} * bedroom) --> ^go>. :|:\n<({cat} * bedroom) --> in>. :|:\n100\n in>. :|:\n<({SELF} * livingroom) --> ^go>. :|:\n//no cat this time, it doesn't like the livingroom :)\n100\n in>. :|:\n<({SELF} * bedroom) --> ^go>. :|:\n<({cat} * bedroom) --> in>. :|:\n100\n//Ok you are in corridor now\n in>. :|:\n") True) + (= (nal_is_test read "\n*volume=0\nG! :|:\n") True) - (= - (nal-sym-char $C) - ( (not (integer $C)) - (set-det) - (char-code $C $D) - (set-det) - (nal-sym-char $D))) -; + (= (nal_is_test read "//Jonas has asthma?\n<{jonas} --> [asthma]>?\n//expected: Answer: <{jonas} --> [asthma]>. Truth: frequency=1.000000, confidence=0.801900\n//Angelika has asthma?\n<{angelika} --> [asthma]>?\n//expected: Answer: <{angelika} --> [asthma]>. Truth: frequency=1.000000, confidence=0.810000") True) - (= - (nal-sym-char $C) - ( (= - (:: $C) - (:: 95)) (set-det))) -; - (= - (nal-sym-char $C) - ( (bx (=< $C 32)) - (set-det) - (fail))) -; + (= (nal_is_test exec "\n'********** [08 + 09 -> 10]:\n\n'The robot is holding key001. \n<(*,Self,key001) --> hold>. :|: %1.00;0.81% \n\n1\n\n'The robot is holding key001. \n<(*,Self,key001) --> hold>. :|:\n\n5\n\n'The robot is holding key001. \n''outputMustContain('<(*,Self,key001) --> hold>. :!1: %1.00;0.93%') \n") True) -; -; -; -; + (= (nal_is_test exec "\n'********** compound composition, two premises\n\n'Sport is a type of competition. \n competition>. %0.90% \n\n'Chess is a type of competition. \n competition>. %0.80% \n\n16\n\n'If something is either chess or sport, then it is a competition.\n''outputMustContain('<(|,chess,sport) --> competition>. %0.72;0.81%')\n\n'If something is both chess and sport, then it is a competition.\n''outputMustContain('<(&,chess,sport) --> competition>. %0.98;0.81%')\n") True) - (= - (nal-sym-char $C) - ( (nal-never-symbol-char $NeverSymbolList) - (memberchk $C $NeverSymbolList) - (set-det) - (fail))) -; - ; -; -; -; + (= (nal_is_test exec "\n********** [07 + 09 -> 11]:\n IN: <(*,key001) --> ^pick>. :|: %1.00;0.90% {0 : 0 : 1} \n\n1\n\n IN: <(*,Self,key001) --> hold>. :|: %1.00;0.90% {1 : 1 : 2} \n\n1\n\n OUT: <<(*,Self,key001) --> hold> =\\> <(*,key001) --> ^pick>>. :\\: %1.00;0.45% {2 : 1 : 1;2} \n\n OUT: <<(*,key001) --> ^pick> =/> <(*,Self,key001) --> hold>>. :\\: %1.00;0.45% {2 : 1 : 1;2} \n\n OUT: <<(*,key001) --> ^pick> <(*,Self,key001) --> hold>>. :\\: %1.00;0.45% {2 : 1 : 1;2} \n\n OUT: (/,^pick,_)>. :\\: %1.00;0.90% {2 : 0 : 1} \n") True) - (= - (nal-sym-char $_) - (set-det)) -; + (= (nal_is_test exec "********** deduction\n IN: animal>. %1.00;0.90% {0 : 1} \n IN: bird>. %1.00;0.90% {0 : 2} \n1\n OUT: animal>. %1.00;0.81% {1 : 2;1} \n OUT: robin>. %1.00;0.45% {1 : 2;1} ") True) + (= (nal_is_test exec "********** deduction\n'the detective claims that tim lives in graz\n'<{tim} --> (/,livingIn,_,{graz})>.\n'and lawyer claims that this is not the case\n<{tim} --> (/,livingIn,_,{graz})>. %0%\n100\n'the first deponent, a psychologist,\n'claims that people with sunglasses are more aggressive\n<<(*,$1,sunglasses) --> own> ==> <$1 --> [aggressive]>>.\n'the third deponent claims, that he has seen tom with sunglasses on:\n<(*,{tom},sunglasses) --> own>.\n'the teacher claims, that people who are aggressive tend to be murders\n<<$1 --> [aggressive]> ==> <$1 --> murder>>.\n'the second deponent claims, that if the person lives in Graz, he is surely the murder\n<<$1 --> (/,livingIn,_,{graz})> ==> <$1 --> murder>>.\n'who is the murder?\n<{?who} --> murder>?\n''outputMustContain('<{tom} --> murder>. %1.00;0.73%')") True) + (= (nal_is_test read "\n//First: Input diamond:\n// | â\x96\\x88\â\x96\\x88\ |\n// | â\x96\\x88\â\x96\\x88\ â\x96\\x88\â\x96\\x88\ |\n// |â\x96\\x88\â\x96\\x88\ â\x96\\x88\â\x96\\x88\|\n// | â\x96\\x88\â\x96\\x88\ â\x96\\x88\â\x96\\x88\ |\n// | â\x96\\x88\â\x96\\x88\ |:\n<{M1[-1.0,0.0]} --> [BRIGHT]>.\n<{M1[1.0,0.0]} --> [BRIGHT]>.\n<{M1[0.0,1.0]} --> [BRIGHT]>.\n<{M1[0.0,-1.0]} --> [BRIGHT]>.\n<{M1[0.5,0.5]} --> [BRIGHT]>.\n<{M1[-0.5,0.5]} --> [BRIGHT]>.\n<{M1[0.5,-0.5]} --> [BRIGHT]>.\n<{M1[-0.5,-0.5]} --> [BRIGHT]>.\n<{M1} --> (/,called,_,circle)>.\n\n//Re-observe imperfectly\n// |â\x96\\x92\â\x96\\x92\ â\x96\\x88\â\x96\\x88\ |\n// | â\x96\\x88\â\x96\\x88\ â\x96\\x92\â\x96\\x92\ |\n// |â\x96\\x92\â\x96\\x92\ â\x96\\x88\â\x96\\x88\|\n// | â\x96\\x88\â\x96\\x88\ â\x96\\x92\â\x96\\x92\â\x96\\x92\â\x96\\x92\|\n// | |:\n<{M3[-1.0,1.0]} --> [BRIGHT]>. %0.5%\n<{M3[0.0,1.0]} --> [BRIGHT]>.\n<{M3[-0.5,0.5]} --> [BRIGHT]>.\n<{M3[0.5,0.5]} --> [BRIGHT]>. %0.5%\n<{M3[-1.0,0.0]} --> [BRIGHT]>. %0.5%\n<{M3[1.0,0.0]} --> [BRIGHT]>.\n<{M3[-0.5,-0.5]} --> [BRIGHT]>.\n<{M3[0.5,-0.5]} --> [BRIGHT]>. %0.5%\n<{M3[1.0,-0.5]} --> [BRIGHT]>. %0.5%\n\n50000\n//What was observed?\n<{M3} --> (/,called,_,?what)>?\n//A circle\n''outputMustContain('<{M3} --> (/,called,_,circle)>. %0.83;0.36%')") True) - (= - (nal_never_symbol_char - (34 59 40 41 126 39 91 93 33 60 62 96 123 125 44 61 46 92 94)) True) -; + (= (nal_is_test exec "\n*volume=0\nburgers are tasty food\nthe stranger eats a burger in the pub\n100\nwho eats tasty food?\n//expected: Answer: (eat /1 ([tasty] & food))>. :|: occurrenceTime=2 Truth: frequency=1.000000, confidence=0.278811\nwho is in the pub?\n//expected: Answer: (in /1 pub)>. :|: occurrenceTime=3 Truth: frequency=1.000000, confidence=0.900000\n") True) + (= (nal_is_test exec "\n//NARS, where is the cat?\n//Passive question <({cat} * ?where) --> in>? :|: wouldn't trigger a decision\n//Active question however does:\n<(<({cat} * #where) --> in> &/ <({SELF} * #where) --> ^say>) =/> G>.\nG! :|:\n100\n//expected: ^go executed with args ({SELF} * bedroom)\n") True) + (= (nal_is_test read "\n//ok, feedback of NARS going to the bedroom, the cat is there!\n<({cat} * bedroom) --> in>. :|:\nG! :|:\n10\n//expected: ^say executed with args ({SELF} * bedroom)\n") True) - (= - (--> - (nal_rsymbol_cont $Prepend $E) - (, - (nal_sym_continue $S) - (, - { (, - (append $Prepend $S $AChars) - (string_to_symbol $AChars $E)) } !))) True) -; + (= (nal_is_test exec "\n'********** compound composition, two premises\n\n'Sport is a type of competition. \n competition>. %0.90% \n\n'Chess is a type of competition. \n competition>. %0.80% \n\n16\n\n'If something is either chess or sport, then it is a competition.\n''outputMustContain('<(|,chess,sport) --> competition>. %0.72;0.81%')\n\n'If something is both chess and sport, then it is a competition.\n''outputMustContain('<(&,chess,sport) --> competition>. %0.98;0.81%')\n") True) + (= (nal_is_test read " (/,REPRESENT,_,DOG)>. %1.00;0.90% {0 : 2} ") True) + (= (nal_is_test read "\n'********** induction on events \n\n'John is opening door_101\n (/,open,_,door_101)>. :|: \n\n6\n\n'John is entering room_101\n (/,enter,_,room_101)>. :|: \n\n20\n\n'If John enter room_101, he should open door_101 before\n''outputMustContain('< (/,enter,_,room_101)> =\\> (&/, (/,open,_,door_101)>,+6)>. :!6: %1.00;0.45%')\n\n'new: variable introduction also in time:\n\n'If someone enter room_101, he should open door_101 before\n''outputMustContain('<<$1 --> (/,enter,_,room_101)> =\\> (&/,<$1 --> (/,open,_,door_101)>,+6)>. :!6: %1.00;0.45%')\n\n'adjusted +2 to +3 in both conditions\n\n10\n") True) + (= (nal_is_test read "\n''outputMustContain('< (/,enter,_,room_101)> =\\> (&/, (/,open,_,door_101)>,+6)>. :!6: %1.00;0.45%')") True) + (= (nal_is_test read "\n''outputMustContain('<<$1 --> (/,enter,_,room_101)> =\\> (&/,<$1 --> (/,open,_,door_101)>,+6)>. :!6: %1.00;0.45%')") True) - (= - (nal-is-test-file $X) - ( (filematch - (library ../nal-tests/**/*) $X) (not (nal-non-file $X)))) -; - - (= - (nal-is-test-file $X) - ( (filematch - (library ../examples/**/*) $X) - (atom-contains $X nars) - (not (nal-non-file $X)))) -; - - - (= - (nal-non-file $X) - ( (downcase-atom $X $DC) - (\== $X $DC) - (set-det) - (nal-non-file $DC))) -; - (= - (nal-non-file $X) - (atom-contains readme $X)) -; + (= (nal_is_test read "\n< (/,enter,_,room_101)> =\\> (&/, (/,open,_,door_101)>,+6)>. :!6: %1.00;0.45%") True) + (= (nal_is_test read "<<$1 --> (/,enter,_,room_101)> =\\> (&/,<$1 --> (/,open,_,door_101)>,+6)>. :!6: %1.00;0.45%") True) + (= (nal_is_test read "****************I am a comment") True) + (= (nal_is_test read "****************") True) - (= - (nal-non-file $X) - (exists-directory $X)) -; + (= (nal_is_test exec "\n*volume=0\n//When a person picks an object in a place, the picked object is also in that place\n<<#Person --> ((pick /1 $Object) & (in /1 $Place))> ==> <$Object --> (in /1 $Place)>>.\nJohn is in the playground.\nBob is in the office.\nJohn picked up the football.\nBob went to the kitchen.\n50\nThe football is in what?\n//expected: Answer: (in /1 playground)>. :|: occurrenceTime=4 Truth: frequency=1.000000, confidence=0.466560\n") True) - (= - (nal-non-file $X) - (atom-concat $_ .pl $X)) -; + (= (nal_is_test exec "\n********** conditional deduction\n IN: <(&&,a,b) ==> c>. %1.00;0.90% {0 : 1} \n IN: a. %1.00;0.90% {0 : 2} \n1\n OUT: c>. %1.00;0.81% {1 : 1;2} \n") True) + (= (nal-is-test read $X) + (atomic-list-concat $List + "IN: (&|,<#1() --> (/,at,Self,_)>,<(*,{t002},#1()) --> on>). :\\:\n IN: (&|,<#1() --> (/,at,Self,_)>,<(*,{t002},#1()) --> on>). :\\: %1.00;0.90% {0 : -1 : 1}\n IN: (&|,<#1() --> (/,on,{t002},_)>,<#1() --> (/,at,Self,_)>). :\\:\n IN: (&|,<#1() --> (/,on,{t002},_)>,<#1() --> (/,at,Self,_)>). :\\: %1.00;0.90% {0 : -1 : 1}\n IN: (&|,<(*,{t002},#1()) --> on>,<(*,Self,#1()) --> at>)!\n IN: (&|,<(*,{t002},#1()) --> on>,<(*,Self,#1()) --> at>)! %1.00;0.90% {0 : 2}\n IN: (&|,<(*,{t002},#1()) --> on>,<(*,Self,#1()) --> at>). :|:\n IN: (&|,<(*,{t002},#1()) --> on>,<(*,Self,#1()) --> at>). :|: %1.00;0.90% {0 : 0 : 1}\n IN: <(&|,<(*,#1,#2(#1)) --> on>,<(*,Self,#2(#1)) --> at>) =|> <(*,Self,#1) --> reachable>>.\n IN: <(&|,<(*,#1,#2(#1)) --> on>,<(*,Self,#2(#1)) --> at>) =|> <(*,Self,#1) --> reachable>>. %1.00;0.90% {0 : 1}\n IN: <(&|,<(*,#1,#2(#1)) --> on>,<(*,Self,#2(#1)) --> at>) =|> <(*,Self,#1) --> reachable>>. %1.00;0.90% {0 : 2}\n IN: <(&|,<(*,#1,#2(#1)) --> on>,<(*,Self,#2(#1)) --> at>) =|> <(*,Self,#1) --> reachable>>. \n IN: <(&|,<(*,#1,#2(#1)) --> on>,<(*,Self,#2(#1)) --> at>) =|> <(*,Self,#1) --> reachable>>.\n IN: <(&|,<(*,#1,#2(#1)) --> on>,<(*,Self,#2(#1)) --> at>)=|><(*,Self,#1) --> reachable>>.\n OUT: (&|,<#1() --> (/,at,Self,_)>,<(*,{t002},#1()) --> on>). :\\: %1.00;0.90%\n OUT: (&|,<#1() --> (/,at,Self,_)>,<(*,{t002},#1()) --> on>). :\\: %1.00;0.90% {8 : -1 : 1}\n OUT: (&|,<#1() --> (/,at,Self,_)>,<{t002} --> (/,on,_,#1())>). :\\: %1.00;0.90% {6 : -1 : 1}\n OUT: (&|,<#1() --> (/,on,{t002},_)>,<#1() --> (/,at,Self,_)>). :\\: %1.00;0.81%\n OUT: (&|,<#1() --> (/,on,{t002},_)>,<#1() --> (/,at,Self,_)>). :\\: %1.00;0.81% {2 : -1 : 2;1}\n OUT: (&|,<(*,Self,#1()) --> at>,<{t002} --> (/,on,_,#1())>)! %1.00;0.90% {6 : 2}\n OUT: (&|,<(*,Self,#1()) --> at>,<{t002} --> (/,on,_,#1())>)? :\\: {23 : 1 : 3}\n OUT: (&|,<(*,Self,#1()) --> at>,<{t002} --> (/,on,_,#1())>)? :|: {7 : 7 : 5}\n OUT: (&|,<(*,{t002},#1()) --> on>,<(*,Self,#1()) --> at>)! %1.00;0.81%\n OUT: (&|,<(*,{t002},#1()) --> on>,<(*,Self,#1()) --> at>)! %1.00;0.81% {16 : 2;1}\n OUT: (&|,<(*,{t002},#1()) --> on>,<(*,Self,#1()) --> at>). :\\: %1.00;0.90%\n OUT: (&|,<(*,{t002},#1()) --> on>,<(*,Self,#1()) --> at>). :\\: %1.00;0.90% {4 : -1 : 1}\n OUT: (&|,<(*,{t002},#1()) --> on>,<(*,Self,#1()) --> at>)? :|: {1 : 1 : 3}\n OUT: (&|,<(*,{t002},#1()) --> on>, (/,at,_,#1())>)! %1.00;0.90% {1 : 2}\n OUT: (&|,<(*,{t002},#1()) --> on>, (/,at,_,#1())>). :\\: %1.00;0.90% {3 : -1 : 1}\n OUT: (&|,<(*,{t002},#1()) --> on>, (/,at,_,#1())>)? :\\: {15 : 1 : 3}\n OUT: (&|,<(*,{t002},#1()) --> on>, (/,at,_,#1())>)? :|: {2 : 2 : 4}\n OUT: <(&|,<(*,#1,#2(#1)) --> on>, (/,at,_,#2(#1))>) ==> <(*,Self,#1) --> reachable>>. %1.00;0.90% {4 : 1}") + (member $X $List)) - (= - (nal-test-files) - ( (make) (catch (forall (nal-is-test-file $X) (, (nal-dmsg (test-file-begin $X)) (ignore (nal-do-test-file $X)) (nal-dmsg (test-file-end $X)))) %aborted True))) -; + (= (nal-is-test read $X) + (atomic-list-concat $List + "\n ''outputMustContain('')\n ''outputMustContain('(&/,(^go-to,{t003}),(^pick,{t002}),(^go-to,{t001}),(^open,{t001}))! %1.00;0.43%')\n ''outputMustContain('(^go-to,{t001})! %1.00;0.81%')\n ''outputMustContain('(^go-to,{t003})! %1.00;0.81%')\n ''outputMustContain('...')\n ''outputMustContain('<(&&,<$1 --> [chirping]>,<$1 --> [with-wings]>) ==> <$1 --> bird>>. %1.00;0.81%')\n ''outputMustContain('<(&&,<$1 --> [with-wings]>,<(*,$1,worms) --> food>) ==> <$1 --> bird>>. %1.00;0.45%')\n ''outputMustContain('<(&&,<$1 --> flyer>,<(*,$1,worms) --> food>) ==> <$1 --> [with-wings]>>. %1.00;0.45%')\n ''outputMustContain('<(&&, [chirping]>, [with-beak]>) ==> bird>>. %1.00;0.42%')\n ''outputMustContain('<(&&, [chirping]>, [with-wings]>) ==> bird>>. %1.00;0.81%')\n ''outputMustContain('<(&/,(^go-to,{t003}),(^pick,{t002}),(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>. %1.00;0.43%')\n ''outputMustContain('<(&/,<(*,Self,{t002}) --> reachable>,(^pick,{t002}),(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>. %1.00;0.81%')\n ''outputMustContain('<<$1 --> [with-wings]> ==> (&&,<$1 --> flyer>,<(*,$1,worms) --> food>)>. %1.00;0.45%')\n ''outputMustContain('< [with-wings]> ==> bird>>. %0.90;0.45%')\n ''outputMustContain('< [with-wings]> ==> bird>>. %1.00;0.81%')\n ''outputMustContain('< bird> ==> [with-wings]>>. %1.00;0.42%')\n ''outputMustContain(' swan>. %0.10')\n (&&,<#x --> P >, <#x --> S>) ?\n (&&, P1>, P2>) .\n (&&, P1>, P2>)?\n (--, ).\n (^go-to,{SELF},{t001}). :\\:\n < (&&,<(*,#manswer,#m) --> replyTo>, <(*,#manswer,U) --> sender>) <=> <#m --> uResponse> >.\n < <#x --> P > ==> (/,R, #x, _ ) > >.\n <(&&, <#y --> S>, <#x --> P> ) ==> <#y --> (/, R, #x, _ )> > ?\n <(&&,<$x --> [chirping]>,<$x --> [with-wings]>) ==> <$x --> bird>>.\n <(&&,<$x --> flyer>,<$x --> [chirping]>, <(*, $x, worms) --> food>) ==> <$x --> bird>>.\n <(&&,<$y --> [chirping]>,<$y --> [with-wings]>) ==> <$y --> bird>>.\n <(&&, [chirping]>, [flying]>, [with-wings]>) ==> bird>>.\n <(&&, [flying]>, [with-wings]>) ==> [living]>>. %0.9%\n <(&&, [flying]>, [with-wings]>) ==> bird>>.\n <(&&, [flying]>, [with-wings]>, [chirping]>) ==> bird>>.\n <(&&, [with-wings]>, [chirping]>) ==> bird>>.\n <(&, [red], light) --> traffic_signal>?\n <(&/, (||, S, P), +5) =/> M>. %0.9%\n <(&/, a, +1) =/> b>.\n <(&/, b, +1) =/> c>.\n <(&/,(^go-to,{t003}),(^pick,{t002}),(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>. :|:\n <(&/,<(*,Self,{t002}) --> hold>,(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>.\n <(&/,<(*,Self,{t003}) --> at>,(^pick,{t002}),(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>. :|:\n <(*, John, key_101) --> hold>. :\\:\n <(*,S1, S2 ) --> (*,P1, P2 )> ?\n <(*,S1, S2 ) --> (*,P1, P2 )>.\n <(*,{t003}) --> ^go-to>. :|:\n <(^go-to,$1) =/> <(*,Self,$1) --> at>>.\n <(^go-to,$1)=/><(*,SELF,$1) --> at>>.\n <(^go-to,{SELF},$1)=/><(*,{SELF},$1) --> at>>.\n <(|, boy, girl) --> youth>. %0.90%\n <(~, boy, girl) --> [strong]>. %0.90%\n <(~,swimmer, swan) --> bird>?\n <<$y --> [with-wings]> ==> <$y --> flyer>>.\n <<$y --> flyer> ==> <$y --> [with-wings]>>.\n <<(*,$1) --> ^go-to> =/> <(*,SELF,$1) --> at>>.\n <<(*,$1,$2) --> Friends> ==> (||, (&&,<$1 --> [Smokes]>,<$2 --> [Smokes]>), (&&,(--,<$1 --> [Smokes]>),(--,<$2 --> [Smokes]>)))>. %0.6;0.9%\n < [flying]> ==> [with-beak]>>. %0.90%\n .\n .\n .\n .\n ?\n <{Tweety} --> [with-wings]>.\n [number]: # of cycles to process before continuing to next line\n IN: (^go-to,{t001})!\n IN: (^go-to,{t001}). :\\:\n IN: (^go-to,{t003})! %1.00;0.90% {0 : 1}\n IN: (^go-to,{t003}). :|:\n IN: <(&&,<$1 --> [chirping]>,<$1 --> [with-wings]>) ==> <$1 --> bird>>. %1.00;0.90% {0 : 2}\n IN: <(&&, [chirping]>, [flying]>, [with-wings]>) ==> bird>>. %1.00;0.90% {0 : 1}\n IN: <(&&, [chirping]>, [flying]>, [with-wings]>) ==> bird>>. %1.00;0.90% {0 : 2}\n IN: <(&&, [chirping]>, [with-wings]>) ==> bird>>. %1.00;0.90% {0 : 1}\n IN: <(&&, [flying]>, [with-wings]>) ==> [living]>>. %0.90;0.90% {0 : 1}\n IN: <(&&, [flying]>, [with-wings]>) ==> bird>>. %1.00;0.90% {0 : 1}\n IN: <(&/,(^go-to,{t003}),(^pick,{t002}),(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>. :|:\n IN: <(&/,<(*,Self,{t002}) --> hold>,(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>.\n IN: <(&/,<(*,Self,{t002}) --> hold>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. %1.00;0.90% {0 : 1}\n IN: <(&/,<(*,Self,{t002}) --> reachable>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. %1.00;0.90% {0 : 1}\n IN: <(&/,<(*,Self,{t003}) --> at>,(^pick,{t002}),(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>. :|:\n IN: <(&/,<(*,Self,{t003}) --> at>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. :|: %1.00;0.90% {0 : 0 : 1}\n IN: <(&/,<(*,{t003}) --> ^go-to>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. :|: %1.00;0.90% {0 : 0 : 2}\n IN: <(*, John, key_101) --> hold>. :/:\n IN: <(*,{t001}) --> ^go-to>! %1.00;0.90% {0 : 1}\n IN: <(*,{t001}) --> ^go-to>. :\\: %1.00;0.90% {0 : -1 : 1}\n IN: <(*,{t003}) --> ^go-to>! %1.00;0.90% {0 : 1}\n IN: <(*,{t003}) --> ^go-to>. :|: %1.00;0.90% {0 : 0 : 1}\n IN: <(^go-to,#1) =/> <(*,Self,#1) --> at>>.\n IN: <(^go-to,#1)=/><(*,Self,#1) --> at>>.\n IN: <<$1 --> [with-wings]> ==> <$1 --> flyer>>. %1.00;0.90% {0 : 2}\n IN: <<$1 --> flyer> ==> <$1 --> [with-wings]>>. %1.00;0.90% {0 : 2}\n IN: <<(*,#1) --> ^go-to> =/> <(*,Self,#1) --> at>>. %1.00;0.90% {0 : 1}\n IN: <<(*,#1) --> ^go-to> =/> <(*,Self,#1) --> at>>. %1.00;0.90% {0 : 2}\n IN: < [flying]> ==> [with-beak]>>. %0.90;0.90% {0 : 2}\n IN: <{Tweety} --> [with-wings]>. %1.00;0.90% {0 : 1}\n out is a reference to the current output buffer, containing a list of strings; one for each output\n OUT: (&/,(^go-to,{t003}),(^pick,{t002}),(^go-to,{t001}),(^open,{t001}))! %1.00;0.81%\n OUT: (&/,<(*,{t003}) --> ^go-to>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>)! %1.00;0.81% {16 : 2;1}\n OUT: (&/,<(*,{t003}) --> ^go-to>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>)? :\\: {13 : 0 : 2;3}\n OUT: (&/,<(*,{t003}) --> ^go-to>,<(*,{t002}) --> ^pick>,<{t001} --> (/,^go-to,_)>,<(*,{t001}) --> ^open>)? :\\: {14 : 0 : 2;3}\n OUT: (^go-to,{t001})! %1.00;0.81%\n OUT: (^go-to,{t001}). :|: %1.00;0.90%\n OUT: (^go-to,{t003})! %1.00;0.81%\n OUT: (^go-to,{t003}). :|: %1.00;0.90%\n OUT: <(&&,<$1 --> [chirping]>,<$1 --> [with-wings]>) ==> <$1 --> bird>>. %1.00;0.81%\n OUT: <(&&,<$1 --> [chirping]>,<$1 --> [with-wings]>) ==> <$1 --> bird>>. %1.00;0.81% {1 : 2;1}\n OUT: <(&&,<$1 --> [with-wings]>,<(*,$1,worms) --> food>) ==> <$1 --> bird>>. %1.00;0.45%\n OUT: <(&&,<$1 --> [with-wings]>,<(*,$1,worms) --> food>) ==> <$1 --> bird>>. %1.00;0.45% {4 : 1;2}\n OUT: <(&&,<$1 --> flyer>,<(*,$1,worms) --> food>) ==> <$1 --> [with-wings]>>. %1.00;0.45%\n OUT: <(&&,<$1 --> flyer>,<(*,$1,worms) --> food>) ==> <$1 --> [with-wings]>>. %1.00;0.45% {4 : 1;2}\n OUT: <(&&, [chirping]>, [with-beak]>) ==> bird>>. %1.00;0.42%\n OUT: <(&&, [chirping]>, [with-beak]>) ==> bird>>. %1.00;0.42% {11 : 1;2}\n OUT: <(&&, [chirping]>, [with-wings]>) ==> bird>>. %1.00;0.81%\n OUT: <(&&, [chirping]>, [with-wings]>) ==> bird>>. %1.00;0.81% {5 : 1;2}\n OUT: <(&/,(^go-to,{t003}),(^pick,{t002}),(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>. :\\: %1.00;0.81%\n OUT: <(&/,<(*,Self,{t002}) --> hold>,(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>. %1.00;0.81%\n OUT: <(&/,<(*,Self,{t002}) --> hold>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. %1.00;0.81% {2 : 2;1}\n OUT: <(&/,<(*,Self,{t002}) --> reachable>,(^pick,{t002}),(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>. %1.00;0.81%\n OUT: <(&/,<(*,Self,{t002}) --> reachable>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. %1.00;0.81% {14 : 2;1}\n OUT: <(&/,<(*,Self,{t003}) --> at>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. %1.00;0.43% {5 : 2;1}\n OUT: <(&/,<(*,Self,{t003}) --> at>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. %1.00;0.43% {8 : 2;1}\n OUT: <(&/,<(*,Self,{t003}) --> at>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. :\\: %1.00;0.81% {17 : 0 : 1;2}\n OUT: <(&/,<(*,{t003}) --> ^go-to>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. %1.00;0.43% {11 : 1;2}\n OUT: <(&/,<(*,{t003}) --> ^go-to>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. :\\: %1.00;0.81% {16 : 0 : 2;1}\n OUT: <(&/, (/,at,_,{t003})>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) ==> <{t001} --> [opened]>>. :\\: %1.00;0.90% {15 : 0 : 1}\n OUT: <(&/, (/,hold,_,{t002})>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) ==> <{t001} --> [opened]>>. %1.00;0.90% {10 : 1}\n OUT: <(&/, (/,reachable,_,{t002})>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) ==> <{t001} --> [opened]>>. %1.00;0.90% {16 : 1}\n OUT: <(&/,<{t002} --> (/,hold,Self,_)>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) ==> <{t001} --> [opened]>>. %1.00;0.90% {11 : 1}\n OUT: <(&/,<{t002} --> (/,reachable,Self,_)>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) ==> <{t001} --> [opened]>>. %1.00;0.90% {9 : 1}\n OUT: <(&/,<{t003} --> (/,^go-to,_)>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) ==> <{t001} --> [opened]>>. :\\: %1.00;0.90% {11 : 0 : 2}\n OUT: <(&/,<{t003} --> (/,at,Self,_)>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) ==> <{t001} --> [opened]>>. :\\: %1.00;0.90% {7 : 0 : 1}\n OUT: <(*,{t001}) --> ^go-to>! %1.00;0.81% {19 : 2;1}\n OUT: <(*,{t001}) --> ^go-to>. :|: %1.00;0.90% {1 : 1 : 2}\n OUT: <(*,{t003}) --> ^go-to>! %1.00;0.81% {19 : 2;1}\n OUT: <(*,{t003}) --> ^go-to>. :|: %1.00;0.90% {1 : 1 : 2}\n OUT: <(/,(*,{t001}),_) --> (/,^go-to,_)>. :\\: %1.00;0.90% {7 : -1 : 1}\n OUT: <(/,(*,{t003}),_) --> (/,^go-to,_)>. :\\: %1.00;0.90% {7 : 0 : 1}\n OUT: <(~,swimmer, swan) --> bird>. %0.10;0.73%\n OUT: <<$1 --> [with-wings]> ==> (&&,<$1 --> flyer>,<(*,$1,worms) --> food>)>. %1.00;0.45%\n OUT: <<$1 --> [with-wings]> ==> (&&,<$1 --> flyer>,<(*,$1,worms) --> food>)>. %1.00;0.45% {4 : 1;2}\n OUT: <<(*,#1) --> ^go-to> =/> (/,at,_,#1)>>. %1.00;0.90% {1 : 1}\n OUT: <<(*,#1) --> ^go-to> =/> (/,at,_,#1)>>. %1.00;0.90% {1 : 2}\n OUT: <<(*,#1) --> ^go-to> =/> (/,at,_,#1)>>. %1.00;0.90% {10 : 2}\n OUT: <<(*,#1) --> ^go-to> =/> (/,at,_,#1)>>. %1.00;0.90% {8 : 2}\n OUT: < [with-wings]> ==> bird>>. %0.90;0.45%\n OUT: < [with-wings]> ==> bird>>. %0.90;0.45% {8 : 2;1}\n OUT: < [with-wings]> ==> bird>>. %1.00;0.81%\n OUT: < [with-wings]> ==> bird>>. %1.00;0.81% {3 : 2;1}\n OUT: < bird> ==> [with-wings]>>. %1.00;0.42%\n OUT: < bird> ==> [with-wings]>>. %1.00;0.42% {8 : 2;1}\n OUT: <{t001} --> (/,^go-to,_)>. :\\: %1.00;0.90% {2 : -1 : 1}\n OUT: <{t003} --> (/,^go-to,_)>. :\\: %1.00;0.90% {2 : 0 : 1}\n IN: <(*, John, key_101) --> hold>. :/:\n.\n?\n(--, ).\n.\n<(~,swimmer, swan) --> bird>?\nOUT: <(~,swimmer, swan) --> bird>. %0.10;0.73%\n<(|, boy, girl) --> youth>. %0.90%\n<(~, boy, girl) --> [strong]>. %0.90%\n<(&&,<$x --> flyer>,<$x --> [chirping]>, <(*, $x, worms) --> food>) ==> <$x --> bird>>.\nIN: <(*, John, key_101) --> hold>. :/:\n\n''outputMustContain(' swan>. %0.10')\n\nnars hears a boom") + (member $X $List) + (\== $X "") + (\== $X '')) - (= - (nal-do-test-file $File) - ( (or - (not (atom $File)) - (or - (not (is-absolute-file-name $File)) - (not (exists-file $File)))) - (filematch $File $Absolute) - (set-det) - (nal-do-test-file $Absolute))) -; - (= - (nal-do-test-file $File) - (setup-call-cleanup - (open $File read $In) - (nal-do-test-stream $In) - (close $In))) -; + (= (nal_is_test exec "'********** conversions between inheritance and similarity\n\n'Swan is a type of bird. \n bird>. \n\n'Bird is not a type of swan. \n swan>. %0.10% \n\n1\n\n'Bird is different from swan. \n''outputMustContain(' swan>.')\n''outputMustContain(' swan>. %0.10')\n''outputMustContain(' swan>. %0.10;0.81%')\n\n") True) + (= (nal_is_test read "\n<{a, b} |- (&/,a,b)>.") True) -; -; + (= (nal_is_test read "\n<{a, b, after(a,b)} |- b>>.") True) + (= (nal_is_test read "\n<{ b! , b>} |- a! >") True) - (= - (nal-do-test-stream $In) - ( (nal-read-clauses $In $Expr) - (set-det) - (nars-exec-ex $Expr))) -; ; -; - -; -; - - - - (= - (nal-dmsg $O) - ( (is-list $O) - (set-det) - (in-cmt (maplist print-tree-nl $O)))) -; - - (= - (nal-dmsg $O) - ( (format ~N) (in-cmt (print-tree-nl $O)))) -; - - - - (= - (--> - (amw $A) - (, cspace - (, ! - (amw $A)))) True) -; - - (= - (--> - (amw $A) - (, $A - (more_cspace chspace))) True) -; - - -; -; - - (= - (--> chspace cspace) True) -; - - (= - (--> aspaces - (, chspace - (more_aspace chspace))) True) -; - - (= - (--> - (more_aspace $P) - (, $P - (, ! - (more_aspace $P)))) True) -; - - (= - (--> - (more_aspace $_) ()) True) -; - - - (= - (--> - (more_cspace $P) - (, $P - (, ! - (more_cspace $P)))) True) -; - - (= - (--> - (more_cspace $_) ()) True) -; - - -; -; - - (= - (--> - (nal_file $CMT) - (, - { (retract - (: t_l - (%last_comment $CMT))) } !)) True) -; - - (= - (--> - (nal_file end_of_file) - (, file_eof !)) True) -; - - (= - (--> - (nal_file $O) - (, eoln - (, ! - (nal_file $O)))) True) -; - - (= - (--> - (nal_file $O) - (, chspace - (, ! - (nal_file $O)))) True) -; - - (= - (--> - (nal_file ()) - (, - (\+ - (dcg_peek - ($_))) !)) True) -; - -; -; - - (= - (--> - (nal_file $O) - (, - (read_string_until_no_esc $Str eoln) - { (, - (phrase - (, - (nal_file_element $O) owhite) $Str) !) })) True) -; - -; -; - - (= - (--> - (nal_file - (unk_english $Text)) - (, - (read_string_until_no_esc $Str eoln) - { (, - (symbol_string $Str $TextStr) - (, - { (, - (format '~N%~~ ') - (, - (ansifmt - (red) $TextStr) nl)) } - (split_string $TextStr "" " \t\r\n" $Text))) })) True) -; - - -; -; - -; -; - -; -; - - -; -; - - (= - (--> - (nal_file_element $O) - (, chspace - (, ! - (nal_file_element $O)))) True) -; - - (= - (--> - (nal_file_element - (expected $O)) - (, - (47 47 101 120 112 101 99 116 101 100 58) - (, - (read_string_until $Str eoln) - (, ! - { (phrase - (read_nal_expected $O) $Str) })))) True) -; - - (= - (--> - (nal_file_element - (outputMustContain $O)) - (, - (39 39 111 117 116 112 117 116 77 117 115 116 67 111 110 116 97 105 110 40 39) - (, - (amw - (nal_file_element $O)) - (, - (39 41) !)))) True) -; - -; -; - - (= - (--> - (nal_file_element - (oneAnswer $O)) - (, - (39 32 65 110 115 119 101 114 32) - (, - (read_string_until $Str - (, - (123) eoln)) - { (phrase - (nal_task $O) $Str ()) }))) True) -; - - - (= - (--> - (nal_file_element $Comment) - (, - (nal_comment_expr $Comment) !)) True) -; - - - (= - (--> - (nal_file_element - (= $N $V)) - (, - (42) - (, - (nal_word $N) - (, - (amw - (61)) - (nal_term $V))))) True) -; - - (= - (--> - (nal_file_element - (nal_in $H $V3)) - (, - (73 78 58) - (, - (nal_task_0 $H) - (optional - (nal_three_vals $V3))))) True) -; - - (= - (--> - (nal_file_element - (nal_out $H $V3)) - (, - (79 85 84 58) - (, - (nal_task_0 $H) - (optional - (nal_three_vals $V3))))) True) -; - -; -; - - (= - (--> - (nal_file_element - (do_steps $N)) - (, - (: dcg_basics - (number $N)) !)) True) -; - - (= - (--> - (nal_file_element $H) - (, - (nal_task $H) !)) True) -; - - (= - (--> - (nal_file_element - (nal_term $H)) - (nal_term $H)) True) -; - -; -; - - - (= - (--> ospace - (, chspace - (, ! ospace))) True) -; - - (= - (--> ospace ()) True) -; - - - (= - (--> - (read_nal_expected $O) - (, chspace - (, ! - (read_nal_expected $O)))) True) -; - - (= - (--> - (read_nal_expected - (Cons $H $T)) - (, - (read_nal_expected_ele $H) - (read_nal_expected $T))) True) -; - - (= - (--> - (read_nal_expected ()) ()) True) -; - - (= - (--> - (read_nal_expected_ele $O) - (, chspace - (, ! - (read_nal_expected_ele $O)))) True) -; - -; -; - - (= - (--> - (read_nal_expected_ele - (executed_with_args $T $A)) - (, - (amw - (nal_term $T)) - (, - (101 120 101 99 117 116 101 100 32 119 105 116 104 32 97 114 103 115) - (amw - (nal_term $A))))) True) -; - - (= - (--> - (read_nal_expected_ele - (answer $O)) - (, - (65 110 115 119 101 114 58) - (nal_file_element $O))) True) -; - - (= - (--> - (read_nal_expected_ele - (occurrenceTime $T)) - (, - (111 99 99 117 114 114 101 110 99 101 84 105 109 101 61) - (, ospace - (: dcg_basics - (number $T))))) True) -; - - (= - (--> - (read_nal_expected_ele - (truth $F $C)) - (, - (84 114 117 116 104 58) - (read_nal_expected_truth $F $C))) True) -; - - - (= - (--> - (read_nal_expected_truth $F $C) - (, chspace - (, ! - (read_nal_expected_truth $F $C)))) True) -; - - (= - (--> - (read_nal_expected_truth $_ $_) - (, - (46) !)) True) -; - - (= - (--> - (read_nal_expected_truth $_ $_) - (, - (\+ - (dcg_peek - ($_))) !)) True) -; - - (= - (--> - (read_nal_expected_truth $F $C) - (, - (read_nal_expected_truth_ele $F $C) - (, ! - (read_nal_expected_truth $F $C)))) True) -; - - (= - (--> - (read_nal_expected_truth_ele $F $C) - (, - (; chspace - (44)) - (, ! - (read_nal_expected_truth_ele $F $C)))) True) -; - - (= - (--> - (read_nal_expected_truth_ele $F $_) - (, - (102 114 101 113 117 101 110 99 121 61) - (, ospace - (nal_frequency $F)))) True) -; - - (= - (--> - (read_nal_expected_truth_ele $_ $C) - (, - (99 111 110 102 105 100 101 110 99 101 61) - (, ospace - (nal_confidence $C)))) True) -; - - -; -; - - (= - (--> - (nal_three_vals $V3) - (, - (123) - (, - (read_string_until_no_esc $Str - (; - (125) eoln)) - (, - { (read_term_from_codes $Str $V3 - ( (double_quotes string) (syntax_errors fail))) } !)))) True) -; - - - -; -; - - - - - !(thread-local (with_self (t-l *) (/ sreader-options 2))) -; - - - - (= - (nars-tests) - ( (nal-tests) (nal-test-files))) -; - - - - - (= - (nal-tests) - ( (make) - (fmt ' -NAL TEST') - (with_self - (nal-reader *) - (forall - (nal-is-test $_ $Test) - (nal-test $Test))))) -; - - - - - !(use-module (library (/ dcg basics))) -; - - -; -; - - - (= - (nal-test $Test) - ( (in-cmt (, (fmt "\n-----------------------------\n") (fmt $Test) (fmt "-----------------------------\n"))) - (nal-call nal-dmsg $Test $Out) - (nal-dmsg $Out))) -; - - - - - (= - (nal-zave-varname $N $V) - ( (debug-var $N $V) (set-det))) -; - -; -; - - - - (= - (nal-read-clauses $Text $Out) - ( (findall $Cl - (nal-read-clause $Text $Cl) $OutL) (flatten (:: $OutL) $Out))) -; - - - - (= - (nal-read-clause $NonStream $Out) - ( (not (is-stream $NonStream)) - (set-det) - (must-or-rtrace (, (open-string $NonStream $Stream) (nal-read-clause $Stream $Out))))) -; - - - (= - (nal-read-clause $Stream $Out) - ( ($current-typein-module $M) - (\== $M input) - (set-det) - (setup-call-cleanup - ($set-typein-module input) - (nal-read-clause $Stream $Out) - ($set-typein-module $M)))) -; - - - (= - (nal-read-clause $Stream $Out) - ( (op 601 xfx - (with_self - (input *) - (/))) - (op 601 xfx - (with_self - (input *) - (\\))) - (det-if-then-else - (at-end-of-stream $Stream) - (= $Out Nil) - (, - (remove-all-symbols &self - (: t_l - (%last_comment $_))) - (nal-read-term $Stream $Term) - (det-if-then-else - (== $Term end-of-file) - (= $Out Nil) - (, - (det-if-then-else - (= $Term - !$Exec) - (, - (with_self - (input *) - (call $Exec)) - (= $Out $More)) - (= $Out - (Cons $Term $More))) - (nal-read-clause $Stream $More))))))) -; - - - - (= - (nal-read-term $In $Expr) - ( (notrace (, (is-stream $In) (remove-pending-buffer-codes $In $Codes) (read-codes-from-pending-input $In $Text) (\== $Text Nil))) - (set-det) - (call-cleanup - (parse-meta-ascii-nal nal-file $Text $Expr) - (append-buffer-codes $In $Codes)))) -; - - (= - (nal-read-term $Text $Expr) - ( (notrace (, (= ascii- $In) (remove-pending-buffer-codes $In $Codes))) (call-cleanup (parse-meta-ascii-nal nal-file $Text $Expr) (append-buffer-codes $In $Codes)))) -; - - - - (= - (parse-meta-ascii-nal nal-file $Text $Expr) - ( (parse-meta-ascii nal-file $Text $Expr) (remove-all-symbols &self (: t_l (%last_comment $_))))) -; - - - - (= - (with_self - (nal-reader *) - {$X }) - (call $X)) -; - - -; -; - - - (= - (nal-call $Ctx $Stream $Out) - ( (not (compound $Stream)) - (must-or-rtrace (nal-read-clauses $Stream $List)) - (set-det) - (nal-call $Ctx $List $Out))) -; - - - (= - (nal-call $Ctx $List $Out) - ( (is-list $List) - (set-det) - (maplist - (nal-call $Ctx) $List $OutL) - (flatten $OutL $Out))) -; - - (= - (nal-call $Ctx - (= $InnerCtx - (json $List)) $Out) - ( (set-det) (nal-call (Cons $InnerCtx $Ctx) $List $Out))) -; - - - (= - (nal-call $Ctx $List $Out) - ( (sub-term $Sub $List) - (nonvar $Sub) - (nal-rule-rewrite $Ctx $Sub $NewSub) - (nonvar $NewSub) - (\== $Sub $NewSub) - (subst $List $Sub $NewSub $NewList) - (\== $List $NewList) - (set-det) - (nal-call $Ctx $NewList $Out))) -; - - - (= - (nal-call $Ctx $List $Out) - ( (flatten - (:: $List) $Out) (set-det))) -; - - - - - - - (= - (nal-rule-rewrite $Ctx - (json $Replace) $Replace) - ( (nonvar $Replace) (set-det))) -; - - - - - (= - (nal-join-atomics $Sep $List $Joined) - (atomics-to-string $List $Sep $Joined)) -; - - - - !(fixup-exports *) -; - - - - (= - (nal_is_test read "'the detective claims that tim lives in graz") True) -; - - (= - (nal_is_test read "<{tim} --> (/,livingIn,_,{graz})>.") True) -; - - (= - (nal_is_test read " swimmer>. %0.87;0.91%") True) -; - - (= - (nal_is_test read "''outputMustContain(' swimmer>. %0.87;0.91%')") True) -; - - (= - (nal_is_test read "1") True) -; - - - (= - (nal_is_test read "$1") True) -; - - (= - (nal_is_test read "#1") True) -; - - (= - (nal_is_test read "?1") True) -; - - (= - (nal_is_test read "/1") True) -; - - (= - (nal_is_test read "\\1") True) -; - -; -; - -; -; - -; -; - -; -; - - (= - (nal_is_test read "'eating tiger") True) -; - - (= - (nal_is_test read "(eat /1 tiger)") True) -; - - (= - (nal_is_test read "(/,eat,_,tiger)") True) -; - - (= - (nal_is_test read "'eaten by tiger") True) -; - - (= - (nal_is_test read "(eat /2 tiger)") True) -; - - (= - (nal_is_test read "(/,eat,tiger,_)") True) -; - - (= - (nal_is_test read "'intensional eating") True) -; - - (= - (nal_is_test read "(eat \\1 tiger)") True) -; - - (= - (nal_is_test read "(\\,eat,_,tiger)") True) -; - - (= - (nal_is_test read "(eat \\2 tiger)") True) -; - - (= - (nal_is_test read "(\\,eat,tiger,_)") True) -; - - - -; -; - - (= - (nal_is_test exec "'Revision ------\n\n'Bird is a type of swimmer.\n swimmer>.\n\n'Bird is probably not a type of swimmer.\n swimmer>. %0.10;0.60%\n\n1\n\n'Bird is very likely to be a type of swimmer.\n''outputMustContain(' swimmer>. %0.87;0.91%')") True) -; - - - (= - (nal_is_test exec "\n********** revision\n IN: swimmer>. %1.00;0.90% {0 : 1} \n IN: swimmer>. %0.10;0.60% {0 : 2} \n1\n OUT: swimmer>. %0.87;0.91% {1 : 1;2} \n") True) -; - - - - (= - (nal_is_test exec "\n********** abduction\n IN: competition>. %1.00;0.90% {0 : 1} \n IN: competition>. %0.90;0.90% {0 : 2} \n1\n OUT: chess>. %1.00;0.42% {1 : 2;1} \n OUT: sport>. %0.90;0.45% {1 : 2;1} \n OUT: sport>. %0.90;0.45% {1 : 2;1} \n OUT: <(&,chess,sport) --> competition>. %1.00;0.81% {1 : 2;1} \n OUT: <(|,chess,sport) --> competition>. %0.90;0.81% {1 : 2;1} \n OUT: < $1> ==> $1>>. %0.90;0.45% {1 : 2;1} \n OUT: < $1> ==> $1>>. %1.00;0.42% {1 : 2;1} \n OUT: < $1> <=> $1>>. %0.90;0.45% {1 : 2;1} \n OUT: (&&, #1>, #1>). %0.90;0.81% {1 : 2;1} \n") True) -; - - - (= - (nal_is_test exec "\n********* induction\n IN: swimmer>. %0.90;0.90% {0 : 1} \n IN: bird>. %1.00;0.90% {0 : 2} \n1\n OUT: swimmer>. %0.90;0.45% {1 : 2;1} \n OUT: bird>. %1.00;0.42% {1 : 2;1} \n OUT: swimmer>. %0.90;0.45% {1 : 2;1} \n OUT: (|,bird,swimmer)>. %1.00;0.81% {1 : 2;1} \n OUT: (&,bird,swimmer)>. %0.90;0.81% {1 : 2;1} \n OUT: <<$1 --> swimmer> ==> <$1 --> bird>>. %1.00;0.42% {1 : 2;1} \n OUT: <<$1 --> bird> ==> <$1 --> swimmer>>. %0.90;0.45% {1 : 2;1} \n OUT: <<$1 --> bird> <=> <$1 --> swimmer>>. %0.90;0.45% {1 : 2;1} \n OUT: (&&,<#1 --> bird>,<#1 --> swimmer>). %0.90;0.81% {1 : 2;1} \n") True) -; - - - (= - (nal_is_test exec "\n********** exemplification\n IN: bird>. %1.00;0.90% {0 : 1} \n IN: animal>. %1.00;0.90% {0 : 2} \n1\n OUT: animal>. %1.00;0.81% {1 : 2;1} \n OUT: robin>. %1.00;0.45% {1 : 2;1} \n") True) -; - - - (= - (nal_is_test exec "\n********** conversion\n IN: swimmer>. %1.00;0.90% {0 : 1} \n IN: bird>? {0 : 2} \n2\n OUT: bird>. %1.00;0.47% {2 : 1} \n") True) -; - - - (= - (nal_is_test exec "\n********** y/n question\n IN: swimmer>. %1.00;0.90% {0 : 1} \n IN: swimmer>? {0 : 2} \n1\n OUT: swimmer>. %1.00;0.90% {0 : 1} \n") True) -; - - - (= - (nal_is_test exec "\n********** wh-question\n IN: swimmer>. %1.00;0.80% {0 : 1} \n IN: swimmer>? {0 : 2} \n1\n OUT: swimmer>. %1.00;0.80% {0 : 1} \n") True) -; - - - (= - (nal_is_test exec "\n\n'the detective claims that tim lives in graz\n'<{tim} --> (/,livingIn,_,{graz})>.\n'and lawyer claims that this is not the case\n<{tim} --> (/,livingIn,_,{graz})>. %0%\n100\n'the first deponent, a psychologist,\n'claims that people with sunglasses are more aggressive\n<<(*,$1,sunglasses) --> own> ==> <$1 --> [aggressive]>>.\n'the third deponent claims, that he has seen tom with sunglasses on:\n<(*,{tom},sunglasses) --> own>.\n'the teacher claims, that people who are aggressive tend to be murders\n<<$1 --> [aggressive]> ==> <$1 --> murder>>.\n'the second deponent claims, that if the person lives in Graz, he is surely the murder\n<<$1 --> (/,livingIn,_,{graz})> ==> <$1 --> murder>>.\n'who is the murder?\n<{?who} --> murder>?\n''outputMustContain('<{tom} --> murder>. %1.00;0.73%')\n\n") True) -; - - - (= - (nal_is_test read "\n' Custom truth values These are added by appending {0.0 0.9} instead of %0.0;0.9% as we believe this increased the readability.\n\n' Example\n\n********** wh-question\n IN: swimmer>. %1.00;0.80% {0 : 1} \n IN: swimmer>? {0 : 2} \n1\n OUT: swimmer>. %1.00;0.80% {0 : 1} \n\n' can now be\n\n\n********** wh-question\n IN: swimmer>. {1.0 0.80} {0 : 1} \n IN: swimmer>? {0 : 2} \n1\n OUT: swimmer>. {1.0 0.80} {0 : 1} \n\n") True) -; - - - (= - (nal_is_test read "\n'Images\n\n(/,rel,_,b) \n\n' has to be written as\n\n(rel /1 b)\n\n' and image as\n\n(/,rel,a,_) \n\n' as\n\n(rel /2 a)\n\n' same for \\ with \\1 and \\2.\n\n") True) -; - - - (= - (nal_is_test read "\n'Intervals, to measure expected time distances between events, are always learned by ONA and stored as meta-data, they are not part of the Narsese I/O format anymore. Hence a sequence\n\n(&/,a,+5,b)\n\n' becomes\n\n(&/,a,b)\n\n' or\n\n(a &/ b)\n\n' and also the interval for implications is not used anymore.\n\n") True) -; - - - (= - (nal_is_test read "\n'Operators The syntactic sugar\n\n(^op,arg_1,arg_2,arg_3,arg_n)\n\n' is not supported anymore, instead the full notation has to be used which is supported by both systems:\n\n<(*,arg_1,arg_2,arg_3,arg_n) --> ^op>\n\n' though for operations without arguments, the following shortcut can be used:\n\n^op\n\n") True) -; - - - (= - (nal_is_test read "\n'Restrictions\n\n'1. Copulas in ONA are binary, since it's using an array-based heap for terms. \n' While there are ways to encode n-ary relations in a binary heap, the ONA philosophy, following KISS, \n' encourages the use of left-nesting, which is also used by the system itself to compose sequences of events:\n\n((a &/ b) &/ c).\n\n") True) -; - - - (= - (nal_is_test read "\n'2. The parallel temporal copula &| is not implemented, please use &/ for now, again due to KISS. \n' If the order does not matter in some background knowledge we want to give the system, in addition to\n\n<(a &/ b) =/> c>\n\n' also give it\n\n<(b &/ a) =/> c>\n\n' to achieve the same as with &| for now.\n") True) -; - - - (= - (nal_is_test read "\n'Optional syntactic improvements\n' The ONA parser does not require commas, and doesn't distinguish between < and (, also it supports infix format.\n\n<(|,a,b) --> M>. \n\n' can be written as\n\n<(a | b) --> M>. \n\n' or even as\n\n((a | b) --> M).\n\n' Note: Spaces cannot be omitted.\n") True) -; - - - (= - (nal_is_test read "\n'Tim is alive.\n\n<{Tim} --> [alive]>.\n\n'Tim is a human.\n\n<{Tim} --> human>.\n") True) -; - - - (= - (nal_is_test read "\n'Humans are a lifeform.\n\n lifeform>.\n\n'Lifeforms are like machines.\n\n machine>.\n") True) -; - - - (= - (nal_is_test read "\n'Tom eats chocolate.\n\n<(*,{Tom},chocolate) --> eat>.\n\n<{Tom} --> (/,eat,_,chocolate)>.\n\n (/,eat,{Tom},_)>.\n") True) -; - - - (= - (nal_is_test read "\n*volume=0\n*motorbabbling=false\n in>. :|:\n<({SELF} * kitchen) --> ^go>. :|:\n<({cat} * kitchen) --> in>. :|:\n100\n in>. :|:\n<({SELF} * bedroom) --> ^go>. :|:\n<({cat} * bedroom) --> in>. :|:\n100\n in>. :|:\n<({SELF} * livingroom) --> ^go>. :|:\n//no cat this time, it doesn't like the livingroom :)\n100\n in>. :|:\n<({SELF} * bedroom) --> ^go>. :|:\n<({cat} * bedroom) --> in>. :|:\n100\n//Ok you are in corridor now\n in>. :|:\n") True) -; - - - (= - (nal_is_test read "\n*volume=0\nG! :|:\n") True) -; - - - (= - (nal_is_test read "//Jonas has asthma?\n<{jonas} --> [asthma]>?\n//expected: Answer: <{jonas} --> [asthma]>. Truth: frequency=1.000000, confidence=0.801900\n//Angelika has asthma?\n<{angelika} --> [asthma]>?\n//expected: Answer: <{angelika} --> [asthma]>. Truth: frequency=1.000000, confidence=0.810000") True) -; - - - - (= - (nal_is_test exec "\n'********** [08 + 09 -> 10]:\n\n'The robot is holding key001. \n<(*,Self,key001) --> hold>. :|: %1.00;0.81% \n\n1\n\n'The robot is holding key001. \n<(*,Self,key001) --> hold>. :|:\n\n5\n\n'The robot is holding key001. \n''outputMustContain('<(*,Self,key001) --> hold>. :!1: %1.00;0.93%') \n") True) -; - - - - (= - (nal_is_test exec "\n'********** compound composition, two premises\n\n'Sport is a type of competition. \n competition>. %0.90% \n\n'Chess is a type of competition. \n competition>. %0.80% \n\n16\n\n'If something is either chess or sport, then it is a competition.\n''outputMustContain('<(|,chess,sport) --> competition>. %0.72;0.81%')\n\n'If something is both chess and sport, then it is a competition.\n''outputMustContain('<(&,chess,sport) --> competition>. %0.98;0.81%')\n") True) -; - - - - (= - (nal_is_test exec "\n********** [07 + 09 -> 11]:\n IN: <(*,key001) --> ^pick>. :|: %1.00;0.90% {0 : 0 : 1} \n\n1\n\n IN: <(*,Self,key001) --> hold>. :|: %1.00;0.90% {1 : 1 : 2} \n\n1\n\n OUT: <<(*,Self,key001) --> hold> =\\> <(*,key001) --> ^pick>>. :\\: %1.00;0.45% {2 : 1 : 1;2} \n\n OUT: <<(*,key001) --> ^pick> =/> <(*,Self,key001) --> hold>>. :\\: %1.00;0.45% {2 : 1 : 1;2} \n\n OUT: <<(*,key001) --> ^pick> <(*,Self,key001) --> hold>>. :\\: %1.00;0.45% {2 : 1 : 1;2} \n\n OUT: (/,^pick,_)>. :\\: %1.00;0.90% {2 : 0 : 1} \n") True) -; - - - (= - (nal_is_test exec "********** deduction\n IN: animal>. %1.00;0.90% {0 : 1} \n IN: bird>. %1.00;0.90% {0 : 2} \n1\n OUT: animal>. %1.00;0.81% {1 : 2;1} \n OUT: robin>. %1.00;0.45% {1 : 2;1} ") True) -; - - - (= - (nal_is_test exec "********** deduction\n'the detective claims that tim lives in graz\n'<{tim} --> (/,livingIn,_,{graz})>.\n'and lawyer claims that this is not the case\n<{tim} --> (/,livingIn,_,{graz})>. %0%\n100\n'the first deponent, a psychologist,\n'claims that people with sunglasses are more aggressive\n<<(*,$1,sunglasses) --> own> ==> <$1 --> [aggressive]>>.\n'the third deponent claims, that he has seen tom with sunglasses on:\n<(*,{tom},sunglasses) --> own>.\n'the teacher claims, that people who are aggressive tend to be murders\n<<$1 --> [aggressive]> ==> <$1 --> murder>>.\n'the second deponent claims, that if the person lives in Graz, he is surely the murder\n<<$1 --> (/,livingIn,_,{graz})> ==> <$1 --> murder>>.\n'who is the murder?\n<{?who} --> murder>?\n''outputMustContain('<{tom} --> murder>. %1.00;0.73%')") True) -; - - - (= - (nal_is_test read "\n//First: Input diamond:\n// | â\x96\\x88\â\x96\\x88\ |\n// | â\x96\\x88\â\x96\\x88\ â\x96\\x88\â\x96\\x88\ |\n// |â\x96\\x88\â\x96\\x88\ â\x96\\x88\â\x96\\x88\|\n// | â\x96\\x88\â\x96\\x88\ â\x96\\x88\â\x96\\x88\ |\n// | â\x96\\x88\â\x96\\x88\ |:\n<{M1[-1.0,0.0]} --> [BRIGHT]>.\n<{M1[1.0,0.0]} --> [BRIGHT]>.\n<{M1[0.0,1.0]} --> [BRIGHT]>.\n<{M1[0.0,-1.0]} --> [BRIGHT]>.\n<{M1[0.5,0.5]} --> [BRIGHT]>.\n<{M1[-0.5,0.5]} --> [BRIGHT]>.\n<{M1[0.5,-0.5]} --> [BRIGHT]>.\n<{M1[-0.5,-0.5]} --> [BRIGHT]>.\n<{M1} --> (/,called,_,circle)>.\n\n//Re-observe imperfectly\n// |â\x96\\x92\â\x96\\x92\ â\x96\\x88\â\x96\\x88\ |\n// | â\x96\\x88\â\x96\\x88\ â\x96\\x92\â\x96\\x92\ |\n// |â\x96\\x92\â\x96\\x92\ â\x96\\x88\â\x96\\x88\|\n// | â\x96\\x88\â\x96\\x88\ â\x96\\x92\â\x96\\x92\â\x96\\x92\â\x96\\x92\|\n// | |:\n<{M3[-1.0,1.0]} --> [BRIGHT]>. %0.5%\n<{M3[0.0,1.0]} --> [BRIGHT]>.\n<{M3[-0.5,0.5]} --> [BRIGHT]>.\n<{M3[0.5,0.5]} --> [BRIGHT]>. %0.5%\n<{M3[-1.0,0.0]} --> [BRIGHT]>. %0.5%\n<{M3[1.0,0.0]} --> [BRIGHT]>.\n<{M3[-0.5,-0.5]} --> [BRIGHT]>.\n<{M3[0.5,-0.5]} --> [BRIGHT]>. %0.5%\n<{M3[1.0,-0.5]} --> [BRIGHT]>. %0.5%\n\n50000\n//What was observed?\n<{M3} --> (/,called,_,?what)>?\n//A circle\n''outputMustContain('<{M3} --> (/,called,_,circle)>. %0.83;0.36%')") True) -; - - - (= - (nal_is_test exec "\n*volume=0\nburgers are tasty food\nthe stranger eats a burger in the pub\n100\nwho eats tasty food?\n//expected: Answer: (eat /1 ([tasty] & food))>. :|: occurrenceTime=2 Truth: frequency=1.000000, confidence=0.278811\nwho is in the pub?\n//expected: Answer: (in /1 pub)>. :|: occurrenceTime=3 Truth: frequency=1.000000, confidence=0.900000\n") True) -; - - - (= - (nal_is_test exec "\n//NARS, where is the cat?\n//Passive question <({cat} * ?where) --> in>? :|: wouldn't trigger a decision\n//Active question however does:\n<(<({cat} * #where) --> in> &/ <({SELF} * #where) --> ^say>) =/> G>.\nG! :|:\n100\n//expected: ^go executed with args ({SELF} * bedroom)\n") True) -; - - - (= - (nal_is_test read "\n//ok, feedback of NARS going to the bedroom, the cat is there!\n<({cat} * bedroom) --> in>. :|:\nG! :|:\n10\n//expected: ^say executed with args ({SELF} * bedroom)\n") True) -; - - - - (= - (nal_is_test exec "\n'********** compound composition, two premises\n\n'Sport is a type of competition. \n competition>. %0.90% \n\n'Chess is a type of competition. \n competition>. %0.80% \n\n16\n\n'If something is either chess or sport, then it is a competition.\n''outputMustContain('<(|,chess,sport) --> competition>. %0.72;0.81%')\n\n'If something is both chess and sport, then it is a competition.\n''outputMustContain('<(&,chess,sport) --> competition>. %0.98;0.81%')\n") True) -; - - - (= - (nal_is_test read " (/,REPRESENT,_,DOG)>. %1.00;0.90% {0 : 2} ") True) -; - - - (= - (nal_is_test read "\n'********** induction on events \n\n'John is opening door_101\n (/,open,_,door_101)>. :|: \n\n6\n\n'John is entering room_101\n (/,enter,_,room_101)>. :|: \n\n20\n\n'If John enter room_101, he should open door_101 before\n''outputMustContain('< (/,enter,_,room_101)> =\\> (&/, (/,open,_,door_101)>,+6)>. :!6: %1.00;0.45%')\n\n'new: variable introduction also in time:\n\n'If someone enter room_101, he should open door_101 before\n''outputMustContain('<<$1 --> (/,enter,_,room_101)> =\\> (&/,<$1 --> (/,open,_,door_101)>,+6)>. :!6: %1.00;0.45%')\n\n'adjusted +2 to +3 in both conditions\n\n10\n") True) -; - - - (= - (nal_is_test read "\n''outputMustContain('< (/,enter,_,room_101)> =\\> (&/, (/,open,_,door_101)>,+6)>. :!6: %1.00;0.45%')") True) -; - - (= - (nal_is_test read "\n''outputMustContain('<<$1 --> (/,enter,_,room_101)> =\\> (&/,<$1 --> (/,open,_,door_101)>,+6)>. :!6: %1.00;0.45%')") True) -; - - - - (= - (nal_is_test read "\n< (/,enter,_,room_101)> =\\> (&/, (/,open,_,door_101)>,+6)>. :!6: %1.00;0.45%") True) -; - - (= - (nal_is_test read "<<$1 --> (/,enter,_,room_101)> =\\> (&/,<$1 --> (/,open,_,door_101)>,+6)>. :!6: %1.00;0.45%") True) -; - - (= - (nal_is_test read "****************I am a comment") True) -; - - (= - (nal_is_test read "****************") True) -; - - - (= - (nal_is_test exec "\n*volume=0\n//When a person picks an object in a place, the picked object is also in that place\n<<#Person --> ((pick /1 $Object) & (in /1 $Place))> ==> <$Object --> (in /1 $Place)>>.\nJohn is in the playground.\nBob is in the office.\nJohn picked up the football.\nBob went to the kitchen.\n50\nThe football is in what?\n//expected: Answer: (in /1 playground)>. :|: occurrenceTime=4 Truth: frequency=1.000000, confidence=0.466560\n") True) -; - - - - (= - (nal_is_test exec "\n********** conditional deduction\n IN: <(&&,a,b) ==> c>. %1.00;0.90% {0 : 1} \n IN: a. %1.00;0.90% {0 : 2} \n1\n OUT: c>. %1.00;0.81% {1 : 1;2} \n") True) -; - - - (= - (nal-is-test read $X) - ( (atomic-list-concat $List - "IN: (&|,<#1() --> (/,at,Self,_)>,<(*,{t002},#1()) --> on>). :\\:\n IN: (&|,<#1() --> (/,at,Self,_)>,<(*,{t002},#1()) --> on>). :\\: %1.00;0.90% {0 : -1 : 1}\n IN: (&|,<#1() --> (/,on,{t002},_)>,<#1() --> (/,at,Self,_)>). :\\:\n IN: (&|,<#1() --> (/,on,{t002},_)>,<#1() --> (/,at,Self,_)>). :\\: %1.00;0.90% {0 : -1 : 1}\n IN: (&|,<(*,{t002},#1()) --> on>,<(*,Self,#1()) --> at>)!\n IN: (&|,<(*,{t002},#1()) --> on>,<(*,Self,#1()) --> at>)! %1.00;0.90% {0 : 2}\n IN: (&|,<(*,{t002},#1()) --> on>,<(*,Self,#1()) --> at>). :|:\n IN: (&|,<(*,{t002},#1()) --> on>,<(*,Self,#1()) --> at>). :|: %1.00;0.90% {0 : 0 : 1}\n IN: <(&|,<(*,#1,#2(#1)) --> on>,<(*,Self,#2(#1)) --> at>) =|> <(*,Self,#1) --> reachable>>.\n IN: <(&|,<(*,#1,#2(#1)) --> on>,<(*,Self,#2(#1)) --> at>) =|> <(*,Self,#1) --> reachable>>. %1.00;0.90% {0 : 1}\n IN: <(&|,<(*,#1,#2(#1)) --> on>,<(*,Self,#2(#1)) --> at>) =|> <(*,Self,#1) --> reachable>>. %1.00;0.90% {0 : 2}\n IN: <(&|,<(*,#1,#2(#1)) --> on>,<(*,Self,#2(#1)) --> at>) =|> <(*,Self,#1) --> reachable>>. \n IN: <(&|,<(*,#1,#2(#1)) --> on>,<(*,Self,#2(#1)) --> at>) =|> <(*,Self,#1) --> reachable>>.\n IN: <(&|,<(*,#1,#2(#1)) --> on>,<(*,Self,#2(#1)) --> at>)=|><(*,Self,#1) --> reachable>>.\n OUT: (&|,<#1() --> (/,at,Self,_)>,<(*,{t002},#1()) --> on>). :\\: %1.00;0.90%\n OUT: (&|,<#1() --> (/,at,Self,_)>,<(*,{t002},#1()) --> on>). :\\: %1.00;0.90% {8 : -1 : 1}\n OUT: (&|,<#1() --> (/,at,Self,_)>,<{t002} --> (/,on,_,#1())>). :\\: %1.00;0.90% {6 : -1 : 1}\n OUT: (&|,<#1() --> (/,on,{t002},_)>,<#1() --> (/,at,Self,_)>). :\\: %1.00;0.81%\n OUT: (&|,<#1() --> (/,on,{t002},_)>,<#1() --> (/,at,Self,_)>). :\\: %1.00;0.81% {2 : -1 : 2;1}\n OUT: (&|,<(*,Self,#1()) --> at>,<{t002} --> (/,on,_,#1())>)! %1.00;0.90% {6 : 2}\n OUT: (&|,<(*,Self,#1()) --> at>,<{t002} --> (/,on,_,#1())>)? :\\: {23 : 1 : 3}\n OUT: (&|,<(*,Self,#1()) --> at>,<{t002} --> (/,on,_,#1())>)? :|: {7 : 7 : 5}\n OUT: (&|,<(*,{t002},#1()) --> on>,<(*,Self,#1()) --> at>)! %1.00;0.81%\n OUT: (&|,<(*,{t002},#1()) --> on>,<(*,Self,#1()) --> at>)! %1.00;0.81% {16 : 2;1}\n OUT: (&|,<(*,{t002},#1()) --> on>,<(*,Self,#1()) --> at>). :\\: %1.00;0.90%\n OUT: (&|,<(*,{t002},#1()) --> on>,<(*,Self,#1()) --> at>). :\\: %1.00;0.90% {4 : -1 : 1}\n OUT: (&|,<(*,{t002},#1()) --> on>,<(*,Self,#1()) --> at>)? :|: {1 : 1 : 3}\n OUT: (&|,<(*,{t002},#1()) --> on>, (/,at,_,#1())>)! %1.00;0.90% {1 : 2}\n OUT: (&|,<(*,{t002},#1()) --> on>, (/,at,_,#1())>). :\\: %1.00;0.90% {3 : -1 : 1}\n OUT: (&|,<(*,{t002},#1()) --> on>, (/,at,_,#1())>)? :\\: {15 : 1 : 3}\n OUT: (&|,<(*,{t002},#1()) --> on>, (/,at,_,#1())>)? :|: {2 : 2 : 4}\n OUT: <(&|,<(*,#1,#2(#1)) --> on>, (/,at,_,#2(#1))>) ==> <(*,Self,#1) --> reachable>>. %1.00;0.90% {4 : 1}") (member $X $List))) -; - - - - - (= - (nal-is-test read $X) - ( (atomic-list-concat $List - "\n ''outputMustContain('')\n ''outputMustContain('(&/,(^go-to,{t003}),(^pick,{t002}),(^go-to,{t001}),(^open,{t001}))! %1.00;0.43%')\n ''outputMustContain('(^go-to,{t001})! %1.00;0.81%')\n ''outputMustContain('(^go-to,{t003})! %1.00;0.81%')\n ''outputMustContain('...')\n ''outputMustContain('<(&&,<$1 --> [chirping]>,<$1 --> [with-wings]>) ==> <$1 --> bird>>. %1.00;0.81%')\n ''outputMustContain('<(&&,<$1 --> [with-wings]>,<(*,$1,worms) --> food>) ==> <$1 --> bird>>. %1.00;0.45%')\n ''outputMustContain('<(&&,<$1 --> flyer>,<(*,$1,worms) --> food>) ==> <$1 --> [with-wings]>>. %1.00;0.45%')\n ''outputMustContain('<(&&, [chirping]>, [with-beak]>) ==> bird>>. %1.00;0.42%')\n ''outputMustContain('<(&&, [chirping]>, [with-wings]>) ==> bird>>. %1.00;0.81%')\n ''outputMustContain('<(&/,(^go-to,{t003}),(^pick,{t002}),(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>. %1.00;0.43%')\n ''outputMustContain('<(&/,<(*,Self,{t002}) --> reachable>,(^pick,{t002}),(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>. %1.00;0.81%')\n ''outputMustContain('<<$1 --> [with-wings]> ==> (&&,<$1 --> flyer>,<(*,$1,worms) --> food>)>. %1.00;0.45%')\n ''outputMustContain('< [with-wings]> ==> bird>>. %0.90;0.45%')\n ''outputMustContain('< [with-wings]> ==> bird>>. %1.00;0.81%')\n ''outputMustContain('< bird> ==> [with-wings]>>. %1.00;0.42%')\n ''outputMustContain(' swan>. %0.10')\n (&&,<#x --> P >, <#x --> S>) ?\n (&&, P1>, P2>) .\n (&&, P1>, P2>)?\n (--, ).\n (^go-to,{SELF},{t001}). :\\:\n < (&&,<(*,#manswer,#m) --> replyTo>, <(*,#manswer,U) --> sender>) <=> <#m --> uResponse> >.\n < <#x --> P > ==> (/,R, #x, _ ) > >.\n <(&&, <#y --> S>, <#x --> P> ) ==> <#y --> (/, R, #x, _ )> > ?\n <(&&,<$x --> [chirping]>,<$x --> [with-wings]>) ==> <$x --> bird>>.\n <(&&,<$x --> flyer>,<$x --> [chirping]>, <(*, $x, worms) --> food>) ==> <$x --> bird>>.\n <(&&,<$y --> [chirping]>,<$y --> [with-wings]>) ==> <$y --> bird>>.\n <(&&, [chirping]>, [flying]>, [with-wings]>) ==> bird>>.\n <(&&, [flying]>, [with-wings]>) ==> [living]>>. %0.9%\n <(&&, [flying]>, [with-wings]>) ==> bird>>.\n <(&&, [flying]>, [with-wings]>, [chirping]>) ==> bird>>.\n <(&&, [with-wings]>, [chirping]>) ==> bird>>.\n <(&, [red], light) --> traffic_signal>?\n <(&/, (||, S, P), +5) =/> M>. %0.9%\n <(&/, a, +1) =/> b>.\n <(&/, b, +1) =/> c>.\n <(&/,(^go-to,{t003}),(^pick,{t002}),(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>. :|:\n <(&/,<(*,Self,{t002}) --> hold>,(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>.\n <(&/,<(*,Self,{t003}) --> at>,(^pick,{t002}),(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>. :|:\n <(*, John, key_101) --> hold>. :\\:\n <(*,S1, S2 ) --> (*,P1, P2 )> ?\n <(*,S1, S2 ) --> (*,P1, P2 )>.\n <(*,{t003}) --> ^go-to>. :|:\n <(^go-to,$1) =/> <(*,Self,$1) --> at>>.\n <(^go-to,$1)=/><(*,SELF,$1) --> at>>.\n <(^go-to,{SELF},$1)=/><(*,{SELF},$1) --> at>>.\n <(|, boy, girl) --> youth>. %0.90%\n <(~, boy, girl) --> [strong]>. %0.90%\n <(~,swimmer, swan) --> bird>?\n <<$y --> [with-wings]> ==> <$y --> flyer>>.\n <<$y --> flyer> ==> <$y --> [with-wings]>>.\n <<(*,$1) --> ^go-to> =/> <(*,SELF,$1) --> at>>.\n <<(*,$1,$2) --> Friends> ==> (||, (&&,<$1 --> [Smokes]>,<$2 --> [Smokes]>), (&&,(--,<$1 --> [Smokes]>),(--,<$2 --> [Smokes]>)))>. %0.6;0.9%\n < [flying]> ==> [with-beak]>>. %0.90%\n .\n .\n .\n .\n ?\n <{Tweety} --> [with-wings]>.\n [number]: # of cycles to process before continuing to next line\n IN: (^go-to,{t001})!\n IN: (^go-to,{t001}). :\\:\n IN: (^go-to,{t003})! %1.00;0.90% {0 : 1}\n IN: (^go-to,{t003}). :|:\n IN: <(&&,<$1 --> [chirping]>,<$1 --> [with-wings]>) ==> <$1 --> bird>>. %1.00;0.90% {0 : 2}\n IN: <(&&, [chirping]>, [flying]>, [with-wings]>) ==> bird>>. %1.00;0.90% {0 : 1}\n IN: <(&&, [chirping]>, [flying]>, [with-wings]>) ==> bird>>. %1.00;0.90% {0 : 2}\n IN: <(&&, [chirping]>, [with-wings]>) ==> bird>>. %1.00;0.90% {0 : 1}\n IN: <(&&, [flying]>, [with-wings]>) ==> [living]>>. %0.90;0.90% {0 : 1}\n IN: <(&&, [flying]>, [with-wings]>) ==> bird>>. %1.00;0.90% {0 : 1}\n IN: <(&/,(^go-to,{t003}),(^pick,{t002}),(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>. :|:\n IN: <(&/,<(*,Self,{t002}) --> hold>,(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>.\n IN: <(&/,<(*,Self,{t002}) --> hold>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. %1.00;0.90% {0 : 1}\n IN: <(&/,<(*,Self,{t002}) --> reachable>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. %1.00;0.90% {0 : 1}\n IN: <(&/,<(*,Self,{t003}) --> at>,(^pick,{t002}),(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>. :|:\n IN: <(&/,<(*,Self,{t003}) --> at>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. :|: %1.00;0.90% {0 : 0 : 1}\n IN: <(&/,<(*,{t003}) --> ^go-to>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. :|: %1.00;0.90% {0 : 0 : 2}\n IN: <(*, John, key_101) --> hold>. :/:\n IN: <(*,{t001}) --> ^go-to>! %1.00;0.90% {0 : 1}\n IN: <(*,{t001}) --> ^go-to>. :\\: %1.00;0.90% {0 : -1 : 1}\n IN: <(*,{t003}) --> ^go-to>! %1.00;0.90% {0 : 1}\n IN: <(*,{t003}) --> ^go-to>. :|: %1.00;0.90% {0 : 0 : 1}\n IN: <(^go-to,#1) =/> <(*,Self,#1) --> at>>.\n IN: <(^go-to,#1)=/><(*,Self,#1) --> at>>.\n IN: <<$1 --> [with-wings]> ==> <$1 --> flyer>>. %1.00;0.90% {0 : 2}\n IN: <<$1 --> flyer> ==> <$1 --> [with-wings]>>. %1.00;0.90% {0 : 2}\n IN: <<(*,#1) --> ^go-to> =/> <(*,Self,#1) --> at>>. %1.00;0.90% {0 : 1}\n IN: <<(*,#1) --> ^go-to> =/> <(*,Self,#1) --> at>>. %1.00;0.90% {0 : 2}\n IN: < [flying]> ==> [with-beak]>>. %0.90;0.90% {0 : 2}\n IN: <{Tweety} --> [with-wings]>. %1.00;0.90% {0 : 1}\n out is a reference to the current output buffer, containing a list of strings; one for each output\n OUT: (&/,(^go-to,{t003}),(^pick,{t002}),(^go-to,{t001}),(^open,{t001}))! %1.00;0.81%\n OUT: (&/,<(*,{t003}) --> ^go-to>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>)! %1.00;0.81% {16 : 2;1}\n OUT: (&/,<(*,{t003}) --> ^go-to>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>)? :\\: {13 : 0 : 2;3}\n OUT: (&/,<(*,{t003}) --> ^go-to>,<(*,{t002}) --> ^pick>,<{t001} --> (/,^go-to,_)>,<(*,{t001}) --> ^open>)? :\\: {14 : 0 : 2;3}\n OUT: (^go-to,{t001})! %1.00;0.81%\n OUT: (^go-to,{t001}). :|: %1.00;0.90%\n OUT: (^go-to,{t003})! %1.00;0.81%\n OUT: (^go-to,{t003}). :|: %1.00;0.90%\n OUT: <(&&,<$1 --> [chirping]>,<$1 --> [with-wings]>) ==> <$1 --> bird>>. %1.00;0.81%\n OUT: <(&&,<$1 --> [chirping]>,<$1 --> [with-wings]>) ==> <$1 --> bird>>. %1.00;0.81% {1 : 2;1}\n OUT: <(&&,<$1 --> [with-wings]>,<(*,$1,worms) --> food>) ==> <$1 --> bird>>. %1.00;0.45%\n OUT: <(&&,<$1 --> [with-wings]>,<(*,$1,worms) --> food>) ==> <$1 --> bird>>. %1.00;0.45% {4 : 1;2}\n OUT: <(&&,<$1 --> flyer>,<(*,$1,worms) --> food>) ==> <$1 --> [with-wings]>>. %1.00;0.45%\n OUT: <(&&,<$1 --> flyer>,<(*,$1,worms) --> food>) ==> <$1 --> [with-wings]>>. %1.00;0.45% {4 : 1;2}\n OUT: <(&&, [chirping]>, [with-beak]>) ==> bird>>. %1.00;0.42%\n OUT: <(&&, [chirping]>, [with-beak]>) ==> bird>>. %1.00;0.42% {11 : 1;2}\n OUT: <(&&, [chirping]>, [with-wings]>) ==> bird>>. %1.00;0.81%\n OUT: <(&&, [chirping]>, [with-wings]>) ==> bird>>. %1.00;0.81% {5 : 1;2}\n OUT: <(&/,(^go-to,{t003}),(^pick,{t002}),(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>. :\\: %1.00;0.81%\n OUT: <(&/,<(*,Self,{t002}) --> hold>,(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>. %1.00;0.81%\n OUT: <(&/,<(*,Self,{t002}) --> hold>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. %1.00;0.81% {2 : 2;1}\n OUT: <(&/,<(*,Self,{t002}) --> reachable>,(^pick,{t002}),(^go-to,{t001}),(^open,{t001})) =/> <{t001} --> [opened]>>. %1.00;0.81%\n OUT: <(&/,<(*,Self,{t002}) --> reachable>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. %1.00;0.81% {14 : 2;1}\n OUT: <(&/,<(*,Self,{t003}) --> at>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. %1.00;0.43% {5 : 2;1}\n OUT: <(&/,<(*,Self,{t003}) --> at>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. %1.00;0.43% {8 : 2;1}\n OUT: <(&/,<(*,Self,{t003}) --> at>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. :\\: %1.00;0.81% {17 : 0 : 1;2}\n OUT: <(&/,<(*,{t003}) --> ^go-to>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. %1.00;0.43% {11 : 1;2}\n OUT: <(&/,<(*,{t003}) --> ^go-to>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) =/> <{t001} --> [opened]>>. :\\: %1.00;0.81% {16 : 0 : 2;1}\n OUT: <(&/, (/,at,_,{t003})>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) ==> <{t001} --> [opened]>>. :\\: %1.00;0.90% {15 : 0 : 1}\n OUT: <(&/, (/,hold,_,{t002})>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) ==> <{t001} --> [opened]>>. %1.00;0.90% {10 : 1}\n OUT: <(&/, (/,reachable,_,{t002})>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) ==> <{t001} --> [opened]>>. %1.00;0.90% {16 : 1}\n OUT: <(&/,<{t002} --> (/,hold,Self,_)>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) ==> <{t001} --> [opened]>>. %1.00;0.90% {11 : 1}\n OUT: <(&/,<{t002} --> (/,reachable,Self,_)>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) ==> <{t001} --> [opened]>>. %1.00;0.90% {9 : 1}\n OUT: <(&/,<{t003} --> (/,^go-to,_)>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) ==> <{t001} --> [opened]>>. :\\: %1.00;0.90% {11 : 0 : 2}\n OUT: <(&/,<{t003} --> (/,at,Self,_)>,<(*,{t002}) --> ^pick>,<(*,{t001}) --> ^go-to>,<(*,{t001}) --> ^open>) ==> <{t001} --> [opened]>>. :\\: %1.00;0.90% {7 : 0 : 1}\n OUT: <(*,{t001}) --> ^go-to>! %1.00;0.81% {19 : 2;1}\n OUT: <(*,{t001}) --> ^go-to>. :|: %1.00;0.90% {1 : 1 : 2}\n OUT: <(*,{t003}) --> ^go-to>! %1.00;0.81% {19 : 2;1}\n OUT: <(*,{t003}) --> ^go-to>. :|: %1.00;0.90% {1 : 1 : 2}\n OUT: <(/,(*,{t001}),_) --> (/,^go-to,_)>. :\\: %1.00;0.90% {7 : -1 : 1}\n OUT: <(/,(*,{t003}),_) --> (/,^go-to,_)>. :\\: %1.00;0.90% {7 : 0 : 1}\n OUT: <(~,swimmer, swan) --> bird>. %0.10;0.73%\n OUT: <<$1 --> [with-wings]> ==> (&&,<$1 --> flyer>,<(*,$1,worms) --> food>)>. %1.00;0.45%\n OUT: <<$1 --> [with-wings]> ==> (&&,<$1 --> flyer>,<(*,$1,worms) --> food>)>. %1.00;0.45% {4 : 1;2}\n OUT: <<(*,#1) --> ^go-to> =/> (/,at,_,#1)>>. %1.00;0.90% {1 : 1}\n OUT: <<(*,#1) --> ^go-to> =/> (/,at,_,#1)>>. %1.00;0.90% {1 : 2}\n OUT: <<(*,#1) --> ^go-to> =/> (/,at,_,#1)>>. %1.00;0.90% {10 : 2}\n OUT: <<(*,#1) --> ^go-to> =/> (/,at,_,#1)>>. %1.00;0.90% {8 : 2}\n OUT: < [with-wings]> ==> bird>>. %0.90;0.45%\n OUT: < [with-wings]> ==> bird>>. %0.90;0.45% {8 : 2;1}\n OUT: < [with-wings]> ==> bird>>. %1.00;0.81%\n OUT: < [with-wings]> ==> bird>>. %1.00;0.81% {3 : 2;1}\n OUT: < bird> ==> [with-wings]>>. %1.00;0.42%\n OUT: < bird> ==> [with-wings]>>. %1.00;0.42% {8 : 2;1}\n OUT: <{t001} --> (/,^go-to,_)>. :\\: %1.00;0.90% {2 : -1 : 1}\n OUT: <{t003} --> (/,^go-to,_)>. :\\: %1.00;0.90% {2 : 0 : 1}\n IN: <(*, John, key_101) --> hold>. :/:\n.\n?\n(--, ).\n.\n<(~,swimmer, swan) --> bird>?\nOUT: <(~,swimmer, swan) --> bird>. %0.10;0.73%\n<(|, boy, girl) --> youth>. %0.90%\n<(~, boy, girl) --> [strong]>. %0.90%\n<(&&,<$x --> flyer>,<$x --> [chirping]>, <(*, $x, worms) --> food>) ==> <$x --> bird>>.\nIN: <(*, John, key_101) --> hold>. :/:\n\n''outputMustContain(' swan>. %0.10')\n\nnars hears a boom") - (member $X $List) - (\== $X "") - (\== $X ''))) -; - - - - (= - (nal_is_test exec "'********** conversions between inheritance and similarity\n\n'Swan is a type of bird. \n bird>. \n\n'Bird is not a type of swan. \n swan>. %0.10% \n\n1\n\n'Bird is different from swan. \n''outputMustContain(' swan>.')\n''outputMustContain(' swan>. %0.10')\n''outputMustContain(' swan>. %0.10;0.81%')\n\n") True) -; - - - (= - (nal_is_test read "\n<{a, b} |- (&/,a,b)>.") True) -; - - - (= - (nal_is_test read "\n<{a, b, after(a,b)} |- b>>.") True) -; - - - (= - (nal_is_test read "\n<{ b! , b>} |- a! >") True) -; - - - -; -; - +; {Event a., Implication b>.} |- Event b. diff --git a/nars_lp/nars/nars.metta b/nars_lp/nars/nars.metta index 1993ade..9a9ffa7 100644 --- a/nars_lp/nars/nars.metta +++ b/nars_lp/nars/nars.metta @@ -1,55 +1,37 @@ +; (convert_to_metta_file nars $_188462 nars_lp/nars/nars.pl nars_lp/nars/nars.metta) ; -; - +; nal.pl ; -; - +; Non-Axiomatic Logic in MeTTa ; -; - +; Version: 1.1, September 2012 ; -; - +; GNU Lesser General Public License ; -; - +; Author: Pei Wang/Pat Hammer/Douglas Miles !(module nars (:: (/ nars-main 1) (/ nars-main 0))) -; - +; /* User's Guide of NAL Input/Output Language In this demonstration, NAL implements the following formal language, Narsese. The input and output of the system are Narsese judgments. ::= [ [frequency-value, confidence-value]] ::= (, ) | | ::= | | | ::= | (*) ::= inheritance | similarity | implication | equivalence | instance | property | inst_prop // instance-property ::= negation() | conjunction([, +]) | disjunction([, +]) ::= ext_set([+]) // extensional set | int_set([+]) // intensional set | ext_intersection([, +]) // extensional intersection | int_intersection([, +]) // intensional intersection | ext_difference(, ) // extensional difference | int_difference(, ) // intensional difference | product([, +]) | ext_image(, ) // extensional image | int_image(, ) // intensional image The frequency-value is a real number in [0, 1]; the confidence-value a real number in (0, 1). User Interface The program can be invoked in the following ways: revision(J1, J2, J). Judgment J is the result of a revision between judgments J1 and J2. The three judgments all have the same statement in them. choice(J1, J2, J). Judgment J is the result of a choice between judgments J1 and J2. inference(J1, J2, J). Judgment J is the conclusion derived from judgments J1 and J2 as premises. inference(J1, J). Judgment J is the conclusion derived from judgment J1 as single premise. */ !(set-module (class library)) -; - !(set-module (base system)) -; - - !(use-module (library (/ nars nal-reader))) -; - + !(use-module (library (/ nars nal-reader))) ; -; - +; will change later to what we consider "enough" ground - (= - (narz-ground $G) + (= (narz-ground $G) (ground $G)) -; - - (= - (nars-string $Name) + (= (nars-string $Name) (or (atom $Name) (string $Name))) -; - @@ -60,374 +42,234 @@ - (= - (do-nars-example-tests) + (= (do-nars-example-tests) (run-nars-example-tests)) -; - - (= - (run-nars-example-tests) - ( (make) - (use-module - (library ../examples/prolog/nal/nal-examples) - (:: (/ nal-example-test 2))) - (add-history run-nars-example-tests) - (forall - (with_self - (nal-examples *) - (nal-example-test $Goal $Results)) - (take-nal-example-test $Goal $Results)))) -; - + (= (run-nars-example-tests) + (make) + (use-module + (library ../examples/prolog/nal/nal-examples) + (:: (/ nal-example-test 2))) + (add-history run-nars-example-tests) + (forall + (with_self + (nal-examples *) + (nal-example-test $Goal $Results)) + (take-nal-example-test $Goal $Results))) - (= - (with_self - (baseKB *) - (sanity-test)) + (= (with_self (baseKB *) (sanity-test)) (do-nars-example-tests)) -; - - (= - (with_self - (baseKB *) - (feature-test)) + (= (with_self (baseKB *) (feature-test)) (run-nars-example-tests)) -; - - - (= - (nal-into-prolog) - ( (make) (forall (, (nal-is-test $Type $Text) (== $Type into-prolog)) (nal-do-exec-test $Type $Text)))) -; + (= (nal-into-prolog) + (make) + (forall + (, + (nal-is-test $Type $Text) + (== $Type into-prolog)) + (nal-do-exec-test $Type $Text))) +; /* ```diff - text in red + text in green ! text in orange # text in gray @@ text in purple (and bold)@@ ``` */ +; ;take_nal_example_test(_,_):- make, fail. - (= - (nal-do-exec-test $Type $Text) + (= (nal-do-exec-test $Type $Text) (nal-do-exec-test-text $Text)) -; - - (= - (nal-do-exec-test-text $Text) - ( (nal-read-clauses $Text $Clauses) (nars-exec-ex in $Clauses))) -; - + (= (nal-do-exec-test-text $Text) + (nal-read-clauses $Text $Clauses) + (nars-exec-ex in $Clauses)) - (= - (nars-exec-ex $Clauses) + (= (nars-exec-ex $Clauses) (nars-exec-ex in $Clauses)) -; - - (= - (nars-exec-ex $_ Nil) + (= (nars-exec-ex $_ Nil) (set-det)) -; - - (= - (nars-exec-ex $IO - (Cons $C $Clauses)) - ( (set-det) - (nars-exec-ex $IO $C) - (nars-exec-ex $IO $Clauses))) -; - - (= - (nars-exec-ex $IO $C) - ( (nal-to-prolog $IO $C $P) - (set-det) - (nars-exec-ex1 $IO $P))) -; - - (= - (nars-exec-ex $IO $C) + (= (nars-exec-ex $IO (Cons $C $Clauses)) + (set-det) + (nars-exec-ex $IO $C) + (nars-exec-ex $IO $Clauses)) + (= (nars-exec-ex $IO $C) + (nal-to-prolog $IO $C $P) + (set-det) + (nars-exec-ex1 $IO $P)) + (= (nars-exec-ex $IO $C) (nars-exec-ex1 $IO $C)) -; - - (= - (nars-exec-ex1 $_ Nil) + (= (nars-exec-ex1 $_ Nil) + (set-det)) + (= (nars-exec-ex1 $IO (Cons $C $Clauses)) + (set-det) + (nars-exec-ex1 $IO $C) + (nars-exec-ex1 $IO $Clauses)) + (= (nars-exec-ex1 $IO (nop $C)) + (set-det) + (nars-exec-ex1 $IO $C)) + (= (nars-exec-ex1 $_ (nal-in $C $V3)) + (set-det) + (nars-exec-ex1 in $C)) + (= (nars-exec-ex1 $_ (nal-out $C $V3)) + (set-det) + (nars-exec-ex1 out $C)) + (= (nars-exec-ex1 $_ (outputMustContain $C)) + (set-det) + (nars-exec-ex1 out $C)) + (= (nars-exec-ex1 $_ (expected $C)) + (set-det) + (nars-exec-ex1 out $C)) + (= (nars-exec-ex1 $_ (write $C)) + (set-det) + (nars-exec-ex1 cmt $C)) + (= (nars-exec-ex1 $IO $C) + (dmsg (= $IO $C)) + (fail)) + (= (nars-exec-ex1 $_ (do-steps $N)) + (set-det) + (forall + (between 1 $N $_) + (nop (inference-step $_))) (set-det)) -; - - (= - (nars-exec-ex1 $IO - (Cons $C $Clauses)) - ( (set-det) - (nars-exec-ex1 $IO $C) - (nars-exec-ex1 $IO $Clauses))) -; - - (= - (nars-exec-ex1 $IO - (nop $C)) - ( (set-det) (nars-exec-ex1 $IO $C))) -; - - (= - (nars-exec-ex1 $_ - (nal-in $C $V3)) - ( (set-det) (nars-exec-ex1 in $C))) -; - - (= - (nars-exec-ex1 $_ - (nal-out $C $V3)) - ( (set-det) (nars-exec-ex1 out $C))) -; - - (= - (nars-exec-ex1 $_ - (outputMustContain $C)) - ( (set-det) (nars-exec-ex1 out $C))) -; - - (= - (nars-exec-ex1 $_ - (expected $C)) - ( (set-det) (nars-exec-ex1 out $C))) -; - - (= - (nars-exec-ex1 $_ - (write $C)) - ( (set-det) (nars-exec-ex1 cmt $C))) -; - - (= - (nars-exec-ex1 $IO $C) - ( (dmsg (= $IO $C)) (fail))) -; - - (= - (nars-exec-ex1 $_ - (do-steps $N)) - ( (set-det) - (forall - (between 1 $N $_) - (nop (inference-step $_))) - (set-det))) -; - ; -; - - (= - (nars-exec-ex1 in $C) - ( (add-symbol &self +; nars_exec_ex1(IO,task(judgement,C,_,TV,_)):- !, nars_exec_ex1(IO,C). + (= (nars-exec-ex1 in $C) + ( (add-is-symbol &self (nars_db $C)) (nop (derive-event $C)) (set-det))) -; + (= (nars_exec_ex1 $_ $_) True) - (= - (nars_exec_ex1 $_ $_) True) -; - - - (= - (nal-exec-tests) - ( (make) (forall (, (with_self (nal-reader *) (nal-is-test $Type $Text)) (\== $Type read)) (nal-do-exec-test $Type $Text)))) -; - + (= (nal-exec-tests) + (make) + (forall + (, + (with_self + (nal-reader *) + (nal-is-test $Type $Text)) + (\== $Type read)) + (nal-do-exec-test $Type $Text))) - (= - (nal-clauses-to-test $Clauses $Goal - (:: $ResultsExpected)) + (= (nal-clauses-to-test $Clauses $Goal (:: $ResultsExpected)) (nal-clauses-to-test $Clauses True $Goal True $ResultsExpected)) -; - - (= - (nal-clauses-to-test Nil $Goal $Goal $InOut $InOut) + (= (nal-clauses-to-test Nil $Goal $Goal $InOut $InOut) + (set-det)) + (= (nal-clauses-to-test (Cons $C $Cs) $Goal $PGoal $In $Out) + (set-det) + (nal-clauses-to-test $C $Goal $MGoal $In $Mid) + (set-det) + (nal-clauses-to-test $Cs $MGoal $PGoal $Mid $Out)) + (= (nal-clauses-to-test (expected $C) $Goal $Goal $In $Out) + (set-det) + (nal-to-prolog out $C $P) + (conjoin-op or $In $P $Out)) + (= (nal-clauses-to-test (outputMustContain $C) $Goal $Goal $In $Out) + (set-det) + (nal-to-prolog out $C $P) + (conjoin-op or $In $P $Out)) + (= (nal-clauses-to-test (nal-out $C $W) $Goal $Goal $In $Out) + (set-det) + (nal-to-prolog out + (nal-out $C $W) $P) + (conjoin $In $P $Out)) + (= (nal-clauses-to-test (nal-in $C $W) $Goal $PGoal $InOut $InOut) + (set-det) + (nal-to-prolog in + (nal-in $C $W) $P) + (conjoin $Goal $P $PGoal)) + (= (nal-clauses-to-test $CMT $Goal $Goal $In $Out) + (\== $In True) + (= $CMT + ($COMMENT $_ $_ $_)) + (set-det) + (nal-to-prolog out $CMT $P) + (conjoin $In $P $Out)) + (= (nal-clauses-to-test $C $Goal $PGoal $InOut $InOut) + (nal-to-prolog in $C $P) + (conjoin $Goal $P $PGoal) (set-det)) -; - - (= - (nal-clauses-to-test - (Cons $C $Cs) $Goal $PGoal $In $Out) - ( (set-det) - (nal-clauses-to-test $C $Goal $MGoal $In $Mid) - (set-det) - (nal-clauses-to-test $Cs $MGoal $PGoal $Mid $Out))) -; - - (= - (nal-clauses-to-test - (expected $C) $Goal $Goal $In $Out) - ( (set-det) - (nal-to-prolog out $C $P) - (conjoin-op or $In $P $Out))) -; - - (= - (nal-clauses-to-test - (outputMustContain $C) $Goal $Goal $In $Out) - ( (set-det) - (nal-to-prolog out $C $P) - (conjoin-op or $In $P $Out))) -; - - (= - (nal-clauses-to-test - (nal-out $C $W) $Goal $Goal $In $Out) - ( (set-det) - (nal-to-prolog out - (nal-out $C $W) $P) - (conjoin $In $P $Out))) -; - - (= - (nal-clauses-to-test - (nal-in $C $W) $Goal $PGoal $InOut $InOut) - ( (set-det) - (nal-to-prolog in - (nal-in $C $W) $P) - (conjoin $Goal $P $PGoal))) -; - - (= - (nal-clauses-to-test $CMT $Goal $Goal $In $Out) - ( (\== $In True) - (= $CMT - ($COMMENT $_ $_ $_)) - (set-det) - (nal-to-prolog out $CMT $P) - (conjoin $In $P $Out))) -; - - (= - (nal-clauses-to-test $C $Goal $PGoal $InOut $InOut) - ( (nal-to-prolog in $C $P) - (conjoin $Goal $P $PGoal) - (set-det))) -; - ; -; - +; nal_to_MeTTa(IO,'$COMMENT'(C,_,_),writeln(C)):- !. ; -; - - - (= - (nal-to-prolog $IO - ($COMMENT $C $_ $_) $M) - ( (set-det) (nal-to-prolog $IO (write $C) $M))) -; +; nal_to_MeTTa(IO,'$COMMENT'(_,_,_),true):- !. - (= + (= (nal-to-prolog $IO ($COMMENT $C $_ $_) $M) + (set-det) (nal-to-prolog $IO - (nal-in $C $_) $M) - ( (set-det) (nal-to-prolog $IO $C $M))) -; - - (= - (nal-to-prolog $IO - (nal-out $C $_) $M) - ( (set-det) (nal-to-prolog $IO $C $M))) -; - - (= - (nal-to-prolog $IO - (task $X $S $T $O $B) $M) - ( (not (ground $O)) - (= $O - (:: $C $F)) - (ignore (= $C 1.0)) - (ignore (= $F 1.0)) - (nal-to-prolog $IO - (task $X $S $T $O $B) $M))) -; - - (= + (write $C) $M)) + (= (nal-to-prolog $IO (nal-in $C $_) $M) + (set-det) + (nal-to-prolog $IO $C $M)) + (= (nal-to-prolog $IO (nal-out $C $_) $M) + (set-det) + (nal-to-prolog $IO $C $M)) + (= (nal-to-prolog $IO (task $X $S $T $O $B) $M) + (not (ground $O)) + (= $O + (:: $C $F)) + (ignore (= $C 1.0)) + (ignore (= $F 1.0)) (nal-to-prolog $IO - (task $X $S $T $O $B) $M) - ( (var $T) - (= $T present) - (nal-to-prolog $IO - (task $X $S $T $O $B) $M))) -; - - (= + (task $X $S $T $O $B) $M)) + (= (nal-to-prolog $IO (task $X $S $T $O $B) $M) + (var $T) + (= $T present) (nal-to-prolog $IO - (task judgement $S $_ $FC $_) $O) - ( (append-term $S $FC $M) (nal-to-prolog $IO $M $O))) -; - - (= - (nal_to_prolog in $X - (nop $X)) True) -; - - (= - (nal_to_prolog out $X - (nop - (expected $X))) True) -; - - + (task $X $S $T $O $B) $M)) + (= (nal-to-prolog $IO (task judgement $S $_ $FC $_) $O) + (append-term $S $FC $M) + (nal-to-prolog $IO $M $O)) + (= (nal_to_prolog in $X (nop $X)) True) + (= (nal_to_prolog out $X (nop (expected $X))) True) - (= - (take-nal-example-test $Goal $ResultsExpected) - ( (= $Failed $_) - (wots $S - (ignore (take-nal-example-test-node $Goal $ResultsExpected $Failed))) - (det-if-then-else - (== $Failed failed) - (ansifmt - (:: red) $S) - (ansifmt - (:: green) $S)))) -; + (= (take-nal-example-test $Goal $ResultsExpected) + (= $Failed $_) + (wots $S + (ignore (take-nal-example-test-node $Goal $ResultsExpected $Failed))) + (det-if-then-else + (== $Failed failed) + (ansifmt + (:: red) $S) + (ansifmt + (:: green) $S))) - (= + (= (take-nal-example-test-node $Goal (:: (or $Results $Expected)) $Failed) + (set-det) (take-nal-example-test-node $Goal - (:: (or $Results $Expected)) $Failed) - ( (set-det) - (take-nal-example-test-node $Goal - (:: $Results) $Failed) - (take-nal-example-test-node $Goal - (:: $Expected) $Failed))) -; - - - (= - (take-nal-example-test-node $Goal $ResultsExpected $Failed) - ( (guess-pretty (take-nal-example-test $Goal $ResultsExpected)) - (format '~N~n```prolog~nTEST: ?- ~@~n```' - (:: (print-tree $Goal))) - (maplist - (>> - (:: $R) - (format '~NEXPECTED: `~@`' - (:: (print-tree $R)))) $ResultsExpected) - (take-nal-example-test-result $Goal $ResultsExpected $Failed))) -; - - - - (= - (take-nal-example-test-result $Goal $ResultsExpected $Failed) + (:: $Results) $Failed) + (take-nal-example-test-node $Goal + (:: $Expected) $Failed)) + + (= (take-nal-example-test-node $Goal $ResultsExpected $Failed) + (guess-pretty (take-nal-example-test $Goal $ResultsExpected)) + (format '~N~n```prolog~nTEST: ?- ~@~n```' + (:: (print-tree $Goal))) + (maplist + (>> + (:: $R) + (format '~NEXPECTED: `~@`' + (:: (print-tree $R)))) $ResultsExpected) + (take-nal-example-test-result $Goal $ResultsExpected $Failed)) +; ; term_variables(Goal,Vs), + + + (= (take-nal-example-test-result $Goal $ResultsExpected $Failed) ( (= $Failed $_) (det-if-then-else (not (not (, (nars-call-ex $Goal) (narz-check-results $ResultsExpected)))) @@ -442,88 +284,60 @@ (print-tree-nl $ResultsExpected)) (format ```~n~n Nil) (set-det))) -; - - (= - (nars-call-ex (, $X $Y)) - ( (set-det) - (nars-call-ex $X) - (nars-call-ex $Y))) -; - - (= - (nars-call-ex (or $X $Y)) + (= (nars-call-ex (, $X $Y)) + (set-det) + (nars-call-ex $X) + (nars-call-ex $Y)) + (= (nars-call-ex (or $X $Y)) (or (, (set-det) (nars-call-ex $X)) (nars-call-ex $Y))) -; - ; -; - - (= - (nars-call-ex $L) - ( (is-list $L) - (set-det) - (maplist nars-call-ex $L))) -; - - (= - (nars-call-ex $X) +; nars_call_ex(X=Y):- !, nars_close_enough(X,Y). ;-> true; (print_tree(failure(X=Y)),!,fail). + (= (nars-call-ex $L) + (is-list $L) + (set-det) + (maplist nars-call-ex $L)) + (= (nars-call-ex $X) (or (if (call $X) True) (, (nop (print-tree-nl (failed-nars-call-ex $X))) (fail)))) -; - - - (= - (narz-check-results $L) - ( (is-list $L) - (set-det) - (maplist narz-check-results $L))) -; - (= - (narz-check-results (or $R1 $R2)) + (= (narz-check-results $L) + (is-list $L) + (set-det) + (maplist narz-check-results $L)) + (= (narz-check-results (or $R1 $R2)) (or (, (set-det) (narz-check-results $R1)) (narz-check-results $R2))) -; - - (= - (narz-check-results (, $R1 $RS)) - ( (set-det) - (narz-check-results $R1) - (narz-check-results $RS))) -; - - (= - (narz-check-results (= $R $V)) + (= (narz-check-results (, $R1 $RS)) + (set-det) + (narz-check-results $R1) + (narz-check-results $RS)) + (= (narz-check-results (= $R $V)) (or (if (, (set-det) (= $R $V)) True) (nars-close-enough $R $V))) -; - - (= - (narz-check-results $X) + (= (narz-check-results $X) (or (if (call $X) True) @@ -531,51 +345,33 @@ (fail) (print-tree (test-failed $X)) (fail)))) -; - - (= - (nars-close-enough $R $V) - ( (=@= $R $V) (set-det))) -; - - (= - (nars-close-enough $R $V) - ( (number $R) - (number $V) - (set-det) - (is $RV - (abs (- $R $V))) - (< $RV 0.03))) -; - - (= - (nars-close-enough $R $V) - ( (or - (not (compound $R)) - (not (compound $V))) - (set-det) - (== $R $V))) -; - - (= - (nars-close-enough - (Cons $R $RT) - (Cons $V $VT)) - ( (set-det) - (nars-close-enough $R $V) - (nars-close-enough $RT $VT))) -; - - (= - (nars-close-enough $R $V) - ( (compound-name-arguments $R $F $RA) - (compound-name-arguments $V $F $VA) - (set-det) - (maplist nars-close-enough $RA $VA))) -; - + (= (nars-close-enough $R $V) + (=@= $R $V) + (set-det)) + (= (nars-close-enough $R $V) + (number $R) + (number $V) + (set-det) + (is $RV + (abs (- $R $V))) + (< $RV 0.03)) + (= (nars-close-enough $R $V) + (or + (not (compound $R)) + (not (compound $V))) + (set-det) + (== $R $V)) + (= (nars-close-enough (Cons $R $RT) (Cons $V $VT)) + (set-det) + (nars-close-enough $R $V) + (nars-close-enough $RT $VT)) + (= (nars-close-enough $R $V) + (compound-name-arguments $R $F $RA) + (compound-name-arguments $V $F $VA) + (set-det) + (maplist nars-close-enough $RA $VA)) @@ -587,3384 +383,1517 @@ ; -; - +; like to distinguish "eaten by tiger" from "eating tiger" (/, eat, tiger, _) vs. (/, eat, _, tiger) ; -; - - - - (= - (use-nars-config-info $List) - ( (is-list $List) - (set-det) - (maplist use-nars-config-info $List))) -; - - (= - (use-nars-config-info (element $_ Nil $List)) - ( (set-det) (use-nars-config-info $List))) -; - - (= - (use-nars-config-info (element $_ (:: (= name $Name) (= value $Value)) $_)) - ( (set-det) (use-nars-config-info (= $Name $Value)))) -; - - (= - (use-nars-config-info (= $Name $Value)) - ( (nars-string $Name) - (downcase-atom $Name $NameD) - (\= $NameD $Name) - (set-det) - (use-nars-config-info (= $NameD $Value)))) -; - - (= - (use-nars-config-info (= $Name $Value)) - ( (nars-string $Value) - (downcase-atom $Value $ValueD) - (\= $ValueD $Value) - (set-det) - (use-nars-config-info (= $Name $ValueD)))) -; +; now: (eat /2 tiger) vs. (eat /1 tiger) - (= - (use-nars-config-info (= $Name $Value)) - ( (atom $Value) - (atom-number $Value $Number) - (use-nars-config-info (= $Name $Number)))) -; + (= (use-nars-config-info $List) + (is-list $List) + (set-det) + (maplist use-nars-config-info $List)) + (= (use-nars-config-info (element $_ Nil $List)) + (set-det) + (use-nars-config-info $List)) + (= (use-nars-config-info (element $_ (:: (= name $Name) (= value $Value)) $_)) + (set-det) + (use-nars-config-info (= $Name $Value))) + (= (use-nars-config-info (= $Name $Value)) + (nars-string $Name) + (downcase-atom $Name $NameD) + (\= $NameD $Name) + (set-det) + (use-nars-config-info (= $NameD $Value))) + (= (use-nars-config-info (= $Name $Value)) + (nars-string $Value) + (downcase-atom $Value $ValueD) + (\= $ValueD $Value) + (set-det) + (use-nars-config-info (= $Name $ValueD))) + (= (use-nars-config-info (= $Name $Value)) + (atom $Value) + (atom-number $Value $Number) + (use-nars-config-info (= $Name $Number))) ; -; - +; use_nars_config_info(Ignore):- nars_string(Ignore), !. ; -; - +; use_nars_config_info(NameValue):- dmsg(use_nars_config_info(NameValue)), fail. ; -; - - (= - (use-nars-config-info (= $Name $Value)) +; use_nars_config_info(Name=Value):- number(Value), !, nb_setval(Name, Value). + (= (use-nars-config-info (= $Name $Value)) (nb-setval $Name $Value)) -; - - (= - (use_nars_config_info $_) True) -; - + (= (use_nars_config_info $_) True) ; -; - +; default gobals !(use-nars-config-info (= volume 100)) -; - !(use-nars-config-info (= novelty-horizon 100000)) -; - !(use-nars-config-info (= decision-threshold 0.51)) -; - !(use-nars-config-info (= concept-bag-size 80000)) -; - !(use-nars-config-info (= concept-bag-levels 1000)) -; - !(use-nars-config-info (= duration 5)) -; - !(use-nars-config-info (= horizon 1)) -; - !(use-nars-config-info (= truth-epsilon 0.01)) -; - !(use-nars-config-info (= budget-epsilon 0.0001)) -; - !(use-nars-config-info (= budget-threshold 0.01)) -; - !(use-nars-config-info (= default-confirmation-expectation 0.6)) -; - !(use-nars-config-info (= always-create-concept True)) -; - !(use-nars-config-info (= default-creation-expectation 0.66)) -; - !(use-nars-config-info (= default-creation-expectation-goal 0.6)) -; - !(use-nars-config-info (= default-judgment-confidence 0.9)) -; - !(use-nars-config-info (= default-judgment-priority 0.8)) -; - !(use-nars-config-info (= default-judgment-durability 0.5)) -; - !(use-nars-config-info (= default-question-priority 0.9)) -; - !(use-nars-config-info (= default-question-durability 0.9)) -; - !(use-nars-config-info (= default-goal-confidence 0.9)) -; - !(use-nars-config-info (= default-goal-priority 0.9)) -; - !(use-nars-config-info (= default-goal-durability 0.9)) -; - !(use-nars-config-info (= default-quest-priority 0.9)) -; - !(use-nars-config-info (= default-quest-durability 0.9)) -; - !(use-nars-config-info (= bag-threshold 1.0)) -; - !(use-nars-config-info (= forget-quality-relative 0.3)) -; - !(use-nars-config-info (= revision-max-occurrence-distance 10)) -; - !(use-nars-config-info (= task-link-bag-size 100)) -; - !(use-nars-config-info (= task-link-bag-levels 10)) -; - !(use-nars-config-info (= term-link-bag-size 100)) -; - !(use-nars-config-info (= term-link-bag-levels 10)) -; - !(use-nars-config-info (= term-link-max-matched 10)) -; - !(use-nars-config-info (= novel-task-bag-size 1000)) -; - !(use-nars-config-info (= novel-task-bag-levels 100)) -; - !(use-nars-config-info (= novel-task-bag-selections 100)) -; - !(use-nars-config-info (= sequence-bag-size 30)) -; - !(use-nars-config-info (= sequence-bag-levels 10)) -; - !(use-nars-config-info (= operation-bag-size 10)) -; - !(use-nars-config-info (= operation-bag-levels 10)) -; - !(use-nars-config-info (= operation-samples 6)) -; - !(use-nars-config-info (= projection-decay 0.1)) -; - !(use-nars-config-info (= maximum-evidental-base-length 20000)) -; - !(use-nars-config-info (= termlink-max-reasoned 3)) -; - !(use-nars-config-info (= term-link-record-length 10)) -; - !(use-nars-config-info (= concept-beliefs-max 28)) -; - !(use-nars-config-info (= concept-questions-max 5)) -; - !(use-nars-config-info (= concept-goals-max 7)) -; - !(use-nars-config-info (= reliance 0.9)) -; - !(use-nars-config-info (= discount-rate 0.5)) -; - !(use-nars-config-info (= immediate-eternalization True)) -; - !(use-nars-config-info (= sequence-bag-attempts 10)) -; - !(use-nars-config-info (= condition-bag-attempts 10)) -; - !(use-nars-config-info (= derivation-priority-leak 0.4)) -; - !(use-nars-config-info (= derivation-durability-leak 0.4)) -; - !(use-nars-config-info (= curiosity-desire-confidence-mul 0.1)) -; - !(use-nars-config-info (= curiosity-desire-priority-mul 0.1)) -; - !(use-nars-config-info (= curiosity-desire-durability-mul 0.3)) -; - !(use-nars-config-info (= curiosity-for-operator-only False)) -; - !(use-nars-config-info (= break-nal-hol-boundary False)) -; - !(use-nars-config-info (= question-generation-on-decision-making False)) -; - !(use-nars-config-info (= how-question-generation-on-decision-making False)) -; - !(use-nars-config-info (= anticipation-confidence 0.1)) -; - !(use-nars-config-info (= anticipation-tolerance 100.0)) -; - !(use-nars-config-info (= retrospective-anticipations False)) -; - !(use-nars-config-info (= satisfaction-treshold 0.0)) -; - !(use-nars-config-info (= complexity-unit 1.0)) -; - !(use-nars-config-info (= interval-adapt-speed 4.0)) -; - !(use-nars-config-info (= tasklink-per-content 4)) -; - !(use-nars-config-info (= default-feedback-priority 0.9)) -; - !(use-nars-config-info (= default-feedback-durability 0.5)) -; - !(use-nars-config-info (= concept-forget-durations 2.0)) -; - !(use-nars-config-info (= termlink-forget-durations 10.0)) -; - !(use-nars-config-info (= tasklink-forget-durations 4.0)) -; - !(use-nars-config-info (= event-forget-durations 4.0)) -; - !(use-nars-config-info (= variable-introduction-combinations-max 8)) -; - !(use-nars-config-info (= variable-introduction-confidence-mul 0.9)) -; - !(use-nars-config-info (= anticipations-per-concept-max 8)) -; - !(use-nars-config-info (= motor-babbling-confidence-threshold 0.8)) -; - !(use-nars-config-info (= threads-amount 1)) -; - !(use-nars-config-info (= milliseconds-per-step 0)) -; - !(use-nars-config-info (= steps-clock True)) -; - !(use-nars-config-info (= derivation-durability-leak 0.4)) -; - !(use-nars-config-info (= derivation-priority-leak 0.4)) -; - - (= - (use-nars-config $File) - ( (or - (not (atom $File)) - (not (is-absolute-file-name $File))) - (absolute-file-name $File $Absolute) - (set-det) - (use-nars-config $Absolute))) -; - - (= - (use-nars-config $Absolute) - ( (open $Absolute read $In) - (load-sgml $In $Dom - (:: - (dialect html5) - (attribute-value string) - (cdata string) - (nars-system-entities True) - (nars-space remove) - (nars-syntax-errors quiet) - (case-preserving-attributes False) - (case-sensitive-attributes False) - (max-errors -1))) - (set-det) - (close $In) - (use-nars-config-info $Dom) - (set-det))) -; - + (= (use-nars-config $File) + (or + (not (atom $File)) + (not (is-absolute-file-name $File))) + (absolute-file-name $File $Absolute) + (set-det) + (use-nars-config $Absolute)) + (= (use-nars-config $Absolute) + (open $Absolute read $In) + (load-sgml $In $Dom + (:: + (dialect html5) + (attribute-value string) + (cdata string) + (nars-system-entities True) + (nars-space remove) + (nars-syntax-errors quiet) + (case-preserving-attributes False) + (case-sensitive-attributes False) + (max-errors -1))) + (set-det) + (close $In) + (use-nars-config-info $Dom) + (set-det)) - (= - (parse-config) + (= (parse-config) (use-nars-config (library ../config/mvpConfig.xml))) -; - ; -; - +; This program covers the inferencerules of upto NAL-6 in ; -; - +; "Non-Axiomatic Logic: A Model of Intelligent Reasoning" ; -; - +; For the details of syntax, see the "User's Guide of NAL" ; -; - +; ;; individual inferencerules ; -; - +; There are three types of inferencerules in NAL: ; -; - +; (1) "revision" merges its two premises into a conclusion; ; -; - +; (2) "choice"nars_selects one of its two premises as a conclusion; ; -; - - +; (3) "inference" generates a conclusion from one or two premises. - (= - (nars_ctx default) True) -; + (= (nars_ctx default) True) ; -; +; revision/3 - - (= - (revision - (:: $S $T1) - (:: $S $T2) - (:: $S $T)) + (= (revision (:: $S $T1) (:: $S $T2) (:: $S $T)) (nars-revision (:: $S $T1) (:: $S $T2) (:: $S $T))) -; - - (= - (nars-revision - (:: $S $T1) - (:: $S $T2) - (:: $S $T)) + (= (nars-revision (:: $S $T1) (:: $S $T2) (:: $S $T)) (narz-f-rev $T1 $T2 $T)) -; - ; -; +; NARS choice/3 - - (= - (choice $X $Y $Z) + (= (choice $X $Y $Z) (nars-choice $X $Y $Z)) -; - - - - (= - (nars-choice - (:: $S - (:: $F1 $C1)) - (:: $S - (:: $F2 $C2)) - (:: $S - (:: $F1 $C1))) - ( (>= $C1 $C2) (set-det))) -; - (= - (nars-choice - (:: $S - (:: $F1 $C1)) - (:: $S - (:: $F2 $C2)) - (:: $S - (:: $F2 $C2))) - ( (< $C1 $C2) (set-det))) -; - - (= - (nars-choice - (:: $S1 $T1) - (:: $S2 $T2) - (:: $S1 $T1)) - ( (\= $S1 $S2) - (narz-f-exp $T1 $E1) - (narz-f-exp $T2 $E2) - (>= $E1 $E2) - (set-det))) -; - - (= - (nars-choice - (:: $S1 $T1) - (:: $S2 $T2) - (:: $S2 $T2)) - ( (\= $S1 $S2) - (narz-f-exp $T1 $E1) - (narz-f-exp $T2 $E2) - (< $E1 $E2) - (set-det))) -; + (= (nars-choice (:: $S (:: $F1 $C1)) (:: $S (:: $F2 $C2)) (:: $S (:: $F1 $C1))) + (>= $C1 $C2) + (set-det)) + (= (nars-choice (:: $S (:: $F1 $C1)) (:: $S (:: $F2 $C2)) (:: $S (:: $F2 $C2))) + (< $C1 $C2) + (set-det)) + (= (nars-choice (:: $S1 $T1) (:: $S2 $T2) (:: $S1 $T1)) + (\= $S1 $S2) + (narz-f-exp $T1 $E1) + (narz-f-exp $T2 $E2) + (>= $E1 $E2) + (set-det)) + (= (nars-choice (:: $S1 $T1) (:: $S2 $T2) (:: $S2 $T2)) + (\= $S1 $S2) + (narz-f-exp $T1 $E1) + (narz-f-exp $T2 $E2) + (< $E1 $E2) + (set-det)) ; -; +; NARS infer-ence/2 (simplified version) - - (= - (infer $T1 $T) + (= (infer $T1 $T) (nars-infer $T1 $T)) -; - - - - (= - (nars-infer $T1 $T) - ( (nars-ctx $Ctx) (nars-inference $Ctx (:: $T1 (:: 1 0.9)) $T))) -; - (= - (nars-infer - (inheritance $W1 - (ext-image - (ext-image represent - (:: nil - (inheritance - (product (:: $X $T2)) $R))) - (:: nil $W2 $W3))) - (inheritance $W1 - (ext-image represent - (:: nil $X))) - (:: - (inheritance - (ext-image represent - (:: nil $Y)) - (ext-image - (ext-image represent - (:: nil - (inheritance - (product (:: $Y $T2)) $R))) - (:: nil $W2 $W3))) $V)) - ( (narz-f-ind - (:: 1 0.9) - (:: 1 0.9) $V) (set-det))) -; - - - (= - (nars-infer - (inheritance $W3 - (ext-image - (ext-image represent - (:: nil - (inheritance - (product (:: $T1 $X)) $R))) - (:: $W1 $W2 nil))) - (inheritance $W3 - (ext-image represent - (:: nil $X))) - (:: - (inheritance - (ext-image represent - (:: nil $Y)) - (ext-image - (ext-image represent - (:: nil - (inheritance - (product (:: $T1 $Y)) $R))) - (:: $W1 $W2 nil))) $V)) - ( (narz-f-ind - (:: 1 0.9) - (:: 1 0.9) $V) (set-det))) -; + (= (nars-infer $T1 $T) + (nars-ctx $Ctx) + (nars-inference $Ctx + (:: $T1 + (:: 1 0.9)) $T)) + (= (nars-infer (inheritance $W1 (ext-image (ext-image represent (:: nil (inheritance (product (:: $X $T2)) $R))) (:: nil $W2 $W3))) (inheritance $W1 (ext-image represent (:: nil $X))) (:: (inheritance (ext-image represent (:: nil $Y)) (ext-image (ext-image represent (:: nil (inheritance (product (:: $Y $T2)) $R))) (:: nil $W2 $W3))) $V)) + (narz-f-ind + (:: 1 0.9) + (:: 1 0.9) $V) + (set-det)) - (= - (nars-infer $T1 $T2 $T) - ( (nars-ctx $Ctx) (nars-inference $Ctx (:: $T1 (:: 1 0.9)) (:: $T2 (:: 1 0.9)) $T))) -; + (= (nars-infer (inheritance $W3 (ext-image (ext-image represent (:: nil (inheritance (product (:: $T1 $X)) $R))) (:: $W1 $W2 nil))) (inheritance $W3 (ext-image represent (:: nil $X))) (:: (inheritance (ext-image represent (:: nil $Y)) (ext-image (ext-image represent (:: nil (inheritance (product (:: $T1 $Y)) $R))) (:: $W1 $W2 nil))) $V)) + (narz-f-ind + (:: 1 0.9) + (:: 1 0.9) $V) + (set-det)) + (= (nars-infer $T1 $T2 $T) + (nars-ctx $Ctx) + (nars-inference $Ctx + (:: $T1 + (:: 1 0.9)) + (:: $T2 + (:: 1 0.9)) $T)) ; -; - - - (= - (inference $T1 $T) - ( (nars-ctx $Ctx) (nars-inference $Ctx $T1 $T))) -; +; NARS inference/2 + (= (inference $T1 $T) + (nars-ctx $Ctx) + (nars-inference $Ctx $T1 $T)) ; -; +; ; immediate inference - - (= - (nars-inference $Ctx - (:: - (inheritance $S $P) $T1) - (:: - (inheritance $P $S) $T)) + (= (nars-inference $Ctx (:: (inheritance $S $P) $T1) (:: (inheritance $P $S) $T)) (narz-f-cnv $T1 $T)) -; - - (= - (nars-inference $Ctx - (:: - (implication $S $P) $T1) - (:: - (implication $P $S) $T)) + (= (nars-inference $Ctx (:: (implication $S $P) $T1) (:: (implication $P $S) $T)) (narz-f-cnv $T1 $T)) -; - - (= - (nars-inference $Ctx - (:: - (implication - (negation $S) $P) $T1) - (:: - (implication - (negation $P) $S) $T)) + (= (nars-inference $Ctx (:: (implication (negation $S) $P) $T1) (:: (implication (negation $P) $S) $T)) (narz-f-cnt $T1 $T)) -; - - (= - (nars-inference $Ctx - (:: - (negation $S) $T1) - (:: $S $T)) + (= (nars-inference $Ctx (:: (negation $S) $T1) (:: $S $T)) (narz-f-neg $T1 $T)) -; + (= (nars-inference $Ctx (:: $S (:: $F1 $C1)) (:: (negation $S) $T)) + (< $F1 0.5) + (narz-f-neg + (:: $F1 $C1) $T)) + +; +; ; structural inference + + (= (nars-inference $Ctx (:: $S1 $T) (:: $S $T)) + (narz-reduce $S1 $S) + (\== $S1 $S) + (set-det)) + (= (nars-inference $Ctx (:: $S1 $T) (:: $S $T)) + (or + (nars-equivalence $Ctx $S1 $S) + (nars-equivalence $Ctx $S $S1))) - (= + (= (nars-inference $Ctx $P $C) + (nars-inference $Ctx $P + (:: $S + (:: 1 1)) $C) + (call $S)) + (= (nars-inference $Ctx $P $C) (nars-inference $Ctx (:: $S - (:: $F1 $C1)) - (:: - (negation $S) $T)) - ( (< $F1 0.5) (narz-f-neg (:: $F1 $C1) $T))) -; + (:: 1 1)) $P $C) + (call $S)) ; -; - - - (= - (nars-inference $Ctx - (:: $S1 $T) - (:: $S $T)) - ( (narz-reduce $S1 $S) - (\== $S1 $S) - (set-det))) -; - - (= - (nars-inference $Ctx - (:: $S1 $T) - (:: $S $T)) - (or - (nars-equivalence $Ctx $S1 $S) - (nars-equivalence $Ctx $S $S1))) -; - - - (= - (nars-inference $Ctx $P $C) - ( (nars-inference $Ctx $P - (:: $S - (:: 1 1)) $C) (call $S))) -; - - (= - (nars-inference $Ctx $P $C) - ( (nars-inference $Ctx - (:: $S - (:: 1 1)) $P $C) (call $S))) -; - - - -; -; - - - (= - (inference $X $Y $Z) - ( (nars-ctx $Ctx) (nars-inference $Ctx $X $Y $Z))) -; +; inference/3 + (= (inference $X $Y $Z) + (nars-ctx $Ctx) + (nars-inference $Ctx $X $Y $Z)) ; -; - - - - (= - (nars-inference $Ctx - (:: - (inheritance $M $P) $T1) - (:: - (inheritance $S $M) $T2) - (:: - (inheritance $S $P) $T)) - ( (\= $S $P) (narz-f-ded $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $P $M) $T1) - (:: - (inheritance $S $M) $T2) - (:: - (inheritance $S $P) $T)) - ( (\= $S $P) (narz-f-abd $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $M $P) $T1) - (:: - (inheritance $M $S) $T2) - (:: - (inheritance $S $P) $T)) - ( (\= $S $P) (narz-f-ind $T1 $T2 $T))) -; +; ; inheritance-based syllogism - (= - (nars-inference $Ctx - (:: - (inheritance $P $M) $T1) - (:: - (inheritance $M $S) $T2) - (:: - (inheritance $S $P) $T)) - ( (\= $S $P) (narz-f-exe $T1 $T2 $T))) -; + (= (nars-inference $Ctx (:: (inheritance $M $P) $T1) (:: (inheritance $S $M) $T2) (:: (inheritance $S $P) $T)) + (\= $S $P) + (narz-f-ded $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $P $M) $T1) (:: (inheritance $S $M) $T2) (:: (inheritance $S $P) $T)) + (\= $S $P) + (narz-f-abd $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $M $P) $T1) (:: (inheritance $M $S) $T2) (:: (inheritance $S $P) $T)) + (\= $S $P) + (narz-f-ind $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $P $M) $T1) (:: (inheritance $M $S) $T2) (:: (inheritance $S $P) $T)) + (\= $S $P) + (narz-f-exe $T1 $T2 $T)) ; -; +; ; similarity from inheritance - - (= - (nars-inference $Ctx - (:: - (inheritance $S $P) $T1) - (:: - (inheritance $P $S) $T2) - (:: - (similarity $S $P) $T)) + (= (nars-inference $Ctx (:: (inheritance $S $P) $T1) (:: (inheritance $P $S) $T2) (:: (similarity $S $P) $T)) (narz-f-int $T1 $T2 $T)) -; - ; -; - - - (= - (nars-inference $Ctx - (:: - (inheritance $P $M) $T1) - (:: - (inheritance $S $M) $T2) - (:: - (similarity $S $P) $T)) - ( (\= $S $P) (narz-f-com $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $M $P) $T1) - (:: - (inheritance $M $S) $T2) - (:: - (similarity $S $P) $T)) - ( (\= $S $P) (narz-f-com $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $M $P) $T1) - (:: - (similarity $S $M) $T2) - (:: - (inheritance $S $P) $T)) - ( (\= $S $P) (narz-f-ana $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $P $M) $T1) - (:: - (similarity $S $M) $T2) - (:: - (inheritance $P $S) $T)) - ( (\= $S $P) (narz-f-ana $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (similarity $M $P) $T1) - (:: - (similarity $S $M) $T2) - (:: - (similarity $S $P) $T)) - ( (\= $S $P) (narz-f-res $T1 $T2 $T))) -; +; ; similarity-based syllogism + (= (nars-inference $Ctx (:: (inheritance $P $M) $T1) (:: (inheritance $S $M) $T2) (:: (similarity $S $P) $T)) + (\= $S $P) + (narz-f-com $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $M $P) $T1) (:: (inheritance $M $S) $T2) (:: (similarity $S $P) $T)) + (\= $S $P) + (narz-f-com $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $M $P) $T1) (:: (similarity $S $M) $T2) (:: (inheritance $S $P) $T)) + (\= $S $P) + (narz-f-ana $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $P $M) $T1) (:: (similarity $S $M) $T2) (:: (inheritance $P $S) $T)) + (\= $S $P) + (narz-f-ana $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (similarity $M $P) $T1) (:: (similarity $S $M) $T2) (:: (similarity $S $P) $T)) + (\= $S $P) + (narz-f-res $T1 $T2 $T)) ; -; +; ; inheritance-based composition - - (= - (nars-inference $Ctx - (:: - (inheritance $P $M) $T1) - (:: - (inheritance $S $M) $T2) - (:: - (inheritance $N $M) $T)) - ( (\= $S $P) - (narz-reduce - (int-intersection (:: $P $S)) $N) - (narz-f-int $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $P $M) $T1) - (:: - (inheritance $S $M) $T2) - (:: - (inheritance $N $M) $T)) - ( (\= $S $P) - (narz-reduce - (ext-intersection (:: $P $S)) $N) - (narz-f-uni $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $P $M) $T1) - (:: - (inheritance $S $M) $T2) - (:: - (inheritance $N $M) $T)) - ( (\= $S $P) - (narz-reduce - (int-difference $P $S) $N) - (narz-f-dif $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $M $P) $T1) - (:: - (inheritance $M $S) $T2) - (:: - (inheritance $M $N) $T)) - ( (\= $S $P) - (narz-reduce - (ext-intersection (:: $P $S)) $N) - (narz-f-int $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $M $P) $T1) - (:: - (inheritance $M $S) $T2) - (:: - (inheritance $M $N) $T)) - ( (\= $S $P) - (narz-reduce - (int-intersection (:: $P $S)) $N) - (narz-f-uni $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $M $P) $T1) - (:: - (inheritance $M $S) $T2) - (:: - (inheritance $M $N) $T)) - ( (\= $S $P) - (narz-reduce - (ext-difference $P $S) $N) - (narz-f-dif $T1 $T2 $T))) -; - - -; -; - - - (= - (nars-inference $Ctx - (:: - (inheritance $S $M) $T1) - (:: - (inheritance - (int-intersection $L) $M) $T2) - (:: - (inheritance $P $M) $T)) - ( (narz-ground $S) - (narz-ground $L) - (member $S $L) - (delete $L $S $N) - (narz-reduce - (int-intersection $N) $P) - (narz-f-pnn $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $S $M) $T1) - (:: - (inheritance - (ext-intersection $L) $M) $T2) - (:: - (inheritance $P $M) $T)) - ( (narz-ground $S) - (narz-ground $L) - (member $S $L) - (delete $L $S $N) - (narz-reduce - (ext-intersection $N) $P) - (narz-f-npp $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $S $M) $T1) - (:: - (inheritance - (int-difference $S $P) $M) $T2) - (:: - (inheritance $P $M) $T)) - ( (atom $S) - (atom $P) - (narz-f-pnp $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $S $M) $T1) - (:: - (inheritance - (int-difference $P $S) $M) $T2) - (:: - (inheritance $P $M) $T)) - ( (atom $S) - (atom $P) - (narz-f-nnn $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $M $S) $T1) - (:: - (inheritance $M - (ext-intersection $L)) $T2) - (:: - (inheritance $M $P) $T)) - ( (narz-ground $S) - (narz-ground $L) - (member $S $L) - (delete $L $S $N) - (narz-reduce - (ext-intersection $N) $P) - (narz-f-pnn $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $M $S) $T1) - (:: - (inheritance $M - (int-intersection $L)) $T2) - (:: - (inheritance $M $P) $T)) - ( (narz-ground $S) - (narz-ground $L) - (member $S $L) - (delete $L $S $N) - (narz-reduce - (int-intersection $N) $P) - (narz-f-npp $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $M $S) $T1) - (:: - (inheritance $M - (ext-difference $S $P)) $T2) - (:: - (inheritance $M $P) $T)) - ( (atom $S) - (atom $P) - (narz-f-pnp $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $M $S) $T1) - (:: - (inheritance $M - (ext-difference $P $S)) $T2) - (:: - (inheritance $M $P) $T)) - ( (atom $S) - (atom $P) - (narz-f-nnn $T1 $T2 $T))) -; - - -; -; - - - (= - (nars-inference $Ctx - (:: - (implication $M $P) $T1) - (:: - (implication $S $M) $T2) - (:: - (implication $S $P) $T)) - ( (\= $S $P) (narz-f-ded $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (implication $P $M) $T1) - (:: - (implication $S $M) $T2) - (:: - (implication $S $P) $T)) - ( (\= $S $P) (narz-f-abd $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (implication $M $P) $T1) - (:: - (implication $M $S) $T2) - (:: - (implication $S $P) $T)) - ( (\= $S $P) (narz-f-ind $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (implication $P $M) $T1) - (:: - (implication $M $S) $T2) - (:: - (implication $S $P) $T)) - ( (\= $S $P) (narz-f-exe $T1 $T2 $T))) -; - - -; -; - - - (= - (nars-inference $Ctx - (:: - (implication $S $P) $T1) - (:: - (implication $P $S) $T2) - (:: - (equivalence $S $P) $T)) + (= (nars-inference $Ctx (:: (inheritance $P $M) $T1) (:: (inheritance $S $M) $T2) (:: (inheritance $N $M) $T)) + (\= $S $P) + (narz-reduce + (int-intersection (:: $P $S)) $N) (narz-f-int $T1 $T2 $T)) -; - - -; -; - - - (= - (nars-inference $Ctx - (:: - (implication $P $M) $T1) - (:: - (implication $S $M) $T2) - (:: - (equivalence $S $P) $T)) - ( (\= $S $P) (narz-f-com $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (implication $M $P) $T1) - (:: - (implication $M $S) $T2) - (:: - (equivalence $S $P) $T)) - ( (\= $S $P) (narz-f-com $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (implication $M $P) $T1) - (:: - (equivalence $S $M) $T2) - (:: - (implication $S $P) $T)) - ( (\= $S $P) (narz-f-ana $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (implication $P $M) $T1) - (:: - (equivalence $S $M) $T2) - (:: - (implication $P $S) $T)) - ( (\= $S $P) (narz-f-ana $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (equivalence $M $P) $T1) - (:: - (equivalence $S $M) $T2) - (:: - (equivalence $S $P) $T)) - ( (\= $S $P) (narz-f-res $T1 $T2 $T))) -; - + (= (nars-inference $Ctx (:: (inheritance $P $M) $T1) (:: (inheritance $S $M) $T2) (:: (inheritance $N $M) $T)) + (\= $S $P) + (narz-reduce + (ext-intersection (:: $P $S)) $N) + (narz-f-uni $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $P $M) $T1) (:: (inheritance $S $M) $T2) (:: (inheritance $N $M) $T)) + (\= $S $P) + (narz-reduce + (int-difference $P $S) $N) + (narz-f-dif $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $M $P) $T1) (:: (inheritance $M $S) $T2) (:: (inheritance $M $N) $T)) + (\= $S $P) + (narz-reduce + (ext-intersection (:: $P $S)) $N) + (narz-f-int $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $M $P) $T1) (:: (inheritance $M $S) $T2) (:: (inheritance $M $N) $T)) + (\= $S $P) + (narz-reduce + (int-intersection (:: $P $S)) $N) + (narz-f-uni $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $M $P) $T1) (:: (inheritance $M $S) $T2) (:: (inheritance $M $N) $T)) + (\= $S $P) + (narz-reduce + (ext-difference $P $S) $N) + (narz-f-dif $T1 $T2 $T)) ; -; - - - (= - (nars-inference $Ctx - (:: - (implication $P $M) $T1) - (:: - (implication $S $M) $T2) - (:: - (implication $N $M) $T)) - ( (\= $S $P) - (narz-reduce - (disjunction (:: $P $S)) $N) - (narz-f-int $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (implication $P $M) $T1) - (:: - (implication $S $M) $T2) - (:: - (implication $N $M) $T)) - ( (\= $S $P) - (narz-reduce - (conjunction (:: $P $S)) $N) - (narz-f-uni $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (implication $M $P) $T1) - (:: - (implication $M $S) $T2) - (:: - (implication $M $N) $T)) - ( (\= $S $P) - (narz-reduce - (conjunction (:: $P $S)) $N) - (narz-f-int $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (implication $M $P) $T1) - (:: - (implication $M $S) $T2) - (:: - (implication $M $N) $T)) - ( (\= $S $P) - (narz-reduce - (disjunction (:: $P $S)) $N) - (narz-f-uni $T1 $T2 $T))) -; +; ; inheirance-based decomposition + (= (nars-inference $Ctx (:: (inheritance $S $M) $T1) (:: (inheritance (int-intersection $L) $M) $T2) (:: (inheritance $P $M) $T)) + (narz-ground $S) + (narz-ground $L) + (member $S $L) + (delete $L $S $N) + (narz-reduce + (int-intersection $N) $P) + (narz-f-pnn $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $S $M) $T1) (:: (inheritance (ext-intersection $L) $M) $T2) (:: (inheritance $P $M) $T)) + (narz-ground $S) + (narz-ground $L) + (member $S $L) + (delete $L $S $N) + (narz-reduce + (ext-intersection $N) $P) + (narz-f-npp $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $S $M) $T1) (:: (inheritance (int-difference $S $P) $M) $T2) (:: (inheritance $P $M) $T)) + (atom $S) + (atom $P) + (narz-f-pnp $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $S $M) $T1) (:: (inheritance (int-difference $P $S) $M) $T2) (:: (inheritance $P $M) $T)) + (atom $S) + (atom $P) + (narz-f-nnn $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $M $S) $T1) (:: (inheritance $M (ext-intersection $L)) $T2) (:: (inheritance $M $P) $T)) + (narz-ground $S) + (narz-ground $L) + (member $S $L) + (delete $L $S $N) + (narz-reduce + (ext-intersection $N) $P) + (narz-f-pnn $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $M $S) $T1) (:: (inheritance $M (int-intersection $L)) $T2) (:: (inheritance $M $P) $T)) + (narz-ground $S) + (narz-ground $L) + (member $S $L) + (delete $L $S $N) + (narz-reduce + (int-intersection $N) $P) + (narz-f-npp $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $M $S) $T1) (:: (inheritance $M (ext-difference $S $P)) $T2) (:: (inheritance $M $P) $T)) + (atom $S) + (atom $P) + (narz-f-pnp $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $M $S) $T1) (:: (inheritance $M (ext-difference $P $S)) $T2) (:: (inheritance $M $P) $T)) + (atom $S) + (atom $P) + (narz-f-nnn $T1 $T2 $T)) + +; +; ; implication-based syllogism + + (= (nars-inference $Ctx (:: (implication $M $P) $T1) (:: (implication $S $M) $T2) (:: (implication $S $P) $T)) + (\= $S $P) + (narz-f-ded $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication $P $M) $T1) (:: (implication $S $M) $T2) (:: (implication $S $P) $T)) + (\= $S $P) + (narz-f-abd $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication $M $P) $T1) (:: (implication $M $S) $T2) (:: (implication $S $P) $T)) + (\= $S $P) + (narz-f-ind $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication $P $M) $T1) (:: (implication $M $S) $T2) (:: (implication $S $P) $T)) + (\= $S $P) + (narz-f-exe $T1 $T2 $T)) + +; +; ; implication to equivalence + + (= (nars-inference $Ctx (:: (implication $S $P) $T1) (:: (implication $P $S) $T2) (:: (equivalence $S $P) $T)) + (narz-f-int $T1 $T2 $T)) ; -; - - - (= - (nars-inference $Ctx - (:: - (implication $S $M) $T1) - (:: - (implication - (disjunction $L) $M) $T2) - (:: - (implication $P $M) $T)) - ( (narz-ground $S) - (narz-ground $L) - (member $S $L) - (delete $L $S $N) - (narz-reduce - (disjunction $N) $P) - (narz-f-pnn $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (implication $S $M) $T1) - (:: - (implication - (conjunction $L) $M) $T2) - (:: - (implication $P $M) $T)) - ( (narz-ground $S) - (narz-ground $L) - (member $S $L) - (delete $L $S $N) - (narz-reduce - (conjunction $N) $P) - (narz-f-npp $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (implication $M $S) $T1) - (:: - (implication $M - (conjunction $L)) $T2) - (:: - (implication $M $P) $T)) - ( (narz-ground $S) - (narz-ground $L) - (member $S $L) - (delete $L $S $N) - (narz-reduce - (conjunction $N) $P) - (narz-f-pnn $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (implication $M $S) $T1) - (:: - (implication $M - (disjunction $L)) $T2) - (:: - (implication $M $P) $T)) - ( (narz-ground $S) - (narz-ground $L) - (member $S $L) - (delete $L $S $N) - (narz-reduce - (disjunction $N) $P) - (narz-f-npp $T1 $T2 $T))) -; +; ; equivalence-based syllogism + (= (nars-inference $Ctx (:: (implication $P $M) $T1) (:: (implication $S $M) $T2) (:: (equivalence $S $P) $T)) + (\= $S $P) + (narz-f-com $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication $M $P) $T1) (:: (implication $M $S) $T2) (:: (equivalence $S $P) $T)) + (\= $S $P) + (narz-f-com $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication $M $P) $T1) (:: (equivalence $S $M) $T2) (:: (implication $S $P) $T)) + (\= $S $P) + (narz-f-ana $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication $P $M) $T1) (:: (equivalence $S $M) $T2) (:: (implication $P $S) $T)) + (\= $S $P) + (narz-f-ana $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (equivalence $M $P) $T1) (:: (equivalence $S $M) $T2) (:: (equivalence $S $P) $T)) + (\= $S $P) + (narz-f-res $T1 $T2 $T)) ; -; - - - (= - (nars-inference $Ctx - (:: - (implication $M $P) $T1) - (:: $M $T2) - (:: $P $T)) - ( (narz-ground $P) (narz-f-ded $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (implication $P $M) $T1) - (:: $M $T2) - (:: $P $T)) - ( (narz-ground $P) (narz-f-abd $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: $M $T1) - (:: - (equivalence $S $M) $T2) - (:: $S $T)) - ( (narz-ground $S) (narz-f-ana $T1 $T2 $T))) -; +; ; implication-based composition + (= (nars-inference $Ctx (:: (implication $P $M) $T1) (:: (implication $S $M) $T2) (:: (implication $N $M) $T)) + (\= $S $P) + (narz-reduce + (disjunction (:: $P $S)) $N) + (narz-f-int $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication $P $M) $T1) (:: (implication $S $M) $T2) (:: (implication $N $M) $T)) + (\= $S $P) + (narz-reduce + (conjunction (:: $P $S)) $N) + (narz-f-uni $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication $M $P) $T1) (:: (implication $M $S) $T2) (:: (implication $M $N) $T)) + (\= $S $P) + (narz-reduce + (conjunction (:: $P $S)) $N) + (narz-f-int $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication $M $P) $T1) (:: (implication $M $S) $T2) (:: (implication $M $N) $T)) + (\= $S $P) + (narz-reduce + (disjunction (:: $P $S)) $N) + (narz-f-uni $T1 $T2 $T)) ; -; - - - (= - (nars-inference $Ctx - (:: $P $T1) - (:: $S $T2) - (:: $C $T)) - ( (== $C - (implication $S $P)) (narz-f-ind $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: $P $T1) - (:: $S $T2) - (:: $C $T)) - ( (== $C - (equivalence $S $P)) (narz-f-com $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: $P $T1) - (:: $S $T2) - (:: $C $T)) - ( (narz-reduce - (conjunction (:: $P $S)) $N) - (== $N $C) - (narz-f-int $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: $P $T1) - (:: $S $T2) - (:: $C $T)) - ( (narz-reduce - (disjunction (:: $P $S)) $N) - (== $N $C) - (narz-f-uni $T1 $T2 $T))) -; +; ; implication-based decomposition + (= (nars-inference $Ctx (:: (implication $S $M) $T1) (:: (implication (disjunction $L) $M) $T2) (:: (implication $P $M) $T)) + (narz-ground $S) + (narz-ground $L) + (member $S $L) + (delete $L $S $N) + (narz-reduce + (disjunction $N) $P) + (narz-f-pnn $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication $S $M) $T1) (:: (implication (conjunction $L) $M) $T2) (:: (implication $P $M) $T)) + (narz-ground $S) + (narz-ground $L) + (member $S $L) + (delete $L $S $N) + (narz-reduce + (conjunction $N) $P) + (narz-f-npp $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication $M $S) $T1) (:: (implication $M (conjunction $L)) $T2) (:: (implication $M $P) $T)) + (narz-ground $S) + (narz-ground $L) + (member $S $L) + (delete $L $S $N) + (narz-reduce + (conjunction $N) $P) + (narz-f-pnn $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication $M $S) $T1) (:: (implication $M (disjunction $L)) $T2) (:: (implication $M $P) $T)) + (narz-ground $S) + (narz-ground $L) + (member $S $L) + (delete $L $S $N) + (narz-reduce + (disjunction $N) $P) + (narz-f-npp $T1 $T2 $T)) + +; +; ; conditional syllogism + + (= (nars-inference $Ctx (:: (implication $M $P) $T1) (:: $M $T2) (:: $P $T)) + (narz-ground $P) + (narz-f-ded $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication $P $M) $T1) (:: $M $T2) (:: $P $T)) + (narz-ground $P) + (narz-f-abd $T1 $T2 $T)) + (= (nars-inference $Ctx (:: $M $T1) (:: (equivalence $S $M) $T2) (:: $S $T)) + (narz-ground $S) + (narz-f-ana $T1 $T2 $T)) + +; +; ; conditional composition + + (= (nars-inference $Ctx (:: $P $T1) (:: $S $T2) (:: $C $T)) + (== $C + (implication $S $P)) + (narz-f-ind $T1 $T2 $T)) + (= (nars-inference $Ctx (:: $P $T1) (:: $S $T2) (:: $C $T)) + (== $C + (equivalence $S $P)) + (narz-f-com $T1 $T2 $T)) + (= (nars-inference $Ctx (:: $P $T1) (:: $S $T2) (:: $C $T)) + (narz-reduce + (conjunction (:: $P $S)) $N) + (== $N $C) + (narz-f-int $T1 $T2 $T)) + (= (nars-inference $Ctx (:: $P $T1) (:: $S $T2) (:: $C $T)) + (narz-reduce + (disjunction (:: $P $S)) $N) + (== $N $C) + (narz-f-uni $T1 $T2 $T)) ; -; - - - (= - (nars-inference $Ctx - (:: $S $T1) - (:: - (conjunction $L) $T2) - (:: $P $T)) - ( (narz-ground $S) - (narz-ground $L) - (member $S $L) - (delete $L $S $N) - (narz-reduce - (conjunction $N) $P) - (narz-f-pnn $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: $S $T1) - (:: - (disjunction $L) $T2) - (:: $P $T)) - ( (narz-ground $S) - (narz-ground $L) - (member $S $L) - (delete $L $S $N) - (narz-reduce - (disjunction $N) $P) - (narz-f-npp $T1 $T2 $T))) -; +; ; propositional decomposition + (= (nars-inference $Ctx (:: $S $T1) (:: (conjunction $L) $T2) (:: $P $T)) + (narz-ground $S) + (narz-ground $L) + (member $S $L) + (delete $L $S $N) + (narz-reduce + (conjunction $N) $P) + (narz-f-pnn $T1 $T2 $T)) + (= (nars-inference $Ctx (:: $S $T1) (:: (disjunction $L) $T2) (:: $P $T)) + (narz-ground $S) + (narz-ground $L) + (member $S $L) + (delete $L $S $N) + (narz-reduce + (disjunction $N) $P) + (narz-f-npp $T1 $T2 $T)) ; -; - +; ; multi-conditional syllogism - (= - (nars-inference $Ctx - (:: - (implication - (conjunction $L) $C) $T1) - (:: $M $T2) - (:: - (implication $P $C) $T)) - ( (nonvar $L) - (member $M $L) - (nars-subtract $L - (:: $M) $A) - (\= $A Nil) - (narz-reduce - (conjunction $A) $P) - (narz-f-ded $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (implication - (conjunction $L) $C) $T1) - (:: - (implication $P $C) $T2) - (:: $M $T)) - ( (narz-ground $L) - (member $M $L) - (nars-subtract $L - (:: $M) $A) - (\= $A Nil) - (narz-reduce - (conjunction $A) $P) - (narz-f-abd $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (implication - (conjunction $L) $C) $T1) - (:: $M $T2) - (:: $S $T)) - ( (== $S - (implication - (conjunction (Cons $M $L)) $C)) (narz-f-ind $T1 $T2 $T))) -; - - - (= - (nars-inference $Ctx - (:: - (implication - (conjunction $Lm) $C) $T1) - (:: - (implication $A $M) $T2) - (:: - (implication $P $C) $T)) - ( (nonvar $Lm) - (narz-replace $Lm $M $La $A) - (narz-reduce - (conjunction $La) $P) - (narz-f-ded $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (implication - (conjunction $Lm) $C) $T1) - (:: - (implication - (conjunction $La) $C) $T2) - (:: - (implication $A $M) $T)) - ( (nonvar $Lm) - (narz-replace $Lm $M $La $A) - (narz-f-abd $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (implication - (conjunction $La) $C) $T1) - (:: - (implication $A $M) $T2) - (:: - (implication $P $C) $T)) - ( (nonvar $La) - (narz-replace $Lm $M $La $A) - (narz-reduce - (conjunction $Lm) $P) - (narz-f-ind $T1 $T2 $T))) -; + (= (nars-inference $Ctx (:: (implication (conjunction $L) $C) $T1) (:: $M $T2) (:: (implication $P $C) $T)) + (nonvar $L) + (member $M $L) + (nars-subtract $L + (:: $M) $A) + (\= $A Nil) + (narz-reduce + (conjunction $A) $P) + (narz-f-ded $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication (conjunction $L) $C) $T1) (:: (implication $P $C) $T2) (:: $M $T)) + (narz-ground $L) + (member $M $L) + (nars-subtract $L + (:: $M) $A) + (\= $A Nil) + (narz-reduce + (conjunction $A) $P) + (narz-f-abd $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication (conjunction $L) $C) $T1) (:: $M $T2) (:: $S $T)) + (== $S + (implication + (conjunction (Cons $M $L)) $C)) + (narz-f-ind $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication (conjunction $Lm) $C) $T1) (:: (implication $A $M) $T2) (:: (implication $P $C) $T)) + (nonvar $Lm) + (narz-replace $Lm $M $La $A) + (narz-reduce + (conjunction $La) $P) + (narz-f-ded $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication (conjunction $Lm) $C) $T1) (:: (implication (conjunction $La) $C) $T2) (:: (implication $A $M) $T)) + (nonvar $Lm) + (narz-replace $Lm $M $La $A) + (narz-f-abd $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication (conjunction $La) $C) $T1) (:: (implication $A $M) $T2) (:: (implication $P $C) $T)) + (nonvar $La) + (narz-replace $Lm $M $La $A) + (narz-reduce + (conjunction $Lm) $P) + (narz-f-ind $T1 $T2 $T)) + +; +; ; variable introduction + + (= (nars-inference $Ctx (:: (inheritance $M $P) $T1) (:: (inheritance $M $S) $T2) (:: (implication (inheritance $X $S) (inheritance $X $P)) $T)) + (\= $S $P) + (narz-f-ind $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $P $M) $T1) (:: (inheritance $S $M) $T2) (:: (implication (inheritance $P $X) (inheritance $S $X)) $T)) + (\= $S $P) + (narz-f-abd $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $M $P) $T1) (:: (inheritance $M $S) $T2) (:: (equivalence (inheritance $X $S) (inheritance $X $P)) $T)) + (\= $S $P) + (narz-f-com $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $P $M) $T1) (:: (inheritance $S $M) $T2) (:: (equivalence (inheritance $P $X) (inheritance $S $X)) $T)) + (\= $S $P) + (narz-f-com $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $M $P) $T1) (:: (inheritance $M $S) $T2) (:: (conjunction (:: (inheritance (var $Y Nil) $S) (inheritance (var $Y Nil) $P))) $T)) + (\= $S $P) + (narz-f-int $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (inheritance $P $M) $T1) (:: (inheritance $S $M) $T2) (:: (conjunction (:: (inheritance $S (var $Y Nil)) (inheritance $P (var $Y Nil)))) $T)) + (\= $S $P) + (narz-f-int $T1 $T2 $T)) ; -; +; ; 2nd variable introduction + (= (nars-inference $Ctx (:: (implication $A (inheritance $M1 $P)) $T1) (:: (inheritance $M2 $S) $T2) (:: (implication (conjunction (:: $A (inheritance $X $S))) (inheritance $X $P)) $T)) + (\= $S $P) + (== $M1 $M2) + (\= $A + (inheritance $M2 $S)) + (narz-f-ind $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication $A (inheritance $M1 $P)) $T1) (:: (inheritance $M2 $S) $T2) (:: (conjunction (:: (implication $A (inheritance (var $Y Nil) $P)) (inheritance (var $Y Nil) $S))) $T)) + (\= $S $P) + (== $M1 $M2) + (\= $A + (inheritance $M2 $S)) + (narz-f-int $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (conjunction $L1) $T1) (:: (inheritance $M $S) $T2) (:: (implication (inheritance $Y $S) (conjunction (Cons (inheritance $Y $P2) $L3))) $T)) + (nars-subtract $L1 + (:: (inheritance $M $P)) $L2) + (\= $L1 $L2) + (\= $S $P) + (narz-dependant $P $Y $P2) + (narz-dependant $L2 $Y $L3) + (narz-f-ind $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (conjunction $L1) $T1) (:: (inheritance $M $S) $T2) (:: (conjunction (Cons (inheritance (var $Y Nil) $S) (Cons (inheritance (var $Y Nil) $P) $L2))) $T)) + (nars-subtract $L1 + (:: (inheritance $M $P)) $L2) + (\= $L1 $L2) + (\= $S $P) + (narz-f-int $T1 $T2 $T)) - (= - (nars-inference $Ctx - (:: - (inheritance $M $P) $T1) - (:: - (inheritance $M $S) $T2) - (:: - (implication - (inheritance $X $S) - (inheritance $X $P)) $T)) - ( (\= $S $P) (narz-f-ind $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $P $M) $T1) - (:: - (inheritance $S $M) $T2) - (:: - (implication - (inheritance $P $X) - (inheritance $S $X)) $T)) - ( (\= $S $P) (narz-f-abd $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $M $P) $T1) - (:: - (inheritance $M $S) $T2) - (:: - (equivalence - (inheritance $X $S) - (inheritance $X $P)) $T)) - ( (\= $S $P) (narz-f-com $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $P $M) $T1) - (:: - (inheritance $S $M) $T2) - (:: - (equivalence - (inheritance $P $X) - (inheritance $S $X)) $T)) - ( (\= $S $P) (narz-f-com $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $M $P) $T1) - (:: - (inheritance $M $S) $T2) - (:: - (conjunction (:: (inheritance (var $Y Nil) $S) (inheritance (var $Y Nil) $P))) $T)) - ( (\= $S $P) (narz-f-int $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (inheritance $P $M) $T1) - (:: - (inheritance $S $M) $T2) - (:: - (conjunction (:: (inheritance $S (var $Y Nil)) (inheritance $P (var $Y Nil)))) $T)) - ( (\= $S $P) (narz-f-int $T1 $T2 $T))) -; - + (= (nars-inference $Ctx (:: (implication $A (inheritance $P $M1)) $T1) (:: (inheritance $S $M2) $T2) (:: (implication (conjunction (:: $A (inheritance $P $X))) (inheritance $S $X)) $T)) + (\= $S $P) + (== $M1 $M2) + (\= $A + (inheritance $S $M2)) + (narz-f-abd $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (implication $A (inheritance $P $M1)) $T1) (:: (inheritance $S $M2) $T2) (:: (conjunction (:: (implication $A (inheritance $P (var $Y Nil))) (inheritance $S (var $Y Nil)))) $T)) + (\= $S $P) + (== $M1 $M2) + (\= $A + (inheritance $S $M2)) + (narz-f-int $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (conjunction $L1) $T1) (:: (inheritance $S $M) $T2) (:: (implication (inheritance $S $Y) (conjunction (Cons (inheritance $P2 $Y) $L3))) $T)) + (nars-subtract $L1 + (:: (inheritance $P $M)) $L2) + (\= $L1 $L2) + (\= $S $P) + (narz-dependant $P $Y $P2) + (narz-dependant $L2 $Y $L3) + (narz-f-abd $T1 $T2 $T)) + (= (nars-inference $Ctx (:: (conjunction $L1) $T1) (:: (inheritance $S $M) $T2) (:: (conjunction (Cons (inheritance $S (var $Y Nil)) (Cons (inheritance $P (var $Y Nil)) $L2))) $T)) + (nars-subtract $L1 + (:: (inheritance $P $M)) $L2) + (\= $L1 $L2) + (\= $S $P) + (narz-f-int $T1 $T2 $T)) ; -; +; ; dependant variable elimination - (= - (nars-inference $Ctx - (:: - (implication $A - (inheritance $M1 $P)) $T1) - (:: - (inheritance $M2 $S) $T2) - (:: - (implication - (conjunction (:: $A (inheritance $X $S))) - (inheritance $X $P)) $T)) - ( (\= $S $P) - (== $M1 $M2) - (\= $A - (inheritance $M2 $S)) - (narz-f-ind $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (implication $A - (inheritance $M1 $P)) $T1) - (:: - (inheritance $M2 $S) $T2) - (:: - (conjunction (:: (implication $A (inheritance (var $Y Nil) $P)) (inheritance (var $Y Nil) $S))) $T)) - ( (\= $S $P) - (== $M1 $M2) - (\= $A - (inheritance $M2 $S)) - (narz-f-int $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (conjunction $L1) $T1) - (:: - (inheritance $M $S) $T2) - (:: - (implication - (inheritance $Y $S) - (conjunction (Cons (inheritance $Y $P2) $L3))) $T)) - ( (nars-subtract $L1 - (:: (inheritance $M $P)) $L2) - (\= $L1 $L2) - (\= $S $P) - (narz-dependant $P $Y $P2) - (narz-dependant $L2 $Y $L3) - (narz-f-ind $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (conjunction $L1) $T1) - (:: - (inheritance $M $S) $T2) - (:: - (conjunction (Cons (inheritance (var $Y Nil) $S) (Cons (inheritance (var $Y Nil) $P) $L2))) $T)) - ( (nars-subtract $L1 - (:: (inheritance $M $P)) $L2) - (\= $L1 $L2) - (\= $S $P) - (narz-f-int $T1 $T2 $T))) -; - - - (= - (nars-inference $Ctx - (:: - (implication $A - (inheritance $P $M1)) $T1) - (:: - (inheritance $S $M2) $T2) - (:: - (implication - (conjunction (:: $A (inheritance $P $X))) - (inheritance $S $X)) $T)) - ( (\= $S $P) - (== $M1 $M2) - (\= $A - (inheritance $S $M2)) - (narz-f-abd $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (implication $A - (inheritance $P $M1)) $T1) - (:: - (inheritance $S $M2) $T2) - (:: - (conjunction (:: (implication $A (inheritance $P (var $Y Nil))) (inheritance $S (var $Y Nil)))) $T)) - ( (\= $S $P) - (== $M1 $M2) - (\= $A - (inheritance $S $M2)) - (narz-f-int $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (conjunction $L1) $T1) - (:: - (inheritance $S $M) $T2) - (:: - (implication - (inheritance $S $Y) - (conjunction (Cons (inheritance $P2 $Y) $L3))) $T)) - ( (nars-subtract $L1 - (:: (inheritance $P $M)) $L2) - (\= $L1 $L2) - (\= $S $P) - (narz-dependant $P $Y $P2) - (narz-dependant $L2 $Y $L3) - (narz-f-abd $T1 $T2 $T))) -; - - (= - (nars-inference $Ctx - (:: - (conjunction $L1) $T1) - (:: - (inheritance $S $M) $T2) - (:: - (conjunction (Cons (inheritance $S (var $Y Nil)) (Cons (inheritance $P (var $Y Nil)) $L2))) $T)) - ( (nars-subtract $L1 - (:: (inheritance $P $M)) $L2) - (\= $L1 $L2) - (\= $S $P) - (narz-f-int $T1 $T2 $T))) -; - - -; -; - + (= (nars-inference $Ctx (:: (conjunction $L1) $T1) (:: (inheritance $M $S) $T2) (:: $C $T)) + (nars-subtract $L1 + (:: (inheritance (var $N $D) $S)) $L2) + (\= $L1 $L2) + (replace-var $L2 + (var $N $D) $L3 $M) + (narz-reduce + (conjunction $L3) $C) + (narz-f-cnv $T2 $T0) + (narz-f-ana $T1 $T0 $T)) + (= (nars-inference $Ctx (:: (conjunction $L1) $T1) (:: (inheritance $S $M) $T2) (:: $C $T)) + (nars-subtract $L1 + (:: (inheritance $S (var $N $D))) $L2) + (\= $L1 $L2) + (replace-var $L2 + (var $N $D) $L3 $M) + (narz-reduce + (conjunction $L3) $C) + (narz-f-cnv $T2 $T0) + (narz-f-ana $T1 $T0 $T)) - (= - (nars-inference $Ctx - (:: - (conjunction $L1) $T1) - (:: - (inheritance $M $S) $T2) - (:: $C $T)) - ( (nars-subtract $L1 - (:: (inheritance (var $N $D) $S)) $L2) - (\= $L1 $L2) - (replace-var $L2 - (var $N $D) $L3 $M) - (narz-reduce - (conjunction $L3) $C) - (narz-f-cnv $T2 $T0) - (narz-f-ana $T1 $T0 $T))) -; - - (= - (nars-inference $Ctx - (:: - (conjunction $L1) $T1) - (:: - (inheritance $S $M) $T2) - (:: $C $T)) - ( (nars-subtract $L1 - (:: (inheritance $S (var $N $D))) $L2) - (\= $L1 $L2) - (replace-var $L2 - (var $N $D) $L3 $M) - (narz-reduce - (conjunction $L3) $C) - (narz-f-cnv $T2 $T0) - (narz-f-ana $T1 $T0 $T))) -; - - - - (= - (replace_var () $_ () $_) True) -; - - (= - (replace-var - (Cons - (inheritance $S1 $P) $T1) $S1 - (Cons - (inheritance $S2 $P) $T2) $S2) + (= (replace_var () $_ () $_) True) + (= (replace-var (Cons (inheritance $S1 $P) $T1) $S1 (Cons (inheritance $S2 $P) $T2) $S2) (replace-var $T1 $S1 $T2 $S2)) -; - - (= - (replace-var - (Cons - (inheritance $S $P1) $T1) $P1 - (Cons - (inheritance $S $P2) $T2) $P2) + (= (replace-var (Cons (inheritance $S $P1) $T1) $P1 (Cons (inheritance $S $P2) $T2) $P2) (replace-var $T1 $P1 $T2 $P2)) -; - - (= - (replace-all - (Cons $H $T1) $H1 - (Cons $H $T2) $H2) + (= (replace-all (Cons $H $T1) $H1 (Cons $H $T2) $H2) (replace-var $T1 $H1 $T2 $H2)) -; - ; -; - +; ;; Theorems in IL: ; -; - - - (= - (inheritance $X $Y) - ( (nars-ctx $Ctx) (nars-inheritance $Ctx $X $Y))) -; +; NARS inheritance/2 + (= (inheritance $X $Y) + (nars-ctx $Ctx) + (nars-inheritance $Ctx $X $Y)) - (= - (nars-inheritance $Ctx - (ext-intersection $Ls) $P) + (= (nars-inheritance $Ctx (ext-intersection $Ls) $P) (narz-include (:: $P) $Ls)) -; - - (= - (nars-inheritance $Ctx $S - (int-intersection $Lp)) + (= (nars-inheritance $Ctx $S (int-intersection $Lp)) (narz-include (:: $S) $Lp)) -; - - (= - (nars-inheritance $Ctx - (ext-intersection $S) - (ext-intersection $P)) - ( (narz-include $P $S) (\= $P (:: $_)))) -; - - (= - (nars-inheritance $Ctx - (int-intersection $S) - (int-intersection $P)) - ( (narz-include $S $P) (\= $S (:: $_)))) -; - - (= - (nars-inheritance $Ctx - (ext-set $S) - (ext-set $P)) + (= (nars-inheritance $Ctx (ext-intersection $S) (ext-intersection $P)) + (narz-include $P $S) + (\= $P + (:: $_))) + (= (nars-inheritance $Ctx (int-intersection $S) (int-intersection $P)) + (narz-include $S $P) + (\= $S + (:: $_))) + (= (nars-inheritance $Ctx (ext-set $S) (ext-set $P)) (narz-include $S $P)) -; - - (= - (nars-inheritance $Ctx - (int-set $S) - (int-set $P)) + (= (nars-inheritance $Ctx (int-set $S) (int-set $P)) (narz-include $P $S)) -; - - - (= - (nars-inheritance $Ctx - (ext-difference $S $P) $S) - ( (narz-ground $S) (narz-ground $P))) -; - - (= - (nars-inheritance $Ctx $S - (int-difference $S $P)) - ( (narz-ground $S) (narz-ground $P))) -; - - - (= - (nars-inheritance $Ctx - (product $L1) $R) - ( (narz-ground $L1) - (member - (ext-image $R $L2) $L1) - (narz-replace $L1 - (ext-image $R $L2) $L2))) -; - - (= - (nars-inheritance $Ctx $R - (product $L1)) - ( (narz-ground $L1) - (member - (int-image $R $L2) $L1) - (narz-replace $L1 - (int-image $R $L2) $L2))) -; - - -; -; - - - (= - (similarity $X $Y) - ( (nars-ctx $Ctx) (nars-similarity $Ctx $X $Y))) -; - - - - (= - (nars-similarity $Ctx $X $Y) - ( (narz-ground $X) - (narz-reduce $X $Y) - (\== $X $Y) - (set-det))) -; + (= (nars-inheritance $Ctx (ext-difference $S $P) $S) + (narz-ground $S) + (narz-ground $P)) + (= (nars-inheritance $Ctx $S (int-difference $S $P)) + (narz-ground $S) + (narz-ground $P)) + + (= (nars-inheritance $Ctx (product $L1) $R) + (narz-ground $L1) + (member + (ext-image $R $L2) $L1) + (narz-replace $L1 + (ext-image $R $L2) $L2)) + (= (nars-inheritance $Ctx $R (product $L1)) + (narz-ground $L1) + (member + (int-image $R $L2) $L1) + (narz-replace $L1 + (int-image $R $L2) $L2)) + +; +; NARS similarity/2 + + (= (similarity $X $Y) + (nars-ctx $Ctx) + (nars-similarity $Ctx $X $Y)) + + + (= (nars-similarity $Ctx $X $Y) + (narz-ground $X) + (narz-reduce $X $Y) + (\== $X $Y) + (set-det)) - (= - (nars-similarity $Ctx - (ext-intersection $L1) - (ext-intersection $L2)) + (= (nars-similarity $Ctx (ext-intersection $L1) (ext-intersection $L2)) (narz-same-set $L1 $L2)) -; - - (= - (nars-similarity $Ctx - (int-intersection $L1) - (int-intersection $L2)) + (= (nars-similarity $Ctx (int-intersection $L1) (int-intersection $L2)) (narz-same-set $L1 $L2)) -; - - (= - (nars-similarity $Ctx - (ext-set $L1) - (ext-set $L2)) + (= (nars-similarity $Ctx (ext-set $L1) (ext-set $L2)) (narz-same-set $L1 $L2)) -; - - (= - (nars-similarity $Ctx - (int-set $L1) - (int-set $L2)) + (= (nars-similarity $Ctx (int-set $L1) (int-set $L2)) (narz-same-set $L1 $L2)) -; - ; -; - - - (= - (implication $X $Y) - ( (nars-ctx $Ctx) (nars-implication $Ctx $X $Y))) -; - - - - (= - (nars_implication $Ctx - (similarity $S $P) - (inheritance $S $P)) True) -; - - (= - (nars_implication $Ctx - (equivalence $S $P) - (implication $S $P)) True) -; - - - (= - (nars-implication $Ctx - (conjunction $L) $M) - ( (narz-ground $L) (member $M $L))) -; - - (= - (nars-implication $Ctx $M - (disjunction $L)) - ( (narz-ground $L) (member $M $L))) -; - - - (= - (nars-implication $Ctx - (conjunction $L1) - (conjunction $L2)) - ( (narz-ground $L1) - (narz-ground $L2) - (subset $L2 $L1))) -; - - (= - (nars-implication $Ctx - (disjunction $L1) - (disjunction $L2)) - ( (narz-ground $L1) - (narz-ground $L2) - (subset $L1 $L2))) -; - - - (= - (nars-implication $Ctx - (inheritance $S $P) - (inheritance - (ext-intersection $Ls) - (ext-intersection $Lp))) - ( (narz-ground $Ls) - (narz-ground $Lp) - (narz-replace $Ls $S $L $P) - (narz-same $L $Lp))) -; - - (= - (nars-implication $Ctx - (inheritance $S $P) - (inheritance - (int-intersection $Ls) - (int-intersection $Lp))) - ( (narz-ground $Ls) - (narz-ground $Lp) - (narz-replace $Ls $S $L $P) - (narz-same $L $Lp))) -; - - (= - (nars-implication $Ctx - (similarity $S $P) - (similarity - (ext-intersection $Ls) - (ext-intersection $Lp))) - ( (narz-ground $Ls) - (narz-ground $Lp) - (narz-replace $Ls $S $L $P) - (narz-same $L $Lp))) -; - - (= - (nars-implication $Ctx - (similarity $S $P) - (similarity - (int-intersection $Ls) - (int-intersection $Lp))) - ( (narz-ground $Ls) - (narz-ground $Lp) - (narz-replace $Ls $S $L $P) - (narz-same $L $Lp))) -; - - - (= - (nars-implication $Ctx - (inheritance $S $P) - (inheritance - (ext-difference $S $M) - (ext-difference $P $M))) +; NARS implication/2 + + (= (implication $X $Y) + (nars-ctx $Ctx) + (nars-implication $Ctx $X $Y)) + + + (= (nars_implication $Ctx (similarity $S $P) (inheritance $S $P)) True) + (= (nars_implication $Ctx (equivalence $S $P) (implication $S $P)) True) + + (= (nars-implication $Ctx (conjunction $L) $M) + (narz-ground $L) + (member $M $L)) + (= (nars-implication $Ctx $M (disjunction $L)) + (narz-ground $L) + (member $M $L)) + + (= (nars-implication $Ctx (conjunction $L1) (conjunction $L2)) + (narz-ground $L1) + (narz-ground $L2) + (subset $L2 $L1)) + (= (nars-implication $Ctx (disjunction $L1) (disjunction $L2)) + (narz-ground $L1) + (narz-ground $L2) + (subset $L1 $L2)) + + (= (nars-implication $Ctx (inheritance $S $P) (inheritance (ext-intersection $Ls) (ext-intersection $Lp))) + (narz-ground $Ls) + (narz-ground $Lp) + (narz-replace $Ls $S $L $P) + (narz-same $L $Lp)) + (= (nars-implication $Ctx (inheritance $S $P) (inheritance (int-intersection $Ls) (int-intersection $Lp))) + (narz-ground $Ls) + (narz-ground $Lp) + (narz-replace $Ls $S $L $P) + (narz-same $L $Lp)) + (= (nars-implication $Ctx (similarity $S $P) (similarity (ext-intersection $Ls) (ext-intersection $Lp))) + (narz-ground $Ls) + (narz-ground $Lp) + (narz-replace $Ls $S $L $P) + (narz-same $L $Lp)) + (= (nars-implication $Ctx (similarity $S $P) (similarity (int-intersection $Ls) (int-intersection $Lp))) + (narz-ground $Ls) + (narz-ground $Lp) + (narz-replace $Ls $S $L $P) + (narz-same $L $Lp)) + + (= (nars-implication $Ctx (inheritance $S $P) (inheritance (ext-difference $S $M) (ext-difference $P $M))) (narz-ground $M)) -; - - (= - (nars-implication $Ctx - (inheritance $S $P) - (inheritance - (int-difference $S $M) - (int-difference $P $M))) + (= (nars-implication $Ctx (inheritance $S $P) (inheritance (int-difference $S $M) (int-difference $P $M))) (narz-ground $M)) -; - - (= - (nars-implication $Ctx - (similarity $S $P) - (similarity - (ext-difference $S $M) - (ext-difference $P $M))) + (= (nars-implication $Ctx (similarity $S $P) (similarity (ext-difference $S $M) (ext-difference $P $M))) (narz-ground $M)) -; - - (= - (nars-implication $Ctx - (similarity $S $P) - (similarity - (int-difference $S $M) - (int-difference $P $M))) + (= (nars-implication $Ctx (similarity $S $P) (similarity (int-difference $S $M) (int-difference $P $M))) (narz-ground $M)) -; - - (= - (nars-implication $Ctx - (inheritance $S $P) - (inheritance - (ext-difference $M $P) - (ext-difference $M $S))) + (= (nars-implication $Ctx (inheritance $S $P) (inheritance (ext-difference $M $P) (ext-difference $M $S))) (narz-ground $M)) -; - - (= - (nars-implication $Ctx - (inheritance $S $P) - (inheritance - (int-difference $M $P) - (int-difference $M $S))) + (= (nars-implication $Ctx (inheritance $S $P) (inheritance (int-difference $M $P) (int-difference $M $S))) (narz-ground $M)) -; - - (= - (nars-implication $Ctx - (similarity $S $P) - (similarity - (ext-difference $M $P) - (ext-difference $M $S))) + (= (nars-implication $Ctx (similarity $S $P) (similarity (ext-difference $M $P) (ext-difference $M $S))) (narz-ground $M)) -; - - (= - (nars-implication $Ctx - (similarity $S $P) - (similarity - (int-difference $M $P) - (int-difference $M $S))) + (= (nars-implication $Ctx (similarity $S $P) (similarity (int-difference $M $P) (int-difference $M $S))) (narz-ground $M)) -; - - (= - (nars-implication $Ctx - (inheritance $S $P) - (negation (inheritance $S (ext-difference $M $P)))) + (= (nars-implication $Ctx (inheritance $S $P) (negation (inheritance $S (ext-difference $M $P)))) (narz-ground $M)) -; - - (= - (nars-implication $Ctx - (inheritance $S - (ext-difference $M $P)) - (negation (inheritance $S $P))) + (= (nars-implication $Ctx (inheritance $S (ext-difference $M $P)) (negation (inheritance $S $P))) (narz-ground $M)) -; - - (= - (nars-implication $Ctx - (inheritance $S $P) - (negation (inheritance (int-difference $M $S) $P))) + (= (nars-implication $Ctx (inheritance $S $P) (negation (inheritance (int-difference $M $S) $P))) (narz-ground $M)) -; - - (= - (nars-implication $Ctx - (inheritance - (int-difference $M $S) $P) - (negation (inheritance $S $P))) + (= (nars-implication $Ctx (inheritance (int-difference $M $S) $P) (negation (inheritance $S $P))) (narz-ground $M)) -; - - (= - (nars-implication $Ctx - (inheritance $S $P) - (inheritance - (ext-image $S $M) - (ext-image $P $M))) + (= (nars-implication $Ctx (inheritance $S $P) (inheritance (ext-image $S $M) (ext-image $P $M))) (narz-ground $M)) -; - - (= - (nars-implication $Ctx - (inheritance $S $P) - (inheritance - (int-image $S $M) - (int-image $P $M))) + (= (nars-implication $Ctx (inheritance $S $P) (inheritance (int-image $S $M) (int-image $P $M))) (narz-ground $M)) -; - - (= - (nars-implication $Ctx - (inheritance $S $P) - (inheritance - (ext-image $M $Lp) - (ext-image $M $Ls))) - ( (narz-ground $Ls) - (narz-ground $Lp) - (append $L1 - (Cons $S $L2) $Ls) - (append $L1 - (Cons $P $L2) $Lp))) -; - - (= - (nars-implication $Ctx - (inheritance $S $P) - (inheritance - (int-image $M $Lp) - (int-image $M $Ls))) - ( (narz-ground $Ls) - (narz-ground $Lp) - (append $L1 - (Cons $S $L2) $Ls) - (append $L1 - (Cons $P $L2) $Lp))) -; - - - (= - (nars-implication $Ctx - (negation $M) - (negation (conjunction $L))) + (= (nars-implication $Ctx (inheritance $S $P) (inheritance (ext-image $M $Lp) (ext-image $M $Ls))) + (narz-ground $Ls) + (narz-ground $Lp) + (append $L1 + (Cons $S $L2) $Ls) + (append $L1 + (Cons $P $L2) $Lp)) + (= (nars-implication $Ctx (inheritance $S $P) (inheritance (int-image $M $Lp) (int-image $M $Ls))) + (narz-ground $Ls) + (narz-ground $Lp) + (append $L1 + (Cons $S $L2) $Ls) + (append $L1 + (Cons $P $L2) $Lp)) + + (= (nars-implication $Ctx (negation $M) (negation (conjunction $L))) (narz-include (:: $M) $L)) -; - - (= - (nars-implication $Ctx - (negation (disjunction $L)) - (negation $M)) + (= (nars-implication $Ctx (negation (disjunction $L)) (negation $M)) (narz-include (:: $M) $L)) -; + (= (nars-implication $Ctx (implication $S $P) (implication (conjunction $Ls) (conjunction $Lp))) + (narz-ground $Ls) + (narz-ground $Lp) + (narz-replace $Ls $S $L $P) + (narz-same $L $Lp)) + (= (nars-implication $Ctx (implication $S $P) (implication (disjunction $Ls) (disjunction $Lp))) + (narz-ground $Ls) + (narz-ground $Lp) + (narz-replace $Ls $S $L $P) + (narz-same $L $Lp)) + (= (nars-implication $Ctx (equivalence $S $P) (equivalence (conjunction $Ls) (conjunction $Lp))) + (narz-ground $Ls) + (narz-ground $Lp) + (narz-replace $Ls $S $L $P) + (narz-same $L $Lp)) + (= (nars-implication $Ctx (equivalence $S $P) (equivalence (disjunction $Ls) (disjunction $Lp))) + (narz-ground $Ls) + (narz-ground $Lp) + (narz-replace $Ls $S $L $P) + (narz-same $L $Lp)) + + +; +; NARS equivalence/2 + + (= (equivalence $X $Y) + (nars-ctx $Ctx) + (nars-equivalence $Ctx $X $Y)) + + + (= (nars-equivalence $Ctx $X $Y) + (narz-ground $X) + (narz-reduce $X $Y) + (\== $X $Y) + (set-det)) - (= - (nars-implication $Ctx - (implication $S $P) - (implication - (conjunction $Ls) - (conjunction $Lp))) - ( (narz-ground $Ls) - (narz-ground $Lp) - (narz-replace $Ls $S $L $P) - (narz-same $L $Lp))) -; - - (= - (nars-implication $Ctx - (implication $S $P) - (implication - (disjunction $Ls) - (disjunction $Lp))) - ( (narz-ground $Ls) - (narz-ground $Lp) - (narz-replace $Ls $S $L $P) - (narz-same $L $Lp))) -; - - (= - (nars-implication $Ctx - (equivalence $S $P) - (equivalence - (conjunction $Ls) - (conjunction $Lp))) - ( (narz-ground $Ls) - (narz-ground $Lp) - (narz-replace $Ls $S $L $P) - (narz-same $L $Lp))) -; - - (= - (nars-implication $Ctx - (equivalence $S $P) - (equivalence - (disjunction $Ls) - (disjunction $Lp))) - ( (narz-ground $Ls) - (narz-ground $Lp) - (narz-replace $Ls $S $L $P) - (narz-same $L $Lp))) -; - - - -; -; - - - (= - (equivalence $X $Y) - ( (nars-ctx $Ctx) (nars-equivalence $Ctx $X $Y))) -; - - - - (= - (nars-equivalence $Ctx $X $Y) - ( (narz-ground $X) - (narz-reduce $X $Y) - (\== $X $Y) - (set-det))) -; - - - (= - (nars_equivalence $Ctx - (similarity $S $P) - (similarity $P $S)) True) -; - - - (= - (nars_equivalence $Ctx - (inheritance $S - (ext_set - ($P))) - (similarity $S - (ext_set - ($P)))) True) -; - - (= - (nars_equivalence $Ctx - (inheritance - (int_set - ($S)) $P) - (similarity - (int_set - ($S)) $P)) True) -; - - - (= - (nars-equivalence $Ctx - (inheritance $S - (ext-intersection $Lp)) - (conjunction $L)) + (= (nars_equivalence $Ctx (similarity $S $P) (similarity $P $S)) True) + + (= (nars_equivalence $Ctx (inheritance $S (ext_set ($P))) (similarity $S (ext_set ($P)))) True) + (= (nars_equivalence $Ctx (inheritance (int_set ($S)) $P) (similarity (int_set ($S)) $P)) True) + + (= (nars-equivalence $Ctx (inheritance $S (ext-intersection $Lp)) (conjunction $L)) (findall (nars-inheritance $Ctx $S $P) - (member $P $Lp) $L)) -; - - (= - (nars-equivalence $Ctx - (inheritance - (int-intersection $Ls) $P) - (conjunction $L)) + (member $P $Lp) $L)) + (= (nars-equivalence $Ctx (inheritance (int-intersection $Ls) $P) (conjunction $L)) (findall (nars-inheritance $Ctx $S $P) (member $S $Ls) $L)) -; - - - (= - (nars_equivalence $Ctx - (inheritance $S - (ext_difference $P1 $P2)) - (conjunction - ( (inheritance $S $P1) (negation (inheritance $S $P2))))) True) -; - - (= - (nars_equivalence $Ctx - (inheritance - (int_difference $S1 $S2) $P) - (conjunction - ( (inheritance $S1 $P) (negation (inheritance $S2 $P))))) True) -; + (= (nars_equivalence $Ctx (inheritance $S (ext_difference $P1 $P2)) (conjunction ((inheritance $S $P1) (negation (inheritance $S $P2))))) True) + (= (nars_equivalence $Ctx (inheritance (int_difference $S1 $S2) $P) (conjunction ((inheritance $S1 $P) (negation (inheritance $S2 $P))))) True) - (= - (nars-equivalence $Ctx - (inheritance - (product $Ls) - (product $Lp)) - (conjunction $L)) + (= (nars-equivalence $Ctx (inheritance (product $Ls) (product $Lp)) (conjunction $L)) (equ-product $Ls $Lp $L)) -; - - (= - (nars-equivalence $Ctx - (inheritance - (product (Cons $S $L)) - (product (Cons $P $L))) - (inheritance $S $P)) + (= (nars-equivalence $Ctx (inheritance (product (Cons $S $L)) (product (Cons $P $L))) (inheritance $S $P)) (narz-ground $L)) -; - - (= + (= (nars-equivalence $Ctx (inheritance $S $P) (inheritance (product (Cons $H $Ls)) (product (Cons $H $Lp)))) + (narz-ground $H) (nars-equivalence $Ctx - (inheritance $S $P) (inheritance - (product (Cons $H $Ls)) - (product (Cons $H $Lp)))) - ( (narz-ground $H) (nars-equivalence $Ctx (inheritance (product $Ls) (product $Lp)) (inheritance $S $P)))) -; - + (product $Ls) + (product $Lp)) + (inheritance $S $P))) - (= - (nars-equivalence $Ctx - (inheritance - (product $L) $R) - (inheritance $T - (ext-image $R $L1))) + (= (nars-equivalence $Ctx (inheritance (product $L) $R) (inheritance $T (ext-image $R $L1))) (narz-replace $L $T $L1)) -; - - (= - (nars-equivalence $Ctx - (inheritance $R - (product $L)) - (inheritance - (int-image $R $L1) $T)) + (= (nars-equivalence $Ctx (inheritance $R (product $L)) (inheritance (int-image $R $L1) $T)) (narz-replace $L $T $L1)) -; + (= (nars_equivalence $Ctx (equivalence $S $P) (equivalence $P $S)) True) - (= - (nars_equivalence $Ctx - (equivalence $S $P) - (equivalence $P $S)) True) -; + (= (nars_equivalence $Ctx (equivalence (negation $S) $P) (equivalence (negation $P) $S)) True) - - (= - (nars_equivalence $Ctx - (equivalence - (negation $S) $P) - (equivalence - (negation $P) $S)) True) -; - - - (= - (nars-equivalence $Ctx - (conjunction $L1) - (conjunction $L2)) + (= (nars-equivalence $Ctx (conjunction $L1) (conjunction $L2)) (narz-same-set $L1 $L2)) -; - - (= - (nars-equivalence $Ctx - (disjunction $L1) - (disjunction $L2)) + (= (nars-equivalence $Ctx (disjunction $L1) (disjunction $L2)) (narz-same-set $L1 $L2)) -; - - (= - (nars-equivalence $Ctx - (implication $S - (conjunction $Lp)) - (conjunction $L)) + (= (nars-equivalence $Ctx (implication $S (conjunction $Lp)) (conjunction $L)) (findall (nars-implication $Ctx $S $P) (member $P $Lp) $L)) -; - - (= - (nars-equivalence $Ctx - (implication - (disjunction $Ls) $P) - (conjunction $L)) + (= (nars-equivalence $Ctx (implication (disjunction $Ls) $P) (conjunction $L)) (findall (nars-implication $Ctx $S $P) (member $S $Ls) $L)) -; - - (= - (nars-equivalence $Ctx $T1 $T2) - ( (not (atom $T1)) - (not (atom $T2)) - (narz-ground $T1) - (narz-ground $T2) - (=.. $T1 $L1) - (=.. $T2 $L2) - (nars-equivalence-list $Ctx $L1 $L2))) -; - - - - (= - (nars_equivalence_list $Ctx $L $L) True) -; - - (= - (nars-equivalence-list $Ctx - (Cons $H $L1) - (Cons $H $L2)) + (= (nars-equivalence $Ctx $T1 $T2) + (not (atom $T1)) + (not (atom $T2)) + (narz-ground $T1) + (narz-ground $T2) + (=.. $T1 $L1) + (=.. $T2 $L2) (nars-equivalence-list $Ctx $L1 $L2)) -; - (= - (nars-equivalence-list $Ctx - (Cons $H1 $L1) - (Cons $H2 $L2)) - ( (nars-similarity $Ctx $H1 $H2) (nars-equivalence-list $Ctx $L1 $L2))) -; - - (= - (nars-equivalence-list $Ctx - (Cons $H1 $L1) - (Cons $H2 $L2)) - ( (nars-equivalence $Ctx $H1 $H2) (nars-equivalence-list $Ctx $L1 $L2))) -; + (= (nars_equivalence_list $Ctx $L $L) True) + (= (nars-equivalence-list $Ctx (Cons $H $L1) (Cons $H $L2)) + (nars-equivalence-list $Ctx $L1 $L2)) + (= (nars-equivalence-list $Ctx (Cons $H1 $L1) (Cons $H2 $L2)) + (nars-similarity $Ctx $H1 $H2) + (nars-equivalence-list $Ctx $L1 $L2)) + (= (nars-equivalence-list $Ctx (Cons $H1 $L1) (Cons $H2 $L2)) + (nars-equivalence $Ctx $H1 $H2) + (nars-equivalence-list $Ctx $L1 $L2)) ; -; +; compound termnars_structurereduction - - (= - (narz-reduce - (similarity - (ext-set (:: $S)) - (ext-set (:: $P))) - (similarity $S $P)) + (= (narz-reduce (similarity (ext-set (:: $S)) (ext-set (:: $P))) (similarity $S $P)) (set-det)) -; - - (= - (narz-reduce - (similarity - (int-set (:: $S)) - (int-set (:: $P))) - (similarity $S $P)) + (= (narz-reduce (similarity (int-set (:: $S)) (int-set (:: $P))) (similarity $S $P)) (set-det)) -; - - (= - (narz-reduce - (instance $S $P) - (inheritance - (ext-set (:: $S)) $P)) + (= (narz-reduce (instance $S $P) (inheritance (ext-set (:: $S)) $P)) (set-det)) -; - - (= - (narz-reduce - (property $S $P) - (inheritance $S - (int-set (:: $P)))) + (= (narz-reduce (property $S $P) (inheritance $S (int-set (:: $P)))) (set-det)) -; - - (= - (narz-reduce - (inst-prop $S $P) - (inheritance - (ext-set (:: $S)) - (int-set (:: $P)))) + (= (narz-reduce (inst-prop $S $P) (inheritance (ext-set (:: $S)) (int-set (:: $P)))) (set-det)) -; - - (= - (narz-reduce - (ext-intersection (:: $T)) $T) + (= (narz-reduce (ext-intersection (:: $T)) $T) (set-det)) -; - - (= - (narz-reduce - (int-intersection (:: $T)) $T) + (= (narz-reduce (int-intersection (:: $T)) $T) (set-det)) -; - - - (= - (narz-reduce - (ext-intersection (:: (ext-intersection $L1) (ext-intersection $L2))) - (ext-intersection $L)) - ( (nars-union $L1 $L2 $L) (set-det))) -; - - (= - (narz-reduce - (ext-intersection (:: (ext-intersection $L1) $L2)) - (ext-intersection $L)) - ( (nars-union $L1 - (:: $L2) $L) (set-det))) -; - - (= - (narz-reduce - (ext-intersection (:: $L1 (ext-intersection $L2))) - (ext-intersection $L)) - ( (nars-union - (:: $L1) $L2 $L) (set-det))) -; - - (= - (narz-reduce - (ext-intersection (:: (ext-set $L1) (ext-set $L2))) - (ext-set $L)) - ( (intersection $L1 $L2 $L) (set-det))) -; - - (= - (narz-reduce - (ext-intersection (:: (int-set $L1) (int-set $L2))) - (int-set $L)) - ( (nars-union $L1 $L2 $L) (set-det))) -; - - - (= - (narz-reduce - (int-intersection (:: (int-intersection $L1) (int-intersection $L2))) - (int-intersection $L)) - ( (nars-union $L1 $L2 $L) (set-det))) -; - - (= - (narz-reduce - (int-intersection (:: (int-intersection $L1) $L2)) - (int-intersection $L)) - ( (nars-union $L1 - (:: $L2) $L) (set-det))) -; - - (= - (narz-reduce - (int-intersection (:: $L1 (int-intersection $L2))) - (int-intersection $L)) - ( (nars-union - (:: $L1) $L2 $L) (set-det))) -; - - (= - (narz-reduce - (int-intersection (:: (int-set $L1) (int-set $L2))) - (int-set $L)) - ( (intersection $L1 $L2 $L) (set-det))) -; - - (= - (narz-reduce - (int-intersection (:: (ext-set $L1) (ext-set $L2))) - (ext-set $L)) - ( (nars-union $L1 $L2 $L) (set-det))) -; - - - (= - (narz-reduce - (ext-difference - (ext-set $L1) - (ext-set $L2)) - (ext-set $L)) - ( (nars-subtract $L1 $L2 $L) (set-det))) -; - - (= - (narz-reduce - (int-difference - (int-set $L1) - (int-set $L2)) - (int-set $L)) - ( (nars-subtract $L1 $L2 $L) (set-det))) -; - - - (= - (narz-reduce - (product - (product $L) $T) - (product $L1)) - ( (append $L - (:: $T) $L1) (set-det))) -; - - - (= - (narz-reduce - (ext-image - (product $L1) $L2) $T1) - ( (member $T1 $L1) - (narz-replace $L1 $T1 $L2) - (set-det))) -; - - (= - (narz-reduce - (int-image - (product $L1) $L2) $T1) - ( (member $T1 $L1) - (narz-replace $L1 $T1 $L2) - (set-det))) -; - - (= - (narz-reduce - (negation (negation $S)) $S) + (= (narz-reduce (ext-intersection (:: (ext-intersection $L1) (ext-intersection $L2))) (ext-intersection $L)) + (nars-union $L1 $L2 $L) (set-det)) -; - - - (= - (narz-reduce - (conjunction (:: $T)) $T) + (= (narz-reduce (ext-intersection (:: (ext-intersection $L1) $L2)) (ext-intersection $L)) + (nars-union $L1 + (:: $L2) $L) (set-det)) -; - - (= - (narz-reduce - (disjunction (:: $T)) $T) + (= (narz-reduce (ext-intersection (:: $L1 (ext-intersection $L2))) (ext-intersection $L)) + (nars-union + (:: $L1) $L2 $L) + (set-det)) + (= (narz-reduce (ext-intersection (:: (ext-set $L1) (ext-set $L2))) (ext-set $L)) + (intersection $L1 $L2 $L) + (set-det)) + (= (narz-reduce (ext-intersection (:: (int-set $L1) (int-set $L2))) (int-set $L)) + (nars-union $L1 $L2 $L) (set-det)) -; + (= (narz-reduce (int-intersection (:: (int-intersection $L1) (int-intersection $L2))) (int-intersection $L)) + (nars-union $L1 $L2 $L) + (set-det)) + (= (narz-reduce (int-intersection (:: (int-intersection $L1) $L2)) (int-intersection $L)) + (nars-union $L1 + (:: $L2) $L) + (set-det)) + (= (narz-reduce (int-intersection (:: $L1 (int-intersection $L2))) (int-intersection $L)) + (nars-union + (:: $L1) $L2 $L) + (set-det)) + (= (narz-reduce (int-intersection (:: (int-set $L1) (int-set $L2))) (int-set $L)) + (intersection $L1 $L2 $L) + (set-det)) + (= (narz-reduce (int-intersection (:: (ext-set $L1) (ext-set $L2))) (ext-set $L)) + (nars-union $L1 $L2 $L) + (set-det)) - (= - (narz-reduce - (conjunction (:: (conjunction $L1) (conjunction $L2))) - (conjunction $L)) - ( (nars-union $L1 $L2 $L) (set-det))) -; + (= (narz-reduce (ext-difference (ext-set $L1) (ext-set $L2)) (ext-set $L)) + (nars-subtract $L1 $L2 $L) + (set-det)) + (= (narz-reduce (int-difference (int-set $L1) (int-set $L2)) (int-set $L)) + (nars-subtract $L1 $L2 $L) + (set-det)) - (= - (narz-reduce - (conjunction (:: (conjunction $L1) $L2)) - (conjunction $L)) - ( (nars-union $L1 - (:: $L2) $L) (set-det))) -; + (= (narz-reduce (product (product $L) $T) (product $L1)) + (append $L + (:: $T) $L1) + (set-det)) - (= - (narz-reduce - (conjunction (:: $L1 (conjunction $L2))) - (conjunction $L)) - ( (nars-union - (:: $L1) $L2 $L) (set-det))) -; + (= (narz-reduce (ext-image (product $L1) $L2) $T1) + (member $T1 $L1) + (narz-replace $L1 $T1 $L2) + (set-det)) + (= (narz-reduce (int-image (product $L1) $L2) $T1) + (member $T1 $L1) + (narz-replace $L1 $T1 $L2) + (set-det)) + (= (narz-reduce (negation (negation $S)) $S) + (set-det)) - (= - (narz-reduce - (disjunction - (disjunction $L1) - (disjunction $L2)) - (disjunction $L)) - ( (nars-union $L1 $L2 $L) (set-det))) -; - - (= - (narz-reduce - (disjunction - (disjunction $L1) $L2) - (disjunction $L)) - ( (nars-union $L1 - (:: $L2) $L) (set-det))) -; - - (= - (narz-reduce - (disjunction $L1 - (disjunction $L2)) - (disjunction $L)) - ( (nars-union - (:: $L1) $L2 $L) (set-det))) -; + (= (narz-reduce (conjunction (:: $T)) $T) + (set-det)) + (= (narz-reduce (disjunction (:: $T)) $T) + (set-det)) + (= (narz-reduce (conjunction (:: (conjunction $L1) (conjunction $L2))) (conjunction $L)) + (nars-union $L1 $L2 $L) + (set-det)) + (= (narz-reduce (conjunction (:: (conjunction $L1) $L2)) (conjunction $L)) + (nars-union $L1 + (:: $L2) $L) + (set-det)) + (= (narz-reduce (conjunction (:: $L1 (conjunction $L2))) (conjunction $L)) + (nars-union + (:: $L1) $L2 $L) + (set-det)) - (= - (narz_reduce $X $X) True) -; + (= (narz-reduce (disjunction (disjunction $L1) (disjunction $L2)) (disjunction $L)) + (nars-union $L1 $L2 $L) + (set-det)) + (= (narz-reduce (disjunction (disjunction $L1) $L2) (disjunction $L)) + (nars-union $L1 + (:: $L2) $L) + (set-det)) + (= (narz-reduce (disjunction $L1 (disjunction $L2)) (disjunction $L)) + (nars-union + (:: $L1) $L2 $L) + (set-det)) + (= (narz_reduce $X $X) True) ; -; +; nars_union(X,Y,Z):- (nonvar(X);nonvar(Z)), catch(union(X,Y,Z),_,fail). - - (= - (nars-union $X $Y $Z) + (= (nars-union $X $Y $Z) (catch (union $X $Y $Z) $_ fail)) -; - ; -; +; nars_subtract(X,Y,Z):- (nonvar(X);nonvar(Z)), catch(subtract(X,Y,Z),_,fail). - - (= - (nars-subtract $X $Y $Z) + (= (nars-subtract $X $Y $Z) (catch (subtract $X $Y $Z) $_ fail)) -; - ; -; - - +; ;; Argument processing - (= - (equ_product () () ()) True) -; - (= - (equ-product - (Cons $T $Ls) - (Cons $T $Lp) $L) - ( (equ-product $Ls $Lp $L) (set-det))) -; - - (= - (equ-product - (Cons $S $Ls) - (Cons $P $Lp) - (Cons - (inheritance $S $P) $L)) + (= (equ_product () () ()) True) + (= (equ-product (Cons $T $Ls) (Cons $T $Lp) $L) + (equ-product $Ls $Lp $L) + (set-det)) + (= (equ-product (Cons $S $Ls) (Cons $P $Lp) (Cons (inheritance $S $P) $L)) (equ-product $Ls $Lp $L)) -; - - - (= - (narz-same-set $L1 $L2) - ( (\== $L1 Nil) - (\== $L1 - (:: $_)) - (narz-same $L1 $L2) - (\== $L1 $L2))) -; + (= (narz-same-set $L1 $L2) + (\== $L1 Nil) + (\== $L1 + (:: $_)) + (narz-same $L1 $L2) + (\== $L1 $L2)) - (= - (narz_same () ()) True) -; + (= (narz_same () ()) True) + (= (narz-same $L (Cons $H $T)) + (member $H $L) + (nars-subtract $L + (:: $H) $L1) + (narz-same $L1 $T)) - (= - (narz-same $L - (Cons $H $T)) - ( (member $H $L) - (nars-subtract $L - (:: $H) $L1) - (narz-same $L1 $T))) -; - - - - (= - (narz-include $L1 $L2) - ( (narz-ground $L2) - (include1 $L1 $L2) - (\== $L1 Nil) - (\== $L1 $L2))) -; + (= (narz-include $L1 $L2) + (narz-ground $L2) + (include1 $L1 $L2) + (\== $L1 Nil) + (\== $L1 $L2)) - (= - (include1 () $_) True) -; - - (= - (include1 - (Cons $H $T1) - (Cons $H $T2)) + (= (include1 () $_) True) + (= (include1 (Cons $H $T1) (Cons $H $T2)) (include1 $T1 $T2)) -; - - (= + (= (include1 (Cons $H1 $T1) (Cons $H2 $T2)) + (\== $H2 $H1) (include1 - (Cons $H1 $T1) - (Cons $H2 $T2)) - ( (\== $H2 $H1) (include1 (Cons $H1 $T1) $T2))) -; - - - - (= - (narz_not_member $_ ()) True) -; - - (= - (narz-not-member $C - (Cons $C $_)) - ( (set-det) (fail))) -; - - (= - (narz-not-member - (:: $S $T) - (Cons - (:: $S1 $T) $_)) - ( (nars-equivalence $Ctx $S $S1) - (set-det) - (fail))) -; - - (= - (narz-not-member $C - (Cons $_ $L)) + (Cons $H1 $T1) $T2)) + + + (= (narz_not_member $_ ()) True) + (= (narz-not-member $C (Cons $C $_)) + (set-det) + (fail)) + (= (narz-not-member (:: $S $T) (Cons (:: $S1 $T) $_)) + (nars-equivalence $Ctx $S $S1) + (set-det) + (fail)) + (= (narz-not-member $C (Cons $_ $L)) (narz-not-member $C $L)) -; + (= (narz_replace (Cons $T $L) $T (Cons nil $L)) True) + (= (narz-replace (Cons $H $L) $T (Cons $H $L1)) + (narz-replace $L $T $L1)) - (= - (narz_replace - (Cons $T $L) $T - (Cons nil $L)) True) -; + (= (narz_replace (Cons $H1 $T) $H1 (Cons $H2 $T) $H2) True) + (= (narz-replace (Cons $H $T1) $H1 (Cons $H $T2) $H2) + (narz-replace $T1 $H1 $T2 $H2)) - (= - (narz-replace - (Cons $H $L) $T - (Cons $H $L1)) - (narz-replace $L $T $L1)) -; + (= (narz-dependant (var $V $L) $Y (var $V (Cons $Y $L))) + (set-det)) + (= (narz-dependant (Cons $H $T) $Y (Cons $H1 $T1)) + (narz-dependant $H $Y $H1) + (narz-dependant $T $Y $T1) + (set-det)) + (= (narz-dependant (inheritance $S $P) $Y (inheritance $S1 $P1)) + (narz-dependant $S $Y $S1) + (narz-dependant $P $Y $P1) + (set-det)) + (= (narz-dependant (ext-image $R $A) $Y (ext-image $R $A1)) + (narz-dependant $A $Y $A1) + (set-det)) + (= (narz-dependant (int-image $R $A) $Y (int-image $R $A1)) + (narz-dependant $A $Y $A1) + (set-det)) + (= (narz_dependant $X $_ $X) True) - (= - (narz_replace - (Cons $H1 $T) $H1 - (Cons $H2 $T) $H2) True) -; - (= - (narz-replace - (Cons $H $T1) $H1 - (Cons $H $T2) $H2) - (narz-replace $T1 $H1 $T2 $H2)) -; +; +; ;; Truth-value functions + (= (narz-f-rev (:: $F1 $C1) (:: $F2 $C2) (:: $F $C)) + (< $C1 1) + (< $C2 1) + (is $M1 + (/ $C1 + (- 1 $C1))) + (is $M2 + (/ $C2 + (- 1 $C2))) + (is $F + (/ + (+ + (* $M1 $F1) + (* $M2 $F2)) + (+ $M1 $M2))) + (is $C + (/ + (+ $M1 $M2) + (+ + (+ $M1 $M2) 1)))) - (= - (narz-dependant - (var $V $L) $Y - (var $V - (Cons $Y $L))) - (set-det)) -; - - (= - (narz-dependant - (Cons $H $T) $Y - (Cons $H1 $T1)) - ( (narz-dependant $H $Y $H1) - (narz-dependant $T $Y $T1) - (set-det))) -; - - (= - (narz-dependant - (inheritance $S $P) $Y - (inheritance $S1 $P1)) - ( (narz-dependant $S $Y $S1) - (narz-dependant $P $Y $P1) - (set-det))) -; - - (= - (narz-dependant - (ext-image $R $A) $Y - (ext-image $R $A1)) - ( (narz-dependant $A $Y $A1) (set-det))) -; - - (= - (narz-dependant - (int-image $R $A) $Y - (int-image $R $A1)) - ( (narz-dependant $A $Y $A1) (set-det))) -; - - (= - (narz_dependant $X $_ $X) True) -; - - - -; -; - - - - (= - (narz-f-rev - (:: $F1 $C1) - (:: $F2 $C2) - (:: $F $C)) - ( (< $C1 1) - (< $C2 1) - (is $M1 - (/ $C1 - (- 1 $C1))) - (is $M2 - (/ $C2 - (- 1 $C2))) - (is $F - (/ - (+ - (* $M1 $F1) - (* $M2 $F2)) - (+ $M1 $M2))) - (is $C - (/ - (+ $M1 $M2) - (+ - (+ $M1 $M2) 1))))) -; - - - - (= - (narz-f-exp - (:: $F $C) $E) + + (= (narz-f-exp (:: $F $C) $E) (is $E (+ (* $C (- $F 0.5)) 0.5))) -; - - (= - (narz-f-neg - (:: $F1 $C1) - (:: $F $C1)) + (= (narz-f-neg (:: $F1 $C1) (:: $F $C1)) (u-not $F1 $F)) -; - - - (= - (narz-f-cnv - (:: $F1 $C1) - (:: 1 $C)) - ( (u-and - (:: $F1 $C1) $W) (u-w2c $W $C))) -; + (= (narz-f-cnv (:: $F1 $C1) (:: 1 $C)) + (u-and + (:: $F1 $C1) $W) + (u-w2c $W $C)) - (= - (narz-f-cnt - (:: $F1 $C1) - (:: 0 $C)) - ( (u-not $F1 $F0) - (u-and - (:: $F0 $C1) $W) - (u-w2c $W $C))) -; - - - - (= - (narz-f-ded - (:: $F1 $C1) - (:: $F2 $C2) - (:: $F $C)) - ( (u-and - (:: $F1 $F2) $F) (u-and (:: $C1 $C2 $F) $C))) -; - - + (= (narz-f-cnt (:: $F1 $C1) (:: 0 $C)) + (u-not $F1 $F0) + (u-and + (:: $F0 $C1) $W) + (u-w2c $W $C)) - (= - (narz-f-ana - (:: $F1 $C1) - (:: $F2 $C2) - (:: $F $C)) - ( (u-and - (:: $F1 $F2) $F) (u-and (:: $C1 $C2 $F2) $C))) -; + (= (narz-f-ded (:: $F1 $C1) (:: $F2 $C2) (:: $F $C)) + (u-and + (:: $F1 $F2) $F) + (u-and + (:: $C1 $C2 $F) $C)) - (= - (narz-f-res - (:: $F1 $C1) - (:: $F2 $C2) - (:: $F $C)) - ( (u-and - (:: $F1 $F2) $F) - (u-or - (:: $F1 $F2) $F0) - (u-and - (:: $C1 $C2 $F0) $C))) -; + (= (narz-f-ana (:: $F1 $C1) (:: $F2 $C2) (:: $F $C)) + (u-and + (:: $F1 $F2) $F) + (u-and + (:: $C1 $C2 $F2) $C)) + (= (narz-f-res (:: $F1 $C1) (:: $F2 $C2) (:: $F $C)) + (u-and + (:: $F1 $F2) $F) + (u-or + (:: $F1 $F2) $F0) + (u-and + (:: $C1 $C2 $F0) $C)) - (= - (narz-f-abd - (:: $F1 $C1) - (:: $F2 $C2) - (:: $F2 $C)) - ( (u-and - (:: $F1 $C1 $C2) $W) (u-w2c $W $C))) -; + (= (narz-f-abd (:: $F1 $C1) (:: $F2 $C2) (:: $F2 $C)) + (u-and + (:: $F1 $C1 $C2) $W) + (u-w2c $W $C)) - (= - (narz-f-ind $T1 $T2 $T) + (= (narz-f-ind $T1 $T2 $T) (narz-f-abd $T2 $T1 $T)) -; - - - - (= - (narz-f-exe - (:: $F1 $C1) - (:: $F2 $C2) - (:: 1 $C)) - ( (u-and - (:: $F1 $C1 $F2 $C2) $W) (u-w2c $W $C))) -; - - - - (= - (narz_f_com - (0 $C1) - (0 $C2) - (0 0)) True) -; - - (= - (narz-f-com - (:: $F1 $C1) - (:: $F2 $C2) - (:: $F $C)) - ( (u-or - (:: $F1 $F2) $F0) - (> $F0 0) - (is $F - (/ - (* $F1 $F2) $F0)) - (u-and - (:: $F0 $C1 $C2) $W) - (u-w2c $W $C))) -; - - - - (= - (narz-f-int - (:: $F1 $C1) - (:: $F2 $C2) - (:: $F $C)) - ( (u-and - (:: $F1 $F2) $F) (u-and (:: $C1 $C2) $C))) -; - - (= - (narz-f-uni - (:: $F1 $C1) - (:: $F2 $C2) - (:: $F $C)) - ( (u-or - (:: $F1 $F2) $F) (u-and (:: $C1 $C2) $C))) -; - - - - (= - (narz-f-dif - (:: $F1 $C1) - (:: $F2 $C2) - (:: $F $C)) - ( (u-not $F2 $F0) - (u-and - (:: $F1 $F0) $F) - (u-and - (:: $C1 $C2) $C))) -; + (= (narz-f-exe (:: $F1 $C1) (:: $F2 $C2) (:: 1 $C)) + (u-and + (:: $F1 $C1 $F2 $C2) $W) + (u-w2c $W $C)) + (= (narz_f_com (0 $C1) (0 $C2) (0 0)) True) + (= (narz-f-com (:: $F1 $C1) (:: $F2 $C2) (:: $F $C)) + (u-or + (:: $F1 $F2) $F0) + (> $F0 0) + (is $F + (/ + (* $F1 $F2) $F0)) + (u-and + (:: $F0 $C1 $C2) $W) + (u-w2c $W $C)) - (= - (narz-f-pnn - (:: $F1 $C1) - (:: $F2 $C2) - (:: $F $C)) - ( (u-not $F2 $F2n) - (u-and - (:: $F1 $F2n) $Fn) - (u-not $Fn $F) - (u-and - (:: $Fn $C1 $C2) $C))) -; + (= (narz-f-int (:: $F1 $C1) (:: $F2 $C2) (:: $F $C)) + (u-and + (:: $F1 $F2) $F) + (u-and + (:: $C1 $C2) $C)) - (= - (narz-f-npp - (:: $F1 $C1) - (:: $F2 $C2) - (:: $F $C)) - ( (u-not $F1 $F1n) - (u-and - (:: $F1n $F2) $F) - (u-and - (:: $F $C1 $C2) $C))) -; + (= (narz-f-uni (:: $F1 $C1) (:: $F2 $C2) (:: $F $C)) + (u-or + (:: $F1 $F2) $F) + (u-and + (:: $C1 $C2) $C)) + (= (narz-f-dif (:: $F1 $C1) (:: $F2 $C2) (:: $F $C)) + (u-not $F2 $F0) + (u-and + (:: $F1 $F0) $F) + (u-and + (:: $C1 $C2) $C)) - (= - (narz-f-pnp - (:: $F1 $C1) - (:: $F2 $C2) - (:: $F $C)) - ( (u-not $F2 $F2n) - (u-and - (:: $F1 $F2n) $F) - (u-and - (:: $F $C1 $C2) $C))) -; - - - - (= - (narz-f-nnn - (:: $F1 $C1) - (:: $F2 $C2) - (:: $F $C)) - ( (u-not $F1 $F1n) - (u-not $F2 $F2n) - (u-and - (:: $F1n $F2n) $Fn) - (u-not $Fn $F) - (u-and - (:: $Fn $C1 $C2) $C))) -; - - -; -; + (= (narz-f-pnn (:: $F1 $C1) (:: $F2 $C2) (:: $F $C)) + (u-not $F2 $F2n) + (u-and + (:: $F1 $F2n) $Fn) + (u-not $Fn $F) + (u-and + (:: $Fn $C1 $C2) $C)) - (= - (u-not $N0 $N) - ( (is $N - (- 1 $N0)) (set-det))) -; + (= (narz-f-npp (:: $F1 $C1) (:: $F2 $C2) (:: $F $C)) + (u-not $F1 $F1n) + (u-and + (:: $F1n $F2) $F) + (u-and + (:: $F $C1 $C2) $C)) + (= (narz-f-pnp (:: $F1 $C1) (:: $F2 $C2) (:: $F $C)) + (u-not $F2 $F2n) + (u-and + (:: $F1 $F2n) $F) + (u-and + (:: $F $C1 $C2) $C)) - (= - (u_and - ($N) $N) True) -; - (= + (= (narz-f-nnn (:: $F1 $C1) (:: $F2 $C2) (:: $F $C)) + (u-not $F1 $F1n) + (u-not $F2 $F2n) (u-and - (Cons $N0 $Nt) $N) - ( (u-and $Nt $N1) - (is $N - (* $N0 $N1)) - (set-det))) -; + (:: $F1n $F2n) $Fn) + (u-not $Fn $F) + (u-and + (:: $Fn $C1 $C2) $C)) + +; +; Utility functions + (= (u-not $N0 $N) + (is $N + (- 1 $N0)) + (set-det)) - (= - (u_or - ($N) $N) True) -; - (= - (u-or - (Cons $N0 $Nt) $N) - ( (u-or $Nt $N1) - (is $N - (- - (+ $N0 $N1) - (* $N0 $N1))) - (set-det))) -; + (= (u_and ($N) $N) True) + (= (u-and (Cons $N0 $Nt) $N) + (u-and $Nt $N1) + (is $N + (* $N0 $N1)) + (set-det)) + (= (u_or ($N) $N) True) + (= (u-or (Cons $N0 $Nt) $N) + (u-or $Nt $N1) + (is $N + (- + (+ $N0 $N1) + (* $N0 $N1))) + (set-det)) - (= - (u-w2c $W $C) - ( (= $K 1) - (is $C - (/ $W - (+ $W $K))) - (set-det))) -; + (= (u-w2c $W $C) + (= $K 1) + (is $C + (/ $W + (+ $W $K))) + (set-det)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; memory.pl ; -; - +; 11.1.2 State accumulation using engines - https://www.swi-MeTTa.org/pldoc/man?section=engine-state !(use-module (library heaps)) -; - - - (= - (create-heap $E) - ( (empty-heap $H) (engine-create $_ (update-heap $H) $E))) -; + (= (create-heap $E) + (empty-heap $H) + (engine-create $_ + (update-heap $H) $E)) - (= - (update-heap $H) - ( (engine-fetch $Command) - (det-if-then-else - (update-heap $Command $Reply $H $H1) True - (, - (= $H1 $H) - (= $Reply False))) - (engine-yield $Reply) - (update-heap $H1))) -; - + (= (update-heap $H) + (engine-fetch $Command) + (det-if-then-else + (update-heap $Command $Reply $H $H1) True + (, + (= $H1 $H) + (= $Reply False))) + (engine-yield $Reply) + (update-heap $H1)) - (= - (update-heap - (add $Priority $Key) True $H0 $H) + (= (update-heap (add $Priority $Key) True $H0 $H) (add-to-heap $H0 $Priority $Key $H)) -; - - (= - (update-heap - (get $Priority $Key) - (- $Priority $Key) $H0 $H) + (= (update-heap (get $Priority $Key) (- $Priority $Key) $H0 $H) (get-from-heap $H0 $Priority $Key $H)) -; - - (= - (heap-add $Priority $Key $E) + (= (heap-add $Priority $Key $E) (engine-post $E (add $Priority $Key) True)) -; - - (= - (heap-get $Priority $Key $E) + (= (heap-get $Priority $Key $E) (engine-post $E (get $Priority $Key) (- $Priority $Key))) -; - ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - - +; control.pl - (= - (priority - (:: $_ - (:: $F $C)) $P) - ( (narz-f-exp - (:: $F $C) $E) (is $P $E))) -; + (= (priority (:: $_ (:: $F $C)) $P) + (narz-f-exp + (:: $F $C) $E) + (is $P $E)) - (= - (input-event $Event) + (= (input-event $Event) (heap-add 1.0 $Event belief-events-queue)) -; - - (= - (derive-event $Event) - ( (priority $Event $P) (heap-add $P $Event belief-events-queue))) -; + (= (derive-event $Event) + (priority $Event $P) + (heap-add $P $Event belief-events-queue)) - - (= - (inference-step $_) + (= (inference-step $_) (or (, (heap-get $Priority $Event belief-events-queue) @@ -3974,73 +1903,62 @@ (derive-event $Conclusion) (write $Conclusion) (nl)) True)) -; - +; ;undo removal of the second premise (TODO) - (= - (nars-main) - ( (create-heap belief-events-queue) (nars-main 1))) -; - - (= - (nars-main $T) - ( (read-nal $X) (or (, (= $X 1) (write "performing 1 inference steps:") (nl) (inference-step $T) (write "done with 1 additional inference steps.") (nl) (nars-main (+ $T 1))) (, (\= $X 1) (write "Input: ") (write $X) (nl) (input-event $X) (nars-main (+ $T 1)))))) -; - + (= (nars-main) + (create-heap belief-events-queue) + (nars-main 1)) + (= (nars-main $T) + (read-nal $X) + (or + (, + (= $X 1) + (write "performing 1 inference steps:") + (nl) + (inference-step $T) + (write "done with 1 additional inference steps.") + (nl) + (nars-main (+ $T 1))) + (, + (\= $X 1) + (write "Input: ") + (write $X) + (nl) + (input-event $X) + (nars-main (+ $T 1))))) ; -; - +; read_nal(X):- read(X). - (= - (read-nal $X) + (= (read-nal $X) (nal-read-clause current-input $X)) -; - !(if (prolog-load-context reload False)) -; - !(create-heap belief-events-queue) -; - !(endif *) -; - ; -; - +; test: ; -; - +; nars_main. ; -; - +; [inheritance(cat,animal), [1.0, 0.9]]. ; -; - +; [inheritance(animal,being), [1.0, 0.9]]. ; -; - +; 1. ; -; - +; output: ; -; - +; performing 1 inference steps: ; -; - +; [inheritance(cat,being),[1.0,0.81]] ; -; - +; done with 1 additional inference steps. !(fixup-exports *) -; - diff --git a/nars_lp/narsese.metta b/nars_lp/narsese.metta index 89a9214..db14b03 100644 --- a/nars_lp/narsese.metta +++ b/nars_lp/narsese.metta @@ -1,30 +1,18 @@ +; (convert_to_metta_file narsese $_283334 nars_lp/narsese.pl nars_lp/narsese.metta) ; -; - +; Non-Axiomatic Logic in MeTTa ; -; - +; Version: 1.1, September 2012 ; -; - +; GNU Lesser General Public License !(module narsese Nil) -; - !(set-module (class library)) -; - !(set-module (base system)) -; - !(reexport (library (/ nars nars))) -; - !(reexport (library (/ nars nal-reader))) -; - diff --git a/sldr_dl/example.metta b/sldr_dl/example.metta index c409a93..b2b1276 100644 --- a/sldr_dl/example.metta +++ b/sldr_dl/example.metta @@ -1,92 +1,117 @@ +; (convert_to_metta_file example $_339368 sldr_dl/example.pl sldr_dl/example.metta) !(:: (resolution *)) -; - - - - - - (= - (rule-set $RuleSet $MaxRuleID) - ( (= $MaxRuleID 7) (= $RuleSet (:: (:: 1 def-father-1 (:: (- (:: child $Y $X)) (- (:: male $X)) (+ (:: father $X $Y)))) (:: 2 def-mother-1 (:: (- (:: child $Y $X)) (- (:: female $X)) (+ (:: mother $X $Y)))) (:: 3 def-parent-1 (:: (- (:: father $X $Y)) (+ (:: parent $X $Y)))) (:: 4 def-parent-2 (:: (- (:: mother $X $Y)) (+ (:: parent $X $Y)))) (:: 5 fact-lucy-1 (:: (+ (:: female lucy)))) (:: 6 fact-alice-1 (:: (+ (:: child alice bob)))) (:: 7 fact-bob-1 (:: (+ (:: child bob lucy)))))))) -; - - - - (= - (symbol-set $SymbolSet $MaxSymbolID) - ( (= $MaxSymbolID 10) (= $SymbolSet (:: (:: 1 vble) (:: 2 father) (:: 3 child) (:: 4 male) (:: 5 female) (:: 6 parent) (:: 7 lucy) (:: 8 alice) (:: 9 bob) (:: 10 mother))))) -; - - - - - (= - (nnet-definition $NNet) - ( (= $InDim 70) - (= $HidDim 32) - (= $OutDim 7) - (layer-init layer1 $InDim $HidDim relu - (:: -0.2 0.2)) - (layer-init layer2 $HidDim $HidDim relu - (:: -0.2 0.2)) - (layer-init layer3 $HidDim $HidDim relu - (:: -0.2 0.2)) - (layer-init layer4 $HidDim $HidDim relu - (:: -0.2 0.2)) - (layer-init layer5 $HidDim $HidDim relu - (:: -0.2 0.2)) - (layer-init layer6 $HidDim $OutDim softmax - (:: -0.2 0.2)) - (= $NNet - (:: layer1 layer2 layer3 layer4 layer5 layer6)))) -; - - - - (= - (run-main) - ( (init-search-time) - (nnet-definition $NNet) - (rule-set $RS $NR) - (symbol-set $SS $NS) - (= $LM - (method - (learning 100 0.01) - (input 2 2) - (output 7))) - (= $RM - (method reasoning - (input 2 2) - (output 7))) - (= $G1 - (:: (- (:: female lucy)))) - (dnn-sl-resolution $G1 - (:: $RS $NR) - (:: $SS $NS) $NNet $LM 100 $_) - (= $G2 - (:: (- (:: mother lucy bob)))) - (dnn-sl-resolution $G2 - (:: $RS $NR) - (:: $SS $NS) $NNet $LM 100 $_) - (= $G3 - (:: - (- (:: mother lucy bob)) - (- (:: female lucy)))) - (dnn-sl-resolution $G3 - (:: $RS $NR) - (:: $SS $NS) $NNet $LM 100 $_) - (= $G4 - (:: (- (:: parent lucy bob)))) - (dnn-sl-resolution $G4 - (:: $RS $NR) - (:: $SS $NS) $NNet $RM 100 $Path4) - (nl) - (print-by-line $Path4) - (nl))) -; + + (= (rule-set $RuleSet $MaxRuleID) + (= $MaxRuleID 7) + (= $RuleSet + (:: + (:: 1 def-father-1 + (:: + (- (:: child $Y $X)) + (- (:: male $X)) + (+ (:: father $X $Y)))) + (:: 2 def-mother-1 + (:: + (- (:: child $Y $X)) + (- (:: female $X)) + (+ (:: mother $X $Y)))) + (:: 3 def-parent-1 + (:: + (- (:: father $X $Y)) + (+ (:: parent $X $Y)))) + (:: 4 def-parent-2 + (:: + (- (:: mother $X $Y)) + (+ (:: parent $X $Y)))) + (:: 5 fact-lucy-1 + (:: (+ (:: female lucy)))) + (:: 6 fact-alice-1 + (:: (+ (:: child alice bob)))) + (:: 7 fact-bob-1 + (:: (+ (:: child bob lucy))))))) + + + (= (symbol-set $SymbolSet $MaxSymbolID) + (= $MaxSymbolID 10) + (= $SymbolSet + (:: + (:: 1 vble) + (:: 2 father) + (:: 3 child) + (:: 4 male) + (:: 5 female) + (:: 6 parent) + (:: 7 lucy) + (:: 8 alice) + (:: 9 bob) + (:: 10 mother)))) + + + + (= (nnet-definition $NNet) + (= $InDim 70) + (= $HidDim 32) + (= $OutDim 7) + (layer-init layer1 $InDim $HidDim relu + (:: -0.2 0.2)) + (layer-init layer2 $HidDim $HidDim relu + (:: -0.2 0.2)) + (layer-init layer3 $HidDim $HidDim relu + (:: -0.2 0.2)) + (layer-init layer4 $HidDim $HidDim relu + (:: -0.2 0.2)) + (layer-init layer5 $HidDim $HidDim relu + (:: -0.2 0.2)) + (layer-init layer6 $HidDim $OutDim softmax + (:: -0.2 0.2)) + (= $NNet + (:: layer1 layer2 layer3 layer4 layer5 layer6))) + + + (= (run-main) + (init-search-time) + (nnet-definition $NNet) + (rule-set $RS $NR) + (symbol-set $SS $NS) + (= $LM + (method + (learning 100 0.01) + (input 2 2) + (output 7))) + (= $RM + (method reasoning + (input 2 2) + (output 7))) + (= $G1 + (:: (- (:: female lucy)))) + (dnn-sl-resolution $G1 + (:: $RS $NR) + (:: $SS $NS) $NNet $LM 100 $_) + (= $G2 + (:: (- (:: mother lucy bob)))) + (dnn-sl-resolution $G2 + (:: $RS $NR) + (:: $SS $NS) $NNet $LM 100 $_) + (= $G3 + (:: + (- (:: mother lucy bob)) + (- (:: female lucy)))) + (dnn-sl-resolution $G3 + (:: $RS $NR) + (:: $SS $NS) $NNet $LM 100 $_) + (= $G4 + (:: (- (:: parent lucy bob)))) + (dnn-sl-resolution $G4 + (:: $RS $NR) + (:: $SS $NS) $NNet $RM 100 $Path4) + (nl) + (print-by-line $Path4) + (nl)) + + diff --git a/sldr_dl/matrix.metta b/sldr_dl/matrix.metta index ee976ae..4b21a9a 100644 --- a/sldr_dl/matrix.metta +++ b/sldr_dl/matrix.metta @@ -1,108 +1,79 @@ +; (convert_to_metta_file matrix $_433166 sldr_dl/matrix.pl sldr_dl/matrix.metta) !(use-module (library clpfd)) -; - ; -; - - - - (= - (const-add-const $X $Y $Z) - ( (is $Z - (+ $X $Y)) (set-det))) -; - +; Addition - (= - (vec-add-vec $X $Y $R) - ( (maplist const-add-const $X $Y $R) (set-det))) -; + (= (const-add-const $X $Y $Z) + (is $Z + (+ $X $Y)) + (set-det)) + (= (vec-add-vec $X $Y $R) + (maplist const-add-const $X $Y $R) + (set-det)) - (= - (mat-add-mat $X $Y $R) - ( (maplist vec-add-vec $X $Y $R) (set-det))) -; + (= (mat-add-mat $X $Y $R) + (maplist vec-add-vec $X $Y $R) + (set-det)) ; -; - - - - (= - (const-mult-const $X $Y $Z) - ( (is $Z - (* $X $Y)) (set-det))) -; - - +; Multiplication - (= - (const-mult-vec $C $V $R) - ( (maplist - (const-mult-const $C) $V $R) (set-det))) -; + (= (const-mult-const $X $Y $Z) + (is $Z + (* $X $Y)) + (set-det)) - (= - (vec-mult-const $V $C $R) - ( (maplist - (const-mult-const $C) $V $R) (set-det))) -; - - - - (= - (vec-mult-vec $X $Y $R) - ( (maplist const-mult-const $X $Y $R) (set-det))) -; + (= (const-mult-vec $C $V $R) + (maplist + (const-mult-const $C) $V $R) + (set-det)) + (= (vec-mult-const $V $C $R) + (maplist + (const-mult-const $C) $V $R) + (set-det)) - (= - (mat-mult-const $M $C $R) - ( (maplist - (const-mult-vec $C) $M $R) (set-det))) -; + (= (vec-mult-vec $X $Y $R) + (maplist const-mult-const $X $Y $R) + (set-det)) - (= - (mat-mult-vec $M $V $R) - ( (maplist - (vec-mult-vec $V) $M $T) - (maplist sumlist $T $R) - (set-det))) -; + (= (mat-mult-const $M $C $R) + (maplist + (const-mult-vec $C) $M $R) + (set-det)) + (= (mat-mult-vec $M $V $R) + (maplist + (vec-mult-vec $V) $M $T) + (maplist sumlist $T $R) + (set-det)) - (= - (mat-mult-mat $X $Y $R) - ( (transpose $Y $T) - (maplist - (mat-mult-vec $T) $X $R) - (set-det))) -; + (= (mat-mult-mat $X $Y $R) + (transpose $Y $T) + (maplist + (mat-mult-vec $T) $X $R) + (set-det)) - (= - (mapmat $F $M $R) + (= (mapmat $F $M $R) (maplist (mapmatsub $F) $M $R)) -; - - - (= - (mapmatsub $F $V $R) - ( (maplist $F $V $R) (set-det))) -; +; /* mat_mult_mat(X,Y,R):- transpose(Y,T), maplist(mat_mult_vec(X),T,S), transpose(S,R), !. */ + (= (mapmatsub $F $V $R) + (maplist $F $V $R) + (set-det)) diff --git a/sldr_dl/nnet.metta b/sldr_dl/nnet.metta index 68d0c51..ffb9538 100644 --- a/sldr_dl/nnet.metta +++ b/sldr_dl/nnet.metta @@ -1,304 +1,201 @@ +; (convert_to_metta_file nnet $_20494 sldr_dl/nnet.pl sldr_dl/nnet.metta) !(:: (matrix *)) -; - ; -; - +; Randomise. ; -; - +; Seed. !(set-random (seed 777)) -; - ; -; - +; Vector. - (= - (rand-vector 0 $_ Nil) + (= (rand-vector 0 $_ Nil) + (set-det)) + (= (rand-vector $D (:: $A $B) (Cons $X $R)) + (is $D1 + (- $D 1)) + (random $P) + (is $X + (+ + (* $P + (- $B $A)) $A)) + (rand-vector $D1 + (:: $A $B) $R) (set-det)) -; - - (= - (rand-vector $D - (:: $A $B) - (Cons $X $R)) - ( (is $D1 - (- $D 1)) - (random $P) - (is $X - (+ - (* $P - (- $B $A)) $A)) - (rand-vector $D1 - (:: $A $B) $R) - (set-det))) -; - ; -; - +; Matrix. - (= - (rand-matrix 0 $_ $_ Nil) + (= (rand-matrix 0 $_ $_ Nil) + (set-det)) + (= (rand-matrix $P $Q (:: $A $B) (Cons $X $R)) + (is $P1 + (- $P 1)) + (rand-vector $Q + (:: $A $B) $X) + (rand-matrix $P1 $Q + (:: $A $B) $R) (set-det)) -; - - (= - (rand-matrix $P $Q - (:: $A $B) - (Cons $X $R)) - ( (is $P1 - (- $P 1)) - (rand-vector $Q - (:: $A $B) $X) - (rand-matrix $P1 $Q - (:: $A $B) $R) - (set-det))) -; - ; -; - +; Nnet constructor. !(dynamic (/ weight-matrix 2)) -; - !(dynamic (/ bias-vector 2)) -; - !(dynamic (/ activation 2)) -; - !(dynamic (/ layer-input 2)) -; - !(dynamic (/ layer-output 2)) -; - !(dynamic (/ layer-out-diff 2)) -; - !(dynamic (/ layer-in-diff 2)) -; - !(dynamic (/ layer-bias-grad 2)) -; - !(dynamic (/ layer-weight-grad 2)) -; - - (= - (layer-init $Name $InDim $OutDim $Act - (:: $S1 $S2)) - ( (remove-all-symbols &self + (= (layer-init $Name $InDim $OutDim $Act (:: $S1 $S2)) + ( (remove-all-atoms &self (weight_matrix $Name $_)) - (remove-all-symbols &self + (remove-all-atoms &self (bias_vector $Name $_)) - (remove-all-symbols &self + (remove-all-atoms &self (activation $Name $_)) (rand-matrix $OutDim $InDim (:: $S1 $S2) $W) - (add-symbol &self + (add-is-symbol &self (weight_matrix $Name $W)) (rand-vector $OutDim (:: $S1 $S2) $B) - (add-symbol &self + (add-is-symbol &self (bias_vector $Name $B)) - (add-symbol &self + (add-is-symbol &self (activation $Name $Act)) (print (:: layer $Name has been initialised)) (nl) (set-det))) -; - ; -; - +; Activation Function. ; -; - +; ReLU. - (= - (relu $X 0) - ( (< $X 0) (set-det))) -; - - (= - (relu $X 30) - ( (> $X 30) (set-det))) -; - - (= - (relu $X $X) + (= (relu $X 0) + (< $X 0) + (set-det)) + (= (relu $X 30) + (> $X 30) + (set-det)) + (= (relu $X $X) (set-det)) -; - - - - (= - (relu-diff $X 0) - ( (< $X 0) (set-det))) -; - (= - (relu-diff $X 0) - ( (> $X 30) (set-det))) -; - (= - (relu-diff $_ 1) + (= (relu-diff $X 0) + (< $X 0) + (set-det)) + (= (relu-diff $X 0) + (> $X 30) + (set-det)) + (= (relu-diff $_ 1) (set-det)) -; - !(discontiguous (/ vec-act 3)) -; - !(discontiguous (/ vec-act-diff 3)) -; - - - (= - (vec-act relu $V $R) - ( (maplist relu $V $R) (set-det))) -; + (= (vec-act relu $V $R) + (maplist relu $V $R) + (set-det)) - (= - (vec-act-diff relu $V $R) - ( (maplist relu-diff $V $R) (set-det))) -; - + (= (vec-act-diff relu $V $R) + (maplist relu-diff $V $R) + (set-det)) ; -; - - - (= - (exp $X $Y) - ( (is $Y - (exp $X)) (set-det))) -; +; Softmax. - - (= - (softmax-sub1 $A $X $Y) - ( (is $Y - (/ $X $A)) (set-det))) -; - - - (= - (softmax $V $R) - ( (maplist exp $V $P) - (sumlist $P $S) - (maplist - (softmax-sub1 $S) $P $R) - (set-det))) -; - - - - (= - (softmax-diff-sub $_ 1) + (= (exp $X $Y) + (is $Y + (exp $X)) (set-det)) -; + (= (softmax-sub1 $A $X $Y) + (is $Y + (/ $X $A)) + (set-det)) - (= - (softmax-diff $V $R) - ( (maplist softmax-diff-sub $V $R) (set-det))) -; + (= (softmax $V $R) + (maplist exp $V $P) + (sumlist $P $S) + (maplist + (softmax-sub1 $S) $P $R) + (set-det)) + (= (softmax-diff-sub $_ 1) + (set-det)) - (= - (vec-act softmax $V $R) - ( (softmax $V $R) (set-det))) -; + (= (softmax-diff $V $R) + (maplist softmax-diff-sub $V $R) + (set-det)) - (= - (vec-act-diff softmax $V $R) - ( (softmax-diff $V $R) (set-det))) -; + (= (vec-act softmax $V $R) + (softmax $V $R) + (set-det)) + (= (vec-act-diff softmax $V $R) + (softmax-diff $V $R) + (set-det)) ; -; - - - (= - (ce-sub1 $A $B $S) - ( (is $S - (- $A $B)) (set-det))) -; +; Cross-Entropy Loss. + (= (ce-sub1 $A $B $S) + (is $S + (- $A $B)) + (set-det)) - (= - (neg-t-ln-y $Y $T $R) - ( (is $R - (* - (* -1 $T) - (log $Y))) (set-det))) -; - - - (= - (ce-error $Y $T $E) - ( (maplist neg-t-ln-y $Y $T $P) - (sumlist $P $E) - (set-det))) -; - + (= (neg-t-ln-y $Y $T $R) + (is $R + (* + (* -1 $T) + (log $Y))) + (set-det)) - (= - (ce-diff $Y $T $D) - ( (maplist ce-sub1 $T $Y $D) (set-det))) -; + (= (ce-error $Y $T $E) + (maplist neg-t-ln-y $Y $T $P) + (sumlist $P $E) + (set-det)) + (= (ce-diff $Y $T $D) + (maplist ce-sub1 $T $Y $D) + (set-det)) ; -; +; Forward Computation. - - (= - (nnet-forward Nil $In $In) + (= (nnet-forward Nil $In $In) (set-det)) -; - - (= - (nnet-forward - (Cons $Name $LayerList) $In $Out) + (= (nnet-forward (Cons $Name $LayerList) $In $Out) ( (weight-matrix $Name $W) (bias-vector $Name $B) (activation $Name $Act) - (remove-all-symbols &self + (remove-all-atoms &self (layer_input $Name $_)) - (add-symbol &self + (add-is-symbol &self (layer_input $Name $In)) (transpose $In $InT) (mat-mult-mat $W $InT $X) @@ -307,45 +204,41 @@ (vec-add-vec $B) $XT $ZT) (maplist (vec-act $Act) $ZT $Y) - (remove-all-symbols &self + (remove-all-atoms &self (layer_output $Name $_)) - (add-symbol &self + (add-is-symbol &self (layer_output $Name $Y)) (nnet-forward $LayerList $Y $Out) (set-det))) -; - +; ; Y = Act(W * In + B) +; ;print(X),nl, +; ;print(ZT),nl, +; ;print(Y),nl, +; ; Go to the next layer ; -; - - - (= - (nnet-comp-error $LayerList $Tgt $Err $Diff) - ( (append $_ - (:: $Name) $LayerList) - (layer-output $Name $Y) - (maplist ce-error $Y $Tgt $ErrList) - (sumlist $ErrList $ErrTot) - (length $ErrList $NumData) - (is $Err - (/ $ErrTot $NumData)) - (maplist ce-diff $Y $Tgt $Diff) - (set-det))) -; - +; Error Computation. + + (= (nnet-comp-error $LayerList $Tgt $Err $Diff) + (append $_ + (:: $Name) $LayerList) + (layer-output $Name $Y) + (maplist ce-error $Y $Tgt $ErrList) + (sumlist $ErrList $ErrTot) + (length $ErrList $NumData) + (is $Err + (/ $ErrTot $NumData)) + (maplist ce-diff $Y $Tgt $Diff) + (set-det)) +; ;retractall(layer_out_diff(Name,_)), +; ;assert(layer_out_diff(Name,Diff)), ; -; - +; Backward Computation. - (= - (nnet-backward Nil $_ $_) + (= (nnet-backward Nil $_ $_) (set-det)) -; - - (= - (nnet-backward $LayerList $Diff $LRate) + (= (nnet-backward $LayerList $Diff $LRate) ( (append $L1 (:: $Name) $LayerList) (weight-matrix $Name $W) @@ -357,93 +250,81 @@ (maplist vec-mult-vec $Diff $ActDiff $BDiff) (transpose $BDiff $BDT) (maplist sumlist $BDT $BGrad) - (remove-all-symbols &self + (remove-all-atoms &self (layer_bias_grad $Name $_)) - (add-symbol &self + (add-is-symbol &self (layer_bias_grad $Name $BGrad)) (layer-input $Name $In) (mat-mult-mat $BDT $In $WGrad) - (remove-all-symbols &self + (remove-all-atoms &self (layer_weight_grad $Name $_)) - (add-symbol &self + (add-is-symbol &self (layer_weight_grad $Name $WGrad)) (mat-mult-mat $BDiff $W $InDiff) (nnet-backward $L1 $InDiff $LRate) (mat-mult-const $WGrad $LRate $DW) (mat-add-mat $W $DW $WNew) - (remove-all-symbols &self + (remove-all-atoms &self (weight_matrix $Name $_)) - (add-symbol &self + (add-is-symbol &self (weight_matrix $Name $WNew)) (vec-mult-const $BGrad $LRate $DB) (vec-add-vec $B $DB $BNew) - (remove-all-symbols &self + (remove-all-atoms &self (bias_vector $Name $_)) - (add-symbol &self + (add-is-symbol &self (bias_vector $Name $BNew)) (set-det))) -; - +; ; Next Layer. +; ; Update. - (= - (nnet-train $_ $_ $_ 0 $_) + (= (nnet-train $_ $_ $_ 0 $_) (set-det)) -; - - (= - (nnet-train $Nnet $In $Tgt $Iter $LRate) - ( (is $I1 - (- $Iter 1)) - (nnet-forward $Nnet $In $_) - (nnet-comp-error $Nnet $Tgt $Err $Diff) - (printerr $Err) - (nnet-backward $Nnet $Diff $LRate) - (nnet-train $Nnet $In $Tgt $I1 $LRate))) -; - - - - (= - (printerr $X) - ( (is $Y - (* $X 1000000)) - (round $Y $Z) - (is $R - (/ $Z 1000000)) - (print $R) - (nl) - (set-det))) -; - - - - (= - (try) - ( (= $NumHid 32) - (layer-init try1 4 $NumHid relu - (:: -0.2 0.2)) - (layer-init try2 $NumHid $NumHid relu - (:: -0.2 0.2)) - (layer-init try3 $NumHid $NumHid relu - (:: -0.2 0.2)) - (layer-init try4 $NumHid $NumHid relu - (:: -0.2 0.2)) - (layer-init try5 $NumHid $NumHid relu - (:: -0.2 0.2)) - (layer-init try6 $NumHid 5 softmax - (:: -0.2 0.2)) - (= $In - (:: - (:: 2 3 4 5) - (:: 6 7 8 9))) - (= $Tgt - (:: - (:: 0 1 0 0 0) - (:: 0 0 0 1 0))) - (= $Nnet - (:: try1 try2 try3 try4 try5 try6)) - (nnet-train $Nnet $In $Tgt 100 0.01))) -; - + (= (nnet-train $Nnet $In $Tgt $Iter $LRate) + (is $I1 + (- $Iter 1)) + (nnet-forward $Nnet $In $_) + (nnet-comp-error $Nnet $Tgt $Err $Diff) + (printerr $Err) + (nnet-backward $Nnet $Diff $LRate) + (nnet-train $Nnet $In $Tgt $I1 $LRate)) + + + (= (printerr $X) + (is $Y + (* $X 1000000)) + (round $Y $Z) + (is $R + (/ $Z 1000000)) + (print $R) + (nl) + (set-det)) + + + (= (try) + (= $NumHid 32) + (layer-init try1 4 $NumHid relu + (:: -0.2 0.2)) + (layer-init try2 $NumHid $NumHid relu + (:: -0.2 0.2)) + (layer-init try3 $NumHid $NumHid relu + (:: -0.2 0.2)) + (layer-init try4 $NumHid $NumHid relu + (:: -0.2 0.2)) + (layer-init try5 $NumHid $NumHid relu + (:: -0.2 0.2)) + (layer-init try6 $NumHid 5 softmax + (:: -0.2 0.2)) + (= $In + (:: + (:: 2 3 4 5) + (:: 6 7 8 9))) + (= $Tgt + (:: + (:: 0 1 0 0 0) + (:: 0 0 0 1 0))) + (= $Nnet + (:: try1 try2 try3 try4 try5 try6)) + (nnet-train $Nnet $In $Tgt 100 0.01)) diff --git a/sldr_dl/resolution.metta b/sldr_dl/resolution.metta index 9a83dd4..dc231b6 100644 --- a/sldr_dl/resolution.metta +++ b/sldr_dl/resolution.metta @@ -1,466 +1,316 @@ +; (convert_to_metta_file resolution $_192350 sldr_dl/resolution.pl sldr_dl/resolution.metta) !(:: (nnet *)) -; - - (= - (dnn-heuristic $Nnet $G $SList - (method $_ - (input $TreeBreadth $TreeDepth) $_) $Res) - ( (pred-to-vec $G $SList $TreeBreadth $TreeDepth $InVec) - (nnet-forward $Nnet - (:: $InVec) - (:: $OutVec)) - (label-vec $OutVec 1 $OVL) - (sort $OVL $OVLS) - (reverse $OVLS $Res) - (set-det))) -; - - - - - (= - (comp-indim $TreeBreadth $TreeDepth $NumWord $Dim) - ( (get-partial-tree a $TreeBreadth $TreeDepth $T) - (flatten $T $FT) - (length $FT $P) - (is $Dim - (* $P $NumWord)) - (set-det))) -; - + (= (dnn-heuristic $Nnet $G $SList (method $_ (input $TreeBreadth $TreeDepth) $_) $Res) + (pred-to-vec $G $SList $TreeBreadth $TreeDepth $InVec) + (nnet-forward $Nnet + (:: $InVec) + (:: $OutVec)) + (label-vec $OutVec 1 $OVL) + (sort $OVL $OVLS) + (reverse $OVLS $Res) + (set-det)) - (= - (pred-to-vec $Pred - (:: $SList $MaxN) $TreeBreadth $TreeDepth $Vec) - ( (copy-term $Pred $GT) - (vble-fill $GT $GTF) - (get-partial-tree $GTF $TreeBreadth $TreeDepth $PT) - (flatten $PT $PTF) - (symlist-to-numlist $PTF $SList $NL) - (numlist-to-vec $NL $MaxN $Vec) - (set-det))) -; + (= (comp-indim $TreeBreadth $TreeDepth $NumWord $Dim) + (get-partial-tree a $TreeBreadth $TreeDepth $T) + (flatten $T $FT) + (length $FT $P) + (is $Dim + (* $P $NumWord)) + (set-det)) - (= - (label-vec Nil $_ Nil) + (= (pred-to-vec $Pred (:: $SList $MaxN) $TreeBreadth $TreeDepth $Vec) + (copy-term $Pred $GT) + (vble-fill $GT $GTF) + (get-partial-tree $GTF $TreeBreadth $TreeDepth $PT) + (flatten $PT $PTF) + (symlist-to-numlist $PTF $SList $NL) + (numlist-to-vec $NL $MaxN $Vec) (set-det)) -; - (= - (label-vec - (Cons $Elem $L) $Num - (Cons - (:: $Elem $Num) $LT)) - ( (is $N1 - (+ $Num 1)) - (label-vec $L $N1 $LT) - (set-det))) -; + (= (label-vec Nil $_ Nil) + (set-det)) + (= (label-vec (Cons $Elem $L) $Num (Cons (:: $Elem $Num) $LT)) + (is $N1 + (+ $Num 1)) + (label-vec $L $N1 $LT) + (set-det)) - (= - (dnn-train $Nnet $G $SList $AxNum - (method - (learning $NumEpoch $LRate) - (input $TreeBreadth $TreeDepth) - (output $OutDim))) - ( (pred-to-vec $G $SList $TreeBreadth $TreeDepth $InVec) - (axnum-to-vec $AxNum $OutDim $TgtVec) - (nnet-train $Nnet - (:: $InVec) - (:: $TgtVec) $NumEpoch $LRate) - (set-det))) -; - + (= (dnn-train $Nnet $G $SList $AxNum (method (learning $NumEpoch $LRate) (input $TreeBreadth $TreeDepth) (output $OutDim))) + (pred-to-vec $G $SList $TreeBreadth $TreeDepth $InVec) + (axnum-to-vec $AxNum $OutDim $TgtVec) + (nnet-train $Nnet + (:: $InVec) + (:: $TgtVec) $NumEpoch $LRate) + (set-det)) - (= - (axnum-to-vec $AxNum $Dim $Vec) - ( (> $AxNum $Dim) - (print (:: 'Warning: AxNum is bigger than Dim: ' $AxNum $Dim)) - (nl) - (copy-n-times 0 $Dim $Vec) - (set-det))) -; - - - (= - (axnum-to-vec $AxNum $Dim $Vec) - ( (is $D1 - (- $AxNum 1)) - (copy-n-times 0 $D1 $Vec1) - (is $D2 - (- $Dim $AxNum)) - (copy-n-times 0 $D2 $Vec2) - (append $Vec1 - (Cons 1 $Vec2) $Vec) - (set-det))) -; + (= (axnum-to-vec $AxNum $Dim $Vec) + (> $AxNum $Dim) + (print (:: 'Warning: AxNum is bigger than Dim: ' $AxNum $Dim)) + (nl) + (copy-n-times 0 $Dim $Vec) + (set-det)) + (= (axnum-to-vec $AxNum $Dim $Vec) + (is $D1 + (- $AxNum 1)) + (copy-n-times 0 $D1 $Vec1) + (is $D2 + (- $Dim $AxNum)) + (copy-n-times 0 $D2 $Vec2) + (append $Vec1 + (Cons 1 $Vec2) $Vec) + (set-det)) !(dynamic (/ search-time 1)) -; + (= (init-search-time) + ( (remove-all-atoms &self + (search_time $_)) (add-is-symbol &self (search_time 0)))) - (= - (init-search-time) - ( (remove-all-symbols &self - (search_time $_)) (add-symbol &self (search_time 0)))) -; - - - (= - (add-search-time) + (= (add-search-time) ( (search-time $N) - (remove-all-symbols &self + (remove-all-atoms &self (search_time $_)) (is $N1 (+ $N 1)) - (add-symbol &self + (add-is-symbol &self (search_time $N1)) (set-det))) -; - - (= - (dnn-sl-resolution $A $B $C $D $E $F $G) + (= (dnn-sl-resolution $A $B $C $D $E $F $G) (dnn-sl-resolution $A $B $C standard $D $E $F $G)) -; - - - (= - (dnn_sl_resolution () $_ $_ $_ $_ $_ $_ ()) True) -; - - (= - (dnn-sl-resolution $GList - (:: $AList $NumA) $SList $StatModName $Nnet $Mtd $Depth $Path) - ( (> $Depth 0) - (is $D1 - (- $Depth 1)) - (= $GList - (Cons - (- $OrgG) $GLT)) - (copy-term $GList $PreGList) - (static-module $StatModName $OrgG $G) - (copy-term $G $GTemp) - (dnn-heuristic $Nnet $G $SList $Mtd $SAL) - (member - (:: $_ $AxNum) $SAL) - (member - (:: $AxNum $AxName $AxRule) $AList) - (add-search-time) - (copy-term $AxRule $Ax) - (append $GN - (:: (+ $G)) $Ax) - (append $GN $GLT $GListNew) - (dnn-sl-resolution $GListNew - (:: $AList $NumA) $SList $StatModName $Nnet $Mtd $D1 $PathNew) - (= $Path - (Cons - (:: $PreGList $AxName) $PathNew)) - (or - (, - (= $Mtd - (method - (learning $_ $_) $_ $_)) - (dnn-train $Nnet $GTemp $SList $AxNum $Mtd)) - (= $Mtd - (method reasoning $_ $_))))) -; + (= (dnn_sl_resolution () $_ $_ $_ $_ $_ $_ ()) True) + (= (dnn-sl-resolution $GList (:: $AList $NumA) $SList $StatModName $Nnet $Mtd $Depth $Path) + (> $Depth 0) + (is $D1 + (- $Depth 1)) + (= $GList + (Cons + (- $OrgG) $GLT)) + (copy-term $GList $PreGList) + (static-module $StatModName $OrgG $G) + (copy-term $G $GTemp) + (dnn-heuristic $Nnet $G $SList $Mtd $SAL) + (member + (:: $_ $AxNum) $SAL) + (member + (:: $AxNum $AxName $AxRule) $AList) + (add-search-time) + (copy-term $AxRule $Ax) + (append $GN + (:: (+ $G)) $Ax) + (append $GN $GLT $GListNew) + (dnn-sl-resolution $GListNew + (:: $AList $NumA) $SList $StatModName $Nnet $Mtd $D1 $PathNew) + (= $Path + (Cons + (:: $PreGList $AxName) $PathNew)) + (or + (, + (= $Mtd + (method + (learning $_ $_) $_ $_)) + (dnn-train $Nnet $GTemp $SList $AxNum $Mtd)) + (= $Mtd + (method reasoning $_ $_)))) +; ;SAL = AList, +; ;Ax = [+G|GN], - (= - (print_by_line ()) True) -; - - (= - (print-by-line (Cons $X $L)) - ( (print $X) - (nl) - (print-by-line $L))) -; - + (= (print_by_line ()) True) + (= (print-by-line (Cons $X $L)) + (print $X) + (nl) + (print-by-line $L)) !(dynamic (/ num-vble 1)) -; - - ! (remove-all-symbols &self + ! (remove-all-atoms &self (num_vble $_)) -; - - ! (add-symbol &self + ! (add-is-symbol &self (num_vble 0)) -; - - (= - (vble-fill $X $X) - ( (ground $X) (set-det))) -; - - (= - (vble-fill $X $X) + (= (vble-fill $X $X) + (ground $X) + (set-det)) + (= (vble-fill $X $X) ( (var $X) (num-vble $N1) (is $N (+ $N1 1)) - (remove-all-symbols &self + (remove-all-atoms &self (num_vble $_)) - (add-symbol &self + (add-is-symbol &self (num_vble $N)) (= $X (vble $N)) (set-det))) -; - - (= - (vble-fill Nil Nil) + (= (vble-fill Nil Nil) + (set-det)) + (= (vble-fill (Cons $X $L) (Cons $XT $LT)) + (vble-fill $X $XT) + (vble-fill $L $LT) (set-det)) -; - - (= - (vble-fill - (Cons $X $L) - (Cons $XT $LT)) - ( (vble-fill $X $XT) - (vble-fill $L $LT) - (set-det))) -; - - (= - (copy-n-times $_ 0 Nil) + (= (copy-n-times $_ 0 Nil) (set-det)) -; - - (= - (copy-n-times $X $N - (Cons $X $L)) - ( (> $N 0) - (is $N1 - (- $N 1)) - (copy-n-times $X $N1 $L) - (set-det))) -; - - - - (= - (produce-empty-tree $_ 0 novalue) + (= (copy-n-times $X $N (Cons $X $L)) + (> $N 0) + (is $N1 + (- $N 1)) + (copy-n-times $X $N1 $L) (set-det)) -; - - (= - (produce-empty-tree $B $D - (Cons novalue $L)) - ( (> $D 0) - (is $D1 - (- $D 1)) - (produce-empty-tree $B $D1 $Res1) - (copy-n-times $Res1 $B $L) - (set-det))) -; - - (= - (get-partial-tree - (Cons $X $_) $_ 0 $X) + (= (produce-empty-tree $_ 0 novalue) + (set-det)) + (= (produce-empty-tree $B $D (Cons novalue $L)) + (> $D 0) + (is $D1 + (- $D 1)) + (produce-empty-tree $B $D1 $Res1) + (copy-n-times $Res1 $B $L) (set-det)) -; - - (= - (get-partial-tree $X $_ 0 $X) - ( (not (is-list $X)) (set-det))) -; - - (= - (get-partial-tree - (Cons $X $L) $Breadth $Depth - (Cons $X $LT)) - ( (> $Depth 0) - (is $D1 - (- $Depth 1)) - (get-partial-tree2 $L $Breadth $D1 $LT) - (set-det))) -; - - (= - (get-partial-tree $X $Breadth $Depth - (Cons $X $LT)) - ( (not (is-list $X)) - (> $Depth 0) - (is $D1 - (- $Depth 1)) - (get-partial-tree2 Nil $Breadth $D1 $LT) - (set-det))) -; - - - (= - (get-partial-tree2 $L $Breadth $Depth $Res) - ( (findall $XT - (, - (member $X $L) - (get-partial-tree $X $Breadth $Depth $XT)) $Res1) - (length $L $LenL) - (length $XT $LenL) - (is $N1 - (- $Breadth $LenL)) - (or - (, - (>= $N1 0) - (produce-empty-tree $Breadth $Depth $TEmpty) - (copy-n-times $TEmpty $N1 $Res2) - (append $Res1 $Res2 $Res)) - (, - (< $N1 0) - (get-first-element $Res1 $Breadth $Res))) - (set-det))) -; + (= (get-partial-tree (Cons $X $_) $_ 0 $X) + (set-det)) + (= (get-partial-tree $X $_ 0 $X) + (not (is-list $X)) + (set-det)) + (= (get-partial-tree (Cons $X $L) $Breadth $Depth (Cons $X $LT)) + (> $Depth 0) + (is $D1 + (- $Depth 1)) + (get-partial-tree2 $L $Breadth $D1 $LT) + (set-det)) + (= (get-partial-tree $X $Breadth $Depth (Cons $X $LT)) + (not (is-list $X)) + (> $Depth 0) + (is $D1 + (- $Depth 1)) + (get-partial-tree2 Nil $Breadth $D1 $LT) + (set-det)) - (= - (get_first_element $_ 0 ()) True) -; + (= (get-partial-tree2 $L $Breadth $Depth $Res) + (findall $XT + (, + (member $X $L) + (get-partial-tree $X $Breadth $Depth $XT)) $Res1) + (length $L $LenL) + (length $XT $LenL) + (is $N1 + (- $Breadth $LenL)) + (or + (, + (>= $N1 0) + (produce-empty-tree $Breadth $Depth $TEmpty) + (copy-n-times $TEmpty $N1 $Res2) + (append $Res1 $Res2 $Res)) + (, + (< $N1 0) + (get-first-element $Res1 $Breadth $Res))) + (set-det)) +; ; Check if the lengths agree. - (= - (get-first-element Nil $N - (Cons norule $Res1)) - ( (> $N 0) - (is $N1 - (- $N 1)) - (get-first-element Nil $N1 $Res1))) -; - - (= - (get-first-element - (Cons $X $L) $N - (Cons $X $Res1)) - ( (> $N 0) - (is $N1 - (- $N 1)) - (get-first-element $L $N1 $Res1))) -; + (= (get_first_element $_ 0 ()) True) + (= (get-first-element Nil $N (Cons norule $Res1)) + (> $N 0) + (is $N1 + (- $N 1)) + (get-first-element Nil $N1 $Res1)) + (= (get-first-element (Cons $X $L) $N (Cons $X $Res1)) + (> $N 0) + (is $N1 + (- $N 1)) + (get-first-element $L $N1 $Res1)) - (= - (symlist-to-numlist Nil $_ Nil) + (= (symlist-to-numlist Nil $_ Nil) (set-det)) -; - - (= - (symlist-to-numlist - (Cons $X $L) $SList - (Cons $XT $LT)) - ( (or + (= (symlist-to-numlist (Cons $X $L) $SList (Cons $XT $LT)) + (or + (, + (= $X + (vble $_)) + (= $XT 1)) + (or (, - (= $X - (vble $_)) - (= $XT 1)) - (or - (, - (= $X novalue) - (= $XT -1)) - (member - (:: $XT $X) $SList))) - (symlist-to-numlist $L $SList $LT) - (set-det))) -; - - - - (= - (num-to-vec -1 $Dim $Vec) - ( (copy-n-times 0 $Dim $Vec) (set-det))) -; - - (= - (num-to-vec $Num $Dim $Vec) - ( (> $Num $Dim) - (print (:: 'Warning: Num is bigger than Dim: ' $Num $Dim)) - (nl) - (copy-n-times 0 $Dim $Vec) - (set-det))) -; - - - (= - (num-to-vec $Num $Dim $Vec) - ( (is $D1 - (- $Num 1)) - (copy-n-times 0 $D1 $Vec1) - (is $D2 - (- $Dim $Num)) - (copy-n-times 0 $D2 $Vec2) - (append $Vec1 - (Cons 1 $Vec2) $Vec) - (set-det))) -; - - + (= $X novalue) + (= $XT -1)) + (member + (:: $XT $X) $SList))) + (symlist-to-numlist $L $SList $LT) + (set-det)) + (= (num-to-vec -1 $Dim $Vec) + (copy-n-times 0 $Dim $Vec) + (set-det)) + (= (num-to-vec $Num $Dim $Vec) + (> $Num $Dim) + (print (:: 'Warning: Num is bigger than Dim: ' $Num $Dim)) + (nl) + (copy-n-times 0 $Dim $Vec) + (set-det)) - (= - (numlist-to-vec Nil $_ Nil) + (= (num-to-vec $Num $Dim $Vec) + (is $D1 + (- $Num 1)) + (copy-n-times 0 $D1 $Vec1) + (is $D2 + (- $Dim $Num)) + (copy-n-times 0 $D2 $Vec2) + (append $Vec1 + (Cons 1 $Vec2) $Vec) (set-det)) -; - - (= - (numlist-to-vec - (Cons $X $L) $Dim $Res) - ( (num-to-vec $X $Dim $XT) - (numlist-to-vec $L $Dim $LT) - (append $XT $LT $Res) - (set-det))) -; - (= - (for $K $P $Q) - ( (=< $P $Q) (= $K $P))) -; - (= - (for $K $P $Q) - ( (< $P $Q) - (is $P1 - (+ $P 1)) - (for $K $P1 $Q))) -; + (= (numlist-to-vec Nil $_ Nil) + (set-det)) + (= (numlist-to-vec (Cons $X $L) $Dim $Res) + (num-to-vec $X $Dim $XT) + (numlist-to-vec $L $Dim $LT) + (append $XT $LT $Res) + (set-det)) + (= (for $K $P $Q) + (=< $P $Q) + (= $K $P)) + (= (for $K $P $Q) + (< $P $Q) + (is $P1 + (+ $P 1)) + (for $K $P1 $Q)) - (= - (static_module standard $G $G) True) -; + (= (static_module standard $G $G) True) diff --git a/sldr_dl/yap_compat.metta b/sldr_dl/yap_compat.metta index f7a810d..93cd281 100644 --- a/sldr_dl/yap_compat.metta +++ b/sldr_dl/yap_compat.metta @@ -1,26 +1,17 @@ +; (convert_to_metta_file yap_compat $_386360 sldr_dl/yap_compat.pl sldr_dl/yap_compat.metta) ; -; +; :- statistics( walltime, [X,Y]), XY is X+Y, srandom(X),!. - - (= - (random $X) + (= (random $X) (is $X random)) -; - !(use-module (library random)) -; - !(use-module (library lists)) -; - - (= - (round $X $Y) + (= (round $X $Y) (= $Y (round $X))) -; - +; /*flatten([], []). flatten([H|T], M) :- flatten(H, Hf), flatten(T, Tf), append(Hf, Tf, M).*/ diff --git a/sre_dna/ccs_utils.metta b/sre_dna/ccs_utils.metta index 0ea0e44..541d255 100644 --- a/sre_dna/ccs_utils.metta +++ b/sre_dna/ccs_utils.metta @@ -1,61 +1,27 @@ +; (convert_to_metta_file ccs_utils $_453856 sre_dna/ccs_utils.pl sre_dna/ccs_utils.metta) - (= - (trace-append $R $S $T) + (= (trace-append $R $S $T) (tappend $R $S $T)) -; - - (= - (trace-append $R $S $T) + (= (trace-append $R $S $T) (tappend $S $R $T)) -; - - - (= - (tappend () $X $X) True) -; - (= - (tappend - (Cons $A $R) - (Cons $B $S) $T) - ( (opposite $A $B) - (set-det) - (trace-append $R $S $T))) -; - - (= - (tappend - (Cons $A $R) - (Cons $B $S) - (Cons $A $T)) + (= (tappend () $X $X) True) + (= (tappend (Cons $A $R) (Cons $B $S) $T) + (opposite $A $B) + (set-det) + (trace-append $R $S $T)) + (= (tappend (Cons $A $R) (Cons $B $S) (Cons $A $T)) (trace-append $R (Cons $B $S) $T)) -; - - (= - (opposite $X - (- $X)) True) -; + (= (opposite $X (- $X)) True) + (= (opposite (- $X) $X) True) - (= - (opposite - (- $X) $X) True) -; - - - (= - (stripped - (- $A) $A) + (= (stripped (- $A) $A) (set-det)) -; - - (= - (stripped $A $A) True) -; - + (= (stripped $A $A) True) diff --git a/sre_dna/compile.metta b/sre_dna/compile.metta index c84429b..532676f 100644 --- a/sre_dna/compile.metta +++ b/sre_dna/compile.metta @@ -1,143 +1,39 @@ +; (convert_to_metta_file compile $_19512 sre_dna/compile.pl sre_dna/compile.metta) - (= - (?- - (use_module - (library random))) True) -; + (= (?- (use_module (library random))) True) + (= (?- (use_module (library system))) True) + (= (?- (use_module (library lists))) True) - (= - (?- - (use_module - (library system))) True) -; + (= (?- (compile dynamics)) True) + (= (?- (consult dctg)) True) + (= (?- (consult parameters_P)) True) + (= (?- (compile operators)) True) + (= (?- (consult dctg_pp)) True) + (= (?- (compile utils)) True) - (= - (?- - (use_module - (library lists))) True) -; - - - (= - (?- - (compile dynamics)) True) -; - - (= - (?- - (consult dctg)) True) -; - - (= - (?- - (consult parameters_P)) True) -; - - (= - (?- - (compile operators)) True) -; - - (= - (?- - (consult dctg_pp)) True) -; - - (= - (?- - (compile utils)) True) -; - - - (= - (?- - (, - (dctg_file_P $FileDCTG) - (, - (grammar $FileDCTG) make_grammar_table))) True) -; - - (= - (?- - (, - (tell compile_file.pl) - (, - (write ' + (= (?- (, (dctg_file_P $FileDCTG) (, (grammar $FileDCTG) make_grammar_table))) True) + (= (?- (, (tell compile_file.pl) (, (write ' ?- use_module(library(lists)). - ') - (, nl - (, listing told))))) True) -; - - - (= - (?- - (compile ccs_utils)) True) -; - - (= - (?- - (compile dctg_gen)) True) -; - - (= - (?- - (compile dctg_reprod)) True) -; - - (= - (?- - (compile dctg_utils)) True) -; - - (= - (?- - (compile generate)) True) -; - - (= - (?- - (compile gp_engine)) True) -; - - (= - (?- - (compile lamarckian)) True) -; - - (= - (?- - (compile evaluation)) True) -; - - (= - (?- - (compile file_stats)) True) -; - + ') (, nl (, listing told))))) True) +; ; fast: new + + (= (?- (compile ccs_utils)) True) + (= (?- (compile dctg_gen)) True) + (= (?- (compile dctg_reprod)) True) + (= (?- (compile dctg_utils)) True) + (= (?- (compile generate)) True) + (= (?- (compile gp_engine)) True) + (= (?- (compile lamarckian)) True) + (= (?- (compile evaluation)) True) + (= (?- (compile file_stats)) True) ; -; - - - (= - (?- - (, - (fitness_func_P $File) - (compile $File))) True) -; - - - (= - (?- - (: fast - (compile compile_file.pl))) True) -; +; following must follow 'parameters_P' above. - (= - (?- clean_up) True) -; + (= (?- (, (fitness_func_P $File) (compile $File))) True) + (= (?- (: fast (compile compile_file.pl))) True) + (= (?- clean_up) True) diff --git a/sre_dna/compile_file_ex.metta b/sre_dna/compile_file_ex.metta index 6e87f99..9bceada 100644 --- a/sre_dna/compile_file_ex.metta +++ b/sre_dna/compile_file_ex.metta @@ -1,392 +1,218 @@ - (= - (?- - (use_module - (library lists))) True) -; - +; (convert_to_metta_file compile_file_ex $_79652 sre_dna/compile_file_ex.pl sre_dna/compile_file_ex.metta) + (= (?- (use_module (library lists))) True) !(op 650 yfx ^^) -; - !(op 601 xfy :) -; - !(op 1150 xfx ::=) -; - !(op 1175 xfx <:>) -; - !(op 1150 xfx ::-) -; - - (= - (guardedexpr-a - (node guardedexpr-a - (:: (:: a)) 8) $A $B) + (= (guardedexpr-a (node guardedexpr-a (:: (:: a)) 8) $A $B) (c $A a $B)) -; + (= (guardedexpr-a (node guardedexpr-a (:: (:: a) $A) 9) $B $C) + (c $B a $D) + (expr $A $D $C)) - (= - (guardedexpr-a - (node guardedexpr-a - (:: - (:: a) $A) 9) $B $C) - ( (c $B a $D) (expr $A $D $C))) -; + (= (char $A $B) + (integer $A) + (< $A 256) + (set-det) + (name $B + (:: $A))) - (= - (char $A $B) - ( (integer $A) - (< $A 256) - (set-det) - (name $B - (:: $A)))) -; - - - - (= - (c - (Cons $A $B) $A $B) True) -; - - - - (= - (dctg_rule_info guardedexpr_b 11 - (guardedexpr_b - (node $_ $_ 11) $_ $_) 3 nonterminal) True) -; - - (= - (dctg_rule_info guardedexpr_a 9 - (guardedexpr_a - (node $_ $_ 9) $_ $_) 3 nonterminal) True) -; - - (= - (dctg_rule_info noniter_expr 5 - (noniter_expr - (node $_ $_ 5) $_ $_) 3 nonterminal) True) -; - - (= - (dctg_rule_info expr 0 - (expr - (node $_ $_ 0) $_ $_) 3 nonterminal) True) -; - - (= - (dctg_rule_info expr 1 - (expr - (node $_ $_ 1) $_ $_) 2 nonterminal) True) -; - - (= - (dctg_rule_info noniter_expr 4 - (noniter_expr - (node $_ $_ 4) $_ $_) 2 nonterminal) True) -; - - (= - (dctg_rule_info iter_expr 6 - (iter_expr - (node $_ $_ 6) $_ $_) 2 nonterminal) True) -; - - (= - (dctg_rule_info iter_expr 7 - (iter_expr - (node $_ $_ 7) $_ $_) 2 nonterminal) True) -; - - (= - (dctg_rule_info probval 13 - (probval - (node $_ $_ 13) $_ $_) 1 terminal) True) -; - - (= - (dctg_rule_info intval 12 - (intval - (node $_ $_ 12) $_ $_) 1 terminal) True) -; - - (= - (dctg_rule_info guardedexpr_b 10 - (guardedexpr_b - (node $_ $_ 10) $_ $_) 1 terminal) True) -; - - (= - (dctg_rule_info guardedexpr_a 8 - (guardedexpr_a - (node $_ $_ 8) $_ $_) 1 terminal) True) -; - - (= - (dctg_rule_info noniter_expr 3 - (noniter_expr - (node $_ $_ 3) $_ $_) 1 terminal) True) -; - - (= - (dctg_rule_info noniter_expr 2 - (noniter_expr - (node $_ $_ 2) $_ $_) 1 terminal) True) -; - - - - (= - (library_directory 'c:/program files/sicstus prolog/library') True) -; - - - - (= - (sre-pp-l (:: $A)) - ( (sre-pp $A) (set-det))) -; - - (= - (sre-pp-l (Cons $A $B)) - ( (write [) - (sre-pp $A) - (write +) - (sre-pp-l $B) - (write ]) - (set-det))) -; + (= (c (Cons $A $B) $A $B) True) + (= (dctg_rule_info guardedexpr_b 11 (guardedexpr_b (node $_ $_ 11) $_ $_) 3 nonterminal) True) + (= (dctg_rule_info guardedexpr_a 9 (guardedexpr_a (node $_ $_ 9) $_ $_) 3 nonterminal) True) + (= (dctg_rule_info noniter_expr 5 (noniter_expr (node $_ $_ 5) $_ $_) 3 nonterminal) True) + (= (dctg_rule_info expr 0 (expr (node $_ $_ 0) $_ $_) 3 nonterminal) True) + (= (dctg_rule_info expr 1 (expr (node $_ $_ 1) $_ $_) 2 nonterminal) True) + (= (dctg_rule_info noniter_expr 4 (noniter_expr (node $_ $_ 4) $_ $_) 2 nonterminal) True) + (= (dctg_rule_info iter_expr 6 (iter_expr (node $_ $_ 6) $_ $_) 2 nonterminal) True) + (= (dctg_rule_info iter_expr 7 (iter_expr (node $_ $_ 7) $_ $_) 2 nonterminal) True) + (= (dctg_rule_info probval 13 (probval (node $_ $_ 13) $_ $_) 1 terminal) True) + (= (dctg_rule_info intval 12 (intval (node $_ $_ 12) $_ $_) 1 terminal) True) + (= (dctg_rule_info guardedexpr_b 10 (guardedexpr_b (node $_ $_ 10) $_ $_) 1 terminal) True) + (= (dctg_rule_info guardedexpr_a 8 (guardedexpr_a (node $_ $_ 8) $_ $_) 1 terminal) True) + (= (dctg_rule_info noniter_expr 3 (noniter_expr (node $_ $_ 3) $_ $_) 1 terminal) True) + (= (dctg_rule_info noniter_expr 2 (noniter_expr (node $_ $_ 2) $_ $_) 1 terminal) True) - (= - (sre2b $A) - ( (generate-tree expr grow 8 $_ $B $_) - (^^ $B - (construct $C)) - (^^ $B - (recognize $A $D 1.0 $E)) - (nl) - (sre-pp $C) - (nl) - (write 'Prob = ') - (write $E) - (nl) - (write 'Leftover = ') - (write $D) - (nl))) -; + (= (library_directory 'c:/program files/sicstus prolog/library') True) - (= - (sre2c $A $B $C) - ( (repeat) - (or - (= $A full) - (= $A grow)) - (generate-tree expr $A 12 $_ $D $_) - (^^ $D - (construct $B)) - (nl) - (write $A) - (nl) - (sre-pp $B) - (nl) - (bagof $E - (^^ $D - (recognize $C Nil 1.0 $E)) $F) - (write 'Pr list: ') - (nl) - (writelist $F) - (nl))) -; - - - - (= - (sre2 $A $B $C) - ( (repeat) - (or - (= $A full) - (= $A grow)) - (generate-tree expr $A 12 $_ $D $_) - (^^ $D - (construct $B)) - (nl) - (write $A) - (nl) - (sre-pp $B) - (nl) - (bagof - (, $E $F) - (^^ $D - (recognize $C $E 1.0 $F)) $G) - (write 'Recog list: ') - (nl) - (writelist $G) - (nl))) -; - - - - (= - (sre-pp (* $A $B)) - ( (write () - (sre-pp $A) - (write )*) - (write $B) - (set-det))) -; - - (= - (sre-pp (+ $A $B)) - ( (write () - (sre-pp $A) - (write )+) - (write $B) - (set-det))) -; + (= (sre-pp-l (:: $A)) + (sre-pp $A) + (set-det)) + (= (sre-pp-l (Cons $A $B)) + (write [) + (sre-pp $A) + (write +) + (sre-pp-l $B) + (write ]) + (set-det)) - (= - (sre-pp (with_self $A $B)) - ( (sre-pp $A) - (write :) - (sre-pp $B) - (set-det))) -; - - (= - (sre-pp (Cons $A $B)) - ( (sre-pp-l (Cons $A $B)) (set-det))) -; - - (= - (sre-pp (, $A $B)) - ( (write () - (sre-pp $A) - (write ,) - (write $B) - (write )) - (set-det))) -; - (= - (sre-pp $A) + (= (sre2b $A) + (generate-tree expr grow 8 $_ $B $_) + (^^ $B + (construct $C)) + (^^ $B + (recognize $A $D 1.0 $E)) + (nl) + (sre-pp $C) + (nl) + (write 'Prob = ') + (write $E) + (nl) + (write 'Leftover = ') + (write $D) + (nl)) + + + (= (sre2c $A $B $C) + (repeat) + (or + (= $A full) + (= $A grow)) + (generate-tree expr $A 12 $_ $D $_) + (^^ $D + (construct $B)) + (nl) + (write $A) + (nl) + (sre-pp $B) + (nl) + (bagof $E + (^^ $D + (recognize $C Nil 1.0 $E)) $F) + (write 'Pr list: ') + (nl) + (writelist $F) + (nl)) + + + (= (sre2 $A $B $C) + (repeat) + (or + (= $A full) + (= $A grow)) + (generate-tree expr $A 12 $_ $D $_) + (^^ $D + (construct $B)) + (nl) + (write $A) + (nl) + (sre-pp $B) + (nl) + (bagof + (, $E $F) + (^^ $D + (recognize $C $E 1.0 $F)) $G) + (write 'Recog list: ') + (nl) + (writelist $G) + (nl)) + + + (= (sre-pp (* $A $B)) + (write () + (sre-pp $A) + (write )*) + (write $B) + (set-det)) + (= (sre-pp (+ $A $B)) + (write () + (sre-pp $A) + (write )+) + (write $B) + (set-det)) + (= (sre-pp (with_self $A $B)) + (sre-pp $A) + (write :) + (sre-pp $B) + (set-det)) + (= (sre-pp (Cons $A $B)) + (sre-pp-l (Cons $A $B)) + (set-det)) + (= (sre-pp (, $A $B)) + (write () + (sre-pp $A) + (write ,) + (write $B) + (write )) + (set-det)) + (= (sre-pp $A) (write $A)) -; - - (= - (select-kth-term - (:: $A) $_ $B $B $A) + (= (select-kth-term (:: $A) $_ $B $B $A) (set-det)) -; - - (= - (select-kth-term - (Cons $A $_) $B $C $C $A) - ( (>= $A $B) (set-det))) -; - - (= - (select-kth-term - (Cons $_ $A) $B $C $D $E) - ( (is $F - (+ $C 1)) (select-kth-term $A $B $F $D $E))) -; - - - - (= - (sumlist () () $A $A) True) -; - - (= - (sumlist - (Cons $A $B) - (Cons $C $D) $E $F) - ( (is $C - (+ $E $A)) (sumlist $B $D $C $F))) -; - + (= (select-kth-term (Cons $A $_) $B $C $C $A) + (>= $A $B) + (set-det)) + (= (select-kth-term (Cons $_ $A) $B $C $D $E) + (is $F + (+ $C 1)) + (select-kth-term $A $B $F $D $E)) - (= - (int_range 0 1000) True) -; + (= (sumlist () () $A $A) True) + (= (sumlist (Cons $A $B) (Cons $C $D) $E $F) + (is $C + (+ $E $A)) + (sumlist $B $D $C $F)) + (= (int_range 0 1000) True) - (= - (is-a-probability $A) - ( (float $A) (set-det))) -; - (= - (is-a-probability $A) + (= (is-a-probability $A) + (float $A) + (set-det)) + (= (is-a-probability $A) ( (with_self (random *) (random $B)) (is $A (/ (truncate (* $B 100)) 100)))) -; - - (= - (is-an-integer $A) - ( (integer $A) (set-det))) -; - - (= - (is-an-integer $A) + (= (is-an-integer $A) + (integer $A) + (set-det)) + (= (is-an-integer $A) ( (int-range $B $C) (with_self (random *) (random $B $C $A)))) -; - - (= - (recognize-loop $_ $A Nil Nil $B $C) - ( (set-det) - (is $C - (* $B - (- 1.0 $A))) - (check-prob $C))) -; - - (= - (recognize-loop $_ $A $B $B $C $D) - ( (is $D - (* $C - (- 1.0 $A))) (check-prob $D))) -; - - (= - (recognize-loop $A $B $C $D $E $F) - ( (is $G - (* $E $B)) - (check-prob $G) - (^^ $A - (recognize $C $H $G $I)) - (not (= $C $H)) - (check-prob $I) - (recognize-loop $A $B $H $D $I $F))) -; - - - - (= - (raw-gen-loop $A $B $C $D $E $F) + (= (recognize-loop $_ $A Nil Nil $B $C) + (set-det) + (is $C + (* $B + (- 1.0 $A))) + (check-prob $C)) + (= (recognize-loop $_ $A $B $B $C $D) + (is $D + (* $C + (- 1.0 $A))) + (check-prob $D)) + (= (recognize-loop $A $B $C $D $E $F) + (is $G + (* $E $B)) + (check-prob $G) + (^^ $A + (recognize $C $H $G $I)) + (not (= $C $H)) + (check-prob $I) + (recognize-loop $A $B $H $D $I $F)) + + + (= (raw-gen-loop $A $B $C $D $E $F) ( (< $E $C) (maybe $B) (^^ $A @@ -396,241 +222,134 @@ (lists *) (append $G $I $D)) (set-det))) -; - - (= - (raw-gen-loop $_ $_ $_ Nil $A $A) + (= (raw-gen-loop $_ $_ $_ Nil $A $A) (set-det)) -; + (= (probval (node probval (:: (:: $A)) 13) $B $C) + (c $B $A $C) + (is-a-probability $A)) - (= - (probval - (node probval - (:: (:: $A)) 13) $B $C) - ( (c $B $A $C) (is-a-probability $A))) -; - - - (= - (raw-select-term $A $B) + (= (raw-select-term $A $B) ( (sumlist $A $C 0 $D) (with_self (random *) (random 0 $D $E)) (select-kth-term $C $E 1 $B $_) (set-det))) -; - - (= - (guardedexpr-b - (node guardedexpr-b - (:: (:: b)) 10) $A $B) + (= (guardedexpr-b (node guardedexpr-b (:: (:: b)) 10) $A $B) (c $A b $B)) -; - - (= - (guardedexpr-b - (node guardedexpr-b - (:: - (:: b) $A) 11) $B $C) - ( (c $B b $D) (expr $A $D $C))) -; + (= (guardedexpr-b (node guardedexpr-b (:: (:: b) $A) 11) $B $C) + (c $B b $D) + (expr $A $D $C)) + (= (intval (node intval (:: (:: $A)) 12) $B $C) + (c $B $A $C) + (is-an-integer $A)) - (= - (intval - (node intval - (:: (:: $A)) 12) $B $C) - ( (c $B $A $C) (is-an-integer $A))) -; - - - (= - (noniter-expr - (node noniter-expr - (:: (:: a)) 2) $A $B) + (= (noniter-expr (node noniter-expr (:: (:: a)) 2) $A $B) (c $A a $B)) -; - - (= - (noniter-expr - (node noniter-expr - (:: (:: b)) 3) $A $B) + (= (noniter-expr (node noniter-expr (:: (:: b)) 3) $A $B) (c $A b $B)) -; - - (= - (noniter-expr - (node noniter-expr - (:: $A $B $C $D) 4) $E $F) - ( (guardedexpr-a $A $E $G) - (intval $B $G $H) - (guardedexpr-b $C $H $I) - (intval $D $I $F))) -; - - (= - (noniter-expr - (node noniter-expr - (:: $A $B) 5) $C $D) - ( (expr $A $C $E) (expr $B $E $D))) -; - - - - (= - (check-prob $A) - ( (min-grammar-prob-P $B) - (> $A $B) - (set-det))) -; - - - - (= - (iter-expr - (node iter-expr - (:: $A $B) 6) $C $D) - ( (noniter-expr $A $C $E) (probval $B $E $D))) -; - - (= - (iter-expr - (node iter-expr - (:: $A $B) 7) $C $D) - ( (noniter-expr $A $C $E) (probval $B $E $D))) -; - + (= (noniter-expr (node noniter-expr (:: $A $B $C $D) 4) $E $F) + (guardedexpr-a $A $E $G) + (intval $B $G $H) + (guardedexpr-b $C $H $I) + (intval $D $I $F)) + (= (noniter-expr (node noniter-expr (:: $A $B) 5) $C $D) + (expr $A $C $E) + (expr $B $E $D)) + + + (= (check-prob $A) + (min-grammar-prob-P $B) + (> $A $B) + (set-det)) - (= - (identify_type () () ()) True) -; + (= (iter-expr (node iter-expr (:: $A $B) 6) $C $D) + (noniter-expr $A $C $E) + (probval $B $E $D)) + (= (iter-expr (node iter-expr (:: $A $B) 7) $C $D) + (noniter-expr $A $C $E) + (probval $B $E $D)) - (= - (identify-type - (Cons $A $B) - (Cons $A $C) $D) - ( (dctg-rule-info $_ $A $_ $_ terminal) - (set-det) - (identify-type $B $C $D))) -; - (= - (identify-type - (Cons $A $B) $C - (Cons $A $D)) + (= (identify_type () () ()) True) + (= (identify-type (Cons $A $B) (Cons $A $C) $D) + (dctg-rule-info $_ $A $_ $_ terminal) + (set-det) + (identify-type $B $C $D)) + (= (identify-type (Cons $A $B) $C (Cons $A $D)) (identify-type $B $C $D)) -; - - (= - (get-rule-stuff $A $B) - ( (get-symbols &self + (= (get-rule-stuff $A $B) + ( (== (= - (semantic_rule $B $_ $C $_) $_)) (=.. $C (Cons $A $_)))) -; + (semantic_rule $B $_ $C $_) $_) + (get-atoms &self)) (=.. $C (Cons $A $_)))) - - (= - (make-id-entries Nil) + (= (make-id-entries Nil) (set-det)) -; - - (= - (make-id-entries (Cons (, $A $B) $C)) - ( (add-symbol &self + (= (make-id-entries (Cons (, $A $B) $C)) + ( (add-is-symbol &self (dctg_id_table $A $B $_ $_)) (make-id-entries $C) (set-det))) -; + (= (make-rule-id-list2 $A $B) + (bagof $C + (get-rule-stuff $A $C) $D) + (rem-dups $D $B)) - (= - (make-rule-id-list2 $A $B) - ( (bagof $C - (get-rule-stuff $A $C) $D) (rem-dups $D $B))) -; - - - - (= - (same-goal $A $B) - ( (=.. $A - (Cons $C $_)) - (=.. $B - (Cons $C $_)) - (set-det))) -; + (= (same-goal $A $B) + (=.. $A + (Cons $C $_)) + (=.. $B + (Cons $C $_)) + (set-det)) - (= - (abstract-member2 $A - (Cons $B $_)) + (= (abstract-member2 $A (Cons $B $_)) (same-goal $A $B)) -; - - (= - (abstract-member2 $A - (Cons $_ $B)) + (= (abstract-member2 $A (Cons $_ $B)) (abstract-member2 $A $B)) -; - - - - (= - (goal-type $A $B $_ $C $D $E $C $D - (Cons $A $E)) - ( (det-if-then-else - (= $B - (, $F $_)) True - (= $B $F)) - (or - (abstract-member2 $F $E) - (same-goal $A $F)) - (set-det))) -; - - (= - (goal-type $A $B $C $D $E $F - (Cons $A $D) $E $F) - ( (det-if-then-else - (= $B - (, $G $_)) True - (= $B $G)) - (or - (abstract-member2 $G $D) - (abstract-member2 $G $C)) - (set-det))) -; - (= - (goal-type $A - (, $_ $B) $C $D $E $F $G $H $I) - ( (set-det) (goal-type $A $B $C $D $E $F $G $H $I))) -; - - (= - (goal_type $A $_ $_ $B $C $D $B - (Cons $A $C) $D) True) -; + (= (goal-type $A $B $_ $C $D $E $C $D (Cons $A $E)) + (det-if-then-else + (= $B + (, $F $_)) True + (= $B $F)) + (or + (abstract-member2 $F $E) + (same-goal $A $F)) + (set-det)) + (= (goal-type $A $B $C $D $E $F (Cons $A $D) $E $F) + (det-if-then-else + (= $B + (, $G $_)) True + (= $B $G)) + (or + (abstract-member2 $G $D) + (abstract-member2 $G $C)) + (set-det)) + (= (goal-type $A (, $_ $B) $C $D $E $F $G $H $I) + (set-det) + (goal-type $A $B $C $D $E $F $G $H $I)) + (= (goal_type $A $_ $_ $B $C $D $B (Cons $A $C) $D) True) - (= - (user-override $A $B $C - (Cons $A $B) $C) + (= (user-override $A $B $C (Cons $A $B) $C) ( (=.. $A (Cons $D $_)) (dctg-override-P $E $_) @@ -638,11 +357,7 @@ (lists *) (member $D $E)) (set-det))) -; - - (= - (user-override $A $B $C $B - (Cons $A $C)) + (= (user-override $A $B $C $B (Cons $A $C)) ( (=.. $A (Cons $D $_)) (dctg-override-P $_ $E) @@ -650,169 +365,99 @@ (lists *) (member $D $E)) (set-det))) -; - - (= - (grammar-type-loop Nil $A $B $C $A $B $C) + (= (grammar-type-loop Nil $A $B $C $A $B $C) (set-det)) -; - - (= - (grammar-type-loop - (Cons $A $B) $C $D $E $F $G $H) - ( (user-override $A $D $E $I $J) (grammar-type-loop $B $C $I $J $F $G $H))) -; - - (= - (grammar-type-loop - (Cons $A $B) $C $D $E $F $G $H) + (= (grammar-type-loop (Cons $A $B) $C $D $E $F $G $H) + (user-override $A $D $E $I $J) + (grammar-type-loop $B $C $I $J $F $G $H)) + (= (grammar-type-loop (Cons $A $B) $C $D $E $F $G $H) ( (copy-term $A $I) - (get-symbols &self - (= $I $J)) + (== + (= $I $J) + (get-atoms &self)) (goal-type $A $J $B $C $D $E $K $L $M) (grammar-type-loop $B $K $L $M $F $G $H))) -; - - - (= - (find_minimum_depth $_ () $A $A) True) -; - - (= - (find-minimum-depth $A - (Cons - (, $B $C) $D) $E $F) - ( (=.. $B - (Cons $A $_)) - (is $G - (min $C $E)) - (find-minimum-depth $A $D $G $F) - (set-det))) -; - - (= - (find-minimum-depth $A - (Cons $_ $B) $C $D) - ( (find-minimum-depth $A $B $C $D) (set-det))) -; + (= (find_minimum_depth $_ () $A $A) True) + (= (find-minimum-depth $A (Cons (, $B $C) $D) $E $F) + (=.. $B + (Cons $A $_)) + (is $G + (min $C $E)) + (find-minimum-depth $A $D $G $F) + (set-det)) + (= (find-minimum-depth $A (Cons $_ $B) $C $D) + (find-minimum-depth $A $B $C $D) + (set-det)) - (= - (abstract-member $A - (Cons - (, $B $_) $_)) + (= (abstract-member $A (Cons (, $B $_) $_)) (=.. $B (Cons $A $_))) -; - - (= - (abstract-member $A - (Cons $_ $B)) + (= (abstract-member $A (Cons $_ $B)) (abstract-member $A $B)) -; - - (= - (find-min-depth $A - (Cons - (, $B $C) $_) $C) - ( (=.. $A - (Cons $B $_)) (set-det))) -; - - (= - (find-min-depth $A - (Cons $_ $B) $C) - ( (find-min-depth $A $B $C) (set-det))) -; - - - - (= - (is-a-rule-call $A) - ( (=.. $A - (Cons $B $_)) - (dctg-id-table $B $_ $_ $_) - (set-det))) -; + (= (find-min-depth $A (Cons (, $B $C) $_) $C) + (=.. $A + (Cons $B $_)) + (set-det)) + (= (find-min-depth $A (Cons $_ $B) $C) + (find-min-depth $A $B $C) + (set-det)) + (= (is-a-rule-call $A) + (=.. $A + (Cons $B $_)) + (dctg-id-table $B $_ $_ $_) + (set-det)) - (= - (find-min-depth-body - (, $A $B) $C $D $E) - ( (is-a-rule-call $A) - (set-det) - (find-min-depth $A $C $F) - (is $G - (max $F $D)) - (find-min-depth-body $B $C $G $E))) -; - - (= - (find-min-depth-body - (, $_ $A) $B $C $D) - ( (set-det) (find-min-depth-body $A $B $C $D))) -; - - (= - (find-min-depth-body $A $B $C $D) - ( (is-a-rule-call $A) - (set-det) - (find-min-depth $A $B $E) - (is $D - (max $E $C)))) -; - (= - (find-min-depth-body $_ $_ $A $A) + (= (find-min-depth-body (, $A $B) $C $D $E) + (is-a-rule-call $A) + (set-det) + (find-min-depth $A $C $F) + (is $G + (max $F $D)) + (find-min-depth-body $B $C $G $E)) + (= (find-min-depth-body (, $_ $A) $B $C $D) + (set-det) + (find-min-depth-body $A $B $C $D)) + (= (find-min-depth-body $A $B $C $D) + (is-a-rule-call $A) + (set-det) + (find-min-depth $A $B $E) + (is $D + (max $E $C))) + (= (find-min-depth-body $_ $_ $A $A) (set-det)) -; - - (= - (find-rule-mins Nil $A $A) + (= (find-rule-mins Nil $A $A) (set-det)) -; - - (= - (find-rule-mins + (= (find-rule-mins (Cons (, $A $B) $C) $D $E) + (=.. $A + (Cons $F $_)) + (not (member (, $F $_) $D)) + (set-det) + (find-rule-mins $C (Cons - (, $A $B) $C) $D $E) - ( (=.. $A - (Cons $F $_)) - (not (member (, $F $_) $D)) - (set-det) - (find-rule-mins $C - (Cons - (, $F $B) $D) $E))) -; - - (= - (find-rule-mins - (Cons $_ $A) $B $C) + (, $F $B) $D) $E)) + (= (find-rule-mins (Cons $_ $A) $B $C) (find-rule-mins $A $B $C)) -; - - (= - (process-rules Nil $A $_ $B $A $B) + (= (process-rules Nil $A $_ $B $A $B) (set-det)) -; - - (= - (process-rules - (Cons $A $B) $C $D $E $F $G) + (= (process-rules (Cons $A $B) $C $D $E $F $G) ( (copy-term $A $H) - (get-symbols &self - (= $H $I)) + (== + (= $H $I) + (get-atoms &self)) (find-min-depth-body $I $D 0 $J) (set-det) (is $K @@ -820,25 +465,15 @@ (process-rules $B (Cons (, $A $K) $C) $D $E $F $G))) -; - - (= - (process-rules - (Cons $A $B) $C $D $E $F $G) - ( (set-det) (process-rules $B $C $D (Cons $A $E) $F $G))) -; + (= (process-rules (Cons $A $B) $C $D $E $F $G) + (set-det) + (process-rules $B $C $D + (Cons $A $E) $F $G)) - - (= - (set-rule-data Nil $_) + (= (set-rule-data Nil $_) (set-det)) -; - - (= - (set-rule-data - (Cons - (, $A $B) $C) $D) + (= (set-rule-data (Cons (, $A $B) $C) $D) ( (=.. $A (Cons $E $F)) (with_self @@ -852,82 +487,64 @@ (member $A $D)) (= $H terminal) (= $H nonterminal)) - (add-symbol &self + (add-is-symbol &self (dctg_rule_info $E $G $A $B $H)) (set-rule-data $C $D) (set-det))) -; - - - - (= - (grammar-type-top-loop $A $B $C $D) - ( (grammar-type-loop $A Nil $B $C $E $F $G) - (det-if-then-else - (, - (length $A $H) - (length $E $H)) - (= $F $D) - (grammar-type-top-loop $E $F $G $D)) - (set-det))) -; - - (= - (grammar-depth-top-loop Nil $A $_ $A) + (= (grammar-type-top-loop $A $B $C $D) + (grammar-type-loop $A Nil $B $C $E $F $G) + (det-if-then-else + (, + (length $A $H) + (length $E $H)) + (= $F $D) + (grammar-type-top-loop $E $F $G $D)) (set-det)) -; - - (= - (grammar-depth-top-loop $A $B $C $D) - ( (process-rules $A $B $C Nil $E $F) - (find-rule-mins $E $C $G) - (det-if-then-else - (, - (length $A $H) - (length $F $H)) - (, - (write 'Problem - ') - (write $H) - (write ' rules cannot terminate:') - (nl) - (writelist $F) - (nl) - (write 'these terminated - ') - (nl) - (writelist $E) - (nl) - (write 'These are mincalls - ') - (nl) - (writelist $G) - (nl) - (fail)) - (grammar-depth-top-loop $F $E $G $D)) - (set-det))) -; - - (= - (clone-list Nil Nil) + (= (grammar-depth-top-loop Nil $A $_ $A) + (set-det)) + (= (grammar-depth-top-loop $A $B $C $D) + (process-rules $A $B $C Nil $E $F) + (find-rule-mins $E $C $G) + (det-if-then-else + (, + (length $A $H) + (length $F $H)) + (, + (write 'Problem - ') + (write $H) + (write ' rules cannot terminate:') + (nl) + (writelist $F) + (nl) + (write 'these terminated - ') + (nl) + (writelist $E) + (nl) + (write 'These are mincalls - ') + (nl) + (writelist $G) + (nl) + (fail)) + (grammar-depth-top-loop $F $E $G $D)) (set-det)) -; - (= - (clone-list - (Cons $_ $A) - (Cons $_ $B)) - ( (clone-list $A $B) (set-det))) -; + (= (clone-list Nil Nil) + (set-det)) + (= (clone-list (Cons $_ $A) (Cons $_ $B)) + (clone-list $A $B) + (set-det)) - (= - (get-rule-name $A) - ( (get-symbols &self + (= (get-rule-name $A) + ( (== (= - (semantic_rule $B $_ $C $_) $_)) + (semantic_rule $B $_ $C $_) $_) + (get-atoms &self)) (=.. $C (Cons $D $E)) (clone-list $E $F) @@ -938,548 +555,284 @@ (node $_ $_ $B) $_ $_) $G)) (=.. $A (Cons $D $G)))) -; - - - - (= - (dctg_id_table expr - (0 1) () - (0 1)) True) -; - - (= - (dctg_id_table guardedexpr_a - (8 9) - (8) - (9)) True) -; - - (= - (dctg_id_table guardedexpr_b - (10 11) - (10) - (11)) True) -; - - (= - (dctg_id_table intval - (12) - (12) ()) True) -; - - (= - (dctg_id_table iter_expr - (6 7) () - (6 7)) True) -; - - (= - (dctg_id_table noniter_expr - (2 3 4 5) - (2 3) - (4 5)) True) -; - - (= - (dctg_id_table probval - (13) - (13) ()) True) -; - - - - (= - (enhance-rule-id-list) - ( (remove-symbol &self - (dctg_id_table $A $B $_ $_)) - (identify-type $B $C $D) - (add-symbol &self - (dctg_id_table $A $B $C $D)) - (fail))) -; - (= enhance_rule_id_list True) -; + (= (dctg_id_table expr (0 1) () (0 1)) True) + (= (dctg_id_table guardedexpr_a (8 9) (8) (9)) True) + (= (dctg_id_table guardedexpr_b (10 11) (10) (11)) True) + (= (dctg_id_table intval (12) (12) ()) True) + (= (dctg_id_table iter_expr (6 7) () (6 7)) True) + (= (dctg_id_table noniter_expr (2 3 4 5) (2 3) (4 5)) True) + (= (dctg_id_table probval (13) (13) ()) True) - (= - (generate-rule-data) - ( (findall $A - (get-rule-name $A) $B) - (rem-dups $B $C) - (grammar-depth-top-loop $C Nil Nil $D) - (grammar-type-top-loop $C Nil Nil $E) - (set-rule-data $D $E) - (set-det))) -; + (= (enhance-rule-id-list) + ( (remove-is-symbol &self + (dctg_id_table $A $B $_ $_)) + (identify-type $B $C $D) + (add-is-symbol &self + (dctg_id_table $A $B $C $D)) + (fail))) + (= enhance_rule_id_list True) + (= (generate-rule-data) + (findall $A + (get-rule-name $A) $B) + (rem-dups $B $C) + (grammar-depth-top-loop $C Nil Nil $D) + (grammar-type-top-loop $C Nil Nil $E) + (set-rule-data $D $E) + (set-det)) - (= - (make-rule-id-list) - ( (findall - (, $A $B) - (make-rule-id-list2 $A $B) $C) - (make-id-entries $C) - (set-det))) -; + (= (make-rule-id-list) + (findall + (, $A $B) + (make-rule-id-list2 $A $B) $C) + (make-id-entries $C) + (set-det)) - (= - (cleanup-grammar-data) - ( (remove-all-symbols &self + (= (cleanup-grammar-data) + ( (remove-all-atoms &self (dctg_rule_info $_ $_ $_ $_)) - (remove-all-symbols &self + (remove-all-atoms &self (dctg_id_table $_ $_ $_ $_)) (set-det))) -; - - (= - (make-grammar-table) - ( (cleanup-grammar-data) - (make-rule-id-list) - (generate-rule-data) - (enhance-rule-id-list) - (set-det))) -; - + (= (make-grammar-table) + (cleanup-grammar-data) + (make-rule-id-list) + (generate-rule-data) + (enhance-rule-id-list) + (set-det)) - (= - (file-search-path library $A) + (= (file-search-path library $A) (library-directory $A)) -; - - (= - (file-search-path system $A) + (= (file-search-path system $A) (prolog-flag host-type $A)) -; - - - - (= - (eval_with_ID_P no) True) -; - - - - (= - (negsetsize_P 30) True) -; - - - - (= - (elite_migrate_P 0 no) True) -; - - (= - (unique_guards_P no) True) -; + (= (eval_with_ID_P no) True) + (= (negsetsize_P 30) True) - (= - (min_skip_prob_P 0.0001) True) -; + (= (elite_migrate_P 0 no) True) - (= - (min_grammar_prob_P 0.0001) True) -; + (= (unique_guards_P no) True) + (= (min_skip_prob_P 0.0001) True) - (= - (gen_set_size_P 1000) True) -; + (= (min_grammar_prob_P 0.0001) True) - (= - (sre_mintestcnt_P 2) True) -; + (= (gen_set_size_P 1000) True) + (= (sre_mintestcnt_P 2) True) - (= - (mutation_range_P 0.1) True) -; + (= (mutation_range_P 0.1) True) - (= - (dctg_override_P () ()) True) -; + (= (dctg_override_P () ()) True) - - (= - (expr - (node expr - (:: $A) 0) $B $C) + (= (expr (node expr (:: $A) 0) $B $C) (iter-expr $A $B $C)) -; - - (= - (expr - (node expr - (:: $A) 1) $B $C) + (= (expr (node expr (:: $A) 1) $B $C) (noniter-expr $A $B $C)) -; - - - - (= - (dctg_root_P expr) True) -; - - - - (= - (user_args_P ()) True) -; - - - - (= - (reprod_verif_P no) True) -; - - - - (= - (evaluator_reset_P generate_testset 100) True) -; - - - - (= - (gen_type_P steadystate) True) -; - - - - (= - (popn_dump_P no) True) -; - - - - (= - (max_string_length_P 20) True) -; - - - - (= - (rep_limit_P 2) True) -; - - - - (= - (trace_limit_P 0 0) True) -; - - (= - (unique_population_P yes) True) -; + (= (dctg_root_P expr) True) + (= (user_args_P ()) True) - (= - (lamarckian_P 0.0 10 best 0.1) True) -; + (= (reprod_verif_P no) True) - (= - (tournament_size_P 4 4) True) -; + (= (evaluator_reset_P generate_testset 100) True) + (= (gen_type_P steadystate) True) - (= - (error_tolerance_P 0) True) -; + (= (popn_dump_P no) True) - (= - (max_depth_P 10 17) True) -; + (= (max_string_length_P 20) True) + (= (rep_limit_P 2) True) - (= - (prob_terminal_mutation_P 0.75) True) -; + (= (trace_limit_P 0 0) True) - (= - (prob_internal_crossover_P 0.9) True) -; + (= (unique_population_P yes) True) + (= (lamarckian_P 0.0 10 best 0.1) True) - (= - (reprod_P 3) True) -; + (= (tournament_size_P 4 4) True) - (= - (prob_crossover_P 0.9) True) -; + (= (error_tolerance_P 0) True) + (= (max_depth_P 10 17) True) - (= - (prob_grow_P 0.5) True) -; + (= (prob_terminal_mutation_P 0.75) True) - (= - (max_runs_P 1 solution 3) True) -; + (= (prob_internal_crossover_P 0.9) True) + (= (reprod_P 3) True) - (= - (cull_method_P elite) True) -; + (= (prob_crossover_P 0.9) True) - (= - (population_size_P 75 50) True) -; + (= (prob_grow_P 0.5) True) + (= (max_runs_P 1 solution 3) True) - (= - (dctg_file_P sre3.pl) True) -; + (= (cull_method_P elite) True) - (= - (fitness_func_P reg_gram_1) True) -; + (= (population_size_P 75 50) True) + (= (dctg_file_P sre3.pl) True) - (= - (wd_P c:/research/sre_dna_fastX) True) -; + (= (fitness_func_P reg_gram_1) True) - (= - (seed_P random - (, $_ - (, $_ $_))) True) -; + (= (wd_P c:/research/sre_dna_fastX) True) + (= (seed_P random (, $_ (, $_ $_))) True) - (= - (rule_number 14) True) -; + (= (rule_number 14) True) - (= - (semantic-rule 0 - (construct $A) expr - (:: $B)) - ( (set-det) (^^ $B (construct $A)))) -; - - (= - (semantic-rule 0 - (raw-generate $A $B $C) expr - (:: $D)) - ( (set-det) (^^ $D (raw-generate $A $B $C)))) -; - - (= - (semantic-rule 0 - (recognize $A $B $C $D) expr - (:: $E)) - ( (set-det) - (check-prob $C) - (^^ $E - (recognize $A $B $C $D)))) -; - - (= - (semantic-rule 1 - (construct $A) expr - (:: $B)) - ( (set-det) (^^ $B (construct $A)))) -; - - (= - (semantic-rule 1 - (raw-generate $A $B $C) expr - (:: $D)) - ( (set-det) (^^ $D (raw-generate $A $B $C)))) -; - - (= - (semantic-rule 1 - (recognize $A $B $C $D) expr - (:: $E)) - ( (set-det) - (check-prob $C) - (^^ $E - (recognize $A $B $C $D)))) -; - - (= - (semantic-rule 2 - (construct a) noniter-expr - (:: (:: a))) + (= (semantic-rule 0 (construct $A) expr (:: $B)) + (set-det) + (^^ $B + (construct $A))) + (= (semantic-rule 0 (raw-generate $A $B $C) expr (:: $D)) + (set-det) + (^^ $D + (raw-generate $A $B $C))) + (= (semantic-rule 0 (recognize $A $B $C $D) expr (:: $E)) + (set-det) + (check-prob $C) + (^^ $E + (recognize $A $B $C $D))) + (= (semantic-rule 1 (construct $A) expr (:: $B)) + (set-det) + (^^ $B + (construct $A))) + (= (semantic-rule 1 (raw-generate $A $B $C) expr (:: $D)) + (set-det) + (^^ $D + (raw-generate $A $B $C))) + (= (semantic-rule 1 (recognize $A $B $C $D) expr (:: $E)) + (set-det) + (check-prob $C) + (^^ $E + (recognize $A $B $C $D))) + (= (semantic-rule 2 (construct a) noniter-expr (:: (:: a))) (set-det)) -; - - (= - (semantic-rule 2 - (raw-generate - (:: a) $A $B) noniter-expr - (:: (:: a))) - ( (set-det) (is $B (+ $A 1)))) -; - - (= - (semantic-rule 2 - (recognize - (Cons a $A) $A $B $B) noniter-expr - (:: (:: a))) - ( (set-det) (check-prob $B))) -; - - (= - (semantic-rule 3 - (construct b) noniter-expr - (:: (:: b))) + (= (semantic-rule 2 (raw-generate (:: a) $A $B) noniter-expr (:: (:: a))) + (set-det) + (is $B + (+ $A 1))) + (= (semantic-rule 2 (recognize (Cons a $A) $A $B $B) noniter-expr (:: (:: a))) + (set-det) + (check-prob $B)) + (= (semantic-rule 3 (construct b) noniter-expr (:: (:: b))) (set-det)) -; - - (= - (semantic-rule 3 - (raw-generate - (:: b) $A $B) noniter-expr - (:: (:: b))) - ( (set-det) (is $B (+ $A 1)))) -; - - (= - (semantic-rule 3 - (recognize - (Cons b $A) $A $B $B) noniter-expr - (:: (:: b))) - ( (set-det) (check-prob $B))) -; - - (= - (semantic-rule 4 - (construct (:: (, $A $B) (, $C $D))) noniter-expr - (:: $E $F $G $H)) - ( (set-det) - (^^ $E - (construct $A)) - (^^ $F - (construct $B)) - (^^ $G - (construct $C)) - (^^ $H - (construct $D)))) -; - - (= - (semantic-rule 4 - (raw-generate $A $B $C) noniter-expr - (:: $D $E $F $G)) - ( (set-det) - (^^ $E - (construct $H)) - (^^ $G - (construct $I)) - (det-if-then-else - (raw-select-term - (:: $H $I) 1) - (^^ $D - (raw-generate $A $B $C)) - (^^ $F - (raw-generate $A $B $C))))) -; - - (= - (semantic-rule 4 - (recognize $A $B $C $D) noniter-expr - (:: $E $F $_ $G)) - ( (set-det) - (^^ $F - (construct $H)) - (^^ $G - (construct $I)) - (is $J - (/ - (* $C $H) - (+ $H $I))) - (check-prob $J) - (^^ $E - (recognize $A $B $J $D)))) -; - - (= - (semantic-rule 4 - (recognize $A $B $C $D) noniter-expr - (:: $_ $E $F $G)) - ( (set-det) - (^^ $E - (construct $H)) - (^^ $G - (construct $I)) - (is $J - (/ - (* $C $I) - (+ $H $I))) - (check-prob $J) - (^^ $F - (recognize $A $B $J $D)))) -; - - (= - (semantic-rule 5 - (construct (with_self $A $B)) noniter-expr - (:: $C $D)) - ( (set-det) - (^^ $C - (construct $A)) + (= (semantic-rule 3 (raw-generate (:: b) $A $B) noniter-expr (:: (:: b))) + (set-det) + (is $B + (+ $A 1))) + (= (semantic-rule 3 (recognize (Cons b $A) $A $B $B) noniter-expr (:: (:: b))) + (set-det) + (check-prob $B)) + (= (semantic-rule 4 (construct (:: (, $A $B) (, $C $D))) noniter-expr (:: $E $F $G $H)) + (set-det) + (^^ $E + (construct $A)) + (^^ $F + (construct $B)) + (^^ $G + (construct $C)) + (^^ $H + (construct $D))) + (= (semantic-rule 4 (raw-generate $A $B $C) noniter-expr (:: $D $E $F $G)) + (set-det) + (^^ $E + (construct $H)) + (^^ $G + (construct $I)) + (det-if-then-else + (raw-select-term + (:: $H $I) 1) (^^ $D - (construct $B)))) -; - - (= - (semantic-rule 5 - (raw-generate $A $B $C) noniter-expr - (:: $D $E)) + (raw-generate $A $B $C)) + (^^ $F + (raw-generate $A $B $C)))) + (= (semantic-rule 4 (recognize $A $B $C $D) noniter-expr (:: $E $F $_ $G)) + (set-det) + (^^ $F + (construct $H)) + (^^ $G + (construct $I)) + (is $J + (/ + (* $C $H) + (+ $H $I))) + (check-prob $J) + (^^ $E + (recognize $A $B $J $D))) + (= (semantic-rule 4 (recognize $A $B $C $D) noniter-expr (:: $_ $E $F $G)) + (set-det) + (^^ $E + (construct $H)) + (^^ $G + (construct $I)) + (is $J + (/ + (* $C $I) + (+ $H $I))) + (check-prob $J) + (^^ $F + (recognize $A $B $J $D))) + (= (semantic-rule 5 (construct (with_self $A $B)) noniter-expr (:: $C $D)) + (set-det) + (^^ $C + (construct $A)) + (^^ $D + (construct $B))) + (= (semantic-rule 5 (raw-generate $A $B $C) noniter-expr (:: $D $E)) ( (set-det) (^^ $D (raw-generate $F $B $G)) @@ -1488,69 +841,39 @@ (with_self (lists *) (append $F $H $A)))) -; - - (= - (semantic-rule 5 - (recognize $A $B $C $D) noniter-expr - (:: $E $F)) - ( (set-det) - (check-prob $C) - (^^ $E - (recognize $A $G $C $H)) - (check-prob $H) - (^^ $F - (recognize $G $B $H $D)))) -; - - (= - (semantic-rule 6 - (construct (* $A $B)) iter-expr - (:: $C $D)) - ( (set-det) - (^^ $C - (construct $A)) - (^^ $D - (construct $B)))) -; - - (= - (semantic-rule 6 - (raw-generate $A $B $C) iter-expr - (:: $D $E)) - ( (set-det) - (^^ $E - (construct $F)) - (max-string-length-P $G) - (raw-gen-loop $D $F $G $A $B $C))) -; - - (= - (semantic-rule 6 - (recognize $A $B $C $D) iter-expr - (:: $E $F)) - ( (set-det) - (check-prob $C) - (^^ $F - (construct $G)) - (recognize-loop $E $G $A $B $C $D))) -; - - (= - (semantic-rule 7 - (construct (+ $A $B)) iter-expr - (:: $C $D)) - ( (set-det) - (^^ $C - (construct $A)) - (^^ $D - (construct $B)))) -; - - (= - (semantic-rule 7 - (raw-generate $A $B $C) iter-expr - (:: $D $E)) + (= (semantic-rule 5 (recognize $A $B $C $D) noniter-expr (:: $E $F)) + (set-det) + (check-prob $C) + (^^ $E + (recognize $A $G $C $H)) + (check-prob $H) + (^^ $F + (recognize $G $B $H $D))) + (= (semantic-rule 6 (construct (* $A $B)) iter-expr (:: $C $D)) + (set-det) + (^^ $C + (construct $A)) + (^^ $D + (construct $B))) + (= (semantic-rule 6 (raw-generate $A $B $C) iter-expr (:: $D $E)) + (set-det) + (^^ $E + (construct $F)) + (max-string-length-P $G) + (raw-gen-loop $D $F $G $A $B $C)) + (= (semantic-rule 6 (recognize $A $B $C $D) iter-expr (:: $E $F)) + (set-det) + (check-prob $C) + (^^ $F + (construct $G)) + (recognize-loop $E $G $A $B $C $D)) + (= (semantic-rule 7 (construct (+ $A $B)) iter-expr (:: $C $D)) + (set-det) + (^^ $C + (construct $A)) + (^^ $D + (construct $B))) + (= (semantic-rule 7 (raw-generate $A $B $C) iter-expr (:: $D $E)) ( (set-det) (^^ $D (raw-generate $F $B $G)) @@ -1562,153 +885,71 @@ (lists *) (append $F $J $A)) (set-det))) -; - - (= - (semantic-rule 7 - (recognize $A $B $C $D) iter-expr - (:: $E $F)) - ( (set-det) - (check-prob $C) - (^^ $E - (recognize $A $G $C $H)) - (not (= $A $G)) - (check-prob $H) - (^^ $F - (construct $I)) - (recognize-loop $E $I $G $B $H $D))) -; - - (= - (semantic-rule 8 - (construct a) guardedexpr-a - (:: (:: a))) + (= (semantic-rule 7 (recognize $A $B $C $D) iter-expr (:: $E $F)) + (set-det) + (check-prob $C) + (^^ $E + (recognize $A $G $C $H)) + (not (= $A $G)) + (check-prob $H) + (^^ $F + (construct $I)) + (recognize-loop $E $I $G $B $H $D)) + (= (semantic-rule 8 (construct a) guardedexpr-a (:: (:: a))) (set-det)) -; - - (= - (semantic-rule 8 - (raw-generate - (:: a) $A $B) guardedexpr-a - (:: (:: a))) - ( (set-det) (is $B (+ $A 1)))) -; - - (= - (semantic-rule 8 - (recognize - (Cons a $A) $A $B $B) guardedexpr-a - (:: (:: a))) - ( (set-det) (check-prob $B))) -; - - (= - (semantic-rule 9 - (construct (with_self (a *) $A)) guardedexpr-a - (:: - (:: a) $B)) - ( (set-det) (^^ $B (construct $A)))) -; - - (= - (semantic-rule 9 - (raw-generate - (Cons a $A) $B $C) guardedexpr-a - (:: - (:: a) $D)) - ( (set-det) - (^^ $D - (raw-generate $A $B $E)) - (is $C - (+ $E 1)))) -; - - (= - (semantic-rule 9 - (recognize - (Cons a $A) $B $C $D) guardedexpr-a - (:: - (:: a) $E)) - ( (set-det) - (check-prob $C) - (^^ $E - (recognize $A $B $C $D)))) -; - - (= - (semantic-rule 10 - (construct b) guardedexpr-b - (:: (:: b))) + (= (semantic-rule 8 (raw-generate (:: a) $A $B) guardedexpr-a (:: (:: a))) + (set-det) + (is $B + (+ $A 1))) + (= (semantic-rule 8 (recognize (Cons a $A) $A $B $B) guardedexpr-a (:: (:: a))) + (set-det) + (check-prob $B)) + (= (semantic-rule 9 (construct (with_self (a *) $A)) guardedexpr-a (:: (:: a) $B)) + (set-det) + (^^ $B + (construct $A))) + (= (semantic-rule 9 (raw-generate (Cons a $A) $B $C) guardedexpr-a (:: (:: a) $D)) + (set-det) + (^^ $D + (raw-generate $A $B $E)) + (is $C + (+ $E 1))) + (= (semantic-rule 9 (recognize (Cons a $A) $B $C $D) guardedexpr-a (:: (:: a) $E)) + (set-det) + (check-prob $C) + (^^ $E + (recognize $A $B $C $D))) + (= (semantic-rule 10 (construct b) guardedexpr-b (:: (:: b))) (set-det)) -; - - (= - (semantic-rule 10 - (raw-generate - (:: b) $A $B) guardedexpr-b - (:: (:: b))) - ( (set-det) (is $B (+ $A 1)))) -; - - (= - (semantic-rule 10 - (recognize - (Cons b $A) $A $B $B) guardedexpr-b - (:: (:: b))) - ( (set-det) (check-prob $B))) -; - - (= - (semantic-rule 11 - (construct (with_self (b *) $A)) guardedexpr-b - (:: - (:: b) $B)) - ( (set-det) (^^ $B (construct $A)))) -; - - (= - (semantic-rule 11 - (raw-generate - (Cons b $A) $B $C) guardedexpr-b - (:: - (:: b) $D)) - ( (set-det) - (^^ $D - (raw-generate $A $B $E)) - (is $C - (+ $E 1)))) -; - - (= - (semantic-rule 11 - (recognize - (Cons b $A) $B $C $D) guardedexpr-b - (:: - (:: b) $E)) - ( (set-det) - (check-prob $C) - (^^ $E - (recognize $A $B $C $D)))) -; - - (= - (semantic-rule 12 - (construct $A) intval - (:: (:: $A))) + (= (semantic-rule 10 (raw-generate (:: b) $A $B) guardedexpr-b (:: (:: b))) + (set-det) + (is $B + (+ $A 1))) + (= (semantic-rule 10 (recognize (Cons b $A) $A $B $B) guardedexpr-b (:: (:: b))) + (set-det) + (check-prob $B)) + (= (semantic-rule 11 (construct (with_self (b *) $A)) guardedexpr-b (:: (:: b) $B)) + (set-det) + (^^ $B + (construct $A))) + (= (semantic-rule 11 (raw-generate (Cons b $A) $B $C) guardedexpr-b (:: (:: b) $D)) + (set-det) + (^^ $D + (raw-generate $A $B $E)) + (is $C + (+ $E 1))) + (= (semantic-rule 11 (recognize (Cons b $A) $B $C $D) guardedexpr-b (:: (:: b) $E)) + (set-det) + (check-prob $C) + (^^ $E + (recognize $A $B $C $D))) + (= (semantic-rule 12 (construct $A) intval (:: (:: $A))) (set-det)) -; - - (= - (semantic-rule 13 - (construct $A) probval - (:: (:: $A))) + (= (semantic-rule 13 (construct $A) probval (:: (:: $A))) (set-det)) -; - - (= - (process $A) + (= (process $A) ( (or (= $A (<:> $B $C)) @@ -1716,73 +957,48 @@ (::= $B $C))) (set-det) (translate-rule $A $D) - (add-symbol &self $D) + (add-is-symbol &self $D) (set-det))) -; - - (= - (process !$A) - ( (set-det) (call $A))) -; - - (= - (process (= $A $B)) - ( (set-det) (add-symbol &self (:- $A $B)))) -; - - (= - (process $A) - (add-symbol &self $A)) -; - - - - (= - (check-it $A) - ( (= $A end-of-file) (set-det))) -; - - (= - (check-it $A) - ( (process $A) (fail))) -; + (= (process !$A) + (set-det) + (call $A)) + (= (process (= $A $B)) + ( (set-det) (add-is-symbol &self (:- $A $B)))) + (= (process $A) + (add-is-symbol &self $A)) - - (= - (consume) - ( (repeat) - (read $A) - (check-it $A))) -; + (= (check-it $A) + (= $A end-of-file) + (set-det)) + (= (check-it $A) + (process $A) + (fail)) + (= (consume) + (repeat) + (read $A) + (check-it $A)) - (= - (grammar $A) - ( (seeing $B) - (see $A) - (consume) - (seen) - (see $B))) -; + (= (grammar $A) + (seeing $B) + (see $A) + (consume) + (seen) + (see $B)) - (= - (add-extra-args $A $B $C) + (= (add-extra-args $A $B $C) ( (=.. $B $D) (with_self (lists *) (append $D $A $E)) (=.. $C $E))) -; - - (= - (assert-semantic-rule $A $B $C - (, $D $E)) + (= (assert-semantic-rule $A $B $C (, $D $E)) ( (set-det) (or (= $D @@ -1790,147 +1006,71 @@ (, (= $F $D) (= $G True))) - (add-symbol &self + (add-is-symbol &self (:- (semantic_rule $A $F $B $C) (, ! $G))) (assert-semantic-rule $A $B $C $E))) -; - - (= - (assert-semantic-rule $A $B $C $D) + (= (assert-semantic-rule $A $B $C $D) ( (or (= $D (::- $E $F)) (, (= $E $D) - (= $F True))) (add-symbol &self (:- (semantic_rule $A $E $B $C) (, ! $F))))) -; - + (= $F True))) (add-is-symbol &self (:- (semantic_rule $A $E $B $C) (, ! $F))))) - (= - (prod-number $A) - ( (remove-symbol &self + (= (prod-number $A) + ( (remove-is-symbol &self (rule_number $A)) (is $B (+ $A 1)) - (add-symbol &self + (add-is-symbol &self (rule_number $B)))) -; - - (= - (tidy - (, $A $B $C) $D) + (= (tidy (, $A $B $C) $D) (tidy (, $A $B $C) $D)) -; - - (= - (tidy - (, $A $B) - (, $C $D)) - ( (set-det) - (tidy $A $C) - (tidy $B $D))) -; - - (= - (tidy $A $A) + (= (tidy (, $A $B) (, $C $D)) + (set-det) + (tidy $A $C) + (tidy $B $D)) + (= (tidy $A $A) (set-det)) -; - - (= - (t-rp - (set-det) $A $A $B $B - (set-det)) + (= (t-rp (set-det) $A $A $B $B (set-det)) (set-det)) -; - - (= - (t-rp Nil $A - (Cons Nil $A) $B $C - (= $B $C)) + (= (t-rp Nil $A (Cons Nil $A) $B $C (= $B $C)) (set-det)) -; - - (= - (t-rp - (:: $A) $B - (Cons - (:: $C) $B) $D $E - (c $D $A $E)) + (= (t-rp (:: $A) $B (Cons (:: $C) $B) $D $E (c $D $A $E)) (char $A $C)) -; - - (= - (t-rp - (:: $A) $B - (Cons - (:: $A) $B) $C $D - (c $C $A $D)) + (= (t-rp (:: $A) $B (Cons (:: $A) $B) $C $D (c $C $A $D)) (set-det)) -; - - (= - (t-rp - (Cons $A $B) $C - (Cons - (Cons $D $E) $C) $F $G - (, - (c $F $A $H) $I)) - ( (char $A $D) (t-rp $B $C (Cons $E $C) $H $G $I))) -; - - (= - (t-rp - (Cons $A $B) $C - (Cons - (Cons $A $B) $C) $D $E - (, - (c $D $A $F) $G)) - ( (set-det) (t-rp $B $C (Cons $B $C) $F $E $G))) -; - - (= - (t-rp - {$A } $B $B $C $C $A) + (= (t-rp (Cons $A $B) $C (Cons (Cons $D $E) $C) $F $G (, (c $F $A $H) $I)) + (char $A $D) + (t-rp $B $C + (Cons $E $C) $H $G $I)) + (= (t-rp (Cons $A $B) $C (Cons (Cons $A $B) $C) $D $E (, (c $D $A $F) $G)) + (set-det) + (t-rp $B $C + (Cons $B $C) $F $E $G)) + (= (t-rp {$A } $B $B $C $C $A) (set-det)) -; - - (= - (t-rp - (, $A $B) $C $D $E $F - (, $G $H)) - ( (set-det) - (t-rp $A $C $I $E $J $G) - (t-rp $B $I $D $J $F $H))) -; - - (= - (t-rp - (^^ $A $B) $C - (Cons $B $C) $D $E $F) + (= (t-rp (, $A $B) $C $D $E $F (, $G $H)) + (set-det) + (t-rp $A $C $I $E $J $G) + (t-rp $B $I $D $J $F $H)) + (= (t-rp (^^ $A $B) $C (Cons $B $C) $D $E $F) (add-extra-args (:: $B $D $E) $A $F)) -; - - (= - (t-rp $A $B - (Cons $C $B) $D $E $F) + (= (t-rp $A $B (Cons $C $B) $D $E $F) (add-extra-args (:: $C $D $E) $A $F)) -; - - (= - (t-lp - (, $A $B) $C $D $E $F $G) + (= (t-lp (, $A $B) $C $D $E $F $G) ( (with_self (lists *) (append $B $E $H)) @@ -1939,37 +1079,21 @@ (add-extra-args (:: (node $A $C $I) $D $H) $A $G))) -; - - (= - (t-lp $A $B $C $D $E $F) - ( (prod-number $G) - (assert-semantic-rule $G $A $B $E) - (add-extra-args - (:: - (node $A $B $G) $C $D) $A $F))) -; - - - - (= - (translate-rule - (<:> - (::= $A Nil) $B) $C) - ( (set-det) (t-lp $A Nil $D $D $B $C))) -; + (= (t-lp $A $B $C $D $E $F) + (prod-number $G) + (assert-semantic-rule $G $A $B $E) + (add-extra-args + (:: + (node $A $B $G) $C $D) $A $F)) - (= - (translate-rule - (::= $A Nil) $B) - ( (set-det) (t-lp $A Nil $C $C Nil $B))) -; - (= - (translate-rule - (<:> - (::= $A $B) $C) - (= $D $E)) + (= (translate-rule (<:> (::= $A Nil) $B) $C) + (set-det) + (t-lp $A Nil $D $D $B $C)) + (= (translate-rule (::= $A Nil) $B) + (set-det) + (t-lp $A Nil $C $C Nil $B)) + (= (translate-rule (<:> (::= $A $B) $C) (= $D $E)) ( (set-det) (t-rp $B Nil $F $G $H $I) (with_self @@ -1977,50 +1101,36 @@ (reverse $F $J)) (t-lp $A $J $G $H $C $D) (tidy $I $E))) -; - - (= - (translate-rule - (::= $A $B) - (= $C $D)) + (= (translate-rule (::= $A $B) (= $C $D)) (translate-rule (<:> (::= $A $B) Nil) - (= $C $D))) -; - + (= $C $D))) - (= - (^^ - (node $A $B $C) $D) + (= (^^ (node $A $B $C) $D) (semantic-rule $C $D $A $B)) -; - - (= - (sre $A $B $C $D) - ( (repeat) - (or - (= $A full) - (= $A grow)) - (generate-tree expr $A 12 $_ $E $_) - (^^ $E - (construct $B)) - (^^ $E - (raw-generate $C 0 $D)) - (nl) - (sre-pp $B) - (nl) - (write 'tree ') - (write $E) - (nl) - (tree-depth $E $F) - (write 'Depth = ') - (write $F) - (nl))) -; - + (= (sre $A $B $C $D) + (repeat) + (or + (= $A full) + (= $A grow)) + (generate-tree expr $A 12 $_ $E $_) + (^^ $E + (construct $B)) + (^^ $E + (raw-generate $C 0 $D)) + (nl) + (sre-pp $B) + (nl) + (write 'tree ') + (write $E) + (nl) + (tree-depth $E $F) + (write 'Depth = ') + (write $F) + (nl)) diff --git a/sre_dna/dctg.metta b/sre_dna/dctg.metta index ec757bd..3e76849 100644 --- a/sre_dna/dctg.metta +++ b/sre_dna/dctg.metta @@ -1,285 +1,161 @@ +; (convert_to_metta_file dctg $_196846 sre_dna/dctg.pl sre_dna/dctg.metta) !(op 650 yfx ^^) -; - +; /* logic compilation of Definite Clause Translation Grammar rules */ !(op 601 xfy :) -; - !(op 1150 xfx ::=) -; - !(op 1175 xfx <:>) -; - !(op 1150 xfx ::-) -; - - - - - (= - (translate-rule - (<:> - (::= $LP Nil) $Sem) $H) - ( (set-det) (t-lp $LP Nil $S $S $Sem $H))) -; - (= - (translate-rule - (::= $LP Nil) $H) - ( (set-det) (t-lp $LP Nil $S $S Nil $H))) -; + (= (translate-rule (<:> (::= $LP Nil) $Sem) $H) + (set-det) + (t-lp $LP Nil $S $S $Sem $H)) +; /* The form of a rule is: LP ::= RP <:> Args ::- Sem */ - (= - (translate-rule - (<:> - (::= $LP $RP) $Sem) - (= $H $B)) - ( (set-det) - (t-rp $RP Nil $StL $S $SR $B1) - (reverse $StL $RStL) - (t-lp $LP $RStL $S $SR $Sem $H) - (tidy $B1 $B))) -; + (= (translate-rule (::= $LP Nil) $H) + (set-det) + (t-lp $LP Nil $S $S Nil $H)) + (= (translate-rule (<:> (::= $LP $RP) $Sem) (= $H $B)) + (set-det) + (t-rp $RP Nil $StL $S $SR $B1) + (reverse $StL $RStL) + (t-lp $LP $RStL $S $SR $Sem $H) + (tidy $B1 $B)) - (= - (translate-rule - (::= $LP $RP) - (= $H $B)) + (= (translate-rule (::= $LP $RP) (= $H $B)) (translate-rule (<:> (::= $LP $RP) Nil) - (= $H $B))) -; - - - - (= - (t-lp - (, $LP $List) $StL $S $SR $Sem $H) - ( (append $List $SR $List2) - (prod-number $Number) - (assert-semantic-rule $Number $LP $StL $Sem) - (add-extra-args - (:: - (node $LP $StL $Number) $S $List2) $LP $H))) -; + (= $H $B))) - (= - (t-lp $LP $StL $S $SR $Sem $H) - ( (prod-number $Number) - (assert-semantic-rule $Number $LP $StL $Sem) - (add-extra-args - (:: - (node $LP $StL $Number) $S $SR) $LP $H))) -; + (= (t-lp (, $LP $List) $StL $S $SR $Sem $H) + (append $List $SR $List2) + (prod-number $Number) + (assert-semantic-rule $Number $LP $StL $Sem) + (add-extra-args + (:: + (node $LP $StL $Number) $S $List2) $LP $H)) + (= (t-lp $LP $StL $S $SR $Sem $H) + (prod-number $Number) + (assert-semantic-rule $Number $LP $StL $Sem) + (add-extra-args + (:: + (node $LP $StL $Number) $S $SR) $LP $H)) - (= - (t-rp - (set-det) $St $St $S $S - (set-det)) + (= (t-rp (set-det) $St $St $S $S (set-det)) (set-det)) -; - - (= - (t-rp Nil $St - (Cons Nil $St) $S $S1 - (= $S $S1)) + (= (t-rp Nil $St (Cons Nil $St) $S $S1 (= $S $S1)) (set-det)) -; - - (= - (t-rp - (:: $X) $St - (Cons - (:: $NX) $St) $S $SR - (c $S $X $SR)) + (= (t-rp (:: $X) $St (Cons (:: $NX) $St) $S $SR (c $S $X $SR)) (char $X $NX)) -; - - (= - (t-rp - (:: $X) $St - (Cons - (:: $X) $St) $S $SR - (c $S $X $SR)) + (= (t-rp (:: $X) $St (Cons (:: $X) $St) $S $SR (c $S $X $SR)) (set-det)) -; + (= (t-rp (Cons $X $R) $St (Cons (Cons $NX $NR) $St) $S $SR (, (c $S $X $SR1) $RB)) + (char $X $NX) + (t-rp $R $St + (Cons $NR $St) $SR1 $SR $RB)) - (= - (t-rp - (Cons $X $R) $St - (Cons - (Cons $NX $NR) $St) $S $SR - (, - (c $S $X $SR1) $RB)) - ( (char $X $NX) (t-rp $R $St (Cons $NR $St) $SR1 $SR $RB))) -; - - - (= - (t-rp - (Cons $X $R) $St - (Cons - (Cons $X $R) $St) $S $SR - (, - (c $S $X $SR1) $RB)) - ( (set-det) (t-rp $R $St (Cons $R $St) $SR1 $SR $RB))) -; + (= (t-rp (Cons $X $R) $St (Cons (Cons $X $R) $St) $S $SR (, (c $S $X $SR1) $RB)) + (set-det) + (t-rp $R $St + (Cons $R $St) $SR1 $SR $RB)) - - (= - (t-rp - {$T } $St $St $S $S $T) + (= (t-rp {$T } $St $St $S $S $T) (set-det)) -; + (= (t-rp (, $T $R) $St $StR $S $SR (, $Tt $Rt)) + (set-det) + (t-rp $T $St $St1 $S $SR1 $Tt) + (t-rp $R $St1 $StR $SR1 $SR $Rt)) - (= - (t-rp - (, $T $R) $St $StR $S $SR - (, $Tt $Rt)) - ( (set-det) - (t-rp $T $St $St1 $S $SR1 $Tt) - (t-rp $R $St1 $StR $SR1 $SR $Rt))) -; - - - (= - (t-rp - (^^ $T $N) $St - (Cons $N $St) $S $SR $Tt) + (= (t-rp (^^ $T $N) $St (Cons $N $St) $S $SR $Tt) (add-extra-args (:: $N $S $SR) $T $Tt)) -; - - (= - (t-rp $T $St - (Cons $St1 $St) $S $SR $Tt) + (= (t-rp $T $St (Cons $St1 $St) $S $SR $Tt) (add-extra-args (:: $St1 $S $SR) $T $Tt)) -; - - (= - (add-extra-args $L $T $T1) - ( (=.. $T $Tl) - (append $Tl $L $Tl1) - (=.. $T1 $Tl1))) -; - + (= (add-extra-args $L $T $T1) + (=.. $T $Tl) + (append $Tl $L $Tl1) + (=.. $T1 $Tl1)) ; -; - +; append([],L,L) :- !. ; -; - +; append([X|R],L,[X|R1]) :- append(R,L,R1). ; -; - +; reverse(X,RX) :- rev1(X,[],RX). ; ; - ; -; - +; rev1([],R,R) :- !. ; ; - ; -; - +; rev1([X|Y],Z,R) :- rev1(Y,[X|Z],R). - (= - (tidy - (, $P1 $P2 $P3) $Q) + (= (tidy (, $P1 $P2 $P3) $Q) (tidy (, $P1 $P2 $P3) $Q)) -; + (= (tidy (, $P1 $P2) (, $Q1 $Q2)) + (set-det) + (tidy $P1 $Q1) + (tidy $P2 $Q2)) - (= - (tidy - (, $P1 $P2) - (, $Q1 $Q2)) - ( (set-det) - (tidy $P1 $Q1) - (tidy $P2 $Q2))) -; - - - (= - (tidy $A $A) + (= (tidy $A $A) (set-det)) -; - - - (= - (char $X $NX) - ( (integer $X) - (< $X 256) - (set-det) - (name $NX - (:: $X)))) -; - - - - (= - (c - (Cons $X $S) $X $S) True) -; - - (= - (grammar $File) - ( (seeing $Old) - (see $File) - (consume) - (seen) - (see $Old))) -; + (= (char $X $NX) + (integer $X) + (< $X 256) + (set-det) + (name $NX + (:: $X))) - (= - (consume) - ( (repeat) - (read $X) - (check-it $X))) -; + (= (c (Cons $X $S) $X $S) True) + (= (grammar $File) + (seeing $Old) + (see $File) + (consume) + (seen) + (see $Old)) +; /* defined as a system predicate */ +; ; :- asserta(( term_expansion(T,E) :- translate_rule(T,E) , ! )). ; :- asserta(( term_expansion(T,E) :- process_rule(T,E) , ! )). + (= (consume) + (repeat) + (read $X) + (check-it $X)) - (= - (check-it $X) - ( (= $X end-of-file) (set-det))) -; - - (= - (check-it $X) - ( (process $X) (fail))) -; + (= (check-it $X) + (= $X end-of-file) + (set-det)) + (= (check-it $X) + (process $X) + (fail)) - (= - (process $Grammar) + (= (process $Grammar) ( (or (= $Grammar (<:> $H $T)) @@ -287,66 +163,45 @@ (::= $H $T))) (set-det) (translate-rule $Grammar $Clause) - (add-symbol &self $Clause) + (add-is-symbol &self $Clause) (set-det))) -; - - (= - (process !$G) + (= (process !$G) ( (set-det) $G)) -; +; ; Execute a command + (= (process (= $P $Q)) + ( (set-det) (add-is-symbol &self (:- $P $Q)))) +; ; Store a normal clause - (= - (process (= $P $Q)) - ( (set-det) (add-symbol &self (:- $P $Q)))) -; - - - (= - (process $P) - (add-symbol &self $P)) -; - + (= (process $P) + (add-is-symbol &self $P)) +; ; Store a unit clause - (= - (^^ - (node $NonTerminal $Trees $Index) $Args) + (= (^^ (node $NonTerminal $Trees $Index) $Args) (semantic-rule $Index $Args $NonTerminal $Trees)) -; - ; -; +; /* process_rule(T,E) :- translate_rule(T,E), !, assert(T). */ ; +; fast? - - (= - (prod-number $X) - ( (remove-symbol &self + (= (prod-number $X) + ( (remove-is-symbol &self (rule_number $X)) (is $X1 (+ $X 1)) - (add-symbol &self + (add-is-symbol &self (rule_number $X1)))) -; - +; /* get_sem(NonTerminal,Trees,Index,Head) :- semantic_rule(Index,NonTerminal,Trees,Head). */ !(dynamic (/ rule-number 1)) -; + (= (rule_number 0) True) - (= - (rule_number 0) True) -; - - - (= - (assert-semantic-rule $Number $LP $StL - (, $Rule $Rules)) + (= (assert-semantic-rule $Number $LP $StL (, $Rule $Rules)) ( (set-det) (or (= $Rule @@ -354,24 +209,19 @@ (, (= $Head $Rule) (= $Body True))) - (add-symbol &self + (add-is-symbol &self (:- (semantic_rule $Number $Head $LP $StL) (, ! $Body))) (assert-semantic-rule $Number $LP $StL $Rules))) -; - - (= - (assert-semantic-rule $Number $LP $StL $Rule) + (= (assert-semantic-rule $Number $LP $StL $Rule) ( (or (= $Rule (::- $Head $Body)) (, (= $Head $Rule) - (= $Body True))) (add-symbol &self (:- (semantic_rule $Number $Head $LP $StL) (, ! $Body))))) -; - + (= $Body True))) (add-is-symbol &self (:- (semantic_rule $Number $Head $LP $StL) (, ! $Body))))) diff --git a/sre_dna/dctg_gen.metta b/sre_dna/dctg_gen.metta index 8692f9b..749576f 100644 --- a/sre_dna/dctg_gen.metta +++ b/sre_dna/dctg_gen.metta @@ -1,65 +1,46 @@ +; (convert_to_metta_file dctg_gen $_354356 sre_dna/dctg_gen.pl sre_dna/dctg_gen.metta) ; -; - +; DCTG based tree generation for GP ; -; - +; Brian Ross ; -; - +; January, 1999 ; -; - +; generate_tree(TopGoal, TreeType, MaxDepth, UserArgs, Tree, Expr): ; -; - +; TopGoal - name of top of tree to generate ; -; - +; TreeType - either grow or full ; -; - +; MaxDepth - maximum depth of tree ; -; - +; UserArgs - list of user-specified args to use in top of rule ; -; - +; Tree - Resulting tree, in DCTG node structure ; -; - +; Expr - DCTG expression list equivalent of Tree ; ; - ; -; - +; Generates a tree of Type and max Depth, with UserArgs used in head of rule. ; -; - +; With the node structure of Tree, it should be possible to access all ; -; - +; semantic rules. Any embedded MeTTa in DCTG definition of rules is executed ; -; - +; as tree is generated; this permits Expr to be constructed. This means ; -; - +; that user must ensure embedded MeTTa goals will execute correctly. ; -; - +; The node structure inserted into call has it's ID removed, to permit random ; -; - +; selection. Any user arg structures in the tree structure are not used ; -; - +; afterwards. 'verification' must be called to account for them. - (= - (generate-tree $TopGoal $TreeType $MaxDepth $UserArgs $Tree $Expr) + (= (generate-tree $TopGoal $TreeType $MaxDepth $UserArgs $Tree $Expr) ( (with_self (fast *) (dctg-rule-info $TopGoal $_ $RuleHead $_ $_)) @@ -76,102 +57,74 @@ (Cons $Name $Args2)) (set-det) (once (gen-tree $RuleHead2 $TreeType $MaxDepth)))) -; - +; ; enforce empty diff list +; ; new ; -; - +; gen_tree(RuleHead, TreeType, Depth): ; -; - +; RuleHead - Head of rule at root of tree ; -; - +; TreeType - full or grow ; -; - +; Depth - current depth to make tree - (= - (gen-tree $RuleHead $TreeType $Depth) + (= (gen-tree $RuleHead $TreeType $Depth) ( (is $Depth2 (- $Depth 1)) (select-random-rule $TreeType $Depth $RuleHead) - (get-symbols &self - (= $RuleHead $Body)) + (== + (= $RuleHead $Body) + (get-atoms &self)) (process-goals $Body $TreeType $Depth2))) -; - +; ; select_random_rule(TreeType, Depth2, RuleHead), ; -; - +; process_goals(Goals, TreeType, Depth): ; -; - +; Goals - goals to generate subtrees for ; -; - +; TreeType - grow or full ; -; - +; Depth - current depth to make tree - (= - (process-goals - (, $A $B) $TreeType $Depth) - ( (set-det) - (process-goals $A $TreeType $Depth) - (process-goals $B $TreeType $Depth))) -; - + (= (process-goals (, $A $B) $TreeType $Depth) + (set-det) + (process-goals $A $TreeType $Depth) + (process-goals $B $TreeType $Depth)) ; -; - - (= - (process-goals $A $TreeType $Depth) +; !. + (= (process-goals $A $TreeType $Depth) (det-if-then-else (is-a-rule-call $A) (gen-tree $A $TreeType $Depth) (call $A))) -; - ; -; - +; select_random_rule(TreeType, MaxDepth, RuleHead): ; -; - +; TreeType - grow or full ; -; - +; MaxDepth - maximum depth of resulting tree ; -; - +; RuleHead - Head of selected rule ; ; - ; -; - +; Randomly select a rule for given RuleHead structure, based on type and ; -; - +; max depth. The RuleHead args are unified with head of rule to use. ; -; - +; On backtracking, new selections are tried. Random selection done by ; -; - +; generating a shuffled list of rules to try, and each is tried in succession. ; -; - +; Possible for this to fail, depending on MaxDepth value. - (= - (select-random-rule $TreeType $MaxDepth $RuleHead) + (= (select-random-rule $TreeType $MaxDepth $RuleHead) ( (=.. $RuleHead (Cons $RuleName $_)) (shuffle-rule-list $RuleName $TreeType $RuleList) @@ -181,51 +134,37 @@ (dctg-rule-info $_ $ID $RuleHead $MinDepth $_)) (=< $MinDepth $MaxDepth) (set-det))) -; - ; -; - +; ; may backtrack to here +; ; otherwise exceeds Depth; forces backtracking ; +; new: June 11/99 ; -; - +; shuffle_rule_list(RuleName, Type, RuleList): ; -; - +; RuleName - name of rule to make list for ; -; - +; Type - grow or full ; -; - +; RuleList - shuffled list of rule ID's ; ; - ; -; - +; Returns a shuffled list of rule ID's for given rule. ; -; - +; Grow tree has terminal and nonterminal rules shuffled together. ; -; - +; Full tree has nonterminals shuffled first, followed by terminals. ; -; - +; Idea is that rules will be tried one after another from this list. - (= - (shuffle-rule-list $RuleName grow $RuleList) + (= (shuffle-rule-list $RuleName grow $RuleList) ( (with_self (fast *) (dctg-id-table $RuleName $IDList $_ $_)) (random-permutation $IDList $RuleList) (set-det))) -; - - (= - (shuffle-rule-list $RuleName full $RuleList) + (= (shuffle-rule-list $RuleName full $RuleList) ( (with_self (fast *) (dctg-id-table $RuleName $_ $TermList $NontermList)) @@ -233,7 +172,6 @@ (random-permutation $NontermList $T2) (append $T2 $T1 $RuleList) (set-det))) -; - +; ; nonterms have precedence diff --git a/sre_dna/dctg_pp.metta b/sre_dna/dctg_pp.metta index c86d74e..10e90de 100644 --- a/sre_dna/dctg_pp.metta +++ b/sre_dna/dctg_pp.metta @@ -1,101 +1,74 @@ +; (convert_to_metta_file dctg_pp $_459326 sre_dna/dctg_pp.pl sre_dna/dctg_pp.metta) ; -; - +; Brian Ross ; -; - +; Dec 10, 1998 ; -; - +; DCTG post-processor: generates relevant tables needed by GP processing. ; ; - ; -; - +; 1. dctg_rule_info(Name, ID, Call, MinDepth, Type) ; -; - +; Name = name of rule ; -; - +; ID = DCTG ID label ; -; - +; Call = call image for DCTG rule invocation ; -; - +; MinDepth = minimum depth to terminal generation ; -; - +; Type = terminal, nonterminal ; ; - ; -; - +; 2. dctg_id_table(Name, IDList, TermList, NontermList) ; -; - +; Name = functor name ; -; - +; IDList = list of rule ID's for that functor ; -; - +; TermList, NontermList = lists of terminals, nonterminals ; ; - ; -; - +; Some assumptions: ; -; - +; - Grammar rules should be uniquely identifiable by functor name. ; -; - - +; Should not use same functor name for different arity grammar rules! - (= - (make-grammar-table) - ( (cleanup-grammar-data) - (make-rule-id-list) - (generate-rule-data) - (enhance-rule-id-list) - (set-det))) -; + (= (make-grammar-table) + (cleanup-grammar-data) + (make-rule-id-list) + (generate-rule-data) + (enhance-rule-id-list) + (set-det)) - (= - (cleanup-grammar-data) - ( (remove-all-symbols &self + (= (cleanup-grammar-data) + ( (remove-all-atoms &self (dctg_rule_info $_ $_ $_ $_)) - (remove-all-symbols &self + (remove-all-atoms &self (dctg_id_table $_ $_ $_ $_)) (set-det))) -; - ; -; - +; get_rule_name constructs a call to a DCTG rule, such that all the args are ; -; - +; variable except for the node structure, which has the ID number set. ; -; - +; This uniquely identifies a DCTG rule header. - (= - (get-rule-name $Call2) - ( (get-symbols &self + (= (get-rule-name $Call2) + ( (== (= - (semantic_rule $ID $_ $Call $_) $_)) + (semantic_rule $ID $_ $Call $_) $_) + (get-atoms &self)) (=.. $Call (Cons $Name $Args)) (clone-list $Args $T) @@ -104,168 +77,120 @@ (node $_ $_ $ID) $_ $_) $AllArgs) (=.. $Call2 (Cons $Name $AllArgs)))) -; - ; -; - +; Given a list, clone_list creates a list of the same size, ; -; - +; but with uninst. args - (= - (clone-list Nil Nil) + (= (clone-list Nil Nil) + (set-det)) + (= (clone-list (Cons $_ $T) (Cons $_ $T2)) + (clone-list $T $T2) (set-det)) -; - - (= - (clone-list - (Cons $_ $T) - (Cons $_ $T2)) - ( (clone-list $T $T2) (set-det))) -; - ; -; - +; generate_rule_data gets all the rule headers (Calls) and finds: (i) the ; -; - +; minimum depth to terminals for each rule; (ii) whether a rules is a ; -; - +; terminal or nonterminal. Result saved in dctg_rule_info/4. - (= - (generate-rule-data) - ( (findall $Call - (get-rule-name $Call) $Calls) - (rem-dups $Calls $Calls2) - (grammar-depth-top-loop $Calls2 Nil Nil $Calls3) - (grammar-type-top-loop $Calls2 Nil Nil $Terminal) - (set-rule-data $Calls3 $Terminal) - (set-det))) -; - + (= (generate-rule-data) + (findall $Call + (get-rule-name $Call) $Calls) + (rem-dups $Calls $Calls2) + (grammar-depth-top-loop $Calls2 Nil Nil $Calls3) + (grammar-type-top-loop $Calls2 Nil Nil $Terminal) + (set-rule-data $Calls3 $Terminal) + (set-det)) ; -; - +; grammar_depth_top_loop(Calls, Known, MinCalls, Known2) ; -; - +; Processes rules until all have min depths found, or no changes occurred ; -; - +; (which means there's a problem with the rules). ; -; - +; Calls - rules to process ; -; - +; Known - rules with min depths ; -; - +; MinCalls - overall minimum for entire rules, to be used in goal analysis ; -; - +; Known - new Known set ; ; - ; -; - +; Algorithm for depth determination: ; -; - +; Repeat until no unknown rules (hopefully! else there's infinite recursion) ; -; - +; Process all unknown rules: ; -; - +; If all goals have known minimum depths in a rule ; -; - +; then find maximum of these and add to Known list ; -; - +; Process all Known rules: ; -; - +; If a new rule has been added to Known (not in Minimum list) ; -; - +; then add it to Minimum list. - (= - (grammar-depth-top-loop Nil $Known $_ $Known) + (= (grammar-depth-top-loop Nil $Known $_ $Known) (set-det)) -; - - (= - (grammar-depth-top-loop $Calls $Known $MinCalls $Known3) - ( (process-rules $Calls $Known $MinCalls Nil $Known2 $Unknown) - (find-rule-mins $Known2 $MinCalls $MinCalls2) - (det-if-then-else - (, - (length $Calls $L) - (length $Unknown $L)) - (, - (write 'Problem - ') - (write $L) - (write ' rules cannot terminate:') - (nl) - (writelist $Unknown) - (nl) - (write 'these terminated - ') - (nl) - (writelist $Known2) - (nl) - (write 'These are mincalls - ') - (nl) - (writelist $MinCalls2) - (nl) - (fail)) - (grammar-depth-top-loop $Unknown $Known2 $MinCalls2 $Known3)) - (set-det))) -; - + (= (grammar-depth-top-loop $Calls $Known $MinCalls $Known3) + (process-rules $Calls $Known $MinCalls Nil $Known2 $Unknown) + (find-rule-mins $Known2 $MinCalls $MinCalls2) + (det-if-then-else + (, + (length $Calls $L) + (length $Unknown $L)) + (, + (write 'Problem - ') + (write $L) + (write ' rules cannot terminate:') + (nl) + (writelist $Unknown) + (nl) + (write 'these terminated - ') + (nl) + (writelist $Known2) + (nl) + (write 'These are mincalls - ') + (nl) + (writelist $MinCalls2) + (nl) + (fail)) + (grammar-depth-top-loop $Unknown $Known2 $MinCalls2 $Known3)) + (set-det)) +; ; if no changes... ; -; - +; process_rules(Calls, Known, MinCalls, Unknown, Known2, Unknown2): ; -; - +; Calls - to process ; -; - +; Known, Unknown - rules with known/unknown minima ; -; - +; MinCalls - solved rules (can be used in body analyses of other rules) ; -; - +; Known2, Unknown2 - final values of above ; -; - +; Find depth of body for rules. If available, add rule to Known, else Unknown. - (= - (process-rules Nil $Known $_ $Unknown $Known $Unknown) + (= (process-rules Nil $Known $_ $Unknown $Known $Unknown) (set-det)) -; - - (= - (process-rules - (Cons $Call $Rest) $Known $MinCalls $Unknown $Known2 $Unknown2) + (= (process-rules (Cons $Call $Rest) $Known $MinCalls $Unknown $Known2 $Unknown2) ( (copy-term $Call $Call2) - (get-symbols &self - (= $Call2 $Body)) + (== + (= $Call2 $Body) + (get-atoms &self)) (find-min-depth-body $Body $MinCalls 0 $BodyDepth) (set-det) (is $MinD @@ -273,436 +198,277 @@ (process-rules $Rest (Cons (, $Call $MinD) $Known) $MinCalls $Unknown $Known2 $Unknown2))) -; - - (= - (process-rules - (Cons $Call $Rest) $Known $MinCalls $Unknown $Known2 $Unknown2) - ( (set-det) (process-rules $Rest $Known $MinCalls (Cons $Call $Unknown) $Known2 $Unknown2))) -; - - -; -; - -; -; - -; -; - - - - (= - (find-min-depth-body - (, $Goal $Rest) $MinCalls $MinDSoFar $MinD) - ( (is-a-rule-call $Goal) - (set-det) - (find-min-depth $Goal $MinCalls $Val) - (is $MinDSoFar2 - (max $Val $MinDSoFar)) - (find-min-depth-body $Rest $MinCalls $MinDSoFar2 $MinD))) -; - - (= - (find-min-depth-body - (, $_ $Rest) $MinCalls $MinDSoFar $MinD) - ( (set-det) (find-min-depth-body $Rest $MinCalls $MinDSoFar $MinD))) -; - - (= - (find-min-depth-body $Goal $MinCalls $MinDSoFar $MinD) - ( (is-a-rule-call $Goal) - (set-det) - (find-min-depth $Goal $MinCalls $Val) - (is $MinD - (max $Val $MinDSoFar)))) -; - - (= - (find-min-depth-body $_ $_ $MinD $MinD) + (= (process-rules (Cons $Call $Rest) $Known $MinCalls $Unknown $Known2 $Unknown2) + (set-det) + (process-rules $Rest $Known $MinCalls + (Cons $Call $Unknown) $Known2 $Unknown2)) + +; +; find_min_depth_body(Body, MinCalls, MinDSoFar, MinD) +; +; Finds the depth value of body (max of all min vals of goals in body). +; +; Fails if an goal with unknown depth is found. + + + (= (find-min-depth-body (, $Goal $Rest) $MinCalls $MinDSoFar $MinD) + (is-a-rule-call $Goal) + (set-det) + (find-min-depth $Goal $MinCalls $Val) + (is $MinDSoFar2 + (max $Val $MinDSoFar)) + (find-min-depth-body $Rest $MinCalls $MinDSoFar2 $MinD)) + (= (find-min-depth-body (, $_ $Rest) $MinCalls $MinDSoFar $MinD) + (set-det) + (find-min-depth-body $Rest $MinCalls $MinDSoFar $MinD)) + (= (find-min-depth-body $Goal $MinCalls $MinDSoFar $MinD) + (is-a-rule-call $Goal) + (set-det) + (find-min-depth $Goal $MinCalls $Val) + (is $MinD + (max $Val $MinDSoFar))) + (= (find-min-depth-body $_ $_ $MinD $MinD) (set-det)) -; - ; -; - +; find_min_depth searches for goal name in list, and returns corresp. ; -; - - +; depth if found. - (= - (find-min-depth $Goal - (Cons - (, $G $M) $_) $M) - ( (=.. $Goal - (Cons $G $_)) (set-det))) -; - - (= - (find-min-depth $Goal - (Cons $_ $R) $M) - ( (find-min-depth $Goal $R $M) (set-det))) -; + (= (find-min-depth $Goal (Cons (, $G $M) $_) $M) + (=.. $Goal + (Cons $G $_)) + (set-det)) + (= (find-min-depth $Goal (Cons $_ $R) $M) + (find-min-depth $Goal $R $M) + (set-det)) ; -; - +; is_a_rule_call checks if a goal refers to a DCTG rule - (= - (is-a-rule-call $Goal) - ( (=.. $Goal - (Cons $Name $_)) - (dctg-id-table $Name $_ $_ $_) - (set-det))) -; - + (= (is-a-rule-call $Goal) + (=.. $Goal + (Cons $Name $_)) + (dctg-id-table $Name $_ $_ $_) + (set-det)) ; -; - +; find_rule_mins(Calls, MinCalls, MinCalls2): ; -; - +; Checks the current Known list for new overall minimum depths. ; -; - +; If a goal shows up in Known for the first time (ie. not in MinCalls) ; -; - +; then it's depth value must be the minimum for that rule set: add it as such. - (= - (find-rule-mins Nil $MinCalls $MinCalls) + (= (find-rule-mins Nil $MinCalls $MinCalls) (set-det)) -; - - (= - (find-rule-mins + (= (find-rule-mins (Cons (, $Call $Depth) $Rest) $MinCalls $MinCalls2) + (=.. $Call + (Cons $CallName $_)) + (not (member (, $CallName $_) $MinCalls)) + (set-det) + (find-rule-mins $Rest (Cons - (, $Call $Depth) $Rest) $MinCalls $MinCalls2) - ( (=.. $Call - (Cons $CallName $_)) - (not (member (, $CallName $_) $MinCalls)) - (set-det) - (find-rule-mins $Rest - (Cons - (, $CallName $Depth) $MinCalls) $MinCalls2))) -; - - (= - (find-rule-mins - (Cons $_ $Rest) $MinCalls $MinCalls2) + (, $CallName $Depth) $MinCalls) $MinCalls2)) + (= (find-rule-mins (Cons $_ $Rest) $MinCalls $MinCalls2) (find-rule-mins $Rest $MinCalls $MinCalls2)) -; - ; -; +; abstract_member checks if functor names match - - (= - (abstract-member $GoalName - (Cons - (, $First $_) $_)) + (= (abstract-member $GoalName (Cons (, $First $_) $_)) (=.. $First - (Cons $GoalName $_))) -; - - (= - (abstract-member $GoalName - (Cons $_ $Rest)) - (abstract-member $GoalName $Rest)) -; - + (Cons $GoalName $_))) + (= (abstract-member $GoalName (Cons $_ $Rest)) + (abstract-member $GoalName $Rest)) ; -; - +; find_minimum_depth(Name, Calls, MinSoFar, Min): ; -; - - - - (= - (find_minimum_depth $_ () $D $D) True) -; - - (= - (find-minimum-depth $CallName - (Cons - (, $Call $D) $Rest) $MinSoFar $MinDepth) - ( (=.. $Call - (Cons $CallName $_)) - (is $NewMin - (min $D $MinSoFar)) - (find-minimum-depth $CallName $Rest $NewMin $MinDepth) - (set-det))) -; +; Finds the minimum depth value for Name in list of Calls. - (= - (find-minimum-depth $CallName - (Cons $_ $Rest) $MinSoFar $MinDepth) - ( (find-minimum-depth $CallName $Rest $MinSoFar $MinDepth) (set-det))) -; + (= (find_minimum_depth $_ () $D $D) True) + (= (find-minimum-depth $CallName (Cons (, $Call $D) $Rest) $MinSoFar $MinDepth) + (=.. $Call + (Cons $CallName $_)) + (is $NewMin + (min $D $MinSoFar)) + (find-minimum-depth $CallName $Rest $NewMin $MinDepth) + (set-det)) + (= (find-minimum-depth $CallName (Cons $_ $Rest) $MinSoFar $MinDepth) + (find-minimum-depth $CallName $Rest $MinSoFar $MinDepth) + (set-det)) ; -; - +; grammar_type_top_loop(Calls, Terms, Nonterms, Terms2): ; -; - +; Calls - rules to process ; -; - +; Terms, Nonterms - terminals and nonterminals so far ; -; - +; Terms2 - final results of above ; ; - ; -; - +; Determine if rules can be classified as terminals. ; -; - +; Processing continues until no change in the set of rules that are unknown - ; -; - +; these leftovers are classified as 'nonterminals'. ; -; - +; First, user-override is checked. If it fail's then analysis done. ; -; - +; See 'rule_type' for more details. ; -; - +; Note that intermediate nonterminal determination is done as well; ; -; - - - - (= - (grammar-type-top-loop $Calls $Terms $Nonterms $Terms2) - ( (grammar-type-loop $Calls Nil $Terms $Nonterms $Unknown $Terms3 $Nonterms3) - (det-if-then-else - (, - (length $Calls $A) - (length $Unknown $A)) - (= $Terms3 $Terms2) - (grammar-type-top-loop $Unknown $Terms3 $Nonterms3 $Terms2)) - (set-det))) -; - +; this could be deleted in the future to save some processing. - (= - (grammar-type-loop Nil $Unknown $Term $Nonterm $Unknown $Term $Nonterm) + (= (grammar-type-top-loop $Calls $Terms $Nonterms $Terms2) + (grammar-type-loop $Calls Nil $Terms $Nonterms $Unknown $Terms3 $Nonterms3) + (det-if-then-else + (, + (length $Calls $A) + (length $Unknown $A)) + (= $Terms3 $Terms2) + (grammar-type-top-loop $Unknown $Terms3 $Nonterms3 $Terms2)) (set-det)) -; - (= - (grammar-type-loop - (Cons $Call $Rest) $Unknown $Term $Nonterm $Unknown2 $Term2 $Nonterm2) - ( (user-override $Call $Term $Nonterm $Term3 $Nonterm3) (grammar-type-loop $Rest $Unknown $Term3 $Nonterm3 $Unknown2 $Term2 $Nonterm2))) -; - (= - (grammar-type-loop - (Cons $Call $Rest) $Unknown $Term $Nonterm $Unknown2 $Term2 $Nonterm2) + (= (grammar-type-loop Nil $Unknown $Term $Nonterm $Unknown $Term $Nonterm) + (set-det)) + (= (grammar-type-loop (Cons $Call $Rest) $Unknown $Term $Nonterm $Unknown2 $Term2 $Nonterm2) + (user-override $Call $Term $Nonterm $Term3 $Nonterm3) + (grammar-type-loop $Rest $Unknown $Term3 $Nonterm3 $Unknown2 $Term2 $Nonterm2)) + (= (grammar-type-loop (Cons $Call $Rest) $Unknown $Term $Nonterm $Unknown2 $Term2 $Nonterm2) ( (copy-term $Call $Call2) - (get-symbols &self - (= $Call2 $Body)) + (== + (= $Call2 $Body) + (get-atoms &self)) (goal-type $Call $Body $Rest $Unknown $Term $Nonterm $Unknown3 $Term3 $Nonterm3) (grammar-type-loop $Rest $Unknown3 $Term3 $Nonterm3 $Unknown2 $Term2 $Nonterm2))) -; - ; -; - +; user_override(Call, Term, Nonterm, Term2, Nonterm2): ; -; - +; Call - rule head to process ; -; - +; Term, Nonterm - list of rules identified as terms and nonterms ; -; - +; Term2, Nonterm2 - final values of Term, Nonterm ; -; - +; If the user has Call functor name in dctg_override parameter lists, then ; -; - +; add that call to term or nonterm as appropriate. Otherwise, fail. - (= - (user-override $Call $Term $Nonterm - (Cons $Call $Term) $Nonterm) - ( (=.. $Call - (Cons $Name $_)) - (dctg-override-P $OverTerm $_) - (member $Name $OverTerm) - (set-det))) -; - - (= - (user-override $Call $Term $Nonterm $Term - (Cons $Call $Nonterm)) - ( (=.. $Call - (Cons $Name $_)) - (dctg-override-P $_ $OverNonterm) - (member $Name $OverNonterm) - (set-det))) -; - + (= (user-override $Call $Term $Nonterm (Cons $Call $Term) $Nonterm) + (=.. $Call + (Cons $Name $_)) + (dctg-override-P $OverTerm $_) + (member $Name $OverTerm) + (set-det)) + (= (user-override $Call $Term $Nonterm $Term (Cons $Call $Nonterm)) + (=.. $Call + (Cons $Name $_)) + (dctg-override-P $_ $OverNonterm) + (member $Name $OverNonterm) + (set-det)) ; -; - +; goal_type(Call, Body, Unknown, Term, Nonterm, Unknown2, Term2, Nonterm2) ; -; - +; Call - current head of rule being analyzed ; -; - +; Body - body of current rule ; -; - +; Rest - rules not yet processed ; -; - +; Unknown - unknown classifications ; -; - +; Term, Nonterm - Rules known to be terminal or nonterminal ; -; - +; Unknown2,Term2,Nonterm2 - Final values of results ; ; - ; -; - +; This performs abstract interp of a single rule body. ; -; - +; The order of tests in the following is critical. ; -; - +; 1. If goal is a nonterm, then that rule is a nonterm. ; -; - +; 2. If goal is same as rule name, then that rule is a nonterm. ; -; - +; 3. If a goal is unknown, or not yet processed, ; -; - +; then that rule is unknown. ; -; - +; 4. Else if the rest of the goals in that clause are term, ; -; +; then that rule is terminal. - - (= - (goal-type $Call $Goals $_ $U $T $NT $U $T - (Cons $Call $NT)) - ( (det-if-then-else - (= $Goals - (, $A $_)) True - (= $Goals $A)) - (or - (abstract-member2 $A $NT) - (same-goal $Call $A)) - (set-det))) -; - - (= - (goal-type $Call $Goals $Rest $U $T $NT - (Cons $Call $U) $T $NT) - ( (det-if-then-else - (= $Goals - (, $A $_)) True - (= $Goals $A)) - (or - (abstract-member2 $A $U) - (abstract-member2 $A $Rest)) - (set-det))) -; - - (= - (goal-type $Call - (, $_ $B) $Rest $U $T $NT $U2 $T2 $NT2) - ( (set-det) (goal-type $Call $B $Rest $U $T $NT $U2 $T2 $NT2))) -; - - (= - (goal_type $Call $_ $_ $U $T $NT $U - (Cons $Call $T) $NT) True) -; - ; -; - + (= (goal-type $Call $Goals $_ $U $T $NT $U $T (Cons $Call $NT)) + (det-if-then-else + (= $Goals + (, $A $_)) True + (= $Goals $A)) + (or + (abstract-member2 $A $NT) + (same-goal $Call $A)) + (set-det)) +; ; 1, 2 + (= (goal-type $Call $Goals $Rest $U $T $NT (Cons $Call $U) $T $NT) + (det-if-then-else + (= $Goals + (, $A $_)) True + (= $Goals $A)) + (or + (abstract-member2 $A $U) + (abstract-member2 $A $Rest)) + (set-det)) +; ; 3 + (= (goal-type $Call (, $_ $B) $Rest $U $T $NT $U2 $T2 $NT2) + (set-det) + (goal-type $Call $B $Rest $U $T $NT $U2 $T2 $NT2)) + (= (goal_type $Call $_ $_ $U $T $NT $U (Cons $Call $T) $NT) True) ; +; 4 ; -; - +; abstract_member2 checks if functor names match - (= - (abstract-member2 $Goal - (Cons $First $_)) + (= (abstract-member2 $Goal (Cons $First $_)) (same-goal $Goal $First)) -; - - (= - (abstract-member2 $Goal - (Cons $_ $Rest)) - (abstract-member2 $Goal $Rest)) -; - + (= (abstract-member2 $Goal (Cons $_ $Rest)) + (abstract-member2 $Goal $Rest)) - (= - (same-goal $A $B) - ( (=.. $A - (Cons $N $_)) - (=.. $B - (Cons $N $_)) - (set-det))) -; - + (= (same-goal $A $B) + (=.. $A + (Cons $N $_)) + (=.. $B + (Cons $N $_)) + (set-det)) ; -; +; save depths, term/nonterm in dctg_rule_info assertions - - (= - (set-rule-data Nil $_) + (= (set-rule-data Nil $_) (set-det)) -; - - (= - (set-rule-data - (Cons - (, $Rule $Depth) $Rest) $Terminal) + (= (set-rule-data (Cons (, $Rule $Depth) $Rest) $Terminal) ( (=.. $Rule (Cons $Name $Args)) (append $_ @@ -712,108 +478,70 @@ (member $Rule $Terminal) (= $Type terminal) (= $Type nonterminal)) - (add-symbol &self + (add-is-symbol &self (dctg_rule_info $Name $ID $Rule $Depth $Type)) (set-rule-data $Rest $Terminal) (set-det))) -; - ; -; - +; make_rule_id_list makes a table giving rule name and the ID numbers of its ; -; - +; associated rules. Last 2 args are placeholders for term and nonterm lists, ; -; +; to be set later. - - (= - (make-rule-id-list) - ( (findall - (, $Name $IDs) - (make-rule-id-list2 $Name $IDs) $RuleIDs) - (make-id-entries $RuleIDs) - (set-det))) -; - + (= (make-rule-id-list) + (findall + (, $Name $IDs) + (make-rule-id-list2 $Name $IDs) $RuleIDs) + (make-id-entries $RuleIDs) + (set-det)) - (= - (make-rule-id-list2 $Name $RuleIDs2) - ( (bagof $ID - (get-rule-stuff $Name $ID) $RuleIDs) (rem-dups $RuleIDs $RuleIDs2))) -; + (= (make-rule-id-list2 $Name $RuleIDs2) + (bagof $ID + (get-rule-stuff $Name $ID) $RuleIDs) + (rem-dups $RuleIDs $RuleIDs2)) - - (= - (get-rule-stuff $Name $ID) - ( (get-symbols &self + (= (get-rule-stuff $Name $ID) + ( (== (= - (semantic_rule $ID $_ $Call $_) $_)) (=.. $Call (Cons $Name $_)))) -; + (semantic_rule $ID $_ $Call $_) $_) + (get-atoms &self)) (=.. $Call (Cons $Name $_)))) - - (= - (make-id-entries Nil) + (= (make-id-entries Nil) (set-det)) -; - - (= - (make-id-entries (Cons (, $Name $IDs) $Rest)) - ( (add-symbol &self + (= (make-id-entries (Cons (, $Name $IDs) $Rest)) + ( (add-is-symbol &self (dctg_id_table $Name $IDs $_ $_)) (make-id-entries $Rest) (set-det))) -; - ; -; - +; enhance each dctg_id_table entry with list of which rules are terminal, ; -; - +; and which are nonterminal. - (= - (enhance-rule-id-list) - ( (remove-symbol &self + (= (enhance-rule-id-list) + ( (remove-is-symbol &self (dctg_id_table $Name $IDs $_ $_)) (identify-type $IDs $Terms $Nonterms) - (add-symbol &self + (add-is-symbol &self (dctg_id_table $Name $IDs $Terms $Nonterms)) (fail))) -; + (= enhance_rule_id_list True) - (= enhance_rule_id_list True) -; - - - (= - (identify_type () () ()) True) -; - - (= - (identify-type - (Cons $ID $Rest) - (Cons $ID $Terms) $Nonterms) - ( (dctg-rule-info $_ $ID $_ $_ terminal) - (set-det) - (identify-type $Rest $Terms $Nonterms))) -; - - (= - (identify-type - (Cons $ID $Rest) $Terms - (Cons $ID $Nonterms)) + (= (identify_type () () ()) True) + (= (identify-type (Cons $ID $Rest) (Cons $ID $Terms) $Nonterms) + (dctg-rule-info $_ $ID $_ $_ terminal) + (set-det) + (identify-type $Rest $Terms $Nonterms)) + (= (identify-type (Cons $ID $Rest) $Terms (Cons $ID $Nonterms)) (identify-type $Rest $Terms $Nonterms)) -; - diff --git a/sre_dna/dctg_reprod.metta b/sre_dna/dctg_reprod.metta index 7f3884e..f01fe3b 100644 --- a/sre_dna/dctg_reprod.metta +++ b/sre_dna/dctg_reprod.metta @@ -1,177 +1,136 @@ +; (convert_to_metta_file dctg_reprod $_212842 sre_dna/dctg_reprod.pl sre_dna/dctg_reprod.metta) ; -; - +; DCTG based GP reproduction operators: crossover & mutation ; -; - +; Brian Ross ; -; - +; January 25, 1999 ; -; - +; crossover(Parent1, Parent2, Child1, Child2): ; -; - +; Parent1, Parent2 - parent trees to reproduce ; -; - +; Child1, Child2 - resulting children ; -; - +; Performs grammar tree expression crossover on two parents. ; -; - +; If internal crossover probability set, then nodes of the specified type ; -; - +; are selected; else all nodes initially counted. ; -; - +; The rules for crossover are: ; -; - +; - only nodes of same rule name from each parent are crossed ; -; - +; - crossover is attempted a max N number of times until successful ; -; - +; (user-specified parameter) ; -; - +; - an attempt fails if the offspring exceed max depth parameter ; -; - +; - if no internal/leaf counting, then counts on all node names done. ; -; - +; - if internal/leaf counting to be done (case 1), then it is done only ; -; - +; for one parent. (If it fails, then 2nd parent tried; if that fails, ; -; - +; then all nodes counted from first parent). Other parent just uses ; -; - +; terminal name count (increases odds that a crossover will be ; -; - - - - (= - (crossover $P1 $P2 $C1 $C2) - ( (prob-internal-crossover-P $PI) - (not (== $P1 no)) - (det-if-then-else - (maybe $PI) - (= $Type internal) - (= $Type leaf)) - (reprod-P $Tries) - (or - (, - (once (count-nodes $P1 $Type $N1)) - (= - (, $Parent1 $Parent2) - (, $P1 $P2))) - (, - (once (count-nodes $P2 $Type $N1)) - (= - (, $Parent1 $Parent2) - (, $P2 $P1)))) - (do-crossover $Tries $Parent1 $N1 $Parent2 $C1 $C2) - (set-det))) -; - - (= - (crossover $P1 $P2 $C1 $C2) - ( (reprod-P $Tries) - (once (count-nodes $P1 all $N1)) - (do-crossover $Tries $P1 $N1 $P2 $C1 $C2) - (set-det))) -; - - - - (= - (do-crossover 0 $_ $_ $_ $_ $_) - ( (set-det) (fail))) -; - - (= - (do-crossover $_ $Parent1 $N1 $Parent2 $Child1 $Child2) - ( (my-random $N1 $K1) - (select-subtree $Parent1 $K1 $_ $Child1 $Subtree1 $Subtree2 $NodeName) - (count-nodes $Parent2 $NodeName $N2) - (my-random $N2 $K2) - (select-subtree $Parent2 $K2 $_ $Child2 $Subtree2 $Subtree1 $NodeName) - (tree-verification $Child1) - (tree-verification $Child2) - (set-det))) -; +; possible). - (= - (do-crossover $Tries $Parent1 $N1 $Parent2 $Child1 $Child2) - ( (is $Tries2 - (- $Tries 1)) - (do-crossover $Tries2 $Parent1 $N1 $Parent2 $Child1 $Child2) - (set-det))) -; + (= (crossover $P1 $P2 $C1 $C2) + (prob-internal-crossover-P $PI) + (not (== $P1 no)) + (det-if-then-else + (maybe $PI) + (= $Type internal) + (= $Type leaf)) + (reprod-P $Tries) + (or + (, + (once (count-nodes $P1 $Type $N1)) + (= + (, $Parent1 $Parent2) + (, $P1 $P2))) + (, + (once (count-nodes $P2 $Type $N1)) + (= + (, $Parent1 $Parent2) + (, $P2 $P1)))) + (do-crossover $Tries $Parent1 $N1 $Parent2 $C1 $C2) + (set-det)) +; ; case 2 + (= (crossover $P1 $P2 $C1 $C2) + (reprod-P $Tries) + (once (count-nodes $P1 all $N1)) + (do-crossover $Tries $P1 $N1 $P2 $C1 $C2) + (set-det)) +; ; case 1 + + + (= (do-crossover 0 $_ $_ $_ $_ $_) + (set-det) + (fail)) + (= (do-crossover $_ $Parent1 $N1 $Parent2 $Child1 $Child2) + (my-random $N1 $K1) + (select-subtree $Parent1 $K1 $_ $Child1 $Subtree1 $Subtree2 $NodeName) + (count-nodes $Parent2 $NodeName $N2) + (my-random $N2 $K2) + (select-subtree $Parent2 $K2 $_ $Child2 $Subtree2 $Subtree1 $NodeName) + (tree-verification $Child1) + (tree-verification $Child2) + (set-det)) +; ;writel(['A:rand pick ', K1, ' from ', N1, '.', nl]), +; ;writel(['B:rand pick ', K2, ' from ', N2, ' ', NodeName, ' nodes.', nl]), + (= (do-crossover $Tries $Parent1 $N1 $Parent2 $Child1 $Child2) + (is $Tries2 + (- $Tries 1)) + (do-crossover $Tries2 $Parent1 $N1 $Parent2 $Child1 $Child2) + (set-det)) +; ;writel(['Try ', Tries2, nl]), ; -; - +; check that a new Tree doesn't fail due to ; -; - +; failed embedded code in DCTG rules. - (= - (tree-verification $Child) - ( (det-if-then-else - (reprod-verif-P yes) - (, - (user-args-P $Args) - (verification $Child $Args $_)) True) (set-det))) -; - + (= (tree-verification $Child) + (det-if-then-else + (reprod-verif-P yes) + (, + (user-args-P $Args) + (verification $Child $Args $_)) True) + (set-det)) +; ;writel(['tree_verif: testing child:',nl]), +; ;prettyprint(Child), +; ;writel(['tree_verif: verification succeeded.',nl]) ; -; - +; count_nodes(Tree, NodeName, NumNodes): ; -; - +; Tree - DCTG expression structure ; -; - +; NodeName - name of node to count (otherwise: all nodes = 'all'; ; -; - +; all internal = 'internal'; all leaf = 'leaf') ; -; - +; NumNodes - number of nodes in Tree ; -; - +; Scans Tree and counts number of nodes. - (= - (count-nodes - (node $_ $Children $_) all $NumNodes) - ( (set-det) - (count-children-nodes $Children all $NumNodes2) - (is $NumNodes - (+ $NumNodes2 1)))) -; - - (= - (count-nodes - (node $_ $Children $ID) $Type $NumNodes) + (= (count-nodes (node $_ $Children $_) all $NumNodes) + (set-det) + (count-children-nodes $Children all $NumNodes2) + (is $NumNodes + (+ $NumNodes2 1))) + (= (count-nodes (node $_ $Children $ID) $Type $NumNodes) ( (== $Type internal) (with_self (fast *) @@ -180,11 +139,7 @@ (count-children-nodes $Children $Type $NumNodes2) (is $NumNodes (+ $NumNodes2 1)))) -; - - (= - (count-nodes - (node $_ $Children $ID) $Type $NumNodes) + (= (count-nodes (node $_ $Children $ID) $Type $NumNodes) ( (== $Type leaf) (with_self (fast *) @@ -193,11 +148,7 @@ (count-children-nodes $Children $Type $NumNodes2) (is $NumNodes (+ $NumNodes2 1)))) -; - - (= - (count-nodes - (node $_ $Children $ID) $NodeName $NumNodes) + (= (count-nodes (node $_ $Children $ID) $NodeName $NumNodes) ( (with_self (fast *) (dctg-rule-info $NodeName $ID $_ $_ $_)) @@ -205,101 +156,63 @@ (count-children-nodes $Children $NodeName $NumNodes2) (is $NumNodes (+ $NumNodes2 1)))) -; - - (= - (count-nodes - (node $_ $Children $_) $NodeName $NumNodes) - ( (set-det) (count-children-nodes $Children $NodeName $NumNodes))) -; - - (= - (count_nodes $_ $_ 0) True) -; - - - - (= - (count_children_nodes () $_ 0) True) -; - - (= - (count-children-nodes - (Cons $Node $Rest) $NodeName $NumNodes) - ( (count-nodes $Node $NodeName $NumNodes2) - (count-children-nodes $Rest $NodeName $NumNodes3) - (is $NumNodes - (+ $NumNodes2 $NumNodes3)) - (set-det))) -; - + (= (count-nodes (node $_ $Children $_) $NodeName $NumNodes) + (set-det) + (count-children-nodes $Children $NodeName $NumNodes)) + (= (count_nodes $_ $_ 0) True) + + + (= (count_children_nodes () $_ 0) True) + (= (count-children-nodes (Cons $Node $Rest) $NodeName $NumNodes) + (count-nodes $Node $NodeName $NumNodes2) + (count-children-nodes $Rest $NodeName $NumNodes3) + (is $NumNodes + (+ $NumNodes2 $NumNodes3)) + (set-det)) ; -; - +; select_subtree(Parent, K, K2, NewParent, SubTree, Hole, NodeName): ; -; - +; Parent - parent tree structure ; -; - +; K - Kth node to select in Parent; must be < number nodes in Parent. ; -; - +; K2 - final K during structure traversal ; -; - +; NewParent - Parent structure with variable Hole in place of removed ; -; - +; subtree Subtree ; -; - +; Subtree - subtree to swap ; -; - +; Hole - location of hole in ParentWithHole (variable) ; -; - +; NodeName - node name of Subtree to select from; if variable, then ; -; - +; select from all nodes ; -; - +; Selects a Kth node in tree for crossover of type NodeName (or all, if ; -; - +; NodeName not set). Sets up the new tree with Hole placeholder for selected ; -; - +; subtree. Hole may be already unified with other parent's subtree. ; -; - +; Cases: ; -; - +; 1. Count = 0, var name --> use that node ; -; - +; 2. Count = 0, name matches given --> use that node ; -; - +; 3. Count > 0, var name or name match -> count and continue ; -; - +; 4. name doesn't match given --> skip and continue ; -; - +; 5. else stop at given count (we've exhausted tree, and we're at ; -; +; non-node component) - - (= - (select-subtree - (node $_ $Kids $ID) 1 0 $NewParent - (node $NodeName $Kids $ID) $NewParent $NodeName) + (= (select-subtree (node $_ $Kids $ID) 1 0 $NewParent (node $NodeName $Kids $ID) $NewParent $NodeName) ( (or (var $NodeName) (with_self @@ -309,243 +222,186 @@ (with_self (fast *) (dctg-rule-info $NodeName $ID $_ $_ $_)))) -; - - (= - (select-subtree - (node $Name $Kids $ID) $K $K2 - (node $Name $Kids2 $ID) $Subtree $Hole $NodeName) - ( (or - (var $NodeName) - (with_self - (fast *) - (dctg-rule-info $NodeName $ID $_ $_ $_))) - (set-det) - (is $K3 - (- $K 1)) - (select-subtree-children $Kids $K3 $K2 $Kids2 $Subtree $Hole $NodeName))) -; - - (= - (select-subtree - (node $Name $Kids $ID) $K $K2 - (node $Name $Kids2 $ID) $Subtree $Hole $NodeName) - ( (set-det) (select-subtree-children $Kids $K $K2 $Kids2 $Subtree $Hole $NodeName))) -; - - (= - (select_subtree $Node $K $K $Node $_ $_ $_) True) -; - ; -; - +; ; cases 1, 2 + (= (select-subtree (node $Name $Kids $ID) $K $K2 (node $Name $Kids2 $ID) $Subtree $Hole $NodeName) + (or + (var $NodeName) + (with_self + (fast *) + (dctg-rule-info $NodeName $ID $_ $_ $_))) + (set-det) + (is $K3 + (- $K 1)) + (select-subtree-children $Kids $K3 $K2 $Kids2 $Subtree $Hole $NodeName)) +; ; case 3 + (= (select-subtree (node $Name $Kids $ID) $K $K2 (node $Name $Kids2 $ID) $Subtree $Hole $NodeName) + (set-det) + (select-subtree-children $Kids $K $K2 $Kids2 $Subtree $Hole $NodeName)) +; ; case 4 + (= (select_subtree $Node $K $K $Node $_ $_ $_) True) ; +; case 5 ; -; - +; select_subtree_children applies select_subtree to list of nodes. - (= - (select-subtree-children Nil $K $K Nil $_ $_ $_) + (= (select-subtree-children Nil $K $K Nil $_ $_ $_) (set-det)) -; - - (= - (select-subtree-children - (Cons $Node $T) $K $K2 - (Cons $Node2 $T2) $Subtree $Hole $Name) - ( (select-subtree $Node $K $K3 $Node2 $Subtree $Hole $Name) (det-if-then-else (== $K3 0) (, (= $T $T2) (= $K3 $K2)) (select-subtree-children $T $K3 $K2 $T2 $Subtree $Hole $Name)))) -; - - - - (= - (debug-crossover) - ( (dctg-root-P $Root) - (writel (:: 'Generate tree 1...' nl)) - (generate-tree $Root full 6 $_ $P1 $_) - (writel (:: 'Generate tree 2...' nl)) - (generate-tree $Root full 6 $_ $P2 $_) - (writel (:: Parent1... nl)) - (prettyprint $P1) - (writel (:: Parent2... nl)) - (prettyprint $P2) - (writel (:: 'Do the crossover...' nl)) - (crossover $P1 $P2 $C1 $C2) - (writel (:: Child1... nl)) - (prettyprint $C1) - (writel (:: Child2... nl)) - (prettyprint $C2))) -; + (= (select-subtree-children (Cons $Node $T) $K $K2 (Cons $Node2 $T2) $Subtree $Hole $Name) + (select-subtree $Node $K $K3 $Node2 $Subtree $Hole $Name) + (det-if-then-else + (== $K3 0) + (, + (= $T $T2) + (= $K3 $K2)) + (select-subtree-children $T $K3 $K2 $T2 $Subtree $Hole $Name))) + (= (debug-crossover) + (dctg-root-P $Root) + (writel (:: 'Generate tree 1...' nl)) + (generate-tree $Root full 6 $_ $P1 $_) + (writel (:: 'Generate tree 2...' nl)) + (generate-tree $Root full 6 $_ $P2 $_) + (writel (:: Parent1... nl)) + (prettyprint $P1) + (writel (:: Parent2... nl)) + (prettyprint $P2) + (writel (:: 'Do the crossover...' nl)) + (crossover $P1 $P2 $C1 $C2) + (writel (:: Child1... nl)) + (prettyprint $C1) + (writel (:: Child2... nl)) + (prettyprint $C2)) - (= - (debug-crossover2) - ( (generate-tree sentence grow 10 $_ $P1 $_) - (generate-tree sentence grow 10 $_ $P2 $_) - (crossover $P1 $P2 $C1 $C2) - (writel (:: Parent1... nl)) - (prettyprint $P1) - (writel (:: Parent2... nl)) - (prettyprint $P2) - (writel (:: Child1... nl)) - (prettyprint $C1) - (writel (:: Child2... nl)) - (prettyprint $C2))) -; + (= (debug-crossover2) + (generate-tree sentence grow 10 $_ $P1 $_) + (generate-tree sentence grow 10 $_ $P2 $_) + (crossover $P1 $P2 $C1 $C2) + (writel (:: Parent1... nl)) + (prettyprint $P1) + (writel (:: Parent2... nl)) + (prettyprint $P2) + (writel (:: Child1... nl)) + (prettyprint $C1) + (writel (:: Child2... nl)) + (prettyprint $C2)) ; -; - +; --------------------------- ; -; - +; mutation(Parent, Child): ; -; - +; Parent - tree to mutate ; -; - +; Child - mutated result ; -; - +; Performs mutation on a tree. A subtree is randomly selected. Then a ; -; - +; new subtree of the same type as selected one is generated using grow ; -; - +; generation, and it replaces the selected subtree. If the resulting tree ; -; - +; is too deep, then it is repeated a maximum number of user-specified times. ; -; - +; If the user is using terminal mutation probability (Case 1) then all nodes ; -; - +; of that type (if it succeeds statisticall) are counted. If none exist, then ; -; - - - - (= - (mutation $Parent $Child) - ( (reprod-P $Tries) - (do-mutation $Tries $Parent $Child) - (set-det))) -; - - - - (= - (do-mutation 0 $_ $_) - ( (set-det) (fail))) -; +; all nodes counted (case 2). - (= - (do-mutation $_ $Parent $Child) - ( (prob-terminal-mutation-P $PT) - (not (== $PT no)) - (det-if-then-else - (maybe $PT) - (= $Type leaf) - (= $Type internal)) - (count-nodes $Parent $Type $N) - (max-depth-P $_ $MaxDepth) - (my-random $N $K) - (select-subtree $Parent $K $_ $Child $_ $NewTree $NodeName) - (is $NewDepth - (- $MaxDepth 2)) - (generate-tree $NodeName grow $NewDepth $_ $NewTree $_) - (tree-verification $Child) - (set-det))) -; - (= - (do-mutation $_ $Parent $Child) - ( (max-depth-P $_ $MaxDepth) - (count-nodes $Parent all $N) - (my-random $N $K) - (select-subtree $Parent $K $_ $Child $_ $NewTree $NodeName) - (is $NewDepth - (- $MaxDepth 2)) - (generate-tree $NodeName grow $NewDepth $_ $NewTree $_) - (tree-verification $Child) - (set-det))) -; - - (= - (do-mutation $Tries $Parent $Child) - ( (is $Tries2 - (- $Tries 1)) - (do-mutation $Tries2 $Parent $Child) - (set-det))) -; + (= (mutation $Parent $Child) + (reprod-P $Tries) + (do-mutation $Tries $Parent $Child) + (set-det)) + (= (do-mutation 0 $_ $_) + (set-det) + (fail)) + (= (do-mutation $_ $Parent $Child) + (prob-terminal-mutation-P $PT) + (not (== $PT no)) + (det-if-then-else + (maybe $PT) + (= $Type leaf) + (= $Type internal)) + (count-nodes $Parent $Type $N) + (max-depth-P $_ $MaxDepth) + (my-random $N $K) + (select-subtree $Parent $K $_ $Child $_ $NewTree $NodeName) + (is $NewDepth + (- $MaxDepth 2)) + (generate-tree $NodeName grow $NewDepth $_ $NewTree $_) + (tree-verification $Child) + (set-det)) +; ; case 1 +; ;writel(['rand pick ', K, ' from ', N, '.', nl]), +; ; a subtree with a node type has depth > 1 + (= (do-mutation $_ $Parent $Child) + (max-depth-P $_ $MaxDepth) + (count-nodes $Parent all $N) + (my-random $N $K) + (select-subtree $Parent $K $_ $Child $_ $NewTree $NodeName) + (is $NewDepth + (- $MaxDepth 2)) + (generate-tree $NodeName grow $NewDepth $_ $NewTree $_) + (tree-verification $Child) + (set-det)) +; ; case 2 +; ;writel(['rand pick ', K, ' from ', N, '.', nl]), +; ; a subtree with a node type has depth > 1 + (= (do-mutation $Tries $Parent $Child) + (is $Tries2 + (- $Tries 1)) + (do-mutation $Tries2 $Parent $Child) + (set-det)) +; ;writel(['Try countdown... ', Tries2, nl]), - (= - (debug-mutation) - ( (dctg-root-P $Root) - (generate-tree $Root full 6 $_ $Parent $_) - (mutation $Parent $Child) - (writel (:: Parent... nl)) - (prettyprint $Parent) - (writel (:: Child... nl)) - (prettyprint $Child))) -; + (= (debug-mutation) + (dctg-root-P $Root) + (generate-tree $Root full 6 $_ $Parent $_) + (mutation $Parent $Child) + (writel (:: Parent... nl)) + (prettyprint $Parent) + (writel (:: Child... nl)) + (prettyprint $Child)) ; -; - +; --------------------------- ; -; - +; verification(Tree, UserArgs, Expr): ; -; - +; Tree - DCTG tree to verify ; -; - +; UserArgs - Argument list to pass to DCTG rules ; -; - +; Expr - list expression for Tree ; -; - +; The DCTG tree is verified by interpreting the MeTTa DCTG rules ; -; - +; in concert with the Tree structure. The purpose of this is to ; -; - +; execute any embedded MeTTa in the rules, which are ; -; - +; not retained in the tree data structure itself. User args as set by user_args ; -; - +; parameter are also used (those embedded in MeTTa structure are irrelevant). ; -; - +; This routine may cause a tree to fail, in that embedded MeTTa goals or ; -; - +; user args fail. ; -; - +; verification embeds user args into initial call of tree. - (= - (verification - (node $Name $Kids $ID) $UserArgs $Expr) + (= (verification (node $Name $Kids $ID) $UserArgs $Expr) ( (with_self (fast *) (dctg-rule-info $_ $ID $Call $_ $_)) @@ -562,86 +418,64 @@ (set-det) (verify-tree $RuleHead2 (node $Name $Kids $ID)))) -; +; ; embed user args, empty diff list - - (= - (verify-tree $Call - (node $_ $Kids $ID)) - ( (get-symbols &self - (= $Call $Body)) + (= (verify-tree $Call (node $_ $Kids $ID)) + ( (== + (= $Call $Body) + (get-atoms &self)) (same-id $Call $ID) (set-det) (verify-kids $Body $Kids $_))) -; - - (= - (verify-tree $_ $_) - ( (set-det) (fail))) -; - +; ;writel(['verify_tree: Call=', Call, 'node = ', N, ID, nl]), +; ;writel(['verify_tree: Body= ', Body, 'Kids=', Kids,nl]), + (= (verify-tree $_ $_) + (set-det) + (fail)) +; ;writel(['verify_tree: failed', nl]), - (= - (verify-kids - (, $A $B) $Kids $Kids3) - ( (set-det) - (verify-kids $A $Kids $Kids2) - (verify-kids $B $Kids2 $Kids3))) -; - - (= - (verify-kids $A - (Cons - (node $_ $Kids $ID) $Rest) $Rest) - ( (is-a-rule-call $A) - (set-det) - (verify-tree $A - (node $_ $Kids $ID)))) -; - - (= - (verify-kids - (c $A $X $B) - (Cons - (:: $H) $T) $T) - ( (set-det) - (= $X $H) - (c $A $X $B))) -; - - (= - (verify-kids - (c $A $X $B) - (Cons - (Cons $H $T2) $T) - (Cons $T2 $T)) - ( (set-det) - (= $X $H) - (c $A $X $B))) -; - - (= - (verify-kids $A $Kids $Kids) - ( (set-det) (call $A))) -; - - -; -; - - - - (= - (same-id $Call $ID) - ( (=.. $Call - (Cons $_ $Args)) - (member - (node $_ $_ $ID2) $Args) - (set-det) - (== $ID $ID2))) -; - + (= (verify-kids (, $A $B) $Kids $Kids3) + (set-det) + (verify-kids $A $Kids $Kids2) + (verify-kids $B $Kids2 $Kids3)) + (= (verify-kids $A (Cons (node $_ $Kids $ID) $Rest) $Rest) + (is-a-rule-call $A) + (set-det) + (verify-tree $A + (node $_ $Kids $ID))) +; ;writel(['v_k 2: Call=', A, 'Node name = ', N, ID, nl]), + (= (verify-kids (c $A $X $B) (Cons (:: $H) $T) $T) + (set-det) + (= $X $H) + (c $A $X $B)) +; ; single constant +; ; X == H, +; ;writel(['v_k 3: Call=', c(A,X,B), 'List=', [[H]|T], nl]), + (= (verify-kids (c $A $X $B) (Cons (Cons $H $T2) $T) (Cons $T2 $T)) + (set-det) + (= $X $H) + (c $A $X $B)) +; ; multiple constants +; ; X == H, +; ;writel(['v_k 4: Call=', c(A,X,B), 'List=', [[H|T2]|T], nl]), + (= (verify-kids $A $Kids $Kids) + (set-det) + (call $A)) +; ;writel(['v_k 5: Call=', A, 'Kids=', Kids, nl]), + +; +; Warning: user cannot use node/3 structure in their user arg fields! + + + (= (same-id $Call $ID) + (=.. $Call + (Cons $_ $Args)) + (member + (node $_ $_ $ID2) $Args) + (set-det) + (== $ID $ID2)) +; ; append(_, [node(_, _, ID)|_], Args), diff --git a/sre_dna/dctg_utils.metta b/sre_dna/dctg_utils.metta index c554b9e..8f42670 100644 --- a/sre_dna/dctg_utils.metta +++ b/sre_dna/dctg_utils.metta @@ -1,114 +1,76 @@ +; (convert_to_metta_file dctg_utils $_462940 sre_dna/dctg_utils.pl sre_dna/dctg_utils.metta) ; -; - +; Misc DCTG utilities. ; -; - +; B. Ross ; -; - +; January 1999 ; -; - - - - (= - (prettyprint $Tree) - ( (pretty $Tree 0) (set-det))) -; +; Pretty-printer... - - (= - (pretty - (node $Name $Kids $ID) $Tab) - ( (is $T - (* $Tab 4)) - (tab $T) - (writel2 (:: $Name (# $ID ',d ' $Tab ) nl)) - (is $Tab2 - (+ $Tab 1)) - (prettykids $Kids $Tab2) - (set-det))) -; - - (= - (pretty $Value $Tab) - ( (is $T - (* $Tab 4)) - (tab $T) - (writel (:: $Value nl)) - (set-det))) -; - + (= (prettyprint $Tree) + (pretty $Tree 0) + (set-det)) - (= - (prettykids Nil $_) + (= (pretty (node $Name $Kids $ID) $Tab) + (is $T + (* $Tab 4)) + (tab $T) + (writel2 (:: $Name (# $ID ',d ' $Tab ) nl)) + (is $Tab2 + (+ $Tab 1)) + (prettykids $Kids $Tab2) + (set-det)) + (= (pretty $Value $Tab) + (is $T + (* $Tab 4)) + (tab $T) + (writel (:: $Value nl)) (set-det)) -; - (= - (prettykids - (Cons $Node $Rest) $Tab) - ( (pretty $Node $Tab) - (prettykids $Rest $Tab) - (set-det))) -; + (= (prettykids Nil $_) + (set-det)) + (= (prettykids (Cons $Node $Rest) $Tab) + (pretty $Node $Tab) + (prettykids $Rest $Tab) + (set-det)) ; -; - - +; DCTG tree depth measurer... - (= - (tree-depth - (node $_ $Kids $_) $D) - ( (tree-depth-kids $Kids $D2) - (is $D - (+ $D2 1)) - (set-det))) -; - (= - (tree-depth $_ 1) + (= (tree-depth (node $_ $Kids $_) $D) + (tree-depth-kids $Kids $D2) + (is $D + (+ $D2 1)) (set-det)) -; - - - - (= - (tree-depth-kids Nil 0) + (= (tree-depth $_ 1) (set-det)) -; - (= - (tree-depth-kids - (Cons $Node $Rest) $D) - ( (tree-depth $Node $D2) - (tree-depth-kids $Rest $D3) - (is $D - (max $D2 $D3)) - (set-det))) -; + (= (tree-depth-kids Nil 0) + (set-det)) + (= (tree-depth-kids (Cons $Node $Rest) $D) + (tree-depth $Node $D2) + (tree-depth-kids $Rest $D3) + (is $D + (max $D2 $D3)) + (set-det)) ; -; - +; listprint converts tree to list, using DCTG verification - (= - (listprint $Tree) - ( (user-args-P $UserArgs) - (verification $Tree $UserArgs $List) - (writel2 $List) - (nl) - (set-det))) -; - + (= (listprint $Tree) + (user-args-P $UserArgs) + (verification $Tree $UserArgs $List) + (writel2 $List) + (nl) + (set-det)) diff --git a/sre_dna/dna_proc.metta b/sre_dna/dna_proc.metta index 200c5e5..1aee327 100644 --- a/sre_dna/dna_proc.metta +++ b/sre_dna/dna_proc.metta @@ -1,226 +1,144 @@ +; (convert_to_metta_file dna_proc $_43138 sre_dna/dna_proc.pl sre_dna/dna_proc.metta) ; -; - +; Nov/99 ; -; - +; DNA data processing ; -; - +; 1. remove duplicates ; -; - +; 2. break up upper-case constants to lists of lower-case constants - (= - (dna-proc $List $List3) - ( (remove-dups $List $List2) - (conv-to-lc-atoms $List2 $List3) - (make-new-alpha $List3))) -; - + (= (dna-proc $List $List3) + (remove-dups $List $List2) + (conv-to-lc-atoms $List2 $List3) + (make-new-alpha $List3)) ; -; - +; dna_proc2 done by unaligned processing. Pad examples with random ; -; +; alphabet. Don't filter alphabet either, like in dna_proc. + (= (dna-proc2 $List $List4) + (remove-dups $List $List2) + (conv-to-lc-atoms $List2 $List3) + (unaligned-P $_ $StrSize) + (= $List3 + (Cons $S $_)) + (length $S $L) + (is $PadSize + (integer (/ (- $StrSize $L) 2))) + (pad-randomly $List3 $PadSize $List4)) - (= - (dna-proc2 $List $List4) - ( (remove-dups $List $List2) - (conv-to-lc-atoms $List2 $List3) - (unaligned-P $_ $StrSize) - (= $List3 - (Cons $S $_)) - (length $S $L) - (is $PadSize - (integer (/ (- $StrSize $L) 2))) - (pad-randomly $List3 $PadSize $List4))) -; - - - (= - (remove-dups Nil Nil) + (= (remove-dups Nil Nil) (set-det)) -; - - (= - (remove-dups - (Cons $A $R) $S) - ( (member $A $R) - (set-det) - (remove-dups $R $S))) -; - - (= - (remove-dups - (Cons $A $R) - (Cons $A $S)) + (= (remove-dups (Cons $A $R) $S) + (member $A $R) + (set-det) + (remove-dups $R $S)) + (= (remove-dups (Cons $A $R) (Cons $A $S)) (remove-dups $R $S)) -; - - (= - (conv-to-lc-atoms Nil Nil) + (= (conv-to-lc-atoms Nil Nil) (set-det)) -; - - (= - (conv-to-lc-atoms - (Cons $A $R) - (Cons $B $S)) - ( (name $A $L) - (conv-to-lc-atoms2 $L $B) - (conv-to-lc-atoms $R $S))) -; + (= (conv-to-lc-atoms (Cons $A $R) (Cons $B $S)) + (name $A $L) + (conv-to-lc-atoms2 $L $B) + (conv-to-lc-atoms $R $S)) - - (= - (conv-to-lc-atoms2 Nil Nil) + (= (conv-to-lc-atoms2 Nil Nil) (set-det)) -; - - (= - (conv-to-lc-atoms2 - (Cons $A $R) - (Cons $B $S)) - ( (is $A2 - (+ $A 32)) - (name $B - (:: $A2)) - (conv-to-lc-atoms2 $R $S))) -; + (= (conv-to-lc-atoms2 (Cons $A $R) (Cons $B $S)) + (is $A2 + (+ $A 32)) + (name $B + (:: $A2)) + (conv-to-lc-atoms2 $R $S)) +; ; upper-case ascii to lower ascii - - (= - (sum-lengths Nil 0) + (= (sum-lengths Nil 0) (set-det)) -; - - (= - (sum-lengths - (Cons $A $R) $S) - ( (sum-lengths $R $T) - (length $A $L) - (is $S - (+ $T $L)))) -; - + (= (sum-lengths (Cons $A $R) $S) + (sum-lengths $R $T) + (length $A $L) + (is $S + (+ $T $L))) ; -; +; makes N random sequences of size =< A. + (= (make-random-strings $N $_ $_ Nil) + (=< $N 0) + (set-det)) + (= (make-random-strings $N $L $Plist (Cons $S $R)) + (is $M + (- $N 1)) + (make-random-strings $M $L $Plist $R) + (repeat) + (make-randstring $L $S) + (not (member $S $R)) + (not (member $S $Plist)) + (set-det)) - (= - (make-random-strings $N $_ $_ Nil) - ( (=< $N 0) (set-det))) -; - - (= - (make-random-strings $N $L $Plist - (Cons $S $R)) - ( (is $M - (- $N 1)) - (make-random-strings $M $L $Plist $R) - (repeat) - (make-randstring $L $S) - (not (member $S $R)) - (not (member $S $Plist)) - (set-det))) -; - - - - (= - (make-randstring $N Nil) - ( (or - (=< $N 0) maybe) (set-det))) -; - - (= - (make-randstring $N - (Cons $A $R)) - ( (alphabet-P $_ $L) - (select-rand $L $A) - (is $M - (- $N 1)) - (make-randstring $M $R))) -; + (= (make-randstring $N Nil) + (or + (=< $N 0) maybe) + (set-det)) + (= (make-randstring $N (Cons $A $R)) + (alphabet-P $_ $L) + (select-rand $L $A) + (is $M + (- $N 1)) + (make-randstring $M $R)) - (= - (make-new-alpha $List) + (= (make-new-alpha $List) ( (append-all $List Nil $All) (remove-dups $All $All2) (length $All2 $L) - (remove-symbol &self + (remove-is-symbol &self (alphabet_P $_ $_)) - (add-symbol &self + (add-is-symbol &self (alphabet_P $L $All2)) (set-det))) -; - - (= - (append-all Nil $A $A) + (= (append-all Nil $A $A) + (set-det)) + (= (append-all (Cons $A $R) $B $C) + (append $A $B $D) + (append-all $R $D $C) (set-det)) -; - (= - (append-all - (Cons $A $R) $B $C) - ( (append $A $B $D) - (append-all $R $D $C) - (set-det))) -; + (= (pad-randomly Nil $_ Nil) + (set-det)) + (= (pad-randomly (Cons $S $R) $Size (Cons $S2 $R2)) + (make-randstring3 $Size $Left) + (make-randstring3 $Size $Right) + (append $Left $S $T) + (append $T $Right $S2) + (set-det) + (pad-randomly $R $Size $R2)) - (= - (pad-randomly Nil $_ Nil) + (= (make-randstring3 $N Nil) + (=< $N 0) (set-det)) -; - - (= - (pad-randomly - (Cons $S $R) $Size - (Cons $S2 $R2)) - ( (make-randstring3 $Size $Left) - (make-randstring3 $Size $Right) - (append $Left $S $T) - (append $T $Right $S2) - (set-det) - (pad-randomly $R $Size $R2))) -; - - - - (= - (make-randstring3 $N Nil) - ( (=< $N 0) (set-det))) -; - - (= - (make-randstring3 $N - (Cons $A $R)) - ( (alphabet-P $_ $L) - (select-rand $L $A) - (is $M - (- $N 1)) - (make-randstring3 $M $R))) -; - + (= (make-randstring3 $N (Cons $A $R)) + (alphabet-P $_ $L) + (select-rand $L $A) + (is $M + (- $N 1)) + (make-randstring3 $M $R)) diff --git a/sre_dna/dynamics.metta b/sre_dna/dynamics.metta index 85431f9..a7c6379 100644 --- a/sre_dna/dynamics.metta +++ b/sre_dna/dynamics.metta @@ -1,59 +1,30 @@ +; (convert_to_metta_file dynamics $_152978 sre_dna/dynamics.pl sre_dna/dynamics.metta) ; -; - +; ------------------------------------------------ ; -; - +; January 1999 ; -; - +; Author: Brian Ross ; -; - +; Dept. of Computer Science, Brock University ; ; - ; -; - +; dynamic definitions (make this the first file loaded) !(dynamic (/ individual 3)) -; - !(dynamic (/ newindividual 3)) -; - !(dynamic (/ popn-size-P 1)) -; - !(dynamic (/ best-so-far 4)) -; - !(dynamic (/ best-in-run 3)) -; - !(dynamic (/ gp-stats 8)) -; - !(dynamic (/ trace-count 2)) -; - !(dynamic (/ saved-trace 1)) -; - !(dynamic (/ popn-cnt 1)) -; - !(dynamic (/ current-run 1)) -; - !(dynamic (/ temp 1)) -; - - !(dynamic (/ expression-type 1)) -; - + !(dynamic (/ expression-type 1)) diff --git a/sre_dna/evaluation.metta b/sre_dna/evaluation.metta index 02c597a..931786b 100644 --- a/sre_dna/evaluation.metta +++ b/sre_dna/evaluation.metta @@ -1,69 +1,51 @@ +; (convert_to_metta_file evaluation $_217042 sre_dna/evaluation.pl sre_dna/evaluation.metta) ; -; - +; ------------------------------------------------ ; -; - +; January 1999 ; -; - +; Author: Brian Ross ; -; - +; Dept. of Computer Science, Brock University ; ; - ; -; - +; Fitness evaluation. ; ; - ; -; - +; Evaluator/2 is user-supplied fitness function. ; -; - +; It is then applied to initial population, which ; -; - +; are reasserted with their fitness scores. ; ; - ; -; - +; The problem-specific evaluator should assign individuals a standardized ; -; - +; fitness value (lower score is better, 0 is perfect). ; -; +; It's syntax must be: evaluator(Expr, Val) - - (= - (genesis) - ( (population-size-P $InitPopSize $PopSize) - (ramped-population $InitPopSize) - (nl) - (evalInitialPopn) - (writel (:: nl '*** Culling population' nl)) - (cull-population $InitPopSize $PopSize) - (collect-stats (- 0 culled)) - (set-det))) -; - + (= (genesis) + (population-size-P $InitPopSize $PopSize) + (ramped-population $InitPopSize) + (nl) + (evalInitialPopn) + (writel (:: nl '*** Culling population' nl)) + (cull-population $InitPopSize $PopSize) + (collect-stats (- 0 culled)) + (set-det)) ; -; +; following only used for initial population... - - (= - (evalInitialPopn) - ( (remove-symbol &self + (= (evalInitialPopn) + ( (remove-is-symbol &self (individual $ID $Fitness $Expression)) (det-if-then-else (var $Fitness) @@ -71,35 +53,24 @@ (eval-with-ID-P yes) (evaluator $ID $Expression $Fitness) (evaluator $Expression $Fitness)) True) - (add-symbol &self + (add-is-symbol &self (individual $ID $Fitness $Expression)) (write ?) (ttyflush) (fail))) -; - - (= - (evalInitialPopn) +; ; only reevaluate if not scored + (= (evalInitialPopn) (collect-stats (- 0 genesis))) -; - - (= - (cull-population $PopSize $PopSize) + (= (cull-population $PopSize $PopSize) (set-det)) -; - - (= - (cull-population $InitPopSize $PopSize) - ( (< $InitPopSize $PopSize) - (set-det) - (writel (:: 'Error: init pop size ' $InitPopSize '< pop size' $PopSize nl)) - (fail))) -; - - (= - (cull-population $_ $PopSize) + (= (cull-population $InitPopSize $PopSize) + (< $InitPopSize $PopSize) + (set-det) + (writel (:: 'Error: init pop size ' $InitPopSize '< pop size' $PopSize nl)) + (fail)) + (= (cull-population $_ $PopSize) ( (cull-method-P elite) (set-det) (write Culling...) @@ -108,39 +79,32 @@ (, $V $K $E) (individual $K $V $E) $Set) (first-K 0 $PopSize $Set $Set2) - (remove-all-symbols &self + (remove-all-atoms &self (individual $_ $_ $_)) (assert-elite $Set2))) -; - - (= - (cull-population $CurrPopSize $PopSize) + (= (cull-population $CurrPopSize $PopSize) ( (tournament-select worst $CurrPopSize $ID $_) (write x) (ttyflush) - (remove-symbol &self + (remove-is-symbol &self (individual $ID $_ $_)) (det-if-then-else (\== $ID $CurrPopSize) (, - (remove-symbol &self + (remove-is-symbol &self (individual $CurrPopSize $Fit $Expr)) - (add-symbol &self + (add-is-symbol &self (individual $ID $Fit $Expr))) True) (is $NewPopSize (- $CurrPopSize 1)) (set-det) (cull-population $NewPopSize $PopSize))) -; - ; -; +; save best in run and best so far (session) - - (= - (set-best-in-run $Gen) + (= (set-best-in-run $Gen) ( (bagof $V (^ $E (^ $ID @@ -150,51 +114,33 @@ (< $Min $BestSoFar) (set-det) (individual $_ $Min $Expression) - (remove-symbol &self + (remove-is-symbol &self (best_in_run $_ $_ $_)) - (add-symbol &self + (add-is-symbol &self (best_in_run $Gen $Min $Expression)))) -; - - (= - (set_best_in_run $_) True) -; + (= (set_best_in_run $_) True) - - (= - (set-best-so-far $Run) + (= (set-best-so-far $Run) ( (best-in-run $Gen $Value $Expr) (best-so-far $_ $_ $BV $_) (< $Value $BV) (set-det) - (remove-symbol &self + (remove-is-symbol &self (best_so_far $_ $_ $_ $_)) - (add-symbol &self + (add-is-symbol &self (best_so_far $Run $Gen $Value $Expr)))) -; - - (= - (set_best_so_far $_) True) -; - + (= (set_best_so_far $_) True) ; -; +; assert_elite asserts individuals into population.... - - (= - (assert-elite Nil) + (= (assert-elite Nil) (set-det)) -; - - (= - (assert-elite (Cons (, $V $K $E) $R)) - ( (add-symbol &self + (= (assert-elite (Cons (, $V $K $E) $R)) + ( (add-is-symbol &self (individual $K $V $E)) (assert-elite $R) (set-det))) -; - diff --git a/sre_dna/file_stats.metta b/sre_dna/file_stats.metta index 22aacc9..5e05abb 100644 --- a/sre_dna/file_stats.metta +++ b/sre_dna/file_stats.metta @@ -1,60 +1,45 @@ +; (convert_to_metta_file file_stats $_315714 sre_dna/file_stats.pl sre_dna/file_stats.metta) ; -; - +; ------------------------------------------------ ; -; - +; Jan 1999 ; -; - +; Author: Brian Ross ; -; - +; Dept. of Computer Science, Brock University ; ; - ; -; - +; Statistics and I/O !(expects-dialect sicstus) -; - !(use-module (library (/ (/ dialect sicstus) system))) -; - - - (= - (print-tourn-stats $Gen) - ( (collect-stats $Gen) - (gp-stats $Gen $Time $Best $Worst $Avg $AvgD $Lamarck) - (det-if-then-else - (var $Lamarck) - (= $Lamarck - (lamarck 0 0 0)) True) - (print-stat $Gen $Time $Best $Worst $Avg $AvgD $Lamarck) - (det-if-then-else - (popn-dump-P yes) - (dump-population $Gen) True) - (set-det))) -; + (= (print-tourn-stats $Gen) + (collect-stats $Gen) + (gp-stats $Gen $Time $Best $Worst $Avg $AvgD $Lamarck) + (det-if-then-else + (var $Lamarck) + (= $Lamarck + (lamarck 0 0 0)) True) + (print-stat $Gen $Time $Best $Worst $Avg $AvgD $Lamarck) + (det-if-then-else + (popn-dump-P yes) + (dump-population $Gen) True) + (set-det)) +; ; should replace with param passing ; -; - +; collect_stats computes some statistics. gp_stats might already be ; -; - +; asserted for generation by Lamarckian evol routine, if used. Retract it, ; -; - +; but retain it's stat. - (= - (collect-stats $Gen) + (= (collect-stats $Gen) ( (bagof $V (^ $E (^ $ID @@ -85,9 +70,9 @@ (since-last-datime total call $HourT $MinuteT $SecT) (since-last-datime generation retract $Hour $Minute $Sec) (or - (remove-symbol &self + (remove-is-symbol &self (gp_stats $Gen $_ $_ $_ $_ $_ $_ $Lamarck)) True) - (add-symbol &self + (add-is-symbol &self (gp_stats $Gen (: $Hour (: $Minute @@ -98,276 +83,234 @@ (worst $Max $SizeW) (avg $Avg) $AvgDepth $Lamarck)) (set-det))) -; - - - - (= - (since-last-datime $For $SetReset $Hour $Minute $Sec) - ( (once (or (call $SetReset (got-time $For $Was)) (= $Was 0))) - (get-time $Now) - (is $DiffTime - (- $Now $Was)) - (det-if-then-else - (== $SetReset retract) - (add-symbol &self - (got_time $For $Now)) True) - (stamp-date-time $DiffTime - (date $Year $Month $Day $Hour $Minute $Sec $_ $_ $_) UTC) - (set-det))) -; - +; ;time_stamp(';h:;02i:;02s;a',T), +; ; datime(datime(_,_,_,Hour,Minute,Sec)), + + + (= (since-last-datime $For $SetReset $Hour $Minute $Sec) + (once (or (call $SetReset (got-time $For $Was)) (= $Was 0))) + (get-time $Now) + (is $DiffTime + (- $Now $Was)) + (det-if-then-else + (== $SetReset retract) + (add-is-symbol &self + (got_time $For $Now)) True) + (stamp-date-time $DiffTime + (date $Year $Month $Day $Hour $Minute $Sec $_ $_ $_) UTC) + (set-det)) !(dynamic (/ got-time 2)) -; - !((get-time $Now) - (add-symbol &self + (add-is-symbol &self (got_time total $Now)) - (add-symbol &self + (add-is-symbol &self (got_time total $Now))) -; - ; -; - - - (= - (dump-stats $Run) - ( (wd-P $Dir) - (working-directory $_ $Dir) - (set-file-name "stats" $Run $File) - (tell $File) - (since-last-datime total retract $Hour $Min $Sec) - (datime (datime $Year $Month $Day $DA_Hour $DA_Min $DA_Sec)) - (writel (:: nl nl '***** Summary statistics: Run ' $Run ***** nl nl (with_self (- (- (- $Year $Month) $Day) $Hour) (with_self $Min $Sec)) nl nl)) - (gp-stats $Gen $Time $Best $Worst $Avg $AvgDepth $Lamarck) - (det-if-then-else - (var $Lamarck) - (= $Lamarck - (lamarck 0 0 0)) True) - (print-stat $Gen $Time $Best $Worst $Avg $AvgDepth $Lamarck) - (fail))) -; - ; -; - - (= - (dump-stats $Run) - ( (nl) - (nl) - (population-size-P $InitPopSize $PopSize) - (max-runs-P $MaxRun $RunSoln $MaxGen) - (prob-crossover-P $PC) - (prob-internal-crossover-P $PIC) - (prob-terminal-mutation-P $PTM) - (max-depth-P $DepthInit $DepthCross) - (error-tolerance-P $Err) - (fitness-func-P $FitFile) - (dctg-file-P $FileDCTG) - (evaluator-reset-P $EvalReset $N) - (gen-type-P $GenType) - (best-in-run $Bgen $Fitness $Expr) - (count-nodes $Expr all $ENodeCnt) - (tree-depth $Expr $Edepth) - (tournament-size-P $TS $TR) - (lamarckian-P $LP $LK $Lsel $LCross) - (unique-population-P $Unique) - (seed-P $RanMode $Y) - (min-grammar-prob-P $MinProb) - (gen-set-size-P $GenSet) - (sre-mintestcnt-P $Mintst) - (max-string-length-P $Maxstr) - (writel (:: nl 'Best Soln:' $Expr nl)) - (^^ $Expr - (construct $E)) - (write 'Expression: ') - (sre-pp $E) - (nl) - (writel (:: 'found at generation ' $Bgen nl 'Soln # nodes:' $ENodeCnt nl 'Soln depth:' $Edepth nl 'Soln Fitness = ' $Fitness nl)) - (det-if-then-else - (gp-stats $MaxGen $_ - (best $MinLast $_ $BexprLast) $_ $_ $_ $_) - (, - (count-nodes $BexprLast all $ENodeCntLast) - (tree-depth $BexprLast $EdepthLast) - (writel (:: nl 'Best Last Gen' $MaxGen : $BexprLast nl)) - (^^ $BexprLast - (construct $ELast)) - (write 'Expression: ') - (sre-pp $ELast) - (nl) - (writel (:: 'Last # nodes:' $ENodeCntLast nl 'Last depth:' $EdepthLast nl 'Last Fitness = ' $MinLast nl))) True) - (writel (:: ------- nl 'Fitness func file:' $FitFile nl 'DCTG file:' $FileDCTG nl 'Evaluator reset:' $EvalReset ' N:' $N nl 'Generation type:' $GenType nl 'Init pop size = ' $InitPopSize nl 'Pop size = ' $PopSize nl 'Max runs = ' $MaxRun , $RunSoln nl 'Max gen = ' $MaxGen nl 'Prob crossover = ' $PC nl 'Prob int cross = ' $PIC nl 'Prob term mutation = ' $PTM nl 'Tournament size: sel = ' $TS ' repl = ' $TR nl 'Lamarckian: ' $LP 'of popn, iterate = ' $LK ', select = ' $Lsel ', Prob Cross=' $LCross nl 'Unique popn = ' $Unique nl 'Random seed:' $RanMode ', Y=' $Y nl 'Max depth init = ' $DepthInit nl 'Max depth crossover = ' $DepthCross nl 'Initial test set size =' $GenSet nl 'Max test set string length =' $Maxstr nl 'Minimum test set count =' $Mintst nl 'Min grammar probability =' $MinProb nl 'Error tolerance = ' $Err nl)) - (writel (:: '*** End of Run ' $Run *** nl)) - (told) - (tell user) - (write-soln "soln" $Run $Expr))) -; - ; -; - +; print run statistics + + (= (dump-stats $Run) + (wd-P $Dir) + (working-directory $_ $Dir) + (set-file-name "stats" $Run $File) + (tell $File) + (since-last-datime total retract $Hour $Min $Sec) + (datime (datime $Year $Month $Day $DA_Hour $DA_Min $DA_Sec)) + (writel (:: nl nl '***** Summary statistics: Run ' $Run ***** nl nl (with_self (- (- (- $Year $Month) $Day) $Hour) (with_self $Min $Sec)) nl nl)) + (gp-stats $Gen $Time $Best $Worst $Avg $AvgDepth $Lamarck) + (det-if-then-else + (var $Lamarck) + (= $Lamarck + (lamarck 0 0 0)) True) + (print-stat $Gen $Time $Best $Worst $Avg $AvgDepth $Lamarck) + (fail)) +; ; Windows +; ; Windows +; ;once(time_stamp('Date: ;W, ;d ;M ;y Time: ;c:;02i;a', DateTime)), +; ; loops for all ; +; loop driver + (= (dump-stats $Run) + (nl) + (nl) + (population-size-P $InitPopSize $PopSize) + (max-runs-P $MaxRun $RunSoln $MaxGen) + (prob-crossover-P $PC) + (prob-internal-crossover-P $PIC) + (prob-terminal-mutation-P $PTM) + (max-depth-P $DepthInit $DepthCross) + (error-tolerance-P $Err) + (fitness-func-P $FitFile) + (dctg-file-P $FileDCTG) + (evaluator-reset-P $EvalReset $N) + (gen-type-P $GenType) + (best-in-run $Bgen $Fitness $Expr) + (count-nodes $Expr all $ENodeCnt) + (tree-depth $Expr $Edepth) + (tournament-size-P $TS $TR) + (lamarckian-P $LP $LK $Lsel $LCross) + (unique-population-P $Unique) + (seed-P $RanMode $Y) + (min-grammar-prob-P $MinProb) + (gen-set-size-P $GenSet) + (sre-mintestcnt-P $Mintst) + (max-string-length-P $Maxstr) + (writel (:: nl 'Best Soln:' $Expr nl)) + (^^ $Expr + (construct $E)) + (write 'Expression: ') + (sre-pp $E) + (nl) + (writel (:: 'found at generation ' $Bgen nl 'Soln # nodes:' $ENodeCnt nl 'Soln depth:' $Edepth nl 'Soln Fitness = ' $Fitness nl)) + (det-if-then-else + (gp-stats $MaxGen $_ + (best $MinLast $_ $BexprLast) $_ $_ $_ $_) + (, + (count-nodes $BexprLast all $ENodeCntLast) + (tree-depth $BexprLast $EdepthLast) + (writel (:: nl 'Best Last Gen' $MaxGen : $BexprLast nl)) + (^^ $BexprLast + (construct $ELast)) + (write 'Expression: ') + (sre-pp $ELast) + (nl) + (writel (:: 'Last # nodes:' $ENodeCntLast nl 'Last depth:' $EdepthLast nl 'Last Fitness = ' $MinLast nl))) True) + (writel (:: ------- nl 'Fitness func file:' $FitFile nl 'DCTG file:' $FileDCTG nl 'Evaluator reset:' $EvalReset ' N:' $N nl 'Generation type:' $GenType nl 'Init pop size = ' $InitPopSize nl 'Pop size = ' $PopSize nl 'Max runs = ' $MaxRun , $RunSoln nl 'Max gen = ' $MaxGen nl 'Prob crossover = ' $PC nl 'Prob int cross = ' $PIC nl 'Prob term mutation = ' $PTM nl 'Tournament size: sel = ' $TS ' repl = ' $TR nl 'Lamarckian: ' $LP 'of popn, iterate = ' $LK ', select = ' $Lsel ', Prob Cross=' $LCross nl 'Unique popn = ' $Unique nl 'Random seed:' $RanMode ', Y=' $Y nl 'Max depth init = ' $DepthInit nl 'Max depth crossover = ' $DepthCross nl 'Initial test set size =' $GenSet nl 'Max test set string length =' $Maxstr nl 'Minimum test set count =' $Mintst nl 'Min grammar probability =' $MinProb nl 'Error tolerance = ' $Err nl)) + (writel (:: '*** End of Run ' $Run *** nl)) + (told) + (tell user) + (write-soln "soln" $Run $Expr)) +; ; from gp_parameters file... +; ;crossover_P(PIC, PTC), +; ;rep_limit_P(Rep), +; ; some other stats... +; ;sre_mutation_P(SREmut), +; ;mutation_range_P(Mutrange), +; ; if last generation never reached (soln found before) +; ;'SRE numeric mutation rate =', SREmut, nl, +; ;'SRE mutation range = +/-',Mutrange,nl, +; ;write('Best...'), nl, dna_summary(Expr), ; for DNA only +; ;write('Best optimized...'), nl, +; ;mask_optimize(Expr, Fitness, ExprOpt), +; ;dna_summary(ExprOpt), ; for DNA only +; /* (gp_stats(MaxGen,_, best(MinLast, _, BexprLast), _, _, _, _) -> write('Last...'), nl, dna_summary(BexprLast), mask_optimize(BexprLast, MinLast, LastOpt), ; for DNA only write('Last optimized...'), nl, dna_summary(LastOpt) ; true), */ ; +; <-- new. ; -; - +; write_soln("solnopt", Run, ExprOpt). ; <-- new. - (= - (set-file-name $RootName $Run $File) - ( (append $RootName "-" $File0) - (name $Run $File1) - (append $File0 $File1 $File2) - (datime (datime $Year $Month $Day $Hour $Min $Sec)) - (name $Year $N1) - (name $Month $N2) - (name $Day $N3) - (name $Hour $N4) - (name $Min $N5) - (name $Sec $N6) - (append $N3 $N2 $N1a) - (append $N1a $N1 $N1b) - (append $N1b "-" $N1c) - (append $N1c $N4 $N1d) - (append $N1d $N5 $N1e) - (append $N1e $N6 $File3) - (append $File2 $File3 $File4) - (append $File4 ".txt" $File5) - (name $File $File5) - (set-det))) -; - + (= (set-file-name $RootName $Run $File) + (append $RootName "-" $File0) + (name $Run $File1) + (append $File0 $File1 $File2) + (datime (datime $Year $Month $Day $Hour $Min $Sec)) + (name $Year $N1) + (name $Month $N2) + (name $Day $N3) + (name $Hour $N4) + (name $Min $N5) + (name $Sec $N6) + (append $N3 $N2 $N1a) + (append $N1a $N1 $N1b) + (append $N1b "-" $N1c) + (append $N1c $N4 $N1d) + (append $N1d $N5 $N1e) + (append $N1e $N6 $File3) + (append $File2 $File3 $File4) + (append $File4 ".txt" $File5) + (name $File $File5) + (set-det)) +; /* (gp_stats(MaxGen,_, best(MinLast, _, BexprLast), _, _, _, _) -> write_soln("last", Run, BexprLast), ; <-- new write_soln("lastopt", Run, LastOpt) ; true). */ +; ; dump_population(Run). +; ;once(time_stamp('.;d;02n;02y-;02c;02i', Name3)), +; ;name(Name3, File3), - (= - (print-stat $Gen $Time - (best $Bfit $Bcount $Bexpr) - (worst $Wfit $Wcount) - (avg $Avg) $AvgD $_) - ( (lamarckian-P 0.0 $_ $_ $_) - (set-det) - (writel (:: nl nl '---> Generation ' $Gen ( $Time ) nl 'Average fitness:' $Avg nl 'Best count: ' $Bcount nl 'Best example:' $Bexpr nl 'Best fitness = ' $Bfit nl 'Worst count: ' $Wcount nl 'Worst fitness = ' $Wfit nl 'Average Depth:' $AvgD nl 'Lamarckian evolution: off ' nl nl)) - (set-det))) -; - - (= - (print-stat $Gen $Time - (best $Bfit $Bcount $Bexpr) - (worst $Wfit $Wcount) - (avg $Avg) $AvgD - (lamarck $FitImpr $MaxImpr $NumGain)) - ( (lamarckian-P $Percent $_ $_ $_) - (population-size-P $_ $PopSize) - (is $N - (integer (* $Percent $PopSize))) - (det-if-then-else - (> $NumGain 0) - (is $AvgLam - (/ $FitImpr $NumGain)) - (= $AvgLam 0)) - (writel (:: nl nl '---> Generation ' $Gen ( $Time ) nl 'Average fitness:' $Avg nl 'Best count: ' $Bcount nl 'Best example:' $Bexpr nl 'Best fitness = ' $Bfit nl 'Worst count: ' $Wcount nl 'Worst fitness = ' $Wfit nl 'Average Depth:' $AvgD nl 'Lamarckian evolution: ' nl $NumGain ' gains out of ' $N ' tries' nl ' Total gain:' $FitImpr nl ' Max single gain:' $MaxImpr nl ' Avg gain:' $AvgLam nl nl)) - (set-det))) -; - + (= (print-stat $Gen $Time (best $Bfit $Bcount $Bexpr) (worst $Wfit $Wcount) (avg $Avg) $AvgD $_) + (lamarckian-P 0.0 $_ $_ $_) + (set-det) + (writel (:: nl nl '---> Generation ' $Gen ( $Time ) nl 'Average fitness:' $Avg nl 'Best count: ' $Bcount nl 'Best example:' $Bexpr nl 'Best fitness = ' $Bfit nl 'Worst count: ' $Wcount nl 'Worst fitness = ' $Wfit nl 'Average Depth:' $AvgD nl 'Lamarckian evolution: off ' nl nl)) + (set-det)) + (= (print-stat $Gen $Time (best $Bfit $Bcount $Bexpr) (worst $Wfit $Wcount) (avg $Avg) $AvgD (lamarck $FitImpr $MaxImpr $NumGain)) + (lamarckian-P $Percent $_ $_ $_) + (population-size-P $_ $PopSize) + (is $N + (integer (* $Percent $PopSize))) + (det-if-then-else + (> $NumGain 0) + (is $AvgLam + (/ $FitImpr $NumGain)) + (= $AvgLam 0)) + (writel (:: nl nl '---> Generation ' $Gen ( $Time ) nl 'Average fitness:' $Avg nl 'Best count: ' $Bcount nl 'Best example:' $Bexpr nl 'Best fitness = ' $Bfit nl 'Worst count: ' $Wcount nl 'Worst fitness = ' $Wfit nl 'Average Depth:' $AvgD nl 'Lamarckian evolution: ' nl $NumGain ' gains out of ' $N ' tries' nl ' Total gain:' $FitImpr nl ' Max single gain:' $MaxImpr nl ' Avg gain:' $AvgLam nl nl)) + (set-det)) ; -; - - - - (= - (dump-population $Run) - ( (set-file-name "popn" $Run $File) - (tell $File) - (individual $ID $V $Expr) - (write-individual $ID $V $Expr) - (fail))) -; - - (= - (dump-population $_) - ( (told) (tell user))) -; - - - - (= - (write-individual $ID $V $Expr) - ( (writel (:: ----- nl 'Individual ' $ID ': fit=' $V nl $Expr nl)) - (^^ $Expr - (construct $E)) - (sre-pp $E) - (nl) - (set-det))) -; - +; print existing population + + + (= (dump-population $Run) + (set-file-name "popn" $Run $File) + (tell $File) + (individual $ID $V $Expr) + (write-individual $ID $V $Expr) + (fail)) + (= (dump-population $_) + (told) + (tell user)) + + + (= (write-individual $ID $V $Expr) + (writel (:: ----- nl 'Individual ' $ID ': fit=' $V nl $Expr nl)) + (^^ $Expr + (construct $E)) + (sre-pp $E) + (nl) + (set-det)) ; -; - +; ------------------------------------ ; -; - +; solution dump: writes soln expression to a file, for input later. ; -; - +; Grammatical expression is written in multiple lines, since the full ; -; - - - - (= - (write-soln $Name $Run $E) - ( (set-file-name $Name $Run $File) - (tell $File) - (write soln() - (write-term $E) - (write ).) - (nl) - (told) - (tell user) - (set-det))) -; - - +; expression is often larger than MeTTa's builtin "write" can handle. + + + (= (write-soln $Name $Run $E) + (set-file-name $Name $Run $File) + (tell $File) + (write soln() + (write-term $E) + (write ).) + (nl) + (told) + (tell user) + (set-det)) - (= - (write-term (node $X $List $Y)) - ( (set-det) - (write node() - (write $X) - (write ,[) - (write-tlist $List) - (write ],) - (write $Y) - (write )))) -; - (= - (write-term $X) + (= (write-term (node $X $List $Y)) + (set-det) + (write node() + (write $X) + (write ,[) + (write-tlist $List) + (write ],) + (write $Y) + (write ))) + (= (write-term $X) (write $X)) -; - - (= - (write-tlist Nil) + (= (write-tlist Nil) (set-det)) -; - - (= - (write-tlist (Cons $X (Cons $Y $Z))) - ( (set-det) - (write-term $X) - (write ,) - (nl) - (write-tlist (Cons $Y $Z)))) -; - - (= - (write-tlist (:: $X)) + (= (write-tlist (Cons $X (Cons $Y $Z))) + (set-det) + (write-term $X) + (write ,) + (nl) + (write-tlist (Cons $Y $Z))) + (= (write-tlist (:: $X)) (write-term $X)) -; - diff --git a/sre_dna/generate.metta b/sre_dna/generate.metta index 92a30f1..4fd63e0 100644 --- a/sre_dna/generate.metta +++ b/sre_dna/generate.metta @@ -1,77 +1,54 @@ +; (convert_to_metta_file generate $_59478 sre_dna/generate.pl sre_dna/generate.metta) ; -; - +; ------------------------------------------------ ; -; - +; Jan 99 ; -; - +; Author: Brian Ross ; -; - +; Dept. of Computer Science, Brock University ; ; - ; -; - +; Random generation of CCS expressions. ; -; - +; As in Koza, a ramped half-and-half approach used: ; ; - ; -; - +; If depth = M, then equal spread of trees of approx. depth 2, 3, ..., M. ; -; - +; Tree sizes not precise: list terms (restrict, relabel) can vary as much ; -; - +; as +4 (or more?), because I'm avoiding backtracking for tree depth size. ; -; - +; For each depth category, rougly equal split attempted between full ; -; - +; and grow trees. ; -; - +; Full tries to get full depth on all branches. ; -; - +; Growth trees are irregularly shaped. ; -; - +; The generation cycles between them and depth size. Cycling done to ; -; - +; reduce duplicates that are common with grow tree generation. ; ; - ; -; - +; ramped_population: create a population using ramped approach. ; -; - +; Equal spread of trees using full and growth generation, and of size ; -; - +; 2, 3, ..., MaxDepth. ; -; - +; First, old population in individual/3 retracted. ; -; +; All expressions asserted into: individual(ID, Val, Expr). - - (= - (ramped-population $PopSize) - ( (remove-all-symbols &self + (= (ramped-population $PopSize) + ( (remove-all-atoms &self (individual $_ $_ $_)) (max-depth-P $MaxDepth $_) (dctg-root-P $Root) @@ -86,176 +63,130 @@ (populate $MinDepth $MaxDepth $MinDepth grow 0 $PopSize) (number-population) (set-det))) -; - ; -; - +; populate(D, MaxDepth, MinDepth, Type, CurrPopn, PopSize) loops until PopSize ; -; - +; individuals created. Depth D goes between 2 and MaxDepth. Type toggles ; -; - +; between grow and full. - (= - (populate $_ $_ $_ $_ $MaxPopn $MaxPopn) + (= (populate $_ $_ $_ $_ $MaxPopn $MaxPopn) (set-det)) -; - - (= - (populate $D $MaxD $MinD $Type $Popn $MaxPopn) - ( (> $D $MaxD) - (set-det) - (populate $MinD $MaxD $MinD $Type $Popn $MaxPopn))) -; - - (= - (populate $D $MaxD $MinD grow $Popn $MaxPopn) - ( (prob-grow-P $Pgrow) - (maybe $Pgrow) - (make-individual $D grow $Popn $Popn2) - (set-det) - (populate $D $MaxD $MinD full $Popn2 $MaxPopn))) -; - - (= - (populate $D $MaxD $MinD $Type $Popn $MaxPopn) - ( (make-individual $D full $Popn $Popn2) - (is $D2 - (+ $D 1)) - (set-det) - (toggle-type $Type $Type2) - (populate $D2 $MaxD $MinD $Type2 $Popn2 $MaxPopn))) -; - - (= - (populate $D $MaxD $MinD $Type $Popn $MaxPopn) - ( (set-det) (populate $D $MaxD $MinD $Type $Popn $MaxPopn))) -; - - - - (= - (toggle_type grow full) True) -; - - (= - (toggle_type full grow) True) -; - - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - - - (= - (make-individual $Depth $Type $Popn $NewPopn) - ( (dctg-root-P $Root) - (user-args-P $UserArgs) - (set-det) - (generate-tree $Root $Type $Depth $UserArgs $Expr $_) - (det-if-then-else - (, - (or - (unique-population-P yes) - (unique-population-P init)) - (individual $_ $_ $Expr)) - (= $NewPopn $Popn) - (, - (det-if-then-else - (== $Type full) - (writel f) - (writel g)) - (add-symbol &self - (individual x $_ $Expr)) - (is $NewPopn - (+ $Popn 1)))) - (set-det))) -; - + (= (populate $D $MaxD $MinD $Type $Popn $MaxPopn) + (> $D $MaxD) + (set-det) + (populate $MinD $MaxD $MinD $Type $Popn $MaxPopn)) + (= (populate $D $MaxD $MinD grow $Popn $MaxPopn) + (prob-grow-P $Pgrow) + (maybe $Pgrow) + (make-individual $D grow $Popn $Popn2) + (set-det) + (populate $D $MaxD $MinD full $Popn2 $MaxPopn)) +; ; new! May/00: only Pgrow; chance of grow tree + (= (populate $D $MaxD $MinD $Type $Popn $MaxPopn) + (make-individual $D full $Popn $Popn2) + (is $D2 + (+ $D 1)) + (set-det) + (toggle-type $Type $Type2) + (populate $D2 $MaxD $MinD $Type2 $Popn2 $MaxPopn)) +; /* populate(D, MaxD, MinD, full, Popn, MaxPopn) :- make_individual(D, full, Popn, Popn2), D2 is D + 1, !, populate(D2, MaxD, MinD, grow, Popn2, MaxPopn). */ + (= (populate $D $MaxD $MinD $Type $Popn $MaxPopn) + (set-det) + (populate $D $MaxD $MinD $Type $Popn $MaxPopn)) +; ; new: June 11/99 + + + (= (toggle_type grow full) True) + (= (toggle_type full grow) True) + +; +; make_individual(Depth, Type, Popn, NewPopn) +; +; makes an individual of Type tree of Depth size. +; +; current Popn size updated to NewPopn, but might not change +; +; if expression rejected (not unique?) +; +; Each individual Expr is asserted into: +; +; individual(x, _, Expr, Expr2) +; +; where Expr is main body, Expr2 is adf expression ('0' if unused). +; +; ID and fitness will eventually replace first 2 fields. + + + (= (make-individual $Depth $Type $Popn $NewPopn) + (dctg-root-P $Root) + (user-args-P $UserArgs) + (set-det) + (generate-tree $Root $Type $Depth $UserArgs $Expr $_) + (det-if-then-else + (, + (or + (unique-population-P yes) + (unique-population-P init)) + (individual $_ $_ $Expr)) + (= $NewPopn $Popn) + (, + (det-if-then-else + (== $Type full) + (writel f) + (writel g)) + (add-is-symbol &self + (individual x $_ $Expr)) + (is $NewPopn + (+ $Popn 1)))) + (set-det)) +; ; last arg is list notn. ; -; +; consecutively numbers all the population with unique ID numbers - - (= - (number-population) - ( (add-symbol &self + (= (number-population) + ( (add-is-symbol &self (popn_cnt 0)) - (remove-symbol &self + (remove-is-symbol &self (individual x $V $E)) - (remove-symbol &self + (remove-is-symbol &self (popn_cnt $K)) (is $K2 (+ $K 1)) - (add-symbol &self + (add-is-symbol &self (popn_cnt $K2)) - (add-symbol &self + (add-is-symbol &self (individual $K2 $V $E)) (fail))) -; - - (= - (number-population) - ( (remove-symbol &self + (= (number-population) + ( (remove-is-symbol &self (popn_cnt $_)) (set-det))) -; - ; -; - +; consecutively renumbers all the new population with unique ID numbers - (= - (renumber-population) - ( (add-symbol &self + (= (renumber-population) + ( (add-is-symbol &self (popn_cnt 0)) - (remove-symbol &self + (remove-is-symbol &self (newindividual $_ $V $E)) - (remove-symbol &self + (remove-is-symbol &self (popn_cnt $K)) (is $K2 (+ $K 1)) - (add-symbol &self + (add-is-symbol &self (popn_cnt $K2)) - (add-symbol &self + (add-is-symbol &self (individual $K2 $V $E)) (fail))) -; - - (= - (renumber-population) - ( (remove-symbol &self + (= (renumber-population) + ( (remove-is-symbol &self (popn_cnt $_)) (set-det))) -; - diff --git a/sre_dna/go.metta b/sre_dna/go.metta index bcb9e89..0d55f09 100644 --- a/sre_dna/go.metta +++ b/sre_dna/go.metta @@ -1,192 +1,59 @@ +; (convert_to_metta_file go $_169808 sre_dna/go.pl sre_dna/go.metta) ; -; - +; ?- load_files(library(random)). ; -; - +; ?- load_files(library(date)). ; -; - - - - (= - (?- - (use_module - (library random))) True) -; - - (= - (?- - (use_module - (library system))) True) -; - - (= - (?- - (use_module - (library lists))) True) -; - - - (= - (?- - (consult - (library - (/ sre_dna dynamics)))) True) -; - - (= - (?- - (consult - (library - (/ sre_dna dctg)))) True) -; - - (= - (?- - (consult - (library - (/ sre_dna parameters_P)))) True) -; - - (= - (?- - (consult - (library - (/ sre_dna operators)))) True) -; - - (= - (?- - (consult - (library - (/ sre_dna dctg_pp)))) True) -; - - (= - (?- - (consult - (library - (/ sre_dna utils)))) True) -; - - - (= - (?- - (, - (dctg_file_P $FileDCTG) - (, - (grammar $FileDCTG) make_grammar_table))) True) -; - - - (= - (regen) - ( (tell compile-file.pl) - (write '?- use-module(library(lists)). - ') - (nl) - (listing) - (told))) -; - - - !(regen *) -; - - - - - - (= - (?- - (consult - (library - (/ sre_dna ccs_utils)))) True) -; - - (= - (?- - (consult - (library - (/ sre_dna dctg_gen)))) True) -; - - (= - (?- - (consult - (library - (/ sre_dna dctg_reprod)))) True) -; - - (= - (?- - (consult - (library - (/ sre_dna dctg_utils)))) True) -; - - (= - (?- - (consult - (library - (/ sre_dna generate)))) True) -; - - (= - (?- - (consult - (library - (/ sre_dna gp_engine)))) True) -; - - (= - (?- - (consult - (library - (/ sre_dna lamarckian)))) True) -; - - (= - (?- - (consult - (library - (/ sre_dna evaluation)))) True) -; - - (= - (?- - (consult - (library - (/ sre_dna file_stats)))) True) -; +; ?- load_files(library(strings)). -; -; + (= (?- (use_module (library random))) True) + (= (?- (use_module (library system))) True) + (= (?- (use_module (library lists))) True) -; -; + (= (?- (consult (library (/ sre_dna dynamics)))) True) + (= (?- (consult (library (/ sre_dna dctg)))) True) + (= (?- (consult (library (/ sre_dna parameters_P)))) True) + (= (?- (consult (library (/ sre_dna operators)))) True) + (= (?- (consult (library (/ sre_dna dctg_pp)))) True) + (= (?- (consult (library (/ sre_dna utils)))) True) + + (= (?- (, (dctg_file_P $FileDCTG) (, (grammar $FileDCTG) make_grammar_table))) True) + + (= (regen) + (tell compile-file.pl) + (write '?- use-module(library(lists)). + ') + (nl) + (listing) + (told)) +; ; fast: new + !(regen *) - (= - (?- - (, - (fitness_func_P $File) - (consult $File))) True) -; - - (= - (?- - (: fast - (consult compile_file))) True) -; - (= - (?- clean_up) True) -; + (= (?- (consult (library (/ sre_dna ccs_utils)))) True) + (= (?- (consult (library (/ sre_dna dctg_gen)))) True) + (= (?- (consult (library (/ sre_dna dctg_reprod)))) True) + (= (?- (consult (library (/ sre_dna dctg_utils)))) True) + (= (?- (consult (library (/ sre_dna generate)))) True) + (= (?- (consult (library (/ sre_dna gp_engine)))) True) + (= (?- (consult (library (/ sre_dna lamarckian)))) True) + (= (?- (consult (library (/ sre_dna evaluation)))) True) + (= (?- (consult (library (/ sre_dna file_stats)))) True) + +; +; following must follow 'parameters_P' above. +; +; Convenient to put here, as interactive debugging of DCTG-GP is easier. + + (= (?- (, (fitness_func_P $File) (consult $File))) True) +; /* ?- consult(library(sre_dna/sre_mutation3)). ?- consult(library(sre_dna/sre_crossover3a)). ?- consult(library(sre_dna/dna_proc)). ?- consult(library(sre_dna/mask_optimizer)). ?- dna_file_P(DNA_file), consult(DNA_file). */ + + (= (?- (: fast (consult compile_file))) True) + (= (?- clean_up) True) diff --git a/sre_dna/gp_engine.metta b/sre_dna/gp_engine.metta index 954dc85..0e4caf8 100644 --- a/sre_dna/gp_engine.metta +++ b/sre_dna/gp_engine.metta @@ -1,107 +1,84 @@ +; (convert_to_metta_file gp_engine $_233400 sre_dna/gp_engine.pl sre_dna/gp_engine.metta) ; -; - +; ------------------------------------------------ ; -; - +; January 1999 ; -; - +; Author: Brian Ross ; -; - +; Dept. of Computer Science, Brock University ; ; - ; -; - +; Genetic Programming engine II. ; ; - ; -; - +; Tournament, steady state, Lamarckian hill-climbing option. ; -; - +; Parameters set in 'gp_defn' file. ; -; - +; Fitness: lower scores better, 0 is perfect. ; -; - +; Population represented in program database with: ; -; - +; individual(ID_number, Fitness, Expression) ; -; - +; newindividual(ID_number, Fitness, Expression) (for separate gen) - (= - (gp) + (= (gp) ( (clean-up-1) - (add-symbol &self + (add-is-symbol &self (best_so_far $_ $_ 1000 $_)) (max-runs-P $MaxRuns $RunType $_) (set-det) (meta-run-loop 1 $MaxRuns $RunType) (writel (:: '*** END ***' nl nl)))) -; - +; ; from gp_defn file - (= - (meta-run-loop $Runs $MaxRuns $_) - ( (> $Runs $MaxRuns) - (set-det) - (best-so-far $Run $Gen $Fitness $Expr) - (writel (:: nl '--> Max run' $MaxRuns ' reached.' nl 'Best found in run ' $Run ' gen ' $Gen : nl ' Expr = ' $Expr nl ' Fitness = ' $Fitness nl nl)) - (writel (:: '--> Finished runs <--' nl nl)) - (set-det))) -; - - (= - (meta-run-loop $Run $MaxRuns $RunType) - ( (=< $Run $MaxRuns) - (population-size-P $_ $PopSize) - (max-runs-P $_ $_ $MaxGen) - (writel (:: nl '--------------------- Run ' $Run --------------------- nl)) - (since-last-datime total retract $Hour $Minute $Sec) - (since-last-datime generation retract $_ $_ $_) - (do-the-run 0 $MaxGen $PopSize) - (write 'Dumping stats... ') - (dump-stats $Run) - (write done) - (nl) - (set-best-so-far $Run) - (det-if-then-else - (, - (== $RunType solution) - (solved-run)) True - (, - (is $Run2 - (+ $Run 1)) - (meta-run-loop $Run2 $MaxRuns $RunType))))) -; - - - - (= - (do-the-run $Gen $MaxGen $_) - ( (> $Gen $MaxGen) (set-det))) -; - - (= - (do-the-run $_ $_ $_) - ( (solved-run) (set-det))) -; - - (= - (do-the-run 0 $MaxGen $PopSize) + (= (meta-run-loop $Runs $MaxRuns $_) + (> $Runs $MaxRuns) + (set-det) + (best-so-far $Run $Gen $Fitness $Expr) + (writel (:: nl '--> Max run' $MaxRuns ' reached.' nl 'Best found in run ' $Run ' gen ' $Gen : nl ' Expr = ' $Expr nl ' Fitness = ' $Fitness nl nl)) + (writel (:: '--> Finished runs <--' nl nl)) + (set-det)) + (= (meta-run-loop $Run $MaxRuns $RunType) + (=< $Run $MaxRuns) + (population-size-P $_ $PopSize) + (max-runs-P $_ $_ $MaxGen) + (writel (:: nl '--------------------- Run ' $Run --------------------- nl)) + (since-last-datime total retract $Hour $Minute $Sec) + (since-last-datime generation retract $_ $_ $_) + (do-the-run 0 $MaxGen $PopSize) + (write 'Dumping stats... ') + (dump-stats $Run) + (write done) + (nl) + (set-best-so-far $Run) + (det-if-then-else + (, + (== $RunType solution) + (solved-run)) True + (, + (is $Run2 + (+ $Run 1)) + (meta-run-loop $Run2 $MaxRuns $RunType)))) +; ; gp_parameters +; ; gp_parameters + + + (= (do-the-run $Gen $MaxGen $_) + (> $Gen $MaxGen) + (set-det)) + (= (do-the-run $_ $_ $_) + (solved-run) + (set-det)) + (= (do-the-run 0 $MaxGen $PopSize) ( (clean-up-2) - (add-symbol &self + (add-is-symbol &self (best_in_run $_ 1000 $_)) (writel (:: nl '********* Generation ' 0 ********* nl)) (evaluator-reset 0) @@ -111,446 +88,327 @@ (garbage-collect) (set-det) (do-the-run 1 $MaxGen $PopSize))) -; - - (= - (do-the-run $Gen $MaxGen $PopSize) - ( (writel (:: nl '********* Generation ' $Gen ********* nl)) - (evaluator-reset $Gen) - (elite-migration 1 $StartSize) - (tournament-loop $StartSize $PopSize) - (rename-new-popn) - (det-if-then-else - (, - (lamarckian-P $P $_ $_ $_) - (> $P 0)) - (lamarckian-evolution $Gen) True) - (set-best-in-run $Gen) - (print-tourn-stats $Gen) - (is $Gen2 - (+ $Gen 1)) - (garbage-collect) - (set-det) - (do-the-run $Gen2 $MaxGen $PopSize))) -; - +; ; dump_population(0), + (= (do-the-run $Gen $MaxGen $PopSize) + (writel (:: nl '********* Generation ' $Gen ********* nl)) + (evaluator-reset $Gen) + (elite-migration 1 $StartSize) + (tournament-loop $StartSize $PopSize) + (rename-new-popn) + (det-if-then-else + (, + (lamarckian-P $P $_ $_ $_) + (> $P 0)) + (lamarckian-evolution $Gen) True) + (set-best-in-run $Gen) + (print-tourn-stats $Gen) + (is $Gen2 + (+ $Gen 1)) + (garbage-collect) + (set-det) + (do-the-run $Gen2 $MaxGen $PopSize)) +; ; new: May/00 +; ; dump_population(Gen), ; -; - +; tournament_loop(NumNew, PopSize) runs until NumNew changes ; -; - +; done reaches PopSize OR run found solution. ; -; - -; -; - -; -; - -; -; - - - - (= - (tournament-loop $K $PopSize) - ( (> $K $PopSize) (set-det))) -; - - (= - (tournament-loop $_ $_) - ( (solved-run) (set-det))) -; - - (= - (tournament-loop $K $PopSize) - ( (prob-crossover-P $PC) - (maybe $PC) - (tournament-select best $PopSize $_ $Expr1) - (tournament-select best $PopSize $_ $Expr2) - (det-if-then-else - (crossover $Expr1 $Expr2 $NewExpr1 $NewExpr2) - (, - (add-child c $K $K2 $PopSize $NewExpr1) - (add-child c $K2 $K3 $PopSize $NewExpr2)) - (= $K $K3)) - (tournament-loop $K3 $PopSize))) -; - - (= - (tournament-loop $K $PopSize) - ( (tournament-select best $PopSize $_ $Expr) - (det-if-then-else - (mutation $Expr $NewExpr) - (add-child m $K $K2 $PopSize $NewExpr) - (= $K $K2)) - (tournament-loop $K2 $PopSize))) -; - - +; Possible that crossover fails (can't find similar nodes in choices, or ; -; - +; children too large), and crossover will fail. ; -; - +; Else add each child. ; -; - +; Mutation happens if crossover didn't. - (= - (tournament-select best $PopSize $ID $Expression) - ( (tournament-size-P $Num $_) - (select-random-IDs 0 $Num $PopSize Nil $IDs) - (select best $IDs $ID $Expression) - (set-det))) -; - - (= - (tournament-select worst $PopSize $ID $Expression) - ( (tournament-size-P $_ $Num) - (select-random-IDs 0 $Num $PopSize Nil $IDs) - (select worst $IDs $ID $Expression) - (set-det))) -; - + (= (tournament-loop $K $PopSize) + (> $K $PopSize) + (set-det)) + (= (tournament-loop $_ $_) + (solved-run) + (set-det)) + (= (tournament-loop $K $PopSize) + (prob-crossover-P $PC) + (maybe $PC) + (tournament-select best $PopSize $_ $Expr1) + (tournament-select best $PopSize $_ $Expr2) + (det-if-then-else + (crossover $Expr1 $Expr2 $NewExpr1 $NewExpr2) + (, + (add-child c $K $K2 $PopSize $NewExpr1) + (add-child c $K2 $K3 $PopSize $NewExpr2)) + (= $K $K3)) + (tournament-loop $K3 $PopSize)) +; ; do crossover ? +; ; might be same ID +; ; in case crossover didn't succeed + (= (tournament-loop $K $PopSize) + (tournament-select best $PopSize $_ $Expr) + (det-if-then-else + (mutation $Expr $NewExpr) + (add-child m $K $K2 $PopSize $NewExpr) + (= $K $K2)) + (tournament-loop $K2 $PopSize)) +; ; do mutation +; ; in case mutation didn't succeed + +; +; tournament_select(Type, PopSize, ID, Expression) selects the +; +; Type=best/worst Expression from Num randomly selected individuals +; +; from population of size PopSize + + + (= (tournament-select best $PopSize $ID $Expression) + (tournament-size-P $Num $_) + (select-random-IDs 0 $Num $PopSize Nil $IDs) + (select best $IDs $ID $Expression) + (set-det)) + (= (tournament-select worst $PopSize $ID $Expression) + (tournament-size-P $_ $Num) + (select-random-IDs 0 $Num $PopSize Nil $IDs) + (select worst $IDs $ID $Expression) + (set-det)) ; -; - +; select_random_IDs(N, Size, PopSize, SoFar, Result) selects Size unique ; -; - +; individual ID's from 1 to PopSize; N is size of temp answer SoFar. - (= - (select-random-IDs $Size $Size $_ $Result $Result) + (= (select-random-IDs $Size $Size $_ $Result $Result) (set-det)) -; - - (= - (select-random-IDs $N $Size $PopSize $SoFar $Result) - ( (repeat) - (my-random $PopSize $K) - (not (member $K $SoFar)) - (is $N2 - (+ $N 1)) - (select-random-IDs $N2 $Size $PopSize - (Cons $K $SoFar) $Result))) -; - + (= (select-random-IDs $N $Size $PopSize $SoFar $Result) + (repeat) + (my-random $PopSize $K) + (not (member $K $SoFar)) + (is $N2 + (+ $N 1)) + (select-random-IDs $N2 $Size $PopSize + (Cons $K $SoFar) $Result)) ; -; - +; select the best or worst in tournament ; -; - +; If a fair worst selection, then all have a chance to be replaced in ; -; - - - - (= - (select $Type - (Cons $ID1 $Rest) $ID $Expression) - ( (individual $ID1 $Fit1 $_) (select2 $Type $Fit1 $ID1 $Rest $ID $Expression))) -; - +; proportion to the number of best individuals in the population. - (= - (select2 $_ $_ $ID Nil $ID $Expression) - ( (individual $ID $_ $Expression) (set-det))) -; + (= (select $Type (Cons $ID1 $Rest) $ID $Expression) + (individual $ID1 $Fit1 $_) + (select2 $Type $Fit1 $ID1 $Rest $ID $Expression)) - (= - (select2 $Type $Fit1 $_ - (Cons $ID2 $Rest) $ID $Expression) - ( (individual $ID2 $Fit2 $_) - (or - (, - (== $Type best) - (< $Fit2 $Fit1)) - (, - (== $Type worst) - (> $Fit2 $Fit1))) - (set-det) - (select2 $Type $Fit2 $ID2 $Rest $ID $Expression))) -; - (= - (select2 $Type $Fit1 $ID1 - (Cons $_ $Rest) $ID $Expression) + (= (select2 $_ $_ $ID Nil $ID $Expression) + (individual $ID $_ $Expression) + (set-det)) + (= (select2 $Type $Fit1 $_ (Cons $ID2 $Rest) $ID $Expression) + (individual $ID2 $Fit2 $_) + (or + (, + (== $Type best) + (< $Fit2 $Fit1)) + (, + (== $Type worst) + (> $Fit2 $Fit1))) + (set-det) + (select2 $Type $Fit2 $ID2 $Rest $ID $Expression)) + (= (select2 $Type $Fit1 $ID1 (Cons $_ $Rest) $ID $Expression) (select2 $Type $Fit1 $ID1 $Rest $ID $Expression)) -; - ; -; - +; adding to population (replacing a weak member) if legal. ; -; - +; Use a reverse tournament selection, finding indiv to replace with child. - (= - (add-child $T $K $K2 $PopSize $Expr) - ( (det-if-then-else - (not (legal $Expr main)) - (= $K2 $K) - (, - (det-if-then-else - (eval-with-ID-P yes) - (evaluator $K $Expr $Fitness) - (evaluator $Expr $Fitness)) - (add-individual $PopSize $Fitness $Expr) - (writel $T) - (is $K2 - (+ $K 1)))) (set-det))) -; - + (= (add-child $T $K $K2 $PopSize $Expr) + (det-if-then-else + (not (legal $Expr main)) + (= $K2 $K) + (, + (det-if-then-else + (eval-with-ID-P yes) + (evaluator $K $Expr $Fitness) + (evaluator $Expr $Fitness)) + (add-individual $PopSize $Fitness $Expr) + (writel $T) + (is $K2 + (+ $K 1)))) + (set-det)) +; ; T=first arg of add_child - (= - (add-individual $_ $Fitness $NewExpr) + (= (add-individual $_ $Fitness $NewExpr) ( (gen-type-P separate) (set-det) - (add-symbol &self + (add-is-symbol &self (newindividual $_ $Fitness $NewExpr)))) -; - - (= - (add-individual $PopSize $Fitness $NewExpr) + (= (add-individual $PopSize $Fitness $NewExpr) ( (tournament-select worst $PopSize $ID $_) - (remove-symbol &self + (remove-is-symbol &self (individual $ID $_ $_)) - (add-symbol &self + (add-is-symbol &self (individual $ID $Fitness $NewExpr)))) -; - ; -; - +; Expression is legal if: ; -; - +; 1. If unique population option is on, then if child exists in population, ; -; - +; don't add it ; -; - +; 2. If size of child exceeds max, don't add. ; -; - +; 3. If expression modes set, don't add if expression fails them. ; -; - +; Flag set to 'main' if called in main GP loop; else set to 'lamarck' ; -; - - - - (= - (legal $Expr $Flag) - ( (check-unique $Expr $Flag) - (check-depth $Expr) - (set-det))) -; +; (affects if newindividual exists or not; sloppy). + (= (legal $Expr $Flag) + (check-unique $Expr $Flag) + (check-depth $Expr) + (set-det)) - (= - (check-unique $_ $_) - ( (not (unique-population-P yes)) (set-det))) -; - (= - (check-unique $Expr main) - ( (gen-type-P separate) - (set-det) - (not (newindividual $_ $_ $Expr)))) -; - - (= - (check-unique $Expr $_) + (= (check-unique $_ $_) + (not (unique-population-P yes)) + (set-det)) + (= (check-unique $Expr main) + (gen-type-P separate) + (set-det) + (not (newindividual $_ $_ $Expr))) + (= (check-unique $Expr $_) (not (individual $_ $_ $Expr))) -; - ; -; - +; succeed if Expression depth within limits - (= - (check-depth $Expr) - ( (max-depth-P $_ $MaxDepth) - (tree-depth $Expr $D) - (=< $D $MaxDepth) - (set-det))) -; - + (= (check-depth $Expr) + (max-depth-P $_ $MaxDepth) + (tree-depth $Expr $D) + (=< $D $MaxDepth) + (set-det)) ; -; +; succeed if solution criteria satisfied - - (= - (solved-run) - ( (best-in-run $_ $BFitness $_) - (error-tolerance-P $Err) - (=< $BFitness $Err) - (set-det))) -; - + (= (solved-run) + (best-in-run $_ $BFitness $_) + (error-tolerance-P $Err) + (=< $BFitness $Err) + (set-det)) - (= - (clean-up-1) + (= (clean-up-1) ( (set-random-number-gen) - (remove-all-symbols &self + (remove-all-atoms &self (start_time $_)) - (remove-all-symbols &self + (remove-all-atoms &self (best_so_far $_ $_ $_ $_)) (garbage-collect) (set-det))) -; - - (= - (clean-up-2) - ( (remove-all-symbols &self + (= (clean-up-2) + ( (remove-all-atoms &self (best_in_run $_ $_ $_)) - (remove-all-symbols &self + (remove-all-atoms &self (gp_stats $_ $_ $_ $_ $_ $_ $_)) - (remove-all-symbols &self + (remove-all-atoms &self (individual $_ $_ $_)) - (remove-all-symbols &self + (remove-all-atoms &self (newindividual $_ $_ $_)) - (remove-all-symbols &self + (remove-all-atoms &self (popn_size $_)) - (remove-all-symbols &self + (remove-all-atoms &self (popn_cnt $_)) - (remove-all-symbols &self + (remove-all-atoms &self (temp $_)) (garbage-collect) (set-det))) -; - +; ; retractall(trace_count(_,_)), +; ; retractall(saved_trace(_)), ; -; - - +; for interactive exec... - (= - (clean-up) - ( (clean-up-1) (clean-up-2))) -; + (= (clean-up) + (clean-up-1) + (clean-up-2)) ; -; - +; If evaluator_reset_P(Gen) is set to a routine name, then call it before ; -; - +; each generation ensues. It is called if it is the Nth generation (1st gen ; -; - +; is first one a set is created). - (= - (evaluator-reset $_) - ( (evaluator-reset-P $_ no) (set-det))) -; - - (= - (evaluator-reset $G) - ( (evaluator-reset-P $C $N) - (is 0 - (mod $G $N)) - (call $C) - (set-det))) -; - - (= - (evaluator_reset $_) True) -; - + (= (evaluator-reset $_) + (evaluator-reset-P $_ no) + (set-det)) + (= (evaluator-reset $G) + (evaluator-reset-P $C $N) + (is 0 + (mod $G $N)) + (call $C) + (set-det)) + (= (evaluator_reset $_) True) - (= - (rename-new-popn) + (= (rename-new-popn) ( (gen-type-P separate) (set-det) - (remove-all-symbols &self + (remove-all-atoms &self (individual $_ $_ $_)) (renumber-population))) -; - - (= rename_new_popn True) -; - +; /* evaluator_reset :- evaluator_reset_P(no), !. evaluator_reset :- evaluator_reset_P(C), call(C), !. evaluator_reset. */ +; ; If a separate population scheme is being used, then rename the ; newindividual's to individuals, and give them ID numbers. + (= rename_new_popn True) ; -; - +; If elite migration is on, and gen_type is separate, then migrate the ; -; - +; N best individuals into new population. ; -; - +; If ReEval = yes, then each has fitness recomputed (assume new generation of ; -; - +; testset done beforehand elsewhere). - (= - (elite-migration $_ $StartSize) - ( (gen-type-P separate) - (elite-migrate-P $N $ReEval) - (> $N 0) - (set-det) - (setof - (, $V $K) - (^ $E - (individual $K $V $E)) $Set) - (first-K 0 $N $Set $Elite) - (copy-elite $Elite $ReEval) - (is $StartSize - (+ $N 1)))) -; - - (= - (elite-migration $K $K) - (set-det)) -; - ; -; + (= (elite-migration $_ $StartSize) + (gen-type-P separate) + (elite-migrate-P $N $ReEval) + (> $N 0) + (set-det) + (setof + (, $V $K) + (^ $E + (individual $K $V $E)) $Set) + (first-K 0 $N $Set $Elite) + (copy-elite $Elite $ReEval) + (is $StartSize + (+ $N 1))) + (= (elite-migration $K $K) + (set-det)) ; +; else not done - - (= - (copy-elite Nil $_) + (= (copy-elite Nil $_) (set-det)) -; - - (= - (copy-elite - (Cons - (, $V $K) $B) $ReEval) + (= (copy-elite (Cons (, $V $K) $B) $ReEval) ( (individual $K $_ $E) (det-if-then-else (= $ReEval yes) @@ -561,17 +419,12 @@ (evaluator $E $V2)) (write ?)) (= $V $V2)) - (add-symbol &self + (add-is-symbol &self (newindividual $K $V2 $E)) (set-det) (copy-elite $B $ReEval))) -; - - (= - (evaluator $K $E $V2) + (= (evaluator $K $E $V2) (evaluator $E $V2)) -; - diff --git a/sre_dna/lamarckian.metta b/sre_dna/lamarckian.metta index 747eacb..840535b 100644 --- a/sre_dna/lamarckian.metta +++ b/sre_dna/lamarckian.metta @@ -1,70 +1,51 @@ +; (convert_to_metta_file lamarckian $_440142 sre_dna/lamarckian.pl sre_dna/lamarckian.metta) ; -; - +; ------------------------------------------------ ; -; - +; January 1999 ; -; - +; Author: Brian Ross ; -; - +; Dept. of Computer Science, Brock University ; ; - ; -; - +; Lamarckian evolution: lamarckian_P(P, K, Select, PCross) ; -; - +; Performs Lamarckian evolution on P; of population, iterating ; -; - +; each K times using hill-climbing. Hill-climber uses mutation; it is ; -; - +; recommended that prob_terminal_mutation_P parameter be high, or else ; -; - +; internal mutation will not create good search performance. ; -; - +; Select can be tournament (best, worst) or random. ; -; - +; PCross is prob crossover (prob mutation = 1 - PCross). ; -; - +; lamarckian_evolution also asserts gp_stats with improvement gain obtained ; -; - +; First clause efficiently processes entire population. ; -; - +; Second case is if less than entire population to be used, in which case ; -; +; selection must be performed. - - (= - (lamarckian-evolution $Gen) + (= (lamarckian-evolution $Gen) ( (lamarckian-P $Percent $K $_ $_) (>= $Percent 1.0) (writel (:: nl 'Lamarckian evolution...' nl)) (population-size-P $_ $PopSize) (num-list $PopSize $IDs) (lamarck-loop $IDs 0 $FitImpr 0 $MaxImpr 0 $NumGain $K) - (add-symbol &self + (add-is-symbol &self (gp_stats $Gen $_ $_ $_ $_ $_ $_ (lamarck $FitImpr $MaxImpr $NumGain))) (set-det))) -; - - (= - (lamarckian-evolution $Gen) + (= (lamarckian-evolution $Gen) ( (lamarckian-P $Percent $K $Select $_) (< $Percent 1.0) (population-size-P $_ $PopSize) @@ -73,233 +54,177 @@ (writel (:: nl 'Lamarckian evolution...' nl)) (get-unique-IDs $Select $N $PopSize Nil $IDs) (lamarck-loop $IDs 0 $FitImpr 0 $MaxImpr 0 $NumGain $K) - (add-symbol &self + (add-is-symbol &self (gp_stats $Gen $_ $_ $_ $_ $_ $_ (lamarck $FitImpr $MaxImpr $NumGain))) (set-det))) -; - ; -; - +; get_unique_IDs retrieves a list of N unique individual ID's, ; -; +; selecting each one via Type (random or best/worst tournament selection). - - (= - (get-unique-IDs $_ 0 $_ $IDs $IDs) + (= (get-unique-IDs $_ 0 $_ $IDs $IDs) (set-det)) -; - - (= - (get-unique-IDs $Type $N $PopSize $SoFar $IDs) - ( (repeat) - (det-if-then-else - (= $Type random) - (my-random $PopSize $ID) - (tournament-select $Type $PopSize $ID $_)) - (not (member $ID $SoFar)) - (is $M - (- $N 1)) - (get-unique-IDs $Type $M $PopSize - (Cons $ID $SoFar) $IDs) - (set-det))) -; - + (= (get-unique-IDs $Type $N $PopSize $SoFar $IDs) + (repeat) + (det-if-then-else + (= $Type random) + (my-random $PopSize $ID) + (tournament-select $Type $PopSize $ID $_)) + (not (member $ID $SoFar)) + (is $M + (- $N 1)) + (get-unique-IDs $Type $M $PopSize + (Cons $ID $SoFar) $IDs) + (set-det)) +; ; in case number is repeated (member below) ; -; - +; lamark_loop(List, ImprSoFar, FitImpr, MaxSoFar, MaxImpr, ; -; - +; NumSoFar, NumGain, Iter) does best-first Lamarckian evolution. ; -; - +; List = ordered list of individuals+Fitnesses ; -; - +; ImprSoFar, FitImr = Total fitness gain so far / final ; -; - +; MaxSoFar, MaxImpr = best fitness gain so far/final ; -; - +; NumSoFar, NumGain = number that have been changed so far/final ; -; - +; Iter = # iterations to do ; ; - ; -; - +; Note: even if no overall fitness gain achieved, if an altered expression ; -; - +; was found, it is asserted and treated like a gain: will improve genetic ; -; +; diversity in population due to its syntactic variation. - - (= - (lamarck-loop Nil $FitImpr $FitImpr $MaxImpr $MaxImpr $NumGain $NumGain $_) + (= (lamarck-loop Nil $FitImpr $FitImpr $MaxImpr $MaxImpr $NumGain $NumGain $_) (set-det)) -; - - (= - (lamarck-loop - (Cons $ID $Rest) $ImprSoFar $FitImpr $MaxSoFar $MaxImpr $NumSoFar $NumGain $Iter) - ( (individual $ID $Fit $Expr) - (hill-climb $Iter - (, $Fit $Expr) - (, $NewFit $NewExpr)) - (det-if-then-else - (or - (>= $NewFit $Fit) - (not (legal $NewExpr lamarck))) - (, - (writel -) - (= - (, $NewFitImpr $NewMaxImpr $NumSoFar2) - (, $ImprSoFar $MaxSoFar $NumSoFar))) - (, - (remove-symbol &self - (individual $ID $_ $_)) - (add-symbol &self - (individual $ID $NewFit $NewExpr)) - (is $NewFitImpr - (- - (+ $ImprSoFar $Fit) $NewFit)) - (is $NewMaxImpr - (max $MaxSoFar - (- $Fit $NewFit))) - (is $NumSoFar2 - (+ $NumSoFar 1)) - (writel +))) - (lamarck-loop $Rest $NewFitImpr $FitImpr $NewMaxImpr $MaxImpr $NumSoFar2 $NumGain $Iter) - (set-det))) -; - + (= (lamarck-loop (Cons $ID $Rest) $ImprSoFar $FitImpr $MaxSoFar $MaxImpr $NumSoFar $NumGain $Iter) + (individual $ID $Fit $Expr) + (hill-climb $Iter + (, $Fit $Expr) + (, $NewFit $NewExpr)) + (det-if-then-else + (or + (>= $NewFit $Fit) + (not (legal $NewExpr lamarck))) + (, + (writel -) + (= + (, $NewFitImpr $NewMaxImpr $NumSoFar2) + (, $ImprSoFar $MaxSoFar $NumSoFar))) + (, + (remove-is-symbol &self + (individual $ID $_ $_)) + (add-is-symbol &self + (individual $ID $NewFit $NewExpr)) + (is $NewFitImpr + (- + (+ $ImprSoFar $Fit) $NewFit)) + (is $NewMaxImpr + (max $MaxSoFar + (- $Fit $NewFit))) + (is $NumSoFar2 + (+ $NumSoFar 1)) + (writel +))) + (lamarck-loop $Rest $NewFitImpr $FitImpr $NewMaxImpr $MaxImpr $NumSoFar2 $NumGain $Iter) + (set-det)) +; ; writel(['L ID=',ID,'* ']), +; ; don't add ; -; - +; hill_climb(K, BestSoFar, Item) does hill-climbing search for ; -; - +; K iterations. BestSoFar contains best expression obtained so far with ; -; - +; mutation, and it and Item have (Fitness, Expression, Adf) structure. ; -; - +; Note: Failed mutation and repeated mutation is counted as an iteration ; -; - - - - (= - (hill-climb $K $Item $Item) - ( (=< $K 0) (set-det))) -; - - (= - (hill-climb $K - (, $TopFit $TopExpr) $Soln) - ( (lamarckian-P $_ $_ $_ $PC) - (maybe $PC) - (population-size-P $_ $PopSize) - (tournament-select best $PopSize $_ $Expr2) - (crossover $TopExpr $Expr2 $NewExpr1 $NewExpr2) - (evaluator $NewExpr1 $NewFit1) - (evaluator $NewExpr2 $NewFit2) - (select-best - (, $NewFit1 $NewExpr1) - (, $TopFit $TopExpr) $BestSoFar1) - (select-best - (, $NewFit2 $NewExpr2) $BestSoFar1 $BestSoFar2) - (det-if-then-else - (or - (< $NewFit1 $TopFit) - (< $NewFit2 $TopFit)) - (= $K2 $K) - (is $K2 - (- $K 2))) - (hill-climb $K2 $BestSoFar2 $Soln) - (set-det))) -; - - (= - (hill-climb $K - (, $TopFit $TopExpr) $Soln) - ( (sre-mutation $TopExpr $NewExpr) - (evaluator $NewExpr $NewFit) - (select-best - (, $NewFit $NewExpr) - (, $TopFit $TopExpr) $BestSoFar) - (det-if-then-else - (< $NewFit $TopFit) - (= $K2 $K) - (is $K2 - (- $K 1))) - (hill-climb $K2 $BestSoFar $Soln) - (set-det))) -; +; Also, improved hillclimbing step does not count as an iteration. - (= - (hill-climb $K $BestSoFar $Soln) - ( (is $K2 - (- $K 1)) - (hill-climb $K2 $BestSoFar $Soln) - (set-det))) -; + (= (hill-climb $K $Item $Item) + (=< $K 0) + (set-det)) + (= (hill-climb $K (, $TopFit $TopExpr) $Soln) + (lamarckian-P $_ $_ $_ $PC) + (maybe $PC) + (population-size-P $_ $PopSize) + (tournament-select best $PopSize $_ $Expr2) + (crossover $TopExpr $Expr2 $NewExpr1 $NewExpr2) + (evaluator $NewExpr1 $NewFit1) + (evaluator $NewExpr2 $NewFit2) + (select-best + (, $NewFit1 $NewExpr1) + (, $TopFit $TopExpr) $BestSoFar1) + (select-best + (, $NewFit2 $NewExpr2) $BestSoFar1 $BestSoFar2) + (det-if-then-else + (or + (< $NewFit1 $TopFit) + (< $NewFit2 $TopFit)) + (= $K2 $K) + (is $K2 + (- $K 2))) + (hill-climb $K2 $BestSoFar2 $Soln) + (set-det)) +; ; crossover? + (= (hill-climb $K (, $TopFit $TopExpr) $Soln) + (sre-mutation $TopExpr $NewExpr) + (evaluator $NewExpr $NewFit) + (select-best + (, $NewFit $NewExpr) + (, $TopFit $TopExpr) $BestSoFar) + (det-if-then-else + (< $NewFit $TopFit) + (= $K2 $K) + (is $K2 + (- $K 1))) + (hill-climb $K2 $BestSoFar $Soln) + (set-det)) +; ; mutation? +; ;K2 is K - 1, + (= (hill-climb $K $BestSoFar $Soln) + (is $K2 + (- $K 1)) + (hill-climb $K2 $BestSoFar $Soln) + (set-det)) ; -; - +; select best of expression pairs - (= - (select-best - (, $F1 $E1) - (, $F2 $_) - (, $F1 $E1)) - ( (=< $F1 $F2) (set-det))) -; - - (= - (select_best $_ $X $X) True) -; - + (= (select-best (, $F1 $E1) (, $F2 $_) (, $F1 $E1)) + (=< $F1 $F2) + (set-det)) + (= (select_best $_ $X $X) True) - (= - (sre-mutation $I $C) + (= (sre-mutation $I $C) (mutation $I $C)) -; - ; -; +; some debugging code... - - (= - (test-best-first $Iter $ID) - ( (population-size-P $_ $PopSize) - (tournament-select best $PopSize $ID $_) - (individual $ID $Fit $Expr) - (hill-climb $Iter - (, $Fit $Expr) - (, $NewFit $NewExpr)) - (writel (:: 'Initial: ' nl ' Fit = ' $Fit nl ' Expr = ' $Expr nl 'New: ' nl ' Fit = ' $NewFit nl ' Expr = ' $NewExpr nl)) - (set-det))) -; - + (= (test-best-first $Iter $ID) + (population-size-P $_ $PopSize) + (tournament-select best $PopSize $ID $_) + (individual $ID $Fit $Expr) + (hill-climb $Iter + (, $Fit $Expr) + (, $NewFit $NewExpr)) + (writel (:: 'Initial: ' nl ' Fit = ' $Fit nl ' Expr = ' $Expr nl 'New: ' nl ' Fit = ' $NewFit nl ' Expr = ' $NewExpr nl)) + (set-det)) diff --git a/sre_dna/operators.metta b/sre_dna/operators.metta index e86e377..25e2c24 100644 --- a/sre_dna/operators.metta +++ b/sre_dna/operators.metta @@ -1,48 +1,28 @@ +; (convert_to_metta_file operators $_83624 sre_dna/operators.pl sre_dna/operators.metta) ; -; - +; ------------------------------------------------ ; -; - +; Feb 1999 ; -; - +; Author: Brian Ross ; -; - +; Dept. of Computer Science, Brock University ; ; - ; -; - +; GP dctg operators ; ; + (= (?- (op 480 xfy :)) True) + (= (?- (op 470 yfx *)) True) + (= (?- (op 470 yfx +)) True) - (= - (?- - (op 480 xfy :)) True) -; - - (= - (?- - (op 470 yfx *)) True) -; - - (= - (?- - (op 470 yfx +)) True) -; - - - - (= - (sre $E) - ( (write $E) (nl))) -; + (= (sre $E) + (write $E) + (nl)) diff --git a/sre_dna/parameters_P.metta b/sre_dna/parameters_P.metta index 0c77d80..03abb6f 100644 --- a/sre_dna/parameters_P.metta +++ b/sre_dna/parameters_P.metta @@ -1,492 +1,265 @@ +; (convert_to_metta_file parameters_P $_141870 sre_dna/parameters_P.pl sre_dna/parameters_P.metta) ; -; - +; ------------------------------------------------ ; -; - +; October 2001 ; -; - +; Author: Brian Ross ; -; - +; Dept. of Computer Science, Brock University - (= - (?- - (dynamic - (/ seed_P 2))) True) -; - - (= - (?- - (dynamic - (/ recog_flag 1))) True) -; - + (= (?- (dynamic (/ seed_P 2))) True) + (= (?- (dynamic (/ recog_flag 1))) True) ; -; - +; GP Control Parameters ; -; - +; --------------------------- ; -; - +; fitness_func_P(F) - F is file name containing fitness function. ; -; - +; Should have a function called evaluator/2. It sets ; -; - +; standardized fitness scores. ; -; - +; dctg_file_P(F) - F is file name containing DCTG grammar ; -; - +; population_size_P(I,N) - size (initial, final) of GP population ; -; - +; - final is culled from initial ; -; - +; cull_method_P(T) - T=tournament or elite ; -; - +; max_runs_P(R,Type,Gen) - total number R of runs; max generations Gen per run ; -; - +; Type = limit: run to R, even if soln found ; -; - +; Type = solution: run to R, but stop when soln ; -; - +; prob_grow_P - during ramped init population gen, this is ; -; - +; probability a 'grow' tree is attempted ; -; - +; prob_crossover_P - probability of crossover mating ; -; - +; prob mutation = 1 - prob cross ; -; - +; reprod_P(T) - # tries for crossover ; -; - +; prob_internal_crossover_P - probability that crossover happens on an internal ; -; - +; node in 1 parent; set to 'no' otherwise ; -; - +; prob_terminal_mutation_P - probability that mutation is on a terminal node; ; -; - +; set to 'no' otherwise ; -; - +; max_depth_P(I,C) - I = max depth of initial generated indiv's, ; -; - +; C = maximum depth permitted in offspring ; -; - +; Make sure I is large enough, or else generation will stall. ; -; - +; error_tolerance_P - wrt evaluation, tolerance for correct solns. ; -; - +; tournament_size_P(S,R) - # entries in tournament selection S and ; -; - +; replacement R ; -; - +; lamarckian_P(P, K, Select, ProbCross) - do Lamarkian evol on ; -; - +; P ; of population, ; -; - +; K = # iterations for best-first search ; -; - +; Select = {best, worst, random} selection ; -; - +; If P=1.0, then Select is irrelevant. ; -; - +; ProbCross is prob crossover (vs mutation) ; -; - +; unique_population_P(no) - no/yes: children added to popn should be unique ; -; - +; (doesn't affect genesis population however) ; -; - +; trace_limit_P(U,T) - stops interpretation when this many unique/total ; -; - +; traces have been obtained (turn off = (0,0) ) ; -; - +; if arg 1 = deterministic, then only 1 soln ; -; - +; rep_limit_P(X) - if >0, X is max recursion depth for ! repetition ; -; - +; 0 = unlimited repetition ; -; - +; simplify_P(yes) - if 'yes', then offspring are simplified ; -; - +; before added to population ; -; - +; seed_P(X,Y) - if X = default, then default random cycle ; -; - +; if X = random, then system timer used to initialize ; -; - +; (Y set by program to seeds used, for reinit later) ; -; - +; X=manual means Y = (A, B, C) are seed integers 1...30,000 !(dynamic (/ debug-set-P 1)) -; - ; -; - +; debug_set_P(yes): for additional debug printing, if implemented ; -; - +; popn_dump_P(no) - if yes, then population dumped at end of each gen ; -; - +; gen_type_P(T) - generation type: T = steadystate, separate ; -; - +; evaluator_reset_P(P, G)- if G=no, ignore; else call P every G-th generation ; -; - +; reprod_verif_P(T) - if yes, then each reproduced Tree has its DCTG code ; -; - +; executed, to verify it wrt embedded MeTTa code; ; -; - +; user_args_P(_) - list of user args for executing dctg calls ; -; - +; make sure it has # members of what DCTG expects! ; -; - +; dctg_root_P(Root) - root nonterminal of DCTG ; -; - +; dctg_override_P(Term, Nonterm). - user override of terminal, nonterminal ; -; - +; designation for rules; done for entire nonterm set ; -; - +; mutation_range_P(R) - range to mutate SRE numeric values ; -; - +; sre_mintestcnt_P(M) - minimum count for test set entries ; -; - +; gen_set_size_P(S) - initial size of generated grammar test set ; -; - +; min_grammar_prob_P(P) - minimum prob for grammar recognition to continue ; -; - +; min_skip_prob_P(P). - min prob for skipping to continue ; -; - +; unique_guards_P(yes) - if yes, guards in choice are unique; otherwise not. ; -; - +; elite_migrate_P(N, R) - if gen_type=separate, then N best individuals ; -; - +; migrate to next generation; if R=yes, then reeval fitness ; -; - +; negsetsize_P(S) - number negative examples to generate ; -; - +; eval_with_ID_P(T) - T=yes then include expr ID in call to evaluator ; -; - - - - - (= - (wd_P /pack/narsese/prolog/sre_dna/) True) -; - - - - (= - (fitness_func_P reg_gram_1.pl) True) -; - - - (= - (dctg_file_P sre3.pl) True) -; - - - - (= - (population_size_P 750 500) True) -; - ; -; - - - (= - (cull_method_P elite) True) -; - ; -; - - - (= - (max_runs_P 1 solution 50) True) -; - ; -; +; else don't include - (= - (prob_grow_P 0.5) True) -; - ; -; + (= (wd_P /pack/narsese/prolog/sre_dna/) True) - (= - (prob_crossover_P 0.9) True) -; - ; -; + (= (fitness_func_P reg_gram_1.pl) True) - (= - (reprod_P 3) True) -; - ; -; + (= (dctg_file_P sre3.pl) True) - (= - (prob_internal_crossover_P 0.9) True) -; - ; -; + (= (population_size_P 750 500) True) ; +; <-- 750, 500 + (= (cull_method_P elite) True) ; +; <-- tournament - (= - (prob_terminal_mutation_P 0.75) True) -; - ; -; + (= (max_runs_P 1 solution 50) True) ; +; <-- 5, solution, 35 + (= (prob_grow_P 0.5) True) ; +; <-- 0.25 - (= - (max_depth_P 10 17) True) -; - ; -; + (= (prob_crossover_P 0.9) True) ; +; <-- 0.90 + (= (reprod_P 3) True) ; +; <-- 3 - (= - (error_tolerance_P 0) True) -; - ; -; + (= (prob_internal_crossover_P 0.9) True) ; +; <-- 0.90 or no + (= (prob_terminal_mutation_P 0.75) True) ; +; <-- 0.75 or no - (= - (tournament_size_P 4 4) True) -; - ; -; + (= (max_depth_P 10 17) True) ; +; <-- 6, 17 + (= (error_tolerance_P 0) True) ; +; <-- 0.000001 - (= - (lamarckian_P 0.0 10 best 0.1) True) -; - ; -; + (= (tournament_size_P 4 4) True) ; +; <-- 2, 3 + (= (lamarckian_P 0.0 10 best 0.1) True) ; +; <-- 0.25, 10, best, 0.20; (0.0,...) = off ; -; - - - (= - (unique_population_P yes) True) -; - ; -; - - - (= - (trace_limit_P 0 0) True) -; - ; -; - - - (= - (rep_limit_P 2) True) -; - ; -; - - - (= - (max_string_length_P 20) True) -; - ; -; - - - (= - (seed_P random - (, $_ - (, $_ $_))) True) -; - ; -; - - - (= - (popn_dump_P no) True) -; - ; -; - - - (= - (gen_type_P steadystate) True) -; - ; -; - - - (= - (evaluator_reset_P generate_testset 100) True) -; - ; -; - - - (= - (reprod_verif_P no) True) -; - ; -; - - - (= - (user_args_P ()) True) -; - ; -; - +; lamarckian_P(0.25, 10, best, 0.20). - (= - (dctg_root_P expr) True) -; - ; -; + (= (unique_population_P yes) True) ; +; <-- no + (= (trace_limit_P 0 0) True) ; +; <-- (40, 90) - (= - (dctg_override_P () ()) True) -; - ; -; + (= (rep_limit_P 2) True) ; +; <-- 3 + (= (max_string_length_P 20) True) ; +; <-- 10 - (= - (mutation_range_P 0.1) True) -; - ; -; + (= (seed_P random (, $_ (, $_ $_))) True) ; +; <-- random, (_,_,_) + (= (popn_dump_P no) True) ; +; <-- no - (= - (sre_mintestcnt_P 2) True) -; - ; -; + (= (gen_type_P steadystate) True) ; +; <-- steadystate + (= (evaluator_reset_P generate_testset 100) True) ; +; <-- no - (= - (gen_set_size_P 1000) True) -; - ; -; + (= (reprod_verif_P no) True) ; +; <-- yes + (= (user_args_P ()) True) ; +; <-- eg. [], [_] or [_|_] if arity 0, 1 or 2 - (= - (min_grammar_prob_P 0.0001) True) + (= (dctg_root_P expr) True) ; ; - ; -; - - (= - (min_skip_prob_P 0.0001) True) -; - ; -; + (= (dctg_override_P () ()) True) ; +; <-- [], [] + (= (mutation_range_P 0.1) True) ; +; <-- was 0.025 - (= - (unique_guards_P no) True) -; - ; -; + (= (sre_mintestcnt_P 2) True) ; +; <-- 2 + (= (gen_set_size_P 1000) True) ; +; <-- 250 - (= - (elite_migrate_P 0 no) True) -; - ; -; + (= (min_grammar_prob_P 0.0001) True) ; +; <-- 1.0e-4 + (= (min_skip_prob_P 0.0001) True) ; +; <-- 1.0e-4 - (= - (negsetsize_P 30) True) -; - ; -; + (= (unique_guards_P no) True) ; +; <-- yes + (= (elite_migrate_P 0 no) True) ; +; <-- 10 - (= - (eval_with_ID_P no) True) -; - ; -; + (= (negsetsize_P 30) True) ; +; <-- 75 + (= (eval_with_ID_P no) True) ; +; <-- no diff --git a/sre_dna/reg_gram_1.metta b/sre_dna/reg_gram_1.metta index f638bf2..7637586 100644 --- a/sre_dna/reg_gram_1.metta +++ b/sre_dna/reg_gram_1.metta @@ -1,375 +1,243 @@ +; (convert_to_metta_file reg_gram_1 $_259542 sre_dna/reg_gram_1.pl sre_dna/reg_gram_1.metta) - (= - (?- - (dynamic - (/ testset 2))) True) -; - + (= (?- (dynamic (/ testset 2))) True) ; -; - +; Experiment: evolve a SRE to conform with this stoch. regular grammar ; -; - +; (from Carrasco & Forcado 96) ; ; - ; -; - +; S -> a S (0.2) ; -; - +; S -> b A (0.8) ; -; - +; A -> a B (0.7) ; -; - +; A -> b S (0.3) ; -; - +; B -> a A (0.4) ; -; - +; B -> b B (0.1) ; -; - +; B -> [] (0.5) ; ; - ; -; - +; Fitness: ; -; - +; - Mine expression K times, and compare distribution with test set. ; -; - +; - maximum string length enforced ; -; - +; - chi-square 2-bin test to compare distributions - (= - (evaluator $Expr $Fitness) - ( (testset $_ $TestSet) - (gen-set-size-P $Size) - (mine $Expr $Size $MineSet) - (tabulate-set $MineSet 0 $_ $MineSet2) - (chisquare-b $MineSet2 $TestSet $Size 0.0 $Fitness) - (set-det))) -; - - - - (= - (mine $_ 0 Nil) + (= (evaluator $Expr $Fitness) + (testset $_ $TestSet) + (gen-set-size-P $Size) + (mine $Expr $Size $MineSet) + (tabulate-set $MineSet 0 $_ $MineSet2) + (chisquare-b $MineSet2 $TestSet $Size 0.0 $Fitness) (set-det)) -; - - (= - (mine $Expr $K - (Cons $String $Rest)) - ( (^^ $Expr - (raw-generate $String 0 $_)) - (is $K2 - (- $K 1)) - (mine $Expr $K2 $Rest) - (set-det))) -; +; ;sre_mintestcnt_P(MC), ; new +; ; chisquare_2bins(MineSet2, TestSet, 0.0, Fitness), - - (= - (normalize $_ Nil Nil) + (= (mine $_ 0 Nil) + (set-det)) + (= (mine $Expr $K (Cons $String $Rest)) + (^^ $Expr + (raw-generate $String 0 $_)) + (is $K2 + (- $K 1)) + (mine $Expr $K2 $Rest) (set-det)) -; - - (= - (normalize $Size - (Cons - (, $A $C) $R) - (Cons - (, $A $P) $R2)) - ( (is $P - (/ $C $Size)) - (normalize $Size $R $R2) - (set-det))) -; - - (= - (chisquare-b $_ Nil $_ $Fit $Fit) + (= (normalize $_ Nil Nil) + (set-det)) + (= (normalize $Size (Cons (, $A $C) $R) (Cons (, $A $P) $R2)) + (is $P + (/ $C $Size)) + (normalize $Size $R $R2) (set-det)) -; - - (= - (chisquare-b $MineSet - (Cons - (, $Test $Prob) $Rest) $Sum $FitSoFar $Fitness) - ( (member-remove - (, $Test $Count2) $MineSet $MineSet2) - (is $X - (* $Prob $Sum)) - (is $T - (- $Count2 $X)) - (is $Fit2 - (+ $FitSoFar - (/ - (* $T $T) $X))) - (chisquare-b $MineSet2 $Rest $Sum $Fit2 $Fitness) - (set-det))) -; - (= - (chisquare-b $MineSet - (Cons - (, $_ $Prob) $Rest) $Sum $FitSoFar $Fitness) - ( (is $Fit2 - (+ $FitSoFar - (* $Prob $Sum))) - (chisquare-b $MineSet $Rest $Sum $Fit2 $Fitness) - (set-det))) -; + (= (chisquare-b $_ Nil $_ $Fit $Fit) + (set-det)) + (= (chisquare-b $MineSet (Cons (, $Test $Prob) $Rest) $Sum $FitSoFar $Fitness) + (member-remove + (, $Test $Count2) $MineSet $MineSet2) + (is $X + (* $Prob $Sum)) + (is $T + (- $Count2 $X)) + (is $Fit2 + (+ $FitSoFar + (/ + (* $T $T) $X))) + (chisquare-b $MineSet2 $Rest $Sum $Fit2 $Fitness) + (set-det)) + (= (chisquare-b $MineSet (Cons (, $_ $Prob) $Rest) $Sum $FitSoFar $Fitness) + (is $Fit2 + (+ $FitSoFar + (* $Prob $Sum))) + (chisquare-b $MineSet $Rest $Sum $Fit2 $Fitness) + (set-det)) - (= - (member-remove $X - (Cons $X $Y) $Y) + (= (member-remove $X (Cons $X $Y) $Y) (set-det)) -; - - (= - (member-remove $X - (Cons $Y $Z) - (Cons $Y $W)) + (= (member-remove $X (Cons $Y $Z) (Cons $Y $W)) (member-remove $X $Z $W)) -; - - (= - (count-and-remove $_ Nil Nil 0) + (= (count-and-remove $_ Nil Nil 0) (set-det)) -; - - (= - (count-and-remove $A - (Cons $A $R) $S $Count) - ( (set-det) - (count-and-remove $A $R $S $Count2) - (is $Count - (+ $Count2 1)))) -; - - (= - (count-and-remove $A - (Cons $B $R) - (Cons $B $S) $Count) - ( (set-det) (count-and-remove $A $R $S $Count))) -; - + (= (count-and-remove $A (Cons $A $R) $S $Count) + (set-det) + (count-and-remove $A $R $S $Count2) + (is $Count + (+ $Count2 1))) + (= (count-and-remove $A (Cons $B $R) (Cons $B $S) $Count) + (set-det) + (count-and-remove $A $R $S $Count)) ; -; - +; This should be called once per GP generation. - (= - (generate-testset) + (= (generate-testset) ( (or - (remove-symbol &self + (remove-is-symbol &self (testset $_ $_)) True) (gen-set-size-P $Size) (gen-set $Size $S) (sre-mintestcnt-P $MC) (tabulate-set $S $MC $Sum $T) (normalize $Sum $T $T2) - (add-symbol &self + (add-is-symbol &self (testset $Sum $T2)) (set-det))) -; - +; ; was 250 - (= - (gen_set 0 ()) True) -; - - (= - (gen-set $K - (Cons $S $R)) - ( (> $K 0) - (repeat) - (max-string-length-P $Max) - (gen-string s 0 $Max $S) - (is $K2 - (- $K 1)) - (set-det) - (gen-set $K2 $R))) -; - + (= (gen_set 0 ()) True) + (= (gen-set $K (Cons $S $R)) + (> $K 0) + (repeat) + (max-string-length-P $Max) + (gen-string s 0 $Max $S) + (is $K2 + (- $K 1)) + (set-det) + (gen-set $K2 $R)) - (= - (gen-string $NonTerm $Len $Max $String) - ( (=< $Len $Max) (det-if-then-else (production $NonTerm $Out $NextNonTerm) (, (is $Len2 (+ $Len 1)) (gen-string $NextNonTerm $Len2 $Max $R) (= $String (Cons $Out $R))) (= $String Nil)))) -; - + (= (gen-string $NonTerm $Len $Max $String) + (=< $Len $Max) + (det-if-then-else + (production $NonTerm $Out $NextNonTerm) + (, + (is $Len2 + (+ $Len 1)) + (gen-string $NextNonTerm $Len2 $Max $R) + (= $String + (Cons $Out $R))) + (= $String Nil))) ; -; - +; production(NonTerm, Output, NextNonTerm). - (= - (production s a s) + (= (production s a s) (maybe 0.2)) -; - - (= - (production s b a) True) -; - - (= - (production a a b) + (= (production s b a) True) + (= (production a a b) (maybe 0.7)) -; - - (= - (production a b s) True) -; - - (= - (production b a a) + (= (production a b s) True) + (= (production b a a) (maybe 0.4)) -; - - (= - (production b b b) + (= (production b b b) (maybe 0.167)) -; - ; -; - +; pre-filter and count test set, rather than repeatedly process ; -; - +; it during fitness evaluation of population. User can specify minimum ; -; - - - - (= - (tabulate_set () $_ 0 ()) True) -; - - (= - (tabulate-set - (Cons $A $R) $Min $Sum - (Cons - (, $A $C2) $S)) - ( (once (count-and-remove $A $R $R2 $C)) - (is $C2 - (+ $C 1)) - (> $C2 $Min) - (set-det) - (tabulate-set $R2 $Min $Sum2 $S) - (is $Sum - (+ $Sum2 $C2)))) -; +; count for processing. - (= - (tabulate-set - (Cons $_ $R) $Min $Sum $S) - ( (set-det) (tabulate-set $R $Min $Sum $S))) -; + (= (tabulate_set () $_ 0 ()) True) + (= (tabulate-set (Cons $A $R) $Min $Sum (Cons (, $A $C2) $S)) + (once (count-and-remove $A $R $R2 $C)) + (is $C2 + (+ $C 1)) + (> $C2 $Min) + (set-det) + (tabulate-set $R2 $Min $Sum2 $S) + (is $Sum + (+ $Sum2 $C2))) + (= (tabulate-set (Cons $_ $R) $Min $Sum $S) + (set-det) + (tabulate-set $R $Min $Sum $S)) !(multifile (/ chisquare 4)) -; - !(dynamic (/ chisquare 4)) -; - - - (= - (temp-test $Fitness) - ( (generate-tree expr full 12 $_ $Tree1 $_) - (write 'Mining 1... ') - (mine $Tree1 500 $MineSet1) - (repeat) - (generate-tree expr full 12 $_ $Tree2 $_) - (nl) - (write 'Mining 2... ') - (mine $Tree2 500 $MineSet2) - (nl) - (write 'chi square...') - (chisquare $MineSet1 $MineSet2 0.0 $Fitness) - (nl) - (^^ $Tree1 - (construct $Expr1)) - (^^ $Tree2 - (construct $Expr2)) - (write 'Expr 1:') - (sre-pp $Expr1) - (write 'Expr 2:') - (sre-pp $Expr2))) -; - - - (= - (chisquare-2bins Nil Nil $Fit $Fit) + (= (temp-test $Fitness) + (generate-tree expr full 12 $_ $Tree1 $_) + (write 'Mining 1... ') + (mine $Tree1 500 $MineSet1) + (repeat) + (generate-tree expr full 12 $_ $Tree2 $_) + (nl) + (write 'Mining 2... ') + (mine $Tree2 500 $MineSet2) + (nl) + (write 'chi square...') + (chisquare $MineSet1 $MineSet2 0.0 $Fitness) + (nl) + (^^ $Tree1 + (construct $Expr1)) + (^^ $Tree2 + (construct $Expr2)) + (write 'Expr 1:') + (sre-pp $Expr1) + (write 'Expr 2:') + (sre-pp $Expr2)) + + + (= (chisquare-2bins Nil Nil $Fit $Fit) + (set-det)) +; /* test_chi(F) :- generate_testset, testset(_,A), generate_testset, testset(_,B), chisquare(A,B,0,F). */ + (= (chisquare-2bins (Cons (, $_ $Count) $Rest) Nil $FitSoFar $Fit) + (is $Fit2 + (+ $FitSoFar $Count)) + (chisquare-2bins $Rest Nil $Fit2 $Fit) + (set-det)) + (= (chisquare-2bins $MineSet (Cons (, $Test $Count) $Rest) $FitSoFar $Fitness) + (member-remove + (, $Test $Count2) $MineSet $MineSet2) + (is $T + (- $Count2 $Count)) + (is $Fit2 + (+ $FitSoFar + (/ + (* $T $T) + (+ $Count $Count2)))) + (chisquare-2bins $MineSet2 $Rest $Fit2 $Fitness) + (set-det)) + (= (chisquare-2bins $MineSet (Cons (, $_ $Count) $Rest) $FitSoFar $Fitness) + (is $Fit2 + (+ $FitSoFar $Count)) + (chisquare-2bins $MineSet $Rest $Fit2 $Fitness) (set-det)) -; - - (= - (chisquare-2bins - (Cons - (, $_ $Count) $Rest) Nil $FitSoFar $Fit) - ( (is $Fit2 - (+ $FitSoFar $Count)) - (chisquare-2bins $Rest Nil $Fit2 $Fit) - (set-det))) -; - - (= - (chisquare-2bins $MineSet - (Cons - (, $Test $Count) $Rest) $FitSoFar $Fitness) - ( (member-remove - (, $Test $Count2) $MineSet $MineSet2) - (is $T - (- $Count2 $Count)) - (is $Fit2 - (+ $FitSoFar - (/ - (* $T $T) - (+ $Count $Count2)))) - (chisquare-2bins $MineSet2 $Rest $Fit2 $Fitness) - (set-det))) -; - - (= - (chisquare-2bins $MineSet - (Cons - (, $_ $Count) $Rest) $FitSoFar $Fitness) - ( (is $Fit2 - (+ $FitSoFar $Count)) - (chisquare-2bins $MineSet $Rest $Fit2 $Fitness) - (set-det))) -; - diff --git a/sre_dna/sre3.metta b/sre_dna/sre3.metta index bc03d03..f0d378d 100644 --- a/sre_dna/sre3.metta +++ b/sre_dna/sre3.metta @@ -1,1027 +1,479 @@ +; (convert_to_metta_file sre3 $_417696 sre_dna/sre3.pl sre_dna/sre3.metta) ; -; - +; DCTG grammar for stochastic regular expressions ; -; - +; Feb/99 ; ; - ; -; - +; Grammar: a | E:F | [a:E1(N1)+b:E2(N2)] | E*(Pr) | E+(Pr) ; ; - ; -; - +; epsilon e: epsilon (not allowed in constructs; equiv. to [] generation) ; -; - +; action: a ; -; - +; concatanation: E:F Pr(E:F) = Pr(E)*Pr(F) ; -; - +; choice: [E1(N1)+b:E2(N2)] Pr(Ei(Ni)) = Ni / N1+N2 ; -; - +; Kleene star: E*(P) Pr(E*) = [epsilon (1-P), (E:E*)(P)] ; -; - +; Kleene plus: E+(P) Pr(E+) = Pr(E:(E*(P))) ; ; - ; -; - +; where: Ni = integers >= 0, P is probability (0 <= P < 1) ; ; - ; -; - +; Also: (a) no directly nested iteration allowed (star, plus) ; -; - +; (b) choice must have at least 2 terms ; ; - ; -; - +; Semantic rules: ; -; - +; construct(E): makes a MeTTa structure equivalent of expression ; -; - +; generate(S,SL1,SL2,P): randomly interprets an expression, giving output ; -; - +; string S (as list) with associated probability P. ; -; - +; Note that repetition (star, plus) are executed according to ; -; - +; probability, as well as for a max. generated string length. ; -; - +; When length met, then no repetitions possible (max_string_length_P/1) ; -; - +; Resulting string may unavoidably exceed this max length. ; -; - +; raw_generate(S,SL1,SL2): like generate, but no probability computed. ; -; - +; recognize(S,P): finds way of recognizing a string with the ; -; - +; expression, resulting in probability P. Will work with backtracking, ; -; - +; so that all possibile derivations can be found (no probabilistic ; -; - +; execution as with generate/2. - (= - (<:> - (::= expr - (^^ iter_expr $A)) - (, - (::- - (construct $E) - (^^ $A - (construct $E))) - (, - (::- - (raw_generate $S $SL1 $SL2) - (^^ $A - (raw_generate $S $SL1 $SL2))) - (::- - (recognize $S $S2 $PrSoFar $Pr) - (, - (check_prob $PrSoFar) - (^^ $A - (recognize $S $S2 $PrSoFar $Pr))))))) True) -; - - - (= - (<:> - (::= expr - (^^ noniter_expr $A)) - (, - (::- - (construct $E) - (^^ $A - (construct $E))) - (, - (::- - (raw_generate $S $SL1 $SL2) - (^^ $A - (raw_generate $S $SL1 $SL2))) - (::- - (recognize $S $S2 $PrSoFar $Pr) - (, - (check_prob $PrSoFar) - (^^ $A - (recognize $S $S2 $PrSoFar $Pr))))))) True) -; + (= (<:> (::= expr (^^ iter_expr $A)) (, (::- (construct $E) (^^ $A (construct $E))) (, (::- (raw_generate $S $SL1 $SL2) (^^ $A (raw_generate $S $SL1 $SL2))) (::- (recognize $S $S2 $PrSoFar $Pr) (, (check_prob $PrSoFar) (^^ $A (recognize $S $S2 $PrSoFar $Pr))))))) True) + (= (<:> (::= expr (^^ noniter_expr $A)) (, (::- (construct $E) (^^ $A (construct $E))) (, (::- (raw_generate $S $SL1 $SL2) (^^ $A (raw_generate $S $SL1 $SL2))) (::- (recognize $S $S2 $PrSoFar $Pr) (, (check_prob $PrSoFar) (^^ $A (recognize $S $S2 $PrSoFar $Pr))))))) True) ; -; +; ------------------------------------- + (= (<:> (::= noniter_expr (a)) (, (construct a) (, (::- (raw_generate (a) $SL1 $SL2) (is $SL2 (+ $SL1 1))) (::- (recognize (Cons a $T) $T $PrSoFar $PrSoFar) (check_prob $PrSoFar))))) True) +; ; action a - (= - (<:> - (::= noniter_expr - (a)) - (, - (construct a) - (, - (::- - (raw_generate - (a) $SL1 $SL2) - (is $SL2 - (+ $SL1 1))) - (::- - (recognize - (Cons a $T) $T $PrSoFar $PrSoFar) - (check_prob $PrSoFar))))) True) -; - - - (= - (<:> - (::= noniter_expr - (b)) - (, - (construct b) - (, - (::- - (raw_generate - (b) $SL1 $SL2) - (is $SL2 - (+ $SL1 1))) - (::- - (recognize - (Cons b $T) $T $PrSoFar $PrSoFar) - (check_prob $PrSoFar))))) True) -; - + (= (<:> (::= noniter_expr (b)) (, (construct b) (, (::- (raw_generate (b) $SL1 $SL2) (is $SL2 (+ $SL1 1))) (::- (recognize (Cons b $T) $T $PrSoFar $PrSoFar) (check_prob $PrSoFar))))) True) +; ; action b ; -; - - - (= - (<:> - (::= noniter_expr - (, - (^^ guardedexpr_a $A1) - (, - (^^ intval $B1) - (, - (^^ guardedexpr_b $A2) - (^^ intval $B2))))) - (, - (::- - (construct - ( (, $E1 $N1) (, $E2 $N2))) - (, - (^^ $A1 - (construct $E1)) - (, - (^^ $B1 - (construct $N1)) - (, - (^^ $A2 - (construct $E2)) - (^^ $B2 - (construct $N2)))))) - (, - (::- - (raw_generate $S $SL1 $SL2) - (, - (^^ $B1 - (construct $N1)) - (, - (^^ $B2 - (construct $N2)) - (; - (-> - (raw_select_term - ($N1 $N2) 1) - (^^ $A1 - (raw_generate $S $SL1 $SL2))) - (^^ $A2 - (raw_generate $S $SL1 $SL2)))))) - (, - (::- - (recognize $S $S2 $PrSoFar $Pr) - (, - (^^ $B1 - (construct $Val1)) - (, - (^^ $B2 - (construct $Val2)) - (, - (is $Pr2 - (* $PrSoFar - (/ $Val1 - (+ $Val1 $Val2)))) - (, - (check_prob $Pr2) - (^^ $A1 - (recognize $S $S2 $Pr2 $Pr))))))) - (::- - (recognize $S $S2 $PrSoFar $Pr) - (, - (^^ $B1 - (construct $Val1)) - (, - (^^ $B2 - (construct $Val2)) - (, - (is $Pr2 - (* $PrSoFar - (/ $Val2 - (+ $Val1 $Val2)))) - (, - (check_prob $Pr2) - (^^ $A2 - (recognize $S $S2 $Pr2 $Pr))))))))))) True) -; +; - - - - + (= (<:> (::= noniter_expr (, (^^ guardedexpr_a $A1) (, (^^ intval $B1) (, (^^ guardedexpr_b $A2) (^^ intval $B2))))) (, (::- (construct ((, $E1 $N1) (, $E2 $N2))) (, (^^ $A1 (construct $E1)) (, (^^ $B1 (construct $N1)) (, (^^ $A2 (construct $E2)) (^^ $B2 (construct $N2)))))) (, (::- (raw_generate $S $SL1 $SL2) (, (^^ $B1 (construct $N1)) (, (^^ $B2 (construct $N2)) (; (-> (raw_select_term ($N1 $N2) 1) (^^ $A1 (raw_generate $S $SL1 $SL2))) (^^ $A2 (raw_generate $S $SL1 $SL2)))))) (, (::- (recognize $S $S2 $PrSoFar $Pr) (, (^^ $B1 (construct $Val1)) (, (^^ $B2 (construct $Val2)) (, (is $Pr2 (* $PrSoFar (/ $Val1 (+ $Val1 $Val2)))) (, (check_prob $Pr2) (^^ $A1 (recognize $S $S2 $Pr2 $Pr))))))) (::- (recognize $S $S2 $PrSoFar $Pr) (, (^^ $B1 (construct $Val1)) (, (^^ $B2 (construct $Val2)) (, (is $Pr2 (* $PrSoFar (/ $Val2 (+ $Val1 $Val2)))) (, (check_prob $Pr2) (^^ $A2 (recognize $S $S2 $Pr2 $Pr))))))))))) True) ; -; - - - (= - (<:> - (::= noniter_expr - (, - (^^ expr $A) - (^^ expr $B))) - (, - (::- - (construct - (: $E $F)) - (, - (^^ $A - (construct $E)) - (^^ $B - (construct $F)))) - (, - (::- - (raw_generate $S $SL1 $SL2) - (, - (^^ $A - (raw_generate $S1 $SL1 $SL3)) - (, - (^^ $B - (raw_generate $S2 $SL3 $SL2)) - (append $S1 $S2 $S)))) - (::- - (recognize $S $S2 $PrSoFar $Pr) - (, - (check_prob $PrSoFar) - (, - (^^ $A - (recognize $S $S3 $PrSoFar $Pr1)) - (, - (check_prob $Pr1) - (^^ $B - (recognize $S3 $S2 $Pr1 $Pr))))))))) True) -; +; - - - - + (= (<:> (::= noniter_expr (, (^^ expr $A) (^^ expr $B))) (, (::- (construct (: $E $F)) (, (^^ $A (construct $E)) (^^ $B (construct $F)))) (, (::- (raw_generate $S $SL1 $SL2) (, (^^ $A (raw_generate $S1 $SL1 $SL3)) (, (^^ $B (raw_generate $S2 $SL3 $SL2)) (append $S1 $S2 $S)))) (::- (recognize $S $S2 $PrSoFar $Pr) (, (check_prob $PrSoFar) (, (^^ $A (recognize $S $S3 $PrSoFar $Pr1)) (, (check_prob $Pr1) (^^ $B (recognize $S3 $S2 $Pr1 $Pr))))))))) True) +; ; concat ; -; - - - (= - (<:> - (::= iter_expr - (, - (^^ noniter_expr $A) - (^^ probval $B))) - (, - (::- - (construct - (* $E $P)) - (, - (^^ $A - (construct $E)) - (^^ $B - (construct $P)))) - (, - (::- - (raw_generate $S $SL1 $SL2) - (, - (^^ $B - (construct $P)) - (, - (max_string_length_P $MaxL) - (raw_gen_loop $A $P $MaxL $S $SL1 $SL2)))) - (::- - (recognize $S $S2 $PrSoFar $Pr) - (, - (check_prob $PrSoFar) - (, - (^^ $B - (construct $Pr1)) - (recognize_loop $A $Pr1 $S $S2 $PrSoFar $Pr))))))) True) -; +; ------------------------------------- + (= (<:> (::= iter_expr (, (^^ noniter_expr $A) (^^ probval $B))) (, (::- (construct (* $E $P)) (, (^^ $A (construct $E)) (^^ $B (construct $P)))) (, (::- (raw_generate $S $SL1 $SL2) (, (^^ $B (construct $P)) (, (max_string_length_P $MaxL) (raw_gen_loop $A $P $MaxL $S $SL1 $SL2)))) (::- (recognize $S $S2 $PrSoFar $Pr) (, (check_prob $PrSoFar) (, (^^ $B (construct $Pr1)) (recognize_loop $A $Pr1 $S $S2 $PrSoFar $Pr))))))) True) +; ; star ; -; - - - (= - (<:> - (::= iter_expr - (, - (^^ noniter_expr $A) - (^^ probval $B))) - (, - (::- - (construct - (+ $E $P)) - (, - (^^ $A - (construct $E)) - (^^ $B - (construct $P)))) - (, - (::- - (raw_generate $S $SL1 $SL2) - (, - (^^ $A - (raw_generate $S1 $SL1 $SL3)) - (, - (^^ $B - (construct $P)) - (, - (max_string_length_P $MaxL) - (, - (raw_gen_loop $A $P $MaxL $S2 $SL3 $SL2) - (, - (append $S1 $S2 $S) !)))))) - (::- - (recognize $S $S2 $PrSoFar $Pr) - (, - (check_prob $PrSoFar) - (, - (^^ $A - (recognize $S $S3 $PrSoFar $Pr1)) - (, - (\+ - (= $S $S3)) - (, - (check_prob $Pr1) - (, - (^^ $B - (construct $Pr2)) - (recognize_loop $A $Pr2 $S3 $S2 $Pr1 $Pr)))))))))) True) -; +; - - - - + (= (<:> (::= iter_expr (, (^^ noniter_expr $A) (^^ probval $B))) (, (::- (construct (+ $E $P)) (, (^^ $A (construct $E)) (^^ $B (construct $P)))) (, (::- (raw_generate $S $SL1 $SL2) (, (^^ $A (raw_generate $S1 $SL1 $SL3)) (, (^^ $B (construct $P)) (, (max_string_length_P $MaxL) (, (raw_gen_loop $A $P $MaxL $S2 $SL3 $SL2) (, (append $S1 $S2 $S) !)))))) (::- (recognize $S $S2 $PrSoFar $Pr) (, (check_prob $PrSoFar) (, (^^ $A (recognize $S $S3 $PrSoFar $Pr1)) (, (\+ (= $S $S3)) (, (check_prob $Pr1) (, (^^ $B (construct $Pr2)) (recognize_loop $A $Pr2 $S3 $S2 $Pr1 $Pr)))))))))) True) +; ; plus +; ; new ; -; - - - (= - (<:> - (::= guardedexpr_a - (a)) - (, - (construct a) - (, - (::- - (raw_generate - (a) $SL1 $SL2) - (is $SL2 - (+ $SL1 1))) - (::- - (recognize - (Cons a $T) $T $PrSoFar $PrSoFar) - (check_prob $PrSoFar))))) True) -; - - - (= - (<:> - (::= guardedexpr_a - (, - (a) - (^^ expr $A))) - (, - (::- - (construct - (: a $E)) - (^^ $A - (construct $E))) - (, - (::- - (raw_generate - (Cons a $S) $SL1 $SL2) - (, - (^^ $A - (raw_generate $S $SL1 $SL3)) - (is $SL2 - (+ $SL3 1)))) - (::- - (recognize - (Cons a $S) $S2 $PrSoFar $Pr) - (, - (check_prob $PrSoFar) - (^^ $A - (recognize $S $S2 $PrSoFar $Pr))))))) True) -; - +; ------------------------------------- - (= - (<:> - (::= guardedexpr_b - (b)) - (, - (construct b) - (, - (::- - (raw_generate - (b) $SL1 $SL2) - (is $SL2 - (+ $SL1 1))) - (::- - (recognize - (Cons b $T) $T $PrSoFar $PrSoFar) - (check_prob $PrSoFar))))) True) -; + (= (<:> (::= guardedexpr_a (a)) (, (construct a) (, (::- (raw_generate (a) $SL1 $SL2) (is $SL2 (+ $SL1 1))) (::- (recognize (Cons a $T) $T $PrSoFar $PrSoFar) (check_prob $PrSoFar))))) True) +; ; action a + (= (<:> (::= guardedexpr_a (, (a) (^^ expr $A))) (, (::- (construct (: a $E)) (^^ $A (construct $E))) (, (::- (raw_generate (Cons a $S) $SL1 $SL2) (, (^^ $A (raw_generate $S $SL1 $SL3)) (is $SL2 (+ $SL3 1)))) (::- (recognize (Cons a $S) $S2 $PrSoFar $Pr) (, (check_prob $PrSoFar) (^^ $A (recognize $S $S2 $PrSoFar $Pr))))))) True) +; ; concat - (= - (<:> - (::= guardedexpr_b - (, - (b) - (^^ expr $A))) - (, - (::- - (construct - (: b $E)) - (^^ $A - (construct $E))) - (, - (::- - (raw_generate - (Cons b $S) $SL1 $SL2) - (, - (^^ $A - (raw_generate $S $SL1 $SL3)) - (is $SL2 - (+ $SL3 1)))) - (::- - (recognize - (Cons b $S) $S2 $PrSoFar $Pr) - (, - (check_prob $PrSoFar) - (^^ $A - (recognize $S $S2 $PrSoFar $Pr))))))) True) -; + (= (<:> (::= guardedexpr_b (b)) (, (construct b) (, (::- (raw_generate (b) $SL1 $SL2) (is $SL2 (+ $SL1 1))) (::- (recognize (Cons b $T) $T $PrSoFar $PrSoFar) (check_prob $PrSoFar))))) True) +; ; action b + (= (<:> (::= guardedexpr_b (, (b) (^^ expr $A))) (, (::- (construct (: b $E)) (^^ $A (construct $E))) (, (::- (raw_generate (Cons b $S) $SL1 $SL2) (, (^^ $A (raw_generate $S $SL1 $SL3)) (is $SL2 (+ $SL3 1)))) (::- (recognize (Cons b $S) $S2 $PrSoFar $Pr) (, (check_prob $PrSoFar) (^^ $A (recognize $S $S2 $PrSoFar $Pr))))))) True) +; ; concat ; -; - - - (= - (<:> - (::= intval - (, - ($N) - { (is_an_integer $N) })) - (construct $N)) True) -; - +; ------------------------------------- - (= - (<:> - (::= probval - (, - ($R) - { (is_a_probability $R) })) - (construct $R)) True) -; + (= (<:> (::= intval (, ($N) {(is_an_integer $N) })) (construct $N)) True) + (= (<:> (::= probval (, ($R) {(is_a_probability $R) })) (construct $R)) True) ; -; - +; ------------------------------------ ; -; - +; MeTTa utilities... ; -; - +; ------------------------------------ ; -; - +; is_an_integer(N): ; -; - +; N - integer value ; -; - +; Succeeds if N is an integer. If N is variable, a random integer ; -; - - - - (= - (is-an-integer $N) - ( (integer $N) (set-det))) -; - - (= - (is-an-integer $N) - ( (int-range $Low $High) (random $Low $High $N))) -; +; in desired range is created. + (= (is-an-integer $N) + (integer $N) + (set-det)) + (= (is-an-integer $N) + (int-range $Low $High) + (random $Low $High $N)) - (= - (int_range 0 1000) True) -; + (= (int_range 0 1000) True) ; -; - +; ------------------------------------ ; -; - +; is_a_probability(R): ; -; - +; R - real value 0.0 <= R < 1.0 ; -; - +; Succeeds if R is a float, 0.0 <= R < 1.0. ; -; - +; If R is variable, a random probability in desired range is created. - (= - (is-a-probability $R) - ( (float $R) (set-det))) -; - - (= - (is-a-probability $R) - ( (random $T) (is $R (/ (truncate (* $T 100)) 100)))) -; - + (= (is-a-probability $R) + (float $R) + (set-det)) + (= (is-a-probability $R) + (random $T) + (is $R + (/ + (truncate (* $T 100)) 100))) ; -; - +; ------------------------------------ ; -; - +; raw_select_term(L, K): ; -; - +; L - list of probability weights ; -; - +; K - kth term selected via prob. weighting (between 1 and length(L)) ; -; - +; Pr - calculated probability of selected term ; -; - +; Like select_term, but no probability computed. - (= - (raw-select-term $L $K) - ( (sumlist $L $SL 0 $Sum) - (random 0 $Sum $X) - (select-kth-term $SL $X 1 $K $_) - (set-det))) -; - + (= (raw-select-term $L $K) + (sumlist $L $SL 0 $Sum) + (random 0 $Sum $X) + (select-kth-term $SL $X 1 $K $_) + (set-det)) ; -; - +; ------------------------------------ ; -; - +; sumlist(A, B, L, S): ; -; - +; A - list of weights ; -; - +; B - summed list of weights (roulette wheel) ; -; - +; L - sum so far ; -; - +; S - final sum ; -; - +; Creates a summed list of prob weights, with final total S. - (= - (sumlist () () $Sum $Sum) True) -; - - (= - (sumlist - (Cons $N $R) - (Cons $NewSum $SumList2) $LastSum $Sum) - ( (is $NewSum - (+ $LastSum $N)) (sumlist $R $SumList2 $NewSum $Sum))) -; - + (= (sumlist () () $Sum $Sum) True) + (= (sumlist (Cons $N $R) (Cons $NewSum $SumList2) $LastSum $Sum) + (is $NewSum + (+ $LastSum $N)) + (sumlist $R $SumList2 $NewSum $Sum)) ; -; - +; ------------------------------------ ; -; - +; select_kth_term(W, Val, SoFar, K, Val) ; -; - +; W - list of summed weights (roulette wheel) ; -; - +; Val - random value in wheel to use ; -; - +; SoFar - counter ; -; - +; K - selected term according to Val on W ; -; - +; Val - value of selected term - (= - (select-kth-term - (:: $Val) $_ $K $K $Val) + (= (select-kth-term (:: $Val) $_ $K $K $Val) + (set-det)) + (= (select-kth-term (Cons $Val $_) $X $K $K $Val) + (>= $Val $X) (set-det)) -; - - (= - (select-kth-term - (Cons $Val $_) $X $K $K $Val) - ( (>= $Val $X) (set-det))) -; - - (= - (select-kth-term - (Cons $_ $R) $X $K $K2 $Val) - ( (is $K3 - (+ $K 1)) (select-kth-term $R $X $K3 $K2 $Val))) -; - + (= (select-kth-term (Cons $_ $R) $X $K $K2 $Val) + (is $K3 + (+ $K 1)) + (select-kth-term $R $X $K3 $K2 $Val)) ; -; - +; ------------------------------------ ; -; - +; raw_gen_loop(Tree, Pr, MaxL, S, SL1, SL2): ; -; - +; Tree - grammar tree to process ; -; - +; Pr - probability of doing an iteration ; -; - +; MaxL - max length of generated string for terminating looping ; -; - +; S - final generated string ; -; - +; SL1, SL2 - current length and final length of generated string ; -; - - +; Like gen_loop, but no probabilities computed. - (= - (raw-gen-loop $Tree $Pr $MaxL $S $SL1 $SL2) - ( (< $SL1 $MaxL) - (maybe $Pr) - (^^ $Tree - (raw-generate $S1 $SL1 $SL3)) - (raw-gen-loop $Tree $Pr $MaxL $S2 $SL3 $SL2) - (append $S1 $S2 $S) - (set-det))) -; - (= - (raw-gen-loop $Tree $Pr $_ Nil $SL $SL) + (= (raw-gen-loop $Tree $Pr $MaxL $S $SL1 $SL2) + (< $SL1 $MaxL) + (maybe $Pr) + (^^ $Tree + (raw-generate $S1 $SL1 $SL3)) + (raw-gen-loop $Tree $Pr $MaxL $S2 $SL3 $SL2) + (append $S1 $S2 $S) + (set-det)) + (= (raw-gen-loop $Tree $Pr $_ Nil $SL $SL) (set-det)) -; - ; -; - +; ------------------------------------ ; -; - +; recognize_loop(Tree, Pr, S, S2, FinalPr): ; -; - +; Tree - grammar tree to process ; -; - +; Pr - probability of doing an iteration ; -; - +; S, S2 - string to recognize (before, after) ; -; - +; FinalPr - final probability of execution ; -; - +; recognize_loop performs successive iterations of an iterative expression. ; -; - +; Attempts to recognize S, computing probability each time. ; -; - +; No limit to number of iterations, other than the ability to consume S. ; -; - +; epsilon ; -; - +; E ; -; - +; E:E ; -; - +; E:E:E etc. ; -; - +; As soon as an iteration fails to consume (after backtracking as well), ; -; +; then iteration quits. + (= (recognize-loop $_ $Pr Nil Nil $PrSoFar $FinalPr) + (set-det) + (is $FinalPr + (* $PrSoFar + (- 1.0 $Pr))) + (check-prob $FinalPr)) +; ; new + (= (recognize-loop $T $Pr $S $S $PrSoFar $FinalPr) + (is $FinalPr + (* $PrSoFar + (- 1.0 $Pr))) + (check-prob $FinalPr)) + (= (recognize-loop $Tree $Pr $S $S2 $PrSoFar $FinalPr) + (is $Pr3 + (* $PrSoFar $Pr)) + (check-prob $Pr3) + (^^ $Tree + (recognize $S $S3 $Pr3 $Pr1)) + (not (= $S $S3)) + (check-prob $Pr1) + (recognize-loop $Tree $Pr $S3 $S2 $Pr1 $FinalPr)) - (= - (recognize-loop $_ $Pr Nil Nil $PrSoFar $FinalPr) - ( (set-det) - (is $FinalPr - (* $PrSoFar - (- 1.0 $Pr))) - (check-prob $FinalPr))) -; - - (= - (recognize-loop $T $Pr $S $S $PrSoFar $FinalPr) - ( (is $FinalPr - (* $PrSoFar - (- 1.0 $Pr))) (check-prob $FinalPr))) -; - - (= - (recognize-loop $Tree $Pr $S $S2 $PrSoFar $FinalPr) - ( (is $Pr3 - (* $PrSoFar $Pr)) - (check-prob $Pr3) - (^^ $Tree - (recognize $S $S3 $Pr3 $Pr1)) - (not (= $S $S3)) - (check-prob $Pr1) - (recognize-loop $Tree $Pr $S3 $S2 $Pr1 $FinalPr))) -; - - - - (= - (check-prob $P) - ( (min-grammar-prob-P $E) - (> $P $E) - (set-det))) -; + (= (check-prob $P) + (min-grammar-prob-P $E) + (> $P $E) + (set-det)) ; -; - -; -; - - - - (= - (sre $Type $Expr $String $SL) - ( (repeat) - (or - (= $Type full) - (= $Type grow)) - (generate-tree expr $Type 12 $_ $Tree $_) +; ------------------------------------ +; +; for testing... + + + (= (sre $Type $Expr $String $SL) + (repeat) + (or + (= $Type full) + (= $Type grow)) + (generate-tree expr $Type 12 $_ $Tree $_) + (^^ $Tree + (construct $Expr)) + (^^ $Tree + (raw-generate $String 0 $SL)) + (nl) + (sre-pp $Expr) + (nl) + (write 'tree ') + (write $Tree) + (nl) + (tree-depth $Tree $Depth) + (write 'Depth = ') + (write $Depth) + (nl)) + + + (= (sre2 $Type $Expr $Input) + (repeat) + (or + (= $Type full) + (= $Type grow)) + (generate-tree expr $Type 12 $_ $Tree $_) + (^^ $Tree + (construct $Expr)) + (nl) + (write $Type) + (nl) + (sre-pp $Expr) + (nl) + (bagof + (, $Leftover $Pr) (^^ $Tree - (construct $Expr)) + (recognize $Input $Leftover 1.0 $Pr)) $Rlist) + (write 'Recog list: ') + (nl) + (writelist $Rlist) + (nl)) + + + (= (sre2c $Type $Expr $Input) + (repeat) + (or + (= $Type full) + (= $Type grow)) + (generate-tree expr $Type 12 $_ $Tree $_) + (^^ $Tree + (construct $Expr)) + (nl) + (write $Type) + (nl) + (sre-pp $Expr) + (nl) + (bagof $Pr (^^ $Tree - (raw-generate $String 0 $SL)) - (nl) - (sre-pp $Expr) - (nl) - (write 'tree ') - (write $Tree) - (nl) - (tree-depth $Tree $Depth) - (write 'Depth = ') - (write $Depth) - (nl))) -; - - - - (= - (sre2 $Type $Expr $Input) - ( (repeat) - (or - (= $Type full) - (= $Type grow)) - (generate-tree expr $Type 12 $_ $Tree $_) - (^^ $Tree - (construct $Expr)) - (nl) - (write $Type) - (nl) - (sre-pp $Expr) - (nl) - (bagof - (, $Leftover $Pr) - (^^ $Tree - (recognize $Input $Leftover 1.0 $Pr)) $Rlist) - (write 'Recog list: ') - (nl) - (writelist $Rlist) - (nl))) -; - - - - (= - (sre2c $Type $Expr $Input) - ( (repeat) - (or - (= $Type full) - (= $Type grow)) - (generate-tree expr $Type 12 $_ $Tree $_) - (^^ $Tree - (construct $Expr)) - (nl) - (write $Type) - (nl) - (sre-pp $Expr) - (nl) - (bagof $Pr - (^^ $Tree - (recognize $Input Nil 1.0 $Pr)) $Prlist) - (write 'Pr list: ') - (nl) - (writelist $Prlist) - (nl))) -; - - - - (= - (sre2b $Input) - ( (generate-tree expr grow 8 $_ $Tree $_) - (^^ $Tree - (construct $Expr)) - (^^ $Tree - (recognize $Input $Leftover 1.0 $Pr)) - (nl) - (sre-pp $Expr) - (nl) - (write 'Prob = ') - (write $Pr) - (nl) - (write 'Leftover = ') - (write $Leftover) - (nl))) -; - - -; -; - -; -; - - - - (= - (sre-pp (* $E $R)) - ( (write () - (sre-pp $E) - (write )*) - (write $R) - (set-det))) -; - - (= - (sre-pp (+ $E $R)) - ( (write () - (sre-pp $E) - (write )+) - (write $R) - (set-det))) -; - - (= - (sre-pp (with_self $E $F)) - ( (sre-pp $E) - (write :) - (sre-pp $F) - (set-det))) -; - - (= - (sre-pp (Cons $A $T)) - ( (sre-pp-l (Cons $A $T)) (set-det))) -; - - (= - (sre-pp (, $A $B)) - ( (write () - (sre-pp $A) - (write ,) - (write $B) - (write )) - (set-det))) -; - - (= - (sre-pp $X) + (recognize $Input Nil 1.0 $Pr)) $Prlist) + (write 'Pr list: ') + (nl) + (writelist $Prlist) + (nl)) + + + (= (sre2b $Input) + (generate-tree expr grow 8 $_ $Tree $_) + (^^ $Tree + (construct $Expr)) + (^^ $Tree + (recognize $Input $Leftover 1.0 $Pr)) + (nl) + (sre-pp $Expr) + (nl) + (write 'Prob = ') + (write $Pr) + (nl) + (write 'Leftover = ') + (write $Leftover) + (nl)) + +; +; ------------------------------------ +; +; sre pretty printer + + + (= (sre-pp (* $E $R)) + (write () + (sre-pp $E) + (write )*) + (write $R) + (set-det)) + (= (sre-pp (+ $E $R)) + (write () + (sre-pp $E) + (write )+) + (write $R) + (set-det)) + (= (sre-pp (with_self $E $F)) + (sre-pp $E) + (write :) + (sre-pp $F) + (set-det)) + (= (sre-pp (Cons $A $T)) + (sre-pp-l (Cons $A $T)) + (set-det)) + (= (sre-pp (, $A $B)) + (write () + (sre-pp $A) + (write ,) + (write $B) + (write )) + (set-det)) + (= (sre-pp $X) (write $X)) -; - - - - (= - (sre-pp-l (:: $A)) - ( (sre-pp $A) (set-det))) -; - (= - (sre-pp-l (Cons $A $T)) - ( (write [) - (sre-pp $A) - (write +) - (sre-pp-l $T) - (write ]) - (set-det))) -; + (= (sre-pp-l (:: $A)) + (sre-pp $A) + (set-det)) + (= (sre-pp-l (Cons $A $T)) + (write [) + (sre-pp $A) + (write +) + (sre-pp-l $T) + (write ]) + (set-det)) ; -; - +; ------------------------------------ ; -; - +; solution dump: writes soln expression to a file, for input later. ; -; - +; Grammatical expression is written in multiple lines, since the full ; -; - - -; +; expression is often larger than MeTTa's builtin "write" can handle. +; /* write_soln(Run, E) :- set_file_name("soln", Run, File), tell(File), write('soln('), write_term(E), write(').'), nl, told, tell(user), !. write_term(node(X,List,Y)) :- !, write('node('), write(X), write(',['), write_tlist(List), write('],'), write(Y), write(')'). write_term(X) :- write(X). write_tlist([]) :- !. write_tlist([X,Y|Z]) :- !, write_term(X), write(','), nl, write_tlist([Y|Z]). write_tlist([X]) :- write_term(X). */ diff --git a/sre_dna/utils.metta b/sre_dna/utils.metta index 80930d3..351e079 100644 --- a/sre_dna/utils.metta +++ b/sre_dna/utils.metta @@ -1,248 +1,160 @@ +; (convert_to_metta_file utils $_148720 sre_dna/utils.pl sre_dna/utils.metta) ; -; - +; ------------------------------------------------ ; -; - +; January 1999 ; -; - +; Author: Brian Ross ; -; - +; Dept. of Computer Science, Brock University ; ; - ; -; - +; Misc MeTTa predicates. ; ; - ; -; - +; Sicstus: comment out member ; -; - +; - add routines for random numbers (seed, maybe, ...) - (= - (?- - (dynamic - (/ been_here 0))) True) -; - + (= (?- (dynamic (/ been_here 0))) True) ; -; - +; append([], A, A). ; -; - +; append([A|X], Y, [A|Z]) :- append(X, Y, Z). ; -; - +; member(A, [A|_]). ; -; - +; member(A, [_|B]) :- member(A, B). - (= - (memberd $A $L) + (= (memberd $A $L) (once (member $A $L))) -; - ; -; - +; my_random(R, N) finds a random integer N between 1 and R ; -; +; Note: N must be uninstantiated! - - (= - (my-random $R $N) - ( (random-between 1 $R $N) (set-det))) -; - + (= (my-random $R $N) + (random-between 1 $R $N) + (set-det)) +; ; S is R + 1, ; -; - +; probability2(P, M) satisfied when random number between 0 and M ; -; - - +; is less or equal to probability P. - (= - (probability2 $P $M) - ( (random $X) - (is $Y - (* $X $M)) - (=< $Y $P) - (set-det))) -; + (= (probability2 $P $M) + (random $X) + (is $Y + (* $X $M)) + (=< $Y $P) + (set-det)) - (= - (size_of () 0) True) -; - - (= - (size-of - (Cons $_ $R) $K) - ( (size-of $R $L) - (is $K - (+ $L 1)) - (set-det))) -; - + (= (size_of () 0) True) + (= (size-of (Cons $_ $R) $K) + (size-of $R $L) + (is $K + (+ $L 1)) + (set-det)) ; -; - - - - (= - (writel Nil) - ( (set-det) (ttyflush))) -; - - (= - (writel (Cons $A $R)) - ( (var $A) - (set-det) - (write $A) - (write ' ') - (writel $R))) -; - - (= - (writel (Cons nl $R)) - ( (set-det) - (nl) - (writel $R))) -; - - (= - (writel (Cons $A $R)) - ( (set-det) - (write $A) - (write ' ') - (writel $R))) -; - - (= - (writel $A) - ( (write $A) - (ttyflush) - (set-det))) -; - - - - (= - (writel2 Nil) - ( (set-det) (ttyflush))) -; - - (= - (writel2 (Cons $A $R)) - ( (var $A) - (set-det) - (write $A) - (writel2 $R))) -; - - (= - (writel2 (Cons nl $R)) - ( (set-det) - (nl) - (writel2 $R))) -; - - (= - (writel2 (Cons $A $R)) - ( (set-det) - (write $A) - (writel2 $R))) -; +; once(P) :- P, !. + + + (= (writel Nil) + (set-det) + (ttyflush)) + (= (writel (Cons $A $R)) + (var $A) + (set-det) + (write $A) + (write ' ') + (writel $R)) + (= (writel (Cons nl $R)) + (set-det) + (nl) + (writel $R)) + (= (writel (Cons $A $R)) + (set-det) + (write $A) + (write ' ') + (writel $R)) + (= (writel $A) + (write $A) + (ttyflush) + (set-det)) - (= - (writel2 $A) - ( (write $A) - (ttyflush) - (set-det))) -; + (= (writel2 Nil) + (set-det) + (ttyflush)) + (= (writel2 (Cons $A $R)) + (var $A) + (set-det) + (write $A) + (writel2 $R)) + (= (writel2 (Cons nl $R)) + (set-det) + (nl) + (writel2 $R)) + (= (writel2 (Cons $A $R)) + (set-det) + (write $A) + (writel2 $R)) + (= (writel2 $A) + (write $A) + (ttyflush) + (set-det)) - (= - (copy-struct $S $T) - ( (add-symbol &self + (= (copy-struct $S $T) + ( (add-is-symbol &self (temp $S)) - (remove-symbol &self + (remove-is-symbol &self (temp $T)) (set-det))) -; +; /* sum_list([], 0). sum_list([A|L], N) :- sum_list(L, M), N is M + A, !. max_list([A|L], Max) :- once(max_list2(A, L, Max)). max_list2(A, [], A). max_list2(A, [B|L], Max) :- B > A, max_list2(B, L, Max). max_list2(A, [_|L], Max) :- max_list2(A, L, Max). min_list([A|L], Min) :- once(min_list2(A, L, Min)). min_list2(A, [], A). min_list2(A, [B|L], Min) :- B < A, min_list2(B, L, Min). min_list2(A, [_|L], Min) :- min_list2(A, L, Min). */ - - (= - (count $_ () 0) True) -; - - (= - (count $X - (Cons $X $Y) $C) - ( (set-det) - (count $X $Y $C2) - (is $C - (+ $C2 1)))) -; - - (= - (count $X - (Cons $_ $Y) $C) + (= (count $_ () 0) True) + (= (count $X (Cons $X $Y) $C) + (set-det) + (count $X $Y $C2) + (is $C + (+ $C2 1))) + (= (count $X (Cons $_ $Y) $C) (count $X $Y $C)) -; - - - - (= - (round $X $Y) - ( (is $Y - (integer (+ $X 0.5))) (set-det))) -; + (= (round $X $Y) + (is $Y + (integer (+ $X 0.5))) + (set-det)) - (= - (set-random-number-gen) - ( (been-here) (set-det))) -; - (= - (set-random-number-gen) - ( (add-symbol &self been_here) + (= (set-random-number-gen) + (been-here) + (set-det)) + (= (set-random-number-gen) + ( (add-is-symbol &self been_here) (set-det) (seed-P $X $Y) (set-seed $X $Y))) -; - - (= - (set-seed default $_) + (= (set-seed default $_) (set-det)) -; - - (= - (set-seed random $_) + (= (set-seed random $_) ( (datime (datime $Year $Month $Day $Hour $Min $Sec)) (is $N (+ @@ -270,312 +182,180 @@ (+ (mod $N3 30324) 1)) (setrand (rand $R1 $R2 $R3)) - (remove-symbol &self + (remove-is-symbol &self (seed_P $_ $_)) - (add-symbol &self + (add-is-symbol &self (seed_P random (, $R1 (, $R2 $R3)))) (set-det))) -; - - (= - (set-seed manual - (, $X $Y $Z)) +; ; N is approx number of seconds since Jan 1 1970 +; ; between 1 and 30000 +; ; shift right 2 bits +; ; shift right 4 bits + (= (set-seed manual (, $X $Y $Z)) (setrand (rand $X $Y $Z))) -; - - (= - (debug-echo $L) - ( (debug-set-P yes) - (set-det) - (writel $L))) -; - - (= - (debug_echo $_) True) -; - - - - (= - (rem_dups () ()) True) -; - - (= - (rem-dups - (Cons $A $R) $R2) - ( (member $A $R) - (set-det) - (rem-dups $R $R2))) -; - - (= - (rem-dups - (Cons $A $R) - (Cons $A $R2)) - ( (rem-dups $R $R2) (set-det))) -; + (= (debug-echo $L) + (debug-set-P yes) + (set-det) + (writel $L)) +; /* set_seed(default, _) :- !. set_seed(random, _) :- now(N), R1 is mod(N, 30000) + 1, ; between 1 and 30000 N2 is abs(N >> 2), ; shift right 2 bits R2 is mod(N2, 30000) + 1, N3 is abs(N >> 4), ; shift right 4 bits R3 is mod(N3, 30000) + 1, getrand(random(_,_,_,B)), setrand(random(R1,R2,R3,B)), retract(seed_P(_,_)), assert(seed_P(random, (R1,R2,R3))), !. set_seed(manual, (X, Y, Z)) :- getrand(random(_,_,_,B)), ; use default bit string (could be changed) setrand(random(X,Y,Z,B)), !. */ + (= (debug_echo $_) True) + (= (rem_dups () ()) True) + (= (rem-dups (Cons $A $R) $R2) + (member $A $R) + (set-det) + (rem-dups $R $R2)) + (= (rem-dups (Cons $A $R) (Cons $A $R2)) + (rem-dups $R $R2) + (set-det)) - (= - (average $M $Avg) - ( (sum-list $M $Sum) - (size-of $M $N) - (is $Avg - (/ $Sum $N)) - (set-det))) -; + (= (average $M $Avg) + (sum-list $M $Sum) + (size-of $M $N) + (is $Avg + (/ $Sum $N)) + (set-det)) ; -; - +; keep appending B to A until A is at least length K. - (= - (extend-list $A $_ $K $A) - ( (length $A $K2) - (>= $K2 $K) - (set-det))) -; - - (= - (extend-list $A $B $K $A2) - ( (append $A $B $A3) - (extend-list $A3 $B $K $A2) - (set-det))) -; - - - - (= - (num-list 0 Nil) + (= (extend-list $A $_ $K $A) + (length $A $K2) + (>= $K2 $K) + (set-det)) + (= (extend-list $A $B $K $A2) + (append $A $B $A3) + (extend-list $A3 $B $K $A2) (set-det)) -; - - (= - (num-list $N - (Cons $N $R)) - ( (is $M - (- $N 1)) (num-list $M $R))) -; - - (= - (remove $_ () ()) True) -; + (= (num-list 0 Nil) + (set-det)) + (= (num-list $N (Cons $N $R)) + (is $M + (- $N 1)) + (num-list $M $R)) - (= - (remove $A - (Cons $A $B) $B) True) -; - (= - (remove $A - (Cons $X $B) - (Cons $X $C)) + (= (remove $_ () ()) True) + (= (remove $A (Cons $A $B) $B) True) + (= (remove $A (Cons $X $B) (Cons $X $C)) (remove $A $B $C)) -; - - (= - (remove_all $_ () ()) True) -; - - (= - (remove-all $A - (Cons $A $B) $C) - ( (set-det) (remove-all $A $B $C))) -; - - (= - (remove-all $A - (Cons $X $B) - (Cons $X $C)) + (= (remove_all $_ () ()) True) + (= (remove-all $A (Cons $A $B) $C) + (set-det) + (remove-all $A $B $C)) + (= (remove-all $A (Cons $X $B) (Cons $X $C)) (remove-all $A $B $C)) -; - - - - (= - (intersect () $_ ()) True) -; - (= - (intersect - (Cons $X $Y) $R - (Cons $X $Z)) - ( (member $X $R) - (set-det) - (intersect $Y $R $Z))) -; - (= - (intersect - (Cons $_ $Y) $R $Z) + (= (intersect () $_ ()) True) + (= (intersect (Cons $X $Y) $R (Cons $X $Z)) + (member $X $R) + (set-det) + (intersect $Y $R $Z)) + (= (intersect (Cons $_ $Y) $R $Z) (intersect $Y $R $Z)) -; - - (= - (set-diff Nil $T $T) + (= (set-diff Nil $T $T) (set-det)) -; - - (= - (set-diff $T Nil $T) + (= (set-diff $T Nil $T) (set-det)) -; - - (= - (set-diff - (Cons $A $B) $T $Diff) - ( (member $A $T) - (set-det) - (remove-all $A $T $T2) - (set-diff $B $T2 $Diff))) -; - - (= - (set-diff - (Cons $A $B) $T - (Cons $A $R)) + (= (set-diff (Cons $A $B) $T $Diff) + (member $A $T) + (set-det) + (remove-all $A $T $T2) + (set-diff $B $T2 $Diff)) + (= (set-diff (Cons $A $B) $T (Cons $A $R)) (set-diff $B $T $R)) -; - - (= - (remove-list Nil $B $B) + (= (remove-list Nil $B $B) (set-det)) -; - - (= - (remove-list - (Cons $A $B) $C $D) - ( (remove $A $C $E) - (set-det) - (remove-list $B $E $D))) -; - - - - (= - (writelist Nil) - ( (nl) (set-det))) -; - - (= - (writelist (Cons $A $R)) - ( (write $A) - (nl) - (writelist $R) - (set-det))) -; + (= (remove-list (Cons $A $B) $C $D) + (remove $A $C $E) + (set-det) + (remove-list $B $E $D)) + (= (writelist Nil) + (nl) + (set-det)) + (= (writelist (Cons $A $R)) + (write $A) + (nl) + (writelist $R) + (set-det)) - (= - (maybe) - ( (maybe 0.5) (set-det))) -; + (= (maybe) + (maybe 0.5) + (set-det)) - (= - (maybe $X) - ( (random $Y) - (< $Y $X) - (set-det))) -; - - - - (= - (random-permutation $L $Perm) - ( (length $L $Len) - (random-permutation2 $L $Len $Perm) - (set-det))) -; - - + (= (maybe $X) + (random $Y) + (< $Y $X) + (set-det)) - (= - (random_permutation2 () $_ ()) True) -; - - (= - (random-permutation2 $L $Len - (Cons $X $Perm)) - ( (random 0 $Len $R) - (remove-nth $R $L $X $L2) - (is $Len2 - (- $Len 1)) - (random-permutation2 $L2 $Len2 $Perm) - (set-det))) -; + (= (random-permutation $L $Perm) + (length $L $Len) + (random-permutation2 $L $Len $Perm) + (set-det)) - (= - (remove-nth 0 - (Cons $X $Y) $X $Y) + (= (random_permutation2 () $_ ()) True) + (= (random-permutation2 $L $Len (Cons $X $Perm)) + (random 0 $Len $R) + (remove-nth $R $L $X $L2) + (is $Len2 + (- $Len 1)) + (random-permutation2 $L2 $Len2 $Perm) (set-det)) -; - - (= - (remove-nth $N - (Cons $X $Y) $Z - (Cons $X $W)) - ( (is $N2 - (- $N 1)) - (remove-nth $N2 $Y $Z $W) - (set-det))) -; + (= (remove-nth 0 (Cons $X $Y) $X $Y) + (set-det)) + (= (remove-nth $N (Cons $X $Y) $Z (Cons $X $W)) + (is $N2 + (- $N 1)) + (remove-nth $N2 $Y $Z $W) + (set-det)) - (= - (select-rand $L $R) - ( (length $L $Len) - (> $Len 0) - (random 0 $Len $Rand) - (remove-nth $Rand $L $R $_) - (set-det))) -; + (= (select-rand $L $R) + (length $L $Len) + (> $Len 0) + (random 0 $Len $Rand) + (remove-nth $Rand $L $R $_) + (set-det)) ; -; - +; first_K(M, N, List, Grabbed) counts from M to N, grabbing the first N ; -; - +; entries of List, returning them in Grabbed. - (= - (first-K $M $N $_ Nil) - ( (>= $M $N) (set-det))) -; - - (= - (first-K $M $N - (Cons $A $R) - (Cons $A $S)) - ( (is $M2 - (+ $M 1)) - (first-K $M2 $N $R $S) - (set-det))) -; - + (= (first-K $M $N $_ Nil) + (>= $M $N) + (set-det)) + (= (first-K $M $N (Cons $A $R) (Cons $A $S)) + (is $M2 + (+ $M 1)) + (first-K $M2 $N $R $S) + (set-det)) diff --git a/sxx_machine/bench/asm.metta b/sxx_machine/bench/asm.metta index 9b2e1c7..b83a8f0 100644 --- a/sxx_machine/bench/asm.metta +++ b/sxx_machine/bench/asm.metta @@ -1,36 +1,24 @@ +; (convert_to_metta_file asm $_496536 sxx_machine/bench/asm.pl sxx_machine/bench/asm.metta) ; -; - +; File : asm.pl ; -; - +; Author : Neng-Fa ZHOU ; -; - +; Completed October 1993 ; -; - +; Updated: Febuary 1994 ; -; - +; Purpose: Assembler of NTOAM !(op 300 xfx <=) -; - +; /* asm.pl this file translates instructions and symbols into byte code */ !(op 1000 fx mode) -; - !(op 950 xfx :) -; - !(determinate (:: (/ cmp-error 1) (/ name 2) (/ length 2) (/ asm-hash-value 2))) -; - - (= - (asm-bp $Infile $Outfile) + (= (asm-bp $Infile $Outfile) ( (with_self (True *) (global-set %asm-bp 0 1)) @@ -51,12 +39,11 @@ (asm-mark-eot) (global-del %asm-bp 0) (told))) -; - +; ; output_mess('==>asm_pass1'), +; ; output_mess('==>asm_pass2'), - (= - (asm $Infile $Outfile) + (= (asm $Infile $Outfile) ( (with_self (True *) (see $Infile)) @@ -75,40 +62,30 @@ (asm-pass2 $Prog $Index $Psctable $Labeltable) (asm-mark-eot) (told))) -; +; ; output_mess('==>asm_pass1'), +; ; output_mess('==>asm_pass2'), - - (= - (asm-getaslist $Insts) + (= (asm-getaslist $Insts) ( (with_self (True *) (read $Inst)) (asm-getaslist1 $Inst $Insts))) -; - - (= - (asm-getaslist1 end-of-file $Insts) + (= (asm-getaslist1 end-of-file $Insts) (with_self (True *) (:= $Insts Nil))) -; - - (= - (asm-getaslist1 $Inst $Insts) + (= (asm-getaslist1 $Inst $Insts) ( (with_self (True *) (:= $Insts (Cons $Inst $Insts1))) (read $Inst1) (asm-getaslist1 $Inst1 $Insts1))) -; - - (= - (asm $Insts) + (= (asm $Insts) ( (with_self (True *) (asm0 $Insts $Prog $Index 0 $NIndex)) @@ -122,22 +99,17 @@ (asm-putnum $NIndex 4) (asm-pass2 $Prog $Index $Psctable $Labeltable) (asm-mark-eot))) -; +; ; output_mess('==>asm_pass1'), +; ; output_mess('==>asm_pass2'), - - (= - (asm0 Nil $Prog $Index $NIndex0 $NIndex) + (= (asm0 Nil $Prog $Index $NIndex0 $NIndex) ( (with_self (True *) (:= $Prog Nil)) (:= $Index Nil) (:= $NIndex $NIndex0))) -; - - (= - (asm0 - (Cons $Inst $Insts) $Prog $Index $NIndex0 $NIndex) + (= (asm0 (Cons $Inst $Insts) $Prog $Index $NIndex0 $NIndex) ( (with_self (asm-index-inst $Inst $Size) (is $NIndex1 @@ -145,149 +117,89 @@ (= $Index (Cons $Inst $Index1)) (asm0 $Insts $Prog $Index1 $NIndex1 $NIndex))) -; - - (= - (asm0 - (Cons $Inst $Insts) $Prog $Index $NIndex0 $NIndex) + (= (asm0 (Cons $Inst $Insts) $Prog $Index $NIndex0 $NIndex) ( (with_self (True *) (:= $Prog (Cons $Inst $Prog1))) (asm0 $Insts $Prog1 $Index $NIndex0 $NIndex))) -; - - (= - (asm-pass1 $AsmInsts $Index $Csym $Lsym $Ntext $Npsc) + (= (asm-pass1 $AsmInsts $Index $Csym $Lsym $Ntext $Npsc) ( (with_self (True *) (asm-pass11 $AsmInsts $Lsym $Csym 0 $Ntext)) (asm-index-pass1 $Index $Csym) (asmpass1-fillin $Lsym 255 $Csym) (asmpass1-setundef $Csym 255 0 $Npsc))) -; - - (= - (asm-pass1-bp $AsmInsts $Index $Csym $Lsym $Ntext $Npsc) + (= (asm-pass1-bp $AsmInsts $Index $Csym $Lsym $Ntext $Npsc) ( (with_self (True *) (asm-pass11 $AsmInsts $Lsym $Csym 0 $Ntext)) (asm-index-pass1 $Index $Csym) (asmpass1-fillin-bp $Lsym 255 $Csym) (asmpass1-setundef $Csym 255 0 $Npsc))) -; - - (= - (asm-pass11 Nil $_ $_ $Lc $NLc) + (= (asm-pass11 Nil $_ $_ $Lc $NLc) (with_self (True *) (:= $NLc $Lc))) -; - - (= - (asm-pass11 - (Cons $Inst $Rest) $Lsym $Csym $Lc $NLc) + (= (asm-pass11 (Cons $Inst $Rest) $Lsym $Csym $Lc $NLc) ( (<= (label $X) $Inst) (with_self (lab-member1 (lab $X $Lc) $Lsym) (asm-pass11 $Rest $Lsym $Csym $Lc $NLc)))) -; - - (= - (asm-pass11 - (Cons $Inst $Rest) $Lsym $Csym $Lc $NLc) + (= (asm-pass11 (Cons $Inst $Rest) $Lsym $Csym $Lc $NLc) ( (with_self (<= (label $X) $Inst) (error-double-define $X)) (asm-pass11 $Rest $Lsym $Csym $Lc $NLc))) -; - - (= - (asm-pass11 - (Cons $Inst $Rest) $Lsym $Csym $Lc $NLc) + (= (asm-pass11 (Cons $Inst $Rest) $Lsym $Csym $Lc $NLc) ( (with_self (True *) (asm-pass12 $Inst $Csym $N)) (is $Lc0 (+ $Lc $N)) (asm-pass11 $Rest $Lsym $Csym $Lc0 $NLc))) -; - - (= - (error-double-define (, $Pred $Arity $_)) + (= (error-double-define (, $Pred $Arity $_)) (with_self (True *) True)) -; - - (= - (error-double-define (, $Pred $Arity)) + (= (error-double-define (, $Pred $Arity)) (with_self (True *) (cmp-error (:: 'The predicate ' (/ $Pred $Arity) ' is doubly defined')))) -; - - (= - (asm-index-pass1 Nil $_) + (= (asm-index-pass1 Nil $_) (with_self (True *) True)) -; - - (= - (asm-index-pass1 - (Cons - (pred $_ $_ $_ $_) $Rest) $Csym) + (= (asm-index-pass1 (Cons (pred $_ $_ $_ $_) $Rest) $Csym) (with_self (True *) (asm-index-pass1 $Rest $Csym))) -; - - (= - (asm-index-pass1 - (Cons - (arglabel $T $Val $Label) $Rest) $Csym) + (= (asm-index-pass1 (Cons (arglabel $T $Val $Label) $Rest) $Csym) ( (with_self (== $T c) (sym-member1 (sym $Val 0 $_ $_) $Csym)) (asm-index-pass1 $Rest $Csym))) -; - - (= - (asm-index-pass1 - (Cons - (arglabel $T - (, $Str $Ar) $Label) $Rest) $Csym) + (= (asm-index-pass1 (Cons (arglabel $T (, $Str $Ar) $Label) $Rest) $Csym) ( (with_self (== $T s) (sym-member1 (sym $Str $Ar $_ $_) $Csym)) (asm-index-pass1 $Rest $Csym))) -; - - (= - (asm-index-pass1 - (Cons - (arglabel $T $Val $Label) $Rest) $Csym) + (= (asm-index-pass1 (Cons (arglabel $T $Val $Label) $Rest) $Csym) (with_self (True *) (asm-index-pass1 $Rest $Csym))) -; - - (= - (asmpass1-fillin $Lsym $N $_) + (= (asmpass1-fillin $Lsym $N $_) (with_self (< $N 1) True)) -; - - (= - (asmpass1-fillin $Lsym $N $Csym) +; /* Fill in the values of any predicates which are defined within this module.*/ + (= (asmpass1-fillin $Lsym $N $Csym) ( (with_self (True *) (arg $N $Lsym $L)) @@ -295,47 +207,26 @@ (is $N1 (- $N 1)) (asmpass1-fillin $Lsym $N1 $Csym))) -; - - (= - (asmpass1-fillin $L $_) + (= (asmpass1-fillin $L $_) (with_self (var $L) True)) -; - - (= - (asmpass1-fillin - (Cons - (lab - (, $_ $_ $_) $LcValue) $Rest) $Table) + (= (asmpass1-fillin (Cons (lab (, $_ $_ $_) $LcValue) $Rest) $Table) (with_self (True *) (asmpass1-fillin $Rest $Table))) -; - - (= - (asmpass1-fillin - (Cons - (lab - (, $Name $Arity) $LcValue) $Rest) $Table) + (= (asmpass1-fillin (Cons (lab (, $Name $Arity) $LcValue) $Rest) $Table) ( (with_self (True *) (sym-member1 (sym $Name $Arity $LcValue $_) $Table)) (asmpass1-fillin $Rest $Table))) -; - - (= - (asmpass1-fillin-bp $Lsym $N $_) + (= (asmpass1-fillin-bp $Lsym $N $_) (with_self (< $N 1) True)) -; - - (= - (asmpass1-fillin-bp $Lsym $N $Csym) + (= (asmpass1-fillin-bp $Lsym $N $Csym) ( (with_self (True *) (arg $N $Lsym $L)) @@ -343,57 +234,32 @@ (is $N1 (- $N 1)) (asmpass1-fillin-bp $Lsym $N1 $Csym))) -; - - (= - (asmpass1-fillin-bp $L $_) + (= (asmpass1-fillin-bp $L $_) (with_self (var $L) True)) -; - - (= - (asmpass1-fillin-bp - (Cons - (lab - (, $_ $_ $_) $LcValue) $Rest) $Table) + (= (asmpass1-fillin-bp (Cons (lab (, $_ $_ $_) $LcValue) $Rest) $Table) (with_self (True *) (asmpass1-fillin-bp $Rest $Table))) -; - - (= - (asmpass1-fillin-bp - (Cons - (lab - (, $Name $Arity) $LcValue) $Rest) $Table) + (= (asmpass1-fillin-bp (Cons (lab (, $Name $Arity) $LcValue) $Rest) $Table) ( (with_self (predefined $Name $Arity) (sym-member1 (sym $Name $Arity $LcValue $_) $Table)) (asmpass1-fillin-bp $Rest $Table))) -; - - (= - (asmpass1-fillin-bp - (Cons - (lab - (, $Name $Arity) $LcValue) $Rest) $Table) + (= (asmpass1-fillin-bp (Cons (lab (, $Name $Arity) $LcValue) $Rest) $Table) (with_self (True *) (asmpass1-fillin-bp $Rest $Table))) -; - - (= - (asmpass1-setundef $Csym $N $S0 $S) + (= (asmpass1-setundef $Csym $N $S0 $S) (with_self (< $N 1) (= $S $S0))) -; - - (= - (asmpass1-setundef $Csym $N $S0 $S) +; /* asmpass1_fillin([lab((Name, Arity),LcValue)|Rest],Table) :- true : cmp_error(['the predicate ', Name/Arity, ' is doubly defined']), asmpass1_fillin(Rest, Table). */ +; /* Fill in the values of any symbols which have not been defined with the value -2. */ + (= (asmpass1-setundef $Csym $N $S0 $S) ( (with_self (True *) (arg $N $Csym $L)) @@ -401,20 +267,12 @@ (is $N1 (- $N 1)) (asmpass1-setundef $Csym $N1 $S1 $S))) -; - - (= - (asmpass1-setundef $Tab $S0 $S) + (= (asmpass1-setundef $Tab $S0 $S) (with_self (var $Tab) (= $S $S0))) -; - - (= - (asmpass1-setundef - (Cons - (sym $Pred $Arity $Val $_) $Rest) $S0 $S) + (= (asmpass1-setundef (Cons (sym $Pred $Arity $Val $_) $Rest) $S0 $S) ( (with_self (var $Val) (:= $Val -2)) @@ -423,12 +281,7 @@ (+ (+ $S0 $L) 6)) (asmpass1-setundef $Rest $S1 $S))) -; - - (= - (asmpass1-setundef - (Cons - (sym $Pred $Arity $Val $_) $Rest) $S0 $S) + (= (asmpass1-setundef (Cons (sym $Pred $Arity $Val $_) $Rest) $S0 $S) ( (with_self (True *) (b-GET-LENGTH-cf $Pred $L)) @@ -436,1433 +289,438 @@ (+ (+ $S0 $L) 6)) (asmpass1-setundef $Rest $S1 $S))) -; - !(mode (asm-pass12 c d f)) -; - - (= - (asm_pass12 - (label $_) $_ 0) True) -; + (= (asm_pass12 (label $_) $_ 0) True) - - (= - (asm_pass12 - (jmp $_) $_ 2) True) -; - - (= - (asm-pass12 - (jmpn-eq-struct-x $_ - (, $S $N) $_ $_) $Csym 5) + (= (asm_pass12 (jmp $_) $_ 2) True) +; /* Conditional Jump */ + (= (asm-pass12 (jmpn-eq-struct-x $_ (, $S $N) $_ $_) $Csym 5) (sym-member1 (sym $S $N $_ $_) $Csym)) -; - - (= - (asm-pass12 - (jmpn-eq-struct-y $_ - (, $S $N) $_ $_) $Csym 5) + (= (asm-pass12 (jmpn-eq-struct-y $_ (, $S $N) $_ $_) $Csym 5) (sym-member1 (sym $S $N $_ $_) $Csym)) -; - - (= - (asm-pass12 - (jmpn-eq-atom-x $_ $C $_ $_) $Csym 5) + (= (asm-pass12 (jmpn-eq-atom-x $_ $C $_ $_) $Csym 5) (sym-member1 (sym $C 0 $_ $_) $Csym)) -; - - (= - (asm-pass12 - (jmpn-eq-atom-y $_ $C $_ $_) $Csym 5) + (= (asm-pass12 (jmpn-eq-atom-y $_ $C $_ $_) $Csym 5) (sym-member1 (sym $C 0 $_ $_) $Csym)) -; - - (= - (asm_pass12 - (jmpn_nil_x $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (jmpn_nil_y $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (switch_list_x $_ $_ $_ $_) $_ 5) True) -; - - (= - (asm_pass12 - (switch_list_y $_ $_ $_ $_) $_ 5) True) -; - - (= - (asm_pass12 - (switch_list_yxx $_ $_ $_ $_) $_ 5) True) -; - - (= - (asm_pass12 - (switch_list_yxy $_ $_ $_ $_) $_ 5) True) -; - - (= - (asm_pass12 - (switch_list_yyx $_ $_ $_ $_) $_ 5) True) -; - - (= - (asm_pass12 - (switch_list_yyy $_ $_ $_ $_) $_ 5) True) -; - - (= - (asm_pass12 - (jmpn_eq_int_x $_ $_ $_ $_) $_ 5) True) -; - - (= - (asm_pass12 - (jmpn_eq_int_y $_ $_ $_ $_) $_ 5) True) -; - - (= - (asm_pass12 - (jmpn_eql $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (jmp_eql $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (jmp_eql_yy $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (jmpn_gt $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (jmpn_gt_yy $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (jmpn_ge $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (jmpn_ge_yy $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (jmpn_id $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (jmp_id $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (jmpn_var_x $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (jmpn_var_y $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (jmp_var_x $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (jmp_var_y $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (jmpn_symbol_x $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (jmpn_symbol_y $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (jmpn_symbolic_x $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (jmpn_symbolic_y $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (jmpn_num_x $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (jmpn_num_y $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (jmpn_int_x $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (jmpn_int_y $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (jmpn_float_x $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (jmpn_float_y $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (hash_jmpn_nil $_) $_ 2) True) -; - - (= - (asm_pass12 - (hash_jmpn_list $_) $_ 2) True) -; - - (= - (asm_pass12 - (hash_jmpn_int $_ $_) $_ 3) True) -; - - (= - (asm-pass12 - (hash-jmpn-atom $C $_) $Csym 3) + (= (asm_pass12 (jmpn_nil_x $_ $_ $_) $_ 4) True) + (= (asm_pass12 (jmpn_nil_y $_ $_ $_) $_ 4) True) + (= (asm_pass12 (switch_list_x $_ $_ $_ $_) $_ 5) True) + (= (asm_pass12 (switch_list_y $_ $_ $_ $_) $_ 5) True) + (= (asm_pass12 (switch_list_yxx $_ $_ $_ $_) $_ 5) True) + (= (asm_pass12 (switch_list_yxy $_ $_ $_ $_) $_ 5) True) + (= (asm_pass12 (switch_list_yyx $_ $_ $_ $_) $_ 5) True) + (= (asm_pass12 (switch_list_yyy $_ $_ $_ $_) $_ 5) True) + (= (asm_pass12 (jmpn_eq_int_x $_ $_ $_ $_) $_ 5) True) + (= (asm_pass12 (jmpn_eq_int_y $_ $_ $_ $_) $_ 5) True) + (= (asm_pass12 (jmpn_eql $_ $_ $_) $_ 4) True) + (= (asm_pass12 (jmp_eql $_ $_ $_) $_ 4) True) + (= (asm_pass12 (jmp_eql_yy $_ $_ $_) $_ 4) True) + (= (asm_pass12 (jmpn_gt $_ $_ $_) $_ 4) True) + (= (asm_pass12 (jmpn_gt_yy $_ $_ $_) $_ 4) True) + (= (asm_pass12 (jmpn_ge $_ $_ $_) $_ 4) True) + (= (asm_pass12 (jmpn_ge_yy $_ $_ $_) $_ 4) True) + (= (asm_pass12 (jmpn_id $_ $_ $_) $_ 4) True) + (= (asm_pass12 (jmp_id $_ $_ $_) $_ 4) True) + (= (asm_pass12 (jmpn_var_x $_ $_) $_ 3) True) + (= (asm_pass12 (jmpn_var_y $_ $_) $_ 3) True) + (= (asm_pass12 (jmp_var_x $_ $_) $_ 3) True) + (= (asm_pass12 (jmp_var_y $_ $_) $_ 3) True) + (= (asm_pass12 (jmpn_symbol_x $_ $_) $_ 3) True) + (= (asm_pass12 (jmpn_symbol_y $_ $_) $_ 3) True) + (= (asm_pass12 (jmpn_symbolic_x $_ $_) $_ 3) True) + (= (asm_pass12 (jmpn_symbolic_y $_ $_) $_ 3) True) + (= (asm_pass12 (jmpn_num_x $_ $_) $_ 3) True) + (= (asm_pass12 (jmpn_num_y $_ $_) $_ 3) True) + (= (asm_pass12 (jmpn_int_x $_ $_) $_ 3) True) + (= (asm_pass12 (jmpn_int_y $_ $_) $_ 3) True) + (= (asm_pass12 (jmpn_float_x $_ $_) $_ 3) True) + (= (asm_pass12 (jmpn_float_y $_ $_) $_ 3) True) + (= (asm_pass12 (hash_jmpn_nil $_) $_ 2) True) + (= (asm_pass12 (hash_jmpn_list $_) $_ 2) True) + (= (asm_pass12 (hash_jmpn_int $_ $_) $_ 3) True) + (= (asm-pass12 (hash-jmpn-atom $C $_) $Csym 3) (sym-member1 (sym $C 0 $_ $_) $Csym)) -; - - (= - (asm-pass12 - (hash-jmpn-struct - (, $S $N) $_) $Csym 3) + (= (asm-pass12 (hash-jmpn-struct (, $S $N) $_) $Csym 3) (sym-member1 (sym $S $N $_ $_) $Csym)) -; - - (= - (asm-pass12 - (hash-jmpn-struct-x - (, $S $N) $_) $Csym 3) + (= (asm-pass12 (hash-jmpn-struct-x (, $S $N) $_) $Csym 3) (sym-member1 (sym $S $N $_ $_) $Csym)) -; - - (= - (asm-pass12 - (hash-jmpn-struct-y - (, $S $N) $_) $Csym 3) + (= (asm-pass12 (hash-jmpn-struct-y (, $S $N) $_) $Csym 3) (sym-member1 (sym $S $N $_ $_) $Csym)) -; - - (= - (asm-pass12 - (hash-jmpn-struct-xx - (, $S $N) $_) $Csym 3) + (= (asm-pass12 (hash-jmpn-struct-xx (, $S $N) $_) $Csym 3) (sym-member1 (sym $S $N $_ $_) $Csym)) -; - - (= - (asm-pass12 - (hash-jmpn-struct-xy - (, $S $N) $_) $Csym 3) + (= (asm-pass12 (hash-jmpn-struct-xy (, $S $N) $_) $Csym 3) (sym-member1 (sym $S $N $_ $_) $Csym)) -; - - (= - (asm-pass12 - (hash-jmpn-struct-yx - (, $S $N) $_) $Csym 3) + (= (asm-pass12 (hash-jmpn-struct-yx (, $S $N) $_) $Csym 3) (sym-member1 (sym $S $N $_ $_) $Csym)) -; - - (= - (asm-pass12 - (hash-jmpn-struct-yy - (, $S $N) $_) $Csym 3) + (= (asm-pass12 (hash-jmpn-struct-yy (, $S $N) $_) $Csym 3) (sym-member1 (sym $S $N $_ $_) $Csym)) -; - - (= - (asm-pass12 - (unify-struct-x $_ - (, $S $N)) $Csym 3) + (= (asm-pass12 (unify-struct-x $_ (, $S $N)) $Csym 3) (sym-member1 (sym $S $N $_ $_) $Csym)) -; - - (= - (asm-pass12 - (unify-struct-y $_ - (, $S $N)) $Csym 3) +; /* Unify */ + (= (asm-pass12 (unify-struct-y $_ (, $S $N)) $Csym 3) (sym-member1 (sym $S $N $_ $_) $Csym)) -; - - (= - (asm_pass12 - (unify_list_x $_) $_ 2) True) -; - - (= - (asm_pass12 - (unify_list_y $_) $_ 2) True) -; - - (= - (asm_pass12 - (unify_nil_x $_) $_ 2) True) -; - - (= - (asm_pass12 - (unify_nil_y $_) $_ 2) True) -; - - (= - (asm-pass12 - (unify-atom-x $_ $C) $Csym 3) + (= (asm_pass12 (unify_list_x $_) $_ 2) True) + (= (asm_pass12 (unify_list_y $_) $_ 2) True) + (= (asm_pass12 (unify_nil_x $_) $_ 2) True) + (= (asm_pass12 (unify_nil_y $_) $_ 2) True) + (= (asm-pass12 (unify-atom-x $_ $C) $Csym 3) (sym-member1 (sym $C 0 $_ $_) $Csym)) -; - - (= - (asm-pass12 - (unify-atom-y $_ $C) $Csym 3) + (= (asm-pass12 (unify-atom-y $_ $C) $Csym 3) (sym-member1 (sym $C 0 $_ $_) $Csym)) -; - - (= - (asm_pass12 - (unify_int_x $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify_int_y $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify_ux_ux $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify_ux_uy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify_uy_uy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify_cons_x $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify_cons_y $_ $_) $_ 3) True) -; - - - (= - (asm-pass12 - (fork-unify-struct-y $_ - (, $S $N) $_) $Csym 4) + (= (asm_pass12 (unify_int_x $_ $_) $_ 3) True) + (= (asm_pass12 (unify_int_y $_ $_) $_ 3) True) + (= (asm_pass12 (unify_ux_ux $_ $_) $_ 3) True) + (= (asm_pass12 (unify_ux_uy $_ $_) $_ 3) True) + (= (asm_pass12 (unify_uy_uy $_ $_) $_ 3) True) + (= (asm_pass12 (unify_cons_x $_ $_) $_ 3) True) + (= (asm_pass12 (unify_cons_y $_ $_) $_ 3) True) + + (= (asm-pass12 (fork-unify-struct-y $_ (, $S $N) $_) $Csym 4) (sym-member1 (sym $S $N $_ $_) $Csym)) -; - - (= - (asm_pass12 - (fork_unify_list_y $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (fork_unify_nil_y $_ $_) $_ 3) True) -; - - (= - (asm-pass12 - (fork-unify-atom-y $_ $C $_) $Csym 4) + (= (asm_pass12 (fork_unify_list_y $_ $_) $_ 3) True) + (= (asm_pass12 (fork_unify_nil_y $_ $_) $_ 3) True) + (= (asm-pass12 (fork-unify-atom-y $_ $C $_) $Csym 4) (sym-member1 (sym $C 0 $_ $_) $Csym)) -; - - (= - (asm_pass12 - (fork_unify_int_y $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (fork_unify_ux_uy $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (fork_unify_uy_uy $_ $_ $_) $_ 4) True) -; + (= (asm_pass12 (fork_unify_int_y $_ $_ $_) $_ 4) True) + (= (asm_pass12 (fork_unify_ux_uy $_ $_ $_) $_ 4) True) + (= (asm_pass12 (fork_unify_uy_uy $_ $_ $_) $_ 4) True) - - (= - (asm-pass12 - (fork-unicut-struct-y $_ - (, $S $N) $_) $Csym 4) + (= (asm-pass12 (fork-unicut-struct-y $_ (, $S $N) $_) $Csym 4) (sym-member1 (sym $S $N $_ $_) $Csym)) -; - - (= - (asm_pass12 - (fork_unicut_list_y $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (fork_unicut_nil_y $_ $_) $_ 3) True) -; - - (= - (asm-pass12 - (fork-unicut-atom-y $_ $C $_) $Csym 4) + (= (asm_pass12 (fork_unicut_list_y $_ $_) $_ 3) True) + (= (asm_pass12 (fork_unicut_nil_y $_ $_) $_ 3) True) + (= (asm-pass12 (fork-unicut-atom-y $_ $C $_) $Csym 4) (sym-member1 (sym $C 0 $_ $_) $Csym)) -; - - (= - (asm_pass12 - (fork_unicut_int_y $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (fork_unicut_ux_uy $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (fork_unicut_uy_uy $_ $_ $_) $_ 4) True) -; - + (= (asm_pass12 (fork_unicut_int_y $_ $_ $_) $_ 4) True) + (= (asm_pass12 (fork_unicut_ux_uy $_ $_ $_) $_ 4) True) + (= (asm_pass12 (fork_unicut_uy_uy $_ $_ $_) $_ 4) True) - (= - (asm-pass12 - (unify0-struct-y $_ - (, $S $N)) $Csym 3) + (= (asm-pass12 (unify0-struct-y $_ (, $S $N)) $Csym 3) (sym-member1 (sym $S $N $_ $_) $Csym)) -; - - (= - (asm_pass12 - (unify0_list_y $_) $_ 2) True) -; - - (= - (asm_pass12 - (unify0_nil_y $_) $_ 2) True) -; - - (= - (asm-pass12 - (unify0-atom-y $_ $C) $Csym 3) + (= (asm_pass12 (unify0_list_y $_) $_ 2) True) + (= (asm_pass12 (unify0_nil_y $_) $_ 2) True) + (= (asm-pass12 (unify0-atom-y $_ $C) $Csym 3) (sym-member1 (sym $C 0 $_ $_) $Csym)) -; - - (= - (asm_pass12 - (unify0_int_y $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify0_ux_uy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify0_uy_uy $_ $_) $_ 3) True) -; - - (= - (asm-pass12 - (unicut-struct-y $_ - (, $S $N)) $Csym 3) + (= (asm_pass12 (unify0_int_y $_ $_) $_ 3) True) + (= (asm_pass12 (unify0_ux_uy $_ $_) $_ 3) True) + (= (asm_pass12 (unify0_uy_uy $_ $_) $_ 3) True) + (= (asm-pass12 (unicut-struct-y $_ (, $S $N)) $Csym 3) (sym-member1 (sym $S $N $_ $_) $Csym)) -; - - (= - (asm_pass12 - (unicut_list_y $_) $_ 2) True) -; - - (= - (asm_pass12 - (unicut_nil_y $_) $_ 2) True) -; - - (= - (asm-pass12 - (unicut-atom-y $_ $C) $Csym 3) + (= (asm_pass12 (unicut_list_y $_) $_ 2) True) + (= (asm_pass12 (unicut_nil_y $_) $_ 2) True) + (= (asm-pass12 (unicut-atom-y $_ $C) $Csym 3) (sym-member1 (sym $C 0 $_ $_) $Csym)) -; - - (= - (asm_pass12 - (unicut_int_y $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unicut_uy_uy $_ $_) $_ 3) True) -; + (= (asm_pass12 (unicut_int_y $_ $_) $_ 3) True) + (= (asm_pass12 (unicut_uy_uy $_ $_) $_ 3) True) + (= (asm_pass12 unicut $_ 1) True) - (= - (asm_pass12 unicut $_ 1) True) -; - - - (= - (asm_pass12 unify_arg_nil $_ 1) True) -; - - (= - (asm-pass12 - (unify-arg-atom $C) $Csym 2) + (= (asm_pass12 unify_arg_nil $_ 1) True) +; /* Unify argument */ + (= (asm-pass12 (unify-arg-atom $C) $Csym 2) (sym-member1 (sym $C 0 $_ $_) $Csym)) -; - - (= - (asm_pass12 - (unify_arg_int $_) $_ 2) True) -; - - (= - (asm_pass12 - (unify_arg_ux_ux $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify_arg_ux $_) $_ 2) True) -; - - (= - (asm_pass12 - (unify_arg_ux_vy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify_arg_ux_vx $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify_arg_uy_uy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify_arg_uy $_) $_ 2) True) -; - - (= - (asm_pass12 - (unify_arg_vx $_) $_ 2) True) -; - - (= - (asm_pass12 - (unify_arg_vy $_) $_ 2) True) -; - - (= - (asm_pass12 unify_arg_list $_ 1) True) -; - - (= - (asm-pass12 - (unify-arg-struct (, $S $N)) $Csym 2) + (= (asm_pass12 (unify_arg_int $_) $_ 2) True) + (= (asm_pass12 (unify_arg_ux_ux $_ $_) $_ 3) True) + (= (asm_pass12 (unify_arg_ux $_) $_ 2) True) + (= (asm_pass12 (unify_arg_ux_vy $_ $_) $_ 3) True) + (= (asm_pass12 (unify_arg_ux_vx $_ $_) $_ 3) True) + (= (asm_pass12 (unify_arg_uy_uy $_ $_) $_ 3) True) + (= (asm_pass12 (unify_arg_uy $_) $_ 2) True) + (= (asm_pass12 (unify_arg_vx $_) $_ 2) True) + (= (asm_pass12 (unify_arg_vy $_) $_ 2) True) + (= (asm_pass12 unify_arg_list $_ 1) True) + (= (asm-pass12 (unify-arg-struct (, $S $N)) $Csym 2) (sym-member1 (sym $S $N $_ $_) $Csym)) -; - - (= - (asm_pass12 unify_arg_void_one $_ 1) True) -; - - (= - (asm_pass12 - (unify_arg_void $_) $_ 2) True) -; - - (= - (asm_pass12 - (unify_arg_wy $_) $_ 2) True) -; - - (= - (asm_pass12 - (unify_arg_vx_vx $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify_arg_vx_vy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify_arg_vx_ux $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify_arg_vx_uy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify_arg_vy_vx $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify_arg_vy_vy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify_arg_vy_ux $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify_arg_vy_uy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (unify_arg_iii $_ $_ $_) $_ 4) True) -; - - - (= - (asm-pass12 - (move-struct-x $_ - (, $S $N)) $Csym 3) + (= (asm_pass12 unify_arg_void_one $_ 1) True) + (= (asm_pass12 (unify_arg_void $_) $_ 2) True) + (= (asm_pass12 (unify_arg_wy $_) $_ 2) True) + (= (asm_pass12 (unify_arg_vx_vx $_ $_) $_ 3) True) + (= (asm_pass12 (unify_arg_vx_vy $_ $_) $_ 3) True) + (= (asm_pass12 (unify_arg_vx_ux $_ $_) $_ 3) True) + (= (asm_pass12 (unify_arg_vx_uy $_ $_) $_ 3) True) + (= (asm_pass12 (unify_arg_vy_vx $_ $_) $_ 3) True) + (= (asm_pass12 (unify_arg_vy_vy $_ $_) $_ 3) True) + (= (asm_pass12 (unify_arg_vy_ux $_ $_) $_ 3) True) + (= (asm_pass12 (unify_arg_vy_uy $_ $_) $_ 3) True) + (= (asm_pass12 (unify_arg_iii $_ $_ $_) $_ 4) True) + + (= (asm-pass12 (move-struct-x $_ (, $S $N)) $Csym 3) (sym-member1 (sym $S $N $_ $_) $Csym)) -; - - (= - (asm-pass12 - (move-struct-y $_ - (, $S $N)) $Csym 3) +; /* Move */ + (= (asm-pass12 (move-struct-y $_ (, $S $N)) $Csym 3) (sym-member1 (sym $S $N $_ $_) $Csym)) -; - - (= - (asm_pass12 - (move_list_x $_) $_ 2) True) -; - - (= - (asm_pass12 - (move_list_y $_) $_ 2) True) -; - - (= - (asm_pass12 - (move_nil_x $_) $_ 2) True) -; - - (= - (asm_pass12 - (move_nil_y $_) $_ 2) True) -; - - (= - (asm-pass12 - (move-atom-x $_ $C) $Csym 3) + (= (asm_pass12 (move_list_x $_) $_ 2) True) + (= (asm_pass12 (move_list_y $_) $_ 2) True) + (= (asm_pass12 (move_nil_x $_) $_ 2) True) + (= (asm_pass12 (move_nil_y $_) $_ 2) True) + (= (asm-pass12 (move-atom-x $_ $C) $Csym 3) (sym-member1 (sym $C 0 $_ $_) $Csym)) -; - - (= - (asm-pass12 - (move-atom-y $_ $C) $Csym 3) + (= (asm-pass12 (move-atom-y $_ $C) $Csym 3) (sym-member1 (sym $C 0 $_ $_) $Csym)) -; - - (= - (asm_pass12 - (move_int_x $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (move_int_y $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (move_x_ux $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (move_x_uy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (move_y_ux $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (move_y_uy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (move_vx $_) $_ 2) True) -; - - (= - (asm_pass12 - (move_vy $_) $_ 2) True) -; - - (= - (asm_pass12 - (move_x_wy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (move_y_wy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (move_yy_yw $_ $_ $_ $_) $_ 5) True) -; - - (= - (asm_pass12 - (move_yw_yy $_ $_ $_ $_) $_ 5) True) -; - - (= - (asm_pass12 - (move_yy_yy $_ $_ $_ $_) $_ 5) True) -; - - (= - (asm_pass12 - (move_yy_yy_yy $_ $_ $_ $_ $_ $_) $_ 7) True) -; - - - (= - (asm_pass12 - (and $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (or $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (lshiftl $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (lshiftr $_ $_ $_) $_ 4) True) -; + (= (asm_pass12 (move_int_x $_ $_) $_ 3) True) + (= (asm_pass12 (move_int_y $_ $_) $_ 3) True) + (= (asm_pass12 (move_x_ux $_ $_) $_ 3) True) + (= (asm_pass12 (move_x_uy $_ $_) $_ 3) True) + (= (asm_pass12 (move_y_ux $_ $_) $_ 3) True) + (= (asm_pass12 (move_y_uy $_ $_) $_ 3) True) + (= (asm_pass12 (move_vx $_) $_ 2) True) + (= (asm_pass12 (move_vy $_) $_ 2) True) + (= (asm_pass12 (move_x_wy $_ $_) $_ 3) True) + (= (asm_pass12 (move_y_wy $_ $_) $_ 3) True) + (= (asm_pass12 (move_yy_yw $_ $_ $_ $_) $_ 5) True) + (= (asm_pass12 (move_yw_yy $_ $_ $_ $_) $_ 5) True) + (= (asm_pass12 (move_yy_yy $_ $_ $_ $_) $_ 5) True) + (= (asm_pass12 (move_yy_yy_yy $_ $_ $_ $_ $_ $_) $_ 7) True) + + (= (asm_pass12 (and $_ $_ $_) $_ 4) True) +; /* Numeric */ + (= (asm_pass12 (or $_ $_ $_) $_ 4) True) + (= (asm_pass12 (lshiftl $_ $_ $_) $_ 4) True) + (= (asm_pass12 (lshiftr $_ $_ $_) $_ 4) True) + (= (asm_pass12 (complement $_ $_) $_ 3) True) + (= (asm_pass12 (add $_ $_ $_) $_ 4) True) + (= (asm_pass12 (add1_y $_) $_ 2) True) + (= (asm_pass12 (sub $_ $_ $_) $_ 4) True) + (= (asm_pass12 (sub1_y $_) $_ 2) True) + (= (asm_pass12 (mul $_ $_ $_) $_ 4) True) + (= (asm_pass12 (div $_ $_ $_) $_ 4) True) + (= (asm_pass12 (idiv $_ $_ $_) $_ 4) True) + (= (asm_pass12 (mod $_ $_ $_) $_ 4) True) + + (= (asm-pass12 (para-struct (, $S $N)) $Csym 2) + (sym-member1 + (sym $S $N $_ $_) $Csym)) +; /*Parameter passing */ + (= (asm_pass12 para_list $_ 1) True) + (= (asm_pass12 para_nil $_ 1) True) + (= (asm-pass12 (para-atom $C) $Csym 2) + (sym-member1 + (sym $C 0 $_ $_) $Csym)) + (= (asm_pass12 (para_int $_) $_ 2) True) + (= (asm_pass12 (para_ux $_) $_ 2) True) + (= (asm_pass12 (para_uy $_) $_ 2) True) + (= (asm_pass12 (para_vx $_) $_ 2) True) + (= (asm_pass12 (para_vy $_) $_ 2) True) + (= (asm_pass12 para_void_one $_ 1) True) + (= (asm_pass12 (para_void $_) $_ 2) True) + (= (asm_pass12 (para_vy_vy $_ $_) $_ 3) True) + (= (asm_pass12 (para_vy_ux $_ $_) $_ 3) True) + (= (asm_pass12 (para_vy_uy $_ $_) $_ 3) True) + (= (asm_pass12 (para_ux_vy $_ $_) $_ 3) True) + (= (asm_pass12 (para_ux_ux $_ $_) $_ 3) True) + (= (asm_pass12 (para_ux_uy $_ $_) $_ 3) True) + (= (asm_pass12 (para_uy_vy $_ $_) $_ 3) True) + (= (asm_pass12 (para_uy_ux $_ $_) $_ 3) True) + (= (asm_pass12 (para_uy_uy $_ $_) $_ 3) True) + (= (asm_pass12 (para_ux_ux_ux $_ $_ $_) $_ 4) True) + (= (asm_pass12 (para_ux_ux_uy $_ $_ $_) $_ 4) True) + (= (asm_pass12 (para_ux_uy_ux $_ $_ $_) $_ 4) True) + (= (asm_pass12 (para_ux_uy_uy $_ $_ $_) $_ 4) True) + (= (asm_pass12 (para_uy_ux_ux $_ $_ $_) $_ 4) True) + (= (asm_pass12 (para_uy_ux_uy $_ $_ $_) $_ 4) True) + (= (asm_pass12 (para_uy_uy_ux $_ $_ $_) $_ 4) True) + (= (asm_pass12 (para_uy_uy_uy $_ $_ $_) $_ 4) True) + (= (asm_pass12 (para_uy_uy_uy_uy $_ $_ $_ $_) $_ 5) True) + + (= (asm-pass12 (call (, $P $N)) $Csym 2) + (asm-pass12-call $P $N $Csym)) +; /* Procedural */ + (= (asm_pass12 (callv $_) $_ 2) True) + (= (asm-pass12 (execute (, $P $N)) $Csym 2) + (asm-pass12-call $P $N $Csym)) + (= (asm_pass12 (executev $_) $_ 2) True) + (= (asm_pass12 return_a $_ 1) True) + (= (asm_pass12 return_b $_ 1) True) + (= (asm_pass12 (jmpn_det $L) $_ 2) True) + (= (asm_pass12 (save_ht_jmp $_ $_) $_ 3) True) + + (= (asm_pass12 (allocate_flat $N) $_ 2) True) +; /* Allocate */ + (= (asm_pass12 (allocate_nonflat $N) $_ 2) True) + (= (asm_pass12 (allocate_nondet $N) $_ 2) True) + (= (asm_pass12 (flat_to_nondet $N) $_ 2) True) + + (= (asm_pass12 fail $_ 1) True) +; /* Backtracking */ + (= (asm_pass12 fail0 $_ 1) True) + + (= (asm_pass12 (fork $_) $_ 2) True) + + (= (asm_pass12 commit $_ 1) True) + (= (asm_pass12 cut $_ 1) True) + (= (asm_pass12 cut_fail $_ 1) True) + (= (asm_pass12 cut_return $_ 1) True) + (= (asm_pass12 save_b $_ 1) True) + (= (asm_pass12 (getbreg $_) $_ 2) True) + (= (asm_pass12 (getpbreg $_) $_ 2) True) + (= (asm_pass12 (putbreg $_) $_ 2) True) + + (= (asm_pass12 (hash_x $_ $_) $_ 5) True) +; /* Hashing */ + (= (asm_pass12 (hash_y $_ $_) $_ 5) True) + (= (asm_pass12 (tabsize $_) $_ 2) True) + + (= (asm_pass12 (arg $_ $_ $_) $_ 4) True) +; /* builtin */ + (= (asm_pass12 (arg0 $_ $_ $_) $_ 4) True) + (= (asm_pass12 (setarg $_ $_ $_) $_ 4) True) + (= (asm_pass12 (setarg0 $_ $_ $_) $_ 4) True) + (= (asm_pass12 (functor $_ $_ $_) $_ 4) True) + (= (asm_pass12 (builtin0 $_ $_) $_ 3) True) + (= (asm_pass12 (builtin1 $_ $_ $_) $_ 4) True) + (= (asm_pass12 (builtin2 $_ $_ $_ $_) $_ 5) True) + (= (asm_pass12 (builtin3 $_ $_ $_ $_ $_) $_ 6) True) + (= (asm_pass12 (builtin4 $_ $_ $_ $_ $_ $_) $_ 7) True) + (= (asm_pass12 (func_arity $_ $_) $_ 3) True) + + (= (asm_pass12 halt $_ 1) True) +; /* Miscellaneous */ + (= (asm_pass12 endfile $_ 1) True) + (= (asm_pass12 (gethtreg $_ $_) $_ 3) True) + (= (asm_pass12 (puthtreg $_ $_) $_ 3) True) + (= (asm_pass12 endfile $_ 1) True) + (= (asm_pass12 get_ar_cps $_ 1) True) + (= (asm_pass12 (put_ar_cps $_) $_ 2) True) + (= (asm_pass12 (move_ar_cps $_) $_ 2) True) + (= (asm_pass12 (jmpn_det_get_ar_cps $L) $_ 2) True) + (= (asm_pass12 (allocate_susp $N) $_ 2) True) + (= (asm_pass12 (susp_var_x $_) $_ 2) True) + (= (asm_pass12 (susp_var_y $_) $_ 2) True) + (= (asm-pass12 (delay (, $S $N) $_) $Csym 3) + (sym-member1 + (sym $S $N $_ $_) $Csym)) + (= (asm-pass12 (susp-var-delay $_ (, $S $N) $_ $_) $Csym 5) + (sym-member1 + (sym $S $N $_ $_) $Csym)) + (= (asm_pass12 end_delay $_ 1) True) - (= - (asm_pass12 - (complement $_ $_) $_ 3) True) -; + (= (asm_pass12 (nondet $_) $_ 2) True) + (= (asm_pass12 (jmp_susp $_) $_ 2) True) + (= (asm_pass12 (jmpn_dvar_y $_ $_) $_ 3) True) + (= (asm-pass12 (susp-var2-delay $_ (, $S $N) $_ $_) $Csym 5) + (sym-member1 + (sym $S $N $_ $_) $Csym)) + (= (asm_pass12 (domain_set_false_yy $_ $_) $_ 3) True) + (= (asm_pass12 (domain_set_false_yx $_ $_) $_ 3) True) - (= - (asm_pass12 - (add $_ $_ $_) $_ 4) True) -; + (= (asm-pass12-call $P $N $Csym) + ( (isglobal %asm-bp 0) + (b-GET-SYM-TYPE-ccf $P $N $Type) + (with_self + (=\= $Type 3) True))) +; /* no a call to a c function */ + (= (asm-pass12-call $P $N $Csym) + (with_self + (True *) + (sym-member1 + (sym $P $N $_ $_) $Csym))) - (= - (asm_pass12 - (add1_y $_) $_ 2) True) -; - (= - (asm_pass12 - (sub $_ $_ $_) $_ 4) True) -; + (= (asm-pass2 $Prog $Index $Csym $Lsym) + ( (with_self + (True *) + (asm-rearange-csym $Csym 255 $_ $Csym1)) + (asm-symbol $Csym1) + (asm-pass2a $Prog $Csym $Lsym) + (asm-index $Index $Csym $Lsym))) +; /**/ +; /* asm_pass12( Junk,_,N) :- true : N=0, cmp_error(['*** Error in assembly: unknown opcode: ',Junk]). */ +; /******************* Pass 2 **************************************/ - (= - (asm_pass12 - (sub1_y $_) $_ 2) True) -; - (= - (asm_pass12 - (mul $_ $_ $_) $_ 4) True) -; + (= (asm-index Nil $_ $_) + (with_self + (True *) True)) + (= (asm-index (Cons $Inst $Index) $Csym $Lsym) + ( (with_self + (True *) + (asm-proc-index $Inst $Csym $Lsym)) (asm-index $Index $Csym $Lsym))) - (= - (asm_pass12 - (div $_ $_ $_) $_ 4) True) -; - (= - (asm_pass12 - (idiv $_ $_ $_) $_ 4) True) -; + (= (asm-proc-index (pred $HashLab $Op $Num $Alt) $Csym $Lsym) + ( (with_self + (True *) + (x-or-y $Op $XY)) + (asm-lookup-ltab $HashLab $Lsym $Val1) + (asm-lookup-ltab $Alt $Lsym $Val2) + (b-ASPN4-cccc $Val1 $XY $Num $Val2))) + (= (asm-proc-index (arglabel $T $Val $Label) $Csym $Lsym) + ( (with_self + (== $T c) + (asm-lookup-ctab $Val 0 $Csym $Nval)) + (asm-lookup-ltab $Label $Lsym $L) + (writename $T) + (b-ASPN2-cc $Nval $L))) + (= (asm-proc-index (arglabel $T $Val $Label) $Csym $Lsym) + ( (with_self + (== $T s) + (= $Val + (, $Str $Arity))) + (asm-lookup-ctab $Str $Arity $Csym $Nval) + (asm-lookup-ltab $Label $Lsym $L) + (writename $T) + (b-ASPN2-cc $Nval $L))) + (= (asm-proc-index (arglabel $T $Val $Label) $Csym $Lsym) + ( (with_self + (True *) + (asm-lookup-ltab $Label $Lsym $L)) + (writename $T) + (b-ASPN2-cc $Val $L))) - (= - (asm_pass12 - (mod $_ $_ $_) $_ 4) True) -; + (= (asm-pass2a Nil $_ $_) + (with_self + (True *) True)) + (= (asm-pass2a (Cons $Inst $Insts) $Csym $Lsym) + ( (with_self + (True *) + (asm-pass2-inst $Inst $Csym $Lsym)) (asm-pass2a $Insts $Csym $Lsym))) - (= - (asm-pass12 - (para-struct (, $S $N)) $Csym 2) - (sym-member1 - (sym $S $N $_ $_) $Csym)) -; - (= - (asm_pass12 para_list $_ 1) True) -; - (= - (asm_pass12 para_nil $_ 1) True) -; - - (= - (asm-pass12 - (para-atom $C) $Csym 2) - (sym-member1 - (sym $C 0 $_ $_) $Csym)) -; - - (= - (asm_pass12 - (para_int $_) $_ 2) True) -; - - (= - (asm_pass12 - (para_ux $_) $_ 2) True) -; - - (= - (asm_pass12 - (para_uy $_) $_ 2) True) -; - - (= - (asm_pass12 - (para_vx $_) $_ 2) True) -; - - (= - (asm_pass12 - (para_vy $_) $_ 2) True) -; - - (= - (asm_pass12 para_void_one $_ 1) True) -; - - (= - (asm_pass12 - (para_void $_) $_ 2) True) -; - - (= - (asm_pass12 - (para_vy_vy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (para_vy_ux $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (para_vy_uy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (para_ux_vy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (para_ux_ux $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (para_ux_uy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (para_uy_vy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (para_uy_ux $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (para_uy_uy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (para_ux_ux_ux $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (para_ux_ux_uy $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (para_ux_uy_ux $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (para_ux_uy_uy $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (para_uy_ux_ux $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (para_uy_ux_uy $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (para_uy_uy_ux $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (para_uy_uy_uy $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (para_uy_uy_uy_uy $_ $_ $_ $_) $_ 5) True) -; - - - (= - (asm-pass12 - (call (, $P $N)) $Csym 2) - (asm-pass12-call $P $N $Csym)) -; - - (= - (asm_pass12 - (callv $_) $_ 2) True) -; - - (= - (asm-pass12 - (execute (, $P $N)) $Csym 2) - (asm-pass12-call $P $N $Csym)) -; - - (= - (asm_pass12 - (executev $_) $_ 2) True) -; - - (= - (asm_pass12 return_a $_ 1) True) -; - - (= - (asm_pass12 return_b $_ 1) True) -; - - (= - (asm_pass12 - (jmpn_det $L) $_ 2) True) -; - - (= - (asm_pass12 - (save_ht_jmp $_ $_) $_ 3) True) -; - - - (= - (asm_pass12 - (allocate_flat $N) $_ 2) True) -; - - (= - (asm_pass12 - (allocate_nonflat $N) $_ 2) True) -; - - (= - (asm_pass12 - (allocate_nondet $N) $_ 2) True) -; - - (= - (asm_pass12 - (flat_to_nondet $N) $_ 2) True) -; - - - (= - (asm_pass12 fail $_ 1) True) -; - - (= - (asm_pass12 fail0 $_ 1) True) -; - - - (= - (asm_pass12 - (fork $_) $_ 2) True) -; - - - (= - (asm_pass12 commit $_ 1) True) -; - - (= - (asm_pass12 cut $_ 1) True) -; - - (= - (asm_pass12 cut_fail $_ 1) True) -; - - (= - (asm_pass12 cut_return $_ 1) True) -; - - (= - (asm_pass12 save_b $_ 1) True) -; - - (= - (asm_pass12 - (getbreg $_) $_ 2) True) -; - - (= - (asm_pass12 - (getpbreg $_) $_ 2) True) -; - - (= - (asm_pass12 - (putbreg $_) $_ 2) True) -; - - - (= - (asm_pass12 - (hash_x $_ $_) $_ 5) True) -; - - (= - (asm_pass12 - (hash_y $_ $_) $_ 5) True) -; - - (= - (asm_pass12 - (tabsize $_) $_ 2) True) -; - - - (= - (asm_pass12 - (arg $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (arg0 $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (setarg $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (setarg0 $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (functor $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (builtin0 $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (builtin1 $_ $_ $_) $_ 4) True) -; - - (= - (asm_pass12 - (builtin2 $_ $_ $_ $_) $_ 5) True) -; - - (= - (asm_pass12 - (builtin3 $_ $_ $_ $_ $_) $_ 6) True) -; - - (= - (asm_pass12 - (builtin4 $_ $_ $_ $_ $_ $_) $_ 7) True) -; - - (= - (asm_pass12 - (func_arity $_ $_) $_ 3) True) -; - - - (= - (asm_pass12 halt $_ 1) True) -; - - (= - (asm_pass12 endfile $_ 1) True) -; - - (= - (asm_pass12 - (gethtreg $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (puthtreg $_ $_) $_ 3) True) -; - - (= - (asm_pass12 endfile $_ 1) True) -; - - (= - (asm_pass12 get_ar_cps $_ 1) True) -; - - (= - (asm_pass12 - (put_ar_cps $_) $_ 2) True) -; - - (= - (asm_pass12 - (move_ar_cps $_) $_ 2) True) -; - - (= - (asm_pass12 - (jmpn_det_get_ar_cps $L) $_ 2) True) -; - - (= - (asm_pass12 - (allocate_susp $N) $_ 2) True) -; - - (= - (asm_pass12 - (susp_var_x $_) $_ 2) True) -; - - (= - (asm_pass12 - (susp_var_y $_) $_ 2) True) -; - - (= - (asm-pass12 - (delay - (, $S $N) $_) $Csym 3) - (sym-member1 - (sym $S $N $_ $_) $Csym)) -; - - (= - (asm-pass12 - (susp-var-delay $_ - (, $S $N) $_ $_) $Csym 5) - (sym-member1 - (sym $S $N $_ $_) $Csym)) -; - - (= - (asm_pass12 end_delay $_ 1) True) -; - - - (= - (asm_pass12 - (nondet $_) $_ 2) True) -; - - (= - (asm_pass12 - (jmp_susp $_) $_ 2) True) -; - - (= - (asm_pass12 - (jmpn_dvar_y $_ $_) $_ 3) True) -; - - (= - (asm-pass12 - (susp-var2-delay $_ - (, $S $N) $_ $_) $Csym 5) - (sym-member1 - (sym $S $N $_ $_) $Csym)) -; - - (= - (asm_pass12 - (domain_set_false_yy $_ $_) $_ 3) True) -; - - (= - (asm_pass12 - (domain_set_false_yx $_ $_) $_ 3) True) -; - - - (= - (asm-pass12-call $P $N $Csym) - ( (isglobal %asm-bp 0) - (b-GET-SYM-TYPE-ccf $P $N $Type) - (with_self - (=\= $Type 3) True))) -; - - (= - (asm-pass12-call $P $N $Csym) - (with_self - (True *) - (sym-member1 - (sym $P $N $_ $_) $Csym))) -; - - - - (= - (asm-pass2 $Prog $Index $Csym $Lsym) - ( (with_self - (True *) - (asm-rearange-csym $Csym 255 $_ $Csym1)) - (asm-symbol $Csym1) - (asm-pass2a $Prog $Csym $Lsym) - (asm-index $Index $Csym $Lsym))) -; - - - - (= - (asm-index Nil $_ $_) - (with_self - (True *) True)) -; - - (= - (asm-index - (Cons $Inst $Index) $Csym $Lsym) - ( (with_self - (True *) - (asm-proc-index $Inst $Csym $Lsym)) (asm-index $Index $Csym $Lsym))) -; - - - - (= - (asm-proc-index - (pred $HashLab $Op $Num $Alt) $Csym $Lsym) - ( (with_self - (True *) - (x-or-y $Op $XY)) - (asm-lookup-ltab $HashLab $Lsym $Val1) - (asm-lookup-ltab $Alt $Lsym $Val2) - (b-ASPN4-cccc $Val1 $XY $Num $Val2))) -; - - (= - (asm-proc-index - (arglabel $T $Val $Label) $Csym $Lsym) - ( (with_self - (== $T c) - (asm-lookup-ctab $Val 0 $Csym $Nval)) - (asm-lookup-ltab $Label $Lsym $L) - (writename $T) - (b-ASPN2-cc $Nval $L))) -; - - (= - (asm-proc-index - (arglabel $T $Val $Label) $Csym $Lsym) - ( (with_self - (== $T s) - (= $Val - (, $Str $Arity))) - (asm-lookup-ctab $Str $Arity $Csym $Nval) - (asm-lookup-ltab $Label $Lsym $L) - (writename $T) - (b-ASPN2-cc $Nval $L))) -; - - (= - (asm-proc-index - (arglabel $T $Val $Label) $Csym $Lsym) - ( (with_self - (True *) - (asm-lookup-ltab $Label $Lsym $L)) - (writename $T) - (b-ASPN2-cc $Val $L))) -; - - - - (= - (asm-pass2a Nil $_ $_) - (with_self - (True *) True)) -; - - (= - (asm-pass2a - (Cons $Inst $Insts) $Csym $Lsym) - ( (with_self - (True *) - (asm-pass2-inst $Inst $Csym $Lsym)) (asm-pass2a $Insts $Csym $Lsym))) -; - - - - - (= - (asm-pass2-inst - (label $_) $_ $_) + (= (asm-pass2-inst (label $_) $_ $_) (with_self (True *) True)) -; - - (= - (asm-pass2-inst - (call $Lab) $Csym $Lsym) +; /* asm_pass2_inst(X,_,_) :- true ? output_mess(X), fail. */ + (= (asm-pass2-inst (call $Lab) $Csym $Lsym) ( (with_self (asm-lookup-ltab $Lab $Lsym $EPaddr) (opcode call-d $X)) (b-ASPN2-cc $X $EPaddr))) -; - - (= - (asm-pass2-inst - (call (, $P $N)) $Csym $Lsym) + (= (asm-pass2-inst (call (, $P $N)) $Csym $Lsym) (with_self (True *) (det-if-then-else @@ -1871,19 +729,11 @@ (opcode call $X) (b-ASPN2-cc $X $Index)) (warning (:: (/ $P $N) ' is called but not defined'))))) -; - - (= - (asm-pass2-inst - (execute $Lab) $Csym $Lsym) + (= (asm-pass2-inst (execute $Lab) $Csym $Lsym) ( (with_self (asm-lookup-ltab $Lab $Lsym $EPaddr) (opcode djmp $X)) (b-ASPN2-cc $X $EPaddr))) -; - - (= - (asm-pass2-inst - (execute (, $P $N)) $Csym $Lsym) + (= (asm-pass2-inst (execute (, $P $N)) $Csym $Lsym) (with_self (True *) (det-if-then-else @@ -1892,28 +742,15 @@ (opcode execute $X) (b-ASPN2-cc $X $Index)) (warning (:: (/ $P $N) ' is called but not defined'))))) -; - - (= - (asm-pass2-inst - (jmp $L) $Csym $Lsym) + (= (asm-pass2-inst (jmp $L) $Csym $Lsym) ( (with_self (asm-lookup-ltab $L $Lsym $Val) (opcode jmp $X)) (b-ASPN2-cc $X $Val))) -; - - (= - (asm-pass2-inst - (jmp-susp $L) $Csym $Lsym) + (= (asm-pass2-inst (jmp-susp $L) $Csym $Lsym) ( (with_self (asm-lookup-ltab $L $Lsym $Val) (opcode jmp-susp $X)) (b-ASPN2-cc $X $Val))) -; - - (= - (asm-pass2-inst - (jmpn-eq-struct-x $Op - (, $S $N) $L1 $L2) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-eq-struct-x $Op (, $S $N) $L1 $L2) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) @@ -1922,12 +759,7 @@ (opcode jmpn-eq-struct-x $X) (b-ASPN4-cccc $X $Op $I $Val1) (b-ASPN-c $Val2))) -; - - (= - (asm-pass2-inst - (jmpn-eq-struct-y $Op - (, $S $N) $L1 $L2) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-eq-struct-y $Op (, $S $N) $L1 $L2) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) @@ -1936,11 +768,7 @@ (opcode jmpn-eq-struct-y $X) (b-ASPN4-cccc $X $Op $I $Val1) (b-ASPN-c $Val2))) -; - - (= - (asm-pass2-inst - (jmpn-eq-atom-x $Op $C $L1 $L2) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-eq-atom-x $Op $C $L1 $L2) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $C 0 $Csym $I)) @@ -1949,11 +777,7 @@ (opcode jmpn-eq-symbol-x $X) (b-ASPN4-cccc $X $Op $I $Val1) (b-ASPN-c $Val2))) -; - - (= - (asm-pass2-inst - (jmpn-eq-atom-y $Op $C $L1 $L2) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-eq-atom-y $Op $C $L1 $L2) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $C 0 $Csym $I)) @@ -1962,33 +786,21 @@ (opcode jmpn-eq-symbol-y $X) (b-ASPN4-cccc $X $Op $I $Val1) (b-ASPN-c $Val2))) -; - - (= - (asm-pass2-inst - (jmpn-nil-x $Op $L1 $L2) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-nil-x $Op $L1 $L2) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L1 $Lsym $Val1)) (asm-lookup-ltab $L2 $Lsym $Val2) (opcode jmpn-nil-x $X) (b-ASPN4-cccc $X $Op $Val1 $Val2))) -; - - (= - (asm-pass2-inst - (jmpn-nil-y $Op $L1 $L2) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-nil-y $Op $L1 $L2) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L1 $Lsym $Val1)) (asm-lookup-ltab $L2 $Lsym $Val2) (opcode jmpn-nil-y $X) (b-ASPN4-cccc $X $Op $Val1 $Val2))) -; - - (= - (asm-pass2-inst - (switch-list-x $Op $L1 $L2 $L3) $Csym $Lsym) + (= (asm-pass2-inst (switch-list-x $Op $L1 $L2 $L3) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L1 $Lsym $Val1)) @@ -1997,11 +809,7 @@ (opcode switch-list-x $X) (b-ASPN4-cccc $X $Op $Val1 $Val2) (b-ASPN-c $Val3))) -; - - (= - (asm-pass2-inst - (switch-list-y $Op $L1 $L2 $L3) $Csym $Lsym) + (= (asm-pass2-inst (switch-list-y $Op $L1 $L2 $L3) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L1 $Lsym $Val1)) @@ -2010,11 +818,7 @@ (opcode switch-list-y $X) (b-ASPN4-cccc $X $Op $Val1 $Val2) (b-ASPN-c $Val3))) -; - - (= - (asm-pass2-inst - (switch-list-yxx $Op $L1 $L2 $L3) $Csym $Lsym) + (= (asm-pass2-inst (switch-list-yxx $Op $L1 $L2 $L3) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L1 $Lsym $Val1)) @@ -2023,11 +827,7 @@ (opcode switch-list-yxx $X) (b-ASPN4-cccc $X $Op $Val1 $Val2) (b-ASPN-c $Val3))) -; - - (= - (asm-pass2-inst - (switch-list-yxy $Op $L1 $L2 $L3) $Csym $Lsym) + (= (asm-pass2-inst (switch-list-yxy $Op $L1 $L2 $L3) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L1 $Lsym $Val1)) @@ -2036,11 +836,7 @@ (opcode switch-list-yxy $X) (b-ASPN4-cccc $X $Op $Val1 $Val2) (b-ASPN-c $Val3))) -; - - (= - (asm-pass2-inst - (switch-list-yyx $Op $L1 $L2 $L3) $Csym $Lsym) + (= (asm-pass2-inst (switch-list-yyx $Op $L1 $L2 $L3) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L1 $Lsym $Val1)) @@ -2049,11 +845,7 @@ (opcode switch-list-yyx $X) (b-ASPN4-cccc $X $Op $Val1 $Val2) (b-ASPN-c $Val3))) -; - - (= - (asm-pass2-inst - (switch-list-yyy $Op $L1 $L2 $L3) $Csym $Lsym) + (= (asm-pass2-inst (switch-list-yyy $Op $L1 $L2 $L3) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L1 $Lsym $Val1)) @@ -2062,11 +854,7 @@ (opcode switch-list-yyy $X) (b-ASPN4-cccc $X $Op $Val1 $Val2) (b-ASPN-c $Val3))) -; - - (= - (asm-pass2-inst - (jmpn-eq-int-x $Op $I $L1 $L2) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-eq-int-x $Op $I $L1 $L2) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L1 $Lsym $Val1)) @@ -2074,11 +862,7 @@ (opcode jmpn-eq-int-x $X) (b-ASPN4-cccc $X $Op $I $Val1) (b-ASPN-c $Val2))) -; - - (= - (asm-pass2-inst - (jmpn-eq-int-y $Op $I $L1 $L2) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-eq-int-y $Op $I $L1 $L2) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L1 $Lsym $Val1)) @@ -2086,11 +870,7 @@ (opcode jmpn-eq-int-y $X) (b-ASPN4-cccc $X $Op $I $Val1) (b-ASPN-c $Val2))) -; - - (= - (asm-pass2-inst - (jmpn-eql $Op1 $Op2 $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-eql $Op1 $Op2 $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) @@ -2098,11 +878,7 @@ (x-or-y $Op2 $XY2) (opcode jmpn-eql $X) (b-ASPN4-cccc $X $XY1 $XY2 $Val))) -; - - (= - (asm-pass2-inst - (jmp-eql $Op1 $Op2 $L) $Csym $Lsym) + (= (asm-pass2-inst (jmp-eql $Op1 $Op2 $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) @@ -2110,21 +886,13 @@ (x-or-y $Op2 $XY2) (opcode jmp-eql $X) (b-ASPN4-cccc $X $XY1 $XY2 $Val))) -; - - (= - (asm-pass2-inst - (jmp-eql-yy $Op1 $Op2 $L) $Csym $Lsym) + (= (asm-pass2-inst (jmp-eql-yy $Op1 $Op2 $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmp-eql-yy $X) (b-ASPN4-cccc $X $Op1 $Op2 $Val))) -; - - (= - (asm-pass2-inst - (jmpn-gt $Op1 $Op2 $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-gt $Op1 $Op2 $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) @@ -2132,21 +900,13 @@ (x-or-y $Op2 $XY2) (opcode jmpn-gt $X) (b-ASPN4-cccc $X $XY1 $XY2 $Val))) -; - - (= - (asm-pass2-inst - (jmpn-gt-yy $Op1 $Op2 $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-gt-yy $Op1 $Op2 $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmpn-gt-yy $X) (b-ASPN4-cccc $X $Op1 $Op2 $Val))) -; - - (= - (asm-pass2-inst - (jmpn-ge $Op1 $Op2 $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-ge $Op1 $Op2 $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) @@ -2154,21 +914,13 @@ (x-or-y $Op2 $XY2) (opcode jmpn-ge $X) (b-ASPN4-cccc $X $XY1 $XY2 $Val))) -; - - (= - (asm-pass2-inst - (jmpn-ge-yy $Op1 $Op2 $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-ge-yy $Op1 $Op2 $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmpn-ge-yy $X) (b-ASPN4-cccc $X $Op1 $Op2 $Val))) -; - - (= - (asm-pass2-inst - (jmpn-id $Op1 $Op2 $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-id $Op1 $Op2 $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) @@ -2176,11 +928,7 @@ (x-or-y $Op2 $XY2) (opcode jmpn-id $X) (b-ASPN4-cccc $X $XY1 $XY2 $Val))) -; - - (= - (asm-pass2-inst - (jmp-id $Op1 $Op2 $L) $Csym $Lsym) + (= (asm-pass2-inst (jmp-id $Op1 $Op2 $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) @@ -2188,454 +936,269 @@ (x-or-y $Op2 $XY2) (opcode jmp-id $X) (b-ASPN4-cccc $X $XY1 $XY2 $Val))) -; - - (= - (asm-pass2-inst - (jmpn-var-x $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-var-x $Op $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmpn-var-x $X) (b-ASPN3-ccc $X $Op $Val))) -; - - (= - (asm-pass2-inst - (jmpn-var-y $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-var-y $Op $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmpn-var-y $X) (b-ASPN3-ccc $X $Op $Val))) -; - - (= - (asm-pass2-inst - (jmp-var-x $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (jmp-var-x $Op $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmp-var-x $X) (b-ASPN3-ccc $X $Op $Val))) -; - - (= - (asm-pass2-inst - (jmp-var-y $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (jmp-var-y $Op $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmp-var-y $X) (b-ASPN3-ccc $X $Op $Val))) -; - - (= - (asm-pass2-inst - (jmpn-atom-x $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-atom-x $Op $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmpn-symbol-x $X) (b-ASPN3-ccc $X $Op $Val))) -; - - (= - (asm-pass2-inst - (jmpn-atom-y $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-atom-y $Op $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmpn-symbol-y $X) (b-ASPN3-ccc $X $Op $Val))) -; - - (= - (asm-pass2-inst - (jmpn-atomic-x $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-atomic-x $Op $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmpn-symbolic-x $X) (b-ASPN3-ccc $X $Op $Val))) -; - - (= - (asm-pass2-inst - (jmpn-atomic-y $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-atomic-y $Op $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmpn-symbolic-y $X) (b-ASPN3-ccc $X $Op $Val))) -; - - (= - (asm-pass2-inst - (jmpn-num-x $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-num-x $Op $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmpn-num-x $X) (b-ASPN3-ccc $X $Op $Val))) -; - - (= - (asm-pass2-inst - (jmpn-num-y $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-num-y $Op $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmpn-num-y $X) (b-ASPN3-ccc $X $Op $Val))) -; - - (= - (asm-pass2-inst - (jmpn-float-x $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-float-x $Op $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmpn-float-x $X) (b-ASPN3-ccc $X $Op $Val))) -; - - (= - (asm-pass2-inst - (jmpn-float-y $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-float-y $Op $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmpn-float-y $X) (b-ASPN3-ccc $X $Op $Val))) -; - - (= - (asm-pass2-inst - (jmpn-int-x $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-int-x $Op $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmpn-int-x $X) (b-ASPN3-ccc $X $Op $Val))) -; - - (= - (asm-pass2-inst - (jmpn-int-y $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-int-y $Op $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmpn-int-y $X) (b-ASPN3-ccc $X $Op $Val))) -; - - (= - (asm-pass2-inst - (hash-jmpn-nil $L) $Csym $Lsym) + (= (asm-pass2-inst (hash-jmpn-nil $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode hash-jmpn-nil $X) (b-ASPN2-cc $X $Val))) -; - - (= - (asm-pass2-inst - (hash-jmpn-list $L) $Csym $Lsym) + (= (asm-pass2-inst (hash-jmpn-list $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode hash-jmpn-list $X) (b-ASPN2-cc $X $Val))) -; - - (= - (asm-pass2-inst - (hash-jmpn-int $I $L) $Csym $Lsym) + (= (asm-pass2-inst (hash-jmpn-int $I $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode hash-jmpn-int $X) (b-ASPN3-ccc $X $I $Val))) -; - - (= - (asm-pass2-inst - (hash-jmpn-atom $C $L) $Csym $Lsym) + (= (asm-pass2-inst (hash-jmpn-atom $C $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $C 0 $Csym $I)) (asm-lookup-ltab $L $Lsym $Val) (opcode hash-jmpn-symbol $X) (b-ASPN3-ccc $X $I $Val))) -; - - (= - (asm-pass2-inst - (hash-jmpn-struct - (, $S $N) $L) $Csym $Lsym) + (= (asm-pass2-inst (hash-jmpn-struct (, $S $N) $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) (asm-lookup-ltab $L $Lsym $Val) (opcode hash-jmpn-struct $X) (b-ASPN3-ccc $X $I $Val))) -; - - (= - (asm-pass2-inst - (hash-jmpn-struct-x - (, $S $N) $L) $Csym $Lsym) + (= (asm-pass2-inst (hash-jmpn-struct-x (, $S $N) $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) (asm-lookup-ltab $L $Lsym $Val) (opcode hash-jmpn-struct-x $X) (b-ASPN3-ccc $X $I $Val))) -; - - (= - (asm-pass2-inst - (hash-jmpn-struct-y - (, $S $N) $L) $Csym $Lsym) + (= (asm-pass2-inst (hash-jmpn-struct-y (, $S $N) $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) (asm-lookup-ltab $L $Lsym $Val) (opcode hash-jmpn-struct-y $X) (b-ASPN3-ccc $X $I $Val))) -; - - (= - (asm-pass2-inst - (hash-jmpn-struct-xx - (, $S $N) $L) $Csym $Lsym) + (= (asm-pass2-inst (hash-jmpn-struct-xx (, $S $N) $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) (asm-lookup-ltab $L $Lsym $Val) (opcode hash-jmpn-struct-xx $X) (b-ASPN3-ccc $X $I $Val))) -; - - (= - (asm-pass2-inst - (hash-jmpn-struct-xy - (, $S $N) $L) $Csym $Lsym) + (= (asm-pass2-inst (hash-jmpn-struct-xy (, $S $N) $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) (asm-lookup-ltab $L $Lsym $Val) (opcode hash-jmpn-struct-xy $X) (b-ASPN3-ccc $X $I $Val))) -; - - (= - (asm-pass2-inst - (hash-jmpn-struct-yx - (, $S $N) $L) $Csym $Lsym) + (= (asm-pass2-inst (hash-jmpn-struct-yx (, $S $N) $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) (asm-lookup-ltab $L $Lsym $Val) (opcode hash-jmpn-struct-yx $X) (b-ASPN3-ccc $X $I $Val))) -; - - (= - (asm-pass2-inst - (hash-jmpn-struct-yy - (, $S $N) $L) $Csym $Lsym) + (= (asm-pass2-inst (hash-jmpn-struct-yy (, $S $N) $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) (asm-lookup-ltab $L $Lsym $Val) (opcode hash-jmpn-struct-yy $X) (b-ASPN3-ccc $X $I $Val))) -; - - (= - (asm-pass2-inst - (jmpn-det $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-det $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmpn-det $X) (b-ASPN2-cc $X $Val))) -; - - (= - (asm-pass2-inst - (jmpn-det-get-ar-cps $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-det-get-ar-cps $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmpn-det-get-ar-cps $X) (b-ASPN2-cc $X $Val))) -; - - (= - (asm-pass2-inst - (save-ht-jmp $L1 $L2) $Csym $Lsym) + (= (asm-pass2-inst (save-ht-jmp $L1 $L2) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L1 $Lsym $Val1)) (asm-lookup-ltab $L2 $Lsym $Val2) (opcode save-ht-jmp $X) (b-ASPN3-ccc $X $Val1 $Val2))) -; - - (= - (asm-pass2-inst - (unify-struct-x $Op - (, $S $N)) $Csym $Lsym) + (= (asm-pass2-inst (unify-struct-x $Op (, $S $N)) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) (opcode unify-struct-x $X) (b-ASPN3-ccc $X $Op $I))) -; - - (= - (asm-pass2-inst - (unify-struct-y $Op - (, $S $N)) $Csym $Lsym) + (= (asm-pass2-inst (unify-struct-y $Op (, $S $N)) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) (opcode unify-struct-y $X) (b-ASPN3-ccc $X $Op $I))) -; - - (= - (asm-pass2-inst - (unify0-struct-y $Op - (, $S $N)) $Csym $Lsym) + (= (asm-pass2-inst (unify0-struct-y $Op (, $S $N)) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) (opcode unify0-struct-y $X) (b-ASPN3-ccc $X $Op $I))) -; - - (= - (asm-pass2-inst - (unicut-struct-y $Op - (, $S $N)) $Csym $Lsym) + (= (asm-pass2-inst (unicut-struct-y $Op (, $S $N)) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) (opcode unicut-struct-y $X) (b-ASPN3-ccc $X $Op $I))) -; - - (= - (asm-pass2-inst - (unify-atom-x $Op $C) $Csym $Lsym) + (= (asm-pass2-inst (unify-atom-x $Op $C) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $C 0 $Csym $I)) (opcode unify-symbol-x $X) (b-ASPN3-ccc $X $Op $I))) -; - - (= - (asm-pass2-inst - (unify-atom-y $Op $C) $Csym $Lsym) + (= (asm-pass2-inst (unify-atom-y $Op $C) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $C 0 $Csym $I)) (opcode unify-symbol-y $X) (b-ASPN3-ccc $X $Op $I))) -; - - (= - (asm-pass2-inst - (unify0-atom-y $Op $C) $Csym $Lsym) + (= (asm-pass2-inst (unify0-atom-y $Op $C) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $C 0 $Csym $I)) (opcode unify0-symbol-y $X) (b-ASPN3-ccc $X $Op $I))) -; - - (= - (asm-pass2-inst - (unicut-atom-y $Op $C) $Csym $Lsym) + (= (asm-pass2-inst (unicut-atom-y $Op $C) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $C 0 $Csym $I)) (opcode unicut-symbol-y $X) (b-ASPN3-ccc $X $Op $I))) -; - - (= - (asm-pass2-inst - (unify-arg-atom $C) $Csym $Lsym) + (= (asm-pass2-inst (unify-arg-atom $C) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $C 0 $Csym $I)) (opcode unify-arg-symbol $X) (b-ASPN2-cc $X $I))) -; - - (= - (asm-pass2-inst - (unify-arg-struct (, $S $N)) $Csym $Lsym) + (= (asm-pass2-inst (unify-arg-struct (, $S $N)) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) (opcode unify-arg-struct $X) (b-ASPN2-cc $X $I))) -; - - (= - (asm-pass2-inst - (move-struct-x $Op - (, $S $N)) $Csym $Lsym) + (= (asm-pass2-inst (move-struct-x $Op (, $S $N)) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) (opcode move-struct-x $X) (b-ASPN3-ccc $X $Op $I))) -; - - (= - (asm-pass2-inst - (move-struct-y $Op - (, $S $N)) $Csym $Lsym) + (= (asm-pass2-inst (move-struct-y $Op (, $S $N)) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) (opcode move-struct-y $X) (b-ASPN3-ccc $X $Op $I))) -; - - (= - (asm-pass2-inst - (move-atom-x $Op $C) $Csym $Lsym) + (= (asm-pass2-inst (move-atom-x $Op $C) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $C 0 $Csym $I)) (opcode move-symbol-x $X) (b-ASPN3-ccc $X $Op $I))) -; - - (= - (asm-pass2-inst - (move-atom-y $Op $C) $Csym $Lsym) + (= (asm-pass2-inst (move-atom-y $Op $C) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $C 0 $Csym $I)) (opcode move-symbol-y $X) (b-ASPN3-ccc $X $Op $I))) -; - - (= - (asm-pass2-inst - (and $Op1 $Op2 $Op3) $Csym $Lsym) + (= (asm-pass2-inst (and $Op1 $Op2 $Op3) $Csym $Lsym) ( (with_self (True *) (x-or-y $Op1 $XY1)) @@ -2643,11 +1206,7 @@ (x-or-y $Op3 $XY3) (opcode and $X) (b-ASPN4-cccc $X $XY1 $XY2 $XY3))) -; - - (= - (asm-pass2-inst - (or $Op1 $Op2 $Op3) $Csym $Lsym) + (= (asm-pass2-inst (or $Op1 $Op2 $Op3) $Csym $Lsym) ( (with_self (True *) (x-or-y $Op1 $XY1)) @@ -2655,11 +1214,7 @@ (x-or-y $Op3 $XY3) (opcode or $X) (b-ASPN4-cccc $X $XY1 $XY2 $XY3))) -; - - (= - (asm-pass2-inst - (lshiftl $Op1 $Op2 $Op3) $Csym $Lsym) + (= (asm-pass2-inst (lshiftl $Op1 $Op2 $Op3) $Csym $Lsym) ( (with_self (True *) (x-or-y $Op1 $XY1)) @@ -2667,11 +1222,7 @@ (x-or-y $Op3 $XY3) (opcode lshiftl $X) (b-ASPN4-cccc $X $XY1 $XY2 $XY3))) -; - - (= - (asm-pass2-inst - (lshiftr $Op1 $Op2 $Op3) $Csym $Lsym) + (= (asm-pass2-inst (lshiftr $Op1 $Op2 $Op3) $Csym $Lsym) ( (with_self (True *) (x-or-y $Op1 $XY1)) @@ -2679,22 +1230,14 @@ (x-or-y $Op3 $XY3) (opcode lshiftr $X) (b-ASPN4-cccc $X $XY1 $XY2 $XY3))) -; - - (= - (asm-pass2-inst - (complement $Op1 $Op2) $Csym $Lsym) + (= (asm-pass2-inst (complement $Op1 $Op2) $Csym $Lsym) ( (with_self (True *) (x-or-y $Op1 $XY1)) (x-or-y $Op2 $XY2) (opcode complement $X) (b-ASPN3-ccc $X $XY1 $XY2))) -; - - (= - (asm-pass2-inst - (add $Op1 $Op2 $Op3) $Csym $Lsym) + (= (asm-pass2-inst (add $Op1 $Op2 $Op3) $Csym $Lsym) ( (with_self (True *) (x-or-y $Op1 $XY1)) @@ -2702,11 +1245,7 @@ (x-or-y $Op3 $XY3) (opcode add $X) (b-ASPN4-cccc $X $XY1 $XY2 $XY3))) -; - - (= - (asm-pass2-inst - (sub $Op1 $Op2 $Op3) $Csym $Lsym) + (= (asm-pass2-inst (sub $Op1 $Op2 $Op3) $Csym $Lsym) ( (with_self (True *) (x-or-y $Op1 $XY1)) @@ -2714,11 +1253,7 @@ (x-or-y $Op3 $XY3) (opcode sub $X) (b-ASPN4-cccc $X $XY1 $XY2 $XY3))) -; - - (= - (asm-pass2-inst - (mul $Op1 $Op2 $Op3) $Csym $Lsym) + (= (asm-pass2-inst (mul $Op1 $Op2 $Op3) $Csym $Lsym) ( (with_self (True *) (x-or-y $Op1 $XY1)) @@ -2726,11 +1261,7 @@ (x-or-y $Op3 $XY3) (opcode mul $X) (b-ASPN4-cccc $X $XY1 $XY2 $XY3))) -; - - (= - (asm-pass2-inst - (div $Op1 $Op2 $Op3) $Csym $Lsym) + (= (asm-pass2-inst (div $Op1 $Op2 $Op3) $Csym $Lsym) ( (with_self (True *) (x-or-y $Op1 $XY1)) @@ -2738,11 +1269,7 @@ (x-or-y $Op3 $XY3) (opcode div $X) (b-ASPN4-cccc $X $XY1 $XY2 $XY3))) -; - - (= - (asm-pass2-inst - (idiv $Op1 $Op2 $Op3) $Csym $Lsym) + (= (asm-pass2-inst (idiv $Op1 $Op2 $Op3) $Csym $Lsym) ( (with_self (True *) (x-or-y $Op1 $XY1)) @@ -2750,11 +1277,7 @@ (x-or-y $Op3 $XY3) (opcode idiv $X) (b-ASPN4-cccc $X $XY1 $XY2 $XY3))) -; - - (= - (asm-pass2-inst - (mod $Op1 $Op2 $Op3) $Csym $Lsym) + (= (asm-pass2-inst (mod $Op1 $Op2 $Op3) $Csym $Lsym) ( (with_self (True *) (x-or-y $Op1 $XY1)) @@ -2762,221 +1285,135 @@ (x-or-y $Op3 $XY3) (opcode mod $X) (b-ASPN4-cccc $X $XY1 $XY2 $XY3))) -; - - (= - (asm-pass2-inst - (para-struct (, $S $N)) $Csym $Lsym) + (= (asm-pass2-inst (para-struct (, $S $N)) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) (opcode para-struct $X) (b-ASPN2-cc $X $I))) -; - - (= - (asm-pass2-inst - (para-atom $C) $Csym $Lsym) + (= (asm-pass2-inst (para-atom $C) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $C 0 $Csym $I)) (opcode para-symbol $X) (b-ASPN2-cc $X $I))) -; - - (= - (asm-pass2-inst - (fork $L) $Csym $Lsym) + (= (asm-pass2-inst (fork $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode fork $X) (b-ASPN2-cc $X $Val))) -; - - (= - (asm-pass2-inst - (fork-unify-struct-y $Op - (, $S $N) $L) $Csym $Lsym) + (= (asm-pass2-inst (fork-unify-struct-y $Op (, $S $N) $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (asm-lookup-ctab $S $N $Csym $I) (opcode fork-unify-struct-y $X) (b-ASPN4-cccc $X $Op $I $Val))) -; - - (= - (asm-pass2-inst - (fork-unify-list-y $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (fork-unify-list-y $Op $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode fork-unify-list-y $X) (b-ASPN3-ccc $X $Op $Val))) -; - - (= - (asm-pass2-inst - (fork-unify-nil-y $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (fork-unify-nil-y $Op $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode fork-unify-nil-y $X) (b-ASPN3-ccc $X $Op $Val))) -; - - (= - (asm-pass2-inst - (fork-unify-atom-y $Op $C $L) $Csym $Lsym) + (= (asm-pass2-inst (fork-unify-atom-y $Op $C $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $C 0 $Csym $I)) (asm-lookup-ltab $L $Lsym $Val) (opcode fork-unify-symbol-y $X) (b-ASPN4-cccc $X $Op $I $Val))) -; - - (= - (asm-pass2-inst - (fork-unify-int-y $Op1 $Op2 $L) $Csym $Lsym) + (= (asm-pass2-inst (fork-unify-int-y $Op1 $Op2 $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode fork-unify-int-y $X) (b-ASPN4-cccc $X $Op1 $Op2 $Val))) -; - - (= - (asm-pass2-inst - (fork-unify-uy-uy $Op1 $Op2 $L) $Csym $Lsym) + (= (asm-pass2-inst (fork-unify-uy-uy $Op1 $Op2 $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode fork-unify-uy-uy $X) (b-ASPN4-cccc $X $Op1 $Op2 $Val))) -; - - (= - (asm-pass2-inst - (fork-unicut-struct-y $Op - (, $S $N) $L) $Csym $Lsym) + (= (asm-pass2-inst (fork-unicut-struct-y $Op (, $S $N) $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (asm-lookup-ctab $S $N $Csym $I) (opcode fork-unicut-struct-y $X) (b-ASPN4-cccc $X $Op $I $Val))) -; - - (= - (asm-pass2-inst - (fork-unicut-list-y $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (fork-unicut-list-y $Op $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode fork-unicut-list-y $X) (b-ASPN3-ccc $X $Op $Val))) -; - - (= - (asm-pass2-inst - (fork-unicut-nil-y $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (fork-unicut-nil-y $Op $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode fork-unicut-nil-y $X) (b-ASPN3-ccc $X $Op $Val))) -; - - (= - (asm-pass2-inst - (fork-unicut-atom-y $Op $C $L) $Csym $Lsym) + (= (asm-pass2-inst (fork-unicut-atom-y $Op $C $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $C 0 $Csym $I)) (asm-lookup-ltab $L $Lsym $Val) (opcode fork-unicut-symbol-y $X) (b-ASPN4-cccc $X $Op $I $Val))) -; - - (= - (asm-pass2-inst - (fork-unicut-int-y $Op1 $Op2 $L) $Csym $Lsym) + (= (asm-pass2-inst (fork-unicut-int-y $Op1 $Op2 $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode fork-unicut-int-y $X) (b-ASPN4-cccc $X $Op1 $Op2 $Val))) -; - - (= - (asm-pass2-inst - (fork-unicut-ux-uy $Op1 $Op2 $L) $Csym $Lsym) + (= (asm-pass2-inst (fork-unicut-ux-uy $Op1 $Op2 $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode fork-unicut-ux-uy $X) (b-ASPN4-cccc $X $Op1 $Op2 $Val))) -; - - (= - (asm-pass2-inst - (fork-unicut-uy-uy $Op1 $Op2 $L) $Csym $Lsym) + (= (asm-pass2-inst (fork-unicut-uy-uy $Op1 $Op2 $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode fork-unicut-uy-uy $X) (b-ASPN4-cccc $X $Op1 $Op2 $Val))) -; - - (= - (asm-pass2-inst - (hash-x $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (hash-x $Op $L) $Csym $Lsym) ( (with_self (True *) (opcode hash-x $X)) (asm-lookup-ltab $L $Lsym $Val) (b-ASPN4-cccc $X $Op 0 0) (b-ASPN-c $Val))) -; - - (= - (asm-pass2-inst - (hash-y $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (hash-y $Op $L) $Csym $Lsym) ( (with_self (True *) (opcode hash-y $X)) (asm-lookup-ltab $L $Lsym $Val) (b-ASPN4-cccc $X $Op 0 0) (b-ASPN-c $Val))) -; - - (= - (asm-pass2-inst - (callv $Op1) $Csym $Lsym) + (= (asm-pass2-inst (callv $Op1) $Csym $Lsym) ( (with_self (True *) (opcode callv $X)) (x-or-y $Op1 $XY1) (b-ASPN2-cc $X $XY1))) -; - - (= - (asm-pass2-inst - (executev $Op1) $Csym $Lsym) + (= (asm-pass2-inst (executev $Op1) $Csym $Lsym) ( (with_self (True *) (opcode executev $X)) (x-or-y $Op1 $XY1) (b-ASPN2-cc $X $XY1))) -; - - (= - (asm-pass2-inst - (functor $Op1 $Op2 $Op3) $Csym $Lsym) + (= (asm-pass2-inst (functor $Op1 $Op2 $Op3) $Csym $Lsym) ( (with_self (True *) (opcode functor $X)) @@ -2984,33 +1421,21 @@ (x-or-y $Op2 $XY2) (x-or-y $Op3 $XY3) (b-ASPN4-cccc $X $XY1 $XY2 $XY3))) -; - - (= - (asm-pass2-inst - (func-arity $Op1 $Op2) $Csym $Lsym) + (= (asm-pass2-inst (func-arity $Op1 $Op2) $Csym $Lsym) ( (with_self (True *) (opcode func-arity $X)) (x-or-y $Op1 $XY1) (x-or-y $Op2 $XY2) (b-ASPN3-ccc $X $XY1 $XY2))) -; - - (= - (asm-pass2-inst - (arg0 $Op1 $Op2 $Op3) $Csym $Lsym) + (= (asm-pass2-inst (arg0 $Op1 $Op2 $Op3) $Csym $Lsym) ( (with_self (integer $Op1) (opcode arg0 $X)) (x-or-y $Op2 $XY2) (x-or-y $Op3 $XY3) (b-ASPN4-cccc $X $Op1 $XY2 $XY3))) -; - - (= - (asm-pass2-inst - (arg $Op1 $Op2 $Op3) $Csym $Lsym) + (= (asm-pass2-inst (arg $Op1 $Op2 $Op3) $Csym $Lsym) ( (with_self (True *) (opcode arg $X)) @@ -3018,22 +1443,14 @@ (x-or-y $Op2 $XY2) (x-or-y $Op3 $XY3) (b-ASPN4-cccc $X $XY1 $XY2 $XY3))) -; - - (= - (asm-pass2-inst - (setarg0 $Op1 $Op2 $Op3) $Csym $Lsym) + (= (asm-pass2-inst (setarg0 $Op1 $Op2 $Op3) $Csym $Lsym) ( (with_self (integer $Op1) (opcode setarg0 $X)) (x-or-y $Op2 $XY2) (x-or-y $Op3 $XY3) (b-ASPN4-cccc $X $Op1 $XY2 $XY3))) -; - - (= - (asm-pass2-inst - (setarg $Op1 $Op2 $Op3) $Csym $Lsym) + (= (asm-pass2-inst (setarg $Op1 $Op2 $Op3) $Csym $Lsym) ( (with_self (True *) (opcode setarg $X)) @@ -3041,32 +1458,20 @@ (x-or-y $Op2 $XY2) (x-or-y $Op3 $XY3) (b-ASPN4-cccc $X $XY1 $XY2 $XY3))) -; - - (= - (asm-pass2-inst - (builtin0 $N $L) $Csym $Lsym) + (= (asm-pass2-inst (builtin0 $N $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode builtin0 $X) (b-ASPN3-ccc $X $N $Val))) -; - - (= - (asm-pass2-inst - (builtin1 $N $L $Op1) $Csym $Lsym) + (= (asm-pass2-inst (builtin1 $N $L $Op1) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode builtin1 $X) (x-or-y $Op1 $XY1) (b-ASPN4-cccc $X $N $Val $XY1))) -; - - (= - (asm-pass2-inst - (builtin2 $N $L $Op1 $Op2) $Csym $Lsym) + (= (asm-pass2-inst (builtin2 $N $L $Op1 $Op2) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) @@ -3075,11 +1480,7 @@ (x-or-y $Op2 $XY2) (b-ASPN4-cccc $X $N $Val $XY1) (b-ASPN-c $XY2))) -; - - (= - (asm-pass2-inst - (builtin3 $N $L $Op1 $Op2 $Op3) $Csym $Lsym) + (= (asm-pass2-inst (builtin3 $N $L $Op1 $Op2 $Op3) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) @@ -3089,11 +1490,7 @@ (x-or-y $Op3 $XY3) (b-ASPN4-cccc $X $N $Val $XY1) (b-ASPN2-cc $XY2 $XY3))) -; - - (= - (asm-pass2-inst - (builtin4 $N $L $Op1 $Op2 $Op3 $Op4) $Csym $Lsym) + (= (asm-pass2-inst (builtin4 $N $L $Op1 $Op2 $Op3 $Op4) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) @@ -3104,74 +1501,40 @@ (x-or-y $Op4 $XY4) (b-ASPN4-cccc $X $N $Val $XY1) (b-ASPN3-ccc $XY2 $XY3 $XY4))) -; - - (= - (asm-pass2-inst - (getbreg $Op1) $Csym $Lsym) + (= (asm-pass2-inst (getbreg $Op1) $Csym $Lsym) ( (with_self (True *) (opcode getbreg $X)) (x-or-y $Op1 $XY1) (b-ASPN2-cc $X $XY1))) -; - - (= - (asm-pass2-inst - (getpbreg $Op1) $Csym $Lsym) + (= (asm-pass2-inst (getpbreg $Op1) $Csym $Lsym) ( (with_self (True *) (opcode getpbreg $X)) (x-or-y $Op1 $XY1) (b-ASPN2-cc $X $XY1))) -; - - (= - (asm-pass2-inst - (putbreg $Op1) $Csym $Lsym) + (= (asm-pass2-inst (putbreg $Op1) $Csym $Lsym) ( (with_self (True *) (opcode putbreg $X)) (x-or-y $Op1 $XY1) (b-ASPN2-cc $X $XY1))) -; - - (= - (asm-pass2-inst - (gethtreg - (y $X1) - (y $X2)) $Csym $Lsym) + (= (asm-pass2-inst (gethtreg (y $X1) (y $X2)) $Csym $Lsym) ( (with_self (True *) (opcode gethtreg $X)) (b-ASPN3-ccc $X $X1 $X2))) -; - - (= - (asm-pass2-inst - (puthtreg - (y $X1) - (y $X2)) $Csym $Lsym) + (= (asm-pass2-inst (puthtreg (y $X1) (y $X2)) $Csym $Lsym) ( (with_self (True *) (opcode puthtreg $X)) (b-ASPN3-ccc $X $X1 $X2))) -; - - (= - (asm-pass2-inst - (delay - (, $S $N) $L) $Csym $Lsym) + (= (asm-pass2-inst (delay (, $S $N) $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) (asm-lookup-ltab $L $Lsym $Val) (opcode delay $X) (b-ASPN3-ccc $X $I $Val))) -; - - (= - (asm-pass2-inst - (susp-var-delay $Op - (, $S $N) $L1 $L2) $Csym $Lsym) + (= (asm-pass2-inst (susp-var-delay $Op (, $S $N) $L1 $L2) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) @@ -3180,22 +1543,13 @@ (opcode susp-var-delay $X) (b-ASPN4-cccc $X $Op $I $Val1) (b-ASPN-c $Val2))) -; - - (= - (asm-pass2-inst - (jmpn-dvar-y $Op $L) $Csym $Lsym) + (= (asm-pass2-inst (jmpn-dvar-y $Op $L) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ltab $L $Lsym $Val)) (opcode jmpn-dvar-y $X) (b-ASPN3-ccc $X $Op $Val))) -; - - (= - (asm-pass2-inst - (susp-var2-delay $Op - (, $S $N) $L1 $L2) $Csym $Lsym) + (= (asm-pass2-inst (susp-var2-delay $Op (, $S $N) $L1 $L2) $Csym $Lsym) ( (with_self (True *) (asm-lookup-ctab $S $N $Csym $I)) @@ -3204,34 +1558,22 @@ (opcode susp-var2-delay $X) (b-ASPN4-cccc $X $Op $I $Val1) (b-ASPN-c $Val2))) -; - - (= - (asm-pass2-inst $Inst $Csym $Lsym) + (= (asm-pass2-inst $Inst $Csym $Lsym) ( (functor $Inst $F $N) (with_self (opcode $F $X) (b-ASPN-c $X)) (asm-pass2-inst-op $Inst 0 $N))) -; - - (= - (asm-pass2-inst $Inst $Csym $Lsym) + (= (asm-pass2-inst $Inst $Csym $Lsym) (with_self (True *) (cmp-error (:: 'error in asm pass2 :' $Inst 'is not defined')))) -; - - (= - (asm-pass2-inst-op $Inst $N0 $N1) + (= (asm-pass2-inst-op $Inst $N0 $N1) (with_self (=:= $N0 $N1) True)) -; - - (= - (asm-pass2-inst-op $Inst $N0 $Nn) + (= (asm-pass2-inst-op $Inst $N0 $Nn) ( (with_self (True *) (is $N1 @@ -3239,64 +1581,39 @@ (arg $N1 $Inst $Op) (b-ASPN-c $Op) (asm-pass2-inst-op $Inst $N1 $Nn))) -; - - (= - (asm-magic $N) + (= (asm-magic $N) ( (with_self (True *) (asm-putnum 17 1)) (asm-putnum 18 1) (asm-putnum 19 1) (asm-putnum $N 1))) -; - - (= - (asm-index-inst - (pred $_ $_ $_ $_) $Size) + (= (asm-index-inst (pred $_ $_ $_ $_) $Size) (with_self (True *) (= $Size 16))) -; - - (= - (asm-index-inst - (arglabel i $_ $_) $N) + (= (asm-index-inst (arglabel i $_ $_) $N) (with_self (True *) (:= $N 9))) -; - - (= - (asm-index-inst - (arglabel c $_ $_) $N) + (= (asm-index-inst (arglabel c $_ $_) $N) (with_self (True *) (:= $N 9))) -; - - (= - (asm-index-inst - (arglabel s $_ $_) $N) + (= (asm-index-inst (arglabel s $_ $_) $N) (with_self (True *) (:= $N 9))) -; - - (= - (asm-symbol $Tab) + (= (asm-symbol $Tab) (with_self (var $Tab) True)) -; - - (= - (asm-symbol (Cons (sym $Pred $Arity $Val $_) $Symtab)) + (= (asm-symbol (Cons (sym $Pred $Arity $Val $_) $Symtab)) ( (with_self (True *) (b-ASPN-c $Val)) @@ -3305,12 +1622,9 @@ (asm-putnum $L 1) (writename $Pred) (asm-symbol $Symtab))) -; - - (= - (asm-putnum $Num $NBytes) + (= (asm-putnum $Num $NBytes) ( (with_self (> $NBytes 1) (is $Byte @@ -3321,28 +1635,24 @@ (- $NBytes 1)) (asm-putnum $Rest $N) (put $Byte))) -; - - (= - (asm-putnum $Num $NBytes) +; /* putnum(Number, Length) will write Number as a binary number which will be Length bytes long */ +; /* b_ASPN2_cc(X,Y):-b_ASPN_c(X),b_ASPN_c(Y). b_ASPN3_ccc(X,Y,U):-b_ASPN_c(X),b_ASPN_c(Y),b_ASPN_c(U). b_ASPN4_cccc(X,Y,U,V):-b_ASPN_c(X),b_ASPN_c(Y),b_ASPN_c(U),b_ASPN_c(V). */ +; /* aspn(X):- true : write((X,4)),nl. asm_putnum(X,Bytes):- true : write((X,Bytes)),nl. */ +; /* aspn(Num):- true : asm_putnum(Num,4). */ + (= (asm-putnum $Num $NBytes) (with_self (True *) (put $Num))) -; - +; ; Num < 256 : - (= - (asm-mark-eot) + (= (asm-mark-eot) ( (with_self (True *) (opcode endfile $X)) (b-ASPN2-cc $X 0))) -; - - (= - (sym-member1 $Sym $Csym) + (= (sym-member1 $Sym $Csym) ( (with_self (<= (sym $F $N $Val $I) $Sym) @@ -3353,46 +1663,31 @@ (+ $HashVal $N) 255) 1)) (arg $Index $Csym $L) (sym-member1 $F $N $Sym $L))) -; - +; /* local utilities */ - (= - (sym-member1 $F $N $Sym $List) + (= (sym-member1 $F $N $Sym $List) ( (with_self (var $List) (next-sym-no $I)) (arg 4 $Sym $I) (:= $List (Cons $Sym $_)))) -; - - (= - (sym-member1 $F $N $Sym - (Cons - (sym $F $N $Val2 $I) $List)) + (= (sym-member1 $F $N $Sym (Cons (sym $F $N $Val2 $I) $List)) (with_self (True *) (= $Sym (sym $F $N $Val2 $I)))) -; - - (= - (sym-member1 $F $N $Sym - (Cons $X1 $List)) + (= (sym-member1 $F $N $Sym (Cons $X1 $List)) (with_self (True *) (sym-member1 $F $N $Sym $List))) -; - ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (= - (lab-member1 $Lab $Lsym) + (= (lab-member1 $Lab $Lsym) ( (with_self (<= (lab $X $Val) $Lab) @@ -3402,44 +1697,29 @@ (mod $HashVal 255) 1)) (arg $Index $Lsym $L) (lab-member1 $X $Lab $L))) -; - +; ; write(user,Index),nl(user), - (= - (lab-member1 $X $Lab $List) + (= (lab-member1 $X $Lab $List) (with_self (var $List) (:= $List (Cons $Lab $_)))) -; - - (= - (lab-member1 $X $Lab - (Cons - (lab $X $Val2) $List)) + (= (lab-member1 $X $Lab (Cons (lab $X $Val2) $List)) (with_self (True *) (= $Lab (lab $X $Val2)))) -; - - (= - (lab-member1 $X $Lab - (Cons $_ $List)) + (= (lab-member1 $X $Lab (Cons $_ $List)) (with_self (True *) (lab-member1 $X $Lab $List))) -; - ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (= - (asm-lookup-ltab $Lab $Lsym $Val1) + (= (asm-lookup-ltab $Lab $Lsym $Val1) ( (with_self (True *) (asm-hash-value $Lab $HashVal)) @@ -3448,43 +1728,27 @@ (mod $HashVal 255) 1)) (arg $Index $Lsym $L) (asm-lookup-ltab1 $Lab $L $Val1))) -; - - (= - (asm-lookup-ltab1 $Lab $Var $Val1) + (= (asm-lookup-ltab1 $Lab $Var $Val1) (with_self (var $Var) (fail))) -; - - (= - (asm-lookup-ltab1 $Lab - (Cons - (lab $Lab $Val) $_) $Val1) + (= (asm-lookup-ltab1 $Lab (Cons (lab $Lab $Val) $_) $Val1) (with_self (True *) (= $Val1 $Val))) -; - - (= - (asm-lookup-ltab1 $Lab - (Cons $_ $Tab) $Val) + (= (asm-lookup-ltab1 $Lab (Cons $_ $Tab) $Val) (with_self (True *) (asm-lookup-ltab1 $Lab $Tab $Val))) -; - ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (= - (asm-lookup-ctab $F $N $Csym $I) + (= (asm-lookup-ctab $F $N $Csym $I) ( (with_self (True *) (asm-hash-value $F $HashVal)) @@ -3494,41 +1758,25 @@ (+ $HashVal $N) 255) 1)) (arg $Index $Csym $L) (asm-lookup-ctab1 $F $N $L $I))) -; - - (= - (asm-lookup-ctab1 $F $N - (Cons - (sym $F $N $Val $I) $L) $I1) + (= (asm-lookup-ctab1 $F $N (Cons (sym $F $N $Val $I) $L) $I1) (with_self (True *) (= $I1 $I))) -; - - (= - (asm-lookup-ctab1 $F $N - (Cons $_ $L) $I) + (= (asm-lookup-ctab1 $F $N (Cons $_ $L) $I) (with_self (True *) (asm-lookup-ctab1 $F $N $L $I))) -; - ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (asm-rearange-csym $Csym $N $LCsym0 $LCsym) + (= (asm-rearange-csym $Csym $N $LCsym0 $LCsym) (with_self (< $N 1) (= $LCsym $LCsym0))) -; - - (= - (asm-rearange-csym $Csym $N $LCsym0 $LCsym) + (= (asm-rearange-csym $Csym $N $LCsym0 $LCsym) ( (with_self (True *) (arg $N $Csym $L)) @@ -3536,26 +1784,17 @@ (is $N1 (- $N 1)) (asm-rearange-csym $Csym $N1 $LCsym1 $LCsym))) -; - - (= - (asm-merge $L1 $L2 $L3) + (= (asm-merge $L1 $L2 $L3) (with_self (var $L1) (= $L3 $L2))) -; - - (= - (asm-merge $L1 $L2 $L3) + (= (asm-merge $L1 $L2 $L3) (with_self (var $L2) (= $L3 $L1))) -; - - (= - (asm-merge $L1 $L2 $L3) + (= (asm-merge $L1 $L2 $L3) ( (<= (Cons $Sym1 $T1) $L1) (<= @@ -3569,10 +1808,7 @@ (:= $L3 (Cons $Sym1 $L4))) (asm-merge $T1 $L2 $L4))) -; - - (= - (asm-merge $L1 $L2 $L3) + (= (asm-merge $L1 $L2 $L3) ( (<= (Cons $Sym1 $T1) $L1) (with_self @@ -3581,1023 +1817,294 @@ (:= $L3 (Cons $Sym2 $L4))) (asm-merge $L1 $T2 $L4))) -; - ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (next-sym-no $I) + (= (next-sym-no $I) ( (with_self (True *) (global-get %sym-no 0 $I)) (is $I1 (+ $I 1)) (global-set %sym-no 0 $I1))) -; +; /* asm_hash_value(F,N,HashVal):- true : name(F,L), asm_sum_list(L,0,Sum), HashVal is Sum+N. asm_hash_value((F,N,No),HashVal):- true : name(F,L), asm_sum_list(L,0,Sum), HashVal is Sum+N+No. asm_hash_value((F,N),HashVal):- true : name(F,L), asm_sum_list(L,0,Sum), HashVal is Sum+N. asm_sum_list([],Sum0,Sum):- true : Sum=Sum0. asm_sum_list([X|Xs],Sum0,Sum):- true : Sum1 is Sum0+X, asm_sum_list(Xs,Sum1,Sum). */ - - (= - (x-or-y - (vx $X) $Code) + (= (x-or-y (vx $X) $Code) (with_self (True *) (is $Code (<< $X 3)))) -; - - (= - (x-or-y - (x $X) $Code) +; ; xv + (= (x-or-y (x $X) $Code) (with_self (True *) (is $Code (+ (<< $X 3) 1)))) -; - - (= - (x-or-y - (vy $Y) $Code) +; ; ux + (= (x-or-y (vy $Y) $Code) (with_self (True *) (is $Code (\/ (<< $Y 3) 3)))) -; - - (= - (x-or-y - (y $Y) $Code) +; ;vy + (= (x-or-y (y $Y) $Code) (with_self (True *) (is $Code (\/ (<< $Y 3) 7)))) -; - - (= - (x-or-y $Op $Code) + (= (x-or-y $Op $Code) (with_self (True *) (is $Code (\/ (<< $Op 2) 2)))) -; - !(mode (opcode c f)) -; - - - (= - (opcode noop 0) True) -; - - (= - (opcode jmp 1) True) -; - - (= - (opcode djmp 2) True) -; - - (= - (opcode jmpn_eq_struct_x 3) True) -; - - (= - (opcode jmpn_eq_struct_y 4) True) -; - - (= - (opcode jmpn_eq_atom_x 5) True) -; - - (= - (opcode jmpn_eq_atom_y 6) True) -; - - (= - (opcode jmpn_nil_x 7) True) -; - - (= - (opcode jmpn_nil_y 8) True) -; - - (= - (opcode switch_list_x 9) True) -; - - (= - (opcode switch_list_y 10) True) -; - - (= - (opcode switch_list_yxx 11) True) -; - - (= - (opcode switch_list_yxy 12) True) -; - - (= - (opcode switch_list_yyx 13) True) -; - - (= - (opcode switch_list_yyy 14) True) -; - - (= - (opcode jmpn_eq_int_x 15) True) -; - - (= - (opcode jmpn_eq_int_y 16) True) -; - - (= - (opcode jmpn_eql 17) True) -; - - (= - (opcode jmp_eql 18) True) -; - - (= - (opcode jmp_eql_yy 19) True) -; - - (= - (opcode jmpn_gt 20) True) -; - - (= - (opcode jmpn_gt_yy 21) True) -; - - (= - (opcode jmpn_ge 22) True) -; - - (= - (opcode jmpn_ge_yy 23) True) -; - - (= - (opcode jmpn_id 24) True) -; - - (= - (opcode jmp_id 25) True) -; - - (= - (opcode jmpn_var_x 26) True) -; - - (= - (opcode jmpn_var_y 27) True) -; - - (= - (opcode jmp_var_x 28) True) -; - - (= - (opcode jmp_var_y 29) True) -; - - (= - (opcode jmpn_atom_x 30) True) -; - - (= - (opcode jmpn_atom_y 31) True) -; - - (= - (opcode jmpn_atomic_x 32) True) -; - - (= - (opcode jmpn_atomic_y 33) True) -; - - (= - (opcode jmpn_num_x 34) True) -; - - (= - (opcode jmpn_num_y 35) True) -; - - (= - (opcode jmpn_float_x 36) True) -; - - (= - (opcode jmpn_float_y 37) True) -; - - (= - (opcode jmpn_int_x 38) True) -; - - (= - (opcode jmpn_int_y 39) True) -; - - (= - (opcode hash_jmpn_nil 40) True) -; - - (= - (opcode hash_jmpn_list 41) True) -; - - (= - (opcode hash_jmpn_int 42) True) -; - - (= - (opcode hash_jmpn_atom 43) True) -; - - (= - (opcode hash_jmpn_struct 44) True) -; - - (= - (opcode hash_jmpn_struct_x 45) True) -; - - (= - (opcode hash_jmpn_struct_y 46) True) -; - - (= - (opcode hash_jmpn_struct_xx 47) True) -; - - (= - (opcode hash_jmpn_struct_xy 48) True) -; - - (= - (opcode hash_jmpn_struct_yx 49) True) -; - - (= - (opcode hash_jmpn_struct_yy 50) True) -; - - (= - (opcode unify_struct_x 51) True) -; - - (= - (opcode unify_struct_y 52) True) -; - - (= - (opcode unify_list_x 53) True) -; - - (= - (opcode unify_list_y 54) True) -; - - (= - (opcode unify_nil_x 55) True) -; - - (= - (opcode unify_nil_y 56) True) -; - - (= - (opcode unify_atom_x 57) True) -; - - (= - (opcode unify_int_x 58) True) -; - - (= - (opcode unify_atom_y 59) True) -; - - (= - (opcode unify_int_y 60) True) -; - - (= - (opcode unify_ux_ux 61) True) -; - - (= - (opcode unify_ux_uy 62) True) -; - - (= - (opcode unify_uy_uy 63) True) -; - - (= - (opcode unify_cons_x 64) True) -; - - (= - (opcode unify_cons_y 65) True) -; - - (= - (opcode fork_unify_struct_y 66) True) -; - - (= - (opcode fork_unify_list_y 67) True) -; - - (= - (opcode fork_unify_nil_y 68) True) -; - - (= - (opcode fork_unify_atom_y 69) True) -; - - (= - (opcode fork_unify_int_y 70) True) -; - - (= - (opcode fork_unify_uy_uy 71) True) -; - - (= - (opcode fork_unicut_struct_y 72) True) -; - - (= - (opcode fork_unicut_list_y 73) True) -; - - (= - (opcode fork_unicut_nil_y 74) True) -; - (= - (opcode fork_unicut_atom_y 75) True) -; - - (= - (opcode fork_unicut_int_y 76) True) -; - - (= - (opcode fork_unicut_uy_uy 77) True) -; - - (= - (opcode unify0_struct_y 78) True) -; - - (= - (opcode unify0_list_y 79) True) -; - - (= - (opcode unify0_nil_y 80) True) -; - - (= - (opcode unify0_atom_y 81) True) -; - - (= - (opcode unify0_int_y 82) True) -; - - (= - (opcode unify0_uy_uy 83) True) -; - - (= - (opcode unicut_struct_y 84) True) -; - - (= - (opcode unicut_list_y 85) True) -; - - (= - (opcode unicut_nil_y 86) True) -; - - (= - (opcode unicut_atom_y 87) True) -; - - (= - (opcode unicut_int_y 88) True) -; - - (= - (opcode unicut_uy_uy 89) True) -; - - (= - (opcode unicut 90) True) -; - - (= - (opcode unify_arg_nil 91) True) -; - - (= - (opcode unify_arg_atom 92) True) -; - - (= - (opcode unify_arg_int 93) True) -; - - (= - (opcode unify_arg_ux_ux 94) True) -; - - (= - (opcode unify_arg_ux 95) True) -; - - (= - (opcode unify_arg_ux_vx 96) True) -; - - (= - (opcode unify_arg_ux_vy 97) True) -; - - (= - (opcode unify_arg_uy_uy 98) True) -; - - (= - (opcode unify_arg_uy 99) True) -; - - (= - (opcode unify_arg_wy 100) True) -; - - (= - (opcode unify_arg_vx_vx 101) True) -; - - (= - (opcode unify_arg_vx 102) True) -; - - (= - (opcode unify_arg_vy_vy 103) True) -; - - (= - (opcode unify_arg_vy 104) True) -; - - (= - (opcode unify_arg_list 105) True) -; - - (= - (opcode unify_arg_struct 106) True) -; - - (= - (opcode unify_arg_void_one 107) True) -; - - (= - (opcode unify_arg_void 108) True) -; - - (= - (opcode unify_arg_vx_vy 109) True) -; - - (= - (opcode unify_arg_vx_ux 110) True) -; - - (= - (opcode unify_arg_vx_uy 111) True) -; - - (= - (opcode unify_arg_vy_vx 112) True) -; - - (= - (opcode unify_arg_vy_ux 113) True) -; - - (= - (opcode unify_arg_vy_uy 114) True) -; - - (= - (opcode unify_arg_iii 115) True) -; - - (= - (opcode move_struct_x 116) True) -; - - (= - (opcode move_struct_y 117) True) -; - - (= - (opcode move_list_x 118) True) -; - - (= - (opcode move_list_y 119) True) -; - - (= - (opcode move_nil_x 120) True) -; - - (= - (opcode move_nil_y 121) True) -; - - (= - (opcode move_atom_x 122) True) -; - - (= - (opcode move_int_x 123) True) -; - - (= - (opcode move_atom_y 124) True) -; - - (= - (opcode move_int_y 125) True) -; - - (= - (opcode move_x_ux 126) True) -; - - (= - (opcode move_x_uy 127) True) -; - - (= - (opcode move_y_ux 128) True) -; - - (= - (opcode move_yy_yy_yy 129) True) -; - - (= - (opcode move_yy_yy 130) True) -; - - (= - (opcode move_y_uy 131) True) -; - - (= - (opcode move_vx 132) True) -; - - (= - (opcode move_vy 133) True) -; - - (= - (opcode move_x_wy 134) True) -; - - (= - (opcode move_yy_yw 135) True) -; - - (= - (opcode move_y_wy 136) True) -; - - (= - (opcode move_yw_yy 137) True) -; - - (= - (opcode and 138) True) -; - - (= - (opcode or 139) True) -; - - (= - (opcode lshiftl 140) True) -; - - (= - (opcode lshiftr 141) True) -; - - (= - (opcode complement 142) True) -; - - (= - (opcode add 143) True) -; - - (= - (opcode add1_y 144) True) -; - - (= - (opcode sub 145) True) -; - - (= - (opcode sub1_y 146) True) -; - - (= - (opcode mul 147) True) -; - - (= - (opcode div 148) True) -; - - (= - (opcode idiv 149) True) -; - - (= - (opcode mod 150) True) -; - - (= - (opcode para_struct 151) True) -; - - (= - (opcode para_list 152) True) -; - - (= - (opcode para_nil 153) True) -; - - (= - (opcode para_atom 154) True) -; - - (= - (opcode para_int 155) True) -; - - (= - (opcode para_ux_ux_ux 156) True) -; - - (= - (opcode para_ux_ux 157) True) -; - - (= - (opcode para_ux 158) True) -; - - (= - (opcode para_uy_uy_uy_uy 159) True) -; - - (= - (opcode para_uy_uy_uy 160) True) -; - - (= - (opcode para_uy_uy 161) True) -; - - (= - (opcode para_uy 162) True) -; - - (= - (opcode para_vx 163) True) -; - - (= - (opcode para_vy_vy 164) True) -; - - (= - (opcode para_vy 165) True) -; - - (= - (opcode para_void_one 166) True) -; - - (= - (opcode para_void 167) True) -; - - (= - (opcode para_vy_ux 168) True) -; - - (= - (opcode para_vy_uy 169) True) -; - - (= - (opcode para_ux_vy 170) True) -; - - (= - (opcode para_ux_ux_uy 171) True) -; - - (= - (opcode para_ux_uy 172) True) -; - - (= - (opcode para_ux_uy_uy 173) True) -; - - (= - (opcode para_uy_vy 174) True) -; - - (= - (opcode para_ux_uy_ux 175) True) -; - - (= - (opcode para_uy_ux 176) True) -; - - (= - (opcode para_uy_ux_ux 177) True) -; - - (= - (opcode para_uy_ux_uy 178) True) -; - - (= - (opcode para_uy_uy_ux 179) True) -; - - (= - (opcode call 180) True) -; - - (= - (opcode call_d 181) True) -; - - (= - (opcode callv 182) True) -; - - (= - (opcode execute 183) True) -; - - (= - (opcode executev 184) True) -; - - (= - (opcode return_a 185) True) -; - - (= - (opcode return_b 186) True) -; - - (= - (opcode jmpn_det 187) True) -; - - (= - (opcode save_ht_jmp 188) True) -; - - (= - (opcode allocate_flat 189) True) -; - - (= - (opcode allocate_nonflat 190) True) -; - - (= - (opcode allocate_nondet 191) True) -; - - (= - (opcode fail 192) True) -; - - (= - (opcode fail0 193) True) -; - - (= - (opcode fork 194) True) -; - - (= - (opcode commit 195) True) -; - - (= - (opcode cut 196) True) -; - - (= - (opcode cut_fail 197) True) -; - - (= - (opcode cut_return 198) True) -; - - (= - (opcode save_b 199) True) -; - - (= - (opcode getbreg 200) True) -; - - (= - (opcode putbreg 201) True) -; - - (= - (opcode getpbreg 202) True) -; - - (= - (opcode hash_x 203) True) -; - - (= - (opcode hash_y 204) True) -; - - (= - (opcode arg 205) True) -; - - (= - (opcode arg0 206) True) -; - - (= - (opcode setarg 207) True) -; - - (= - (opcode setarg0 208) True) -; - - (= - (opcode functor 209) True) -; - - (= - (opcode func_arity 210) True) -; - - (= - (opcode get_ar_cps 211) True) -; - - (= - (opcode put_ar_cps 212) True) -; - - (= - (opcode move_ar_cps 213) True) -; - - (= - (opcode jmpn_det_get_ar_cps 214) True) -; - - (= - (opcode builtin0 215) True) -; - - (= - (opcode builtin1 216) True) -; - - (= - (opcode builtin2 217) True) -; - - (= - (opcode builtin3 218) True) -; - - (= - (opcode builtin4 219) True) -; - - (= - (opcode allocate_susp 220) True) -; - - (= - (opcode susp_var_x 221) True) -; - - (= - (opcode susp_var_y 222) True) -; - - (= - (opcode delay 223) True) -; - - (= - (opcode susp_var_delay 224) True) -; - - (= - (opcode end_delay 225) True) -; - - (= - (opcode nondet 226) True) -; - - (= - (opcode jmp_susp 227) True) -; - - (= - (opcode jmpn_dvar_y 228) True) -; - - (= - (opcode susp_var2_delay 229) True) -; - - (= - (opcode domain_set_false_yy 230) True) -; - - (= - (opcode domain_set_false_yx 231) True) -; - - (= - (opcode halt 232) True) -; - - (= - (opcode endfile 233) True) -; - - (= - (opcode tabsize 234) True) -; - - - - (= - (output-mess $Mess) + (= (opcode noop 0) True) + (= (opcode jmp 1) True) + (= (opcode djmp 2) True) + (= (opcode jmpn_eq_struct_x 3) True) + (= (opcode jmpn_eq_struct_y 4) True) + (= (opcode jmpn_eq_atom_x 5) True) + (= (opcode jmpn_eq_atom_y 6) True) + (= (opcode jmpn_nil_x 7) True) + (= (opcode jmpn_nil_y 8) True) + (= (opcode switch_list_x 9) True) + (= (opcode switch_list_y 10) True) + (= (opcode switch_list_yxx 11) True) + (= (opcode switch_list_yxy 12) True) + (= (opcode switch_list_yyx 13) True) + (= (opcode switch_list_yyy 14) True) + (= (opcode jmpn_eq_int_x 15) True) + (= (opcode jmpn_eq_int_y 16) True) + (= (opcode jmpn_eql 17) True) + (= (opcode jmp_eql 18) True) + (= (opcode jmp_eql_yy 19) True) + (= (opcode jmpn_gt 20) True) + (= (opcode jmpn_gt_yy 21) True) + (= (opcode jmpn_ge 22) True) + (= (opcode jmpn_ge_yy 23) True) + (= (opcode jmpn_id 24) True) + (= (opcode jmp_id 25) True) + (= (opcode jmpn_var_x 26) True) + (= (opcode jmpn_var_y 27) True) + (= (opcode jmp_var_x 28) True) + (= (opcode jmp_var_y 29) True) + (= (opcode jmpn_atom_x 30) True) + (= (opcode jmpn_atom_y 31) True) + (= (opcode jmpn_atomic_x 32) True) + (= (opcode jmpn_atomic_y 33) True) + (= (opcode jmpn_num_x 34) True) + (= (opcode jmpn_num_y 35) True) + (= (opcode jmpn_float_x 36) True) + (= (opcode jmpn_float_y 37) True) + (= (opcode jmpn_int_x 38) True) + (= (opcode jmpn_int_y 39) True) + (= (opcode hash_jmpn_nil 40) True) + (= (opcode hash_jmpn_list 41) True) + (= (opcode hash_jmpn_int 42) True) + (= (opcode hash_jmpn_atom 43) True) + (= (opcode hash_jmpn_struct 44) True) + (= (opcode hash_jmpn_struct_x 45) True) + (= (opcode hash_jmpn_struct_y 46) True) + (= (opcode hash_jmpn_struct_xx 47) True) + (= (opcode hash_jmpn_struct_xy 48) True) + (= (opcode hash_jmpn_struct_yx 49) True) + (= (opcode hash_jmpn_struct_yy 50) True) + (= (opcode unify_struct_x 51) True) + (= (opcode unify_struct_y 52) True) + (= (opcode unify_list_x 53) True) + (= (opcode unify_list_y 54) True) + (= (opcode unify_nil_x 55) True) + (= (opcode unify_nil_y 56) True) + (= (opcode unify_atom_x 57) True) + (= (opcode unify_int_x 58) True) + (= (opcode unify_atom_y 59) True) + (= (opcode unify_int_y 60) True) + (= (opcode unify_ux_ux 61) True) + (= (opcode unify_ux_uy 62) True) + (= (opcode unify_uy_uy 63) True) + (= (opcode unify_cons_x 64) True) + (= (opcode unify_cons_y 65) True) + (= (opcode fork_unify_struct_y 66) True) + (= (opcode fork_unify_list_y 67) True) + (= (opcode fork_unify_nil_y 68) True) + (= (opcode fork_unify_atom_y 69) True) + (= (opcode fork_unify_int_y 70) True) + (= (opcode fork_unify_uy_uy 71) True) + (= (opcode fork_unicut_struct_y 72) True) + (= (opcode fork_unicut_list_y 73) True) + (= (opcode fork_unicut_nil_y 74) True) + (= (opcode fork_unicut_atom_y 75) True) + (= (opcode fork_unicut_int_y 76) True) + (= (opcode fork_unicut_uy_uy 77) True) + (= (opcode unify0_struct_y 78) True) + (= (opcode unify0_list_y 79) True) + (= (opcode unify0_nil_y 80) True) + (= (opcode unify0_atom_y 81) True) + (= (opcode unify0_int_y 82) True) + (= (opcode unify0_uy_uy 83) True) + (= (opcode unicut_struct_y 84) True) + (= (opcode unicut_list_y 85) True) + (= (opcode unicut_nil_y 86) True) + (= (opcode unicut_atom_y 87) True) + (= (opcode unicut_int_y 88) True) + (= (opcode unicut_uy_uy 89) True) + (= (opcode unicut 90) True) + (= (opcode unify_arg_nil 91) True) + (= (opcode unify_arg_atom 92) True) + (= (opcode unify_arg_int 93) True) + (= (opcode unify_arg_ux_ux 94) True) + (= (opcode unify_arg_ux 95) True) + (= (opcode unify_arg_ux_vx 96) True) + (= (opcode unify_arg_ux_vy 97) True) + (= (opcode unify_arg_uy_uy 98) True) + (= (opcode unify_arg_uy 99) True) + (= (opcode unify_arg_wy 100) True) + (= (opcode unify_arg_vx_vx 101) True) + (= (opcode unify_arg_vx 102) True) + (= (opcode unify_arg_vy_vy 103) True) + (= (opcode unify_arg_vy 104) True) + (= (opcode unify_arg_list 105) True) + (= (opcode unify_arg_struct 106) True) + (= (opcode unify_arg_void_one 107) True) + (= (opcode unify_arg_void 108) True) + (= (opcode unify_arg_vx_vy 109) True) + (= (opcode unify_arg_vx_ux 110) True) + (= (opcode unify_arg_vx_uy 111) True) + (= (opcode unify_arg_vy_vx 112) True) + (= (opcode unify_arg_vy_ux 113) True) + (= (opcode unify_arg_vy_uy 114) True) + (= (opcode unify_arg_iii 115) True) + (= (opcode move_struct_x 116) True) + (= (opcode move_struct_y 117) True) + (= (opcode move_list_x 118) True) + (= (opcode move_list_y 119) True) + (= (opcode move_nil_x 120) True) + (= (opcode move_nil_y 121) True) + (= (opcode move_atom_x 122) True) + (= (opcode move_int_x 123) True) + (= (opcode move_atom_y 124) True) + (= (opcode move_int_y 125) True) + (= (opcode move_x_ux 126) True) + (= (opcode move_x_uy 127) True) + (= (opcode move_y_ux 128) True) + (= (opcode move_yy_yy_yy 129) True) + (= (opcode move_yy_yy 130) True) + (= (opcode move_y_uy 131) True) + (= (opcode move_vx 132) True) + (= (opcode move_vy 133) True) + (= (opcode move_x_wy 134) True) + (= (opcode move_yy_yw 135) True) + (= (opcode move_y_wy 136) True) + (= (opcode move_yw_yy 137) True) + (= (opcode and 138) True) + (= (opcode or 139) True) + (= (opcode lshiftl 140) True) + (= (opcode lshiftr 141) True) + (= (opcode complement 142) True) + (= (opcode add 143) True) + (= (opcode add1_y 144) True) + (= (opcode sub 145) True) + (= (opcode sub1_y 146) True) + (= (opcode mul 147) True) + (= (opcode div 148) True) + (= (opcode idiv 149) True) + (= (opcode mod 150) True) + (= (opcode para_struct 151) True) + (= (opcode para_list 152) True) + (= (opcode para_nil 153) True) + (= (opcode para_atom 154) True) + (= (opcode para_int 155) True) + (= (opcode para_ux_ux_ux 156) True) + (= (opcode para_ux_ux 157) True) + (= (opcode para_ux 158) True) + (= (opcode para_uy_uy_uy_uy 159) True) + (= (opcode para_uy_uy_uy 160) True) + (= (opcode para_uy_uy 161) True) + (= (opcode para_uy 162) True) + (= (opcode para_vx 163) True) + (= (opcode para_vy_vy 164) True) + (= (opcode para_vy 165) True) + (= (opcode para_void_one 166) True) + (= (opcode para_void 167) True) + (= (opcode para_vy_ux 168) True) + (= (opcode para_vy_uy 169) True) + (= (opcode para_ux_vy 170) True) + (= (opcode para_ux_ux_uy 171) True) + (= (opcode para_ux_uy 172) True) + (= (opcode para_ux_uy_uy 173) True) + (= (opcode para_uy_vy 174) True) + (= (opcode para_ux_uy_ux 175) True) + (= (opcode para_uy_ux 176) True) + (= (opcode para_uy_ux_ux 177) True) + (= (opcode para_uy_ux_uy 178) True) + (= (opcode para_uy_uy_ux 179) True) + (= (opcode call 180) True) + (= (opcode call_d 181) True) + (= (opcode callv 182) True) + (= (opcode execute 183) True) + (= (opcode executev 184) True) + (= (opcode return_a 185) True) + (= (opcode return_b 186) True) + (= (opcode jmpn_det 187) True) + (= (opcode save_ht_jmp 188) True) + (= (opcode allocate_flat 189) True) + (= (opcode allocate_nonflat 190) True) + (= (opcode allocate_nondet 191) True) + (= (opcode fail 192) True) + (= (opcode fail0 193) True) + (= (opcode fork 194) True) + (= (opcode commit 195) True) + (= (opcode cut 196) True) + (= (opcode cut_fail 197) True) + (= (opcode cut_return 198) True) + (= (opcode save_b 199) True) + (= (opcode getbreg 200) True) + (= (opcode putbreg 201) True) + (= (opcode getpbreg 202) True) + (= (opcode hash_x 203) True) + (= (opcode hash_y 204) True) + (= (opcode arg 205) True) + (= (opcode arg0 206) True) + (= (opcode setarg 207) True) + (= (opcode setarg0 208) True) + (= (opcode functor 209) True) + (= (opcode func_arity 210) True) + (= (opcode get_ar_cps 211) True) + (= (opcode put_ar_cps 212) True) + (= (opcode move_ar_cps 213) True) + (= (opcode jmpn_det_get_ar_cps 214) True) + (= (opcode builtin0 215) True) + (= (opcode builtin1 216) True) + (= (opcode builtin2 217) True) + (= (opcode builtin3 218) True) + (= (opcode builtin4 219) True) + (= (opcode allocate_susp 220) True) + (= (opcode susp_var_x 221) True) + (= (opcode susp_var_y 222) True) + (= (opcode delay 223) True) + (= (opcode susp_var_delay 224) True) + (= (opcode end_delay 225) True) + (= (opcode nondet 226) True) + (= (opcode jmp_susp 227) True) + (= (opcode jmpn_dvar_y 228) True) + (= (opcode susp_var2_delay 229) True) + (= (opcode domain_set_false_yy 230) True) + (= (opcode domain_set_false_yx 231) True) + (= (opcode halt 232) True) + (= (opcode endfile 233) True) + (= (opcode tabsize 234) True) + + + (= (output-mess $Mess) ( (with_self (True *) (telling $X)) @@ -4605,19 +2112,15 @@ (write $Mess) (nl) (tell $X))) -; +; /* opcode(X,N):- true : cmp_error(['no this instruction : ',X]). */ - - (= - (is-unify-arg-inst $Inst) + (= (is-unify-arg-inst $Inst) ( (with_self (True *) (functor $Inst $F $N)) (opcode $F $Code) (>= $Code 91) (=< $Code 115))) -; - diff --git a/sxx_machine/bench/boyer.metta b/sxx_machine/bench/boyer.metta index e18ce3b..c737388 100644 --- a/sxx_machine/bench/boyer.metta +++ b/sxx_machine/bench/boyer.metta @@ -1,1190 +1,347 @@ +; (convert_to_metta_file boyer $_256844 sxx_machine/bench/boyer.pl sxx_machine/bench/boyer.metta) ; -; - +; generated: 20 November 1989 ; -; - +; option(s): ; ; - ; -; - +; boyer ; ; - ; -; - +; Evan Tick (from Lisp version by R. P. Gabriel) ; ; - ; -; - +; November 1985 ; ; - ; -; - - - - (= - (go) - ( (statistics runtime - (:: $_ $_)) - (wff $Wff) - (rewrite $Wff $NewWff) - (tautology $NewWff Nil Nil) - (statistics runtime - (:: $_ $T)) - (write 'execution time is ') - (write $T) - (write ' milliseconds'))) -; - - - - (= - (top) - ( (wff $Wff) - (rewrite $Wff $NewWff) - (tautology $NewWff Nil Nil))) -; - - - - (= - (wff (implies (and (implies $X $Y) (and (implies $Y $Z) (and (implies $Z $U) (implies $U $W)))) (implies $X $W))) - ( (= $X - (f (myplus (myplus a b) (myplus c zero)))) - (= $Y - (f (times (times a b) (myplus c d)))) - (= $Z - (f (reverse (append (append a b) Nil)))) - (= $U - (equal - (myplus a b) - (boyer-difference x y))) - (= $W - (lessp - (remainder a b) - (boyer-member a - (length b)))))) -; - - - - (= - (tautology $Wff) - ( (rewrite $Wff $NewWff) (tautology $NewWff Nil Nil))) -; - - - (= - (tautology $Wff $Tlist $Flist) - ( (det-if-then-else - (truep $Wff $Tlist) True - (det-if-then-else - (falsep $Wff $Flist) fail - (det-if-then - (= $Wff - (if $If $Then $Else)) +; prove arithmetic theorem + + + (= (go) + (statistics runtime + (:: $_ $_)) + (wff $Wff) + (rewrite $Wff $NewWff) + (tautology $NewWff Nil Nil) + (statistics runtime + (:: $_ $T)) + (write 'execution time is ') + (write $T) + (write ' milliseconds')) + + + (= (top) + (wff $Wff) + (rewrite $Wff $NewWff) + (tautology $NewWff Nil Nil)) + + + (= (wff (implies (and (implies $X $Y) (and (implies $Y $Z) (and (implies $Z $U) (implies $U $W)))) (implies $X $W))) + (= $X + (f (myplus (myplus a b) (myplus c zero)))) + (= $Y + (f (times (times a b) (myplus c d)))) + (= $Z + (f (reverse (append (append a b) Nil)))) + (= $U + (equal + (myplus a b) + (boyer-difference x y))) + (= $W + (lessp + (remainder a b) + (boyer-member a + (length b))))) + + + (= (tautology $Wff) + (rewrite $Wff $NewWff) + (tautology $NewWff Nil Nil)) +; ; write('rewriting...'),nl, +; ; write('proving...'),nl, + + (= (tautology $Wff $Tlist $Flist) + (det-if-then-else + (truep $Wff $Tlist) True + (det-if-then-else + (falsep $Wff $Flist) fail + (det-if-then + (= $Wff + (if $If $Then $Else)) + (det-if-then-else + (truep $If $Tlist) + (tautology $Then $Tlist $Flist) (det-if-then-else - (truep $If $Tlist) - (tautology $Then $Tlist $Flist) - (det-if-then-else - (falsep $If $Flist) - (tautology $Else $Tlist $Flist) - (, - (tautology $Then - (Cons $If $Tlist) $Flist) - (tautology $Else $Tlist - (Cons $If $Flist)))))))) (set-det))) -; - - - - - (= - (rewrite $Atom $Atom) - ( (atomic $Atom) (set-det))) -; - - (= - (rewrite $Old $New) - ( (functor $Old $F $N) - (functor $Mid $F $N) - (rewrite-args $N $Old $Mid) - (or - (, - (equal $Mid $Next) - (rewrite $Next $New)) - (= $New $Mid)) - (set-det))) -; + (falsep $If $Flist) + (tautology $Else $Tlist $Flist) + (, + (tautology $Then + (Cons $If $Tlist) $Flist) + (tautology $Else $Tlist + (Cons $If $Flist)))))))) + (set-det)) +; ; both must hold - (= - (rewrite-args 0 $_ $_) + (= (rewrite $Atom $Atom) + (atomic $Atom) (set-det)) -; + (= (rewrite $Old $New) + (functor $Old $F $N) + (functor $Mid $F $N) + (rewrite-args $N $Old $Mid) + (or + (, + (equal $Mid $Next) + (rewrite $Next $New)) + (= $New $Mid)) + (set-det)) +; ; should be ->, but is compiler smart +; ; enough to generate cut for -> ? - (= - (rewrite-args $N $Old $Mid) - ( (arg $N $Old $OldArg) - (arg $N $Mid $MidArg) - (rewrite $OldArg $MidArg) - (is $N1 - (- $N 1)) - (rewrite-args $N1 $Old $Mid))) -; + (= (rewrite-args 0 $_ $_) + (set-det)) + (= (rewrite-args $N $Old $Mid) + (arg $N $Old $OldArg) + (arg $N $Mid $MidArg) + (rewrite $OldArg $MidArg) + (is $N1 + (- $N 1)) + (rewrite-args $N1 $Old $Mid)) - (= - (truep t $_) + (= (truep t $_) (set-det)) -; - - (= - (truep $Wff $Tlist) + (= (truep $Wff $Tlist) (boyer-member $Wff $Tlist)) -; - - (= - (falsep f $_) + (= (falsep f $_) (set-det)) -; - - (= - (falsep $Wff $Flist) + (= (falsep $Wff $Flist) (boyer-member $Wff $Flist)) -; - - (= - (boyer-member $X - (Cons $X $_)) + (= (boyer-member $X (Cons $X $_)) (set-det)) -; - - (= - (boyer-member $X - (Cons $_ $T)) + (= (boyer-member $X (Cons $_ $T)) (boyer-member $X $T)) -; - - - - - (= - (equal - (and $P $Q) - (if $P - (if $Q t f) f)) True) -; - (= - (equal - (append - (append $X $Y) $Z) - (append $X - (append $Y $Z))) True) -; - (= - (equal - (assignment $X - (append $A $B)) - (if - (assignedp $X $A) - (assignment $X $A) - (assignment $X $B))) True) -; - - (= - (equal - (assume_false $Var $Alist) - (cons - (cons $Var f) $Alist)) True) -; - (= - (equal - (assume_true $Var $Alist) - (cons - (cons $Var t) $Alist)) True) -; - - (= - (equal - (boolean $X) - (or - (equal $X t) - (equal $X f))) True) -; - - (= - (equal - (car - (gopher $X)) - (if - (listp $X) - (car - (flatten $X)) zero)) True) -; - - (= - (equal - (compile $Form) - (reverse - (codegen - (optimize $Form) ()))) True) -; - - (= - (equal - (count_list $Z - (sort_lp $X $Y)) - (myplus - (count_list $Z $X) - (count_list $Z $Y))) True) -; - - (= - (equal - (countps_ $L $Pred) - (countps_loop $L $Pred zero)) True) -; - - (= - (equal - (boyer-difference $A $B) $C) + (= (equal (and $P $Q) (if $P (if $Q t f) f)) True) + (= (equal (append (append $X $Y) $Z) (append $X (append $Y $Z))) True) + (= (equal (assignment $X (append $A $B)) (if (assignedp $X $A) (assignment $X $A) (assignment $X $B))) True) + (= (equal (assume_false $Var $Alist) (cons (cons $Var f) $Alist)) True) + (= (equal (assume_true $Var $Alist) (cons (cons $Var t) $Alist)) True) + (= (equal (boolean $X) (or (equal $X t) (equal $X f))) True) + (= (equal (car (gopher $X)) (if (listp $X) (car (flatten $X)) zero)) True) + (= (equal (compile $Form) (reverse (codegen (optimize $Form) ()))) True) + (= (equal (count_list $Z (sort_lp $X $Y)) (myplus (count_list $Z $X) (count_list $Z $Y))) True) + (= (equal (countps_ $L $Pred) (countps_loop $L $Pred zero)) True) + (= (equal (boyer-difference $A $B) $C) (boyer-difference $A $B $C)) -; - - (= - (equal - (divides $X $Y) - (zerop - (remainder $Y $X))) True) -; - - (= - (equal - (dsort $X) - (sort2 $X)) True) -; - - (= - (equal - (eqp $X $Y) - (equal - (fix $X) - (fix $Y))) True) -; - - (= - (equal - (equal $A $B) $C) + (= (equal (divides $X $Y) (zerop (remainder $Y $X))) True) + (= (equal (dsort $X) (sort2 $X)) True) + (= (equal (eqp $X $Y) (equal (fix $X) (fix $Y))) True) + (= (equal (equal $A $B) $C) (eq $A $B $C)) -; - - (= - (equal - (even1 $X) - (if - (zerop $X) t - (odd - (decr $X)))) True) -; - - (= - (equal - (exec - (append $X $Y) $Pds $Envrn) - (exec $Y - (exec $X $Pds $Envrn) $Envrn)) True) -; - - (= - (equal - (exp $A $B) $C) + (= (equal (even1 $X) (if (zerop $X) t (odd (decr $X)))) True) + (= (equal (exec (append $X $Y) $Pds $Envrn) (exec $Y (exec $X $Pds $Envrn) $Envrn)) True) + (= (equal (exp $A $B) $C) (exp $A $B $C)) -; - - (= - (equal - (fact_ $I) - (fact_loop $I 1)) True) -; - - (= - (equal - (falsify $X) - (falsify1 - (normalize $X) ())) True) -; - - (= - (equal - (fix $X) - (if - (numberp $X) $X zero)) True) -; - - (= - (equal - (flatten - (cdr - (gopher $X))) - (if - (listp $X) - (cdr - (flatten $X)) - (cons zero ()))) True) -; - - (= - (equal - (gcd $A $B) $C) + (= (equal (fact_ $I) (fact_loop $I 1)) True) + (= (equal (falsify $X) (falsify1 (normalize $X) ())) True) + (= (equal (fix $X) (if (numberp $X) $X zero)) True) + (= (equal (flatten (cdr (gopher $X))) (if (listp $X) (cdr (flatten $X)) (cons zero ()))) True) + (= (equal (gcd $A $B) $C) (gcd $A $B $C)) -; - - (= - (equal - (get $J - (set $I $Val $Mem)) - (if - (eqp $J $I) $Val - (get $J $Mem))) True) -; - - (= - (equal - (greatereqp $X $Y) - (not - (lessp $X $Y))) True) -; - - (= - (equal - (greatereqpr $X $Y) - (not - (lessp $X $Y))) True) -; - - (= - (equal - (greaterp $X $Y) - (lessp $Y $X)) True) -; - - (= - (equal - (if - (if $A $B $C) $D $E) - (if $A - (if $B $D $E) - (if $C $D $E))) True) -; - - (= - (equal - (iff $X $Y) - (and - (implies $X $Y) - (implies $Y $X))) True) -; - - (= - (equal - (implies $P $Q) - (if $P - (if $Q t f) t)) True) -; - - (= - (equal - (last - (append $A $B)) - (if - (listp $B) - (last $B) - (if - (listp $A) - (cons - (car - (last $A))) $B))) True) -; - - (= - (equal - (length $A) $B) + (= (equal (get $J (set $I $Val $Mem)) (if (eqp $J $I) $Val (get $J $Mem))) True) + (= (equal (greatereqp $X $Y) (not (lessp $X $Y))) True) + (= (equal (greatereqpr $X $Y) (not (lessp $X $Y))) True) + (= (equal (greaterp $X $Y) (lessp $Y $X)) True) + (= (equal (if (if $A $B $C) $D $E) (if $A (if $B $D $E) (if $C $D $E))) True) + (= (equal (iff $X $Y) (and (implies $X $Y) (implies $Y $X))) True) + (= (equal (implies $P $Q) (if $P (if $Q t f) t)) True) + (= (equal (last (append $A $B)) (if (listp $B) (last $B) (if (listp $A) (cons (car (last $A))) $B))) True) + (= (equal (length $A) $B) (mylength $A $B)) -; - - (= - (equal - (lesseqp $X $Y) - (not - (lessp $Y $X))) True) -; - - (= - (equal - (lessp $A $B) $C) + (= (equal (lesseqp $X $Y) (not (lessp $Y $X))) True) + (= (equal (lessp $A $B) $C) (lessp $A $B $C)) -; - - (= - (equal - (listp - (gopher $X)) - (listp $X)) True) -; - - (= - (equal - (mc_flatten $X $Y) - (append - (flatten $X) $Y)) True) -; - - (= - (equal - (meaning $A $B) $C) + (= (equal (listp (gopher $X)) (listp $X)) True) + (= (equal (mc_flatten $X $Y) (append (flatten $X) $Y)) True) + (= (equal (meaning $A $B) $C) (meaning $A $B $C)) -; - - (= - (equal - (boyer-member $A $B) $C) + (= (equal (boyer-member $A $B) $C) (myboyer-member $A $B $C)) -; - - (= - (equal - (not $P) - (if $P f t)) True) -; - - (= - (equal - (nth $A $B) $C) + (= (equal (not $P) (if $P f t)) True) + (= (equal (nth $A $B) $C) (nth $A $B $C)) -; - - (= - (equal - (numberp - (greatest_factor $X $Y)) - (not - (and - (or - (zerop $Y) - (equal $Y 1)) - (not - (numberp $X))))) True) -; - - (= - (equal - (or $P $Q) - (if $P t - (if $Q t f) f)) True) -; - - (= - (equal - (myplus $A $B) $C) + (= (equal (numberp (greatest_factor $X $Y)) (not (and (or (zerop $Y) (equal $Y 1)) (not (numberp $X))))) True) + (= (equal (or $P $Q) (if $P t (if $Q t f) f)) True) + (= (equal (myplus $A $B) $C) (myplus $A $B $C)) -; - - (= - (equal - (power-eval $A $B) $C) + (= (equal (power-eval $A $B) $C) (power-eval $A $B $C)) -; - - (= - (equal - (prime $X) - (and - (not - (zerop $X)) - (and - (not - (equal $X - (add1 zero))) - (prime1 $X - (decr $X))))) True) -; - - (= - (equal - (prime_list - (append $X $Y)) - (and - (prime_list $X) - (prime_list $Y))) True) -; - - (= - (equal - (quotient $A $B) $C) + (= (equal (prime $X) (and (not (zerop $X)) (and (not (equal $X (add1 zero))) (prime1 $X (decr $X))))) True) + (= (equal (prime_list (append $X $Y)) (and (prime_list $X) (prime_list $Y))) True) + (= (equal (quotient $A $B) $C) (quotient $A $B $C)) -; - - (= - (equal - (remainder $A $B) $C) + (= (equal (remainder $A $B) $C) (remainder $A $B $C)) -; - - (= - (equal - (reverse_ $X) - (reverse_loop $X ())) True) -; - - (= - (equal - (reverse - (append $A $B)) - (append - (reverse $B) - (reverse $A))) True) -; - - (= - (equal - (reverse-loop $A $B) $C) + (= (equal (reverse_ $X) (reverse_loop $X ())) True) + (= (equal (reverse (append $A $B)) (append (reverse $B) (reverse $A))) True) + (= (equal (reverse-loop $A $B) $C) (reverse-loop $A $B $C)) -; - - (= - (equal - (samefringe $X $Y) - (equal - (flatten $X) - (flatten $Y))) True) -; - - (= - (equal - (sigma zero $I) - (quotient - (times $I - (add1 $I)) 2)) True) -; - - (= - (equal - (sort2 - (delete $X $L)) - (delete $X - (sort2 $L))) True) -; - - (= - (equal - (tautology_checker $X) - (tautologyp - (normalize $X) ())) True) -; - - (= - (equal - (times $A $B) $C) + (= (equal (samefringe $X $Y) (equal (flatten $X) (flatten $Y))) True) + (= (equal (sigma zero $I) (quotient (times $I (add1 $I)) 2)) True) + (= (equal (sort2 (delete $X $L)) (delete $X (sort2 $L))) True) + (= (equal (tautology_checker $X) (tautologyp (normalize $X) ())) True) + (= (equal (times $A $B) $C) (times $A $B $C)) -; + (= (equal (times_list (append $X $Y)) (times (times_list $X) (times_list $Y))) True) + (= (equal (value (normalize $X) $A) (value $X $A)) True) + (= (equal (zerop $X) (or (equal $X zero) (not (numberp $X)))) True) - (= - (equal - (times_list - (append $X $Y)) - (times - (times_list $X) - (times_list $Y))) True) -; - - (= - (equal - (value - (normalize $X) $A) - (value $X $A)) True) -; - - (= - (equal - (zerop $X) - (or - (equal $X zero) - (not - (numberp $X)))) True) -; - - - (= - (boyer-difference $X $X zero) + (= (boyer-difference $X $X zero) (set-det)) -; - - (= - (boyer-difference - (myplus $X $Y) $X - (fix $Y)) + (= (boyer-difference (myplus $X $Y) $X (fix $Y)) (set-det)) -; - - (= - (boyer-difference - (myplus $Y $X) $X - (fix $Y)) + (= (boyer-difference (myplus $Y $X) $X (fix $Y)) (set-det)) -; - - (= - (boyer-difference - (myplus $X $Y) - (myplus $X $Z) - (boyer-difference $Y $Z)) + (= (boyer-difference (myplus $X $Y) (myplus $X $Z) (boyer-difference $Y $Z)) (set-det)) -; - - (= - (boyer-difference - (myplus $B - (myplus $A $C)) $A - (myplus $B $C)) + (= (boyer-difference (myplus $B (myplus $A $C)) $A (myplus $B $C)) (set-det)) -; - - (= - (boyer-difference - (add1 (myplus $Y $Z)) $Z - (add1 $Y)) + (= (boyer-difference (add1 (myplus $Y $Z)) $Z (add1 $Y)) (set-det)) -; - - (= - (boyer_difference - (add1 - (add1 $X)) 2 - (fix $X)) True) -; - + (= (boyer_difference (add1 (add1 $X)) 2 (fix $X)) True) - (= - (eq - (myplus $A $B) zero - (and - (zerop $A) - (zerop $B))) + (= (eq (myplus $A $B) zero (and (zerop $A) (zerop $B))) (set-det)) -; - - (= - (eq - (myplus $A $B) - (myplus $A $C) - (equal - (fix $B) - (fix $C))) + (= (eq (myplus $A $B) (myplus $A $C) (equal (fix $B) (fix $C))) (set-det)) -; - - (= - (eq zero - (boyer-difference $X $Y) - (not (lessp $Y $X))) + (= (eq zero (boyer-difference $X $Y) (not (lessp $Y $X))) (set-det)) -; - - (= - (eq $X - (boyer-difference $X $Y) - (and - (numberp $X) - (and (or (equal $X zero) (zerop $Y))))) + (= (eq $X (boyer-difference $X $Y) (and (numberp $X) (and (or (equal $X zero) (zerop $Y))))) (set-det)) -; - - (= - (eq - (times $X $Y) zero - (or - (zerop $X) - (zerop $Y))) + (= (eq (times $X $Y) zero (or (zerop $X) (zerop $Y))) (set-det)) -; - - (= - (eq - (append $A $B) - (append $A $C) - (equal $B $C)) + (= (eq (append $A $B) (append $A $C) (equal $B $C)) (set-det)) -; - - (= - (eq - (flatten $X) - (cons $Y Nil) - (and - (nlistp $X) - (equal $X $Y))) + (= (eq (flatten $X) (cons $Y Nil) (and (nlistp $X) (equal $X $Y))) (set-det)) -; - - (= - (eq - (greatest-factor $X $Y) zero - (and - (or - (zerop $Y) - (equal $Y 1)) - (equal $X zero))) + (= (eq (greatest-factor $X $Y) zero (and (or (zerop $Y) (equal $Y 1)) (equal $X zero))) (set-det)) -; - - (= - (eq - (greatest-factor $X $_) 1 - (equal $X 1)) + (= (eq (greatest-factor $X $_) 1 (equal $X 1)) (set-det)) -; - - (= - (eq $Z - (times $W $Z) - (and - (numberp $Z) - (or - (equal $Z zero) - (equal $W 1)))) + (= (eq $Z (times $W $Z) (and (numberp $Z) (or (equal $Z zero) (equal $W 1)))) (set-det)) -; - - (= - (eq $X - (times $X $Y) - (or - (equal $X zero) - (and - (numberp $X) - (equal $Y 1)))) + (= (eq $X (times $X $Y) (or (equal $X zero) (and (numberp $X) (equal $Y 1)))) (set-det)) -; - - (= - (eq - (times $A $B) 1 - (and - (not (equal $A zero)) - (and - (not (equal $B zero)) - (and - (numberp $A) - (and - (numberp $B) - (and - (equal - (decr $A) zero) - (equal - (decr $B) zero))))))) + (= (eq (times $A $B) 1 (and (not (equal $A zero)) (and (not (equal $B zero)) (and (numberp $A) (and (numberp $B) (and (equal (decr $A) zero) (equal (decr $B) zero))))))) (set-det)) -; - - (= - (eq - (boyer-difference $X $Y) - (boyer-difference $Z $Y) - (if - (lessp $X $Y) - (not (lessp $Y $Z)) - (if - (lessp $Z $Y) - (not (lessp $Y $X)) - (equal - (fix $X) - (fix $Z))))) + (= (eq (boyer-difference $X $Y) (boyer-difference $Z $Y) (if (lessp $X $Y) (not (lessp $Y $Z)) (if (lessp $Z $Y) (not (lessp $Y $X)) (equal (fix $X) (fix $Z))))) (set-det)) -; + (= (eq (lessp $X $Y) $Z (if (lessp $X $Y) (equal t $Z) (equal f $Z))) True) - (= - (eq - (lessp $X $Y) $Z - (if - (lessp $X $Y) - (equal t $Z) - (equal f $Z))) True) -; - - - (= - (exp $I - (myplus $J $K) - (times - (exp $I $J) - (exp $I $K))) + (= (exp $I (myplus $J $K) (times (exp $I $J) (exp $I $K))) (set-det)) -; - - (= - (exp $I - (times $J $K) - (exp - (exp $I $J) $K)) True) -; + (= (exp $I (times $J $K) (exp (exp $I $J) $K)) True) - - (= - (gcd $X $Y - (gcd $Y $X)) + (= (gcd $X $Y (gcd $Y $X)) (set-det)) -; + (= (gcd (times $X $Z) (times $Y $Z) (times $Z (gcd $X $Y))) True) - (= - (gcd - (times $X $Z) - (times $Y $Z) - (times $Z - (gcd $X $Y))) True) -; + (= (mylength (reverse $X) (length $X)) True) + (= (mylength (cons $_ (cons $_ (cons $_ (cons $_ (cons $_ (cons $_ $X7)))))) (myplus 6 (length $X7))) True) - (= - (mylength - (reverse $X) - (length $X)) True) -; - - (= - (mylength - (cons $_ - (cons $_ - (cons $_ - (cons $_ - (cons $_ - (cons $_ $X7)))))) - (myplus 6 - (length $X7))) True) -; - - - - (= - (lessp - (remainder $_ $Y) $Y - (not (zerop $Y))) + (= (lessp (remainder $_ $Y) $Y (not (zerop $Y))) (set-det)) -; - - (= - (lessp - (quotient $I $J) $I - (and - (not (zerop $I)) - (or - (zerop $J) - (not (equal $J 1))))) + (= (lessp (quotient $I $J) $I (and (not (zerop $I)) (or (zerop $J) (not (equal $J 1))))) (set-det)) -; - - (= - (lessp - (remainder $X $Y) $X - (and - (not (zerop $Y)) - (and - (not (zerop $X)) - (not (lessp $X $Y))))) + (= (lessp (remainder $X $Y) $X (and (not (zerop $Y)) (and (not (zerop $X)) (not (lessp $X $Y))))) (set-det)) -; - - (= - (lessp - (myplus $X $Y) - (myplus $X $Z) - (lessp $Y $Z)) + (= (lessp (myplus $X $Y) (myplus $X $Z) (lessp $Y $Z)) (set-det)) -; - - (= - (lessp - (times $X $Z) - (times $Y $Z) - (and - (not (zerop $Z)) - (lessp $X $Y))) + (= (lessp (times $X $Z) (times $Y $Z) (and (not (zerop $Z)) (lessp $X $Y))) (set-det)) -; - - (= - (lessp $Y - (myplus $X $Y) - (not (zerop $X))) + (= (lessp $Y (myplus $X $Y) (not (zerop $X))) (set-det)) -; - - (= - (lessp - (length - (delete $X $L)) - (length $L) - (boyer_member $X $L)) True) -; - + (= (lessp (length (delete $X $L)) (length $L) (boyer_member $X $L)) True) - (= - (meaning - (plus-tree (append $X $Y)) $A - (myplus - (meaning - (plus-tree $X) $A) - (meaning - (plus-tree $Y) $A))) + (= (meaning (plus-tree (append $X $Y)) $A (myplus (meaning (plus-tree $X) $A) (meaning (plus-tree $Y) $A))) (set-det)) -; - - (= - (meaning - (plus-tree (plus-fringe $X)) $A - (fix (meaning $X $A))) + (= (meaning (plus-tree (plus-fringe $X)) $A (fix (meaning $X $A))) (set-det)) -; - - (= - (meaning - (plus_tree - (delete $X $Y)) $A - (if - (boyer_member $X $Y) - (boyer_difference - (meaning - (plus_tree $Y) $A) - (meaning $X $A)) - (meaning - (plus_tree $Y) $A))) True) -; + (= (meaning (plus_tree (delete $X $Y)) $A (if (boyer_member $X $Y) (boyer_difference (meaning (plus_tree $Y) $A) (meaning $X $A)) (meaning (plus_tree $Y) $A))) True) - - (= - (myboyer-member $X - (append $A $B) - (or - (boyer-member $X $A) - (boyer-member $X $B))) + (= (myboyer-member $X (append $A $B) (or (boyer-member $X $A) (boyer-member $X $B))) (set-det)) -; - - (= - (myboyer-member $X - (reverse $Y) - (boyer-member $X $Y)) + (= (myboyer-member $X (reverse $Y) (boyer-member $X $Y)) (set-det)) -; + (= (myboyer_member $A (intersect $B $C) (and (boyer_member $A $B) (boyer_member $A $C))) True) - (= - (myboyer_member $A - (intersect $B $C) - (and - (boyer_member $A $B) - (boyer_member $A $C))) True) -; + (= (nth zero $_ zero) True) + (= (nth () $I (if (zerop $I) () zero)) True) + (= (nth (append $A $B) $I (append (nth $A $I) (nth $B (boyer_difference $I (length $A))))) True) - (= - (nth zero $_ zero) True) -; - - (= - (nth () $I - (if - (zerop $I) () zero)) True) -; - - (= - (nth - (append $A $B) $I - (append - (nth $A $I) - (nth $B - (boyer_difference $I - (length $A))))) True) -; - - - - (= - (myplus - (myplus $X $Y) $Z - (myplus $X - (myplus $Y $Z))) + (= (myplus (myplus $X $Y) $Z (myplus $X (myplus $Y $Z))) (set-det)) -; - - (= - (myplus - (remainder $X $Y) - (times $Y - (quotient $X $Y)) - (fix $X)) + (= (myplus (remainder $X $Y) (times $Y (quotient $X $Y)) (fix $X)) (set-det)) -; - - (= - (myplus $X - (add1 $Y) - (if - (numberp $Y) - (add1 - (myplus $X $Y)) - (add1 $X))) True) -; - + (= (myplus $X (add1 $Y) (if (numberp $Y) (add1 (myplus $X $Y)) (add1 $X))) True) - (= - (power-eval - (big-plus1 $L $I $Base) $Base - (myplus - (power-eval $L $Base) $I)) + (= (power-eval (big-plus1 $L $I $Base) $Base (myplus (power-eval $L $Base) $I)) (set-det)) -; - - (= - (power-eval - (power-rep $I $Base) $Base - (fix $I)) + (= (power-eval (power-rep $I $Base) $Base (fix $I)) (set-det)) -; - - (= - (power-eval - (big-plus $X $Y $I $Base) $Base - (myplus $I - (myplus - (power-eval $X $Base) - (power-eval $Y $Base)))) + (= (power-eval (big-plus $X $Y $I $Base) $Base (myplus $I (myplus (power-eval $X $Base) (power-eval $Y $Base)))) (set-det)) -; - - (= - (power_eval - (big_plus - (power_rep $I $Base) - (power_rep $J $Base) zero $Base) $Base - (myplus $I $J)) True) -; + (= (power_eval (big_plus (power_rep $I $Base) (power_rep $J $Base) zero $Base) $Base (myplus $I $J)) True) + (= (quotient (myplus $X (myplus $X $Y)) 2 (myplus $X (quotient $Y 2))) True) + (= (quotient (times $Y $X) $Y (if (zerop $Y) zero (fix $X))) True) - (= - (quotient - (myplus $X - (myplus $X $Y)) 2 - (myplus $X - (quotient $Y 2))) True) -; - - (= - (quotient - (times $Y $X) $Y - (if - (zerop $Y) zero - (fix $X))) True) -; - - - (= - (remainder $_ 1 zero) + (= (remainder $_ 1 zero) (set-det)) -; - - (= - (remainder $X $X zero) + (= (remainder $X $X zero) (set-det)) -; - - (= - (remainder - (times $_ $Z) $Z zero) + (= (remainder (times $_ $Z) $Z zero) (set-det)) -; - - (= - (remainder - (times $Y $_) $Y zero) True) -; + (= (remainder (times $Y $_) $Y zero) True) - - (= - (reverse-loop $X $Y - (append - (reverse $X) $Y)) + (= (reverse-loop $X $Y (append (reverse $X) $Y)) (set-det)) -; - - (= - (reverse_loop $X () - (reverse $X)) True) -; + (= (reverse_loop $X () (reverse $X)) True) - - (= - (times $X - (myplus $Y $Z) - (myplus - (times $X $Y) - (times $X $Z))) + (= (times $X (myplus $Y $Z) (myplus (times $X $Y) (times $X $Z))) (set-det)) -; - - (= - (times - (times $X $Y) $Z - (times $X - (times $Y $Z))) + (= (times (times $X $Y) $Z (times $X (times $Y $Z))) (set-det)) -; - - (= - (times $X - (boyer-difference $C $W) - (boyer-difference - (times $C $X) - (times $W $X))) + (= (times $X (boyer-difference $C $W) (boyer-difference (times $C $X) (times $W $X))) (set-det)) -; - - (= - (times $X - (add1 $Y) - (if - (numberp $Y) - (myplus $X - (times $X $Y)) - (fix $X))) True) -; - + (= (times $X (add1 $Y) (if (numberp $Y) (myplus $X (times $X $Y)) (fix $X))) True) diff --git a/sxx_machine/bench/browse.metta b/sxx_machine/bench/browse.metta index 49170b3..2e534bc 100644 --- a/sxx_machine/bench/browse.metta +++ b/sxx_machine/bench/browse.metta @@ -1,285 +1,177 @@ +; (convert_to_metta_file browse $_46824 sxx_machine/bench/browse.pl sxx_machine/bench/browse.metta) ; -; - +; generated: 19 June 1990 ; -; - +; option(s): ; ; - ; -; - +; browse ; ; - ; -; - +; Tep Dobry (from Lisp version by R. P. Gabriel) ; ; - ; -; - - - - (= - (top) - ( (init 100 10 4 +; (modified January 1987 by Herve' Touati) + + + (= (top) + (init 100 10 4 + (:: + (:: a a a b b b b a a a a a b b a a a) + (:: a a b b b b a a + (:: a a) + (:: b b)) + (:: a a a b + (:: b a) b a b a)) $Symbols) + (randomize $Symbols $RSymbols 21) + (set-det) + (investigate $RSymbols + (:: (:: - (:: a a a b b b b a a a a a b b a a a) - (:: a a b b b b a a - (:: a a) - (:: b b)) - (:: a a a b - (:: b a) b a b a)) $Symbols) - (randomize $Symbols $RSymbols 21) - (set-det) - (investigate $RSymbols + (star $SA) $B + (star $SB) $B a + (star $SA) a + (star $SB) + (star $SA)) (:: - (:: - (star $SA) $B - (star $SB) $B a - (star $SA) a - (star $SB) - (star $SA)) - (:: - (star $SA) - (star $SB) - (star $SB) - (star $SA) - (:: (star $SA)) - (:: (star $SB))) - (:: $_ $_ - (star $_) - (:: b a) - (star $_) $_ $_))))) -; - + (star $SA) + (star $SB) + (star $SB) + (star $SA) + (:: (star $SA)) + (:: (star $SB))) + (:: $_ $_ + (star $_) + (:: b a) + (star $_) $_ $_)))) - (= - (init $N $M $Npats $Ipats $Result) + (= (init $N $M $Npats $Ipats $Result) (init $N $M $M $Npats $Ipats $Result)) -; - - (= - (init 0 $_ $_ $_ $_ $_) + (= (init 0 $_ $_ $_ $_ $_) (set-det)) -; - - (= - (init $N $I $M $Npats $Ipats - (Cons $Symb $Rest)) - ( (fill $I Nil $L) - (get-pats $Npats $Ipats $Ppats) - (is $J - (- $M $I)) - (fill $J - (Cons - (pattern $Ppats) $L) $Symb) - (is $N1 - (- $N 1)) - (det-if-then-else - (=:= $I 0) - (is $I1 $M) - (is $I1 - (- $I 1))) - (init $N1 $I1 $M $Npats $Ipats $Rest))) -; - - - - (= - (fill 0 $L $L) - (set-det)) -; - - (= - (fill $N $L + (= (init $N $I $M $Npats $Ipats (Cons $Symb $Rest)) + (fill $I Nil $L) + (get-pats $Npats $Ipats $Ppats) + (is $J + (- $M $I)) + (fill $J (Cons - (dummy Nil) $Rest)) - ( (is $N1 - (- $N 1)) (fill $N1 $L $Rest))) -; - - - - (= - (randomize Nil Nil $_) + (pattern $Ppats) $L) $Symb) + (is $N1 + (- $N 1)) + (det-if-then-else + (=:= $I 0) + (is $I1 $M) + (is $I1 + (- $I 1))) + (init $N1 $I1 $M $Npats $Ipats $Rest)) + + + (= (fill 0 $L $L) (set-det)) -; - - (= - (randomize $In - (Cons $X $Out) $Rand) - ( (length $In $Lin) - (is $Rand1 - (mod - (* $Rand 17) 251)) - (is $N - (mod $Rand1 $Lin)) - (split $N $In $X $In1) - (randomize $In1 $Out $Rand1))) -; + (= (fill $N $L (Cons (dummy Nil) $Rest)) + (is $N1 + (- $N 1)) + (fill $N1 $L $Rest)) - - (= - (split 0 - (Cons $X $Xs) $X $Xs) + (= (randomize Nil Nil $_) (set-det)) -; - - (= - (split $N - (Cons $X $Xs) $RemovedElt - (Cons $X $Ys)) - ( (is $N1 - (- $N 1)) (split $N1 $Xs $RemovedElt $Ys))) -; - - - - (= - (investigate Nil $_) + (= (randomize $In (Cons $X $Out) $Rand) + (length $In $Lin) + (is $Rand1 + (mod + (* $Rand 17) 251)) + (is $N + (mod $Rand1 $Lin)) + (split $N $In $X $In1) + (randomize $In1 $Out $Rand1)) + + + (= (split 0 (Cons $X $Xs) $X $Xs) (set-det)) -; + (= (split $N (Cons $X $Xs) $RemovedElt (Cons $X $Ys)) + (is $N1 + (- $N 1)) + (split $N1 $Xs $RemovedElt $Ys)) - (= - (investigate - (Cons $U $Units) $Patterns) - ( (property $U pattern $Data) - (p-investigate $Data $Patterns) - (investigate $Units $Patterns))) -; + (= (investigate Nil $_) + (set-det)) + (= (investigate (Cons $U $Units) $Patterns) + (property $U pattern $Data) + (p-investigate $Data $Patterns) + (investigate $Units $Patterns)) - (= - (get-pats $Npats $Ipats $Result) + (= (get-pats $Npats $Ipats $Result) (get-pats $Npats $Ipats $Result $Ipats)) -; - - (= - (get-pats 0 $_ Nil $_) + (= (get-pats 0 $_ Nil $_) (set-det)) -; - - (= - (get-pats $N - (Cons $X $Xs) - (Cons $X $Ys) $Ipats) - ( (is $N1 - (- $N 1)) (get-pats $N1 $Xs $Ys $Ipats))) -; - - (= - (get-pats $N Nil $Ys $Ipats) + (= (get-pats $N (Cons $X $Xs) (Cons $X $Ys) $Ipats) + (is $N1 + (- $N 1)) + (get-pats $N1 $Xs $Ys $Ipats)) + (= (get-pats $N Nil $Ys $Ipats) (get-pats $N $Ipats $Ys $Ipats)) -; - - - (= - (property () $_ $_) - (empty)) -; - - (= - (property - (Cons $Prop $_) $P $Val) - ( (functor $Prop $P $_) - (set-det) - (arg 1 $Prop $Val))) -; - (= - (property - (Cons $_ $RProps) $P $Val) + (= (property () $_ $_) + (empty)) + (= (property (Cons $Prop $_) $P $Val) + (functor $Prop $P $_) + (set-det) + (arg 1 $Prop $Val)) +; /* don't really need this */ + (= (property (Cons $_ $RProps) $P $Val) (property $RProps $P $Val)) -; + (= (p_investigate () $_) True) + (= (p-investigate (Cons $D $Data) $Patterns) + (p-match $Patterns $D) + (p-investigate $Data $Patterns)) - (= - (p_investigate () $_) True) -; - (= - (p-investigate - (Cons $D $Data) $Patterns) - ( (p-match $Patterns $D) (p-investigate $Data $Patterns))) -; + (= (p_match () $_) True) + (= (p-match (Cons $P $Patterns) $D) + (or + (, + (match $D $P) + (fail)) True) + (p-match $Patterns $D)) - - (= - (p_match () $_) True) -; - - (= - (p-match - (Cons $P $Patterns) $D) - ( (or - (, - (match $D $P) - (fail)) True) (p-match $Patterns $D))) -; - - - - (= - (match Nil Nil) + (= (match Nil Nil) (set-det)) -; - - (= - (match - (Cons $X $PRest) - (Cons $Y $SRest)) - ( (var $Y) - (set-det) + (= (match (Cons $X $PRest) (Cons $Y $SRest)) + (var $Y) + (set-det) + (= $X $Y) + (match $PRest $SRest)) + (= (match $List (Cons $Y $Rest)) + (nonvar $Y) + (= $Y + (star $X)) + (set-det) + ($concat $X $SRest $List) + (match $SRest $Rest)) + (= (match (Cons $X $PRest) (Cons $Y $SRest)) + (det-if-then-else + (atom $X) (= $X $Y) - (match $PRest $SRest))) -; - - (= - (match $List - (Cons $Y $Rest)) - ( (nonvar $Y) - (= $Y - (star $X)) - (set-det) - ($concat $X $SRest $List) - (match $SRest $Rest))) -; - - (= - (match - (Cons $X $PRest) - (Cons $Y $SRest)) - ( (det-if-then-else - (atom $X) - (= $X $Y) - (match $X $Y)) (match $PRest $SRest))) -; - + (match $X $Y)) + (match $PRest $SRest)) - (= - ($concat () $L $L) True) -; - - (= - ($concat - (Cons $X $L1) $L2 - (Cons $X $L3)) + (= (%concat () $L $L) True) + (= ($concat (Cons $X $L1) $L2 (Cons $X $L3)) ($concat $L1 $L2 $L3)) -; - diff --git a/sxx_machine/bench/chat_parser.metta b/sxx_machine/bench/chat_parser.metta index ae63a1a..55e1d2c 100644 --- a/sxx_machine/bench/chat_parser.metta +++ b/sxx_machine/bench/chat_parser.metta @@ -1,3202 +1,1412 @@ +; (convert_to_metta_file chat_parser $_180594 sxx_machine/bench/chat_parser.pl sxx_machine/bench/chat_parser.metta) ; -; - +; generated: 19 November 1989 ; -; - +; option(s): ; ; - ; -; - +; chat_parser ; ; - ; -; - +; Fernando C. N. Pereira and David H. D. Warren - (= - (top) + (= (top) (chat-parser)) -; - - - - (= - (go) - ( (statistics runtime - (:: $_ $_)) - (chat-parser) - (statistics runtime - (:: $_ $T)) - (write 'execution time is ') - (write $T) - (write milliseconds))) -; - - (= - (chat-parser) - ( (my-string $X) - (determinate-say $X $_) - (fail))) -; + (= (go) + (statistics runtime + (:: $_ $_)) + (chat-parser) + (statistics runtime + (:: $_ $T)) + (write 'execution time is ') + (write $T) + (write milliseconds)) - (= chat_parser True) -; + (= (chat-parser) + (my-string $X) + (determinate-say $X $_) + (fail)) + (= chat_parser True) ; -; +; query set + + + (= (my_string (what rivers are there ?)) True) + (= (my_string (does afghanistan border china ?)) True) + (= (my_string (what is the capital of upper_volta ?)) True) + (= (my_string (where is the largest country ?)) True) + (= (my_string (which country ~ s capital is london ?)) True) + (= (my_string (which countries are european ?)) True) + (= (my_string (how large is the smallest american country ?)) True) + (= (my_string (what is the ocean that borders african countries and that borders asian countries ?)) True) + (= (my_string (what are the capitals of the countries bordering the baltic ?)) True) + (= (my_string (which countries are bordered by two seas ?)) True) + (= (my_string (how many countries does the danube flow through ?)) True) + (= (my_string (what is the total area of countries south of the equator and not in australasia ?)) True) + (= (my_string (what is the average area of the countries in each continent ?)) True) + (= (my_string (is there more than one country in each continent ?)) True) + (= (my_string (is there some ocean that does not border any country ?)) True) + (= (my_string (what are the countries from which a river flows into the black_sea ?)) True) +; +; determinate_say - (= - (my_string - (what rivers are there ?)) True) -; - (= - (my_string - (does afghanistan border china ?)) True) -; + (= (determinate-say $X $Y) + (say $X $Y) + (set-det)) - (= - (my_string - (what is the capital of upper_volta ?)) True) -; - (= - (my_string - (where is the largest country ?)) True) +; +; ----------------------------------------------------------------------------- +; ; - - (= - (my_string - (which country ~ s capital is london ?)) True) +; +; xgrun +; ; +; +; ----------------------------------------------------------------------------- - (= - (my_string - (which countries are european ?)) True) -; - (= - (my_string - (how large is the smallest american country ?)) True) -; + (= (terminal $T $S $S (x $_ terminal $T $X) $X) True) + (= (terminal $T (Cons $T $S) $S $X $X) + (gap $X)) - (= - (my_string - (what is the ocean that borders african countries and that borders asian countries ?)) True) -; - (= - (my_string - (what are the capitals of the countries bordering the baltic ?)) True) -; + (= (gap (x gap $_ $_ $_)) True) + (= (gap ()) True) - (= - (my_string - (which countries are bordered by two seas ?)) True) -; - (= - (my_string - (how many countries does the danube flow through ?)) True) -; + (= (virtual $NT (x $_ nonterminal $NT $X) $X) True) - (= - (my_string - (what is the total area of countries south of the equator and not in australasia ?)) True) -; - (= - (my_string - (what is the average area of the countries in each continent ?)) True) +; +; ---------------------------------------------------------------------------- +; ; - - (= - (my_string - (is there more than one country in each continent ?)) True) +; +; clotab +; ; +; +; ---------------------------------------------------------------------------- - (= - (my_string - (is there some ocean that does not border any country ?)) True) -; +; +; normal form masks - (= - (my_string - (what are the countries from which a river flows into the black_sea ?)) True) -; + (= (is_pp (# 1 $_ $_ $_)) True) -; -; + (= (is_pred (# $_ 1 $_ $_)) True) + (= (is_trace (# $_ $_ 1 $_)) True) - (= - (determinate-say $X $Y) - ( (say $X $Y) (set-det))) -; + (= (is_adv (# $_ $_ $_ 1)) True) -; -; + (= (trace1 (# $_ $_ 1 $_) (# 0 0 0 0)) True) -; -; + (= (trace1 (# 0 0 1 0)) True) -; -; -; -; + (= (adv (# 0 0 0 1)) True) -; -; + (= (empty (# 0 0 0 0)) True) - (= - (terminal $T $S $S - (x $_ terminal $T $X) $X) True) -; + (= (np_all (# 1 1 1 0)) True) - (= - (terminal $T - (Cons $T $S) $S $X $X) - (gap $X)) -; + (= (s_all (# 1 0 1 1)) True) - (= - (gap - (x gap $_ $_ $_)) True) -; + (= (np_no_trace (# 1 1 0 0)) True) - (= - (gap ()) True) -; +; +; mask operations + (= (myplus (# $B1 $B2 $B3 $B4) (# $C1 $C2 $C3 $C4) (# $D1 $D2 $D3 $D4)) + (or $B1 $C1 $D1) + (or $B2 $C2 $D2) + (or $B3 $C3 $D3) + (or $B4 $C4 $D4)) - (= - (virtual $NT - (x $_ nonterminal $NT $X) $X) True) -; + (= (minus (# $B1 $B2 $B3 $B4) (# $C1 $C2 $C3 $C4) (# $D1 $D2 $D3 $D4)) + (anot $B1 $C1 $D1) + (anot $B2 $C2 $D2) + (anot $B3 $C3 $D3) + (anot $B4 $C4 $D4)) -; -; + (= (or 1 $_ 1) True) + (= (or 0 1 1) True) + (= (or 0 0 0) True) -; -; -; -; + (= (anot $X 0 $X) True) + (= (anot $X 1 0) True) ; -; +; noun phrase position features -; -; + (= (role subj $_ (# 1 0 0)) True) + (= (role compl $_ (# 0 $_ $_)) True) + (= (role undef main (# $_ 0 $_)) True) + (= (role undef aux (# 0 $_ $_)) True) + (= (role undef decl $_) True) + (= (role nil $_ $_) True) -; -; + (= (subj_case (# 1 0 0)) True) + (= (verb_case (# 0 1 0)) True) - (= - (is_pp - (# 1 $_ $_ $_)) True) -; + (= (prep_case (# 0 0 1)) True) + (= (compl_case (# 0 $_ $_)) True) - (= - (is_pred - (# $_ 1 $_ $_)) True) +; +; ---------------------------------------------------------------------------- +; ; - - - - (= - (is_trace - (# $_ $_ 1 $_)) True) +; +; newg +; ; +; +; ---------------------------------------------------------------------------- - - (= - (is_adv - (# $_ $_ $_ 1)) True) -; + (= (say $X $Y) + (sentence $Y $X Nil Nil Nil)) - (= - (trace1 - (# $_ $_ 1 $_) - (# 0 0 0 0)) True) -; + (= (sentence $B $C $D $E $F) + (declarative $B $C $G $E $H) + (terminator . $G $D $H $F)) + (= (sentence $B $C $D $E $F) + (wh-question $B $C $G $E $H) + (terminator ? $G $D $H $F)) + (= (sentence $B $C $D $E $F) + (topic $C $G $E $H) + (wh-question $B $G $I $H $J) + (terminator ? $I $D $J $F)) + (= (sentence $B $C $D $E $F) + (yn-question $B $C $G $E $H) + (terminator ? $G $D $H $F)) + (= (sentence $B $C $D $E $F) + (imperative $B $C $G $E $H) + (terminator + (set-det) $G $D $H $F)) - (= - (trace1 - (# 0 0 1 0)) True) -; + (= (pp $B $C $D $E $F $F $G $H) + (virtual + (pp $B $C $D $E) $G $H)) + (= (pp (pp $B $C) $D $E $F $G $H $I $J) + (prep $B $G $K $I $L) + (prep-case $M) + (np $C $N $M $O $D $E $F $K $H $L $J)) - (= - (adv - (# 0 0 0 1)) True) -; + (= (topic $B $C $D (x gap nonterminal (pp $E compl $F $G) $H)) + (pp $E compl $F $G $B $I $D $J) + (opt-comma $I $C $J $H)) - (= - (empty - (# 0 0 0 0)) True) -; + (= (opt-comma $B $C $D $E) + (~ , $B $C $D $E)) + (= (opt_comma $B $B $C $C) True) - (= - (np_all - (# 1 1 1 0)) True) -; + (= (declarative (decl $B) $C $D $E $F) + (s $B $G $C $D $E $F)) - (= - (s_all - (# 1 0 1 1)) True) -; + (= (wh-question (whq $B $C) $D $E $F $G) + (variable-q $B $H $I $J $D $K $F $L) + (question $I $J $C $K $E $L $G)) - (= - (np_no_trace - (# 1 1 0 0)) True) -; + (= (np $B $C $D $E $F $G $H $I $I $J $K) + (virtual + (np $B $C $D $E $F $G $H) $J $K)) + (= (np (np $B $C Nil) $B $D def $E $F $G $H $I $J $K) + (is-pp $F) + (pers-pron $C $B $L $H $I $J $K) + (empty $G) + (role $L decl $D)) + (= (np (np $B $C $D) $B $E $F $G $H $I $J $K $L $M) + (is-pp $H) + (np-head $C $B + (+ $F $N) $O $D $J $P $L $Q) + (np-all $R) + (np-compls $N $B $G $O $R $I $P $K $Q $M)) + (= (np (part $B $C) (+ 3 $D) $E indef $F $G $H $I $J $K $L) + (is-pp $G) + (determiner $B $D indef $I $M $K $N) + (~ of $M $O $N $P) + (s-all $Q) + (prep-case $R) + (np $C + (+ 3 plu) $R def $F $Q $H $O $J $P $L)) + + + + (= (variable-q $B $C $D $E $F $G $H (x gap nonterminal (np $I $C $E $J $K $L $M) $N)) + (whq $B $C $I $D $F $G $H $N) + (trace1 $L $M)) + (= (variable-q $B $C compl $D $E $F $G (x gap nonterminal (pp (pp $H $I) compl $J $K) $L)) + (prep $H $E $M $G $N) + (whq $B $C $I $O $M $F $N $L) + (trace1 $J $K) + (compl-case $D)) + (= (variable-q $B $C compl $D $E $F $G (x gap nonterminal (adv-phrase (pp $H (np $C (np-head (int-det $B) Nil $I) Nil)) $J $K) $L)) + (context-pron $H $I $E $F $G $L) + (trace1 $J $K) + (verb-case $D)) + (= (variable-q $B $C compl $D $E $F $G (x gap nonterminal (predicate adj (value $H (wh $B)) $I) $J)) + (~ how $E $K $G $L) + (adj quant $H $K $F $L $J) + (empty $I) + (verb-case $D)) + + + + (= (adv-phrase $B $C $D $E $E $F $G) + (virtual + (adv-phrase $B $C $D) $F $G)) + (= (adv-phrase (pp $B $C) $D $E $F $G $H $I) + (loc-pred $B $F $J $H $K) + (pp + (pp + (prep of) $C) compl $D $E $J $G $K $I)) -; -; + (= (predicate $B $C $D $E $E $F $G) + (virtual + (predicate $B $C $D) $F $G)) + (= (predicate $B $C $D $E $F $G $H) + (adj-phrase $C $D $E $F $G $H)) + (= (predicate neg $B $C $D $E $F $G) + (s-all $H) + (pp $B compl $H $C $D $E $F $G)) + (= (predicate $B $C $D $E $F $G $H) + (s-all $I) + (adv-phrase $C $I $D $E $F $G $H)) - (= - (myplus - (# $B1 $B2 $B3 $B4) - (# $C1 $C2 $C3 $C4) - (# $D1 $D2 $D3 $D4)) - ( (or $B1 $C1 $D1) - (or $B2 $C2 $D2) - (or $B3 $C3 $D3) - (or $B4 $C4 $D4))) -; + (= (whq $B $C $D undef $E $F $G $H) + (int-det $B $C $E $I $G $J) + (s-all $K) + (np $D $C $L $M subj $K $N $I $F $J $H)) + (= (whq $B (+ 3 $C) (np (+ 3 $C) (wh $B) Nil) $D $E $F $G $H) + (int-pron $D $E $F $G $H)) - (= - (minus - (# $B1 $B2 $B3 $B4) - (# $C1 $C2 $C3 $C4) - (# $D1 $D2 $D3 $D4)) - ( (anot $B1 $C1 $D1) - (anot $B2 $C2 $D2) - (anot $B3 $C3 $D3) - (anot $B4 $C4 $D4))) -; + (= (int-det $B (+ 3 $C) $D $E $F $G) + (whose $B $C $D $E $F $G)) + (= (int-det $B (+ 3 $C) $D $E $F $G) + (int-art $B $C $D $E $F $G)) - (= - (or 1 $_ 1) True) -; - (= - (or 0 1 1) True) -; - (= - (or 0 0 0) True) -; + (= (gen-marker $B $B $C $D) + (virtual gen-marker $C $D)) + (= (gen-marker $B $C $D $E) + (~ ~ $B $F $D $G) + (an-s $F $C $G $E)) - (= - (anot $X 0 $X) True) -; + (= (whose $B $C $D $E $F (x nogap nonterminal (np-head0 (wh $B) $C proper) (x nogap nonterminal gen-marker $G))) + (~ whose $D $E $F $G)) - (= - (anot $X 1 0) True) -; -; -; + (= (question $B $C $D $E $F $G $H) + (subj-question $B) + (role subj $I $C) + (s $D $J $E $F $G $H)) + (= (question $B $C $D $E $F $G $H) + (fronted-verb $B $C $E $I $G $J) + (s $D $K $I $F $J $H)) - (= - (role subj $_ - (# 1 0 0)) True) -; + (= (det $B $C $D $E $E $F $G) + (virtual + (det $B $C $D) $F $G)) + (= (det (det $B) $C $D $E $F $G $H) + (terminal $I $E $F $G $H) + (det $I $C $B $D)) + (= (det generic $B generic $C $C $D $D) True) - (= - (role compl $_ - (# 0 $_ $_)) True) -; - (= - (role undef main - (# $_ 0 $_)) True) -; - (= - (role undef aux - (# 0 $_ $_)) True) -; + (= (int-art $B $C $D $E $F (x nogap nonterminal (det $G $C def) $H)) + (int-art $B $C $G $D $E $F $H)) - (= - (role undef decl $_) True) -; - (= - (role nil $_ $_) True) -; + (= (subj_question subj) True) + (= (subj_question undef) True) - (= - (subj_case - (# 1 0 0)) True) -; + (= (yn-question (q $B) $C $D $E $F) + (fronted-verb nil $G $C $H $E $I) + (s $B $J $H $D $I $F)) - (= - (verb_case - (# 0 1 0)) True) -; - (= - (prep_case - (# 0 0 1)) True) -; + (= (verb-form $B $C $D $E $F $F $G $H) + (virtual + (verb-form $B $C $D $E) $G $H)) + (= (verb-form $B $C $D $E $F $G $H $I) + (terminal $J $F $G $H $I) + (verb-form $J $B $C $D)) - (= - (compl_case - (# 0 $_ $_)) True) -; + (= (neg $B $C $D $D $E $F) + (virtual + (neg $B $C) $E $F)) + (= (neg (+ aux $B) neg $C $D $E $F) + (~ not $C $D $E $F)) + (= (neg $B pos $C $C $D $D) True) -; -; -; -; + (= (fronted-verb $B $C $D $E $F (x gap nonterminal (verb-form $G $H $I $J) (x nogap nonterminal (neg $K $L) $M))) + (verb-form $G $H $I $N $D $O $F $P) + (verb-type $G + (+ aux $Q)) + (role $B $J $C) + (neg $R $L $O $E $P $M)) -; -; -; -; -; -; + (= (imperative (imp $B) $C $D $E $F) + (imperative-verb $C $G $E $H) + (s $B $I $G $D $H $F)) - (= - (say $X $Y) - (sentence $Y $X Nil Nil Nil)) -; + (= (imperative-verb $B $C $D (x nogap terminal you (x nogap nonterminal (verb-form $E (+ imp fin) (+ 2 sin) main) $F))) + (verb-form $E inf $G $H $B $C $D $F)) + (= (s (s $B $C $D $E) $F $G $H $I $J) + (subj $B $K $L $G $M $I $N) + (verb $C $K $L $O $M $P $N $Q) + (empty $R) + (s-all $S) + (verb-args $L $O $D $R $T $P $U $Q $V) + (minus $S $T $W) + (myplus $S $T $X) + (verb-mods $E $W $X $F $U $H $V $J)) - (= - (sentence $B $C $D $E $F) - ( (declarative $B $C $G $E $H) (terminator . $G $D $H $F))) -; - (= - (sentence $B $C $D $E $F) - ( (wh-question $B $C $G $E $H) (terminator ? $G $D $H $F))) -; - (= - (sentence $B $C $D $E $F) - ( (topic $C $G $E $H) - (wh-question $B $G $I $H $J) - (terminator ? $I $D $J $F))) -; + (= (subj there $B (+ $C be) $D $E $F $G) + (~ there $D $E $F $G)) + (= (subj $B $C $D $E $F $G $H) + (s-all $I) + (subj-case $J) + (np $B $C $J $K subj $I $L $E $F $G $H)) - (= - (sentence $B $C $D $E $F) - ( (yn-question $B $C $G $E $H) (terminator ? $G $D $H $F))) -; - (= - (sentence $B $C $D $E $F) - ( (imperative $B $C $G $E $H) (terminator (set-det) $G $D $H $F))) -; + (= (np-head $B $C $D $E $F $G $H $I $J) + (np-head0 $K $L $M $G $N $I $O) + (possessive $K $L $M $P $P $B $C $D $E $F $N $H $O $J)) - (= - (pp $B $C $D $E $F $F $G $H) + (= (np-head0 $B $C $D $E $E $F $G) (virtual - (pp $B $C $D $E) $G $H)) -; - - (= - (pp - (pp $B $C) $D $E $F $G $H $I $J) - ( (prep $B $G $K $I $L) - (prep-case $M) - (np $C $N $M $O $D $E $F $K $H $L $J))) -; + (np-head0 $B $C $D) $F $G)) + (= (np-head0 (name $B) (+ 3 sin) (+ def proper) $C $D $E $F) + (name $B $C $D $E $F)) + (= (np-head0 (np-head $B $C $D) (+ 3 $E) (+ $F common) $G $H $I $J) + (determiner $B $E $F $G $K $I $L) + (adjs $C $K $M $L $N) + (noun $D $E $M $H $N $J)) + (= (np-head0 $B $C (+ def proper) $D $E $F (x nogap nonterminal gen-marker $G)) + (poss-pron $B $C $D $E $F $G)) + (= (np-head0 (np-head $B Nil $C) (+ 3 sin) (+ indef common) $D $E $F $G) + (quantifier-pron $B $C $D $E $F $G)) + (= (np-compls proper $B $C Nil $D $E $F $F $G $G) + (empty $E)) + (= (np-compls common $B $C $D $E $F $G $H $I $J) + (np-all $K) + (np-mods $B $C $L $D $E $M $K $N $G $O $I $P) + (relative $B $L $M $N $F $O $H $P $J)) - (= - (topic $B $C $D - (x gap nonterminal - (pp $E compl $F $G) $H)) - ( (pp $E compl $F $G $B $I $D $J) (opt-comma $I $C $J $H))) -; + (= (possessive $B $C $D Nil $E $F $G $H $I $J $K $L $M $N) + (gen-case $K $O $M $P) + (np-head0 $Q $R $S $O $T $P $U) + (possessive $Q $R $S $V + (Cons + (pp poss + (np $C $B $E)) $V) $F $G $H $I $J $T $L $U $N)) + (= (possessive $B $C $D $E $F $B $C $D $E $F $G $G $H $H) True) - (= - (opt-comma $B $C $D $E) - (~ , $B $C $D $E)) -; - (= - (opt_comma $B $B $C $C) True) -; + (= (gen-case $B $C $D (x nogap terminal the $E)) + (gen-marker $B $C $D $E)) + (= (an-s $B $C $D $E) + (~ s $B $C $D $E)) + (= (an_s $B $B $C $C) True) - (= - (declarative - (decl $B) $C $D $E $F) - (s $B $G $C $D $E $F)) -; + (= (determiner $B $C $D $E $F $G $H) + (det $B $C $D $E $F $G $H)) + (= (determiner $B $C $D $E $F $G $H) + (quant-phrase $B $C $D $E $F $G $H)) - (= - (wh-question - (whq $B $C) $D $E $F $G) - ( (variable-q $B $H $I $J $D $K $F $L) (question $I $J $C $K $E $L $G))) -; + (= (quant-phrase (quant $B $C) $D $E $F $G $H $I) + (quant $B $E $F $J $H $K) + (number $C $D $J $G $K $I)) - (= - (np $B $C $D $E $F $G $H $I $I $J $K) - (virtual - (np $B $C $D $E $F $G $H) $J $K)) -; + (= (quant $B indef $C $D $E $F) + (neg-adv $G $B $C $H $E $I) + (comp-adv $G $H $J $I $K) + (~ than $J $D $K $F)) + (= (quant $B indef $C $D $E $F) + (~ at $C $G $E $H) + (sup-adv $I $G $D $H $F) + (sup-op $I $B)) + (= (quant the def $B $C $D $E) + (~ the $B $C $D $E)) + (= (quant same indef $B $B $C $C) True) - (= - (np - (np $B $C Nil) $B $D def $E $F $G $H $I $J $K) - ( (is-pp $F) - (pers-pron $C $B $L $H $I $J $K) - (empty $G) - (role $L decl $D))) -; - (= - (np - (np $B $C $D) $B $E $F $G $H $I $J $K $L $M) - ( (is-pp $H) - (np-head $C $B - (+ $F $N) $O $D $J $P $L $Q) - (np-all $R) - (np-compls $N $B $G $O $R $I $P $K $Q $M))) -; - (= - (np - (part $B $C) - (+ 3 $D) $E indef $F $G $H $I $J $K $L) - ( (is-pp $G) - (determiner $B $D indef $I $M $K $N) - (~ of $M $O $N $P) - (s-all $Q) - (prep-case $R) - (np $C - (+ 3 plu) $R def $F $Q $H $O $J $P $L))) -; + (= (neg-adv $B (+ not $B) $C $D $E $F) + (~ not $C $D $E $F)) + (= (neg_adv $B $B $C $C $D $D) True) + (= (sup_op least (+ not less)) True) + (= (sup_op most (+ not more)) True) - (= - (variable-q $B $C $D $E $F $G $H - (x gap nonterminal - (np $I $C $E $J $K $L $M) $N)) - ( (whq $B $C $I $D $F $G $H $N) (trace1 $L $M))) -; - (= - (variable-q $B $C compl $D $E $F $G - (x gap nonterminal - (pp - (pp $H $I) compl $J $K) $L)) - ( (prep $H $E $M $G $N) - (whq $B $C $I $O $M $F $N $L) - (trace1 $J $K) - (compl-case $D))) -; - (= - (variable-q $B $C compl $D $E $F $G - (x gap nonterminal - (adv-phrase - (pp $H - (np $C - (np-head - (int-det $B) Nil $I) Nil)) $J $K) $L)) - ( (context-pron $H $I $E $F $G $L) - (trace1 $J $K) - (verb-case $D))) -; + (= (np-mods $B $C $D (Cons $E $F) $G $H $I $J $K $L $M $N) + (np-mod $B $C $E $G $O $K $P $M $Q) + (trace1 $R) + (myplus $R $O $S) + (minus $G $S $T) + (myplus $O $G $U) + (np-mods $B $C $D $F $T $H $U $J $P $L $Q $N)) + (= (np_mods $B $C $D $D $E $E $F $F $G $G $H $H) True) - (= - (variable-q $B $C compl $D $E $F $G - (x gap nonterminal - (predicate adj - (value $H - (wh $B)) $I) $J)) - ( (~ how $E $K $G $L) - (adj quant $H $K $F $L $J) - (empty $I) - (verb-case $D))) -; + (= (np-mod $B $C $D $E $F $G $H $I $J) + (pp $D $C $E $F $G $H $I $J)) + (= (np-mod $B $C $D $E $F $G $H $I $J) + (reduced-relative $B $D $E $F $G $H $I $J)) - (= - (adv-phrase $B $C $D $E $E $F $G) - (virtual - (adv-phrase $B $C $D) $F $G)) -; - (= - (adv-phrase - (pp $B $C) $D $E $F $G $H $I) - ( (loc-pred $B $F $J $H $K) (pp (pp (prep of) $C) compl $D $E $J $G $K $I))) -; + (= (verb-mods (Cons $B $C) $D $E $F $G $H $I $J) + (verb-mod $B $D $K $G $L $I $M) + (trace1 $N) + (myplus $N $K $O) + (minus $D $O $P) + (myplus $K $D $Q) + (verb-mods $C $P $Q $F $L $H $M $J)) + (= (verb_mods () $B $C $C $D $D $E $E) True) + (= (verb-mod $B $C $D $E $F $G $H) + (adv-phrase $B $C $D $E $F $G $H)) + (= (verb-mod $B $C $D $E $F $G $H) + (is-adv $C) + (adverb $B $E $F $G $H) + (empty $D)) + (= (verb-mod $B $C $D $E $F $G $H) + (pp $B compl $C $D $E $F $G $H)) - (= - (predicate $B $C $D $E $E $F $G) - (virtual - (predicate $B $C $D) $F $G)) -; - (= - (predicate $B $C $D $E $F $G $H) - (adj-phrase $C $D $E $F $G $H)) -; - (= - (predicate neg $B $C $D $E $F $G) - ( (s-all $H) (pp $B compl $H $C $D $E $F $G))) -; + (= (adjs (Cons $B $C) $D $E $F $G) + (pre-adj $B $D $H $F $I) + (adjs $C $H $E $I $G)) + (= (adjs () $B $B $C $C) True) - (= - (predicate $B $C $D $E $F $G $H) - ( (s-all $I) (adv-phrase $C $I $D $E $F $G $H))) -; + (= (pre-adj $B $C $D $E $F) + (adj $G $B $C $D $E $F)) + (= (pre-adj $B $C $D $E $F) + (sup-phrase $B $C $D $E $F)) - (= - (whq $B $C $D undef $E $F $G $H) - ( (int-det $B $C $E $I $G $J) - (s-all $K) - (np $D $C $L $M subj $K $N $I $F $J $H))) -; - (= - (whq $B - (+ 3 $C) - (np - (+ 3 $C) - (wh $B) Nil) $D $E $F $G $H) - (int-pron $D $E $F $G $H)) -; + (= (sup-phrase (sup most $B) $C $D $E $F) + (sup-adj $B $C $D $E $F)) + (= (sup-phrase (sup $B $C) $D $E $F $G) + (sup-adv $B $D $I $F $J) + (adj quant $C $I $E $J $G)) + (= (comp-phrase (comp $B $C $D) $E $F $G $H $I) + (comp $B $C $F $J $H $K) + (np-no-trace $L) + (prep-case $M) + (np $D $N $M $O compl $L $E $J $G $K $I)) - (= - (int-det $B - (+ 3 $C) $D $E $F $G) - (whose $B $C $D $E $F $G)) -; - (= - (int-det $B - (+ 3 $C) $D $E $F $G) - (int-art $B $C $D $E $F $G)) -; + (= (comp $B $C $D $E $F $G) + (comp-adv $B $D $H $F $I) + (adj quant $C $H $J $I $K) + (~ than $J $E $K $G)) + (= (comp more $B $C $D $E $F) + (rel-adj $B $C $G $E $H) + (~ than $G $D $H $F)) + (= (comp same $B $C $D $E $F) + (~ as $C $G $E $H) + (adj quant $B $G $I $H $J) + (~ as $I $D $J $F)) - (= - (gen-marker $B $B $C $D) - (virtual gen-marker $C $D)) -; + (= (relative $B (:: $C) $D $E $F $G $H $I $J) + (is-pred $D) + (rel-conj $B $K $C $F $G $H $I $J)) + (= (relative $B () $C $D $D $E $E $F $F) True) - (= - (gen-marker $B $C $D $E) - ( (~ ~ $B $F $D $G) (an-s $F $C $G $E))) -; + (= (rel-conj $B $C $D $E $F $G $H $I) + (rel $B $J $K $F $L $H $M) + (rel-rest $B $C $J $D $K $E $L $G $M $I)) - (= - (whose $B $C $D $E $F - (x nogap nonterminal - (np-head0 - (wh $B) $C proper) - (x nogap nonterminal gen-marker $G))) - (~ whose $D $E $F $G)) -; + (= (rel-rest $B $C $D $E $F $G $H $I $J $K) + (conj $C $L $D $M $E $H $N $J $O) + (rel-conj $B $L $M $G $N $I $O $K)) + (= (rel_rest $B $C $D $D $E $E $F $F $G $G) True) - (= - (question $B $C $D $E $F $G $H) - ( (subj-question $B) - (role subj $I $C) - (s $D $J $E $F $G $H))) -; + (= (rel $B (rel $C $D) $E $F $G $H $I) + (myopen $F $J $H $K) + (variable $B $C $J $L $K $M) + (s $D $N $L $O $M $P) + (trace1 $Q) + (minus $N $Q $E) + (close $O $G $P $I)) - (= - (question $B $C $D $E $F $G $H) - ( (fronted-verb $B $C $E $I $G $J) (s $D $K $I $F $J $H))) -; + (= (variable $B $C $D $E $F (x gap nonterminal (np (np $B (wh $C) Nil) $B $G $H $I $J $K) $L)) + (~ that $D $E $F $L) + (trace1 $J $K)) + (= (variable $B $C $D $E $F (x gap nonterminal (np $G $H $I $J $K $L $M) $N)) + (wh $C $B $G $H $I $D $E $F $N) + (trace1 $L $M)) + (= (variable $B $C $D $E $F (x gap nonterminal (pp (pp $G $H) compl $I $J) $K)) + (prep $G $D $L $F $M) + (wh $C $B $H $N $O $L $E $M $K) + (trace1 $I $J) + (compl-case $O)) - (= - (det $B $C $D $E $E $F $G) - (virtual - (det $B $C $D) $F $G)) -; - (= - (det - (det $B) $C $D $E $F $G $H) - ( (terminal $I $E $F $G $H) (det $I $C $B $D))) -; + (= (wh $B $C (np $C (wh $B) Nil) $C $D $E $F $G $H) + (rel-pron $I $E $F $G $H) + (role $I decl $D)) + (= (wh $B $C (np $D $E (:: (pp $F $G))) $D $H $I $J $K $L) + (np-head0 $E $D + (+ $M common) $I $N $K $O) + (prep $F $N $P $O $Q) + (wh $B $C $G $R $S $P $J $Q $L)) + (= (wh $B $C $D $E $F $G $H $I $J) + (whose $B $C $G $K $I $L) + (s-all $M) + (np $D $E $F def subj $M $N $K $H $L $J)) - (= - (det generic $B generic $C $C $D $D) True) -; + (= (reduced-relative $B $C $D $E $F $G $H $I) + (is-pred $D) + (reduced-rel-conj $B $J $C $E $F $G $H $I)) - (= - (int-art $B $C $D $E $F - (x nogap nonterminal - (det $G $C def) $H)) - (int-art $B $C $G $D $E $F $H)) -; + (= (reduced-rel-conj $B $C $D $E $F $G $H $I) + (reduced-rel $B $J $K $F $L $H $M) + (reduced-rel-rest $B $C $J $D $K $E $L $G $M $I)) - (= - (subj_question subj) True) -; + (= (reduced-rel-rest $B $C $D $E $F $G $H $I $J $K) + (conj $C $L $D $M $E $H $N $J $O) + (reduced-rel-conj $B $L $M $G $N $I $O $K)) + (= (reduced_rel_rest $B $C $D $D $E $E $F $F $G $G) True) - (= - (subj_question undef) True) -; + (= (reduced-rel $B (reduced-rel $C $D) $E $F $G $H $I) + (myopen $F $J $H $K) + (reduced-wh $B $C $J $L $K $M) + (s $D $N $L $O $M $P) + (trace1 $Q) + (minus $N $Q $E) + (close $O $G $P $I)) - (= - (yn-question - (q $B) $C $D $E $F) - ( (fronted-verb nil $G $C $H $E $I) (s $B $J $H $D $I $F))) -; + (= (reduced-wh $B $C $D $E $F (x nogap nonterminal (np (np $B (wh $C) Nil) $B $G $H $I $J $K) (x nogap nonterminal (verb-form be (+ pres fin) $B main) (x nogap nonterminal (neg $L $M) (x nogap nonterminal (predicate $M $N $O) $P))))) + (neg $Q $M $D $R $F $S) + (predicate $M $N $O $R $E $S $P) + (trace1 $J $K) + (subj-case $G)) + (= (reduced-wh $B $C $D $E $F (x nogap nonterminal (np (np $B (wh $C) Nil) $B $G $H $I $J $K) (x nogap nonterminal (verb $L $M $N $O) $P))) + (participle $L $N $O $D $E $F $P) + (trace1 $J $K) + (subj-case $G)) + (= (reduced-wh $B $C $D $E $F (x nogap nonterminal (np $G $H $I $J $K $L $M) (x gap nonterminal (np (np $B (wh $C) Nil) $B $N $O $P $Q $R) $S))) + (s-all $T) + (subj-case $I) + (verb-case $N) + (np $G $H $U $J subj $T $V $D $E $F $S) + (trace1 $L $M) + (trace1 $Q $R)) - (= - (verb-form $B $C $D $E $F $F $G $H) + (= (verb $B $C $D $E $F $F $G $H) (virtual - (verb-form $B $C $D $E) $G $H)) -; + (verb $B $C $D $E) $G $H)) + (= (verb (verb $B $C (+ $D fin) $E $F) $G $H $C $I $J $K $L) + (verb-form $M + (+ $D fin) $G $N $I $O $K $P) + (verb-type $M $Q) + (neg $Q $F $O $R $P $S) + (rest-verb $N $M $B $C $E $R $J $S $L) + (verb-type $B $H)) + + + + (= (rest-verb aux have $B $C (Cons perf $D) $E $F $G $H) + (verb-form $I + (+ past part) $J $K $E $L $G $M) + (have $I $B $C $D $L $F $M $H)) + (= (rest-verb aux be $B $C $D $E $F $G $H) + (verb-form $I $J $K $L $E $M $G $N) + (be $J $I $B $C $D $M $F $N $H)) + (= (rest-verb aux do $B active Nil $C $D $E $F) + (verb-form $B inf $G $H $C $D $E $F)) + (= (rest_verb main $B $B active () $C $C $D $D) True) - (= - (verb-form $B $C $D $E $F $G $H $I) - ( (terminal $J $F $G $H $I) (verb-form $J $B $C $D))) -; + (= (have be $B $C $D $E $F $G $H) + (verb-form $I $J $K $L $E $M $G $N) + (be $J $I $B $C $D $M $F $N $H)) + (= (have $B $B active () $C $C $D $D) True) - (= - (neg $B $C $D $D $E $F) - (virtual - (neg $B $C) $E $F)) -; - (= - (neg - (+ aux $B) neg $C $D $E $F) - (~ not $C $D $E $F)) -; + (= (be (+ past part) $B $B passive () $C $C $D $D) True) + (= (be (+ pres part) $B $C $D (:: prog) $E $F $G $H) + (passive $B $C $D $E $F $G $H)) - (= - (neg $B pos $C $C $D $D) True) -; + (= (passive be $B passive $C $D $E $F) + (verb-form $B + (+ past part) $G $H $C $D $E $F) + (verb-type $B $I) + (passive $I)) + (= (passive $B $B active $C $C $D $D) True) - (= - (fronted-verb $B $C $D $E $F - (x gap nonterminal - (verb-form $G $H $I $J) - (x nogap nonterminal - (neg $K $L) $M))) - ( (verb-form $G $H $I $N $D $O $F $P) - (verb-type $G - (+ aux $Q)) - (role $B $J $C) - (neg $R $L $O $E $P $M))) -; + (= (participle (verb $B $C inf $D $E) $F $C $G $H $I $J) + (neg $K $E $G $L $I $M) + (verb-form $B $N $O $P $L $H $M $J) + (participle $N $C $D) + (verb-type $B $F)) - (= - (imperative - (imp $B) $C $D $E $F) - ( (imperative-verb $C $G $E $H) (s $B $I $G $D $H $F))) -; + (= (passive (+ $B trans)) True) + (= (passive (+ $B ditrans)) True) + (= (participle (+ pres part) active (prog)) True) + (= (participle (+ past part) passive ()) True) - (= - (imperative-verb $B $C $D - (x nogap terminal you - (x nogap nonterminal - (verb-form $E - (+ imp fin) - (+ 2 sin) main) $F))) - (verb-form $E inf $G $H $B $C $D $F)) -; + (= (close $B $B $C $D) + (virtual close $C $D)) - (= - (s - (s $B $C $D $E) $F $G $H $I $J) - ( (subj $B $K $L $G $M $I $N) - (verb $C $K $L $O $M $P $N $Q) - (empty $R) - (s-all $S) - (verb-args $L $O $D $R $T $P $U $Q $V) - (minus $S $T $W) - (myplus $S $T $X) - (verb-mods $E $W $X $F $U $H $V $J))) -; + (= (myopen $B $B $C (x gap nonterminal close $C)) True) - (= - (subj there $B - (+ $C be) $D $E $F $G) - (~ there $D $E $F $G)) -; - - (= - (subj $B $C $D $E $F $G $H) - ( (s-all $I) - (subj-case $J) - (np $B $C $J $K subj $I $L $E $F $G $H))) -; - - - - - (= - (np-head $B $C $D $E $F $G $H $I $J) - ( (np-head0 $K $L $M $G $N $I $O) (possessive $K $L $M $P $P $B $C $D $E $F $N $H $O $J))) -; - - - - - (= - (np-head0 $B $C $D $E $E $F $G) - (virtual - (np-head0 $B $C $D) $F $G)) -; - - (= - (np-head0 - (name $B) - (+ 3 sin) - (+ def proper) $C $D $E $F) - (name $B $C $D $E $F)) -; - - (= - (np-head0 - (np-head $B $C $D) - (+ 3 $E) - (+ $F common) $G $H $I $J) - ( (determiner $B $E $F $G $K $I $L) - (adjs $C $K $M $L $N) - (noun $D $E $M $H $N $J))) -; - - (= - (np-head0 $B $C - (+ def proper) $D $E $F - (x nogap nonterminal gen-marker $G)) - (poss-pron $B $C $D $E $F $G)) -; - - (= - (np-head0 - (np-head $B Nil $C) - (+ 3 sin) - (+ indef common) $D $E $F $G) - (quantifier-pron $B $C $D $E $F $G)) -; - - - - - (= - (np-compls proper $B $C Nil $D $E $F $F $G $G) - (empty $E)) -; - - (= - (np-compls common $B $C $D $E $F $G $H $I $J) - ( (np-all $K) - (np-mods $B $C $L $D $E $M $K $N $G $O $I $P) - (relative $B $L $M $N $F $O $H $P $J))) -; - - - - - (= - (possessive $B $C $D Nil $E $F $G $H $I $J $K $L $M $N) - ( (gen-case $K $O $M $P) - (np-head0 $Q $R $S $O $T $P $U) - (possessive $Q $R $S $V - (Cons - (pp poss - (np $C $B $E)) $V) $F $G $H $I $J $T $L $U $N))) -; - - (= - (possessive $B $C $D $E $F $B $C $D $E $F $G $G $H $H) True) -; - - - - - (= - (gen-case $B $C $D - (x nogap terminal the $E)) - (gen-marker $B $C $D $E)) -; - - - - - (= - (an-s $B $C $D $E) - (~ s $B $C $D $E)) -; - - (= - (an_s $B $B $C $C) True) -; - - - - - (= - (determiner $B $C $D $E $F $G $H) - (det $B $C $D $E $F $G $H)) -; - - (= - (determiner $B $C $D $E $F $G $H) - (quant-phrase $B $C $D $E $F $G $H)) -; - - - - - (= - (quant-phrase - (quant $B $C) $D $E $F $G $H $I) - ( (quant $B $E $F $J $H $K) (number $C $D $J $G $K $I))) -; - - - - - (= - (quant $B indef $C $D $E $F) - ( (neg-adv $G $B $C $H $E $I) - (comp-adv $G $H $J $I $K) - (~ than $J $D $K $F))) -; - - (= - (quant $B indef $C $D $E $F) - ( (~ at $C $G $E $H) - (sup-adv $I $G $D $H $F) - (sup-op $I $B))) -; - - (= - (quant the def $B $C $D $E) - (~ the $B $C $D $E)) -; - - (= - (quant same indef $B $B $C $C) True) -; - - - - - (= - (neg-adv $B - (+ not $B) $C $D $E $F) - (~ not $C $D $E $F)) -; - - (= - (neg_adv $B $B $C $C $D $D) True) -; - - - - - (= - (sup_op least - (+ not less)) True) -; - - (= - (sup_op most - (+ not more)) True) -; - - - - - (= - (np-mods $B $C $D - (Cons $E $F) $G $H $I $J $K $L $M $N) - ( (np-mod $B $C $E $G $O $K $P $M $Q) - (trace1 $R) - (myplus $R $O $S) - (minus $G $S $T) - (myplus $O $G $U) - (np-mods $B $C $D $F $T $H $U $J $P $L $Q $N))) -; - - (= - (np_mods $B $C $D $D $E $E $F $F $G $G $H $H) True) -; - - - - - (= - (np-mod $B $C $D $E $F $G $H $I $J) - (pp $D $C $E $F $G $H $I $J)) -; - - (= - (np-mod $B $C $D $E $F $G $H $I $J) - (reduced-relative $B $D $E $F $G $H $I $J)) -; - - - - - (= - (verb-mods - (Cons $B $C) $D $E $F $G $H $I $J) - ( (verb-mod $B $D $K $G $L $I $M) - (trace1 $N) - (myplus $N $K $O) - (minus $D $O $P) - (myplus $K $D $Q) - (verb-mods $C $P $Q $F $L $H $M $J))) -; - - (= - (verb_mods () $B $C $C $D $D $E $E) True) -; - - - - - (= - (verb-mod $B $C $D $E $F $G $H) - (adv-phrase $B $C $D $E $F $G $H)) -; - - (= - (verb-mod $B $C $D $E $F $G $H) - ( (is-adv $C) - (adverb $B $E $F $G $H) - (empty $D))) -; - - (= - (verb-mod $B $C $D $E $F $G $H) - (pp $B compl $C $D $E $F $G $H)) -; - - - - - (= - (adjs - (Cons $B $C) $D $E $F $G) - ( (pre-adj $B $D $H $F $I) (adjs $C $H $E $I $G))) -; - - (= - (adjs () $B $B $C $C) True) -; - - - - - (= - (pre-adj $B $C $D $E $F) - (adj $G $B $C $D $E $F)) -; - - (= - (pre-adj $B $C $D $E $F) - (sup-phrase $B $C $D $E $F)) -; - - - - - (= - (sup-phrase - (sup most $B) $C $D $E $F) - (sup-adj $B $C $D $E $F)) -; - - (= - (sup-phrase - (sup $B $C) $D $E $F $G) - ( (sup-adv $B $D $I $F $J) (adj quant $C $I $E $J $G))) -; - - - - - (= - (comp-phrase - (comp $B $C $D) $E $F $G $H $I) - ( (comp $B $C $F $J $H $K) - (np-no-trace $L) - (prep-case $M) - (np $D $N $M $O compl $L $E $J $G $K $I))) -; - - - - - (= - (comp $B $C $D $E $F $G) - ( (comp-adv $B $D $H $F $I) - (adj quant $C $H $J $I $K) - (~ than $J $E $K $G))) -; - - (= - (comp more $B $C $D $E $F) - ( (rel-adj $B $C $G $E $H) (~ than $G $D $H $F))) -; - - (= - (comp same $B $C $D $E $F) - ( (~ as $C $G $E $H) - (adj quant $B $G $I $H $J) - (~ as $I $D $J $F))) -; - - - - - (= - (relative $B - (:: $C) $D $E $F $G $H $I $J) - ( (is-pred $D) (rel-conj $B $K $C $F $G $H $I $J))) -; - - (= - (relative $B () $C $D $D $E $E $F $F) True) -; - - - - - (= - (rel-conj $B $C $D $E $F $G $H $I) - ( (rel $B $J $K $F $L $H $M) (rel-rest $B $C $J $D $K $E $L $G $M $I))) -; - - - - - (= - (rel-rest $B $C $D $E $F $G $H $I $J $K) - ( (conj $C $L $D $M $E $H $N $J $O) (rel-conj $B $L $M $G $N $I $O $K))) -; - - (= - (rel_rest $B $C $D $D $E $E $F $F $G $G) True) -; - - - - - (= - (rel $B - (rel $C $D) $E $F $G $H $I) - ( (myopen $F $J $H $K) - (variable $B $C $J $L $K $M) - (s $D $N $L $O $M $P) - (trace1 $Q) - (minus $N $Q $E) - (close $O $G $P $I))) -; - - - - - (= - (variable $B $C $D $E $F - (x gap nonterminal - (np - (np $B - (wh $C) Nil) $B $G $H $I $J $K) $L)) - ( (~ that $D $E $F $L) (trace1 $J $K))) -; - - (= - (variable $B $C $D $E $F - (x gap nonterminal - (np $G $H $I $J $K $L $M) $N)) - ( (wh $C $B $G $H $I $D $E $F $N) (trace1 $L $M))) -; - - (= - (variable $B $C $D $E $F - (x gap nonterminal - (pp - (pp $G $H) compl $I $J) $K)) - ( (prep $G $D $L $F $M) - (wh $C $B $H $N $O $L $E $M $K) - (trace1 $I $J) - (compl-case $O))) -; - - - - - (= - (wh $B $C - (np $C - (wh $B) Nil) $C $D $E $F $G $H) - ( (rel-pron $I $E $F $G $H) (role $I decl $D))) -; - - (= - (wh $B $C - (np $D $E - (:: (pp $F $G))) $D $H $I $J $K $L) - ( (np-head0 $E $D - (+ $M common) $I $N $K $O) - (prep $F $N $P $O $Q) - (wh $B $C $G $R $S $P $J $Q $L))) -; - - (= - (wh $B $C $D $E $F $G $H $I $J) - ( (whose $B $C $G $K $I $L) - (s-all $M) - (np $D $E $F def subj $M $N $K $H $L $J))) -; - - - - - (= - (reduced-relative $B $C $D $E $F $G $H $I) - ( (is-pred $D) (reduced-rel-conj $B $J $C $E $F $G $H $I))) -; - - - - - (= - (reduced-rel-conj $B $C $D $E $F $G $H $I) - ( (reduced-rel $B $J $K $F $L $H $M) (reduced-rel-rest $B $C $J $D $K $E $L $G $M $I))) -; - - - - - (= - (reduced-rel-rest $B $C $D $E $F $G $H $I $J $K) - ( (conj $C $L $D $M $E $H $N $J $O) (reduced-rel-conj $B $L $M $G $N $I $O $K))) -; - - (= - (reduced_rel_rest $B $C $D $D $E $E $F $F $G $G) True) -; - - - - - (= - (reduced-rel $B - (reduced-rel $C $D) $E $F $G $H $I) - ( (myopen $F $J $H $K) - (reduced-wh $B $C $J $L $K $M) - (s $D $N $L $O $M $P) - (trace1 $Q) - (minus $N $Q $E) - (close $O $G $P $I))) -; - - - - - (= - (reduced-wh $B $C $D $E $F - (x nogap nonterminal - (np - (np $B - (wh $C) Nil) $B $G $H $I $J $K) - (x nogap nonterminal - (verb-form be - (+ pres fin) $B main) - (x nogap nonterminal - (neg $L $M) - (x nogap nonterminal - (predicate $M $N $O) $P))))) - ( (neg $Q $M $D $R $F $S) - (predicate $M $N $O $R $E $S $P) - (trace1 $J $K) - (subj-case $G))) -; - - (= - (reduced-wh $B $C $D $E $F - (x nogap nonterminal - (np - (np $B - (wh $C) Nil) $B $G $H $I $J $K) - (x nogap nonterminal - (verb $L $M $N $O) $P))) - ( (participle $L $N $O $D $E $F $P) - (trace1 $J $K) - (subj-case $G))) -; - - (= - (reduced-wh $B $C $D $E $F - (x nogap nonterminal - (np $G $H $I $J $K $L $M) - (x gap nonterminal - (np - (np $B - (wh $C) Nil) $B $N $O $P $Q $R) $S))) - ( (s-all $T) - (subj-case $I) - (verb-case $N) - (np $G $H $U $J subj $T $V $D $E $F $S) - (trace1 $L $M) - (trace1 $Q $R))) -; - - - - - (= - (verb $B $C $D $E $F $F $G $H) - (virtual - (verb $B $C $D $E) $G $H)) -; - - (= - (verb - (verb $B $C - (+ $D fin) $E $F) $G $H $C $I $J $K $L) - ( (verb-form $M - (+ $D fin) $G $N $I $O $K $P) - (verb-type $M $Q) - (neg $Q $F $O $R $P $S) - (rest-verb $N $M $B $C $E $R $J $S $L) - (verb-type $B $H))) -; - - - - - (= - (rest-verb aux have $B $C - (Cons perf $D) $E $F $G $H) - ( (verb-form $I - (+ past part) $J $K $E $L $G $M) (have $I $B $C $D $L $F $M $H))) -; - - (= - (rest-verb aux be $B $C $D $E $F $G $H) - ( (verb-form $I $J $K $L $E $M $G $N) (be $J $I $B $C $D $M $F $N $H))) -; - - (= - (rest-verb aux do $B active Nil $C $D $E $F) - (verb-form $B inf $G $H $C $D $E $F)) -; - - (= - (rest_verb main $B $B active () $C $C $D $D) True) -; - - - - - (= - (have be $B $C $D $E $F $G $H) - ( (verb-form $I $J $K $L $E $M $G $N) (be $J $I $B $C $D $M $F $N $H))) -; - - (= - (have $B $B active () $C $C $D $D) True) -; - - - - - (= - (be - (+ past part) $B $B passive () $C $C $D $D) True) -; - - (= - (be - (+ pres part) $B $C $D - (:: prog) $E $F $G $H) - (passive $B $C $D $E $F $G $H)) -; - - - - - (= - (passive be $B passive $C $D $E $F) - ( (verb-form $B - (+ past part) $G $H $C $D $E $F) - (verb-type $B $I) - (passive $I))) -; - - (= - (passive $B $B active $C $C $D $D) True) -; - - - - - (= - (participle - (verb $B $C inf $D $E) $F $C $G $H $I $J) - ( (neg $K $E $G $L $I $M) - (verb-form $B $N $O $P $L $H $M $J) - (participle $N $C $D) - (verb-type $B $F))) -; - - - - - (= - (passive - (+ $B trans)) True) -; - - (= - (passive - (+ $B ditrans)) True) -; - - - - - (= - (participle - (+ pres part) active - (prog)) True) -; - - (= - (participle - (+ past part) passive ()) True) -; - - - - - (= - (close $B $B $C $D) - (virtual close $C $D)) -; - - - - - (= - (myopen $B $B $C - (x gap nonterminal close $C)) True) -; - - - - - (= - (verb-args - (+ $B $C) $D $E $F $G $H $I $J $K) - ( (advs $E $L $M $H $N $J $O) (verb-args $C $D $L $F $G $N $I $O $K))) -; - - (= - (verb-args trans active - (:: (arg dir $B)) $C $D $E $F $G $H) - (verb-arg np $B $D $E $F $G $H)) -; - - (= - (verb-args ditrans $B - (Cons - (arg $C $D) $E) $F $G $H $I $J $K) - ( (verb-arg np $D $L $H $M $J $N) (object $C $E $L $G $M $I $N $K))) -; - - (= - (verb-args be $B - (:: void) $C $C $D $E $F $G) - (terminal there $D $E $F $G)) -; - - (= - (verb-args be $B - (:: (arg predicate $C)) $D $E $F $G $H $I) - (pred-conj $J $C $E $F $G $H $I)) -; - - (= - (verb-args be $B - (:: (arg dir $C)) $D $E $F $G $H $I) - (verb-arg np $C $E $F $G $H $I)) -; - - (= - (verb-args have active - (:: (arg dir $B)) $C $D $E $F $G $H) - (verb-arg np $B $D $E $F $G $H)) -; - - (= - (verb-args $B $C Nil $D $D $E $E $F $F) - (no-args $B)) -; - - - - - (= - (object $B $C $D $E $F $G $H $I) - ( (adv $J) - (minus $J $D $K) - (advs $C $L $K $F $M $H $N) - (obj $B $L $D $E $M $G $N $I))) -; - - - - - (= - (obj ind - (:: (arg dir $B)) $C $D $E $F $G $H) - (verb-arg np $B $D $E $F $G $H)) -; - - (= - (obj dir () $B $B $C $C $D $D) True) -; - - - - - (= - (pred-conj $B $C $D $E $F $G $H) - ( (predicate $I $J $K $E $L $G $M) (pred-rest $B $J $C $K $D $L $F $M $H))) -; - - - - - (= - (pred-rest $B $C $D $E $F $G $H $I $J) - ( (conj $B $K $C $L $D $G $M $I $N) (pred-conj $K $L $F $M $H $N $J))) -; - - (= - (pred_rest $B $C $C $D $D $E $E $F $F) True) -; - - - - - (= - (verb-arg np $B $C $D $E $F $G) - ( (s-all $H) - (verb-case $I) - (np $B $J $I $K compl $H $C $D $E $F $G))) -; - - - - - (= - (advs - (Cons $B $C) $D $E $F $G $H $I) - ( (is-adv $E) - (adverb $B $F $J $H $K) - (advs $C $D $E $J $G $K $I))) -; - - (= - (advs $B $B $C $D $D $E $E) True) -; - - - - - (= - (adj-phrase $B $C $D $E $F $G) - ( (adj $H $B $D $E $F $G) (empty $C))) -; - - (= - (adj-phrase $B $C $D $E $F $G) - (comp-phrase $B $C $D $E $F $G)) -; - - - - - (= - (no_args trans) True) -; - - (= - (no_args ditrans) True) -; - - (= - (no_args intrans) True) -; - - - - - (= - (conj - (conj $B $C) - (conj $B $D) $E $F - (conj $B $E $F) $G $H $I $J) - (conj $B $C $D $G $H $I $J)) -; - - - - - (= - (noun $B $C $D $E $F $G) - ( (terminal $H $D $E $F $G) (noun-form $H $B $C))) -; - - - - - (= - (adj $B - (adj $C) $D $E $F $G) - ( (terminal $C $D $E $F $G) (adj $C $B))) -; - - - - - (= - (prep - (prep $B) $C $D $E $F) - ( (terminal $B $C $D $E $F) (prep $B))) -; - - - - - (= - (rel-adj - (adj $B) $C $D $E $F) - ( (terminal $G $C $D $E $F) (rel-adj $G $B))) -; - - - - - (= - (sup-adj - (adj $B) $C $D $E $F) - ( (terminal $G $C $D $E $F) (sup-adj $G $B))) -; - - - - - (= - (comp-adv less $B $C $D $E) - (~ less $B $C $D $E)) -; - - (= - (comp-adv more $B $C $D $E) - (~ more $B $C $D $E)) -; - - - - - (= - (sup-adv least $B $C $D $E) - (~ least $B $C $D $E)) -; - - (= - (sup-adv most $B $C $D $E) - (~ most $B $C $D $E)) -; - - - - - (= - (rel-pron $B $C $D $E $F) - ( (terminal $G $C $D $E $F) (rel-pron $G $B))) -; - - - - - (= - (name $B $C $D $E $F) - ( (opt-the $C $G $E $H) - (terminal $B $G $D $H $F) - (name $B))) -; - - - - - (= - (int-art $B plu - (quant same - (wh $B)) $C $D $E $F) - ( (~ how $C $G $E $H) (~ many $G $D $H $F))) -; - - (= - (int-art $B $C $D $E $F $G $H) - ( (terminal $I $E $F $G $H) (int-art $I $B $C $D))) -; - - - - - (= - (int-pron $B $C $D $E $F) - ( (terminal $G $C $D $E $F) (int-pron $G $B))) -; - - - - - (= - (adverb - (adv $B) $C $D $E $F) - ( (terminal $B $C $D $E $F) (adverb $B))) -; - - - - - (= - (poss-pron - (pronoun $B) - (+ $C $D) $E $F $G $H) - ( (terminal $I $E $F $G $H) (poss-pron $I $B $C $D))) -; - - - - - (= - (pers-pron - (pronoun $B) - (+ $C $D) $E $F $G $H $I) - ( (terminal $J $F $G $H $I) (pers-pron $J $B $C $D $E))) -; - - - - - (= - (quantifier-pron $B $C $D $E $F $G) - ( (terminal $H $D $E $F $G) (quantifier-pron $H $B $C))) -; - - - - - (= - (context-pron - (prep in) place $B $C $D $E) - (~ where $B $C $D $E)) -; - - (= - (context-pron - (prep at) time $B $C $D $E) - (~ when $B $C $D $E)) -; - - - - - (= - (number - (nb $B) $C $D $E $F $G) - ( (terminal $H $D $E $F $G) (number $H $B $C))) -; - - - - - (= - (terminator $B $C $D $E $F) - ( (terminal $G $C $D $E $F) (terminator $G $B))) -; - - - - - (= - (opt_the $B $B $C $C) True) -; - - (= - (opt-the $B $C $D $E) - (~ the $B $C $D $E)) -; - - - - - (= - (conj $B list list $C $D $E $F) - (terminal , $C $D $E $F)) -; - - (= - (conj $B list end $C $D $E $F) - ( (terminal $B $C $D $E $F) (conj $B))) -; - - - - - (= - (loc-pred $B $C $D $E $F) - ( (terminal $G $C $D $E $F) (loc-pred $G $B))) -; - - - - - (= - (~ $B $C $D $E $F) - ( (terminal $B $C $D $E $F) (~ $B))) -; - - - -; -; - -; -; - -; -; - -; -; - -; -; - - - - (= - (word $Word) - (~ $Word)) -; - - (= - (word $Word) - (conj $Word)) -; - - (= - (word $Word) - (adverb $Word)) -; - - (= - (word $Word) - (sup-adj $Word $_)) -; - - (= - (word $Word) - (rel-adj $Word $_)) -; - - (= - (word $Word) - (adj $Word $_)) -; - - (= - (word $Word) - (name $Word)) -; - - (= - (word $Word) - (terminator $Word $_)) -; - - (= - (word $Word) - (pers-pron $Word $_ $_ $_ $_)) -; - - (= - (word $Word) - (poss-pron $Word $_ $_ $_)) -; - - (= - (word $Word) - (rel-pron $Word $_)) -; - - (= - (word $Word) - (verb-form $Word $_ $_ $_)) -; - - (= - (word $Word) - (noun-form $Word $_ $_)) -; - - (= - (word $Word) - (prep $Word)) -; - - (= - (word $Word) - (quantifier-pron $Word $_ $_)) -; - - (= - (word $Word) - (number $Word $_ $_)) -; - - (= - (word $Word) - (det $Word $_ $_ $_)) -; - - (= - (word $Word) - (int-art $Word $_ $_ $_)) -; - - (= - (word $Word) - (int-pron $Word $_)) -; - - (= - (word $Word) - (loc-pred $Word $_)) -; - - - - (= - (~ how) True) -; - - (= - (~ whose) True) -; - - (= - (~ there) True) -; - - (= - (~ of) True) -; - - (= - (~ ~) True) -; - ; -; - - (= - (~ ,) True) -; - - (= - (~ s) True) -; - - (= - (~ than) True) -; - - (= - (~ at) True) -; - - (= - (~ the) True) -; - - (= - (~ not) True) -; - - (= - (~ as) True) -; - - (= - (~ that) True) -; - - (= - (~ less) True) -; - - (= - (~ more) True) -; - - (= - (~ least) True) -; - - (= - (~ most) True) -; - - (= - (~ many) True) -; - - (= - (~ where) True) -; - - (= - (~ when) True) -; - - - - (= - (conj and) True) -; - - (= - (conj or) True) -; - - - - (= - (int_pron what undef) True) -; - - (= - (int_pron which undef) True) -; - - (= - (int_pron who subj) True) -; - - (= - (int_pron whom compl) True) -; - - - - (= - (int_art what $X $_ - (int_det $X)) True) -; - - (= - (int_art which $X $_ - (int_det $X)) True) -; - - - - (= - (det the $No - (the $No) def) True) -; - - (= - (det a sin a indef) True) -; - - (= - (det an sin a indef) True) -; - - (= - (det every sin every indef) True) -; - - (= - (det some $_ some indef) True) -; - - (= - (det any $_ any indef) True) -; - - (= - (det all plu all indef) True) -; - - (= - (det each sin each indef) True) -; - - (= - (det no $_ no indef) True) -; - - - - (= - (number $W $I $Nb) - ( (tr-number $W $I) (ag-number $I $Nb))) -; - - - - (= - (tr_number - (nb $I) $I) True) -; - - (= - (tr_number one 1) True) -; - - (= - (tr_number two 2) True) -; - - (= - (tr_number three 3) True) -; - - (= - (tr_number four 4) True) -; - - (= - (tr_number five 5) True) -; - - (= - (tr_number six 6) True) -; - - (= - (tr_number seven 7) True) -; - - (= - (tr_number eight 8) True) -; - - (= - (tr_number nine 9) True) -; - - (= - (tr_number ten 10) True) -; - - - - (= - (ag_number 1 sin) True) -; - - (= - (ag-number $N plu) - (> $N 1)) -; - - - - (= - (quantifier_pron everybody every person) True) -; - - (= - (quantifier_pron everyone every person) True) -; - - (= - (quantifier_pron everything every thing) True) -; - - (= - (quantifier_pron somebody some person) True) -; - - (= - (quantifier_pron someone some person) True) -; - - (= - (quantifier_pron something some thing) True) -; - - (= - (quantifier_pron anybody any person) True) -; - - (= - (quantifier_pron anyone any person) True) -; - - (= - (quantifier_pron anything any thing) True) -; - - (= - (quantifier_pron nobody no person) True) -; - - (= - (quantifier_pron nothing no thing) True) -; - - - - (= - (prep as) True) -; - - (= - (prep at) True) -; - - (= - (prep of) True) -; - - (= - (prep to) True) -; - - (= - (prep by) True) -; - - (= - (prep with) True) -; - - (= - (prep in) True) -; - - (= - (prep on) True) -; - - (= - (prep from) True) -; - - (= - (prep into) True) -; - - (= - (prep through) True) -; - - - - (= - (noun-form $Plu $Sin plu) - (noun-plu $Plu $Sin)) -; - - (= - (noun-form $Sin $Sin sin) - (noun-sin $Sin)) -; - - (= - (noun_form proportion proportion $_) True) -; - - (= - (noun_form percentage percentage $_) True) -; - - - - (= - (root_form - (+ 1 sin)) True) -; - - (= - (root_form - (+ 2 $_)) True) -; - - (= - (root_form - (+ 1 plu)) True) -; - - (= - (root_form - (+ 3 plu)) True) -; - - - - (= - (verb_root be) True) -; - - (= - (verb_root have) True) -; - - (= - (verb_root do) True) -; - - (= - (verb_root border) True) -; - - (= - (verb_root contain) True) -; - - (= - (verb_root drain) True) -; - - (= - (verb_root exceed) True) -; - - (= - (verb_root flow) True) -; - - (= - (verb_root rise) True) -; - - - - (= - (regular_pres have) True) -; - - (= - (regular_pres do) True) -; - - (= - (regular_pres rise) True) -; - - (= - (regular_pres border) True) -; - - (= - (regular_pres contain) True) -; - - (= - (regular_pres drain) True) -; - - (= - (regular_pres exceed) True) -; - - (= - (regular_pres flow) True) -; - - - - (= - (regular_past had have) True) -; - - (= - (regular_past bordered border) True) -; - - (= - (regular_past contained contain) True) -; - - (= - (regular_past drained drain) True) -; - - (= - (regular_past exceeded exceed) True) -; - - (= - (regular_past flowed flow) True) -; - - - - (= - (rel_pron who subj) True) -; - - (= - (rel_pron whom compl) True) -; - - (= - (rel_pron which undef) True) -; - - - - (= - (poss_pron my $_ 1 sin) True) -; - - (= - (poss_pron your $_ 2 $_) True) -; - - (= - (poss_pron his masc 3 sin) True) -; - - (= - (poss_pron her fem 3 sin) True) -; - - (= - (poss_pron its neut 3 sin) True) -; - - (= - (poss_pron our $_ 1 plu) True) -; - - (= - (poss_pron their $_ 3 plu) True) -; + (= (verb-args (+ $B $C) $D $E $F $G $H $I $J $K) + (advs $E $L $M $H $N $J $O) + (verb-args $C $D $L $F $G $N $I $O $K)) + (= (verb-args trans active (:: (arg dir $B)) $C $D $E $F $G $H) + (verb-arg np $B $D $E $F $G $H)) + (= (verb-args ditrans $B (Cons (arg $C $D) $E) $F $G $H $I $J $K) + (verb-arg np $D $L $H $M $J $N) + (object $C $E $L $G $M $I $N $K)) + (= (verb-args be $B (:: void) $C $C $D $E $F $G) + (terminal there $D $E $F $G)) + (= (verb-args be $B (:: (arg predicate $C)) $D $E $F $G $H $I) + (pred-conj $J $C $E $F $G $H $I)) + (= (verb-args be $B (:: (arg dir $C)) $D $E $F $G $H $I) + (verb-arg np $C $E $F $G $H $I)) + (= (verb-args have active (:: (arg dir $B)) $C $D $E $F $G $H) + (verb-arg np $B $D $E $F $G $H)) + (= (verb-args $B $C Nil $D $D $E $E $F $F) + (no-args $B)) - (= - (pers_pron i $_ 1 sin subj) True) -; + (= (object $B $C $D $E $F $G $H $I) + (adv $J) + (minus $J $D $K) + (advs $C $L $K $F $M $H $N) + (obj $B $L $D $E $M $G $N $I)) - (= - (pers_pron you $_ 2 $_ $_) True) -; - (= - (pers_pron he masc 3 sin subj) True) -; - (= - (pers_pron she fem 3 sin subj) True) -; + (= (obj ind (:: (arg dir $B)) $C $D $E $F $G $H) + (verb-arg np $B $D $E $F $G $H)) + (= (obj dir () $B $B $C $C $D $D) True) - (= - (pers_pron it neut 3 sin $_) True) -; - (= - (pers_pron we $_ 1 plu subj) True) -; - (= - (pers_pron them $_ 3 plu subj) True) -; + (= (pred-conj $B $C $D $E $F $G $H) + (predicate $I $J $K $E $L $G $M) + (pred-rest $B $J $C $K $D $L $F $M $H)) - (= - (pers_pron me $_ 1 sin - (compl $_)) True) -; - (= - (pers_pron him masc 3 sin - (compl $_)) True) -; - (= - (pers_pron her fem 3 sin - (compl $_)) True) -; + (= (pred-rest $B $C $D $E $F $G $H $I $J) + (conj $B $K $C $L $D $G $M $I $N) + (pred-conj $K $L $F $M $H $N $J)) + (= (pred_rest $B $C $C $D $D $E $E $F $F) True) - (= - (pers_pron us $_ 1 plu - (compl $_)) True) -; - (= - (pers_pron them $_ 3 plu - (compl $_)) True) -; + (= (verb-arg np $B $C $D $E $F $G) + (s-all $H) + (verb-case $I) + (np $B $J $I $K compl $H $C $D $E $F $G)) - (= - (terminator . $_) True) -; - (= - (terminator ? ?) True) -; + (= (advs (Cons $B $C) $D $E $F $G $H $I) + (is-adv $E) + (adverb $B $F $J $H $K) + (advs $C $D $E $J $G $K $I)) + (= (advs $B $B $C $D $D $E $E) True) - (= - (terminator ! !) True) -; + (= (adj-phrase $B $C $D $E $F $G) + (adj $H $B $D $E $F $G) + (empty $C)) + (= (adj-phrase $B $C $D $E $F $G) + (comp-phrase $B $C $D $E $F $G)) - (= - (name $_) True) -; -; -; + (= (no_args trans) True) + (= (no_args ditrans) True) + (= (no_args intrans) True) -; -; + (= (conj (conj $B $C) (conj $B $D) $E $F (conj $B $E $F) $G $H $I $J) + (conj $B $C $D $G $H $I $J)) - (= - (loc_pred east - (prep eastof)) True) -; - (= - (loc_pred west - (prep westof)) True) -; + (= (noun $B $C $D $E $F $G) + (terminal $H $D $E $F $G) + (noun-form $H $B $C)) - (= - (loc_pred north - (prep northof)) True) -; - (= - (loc_pred south - (prep southof)) True) -; + (= (adj $B (adj $C) $D $E $F $G) + (terminal $C $D $E $F $G) + (adj $C $B)) - (= - (adj minimum restr) True) -; - (= - (adj maximum restr) True) -; + (= (prep (prep $B) $C $D $E $F) + (terminal $B $C $D $E $F) + (prep $B)) - (= - (adj average restr) True) -; - (= - (adj total restr) True) -; - (= - (adj african restr) True) -; + (= (rel-adj (adj $B) $C $D $E $F) + (terminal $G $C $D $E $F) + (rel-adj $G $B)) - (= - (adj american restr) True) -; - (= - (adj asian restr) True) -; - (= - (adj european restr) True) -; + (= (sup-adj (adj $B) $C $D $E $F) + (terminal $G $C $D $E $F) + (sup-adj $G $B)) - (= - (adj great quant) True) -; - (= - (adj big quant) True) -; - (= - (adj small quant) True) -; + (= (comp-adv less $B $C $D $E) + (~ less $B $C $D $E)) + (= (comp-adv more $B $C $D $E) + (~ more $B $C $D $E)) - (= - (adj large quant) True) -; - (= - (adj old quant) True) -; - (= - (adj new quant) True) -; + (= (sup-adv least $B $C $D $E) + (~ least $B $C $D $E)) + (= (sup-adv most $B $C $D $E) + (~ most $B $C $D $E)) - (= - (adj populous quant) True) -; + (= (rel-pron $B $C $D $E $F) + (terminal $G $C $D $E $F) + (rel-pron $G $B)) - (= - (rel_adj greater great) True) -; - (= - (rel_adj less small) True) -; - (= - (rel_adj bigger big) True) -; + (= (name $B $C $D $E $F) + (opt-the $C $G $E $H) + (terminal $B $G $D $H $F) + (name $B)) - (= - (rel_adj smaller small) True) -; - (= - (rel_adj larger large) True) -; - (= - (rel_adj older old) True) -; + (= (int-art $B plu (quant same (wh $B)) $C $D $E $F) + (~ how $C $G $E $H) + (~ many $G $D $H $F)) + (= (int-art $B $C $D $E $F $G $H) + (terminal $I $E $F $G $H) + (int-art $I $B $C $D)) - (= - (rel_adj newer new) True) -; + (= (int-pron $B $C $D $E $F) + (terminal $G $C $D $E $F) + (int-pron $G $B)) - (= - (sup_adj biggest big) True) -; - (= - (sup_adj smallest small) True) -; - (= - (sup_adj largest large) True) -; + (= (adverb (adv $B) $C $D $E $F) + (terminal $B $C $D $E $F) + (adverb $B)) - (= - (sup_adj oldest old) True) -; - (= - (sup_adj newest new) True) -; + (= (poss-pron (pronoun $B) (+ $C $D) $E $F $G $H) + (terminal $I $E $F $G $H) + (poss-pron $I $B $C $D)) - (= - (noun_sin average) True) -; - (= - (noun_sin total) True) -; + (= (pers-pron (pronoun $B) (+ $C $D) $E $F $G $H $I) + (terminal $J $F $G $H $I) + (pers-pron $J $B $C $D $E)) - (= - (noun_sin sum) True) -; - (= - (noun_sin degree) True) -; - (= - (noun_sin sqmile) True) -; + (= (quantifier-pron $B $C $D $E $F $G) + (terminal $H $D $E $F $G) + (quantifier-pron $H $B $C)) - (= - (noun_sin ksqmile) True) -; - (= - (noun_sin thousand) True) -; - (= - (noun_sin million) True) -; + (= (context-pron (prep in) place $B $C $D $E) + (~ where $B $C $D $E)) + (= (context-pron (prep at) time $B $C $D $E) + (~ when $B $C $D $E)) - (= - (noun_sin time) True) -; - (= - (noun_sin place) True) -; - (= - (noun_sin area) True) -; + (= (number (nb $B) $C $D $E $F $G) + (terminal $H $D $E $F $G) + (number $H $B $C)) - (= - (noun_sin capital) True) -; - (= - (noun_sin city) True) -; - (= - (noun_sin continent) True) -; + (= (terminator $B $C $D $E $F) + (terminal $G $C $D $E $F) + (terminator $G $B)) - (= - (noun_sin country) True) -; - (= - (noun_sin latitude) True) -; - (= - (noun_sin longitude) True) -; + (= (opt_the $B $B $C $C) True) + (= (opt-the $B $C $D $E) + (~ the $B $C $D $E)) - (= - (noun_sin ocean) True) -; - (= - (noun_sin person) True) -; - (= - (noun_sin population) True) -; + (= (conj $B list list $C $D $E $F) + (terminal , $C $D $E $F)) + (= (conj $B list end $C $D $E $F) + (terminal $B $C $D $E $F) + (conj $B)) - (= - (noun_sin region) True) -; - (= - (noun_sin river) True) -; - (= - (noun_sin sea) True) -; + (= (loc-pred $B $C $D $E $F) + (terminal $G $C $D $E $F) + (loc-pred $G $B)) - (= - (noun_sin seamass) True) -; - (= - (noun_sin number) True) -; + (= (~ $B $C $D $E $F) + (terminal $B $C $D $E $F) + (~ $B)) - (= - (noun_plu averages average) True) +; +; ---------------------------------------------------------------------------- +; ; - - (= - (noun_plu totals total) True) +; +; newdic +; ; +; +; ---------------------------------------------------------------------------- - (= - (noun_plu sums sum) True) -; - (= - (noun_plu degrees degree) True) -; + (= (word $Word) + (~ $Word)) + (= (word $Word) + (conj $Word)) + (= (word $Word) + (adverb $Word)) + (= (word $Word) + (sup-adj $Word $_)) + (= (word $Word) + (rel-adj $Word $_)) + (= (word $Word) + (adj $Word $_)) + (= (word $Word) + (name $Word)) + (= (word $Word) + (terminator $Word $_)) + (= (word $Word) + (pers-pron $Word $_ $_ $_ $_)) + (= (word $Word) + (poss-pron $Word $_ $_ $_)) + (= (word $Word) + (rel-pron $Word $_)) + (= (word $Word) + (verb-form $Word $_ $_ $_)) + (= (word $Word) + (noun-form $Word $_ $_)) + (= (word $Word) + (prep $Word)) + (= (word $Word) + (quantifier-pron $Word $_ $_)) + (= (word $Word) + (number $Word $_ $_)) + (= (word $Word) + (det $Word $_ $_ $_)) + (= (word $Word) + (int-art $Word $_ $_ $_)) + (= (word $Word) + (int-pron $Word $_)) + (= (word $Word) + (loc-pred $Word $_)) - (= - (noun_plu sqmiles sqmile) True) -; - (= - (noun_plu ksqmiles ksqmile) True) -; + (= (~ how) True) + (= (~ whose) True) + (= (~ there) True) + (= (~ of) True) + (= (~ ~) True) ; +; use ~ instead of ' to help assembler + (= (~ ,) True) + (= (~ s) True) + (= (~ than) True) + (= (~ at) True) + (= (~ the) True) + (= (~ not) True) + (= (~ as) True) + (= (~ that) True) + (= (~ less) True) + (= (~ more) True) + (= (~ least) True) + (= (~ most) True) + (= (~ many) True) + (= (~ where) True) + (= (~ when) True) + + + (= (conj and) True) + (= (conj or) True) + + + (= (int_pron what undef) True) + (= (int_pron which undef) True) + (= (int_pron who subj) True) + (= (int_pron whom compl) True) + + + (= (int_art what $X $_ (int_det $X)) True) + (= (int_art which $X $_ (int_det $X)) True) + + + (= (det the $No (the $No) def) True) + (= (det a sin a indef) True) + (= (det an sin a indef) True) + (= (det every sin every indef) True) + (= (det some $_ some indef) True) + (= (det any $_ any indef) True) + (= (det all plu all indef) True) + (= (det each sin each indef) True) + (= (det no $_ no indef) True) + + + (= (number $W $I $Nb) + (tr-number $W $I) + (ag-number $I $Nb)) + + + (= (tr_number (nb $I) $I) True) + (= (tr_number one 1) True) + (= (tr_number two 2) True) + (= (tr_number three 3) True) + (= (tr_number four 4) True) + (= (tr_number five 5) True) + (= (tr_number six 6) True) + (= (tr_number seven 7) True) + (= (tr_number eight 8) True) + (= (tr_number nine 9) True) + (= (tr_number ten 10) True) + + + (= (ag_number 1 sin) True) + (= (ag-number $N plu) + (> $N 1)) - (= - (noun_plu million million) True) -; - (= - (noun_plu thousand thousand) True) -; + (= (quantifier_pron everybody every person) True) + (= (quantifier_pron everyone every person) True) + (= (quantifier_pron everything every thing) True) + (= (quantifier_pron somebody some person) True) + (= (quantifier_pron someone some person) True) + (= (quantifier_pron something some thing) True) + (= (quantifier_pron anybody any person) True) + (= (quantifier_pron anyone any person) True) + (= (quantifier_pron anything any thing) True) + (= (quantifier_pron nobody no person) True) + (= (quantifier_pron nothing no thing) True) + + + (= (prep as) True) + (= (prep at) True) + (= (prep of) True) + (= (prep to) True) + (= (prep by) True) + (= (prep with) True) + (= (prep in) True) + (= (prep on) True) + (= (prep from) True) + (= (prep into) True) + (= (prep through) True) + + + (= (noun-form $Plu $Sin plu) + (noun-plu $Plu $Sin)) + (= (noun-form $Sin $Sin sin) + (noun-sin $Sin)) + (= (noun_form proportion proportion $_) True) + (= (noun_form percentage percentage $_) True) - (= - (noun_plu times time) True) -; - (= - (noun_plu places place) True) -; + (= (root_form (+ 1 sin)) True) + (= (root_form (+ 2 $_)) True) + (= (root_form (+ 1 plu)) True) + (= (root_form (+ 3 plu)) True) - (= - (noun_plu areas area) True) -; - (= - (noun_plu capitals capital) True) -; + (= (verb_root be) True) + (= (verb_root have) True) + (= (verb_root do) True) + (= (verb_root border) True) + (= (verb_root contain) True) + (= (verb_root drain) True) + (= (verb_root exceed) True) + (= (verb_root flow) True) + (= (verb_root rise) True) - (= - (noun_plu cities city) True) -; - (= - (noun_plu continents continent) True) -; + (= (regular_pres have) True) + (= (regular_pres do) True) + (= (regular_pres rise) True) + (= (regular_pres border) True) + (= (regular_pres contain) True) + (= (regular_pres drain) True) + (= (regular_pres exceed) True) + (= (regular_pres flow) True) - (= - (noun_plu countries country) True) -; - (= - (noun_plu latitudes latitude) True) -; + (= (regular_past had have) True) + (= (regular_past bordered border) True) + (= (regular_past contained contain) True) + (= (regular_past drained drain) True) + (= (regular_past exceeded exceed) True) + (= (regular_past flowed flow) True) - (= - (noun_plu longitudes longitude) True) -; - (= - (noun_plu oceans ocean) True) -; + (= (rel_pron who subj) True) + (= (rel_pron whom compl) True) + (= (rel_pron which undef) True) - (= - (noun_plu persons person) True) -; - (= - (noun_plu people person) True) -; - (= - (noun_plu populations population) True) -; + (= (poss_pron my $_ 1 sin) True) + (= (poss_pron your $_ 2 $_) True) + (= (poss_pron his masc 3 sin) True) + (= (poss_pron her fem 3 sin) True) + (= (poss_pron its neut 3 sin) True) + (= (poss_pron our $_ 1 plu) True) + (= (poss_pron their $_ 3 plu) True) - (= - (noun_plu regions region) True) -; - (= - (noun_plu rivers river) True) -; + (= (pers_pron i $_ 1 sin subj) True) + (= (pers_pron you $_ 2 $_ $_) True) + (= (pers_pron he masc 3 sin subj) True) + (= (pers_pron she fem 3 sin subj) True) + (= (pers_pron it neut 3 sin $_) True) + (= (pers_pron we $_ 1 plu subj) True) + (= (pers_pron them $_ 3 plu subj) True) + (= (pers_pron me $_ 1 sin (compl $_)) True) + (= (pers_pron him masc 3 sin (compl $_)) True) + (= (pers_pron her fem 3 sin (compl $_)) True) + (= (pers_pron us $_ 1 plu (compl $_)) True) + (= (pers_pron them $_ 3 plu (compl $_)) True) - (= - (noun_plu seas sea) True) -; - (= - (noun_plu seamasses seamass) True) -; + (= (terminator . $_) True) + (= (terminator ? ?) True) + (= (terminator ! !) True) - (= - (noun_plu numbers number) True) -; + (= (name $_) True) +; +; =========================================================================== - (= - (verb-form $V $V inf $_) +; +; specialised dictionary + + + (= (loc_pred east (prep eastof)) True) + (= (loc_pred west (prep westof)) True) + (= (loc_pred north (prep northof)) True) + (= (loc_pred south (prep southof)) True) + + + (= (adj minimum restr) True) + (= (adj maximum restr) True) + (= (adj average restr) True) + (= (adj total restr) True) + (= (adj african restr) True) + (= (adj american restr) True) + (= (adj asian restr) True) + (= (adj european restr) True) + (= (adj great quant) True) + (= (adj big quant) True) + (= (adj small quant) True) + (= (adj large quant) True) + (= (adj old quant) True) + (= (adj new quant) True) + (= (adj populous quant) True) + + + (= (rel_adj greater great) True) + (= (rel_adj less small) True) + (= (rel_adj bigger big) True) + (= (rel_adj smaller small) True) + (= (rel_adj larger large) True) + (= (rel_adj older old) True) + (= (rel_adj newer new) True) + + + (= (sup_adj biggest big) True) + (= (sup_adj smallest small) True) + (= (sup_adj largest large) True) + (= (sup_adj oldest old) True) + (= (sup_adj newest new) True) + + + (= (noun_sin average) True) + (= (noun_sin total) True) + (= (noun_sin sum) True) + (= (noun_sin degree) True) + (= (noun_sin sqmile) True) + (= (noun_sin ksqmile) True) + (= (noun_sin thousand) True) + (= (noun_sin million) True) + (= (noun_sin time) True) + (= (noun_sin place) True) + (= (noun_sin area) True) + (= (noun_sin capital) True) + (= (noun_sin city) True) + (= (noun_sin continent) True) + (= (noun_sin country) True) + (= (noun_sin latitude) True) + (= (noun_sin longitude) True) + (= (noun_sin ocean) True) + (= (noun_sin person) True) + (= (noun_sin population) True) + (= (noun_sin region) True) + (= (noun_sin river) True) + (= (noun_sin sea) True) + (= (noun_sin seamass) True) + (= (noun_sin number) True) + + + (= (noun_plu averages average) True) + (= (noun_plu totals total) True) + (= (noun_plu sums sum) True) + (= (noun_plu degrees degree) True) + (= (noun_plu sqmiles sqmile) True) + (= (noun_plu ksqmiles ksqmile) True) + (= (noun_plu million million) True) + (= (noun_plu thousand thousand) True) + (= (noun_plu times time) True) + (= (noun_plu places place) True) + (= (noun_plu areas area) True) + (= (noun_plu capitals capital) True) + (= (noun_plu cities city) True) + (= (noun_plu continents continent) True) + (= (noun_plu countries country) True) + (= (noun_plu latitudes latitude) True) + (= (noun_plu longitudes longitude) True) + (= (noun_plu oceans ocean) True) + (= (noun_plu persons person) True) + (= (noun_plu people person) True) + (= (noun_plu populations population) True) + (= (noun_plu regions region) True) + (= (noun_plu rivers river) True) + (= (noun_plu seas sea) True) + (= (noun_plu seamasses seamass) True) + (= (noun_plu numbers number) True) + + + (= (verb-form $V $V inf $_) (verb-root $V)) -; - - (= - (verb-form $V $V - (+ pres fin) $Agmt) - ( (regular-pres $V) - (root-form $Agmt) - (verb-root $V))) -; - - (= - (verb-form $Past $Root - (+ past $_) $_) + (= (verb-form $V $V (+ pres fin) $Agmt) + (regular-pres $V) + (root-form $Agmt) + (verb-root $V)) + (= (verb-form $Past $Root (+ past $_) $_) (regular-past $Past $Root)) -; - - - (= - (verb_form am be - (+ pres fin) - (+ 1 sin)) True) -; - - (= - (verb_form are be - (+ pres fin) - (+ 2 sin)) True) -; - - (= - (verb_form is be - (+ pres fin) - (+ 3 sin)) True) -; - - (= - (verb_form are be - (+ pres fin) - (+ $_ plu)) True) -; - - (= - (verb_form was be - (+ past fin) - (+ 1 sin)) True) -; - - (= - (verb_form were be - (+ past fin) - (+ 2 sin)) True) -; - - (= - (verb_form was be - (+ past fin) - (+ 3 sin)) True) -; - - (= - (verb_form were be - (+ past fin) - (+ $_ plu)) True) -; - - (= - (verb_form been be - (+ past part) $_) True) -; - - (= - (verb_form being be - (+ pres part) $_) True) -; - - (= - (verb_form has have - (+ pres fin) - (+ 3 sin)) True) -; - - (= - (verb_form having have - (+ pres part) $_) True) -; - - (= - (verb_form does do - (+ pres fin) - (+ 3 sin)) True) -; - - (= - (verb_form did do - (+ past fin) $_) True) -; - - (= - (verb_form doing do - (+ pres part) $_) True) -; - - (= - (verb_form done do - (+ past part) $_) True) -; - - (= - (verb_form flows flow - (+ pres fin) - (+ 3 sin)) True) -; - - (= - (verb_form flowing flow - (+ pres part) $_) True) -; - - (= - (verb_form rises rise - (+ pres fin) - (+ 3 sin)) True) -; - - (= - (verb_form rose rise - (+ past fin) $_) True) -; - - (= - (verb_form risen rise - (+ past part) $_) True) -; - - (= - (verb_form borders border - (+ pres fin) - (+ 3 sin)) True) -; - - (= - (verb_form bordering border - (+ pres part) $_) True) -; - - (= - (verb_form contains contain - (+ pres fin) - (+ 3 sin)) True) -; - - (= - (verb_form containing contain - (+ pres part) $_) True) -; - - (= - (verb_form drains drain - (+ pres fin) - (+ 3 sin)) True) -; - - (= - (verb_form draining drain - (+ pres part) $_) True) -; - - (= - (verb_form exceeds exceed - (+ pres fin) - (+ 3 sin)) True) -; - - (= - (verb_form exceeding exceed - (+ pres part) $_) True) -; - - - - (= - (verb_type have - (+ aux have)) True) -; - - (= - (verb_type be - (+ aux be)) True) -; - - (= - (verb_type do - (+ aux ditrans)) True) -; - - (= - (verb_type rise - (+ main intrans)) True) -; - - (= - (verb_type border - (+ main trans)) True) -; - - (= - (verb_type contain - (+ main trans)) True) -; - - (= - (verb_type drain - (+ main intrans)) True) -; - - (= - (verb_type exceed - (+ main trans)) True) -; - - (= - (verb_type flow - (+ main intrans)) True) -; - - - - (= - (adverb yesterday) True) -; - - (= - (adverb tomorrow) True) -; + (= (verb_form am be (+ pres fin) (+ 1 sin)) True) + (= (verb_form are be (+ pres fin) (+ 2 sin)) True) + (= (verb_form is be (+ pres fin) (+ 3 sin)) True) + (= (verb_form are be (+ pres fin) (+ $_ plu)) True) + (= (verb_form was be (+ past fin) (+ 1 sin)) True) + (= (verb_form were be (+ past fin) (+ 2 sin)) True) + (= (verb_form was be (+ past fin) (+ 3 sin)) True) + (= (verb_form were be (+ past fin) (+ $_ plu)) True) + (= (verb_form been be (+ past part) $_) True) + (= (verb_form being be (+ pres part) $_) True) + (= (verb_form has have (+ pres fin) (+ 3 sin)) True) + (= (verb_form having have (+ pres part) $_) True) + (= (verb_form does do (+ pres fin) (+ 3 sin)) True) + (= (verb_form did do (+ past fin) $_) True) + (= (verb_form doing do (+ pres part) $_) True) + (= (verb_form done do (+ past part) $_) True) + (= (verb_form flows flow (+ pres fin) (+ 3 sin)) True) + (= (verb_form flowing flow (+ pres part) $_) True) + (= (verb_form rises rise (+ pres fin) (+ 3 sin)) True) + (= (verb_form rose rise (+ past fin) $_) True) + (= (verb_form risen rise (+ past part) $_) True) + (= (verb_form borders border (+ pres fin) (+ 3 sin)) True) + (= (verb_form bordering border (+ pres part) $_) True) + (= (verb_form contains contain (+ pres fin) (+ 3 sin)) True) + (= (verb_form containing contain (+ pres part) $_) True) + (= (verb_form drains drain (+ pres fin) (+ 3 sin)) True) + (= (verb_form draining drain (+ pres part) $_) True) + (= (verb_form exceeds exceed (+ pres fin) (+ 3 sin)) True) + (= (verb_form exceeding exceed (+ pres part) $_) True) + + + (= (verb_type have (+ aux have)) True) + (= (verb_type be (+ aux be)) True) + (= (verb_type do (+ aux ditrans)) True) + (= (verb_type rise (+ main intrans)) True) + (= (verb_type border (+ main trans)) True) + (= (verb_type contain (+ main trans)) True) + (= (verb_type drain (+ main intrans)) True) + (= (verb_type exceed (+ main trans)) True) + (= (verb_type flow (+ main intrans)) True) + + + (= (adverb yesterday) True) + (= (adverb tomorrow) True) diff --git a/sxx_machine/bench/crypt.metta b/sxx_machine/bench/crypt.metta index 9bf20a7..037bec9 100644 --- a/sxx_machine/bench/crypt.metta +++ b/sxx_machine/bench/crypt.metta @@ -1,274 +1,165 @@ +; (convert_to_metta_file crypt $_169110 sxx_machine/bench/crypt.pl sxx_machine/bench/crypt.metta) ; -; - +; Cryptomultiplication: ; -; - +; Find the unique answer to: ; -; - +; OEE ; -; - +; EE ; -; - +; --- ; -; - +; EOEE ; -; - +; EOE ; -; - +; ---- ; -; - +; OOEE ; ; - ; -; - +; where E=even, O=odd. ; -; - +; This program generalizes easily to any such problem. ; -; - +; Written by Peter Van Roy - (= - (top) - ( (odd $A) - (even $B) - (even $C) - (even $E) - (mult - (:: $C $B $A) $E - (Cons $I - (Cons $H - (Cons $G - (Cons $F $X))))) - (lefteven $F) - (odd $G) - (even $H) - (even $I) - (zero $X) - (lefteven $D) - (mult - (:: $C $B $A) $D - (Cons $L - (Cons $K - (Cons $J $Y)))) - (lefteven $J) - (odd $K) - (even $L) - (zero $Y) - (sum - (:: $I $H $G $F) - (:: 0 $L $K $J) - (Cons $P - (Cons $O - (Cons $N - (Cons $M $Z))))) - (odd $M) - (odd $N) - (even $O) - (even $P) - (zero $Z))) -; - + (= (top) + (odd $A) + (even $B) + (even $C) + (even $E) + (mult + (:: $C $B $A) $E + (Cons $I + (Cons $H + (Cons $G + (Cons $F $X))))) + (lefteven $F) + (odd $G) + (even $H) + (even $I) + (zero $X) + (lefteven $D) + (mult + (:: $C $B $A) $D + (Cons $L + (Cons $K + (Cons $J $Y)))) + (lefteven $J) + (odd $K) + (even $L) + (zero $Y) + (sum + (:: $I $H $G $F) + (:: 0 $L $K $J) + (Cons $P + (Cons $O + (Cons $N + (Cons $M $Z))))) + (odd $M) + (odd $N) + (even $O) + (even $P) + (zero $Z)) ; -; - +; write(' '), write(A), write(B), write(C), nl, ; -; - +; write(' '), write(D), write(E), nl, ; -; - +; write(F), write(G), write(H), write(I), nl, ; -; - +; write(J), write(K), write(L), nl, ; -; - +; write(M), write(N), write(O), write(P), nl. ; -; - +; Addition of two numbers - (= - (sum $AL $BL $CL) + (= (sum $AL $BL $CL) (sum $AL $BL 0 $CL)) -; - - - (= - (sum - (Cons $A $AL) - (Cons $B $BL) $Carry - (Cons $C $CL)) - ( (set-det) - (is $X - (+ - (+ $A $B) $Carry)) - (is $C - (mod $X 10)) - (is $NewCarry - (// $X 10)) - (sum $AL $BL $NewCarry $CL))) -; - (= - (sum Nil $BL 0 $BL) + (= (sum (Cons $A $AL) (Cons $B $BL) $Carry (Cons $C $CL)) + (set-det) + (is $X + (+ + (+ $A $B) $Carry)) + (is $C + (mod $X 10)) + (is $NewCarry + (// $X 10)) + (sum $AL $BL $NewCarry $CL)) + (= (sum Nil $BL 0 $BL) (set-det)) -; - - (= - (sum $AL Nil 0 $AL) + (= (sum $AL Nil 0 $AL) (set-det)) -; - - (= - (sum Nil - (Cons $B $BL) $Carry - (Cons $C $CL)) - ( (set-det) - (is $X - (+ $B $Carry)) - (is $NewCarry - (// $X 10)) - (is $C - (mod $X 10)) - (sum Nil $BL $NewCarry $CL))) -; - - (= - (sum - (Cons $A $AL) Nil $Carry - (Cons $C $CL)) - ( (set-det) - (is $X - (+ $A $Carry)) - (is $NewCarry - (// $X 10)) - (is $C - (mod $X 10)) - (sum Nil $AL $NewCarry $CL))) -; - - (= - (sum () () $Carry - ($Carry)) True) -; - + (= (sum Nil (Cons $B $BL) $Carry (Cons $C $CL)) + (set-det) + (is $X + (+ $B $Carry)) + (is $NewCarry + (// $X 10)) + (is $C + (mod $X 10)) + (sum Nil $BL $NewCarry $CL)) + (= (sum (Cons $A $AL) Nil $Carry (Cons $C $CL)) + (set-det) + (is $X + (+ $A $Carry)) + (is $NewCarry + (// $X 10)) + (is $C + (mod $X 10)) + (sum Nil $AL $NewCarry $CL)) + (= (sum () () $Carry ($Carry)) True) ; -; - +; Multiplication - (= - (mult $AL $D $BL) + (= (mult $AL $D $BL) (mult $AL $D 0 $BL)) -; - - (= - (mult - (Cons $A $AL) $D $Carry - (Cons $B $BL)) - ( (is $X - (+ - (* $A $D) $Carry)) - (is $B - (mod $X 10)) - (is $NewCarry - (// $X 10)) - (mult $AL $D $NewCarry $BL))) -; - - (= - (mult Nil $_ $Carry - (:: $C $Cend)) - ( (is $C - (mod $Carry 10)) (is $Cend (// $Carry 10)))) -; - - - - (= - (zero ()) True) -; - - (= - (zero (Cons 0 $L)) + (= (mult (Cons $A $AL) $D $Carry (Cons $B $BL)) + (is $X + (+ + (* $A $D) $Carry)) + (is $B + (mod $X 10)) + (is $NewCarry + (// $X 10)) + (mult $AL $D $NewCarry $BL)) + (= (mult Nil $_ $Carry (:: $C $Cend)) + (is $C + (mod $Carry 10)) + (is $Cend + (// $Carry 10))) + + + (= (zero ()) True) + (= (zero (Cons 0 $L)) (zero $L)) -; - - - - (= - (odd 1) True) -; - (= - (odd 3) True) -; - (= - (odd 5) True) -; + (= (odd 1) True) + (= (odd 3) True) + (= (odd 5) True) + (= (odd 7) True) + (= (odd 9) True) - (= - (odd 7) True) -; - (= - (odd 9) True) -; + (= (even 0) True) + (= (even 2) True) + (= (even 4) True) + (= (even 6) True) + (= (even 8) True) - - (= - (even 0) True) -; - - (= - (even 2) True) -; - - (= - (even 4) True) -; - - (= - (even 6) True) -; - - (= - (even 8) True) -; - - - - (= - (lefteven 2) True) -; - - (= - (lefteven 4) True) -; - - (= - (lefteven 6) True) -; - - (= - (lefteven 8) True) -; - + (= (lefteven 2) True) + (= (lefteven 4) True) + (= (lefteven 6) True) + (= (lefteven 8) True) diff --git a/sxx_machine/bench/derive.metta b/sxx_machine/bench/derive.metta index b6bef31..e30daa1 100644 --- a/sxx_machine/bench/derive.metta +++ b/sxx_machine/bench/derive.metta @@ -1,40 +1,29 @@ +; (convert_to_metta_file derive $_283666 sxx_machine/bench/derive.pl sxx_machine/bench/derive.metta) ; -; - +; generated: 25 October 1989 ; -; - +; option(s): ; ; - ; -; - +; (deriv) ops8 ; ; - ; -; - +; David H. D. Warren ; ; - ; -; - +; symbolic derivative of (x+1)*((^(x,2)+2)*(^(x,3)+3)) - (= - (top) - ( (ops8) - (log10) - (divide10))) -; - + (= (top) + (ops8) + (log10) + (divide10)) - (= - (ops8) + (= (ops8) (d (* (+ x 1) @@ -43,18 +32,12 @@ (^ x 2) 2) (+ (^ x 3) 3))) x $_)) -; - - (= - (log10) + (= (log10) (d (log (log (log (log (log (log (log (log (log (log x)))))))))) x $_)) -; - - (= - (divide10) + (= (divide10) (d (/ (/ @@ -65,94 +48,40 @@ (/ (/ (/ x x) x) x) x) x) x) x) x) x) x $_)) -; - - - - (= - (d - (+ $U $V) $X - (+ $DU $DV)) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - - (= - (d - (- $U $V) $X - (- $DU $DV)) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - - (= - (d - (* $U $V) $X - (+ - (* $DU $V) - (* $U $DV))) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - - (= - (d - (/ $U $V) $X - (/ - (- - (* $DU $V) - (* $U $DV)) - (^ $V 2))) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - - (= - (d - (^ $U $N) $X - (* - (* $DU $N) - (^ $U $N1))) - ( (set-det) - (integer $N) - (is $N1 - (- $N 1)) - (d $U $X $DU))) -; - (= - (d - (- $U) $X - (- $DU)) - ( (set-det) (d $U $X $DU))) -; - (= - (d - (exp $U) $X - (* - (exp $U) $DU)) - ( (set-det) (d $U $X $DU))) -; - - (= - (d - (log $U) $X - (/ $DU $U)) - ( (set-det) (d $U $X $DU))) -; - - (= - (d $X $X 1) + (= (d (+ $U $V) $X (+ $DU $DV)) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (- $U $V) $X (- $DU $DV)) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (* $U $V) $X (+ (* $DU $V) (* $U $DV))) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (/ $U $V) $X (/ (- (* $DU $V) (* $U $DV)) (^ $V 2))) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (^ $U $N) $X (* (* $DU $N) (^ $U $N1))) + (set-det) + (integer $N) + (is $N1 + (- $N 1)) + (d $U $X $DU)) + (= (d (- $U) $X (- $DU)) + (set-det) + (d $U $X $DU)) + (= (d (exp $U) $X (* (exp $U) $DU)) + (set-det) + (d $U $X $DU)) + (= (d (log $U) $X (/ $DU $U)) + (set-det) + (d $U $X $DU)) + (= (d $X $X 1) (set-det)) -; - - (= - (d $_ $_ 0) True) -; - + (= (d $_ $_ 0) True) diff --git a/sxx_machine/bench/divide10.metta b/sxx_machine/bench/divide10.metta index f8adb0c..406c4d4 100644 --- a/sxx_machine/bench/divide10.metta +++ b/sxx_machine/bench/divide10.metta @@ -1,39 +1,28 @@ +; (convert_to_metta_file divide10 $_380398 sxx_machine/bench/divide10.pl sxx_machine/bench/divide10.metta) ; -; - +; generated: 7 March 1990 ; -; - +; option(s): ; ; - ; -; - +; (deriv) divide10 ; ; - ; -; - +; David H. D. Warren ; ; - ; -; +; symbolic derivative of ((((((((x/x)/x)/x)/x)/x)/x)/x)/x)/x - - (= - (top) + (= (top) (divide10)) -; - - (= - (divide10) + (= (divide10) (d (/ (/ @@ -44,94 +33,40 @@ (/ (/ (/ x x) x) x) x) x) x) x) x) x) x $_)) -; - - - - (= - (d - (+ $U $V) $X - (+ $DU $DV)) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - - (= - (d - (- $U $V) $X - (- $DU $DV)) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - - (= - (d - (* $U $V) $X - (+ - (* $DU $V) - (* $U $DV))) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - - (= - (d - (/ $U $V) $X - (/ - (- - (* $DU $V) - (* $U $DV)) - (^ $V 2))) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - (= - (d - (^ $U $N) $X - (* - (* $DU $N) - (^ $U $N1))) - ( (set-det) - (integer $N) - (is $N1 - (- $N 1)) - (d $U $X $DU))) -; - (= - (d - (- $U) $X - (- $DU)) - ( (set-det) (d $U $X $DU))) -; - - (= - (d - (exp $U) $X - (* - (exp $U) $DU)) - ( (set-det) (d $U $X $DU))) -; - - (= - (d - (log $U) $X - (/ $DU $U)) - ( (set-det) (d $U $X $DU))) -; - - (= - (d $X $X 1) + (= (d (+ $U $V) $X (+ $DU $DV)) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (- $U $V) $X (- $DU $DV)) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (* $U $V) $X (+ (* $DU $V) (* $U $DV))) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (/ $U $V) $X (/ (- (* $DU $V) (* $U $DV)) (^ $V 2))) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (^ $U $N) $X (* (* $DU $N) (^ $U $N1))) + (set-det) + (integer $N) + (is $N1 + (- $N 1)) + (d $U $X $DU)) + (= (d (- $U) $X (- $DU)) + (set-det) + (d $U $X $DU)) + (= (d (exp $U) $X (* (exp $U) $DU)) + (set-det) + (d $U $X $DU)) + (= (d (log $U) $X (/ $DU $U)) + (set-det) + (d $U $X $DU)) + (= (d $X $X 1) (set-det)) -; - - (= - (d $_ $_ 0) True) -; - + (= (d $_ $_ 0) True) diff --git a/sxx_machine/bench/fast_mu.metta b/sxx_machine/bench/fast_mu.metta index ddb7058..8034a10 100644 --- a/sxx_machine/bench/fast_mu.metta +++ b/sxx_machine/bench/fast_mu.metta @@ -1,272 +1,175 @@ +; (convert_to_metta_file fast_mu $_473710 sxx_machine/bench/fast_mu.pl sxx_machine/bench/fast_mu.metta) ; ; - ; -; - +; The MU-puzzle ; -; - +; from Hofstadter's "Godel, Escher, Bach" (pp. 33-6). ; -; - +; written by Bruce Holmer ; ; - ; -; - +; To find a derivation type, for example: ; -; - +; theorem([m,u,i,i,u]). ; -; - +; Also try 'miiiii' (uses all rules) and 'muui' (requires 11 steps). ; -; - +; Note that it can be shown that (# of i's) cannot be a multiple ; -; - +; of three (which includes 0). ; -; - +; Some results: ; ; - ; -; - +; string # steps ; -; - +; ------ ------- ; -; - +; miui 8 ; -; - +; muii 8 ; -; - +; muui 11 ; -; - +; muiiu 6 ; -; - +; miuuu 9 ; -; - +; muiuu 9 ; -; - +; muuiu 9 ; -; - +; muuui 9 ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (= - (top) + (= (top) (theorem (:: m u i i u))) -; - ; -; - +; First break goal atom into a list of characters, ; -; - - - (= - (theorem $G) - ( (length $G $GL1) - (is $GL - (- $GL1 1)) - (derive - (:: m i) $G 1 $GL $Derivation 0))) -; +; find the derivation, and then print the results. + (= (theorem $G) + (length $G $GL1) + (is $GL + (- $GL1 1)) + (derive + (:: m i) $G 1 $GL $Derivation 0)) ; -; - +; nl, print_results([rule(0,[m,i])|Derivation], 0). ; -; - +; derive(StartString, GoalString, StartStringLength, GoalStringLength, ; -; +; Derivation, InitBound). - - (= - (derive $S $G $SL $GL $D $B) + (= (derive $S $G $SL $GL $D $B) (derive2 $S $G $SL $GL 1 $D $B)) -; - - (= - (derive $S $G $SL $GL $D $B) - ( (is $B1 - (+ $B 1)) (derive $S $G $SL $GL $D $B1))) -; - +; ; B1 is B + 1, +; ; write('depth '), write(B1), nl, + (= (derive $S $G $SL $GL $D $B) + (is $B1 + (+ $B 1)) + (derive $S $G $SL $GL $D $B1)) ; -; - +; derive2(StartString, GoalString, StartStringLength, GoalStringLength, ; -; - +; ScanPointer, Derivation, NumRemainingSteps). - (= - (derive2 $S $S $SL $SL $_ () $_) True) -; + (= (derive2 $S $S $SL $SL $_ () $_) True) + (= (derive2 $S $G $SL $GL $Pin (Cons (rule $N $I) $D) $R) + (lower-bound $SL $GL $B) + (>= $R $B) + (is $R1 + (- $R 1)) + (rule $S $I $SL $IL $Pin $Pout $N) + (derive2 $I $G $IL $GL $Pout $D $R1)) - (= - (derive2 $S $G $SL $GL $Pin - (Cons - (rule $N $I) $D) $R) - ( (lower-bound $SL $GL $B) - (>= $R $B) - (is $R1 - (- $R 1)) - (rule $S $I $SL $IL $Pin $Pout $N) - (derive2 $I $G $IL $GL $Pout $D $R1))) -; - - - (= - (rule - (Cons m $T1) - (Cons m $T2) $L1 $L2 $Pin $Pout $N) + (= (rule (Cons m $T1) (Cons m $T2) $L1 $L2 $Pin $Pout $N) (rule $T1 $T2 $L1 $L2 $Pin $Pout 1 i $N $X $X)) -; - ; -; - +; rule(InitialString, FinalString, InitStrLength, FinStrLength, ; -; - +; ScanPtrIn, ScanPtrOut, StrPosition, PreviousChar, ; -; - +; RuleNumber, DiffList, DiffLink). ; -; - - (= - (rule - (:: i) - (:: i u) $L1 $L2 $Pin $Pout $Pos $_ 1 $_ $_) - ( (>= $Pos $Pin) - (is $Pout - (- $Pos 2)) - (is $L2 - (+ $L1 1)))) -; - - (= - (rule Nil $L $L1 $L2 $_ 1 $_ $_ 2 $L Nil) +; The difference list is used for doing a list concatenate in rule 2. + (= (rule (:: i) (:: i u) $L1 $L2 $Pin $Pout $Pos $_ 1 $_ $_) + (>= $Pos $Pin) + (is $Pout + (- $Pos 2)) + (is $L2 + (+ $L1 1))) + (= (rule Nil $L $L1 $L2 $_ 1 $_ $_ 2 $L Nil) (is $L2 (+ $L1 $L1))) -; - - (= - (rule - (Cons i - (Cons i - (Cons i $T))) - (Cons u $T) $L1 $L2 $Pin $Pout $Pos $_ 3 $_ $_) - ( (>= $Pos $Pin) - (is $Pout - (- $Pos 1)) - (is $L2 - (- $L1 2)))) -; - - (= - (rule - (Cons u - (Cons u $T)) $T $L1 $L2 $Pin $Pout $Pos i 4 $_ $_) - ( (>= $Pos $Pin) - (is $Pout - (- $Pos 2)) - (is $L2 - (- $L1 2)))) -; - - (= - (rule - (Cons $H $T1) - (Cons $H $T2) $L1 $L2 $Pin $Pout $Pos $_ $N $L - (Cons $H $X)) - ( (is $Pos1 - (+ $Pos 1)) (rule $T1 $T2 $L1 $L2 $Pin $Pout $Pos1 $H $N $L $X))) -; - + (= (rule (Cons i (Cons i (Cons i $T))) (Cons u $T) $L1 $L2 $Pin $Pout $Pos $_ 3 $_ $_) + (>= $Pos $Pin) + (is $Pout + (- $Pos 1)) + (is $L2 + (- $L1 2))) + (= (rule (Cons u (Cons u $T)) $T $L1 $L2 $Pin $Pout $Pos i 4 $_ $_) + (>= $Pos $Pin) + (is $Pout + (- $Pos 2)) + (is $L2 + (- $L1 2))) + (= (rule (Cons $H $T1) (Cons $H $T2) $L1 $L2 $Pin $Pout $Pos $_ $N $L (Cons $H $X)) + (is $Pos1 + (+ $Pos 1)) + (rule $T1 $T2 $L1 $L2 $Pin $Pout $Pos1 $H $N $L $X)) ; -; - +; print_results([], _). ; -; - +; print_results([rule(N,G)|T], M) :- ; -; - +; M1 is M + 1, ; -; - +; write(M1), write(' '), print_rule(N), write(G), nl, ; -; - +; print_results(T, M1). ; ; - ; -; - +; print_rule(0) :- write('axiom '). ; -; - +; print_rule(N) :- N =\= 0, write('rule '), write(N), write(' '). ; ; - - (= - (lower-bound $N $M 1) + (= (lower-bound $N $M 1) (< $N $M)) -; - - (= - (lower_bound $N $N 2) True) -; - - (= - (lower-bound $N $M $B) - ( (> $N $M) - (is $Diff - (- $N $M)) - (is $P - (/\ $Diff 1)) - (det-if-then-else - (=:= $P 0) - (is $B - (>> $Diff 1)) - (is $B - (+ - (>> - (+ $Diff 1) 1) 1))))) -; - - -; -; - + (= (lower_bound $N $N 2) True) + (= (lower-bound $N $M $B) + (> $N $M) + (is $Diff + (- $N $M)) + (is $P + (/\ $Diff 1)) + (det-if-then-else + (=:= $P 0) + (is $B + (>> $Diff 1)) + (is $B + (+ + (>> + (+ $Diff 1) 1) 1)))) +; ; use and to do even test +; ; use shifts to divide by 2 + +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/sxx_machine/bench/flatten.metta b/sxx_machine/bench/flatten.metta index 6394dbe..f2d3f6f 100644 --- a/sxx_machine/bench/flatten.metta +++ b/sxx_machine/bench/flatten.metta @@ -1,557 +1,292 @@ +; (convert_to_metta_file flatten $_102036 sxx_machine/bench/flatten.pl sxx_machine/bench/flatten.metta) ; -; - +; preprocessing phase to eliminate disjunctions from the code ; -; - +; takes a list of clauses of the form source(Name,Clause) ; -; - +; returns these clauses with disjunctions replaced by dummy calls ; -; - +; and a list of NewClauses corresponding to those dummy calls ; -; - +; Link is the uninstantiated last cdr of this list - (= - (top) - ( (eliminate-disjunctions - (:: (= (a $A $B $C) (or (b $A) (c $C)))) $X $Y Nil) (inst-vars (, $X $Y)))) -; - + (= (top) + (eliminate-disjunctions + (:: (= (a $A $B $C) + (or + (b $A) + (c $C)))) $X $Y Nil) + (inst-vars (, $X $Y))) ; -; - +; write((X,Y)), nl, ; -; - +; (X,Y) == ([(a:-'_dummy_0')],[('_dummy_0':-b),('_dummy_0':-c)]), ; -; - - (= top True) -; - +; write(ok), nl. + (= top True) ; -; +; write(wrong), nl. + (= (eliminate-disjunctions $OneProc $NewProc $NewClauses $Link) + (gather-disj $OneProc $NewProc $Disj Nil) + (treat-disj $Disj $NewClauses $Link)) - (= - (eliminate-disjunctions $OneProc $NewProc $NewClauses $Link) - ( (gather-disj $OneProc $NewProc $Disj Nil) (treat-disj $Disj $NewClauses $Link))) -; - - - - (= - (gather_disj () () $Link $Link) True) -; - - (= - (gather-disj - (Cons $C $Cs) $NewProc $Disj $Link) - ( (extract-disj $C $NewC $Disj $Rest) - (= $NewProc - (Cons $NewC $NewCs)) - (gather-disj $Cs $NewCs $Rest $Link))) -; + (= (gather_disj () () $Link $Link) True) + (= (gather-disj (Cons $C $Cs) $NewProc $Disj $Link) + (extract-disj $C $NewC $Disj $Rest) + (= $NewProc + (Cons $NewC $NewCs)) + (gather-disj $Cs $NewCs $Rest $Link)) ; -; - +; given a clause, find in Disj the list of disj((A;B),N,X,C) ; -; - +; where N is a unique ID, X is a var that takes the place of ; -; - +; (A;B) in the code, NewC is the clause modified in such a way that ; -; - +; the disjunctions are replaced by the corresponding vars ; -; - +; Link is the last (uninstantiated) cdr of the list Disj. ; -; - +; do the work of pretrans for nots, -> etc... ; -; - - - (= - (extract-disj $C - (= $Head $NewBody) $Disj $Link) - ( (= $C - (= $Head $Body)) - (set-det) - (= $CtrIn 0) - (extract-disj $Body $NewBody $Disj $Link $C $CtrIn $CtrOut))) -; - - (= - (extract_disj $Head $Head $Link $Link) True) -; - - - (= - (extract-disj - (, $C1 $C2) - (, $NewC1 $NewC2) $Disj $Link $C $CtrIn $CtrOut) - ( (extract-disj $C1 $NewC1 $Disj $Link1 $C $CtrIn $Ctr) (extract-disj $C2 $NewC2 $Link1 $Link $C $Ctr $CtrOut))) -; - - - (= - (extract-disj $Goal $X $Disj $Link $C $CtrIn $CtrOut) - ( (is-disj $Goal $NewGoal) - (set-det) - (= $Disj - (Cons - (disj $NewGoal $CtrIn $X $C) $Link)) - (is $CtrOut - (+ $CtrIn 1)))) -; - - (= - (extract_disj $Goal $Goal $Link $Link $_ $CtrIn $CtrIn) True) -; - - - - (= - (is-disj - (det-if-then-else $C1 $C2 $C3) - (or - (, $C1 - (set-det) $C2) $C3)) - (set-det)) -; - - (= - (is_disj - (; $C1 $C2) - (; $C1 $C2)) True) -; - - (= - (is_disj - (not $C) - (; - (, $C - (, ! fail)) true)) True) -; - - (= - (is_disj - (\+ $C) - (; - (, $C - (, ! fail)) true)) True) -; - - (= - (is_disj - (\= $C1 $C2) - (; - (, - (= $C1 $C2) - (, ! fail)) true)) True) -; +; put all those guys inside disjunctions + + (= (extract-disj $C (= $Head $NewBody) $Disj $Link) + (= $C + (= $Head $Body)) + (set-det) + (= $CtrIn 0) + (extract-disj $Body $NewBody $Disj $Link $C $CtrIn $CtrOut)) + (= (extract_disj $Head $Head $Link $Link) True) + + (= (extract-disj (, $C1 $C2) (, $NewC1 $NewC2) $Disj $Link $C $CtrIn $CtrOut) + (extract-disj $C1 $NewC1 $Disj $Link1 $C $CtrIn $Ctr) + (extract-disj $C2 $NewC2 $Link1 $Link $C $Ctr $CtrOut)) + + (= (extract-disj $Goal $X $Disj $Link $C $CtrIn $CtrOut) + (is-disj $Goal $NewGoal) + (set-det) + (= $Disj + (Cons + (disj $NewGoal $CtrIn $X $C) $Link)) + (is $CtrOut + (+ $CtrIn 1))) + (= (extract_disj $Goal $Goal $Link $Link $_ $CtrIn $CtrIn) True) -; -; + (= (is-disj (det-if-then-else $C1 $C2 $C3) (or (, $C1 (set-det) $C2) $C3)) + (set-det)) + (= (is_disj (; $C1 $C2) (; $C1 $C2)) True) + (= (is_disj (not $C) (; (, $C (, ! fail)) true)) True) + (= (is_disj (\+ $C) (; (, $C (, ! fail)) true)) True) + (= (is_disj (\= $C1 $C2) (; (, (= $C1 $C2) (, ! fail)) true)) True) ; -; - +; given a list of disj((A;B),N,X,C), for each, do the following: ; -; - +; 1) find vars in (A;B) ; -; - +; 2) find the vars in C ; -; - +; 3) intersect the two sets of vars into one list ; -; - +; 4) make a predicate name using N as a part of it ('dummy_disjN') ; -; - +; 5) put a structure with that name and those vars as args ; -; - - - (= - (treat_disj () $Link $Link) True) -; - - (= - (treat-disj - (Cons - (disj - (or $A $B) $N $X $C) $Disjs) $DummyClauses $Link) - ( (find-vars - (or $A $B) $Vars) - (find-vars $C $CVars) - (intersect-vars $Vars $CVars $Args) - (make-dummy-name $N $Name) - (=.. $X - (Cons $Name $Args)) - (make-dummy-clauses - (or $A $B) $X $DummyClauses $Rest) - (treat-disj $Disjs $Rest $Link))) -; - - - - (= - (make-dummy-clauses - (or $A $B) $X - (Cons $NewC $Cs) $Link) - ( (set-det) - (copy - (= $X $A) $NewC) - (make-dummy-clauses $B $X $Cs $Link))) -; - - (= - (make-dummy-clauses $A $X - (Cons $NewC $Link) $Link) - (copy - (= $X $A) $NewC)) -; - - - - (= - (find-vars $X $Y) - ( (find-vars $X $Y $Link) (= $Link Nil))) -; - - - (= - (find-vars $Var - (Cons $Var $Link) $Link) - ( (var $Var) (set-det))) -; - - (= - (find-vars $Cst $Link $Link) - ( (atomic $Cst) (set-det))) -; +; 6) binds X to this call +; +; 7) add new clauses [(dummy:-A)),(dummy:-B))] - (= + (= (treat_disj () $Link $Link) True) + (= (treat-disj (Cons (disj (or $A $B) $N $X $C) $Disjs) $DummyClauses $Link) (find-vars - (Cons $T $Ts) $Vars $NewLink) - ( (set-det) - (find-vars $T $Vars $Link) - (find-vars $Ts $Link $NewLink))) -; + (or $A $B) $Vars) + (find-vars $C $CVars) + (intersect-vars $Vars $CVars $Args) + (make-dummy-name $N $Name) + (=.. $X + (Cons $Name $Args)) + (make-dummy-clauses + (or $A $B) $X $DummyClauses $Rest) + (treat-disj $Disjs $Rest $Link)) - (= - (find-vars $Term $Vars $Link) - ( (=.. $Term - (Cons $_ $Args)) (find-vars $Args $Vars $Link))) -; + (= (make-dummy-clauses (or $A $B) $X (Cons $NewC $Cs) $Link) + (set-det) + (copy + (= $X $A) $NewC) + (make-dummy-clauses $B $X $Cs $Link)) + (= (make-dummy-clauses $A $X (Cons $NewC $Link) $Link) + (copy + (= $X $A) $NewC)) - (= - (intersect-vars $V1 $V2 $Out) - ( (sort-vars $V1 $Sorted1) - (sort-vars $V2 $Sorted2) - (intersect-sorted-vars $Sorted1 $Sorted2 $Out))) -; + (= (find-vars $X $Y) + (find-vars $X $Y $Link) + (= $Link Nil)) + (= (find-vars $Var (Cons $Var $Link) $Link) + (var $Var) + (set-det)) + (= (find-vars $Cst $Link $Link) + (atomic $Cst) + (set-det)) + (= (find-vars (Cons $T $Ts) $Vars $NewLink) + (set-det) + (find-vars $T $Vars $Link) + (find-vars $Ts $Link $NewLink)) + (= (find-vars $Term $Vars $Link) + (=.. $Term + (Cons $_ $Args)) + (find-vars $Args $Vars $Link)) - (= - (make-dummy-name $N $Name) - ( (name -dummy- $L1) - (name $N $L2) - (append $L1 $L2 $L) - (name $Name $L))) -; + (= (intersect-vars $V1 $V2 $Out) + (sort-vars $V1 $Sorted1) + (sort-vars $V2 $Sorted2) + (intersect-sorted-vars $Sorted1 $Sorted2 $Out)) + (= (make-dummy-name $N $Name) + (name -dummy- $L1) + (name $N $L2) + (append $L1 $L2 $L) + (name $Name $L)) - (= - (append () $L $L) True) -; - (= - (append - (Cons $H $L1) $L2 - (Cons $H $Res)) + (= (append () $L $L) True) + (= (append (Cons $H $L1) $L2 (Cons $H $Res)) (append $L1 $L2 $Res)) -; - ; -; - - - (= - (copy $Term1 $Term2) - ( (varset $Term1 $Set) - (make-sym $Set $Sym) - (copy2 $Term1 $Term2 $Sym) - (set-det))) -; - - +; copy_term using a symbol table. - (= - (copy2 $V1 $V2 $Sym) - ( (var $V1) - (set-det) - (retrieve-sym $V1 $Sym $V2))) -; - - (= - (copy2 $X1 $X2 $Sym) - ( (nonvar $X1) - (set-det) - (functor $X1 $Name $Arity) - (functor $X2 $Name $Arity) - (copy2 $X1 $X2 $Sym 1 $Arity))) -; + (= (copy $Term1 $Term2) + (varset $Term1 $Set) + (make-sym $Set $Sym) + (copy2 $Term1 $Term2 $Sym) + (set-det)) - (= - (copy2 $X1 $X2 $Sym $N $Arity) - ( (> $N $Arity) (set-det))) -; + (= (copy2 $V1 $V2 $Sym) + (var $V1) + (set-det) + (retrieve-sym $V1 $Sym $V2)) + (= (copy2 $X1 $X2 $Sym) + (nonvar $X1) + (set-det) + (functor $X1 $Name $Arity) + (functor $X2 $Name $Arity) + (copy2 $X1 $X2 $Sym 1 $Arity)) - (= - (copy2 $X1 $X2 $Sym $N $Arity) - ( (=< $N $Arity) - (set-det) - (arg $N $X1 $Arg1) - (arg $N $X2 $Arg2) - (copy2 $Arg1 $Arg2 $Sym) - (is $N1 - (+ $N 1)) - (copy2 $X1 $X2 $Sym $N1 $Arity))) -; + (= (copy2 $X1 $X2 $Sym $N $Arity) + (> $N $Arity) + (set-det)) + (= (copy2 $X1 $X2 $Sym $N $Arity) + (=< $N $Arity) + (set-det) + (arg $N $X1 $Arg1) + (arg $N $X2 $Arg2) + (copy2 $Arg1 $Arg2 $Sym) + (is $N1 + (+ $N 1)) + (copy2 $X1 $X2 $Sym $N1 $Arity)) + + + (= (retrieve-sym $V (Cons (p $W $X) $Sym) $X) + (== $V $W) + (set-det)) + (= (retrieve-sym $V (Cons $_ $Sym) $X) + (retrieve-sym $V $Sym $X)) + (= (make_sym () ()) True) + (= (make-sym (Cons $V $L) (Cons (p $V $_) $S)) + (make-sym $L $S)) - (= - (retrieve-sym $V - (Cons - (p $W $X) $Sym) $X) - ( (== $V $W) (set-det))) -; +; +; *** Gather all variables used in a term: (in a set or a bag) - (= - (retrieve-sym $V - (Cons $_ $Sym) $X) - (retrieve-sym $V $Sym $X)) -; + (= (varset $Term $VarSet) + (varbag $Term $VB) + (sort $VB $VarSet)) + (= (varbag $Term $VarBag) + (varbag $Term $VarBag Nil)) - (= - (make_sym () ()) True) -; + (= (--> (varbag $Var) (, {(var $Var) } (, ! ($Var)))) True) + (= (--> (varbag $Str) (, {(, (nonvar $Str) (, ! (functor $Str $_ $Arity))) } (varbag $Str 1 $Arity))) True) - (= - (make-sym - (Cons $V $L) - (Cons - (p $V $_) $S)) - (make-sym $L $S)) -; + (= (--> (varbag $Str $N $Arity) (, {(> $N $Arity) } !)) True) + (= (--> (varbag $Str $N $Arity) (, {(=< $N $Arity) } (, ! (, {(arg $N $Str $Arg) } (, (varbag $Arg) (, {(is $N1 (+ $N 1)) } (varbag $Str $N1 $Arity))))))) True) -; -; + (= (inst-vars $Term) + (varset $Term $Vars) + (= + (:: $A) + (:: 65)) + (inst-vars-list $Vars $A)) - (= - (varset $Term $VarSet) - ( (varbag $Term $VB) (sort $VB $VarSet))) -; + (= (inst_vars_list () $_) True) + (= (inst-vars-list (Cons $T $L) $N) + (name $T + (:: $N)) + (is $N1 + (+ $N 1)) + (inst-vars-list $L $N1)) - (= - (varbag $Term $VarBag) - (varbag $Term $VarBag Nil)) -; - - - - (= - (--> - (varbag $Var) - (, - { (var $Var) } - (, ! - ($Var)))) True) -; - - (= - (--> - (varbag $Str) - (, - { (, - (nonvar $Str) - (, ! - (functor $Str $_ $Arity))) } - (varbag $Str 1 $Arity))) True) -; - - - (= - (--> - (varbag $Str $N $Arity) - (, - { (> $N $Arity) } !)) True) -; - - (= - (--> - (varbag $Str $N $Arity) - (, - { (=< $N $Arity) } - (, ! - (, - { (arg $N $Str $Arg) } - (, - (varbag $Arg) - (, - { (is $N1 - (+ $N 1)) } - (varbag $Str $N1 $Arity))))))) True) -; - - - - (= - (inst-vars $Term) - ( (varset $Term $Vars) - (= - (:: $A) - (:: 65)) - (inst-vars-list $Vars $A))) -; - - - - (= - (inst_vars_list () $_) True) -; - - (= - (inst-vars-list - (Cons $T $L) $N) - ( (name $T - (:: $N)) - (is $N1 - (+ $N 1)) - (inst-vars-list $L $N1))) -; - - - - (= - (sort-vars $V $Out) + (= (sort-vars $V $Out) (sort-vars $V $Out Nil)) -; - - (= - (sort_vars () $Link $Link) True) -; - - (= - (sort-vars - (Cons $V $Vs) $Result $Link) - ( (split-vars $Vs $V $Smaller $Bigger) - (sort-vars $Smaller $Result - (Cons $V $SLink)) - (sort-vars $Bigger $SLink $Link))) -; + (= (sort_vars () $Link $Link) True) + (= (sort-vars (Cons $V $Vs) $Result $Link) + (split-vars $Vs $V $Smaller $Bigger) + (sort-vars $Smaller $Result + (Cons $V $SLink)) + (sort-vars $Bigger $SLink $Link)) - - (= - (intersect-sorted-vars Nil $_ Nil) + (= (intersect-sorted-vars Nil $_ Nil) (set-det)) -; - - (= - (intersect_sorted_vars $_ () ()) True) -; - - (= - (intersect-sorted-vars - (Cons $X $Xs) - (Cons $Y $Ys) - (Cons $X $Rs)) - ( (== $X $Y) - (set-det) - (intersect-sorted-vars $Xs $Ys $Rs))) -; - - (= + (= (intersect_sorted_vars $_ () ()) True) + (= (intersect-sorted-vars (Cons $X $Xs) (Cons $Y $Ys) (Cons $X $Rs)) + (== $X $Y) + (set-det) + (intersect-sorted-vars $Xs $Ys $Rs)) + (= (intersect-sorted-vars (Cons $X $Xs) (Cons $Y $Ys) $Rs) + (@< $X $Y) + (set-det) + (intersect-sorted-vars $Xs + (Cons $Y $Ys) $Rs)) + (= (intersect-sorted-vars (Cons $X $Xs) (Cons $Y $Ys) $Rs) + (@> $X $Y) + (set-det) (intersect-sorted-vars - (Cons $X $Xs) - (Cons $Y $Ys) $Rs) - ( (@< $X $Y) - (set-det) - (intersect-sorted-vars $Xs - (Cons $Y $Ys) $Rs))) -; - - (= - (intersect-sorted-vars - (Cons $X $Xs) - (Cons $Y $Ys) $Rs) - ( (@> $X $Y) - (set-det) - (intersect-sorted-vars - (Cons $X $Xs) $Ys $Rs))) -; - - - - - (= - (split_vars () $_ () ()) True) -; - - (= - (split-vars - (Cons $V $Vs) $A - (Cons $V $Ss) $Bs) - ( (@< $V $A) - (set-det) - (split-vars $Vs $A $Ss $Bs))) -; - - (= - (split-vars - (Cons $V $Vs) $A $Ss $Bs) - ( (== $V $A) - (set-det) - (split-vars $Vs $A $Ss $Bs))) -; - - (= - (split-vars - (Cons $V $Vs) $A $Ss - (Cons $V $Bs)) - ( (@> $V $A) - (set-det) - (split-vars $Vs $A $Ss $Bs))) -; - + (Cons $X $Xs) $Ys $Rs)) + + + + (= (split_vars () $_ () ()) True) + (= (split-vars (Cons $V $Vs) $A (Cons $V $Ss) $Bs) + (@< $V $A) + (set-det) + (split-vars $Vs $A $Ss $Bs)) + (= (split-vars (Cons $V $Vs) $A $Ss $Bs) + (== $V $A) + (set-det) + (split-vars $Vs $A $Ss $Bs)) + (= (split-vars (Cons $V $Vs) $A $Ss (Cons $V $Bs)) + (@> $V $A) + (set-det) + (split-vars $Vs $A $Ss $Bs)) diff --git a/sxx_machine/bench/log10.metta b/sxx_machine/bench/log10.metta index accfb69..1496d09 100644 --- a/sxx_machine/bench/log10.metta +++ b/sxx_machine/bench/log10.metta @@ -1,128 +1,63 @@ +; (convert_to_metta_file log10 $_305106 sxx_machine/bench/log10.pl sxx_machine/bench/log10.metta) ; -; - +; generated: 25 October 1989 ; -; - +; option(s): ; ; - ; -; - +; (deriv) log10 ; ; - ; -; - +; David H. D. Warren ; ; - ; -; +; symbolic derivative of log(log(log(log(log(log(log(log(log(log(x)))))))))) - - (= - (top) + (= (top) (log10)) -; - - (= - (log10) + (= (log10) (d (log (log (log (log (log (log (log (log (log (log x)))))))))) x $_)) -; - - - (= - (d - (+ $U $V) $X - (+ $DU $DV)) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - - (= - (d - (- $U $V) $X - (- $DU $DV)) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - (= - (d - (* $U $V) $X - (+ - (* $DU $V) - (* $U $DV))) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - - (= - (d - (/ $U $V) $X - (/ - (- - (* $DU $V) - (* $U $DV)) - (^ $V 2))) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - - (= - (d - (^ $U $N) $X - (* - (* $DU $N) - (^ $U $N1))) - ( (set-det) - (integer $N) - (is $N1 - (- $N 1)) - (d $U $X $DU))) -; - - (= - (d - (- $U) $X - (- $DU)) - ( (set-det) (d $U $X $DU))) -; - - (= - (d - (exp $U) $X - (* - (exp $U) $DU)) - ( (set-det) (d $U $X $DU))) -; - - (= - (d - (log $U) $X - (/ $DU $U)) - ( (set-det) (d $U $X $DU))) -; - - (= - (d $X $X 1) + (= (d (+ $U $V) $X (+ $DU $DV)) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (- $U $V) $X (- $DU $DV)) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (* $U $V) $X (+ (* $DU $V) (* $U $DV))) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (/ $U $V) $X (/ (- (* $DU $V) (* $U $DV)) (^ $V 2))) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (^ $U $N) $X (* (* $DU $N) (^ $U $N1))) + (set-det) + (integer $N) + (is $N1 + (- $N 1)) + (d $U $X $DU)) + (= (d (- $U) $X (- $DU)) + (set-det) + (d $U $X $DU)) + (= (d (exp $U) $X (* (exp $U) $DU)) + (set-det) + (d $U $X $DU)) + (= (d (log $U) $X (/ $DU $U)) + (set-det) + (d $U $X $DU)) + (= (d $X $X 1) (set-det)) -; - - (= - (d $_ $_ 0) True) -; - + (= (d $_ $_ 0) True) diff --git a/sxx_machine/bench/meta_qsort.metta b/sxx_machine/bench/meta_qsort.metta index bf763ce..37b7a26 100644 --- a/sxx_machine/bench/meta_qsort.metta +++ b/sxx_machine/bench/meta_qsort.metta @@ -1,272 +1,148 @@ +; (convert_to_metta_file meta_qsort $_394192 sxx_machine/bench/meta_qsort.pl sxx_machine/bench/meta_qsort.metta) ; -; - +; generated: 8 March 1990 ; -; - +; option(s): ; ; - ; -; - +; meta_qsort ; ; - ; -; - +; Ralph M. Haygood ; ; - ; -; - +; meta-interpret Warren benchmark qsort ; ; - ; -; - +; For any meta-variable ~X~, interpret(~X~) behaves as if ; ; - ; -; - +; interpret(~X~) :- ~X~. ; ; - ; -; - +; Thus, for example, interpret((foo(X), bar(X), !)) behaves as if ; ; - ; -; - +; interpret((foo(X), bar(X), !)) :- foo(X), bar(X), !. ; ; - ; -; - +; Note that though ~X~ may contain cuts, those cuts cannot escape from ; -; - +; interpret(~X~) to effect the parent goal; interpret(!) is equivalent ; -; - +; to true. ; ; - ; -; - +; Cuts inside ~X~ are executed according to the rule that conjunction, ; -; - +; disjunction, and if-then-else are transparent to cuts, and any other ; -; - +; form is transparent to cuts if and only if it can be macro-expanded ; -; - +; into a form involving only these three without interpret/1. If-then ; -; - +; and negation are the only such other forms currently recognized; ( A ; -; - +; -> B) is equivalent to ( A -> B ; fail ), and \+ A is equivalent to ; -; +; ( A -> fail ; true ). - - (= - (top) + (= (top) (meta-qsort)) -; - - (= - (meta-qsort) + (= (meta-qsort) (interpret qsort)) -; - - - (= - (interpret $Goal) - ( (interpret $Goal $Rest) (or (, (nonvar $Rest) (set-det) (interpret $Rest)) True))) -; - - - (= - (interpret $G $_) - ( (var $G) - (set-det) - (fail))) -; - - (= - (interpret - (, $A $B) $Rest) - ( (set-det) - (interpret $A $Rest0) - (det-if-then-else - (nonvar $Rest0) - (= $Rest - (, $Rest0 $B)) - (interpret $B $Rest)))) -; - - (= - (interpret - (or $A $B) $Rest) - ( (set-det) (interpret-disjunction $A $B $Rest))) -; - - (= - (interpret - (det-if-then $A $B) $Rest) - ( (set-det) (interpret-disjunction (det-if-then $A $B) fail $Rest))) -; - - (= - (interpret - (not $A) $Rest) - ( (set-det) (interpret-disjunction (det-if-then $A fail) True $Rest))) -; - - (= - (interpret - (set-det) True) - (set-det)) -; - - (= - (interpret $G $_) - ( (number $G) - (set-det) - (fail))) -; - (= - (interpret $G $_) - ( (is-built-in $G) - (set-det) - (interpret-built-in $G))) -; - - (= - (interpret $G $_) - ( (define $G $Body) (interpret $Body))) -; - - - - (= + (= (interpret $Goal) + (interpret $Goal $Rest) + (or + (, + (nonvar $Rest) + (set-det) + (interpret $Rest)) True)) + + (= (interpret $G $_) + (var $G) + (set-det) + (fail)) + (= (interpret (, $A $B) $Rest) + (set-det) + (interpret $A $Rest0) + (det-if-then-else + (nonvar $Rest0) + (= $Rest + (, $Rest0 $B)) + (interpret $B $Rest))) + (= (interpret (or $A $B) $Rest) + (set-det) + (interpret-disjunction $A $B $Rest)) + (= (interpret (det-if-then $A $B) $Rest) + (set-det) (interpret-disjunction - (det-if-then $A $B) $_ $Rest) - ( (interpret $A $Rest0) - (set-det) - (det-if-then-else - (nonvar $Rest0) - (= $Rest - (det-if-then $Rest0 $B)) - (interpret $B $Rest)))) -; - - (= + (det-if-then $A $B) fail $Rest)) + (= (interpret (not $A) $Rest) + (set-det) (interpret-disjunction - (det-if-then $_ $_) $C $Rest) - ( (set-det) (interpret $C $Rest))) -; - - (= - (interpret-disjunction $A $_ $Rest) + (det-if-then $A fail) True $Rest)) + (= (interpret (set-det) True) + (set-det)) + (= (interpret $G $_) + (number $G) + (set-det) + (fail)) + (= (interpret $G $_) + (is-built-in $G) + (set-det) + (interpret-built-in $G)) + (= (interpret $G $_) + (define $G $Body) + (interpret $Body)) + + + (= (interpret-disjunction (det-if-then $A $B) $_ $Rest) + (interpret $A $Rest0) + (set-det) + (det-if-then-else + (nonvar $Rest0) + (= $Rest + (det-if-then $Rest0 $B)) + (interpret $B $Rest))) + (= (interpret-disjunction (det-if-then $_ $_) $C $Rest) + (set-det) + (interpret $C $Rest)) + (= (interpret-disjunction $A $_ $Rest) (interpret $A $Rest)) -; - - (= - (interpret-disjunction $_ $B $Rest) + (= (interpret-disjunction $_ $B $Rest) (interpret $B $Rest)) -; + (= (is_built_in true) True) + (= (is_built_in (=< $_ $_)) True) - (= - (is_built_in true) True) -; - (= - (is_built_in - (=< $_ $_)) True) -; - - - - (= - (interpret_built_in true) True) -; - - (= - (interpret-built-in (=< $X $Y)) + (= (interpret_built_in true) True) + (= (interpret-built-in (=< $X $Y)) (=< $X $Y)) -; + (= (define qsort (qsort (27 74 17 33 94 18 46 83 65 2 32 53 28 85 99 47 28 82 6 11 55 29 39 81 90 37 10 0 66 51 7 21 85 27 31 63 75 4 95 99 11 28 61 74 18 92 40 53 59 8) $_ ())) True) - (= - (define qsort - (qsort - (27 74 17 33 94 18 46 83 65 2 32 53 28 85 99 47 28 82 6 11 55 29 39 81 90 37 10 0 66 51 7 21 85 27 31 63 75 4 95 99 11 28 61 74 18 92 40 53 59 8) $_ ())) True) -; - - - (= - (define - (qsort - (Cons $X $L) $R $R0) - (, - (partition $L $X $L1 $L2) - (, - (qsort $L2 $R1 $R0) - (qsort $L1 $R - (Cons $X $R1))))) True) -; - - (= - (define - (qsort () $R $R) true) True) -; - - - (= - (define - (partition - (Cons $X $L) $Y - (Cons $X $L1) $L2) - (, - (=< $X $Y) - (, ! - (partition $L $Y $L1 $L2)))) True) -; - - (= - (define - (partition - (Cons $X $L) $Y $L1 - (Cons $X $L2)) - (partition $L $Y $L1 $L2)) True) -; - - (= - (define - (partition () $_ () ()) true) True) -; + (= (define (qsort (Cons $X $L) $R $R0) (, (partition $L $X $L1 $L2) (, (qsort $L2 $R1 $R0) (qsort $L1 $R (Cons $X $R1))))) True) + (= (define (qsort () $R $R) true) True) + (= (define (partition (Cons $X $L) $Y (Cons $X $L1) $L2) (, (=< $X $Y) (, ! (partition $L $Y $L1 $L2)))) True) + (= (define (partition (Cons $X $L) $Y $L1 (Cons $X $L2)) (partition $L $Y $L1 $L2)) True) + (= (define (partition () $_ () ()) true) True) diff --git a/sxx_machine/bench/mu.metta b/sxx_machine/bench/mu.metta index c2d633e..f423fc7 100644 --- a/sxx_machine/bench/mu.metta +++ b/sxx_machine/bench/mu.metta @@ -1,150 +1,71 @@ +; (convert_to_metta_file mu $_21788 sxx_machine/bench/mu.pl sxx_machine/bench/mu.metta) ; -; - +; generated: 9 November 1989 ; -; - +; option(s): ; ; - ; -; - +; mu ; ; - ; -; - +; derived from Douglas R. Hofstadter, "Godel, Escher, Bach," pages 33-35. ; ; - ; -; +; prove "mu-math" theorem muiiu - - (= - (top) + (= (top) (mu)) -; - - - - (= - (mu) - ( (theorem - (:: m u i i u) 5 $_) (set-det))) -; + (= (mu) + (theorem + (:: m u i i u) 5 $_) + (set-det)) - (= - (theorem - (m i) $_ - ( (a m i))) True) -; - - (= - (theorem $R $Depth - (Cons - (Cons $N $R) $P)) - ( (> $Depth 0) - (is $D - (- $Depth 1)) - (theorem $S $D $P) - (rule $N $S $R))) -; + (= (theorem (m i) $_ ((a m i))) True) + (= (theorem $R $Depth (Cons (Cons $N $R) $P)) + (> $Depth 0) + (is $D + (- $Depth 1)) + (theorem $S $D $P) + (rule $N $S $R)) - (= - (rule 1 $S $R) + (= (rule 1 $S $R) (rule1 $S $R)) -; - - (= - (rule 2 $S $R) + (= (rule 2 $S $R) (rule2 $S $R)) -; - - (= - (rule 3 $S $R) + (= (rule 3 $S $R) (rule3 $S $R)) -; - - (= - (rule 4 $S $R) + (= (rule 4 $S $R) (rule4 $S $R)) -; - - - (= - (rule1 - (i) - (i u)) True) -; - (= - (rule1 - (Cons $H $X) - (Cons $H $Y)) + (= (rule1 (i) (i u)) True) + (= (rule1 (Cons $H $X) (Cons $H $Y)) (rule1 $X $Y)) -; - - (= - (rule2 - (Cons m $X) - (Cons m $Y)) + (= (rule2 (Cons m $X) (Cons m $Y)) (append $X $X $Y)) -; - - (= - (rule3 - (Cons i - (Cons i - (Cons i $X))) - (Cons u $X)) True) -; - - (= - (rule3 - (Cons $H $X) - (Cons $H $Y)) + (= (rule3 (Cons i (Cons i (Cons i $X))) (Cons u $X)) True) + (= (rule3 (Cons $H $X) (Cons $H $Y)) (rule3 $X $Y)) -; - - (= - (rule4 - (Cons u - (Cons u $X)) $X) True) -; - - (= - (rule4 - (Cons $H $X) - (Cons $H $Y)) + (= (rule4 (Cons u (Cons u $X)) $X) True) + (= (rule4 (Cons $H $X) (Cons $H $Y)) (rule4 $X $Y)) -; - - (= - (append () $X $X) True) -; - - (= - (append - (Cons $A $B) $X - (Cons $A $B1)) + (= (append () $X $X) True) + (= (append (Cons $A $B) $X (Cons $A $B1)) (append $B $X $B1)) -; - diff --git a/sxx_machine/bench/nand.metta b/sxx_machine/bench/nand.metta index 3b28a04..571de46 100644 --- a/sxx_machine/bench/nand.metta +++ b/sxx_machine/bench/nand.metta @@ -1,1348 +1,730 @@ +; (convert_to_metta_file nand $_85130 sxx_machine/bench/nand.pl sxx_machine/bench/nand.metta) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; - ; -; - +; This is a rough approximation to the algorithm presented in: ; ; - ; -; - +; "An Algorithm for NAND Decomposition Under Network Constraints," ; -; - +; IEEE Trans. Comp., vol C-18, no. 12, Dec. 1969, p. 1098 ; -; - +; by E. S. Davidson. ; ; - ; -; - +; Written by Bruce Holmer ; ; - ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; - ; -; - +; I have used the paper's terminology for names used in the program. ; ; - ; -; - +; The data structure for representing functions and variables is ; -; - +; function(FunctionNumber, TrueSet, FalseSet, ; -; - +; ConceivableInputs, ; -; - +; ImmediatePredecessors, ImmediateSuccessors, ; -; - +; Predecessors, Successors) ; ; - ; ; - ; -; - +; Common names used in the program: ; ; - ; -; - +; NumVars number of variables (signal inputs) ; -; - +; NumGs current number of variables and functions ; -; - +; Gs list of variable and function data ; -; - +; Gi,Gj,Gk,Gl individual variable or function--letter corresponds to ; -; - +; the subscript in the paper (most of the time) ; -; - +; Vector,V vector from a function's true set ; ; - ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (top) + (= (top) (main 0)) -; - - (= - (main $N) - ( (init-state $N $NumVars $NumGs $Gs) - (add-necessary-functions $NumVars $NumGs $Gs $NumGs2 $Gs2) - (test-bounds $NumVars $NumGs2 $Gs2) - (search $NumVars $NumGs2 $Gs2))) -; - - (= - (main $_) True) -; - + (= (main $N) + (init-state $N $NumVars $NumGs $Gs) + (add-necessary-functions $NumVars $NumGs $Gs $NumGs2 $Gs2) + (test-bounds $NumVars $NumGs2 $Gs2) + (search $NumVars $NumGs2 $Gs2)) + (= (main $_) True) ; -; - +; write('Search completed'), nl. ; -; - +; Test input ; -; +; init_state(circuit(NumInputs, NumOutputs, FunctionList)) - - (= - (init-state 0 2 3 - (:: - (function 2 - (:: 1 2) - (:: 0 3) Nil Nil Nil Nil Nil) - (function 1 - (:: 2 3) - (:: 0 1) Nil Nil Nil Nil Nil) - (function 0 - (:: 1 3) - (:: 0 2) Nil Nil Nil Nil Nil))) + (= (init-state 0 2 3 (:: (function 2 (:: 1 2) (:: 0 3) Nil Nil Nil Nil Nil) (function 1 (:: 2 3) (:: 0 1) Nil Nil Nil Nil Nil) (function 0 (:: 1 3) (:: 0 2) Nil Nil Nil Nil Nil))) (update-bounds $_ 100 $_)) -; - - (= - (init-state 1 3 4 - (:: - (function 3 - (:: 3 5 6 7) - (:: 0 1 2 4) Nil Nil Nil Nil Nil) - (function 2 - (:: 4 5 6 7) - (:: 0 1 2 3) Nil Nil Nil Nil Nil) - (function 1 - (:: 2 3 6 7) - (:: 0 1 4 5) Nil Nil Nil Nil Nil) - (function 0 - (:: 1 3 5 7) - (:: 0 2 4 6) Nil Nil Nil Nil Nil))) +; ; 2 input xor + (= (init-state 1 3 4 (:: (function 3 (:: 3 5 6 7) (:: 0 1 2 4) Nil Nil Nil Nil Nil) (function 2 (:: 4 5 6 7) (:: 0 1 2 3) Nil Nil Nil Nil Nil) (function 1 (:: 2 3 6 7) (:: 0 1 4 5) Nil Nil Nil Nil Nil) (function 0 (:: 1 3 5 7) (:: 0 2 4 6) Nil Nil Nil Nil Nil))) (update-bounds $_ 100 $_)) -; - - (= - (init-state 2 3 4 - (:: - (function 3 - (:: 1 2 4 6 7) - (:: 0 3 5) Nil Nil Nil Nil Nil) - (function 2 - (:: 4 5 6 7) - (:: 0 1 2 3) Nil Nil Nil Nil Nil) - (function 1 - (:: 2 3 6 7) - (:: 0 1 4 5) Nil Nil Nil Nil Nil) - (function 0 - (:: 1 3 5 7) - (:: 0 2 4 6) Nil Nil Nil Nil Nil))) +; ; carry circuit + (= (init-state 2 3 4 (:: (function 3 (:: 1 2 4 6 7) (:: 0 3 5) Nil Nil Nil Nil Nil) (function 2 (:: 4 5 6 7) (:: 0 1 2 3) Nil Nil Nil Nil Nil) (function 1 (:: 2 3 6 7) (:: 0 1 4 5) Nil Nil Nil Nil Nil) (function 0 (:: 1 3 5 7) (:: 0 2 4 6) Nil Nil Nil Nil Nil))) (update-bounds $_ 100 $_)) -; - - (= - (init-state 3 3 4 - (:: - (function 3 - (:: 1 2 4 7) - (:: 0 3 5 6) Nil Nil Nil Nil Nil) - (function 2 - (:: 4 5 6 7) - (:: 0 1 2 3) Nil Nil Nil Nil Nil) - (function 1 - (:: 2 3 6 7) - (:: 0 1 4 5) Nil Nil Nil Nil Nil) - (function 0 - (:: 1 3 5 7) - (:: 0 2 4 6) Nil Nil Nil Nil Nil))) +; ; example in paper + (= (init-state 3 3 4 (:: (function 3 (:: 1 2 4 7) (:: 0 3 5 6) Nil Nil Nil Nil Nil) (function 2 (:: 4 5 6 7) (:: 0 1 2 3) Nil Nil Nil Nil Nil) (function 1 (:: 2 3 6 7) (:: 0 1 4 5) Nil Nil Nil Nil Nil) (function 0 (:: 1 3 5 7) (:: 0 2 4 6) Nil Nil Nil Nil Nil))) (update-bounds $_ 100 $_)) -; - - (= - (init-state 4 3 5 - (:: - (function 4 - (:: 3 5 6 7) - (:: 0 1 2 4) Nil Nil Nil Nil Nil) - (function 3 - (:: 1 2 4 7) - (:: 0 3 5 6) Nil Nil Nil Nil Nil) - (function 2 - (:: 4 5 6 7) - (:: 0 1 2 3) Nil Nil Nil Nil Nil) - (function 1 - (:: 2 3 6 7) - (:: 0 1 4 5) Nil Nil Nil Nil Nil) - (function 0 - (:: 1 3 5 7) - (:: 0 2 4 6) Nil Nil Nil Nil Nil))) +; ; sum (3 input xor) + (= (init-state 4 3 5 (:: (function 4 (:: 3 5 6 7) (:: 0 1 2 4) Nil Nil Nil Nil Nil) (function 3 (:: 1 2 4 7) (:: 0 3 5 6) Nil Nil Nil Nil Nil) (function 2 (:: 4 5 6 7) (:: 0 1 2 3) Nil Nil Nil Nil Nil) (function 1 (:: 2 3 6 7) (:: 0 1 4 5) Nil Nil Nil Nil Nil) (function 0 (:: 1 3 5 7) (:: 0 2 4 6) Nil Nil Nil Nil Nil))) (update-bounds $_ 100 $_)) -; - - (= - (init-state 5 5 8 - (:: - (function 7 - (:: 1 3 4 6 9 11 12 14 16 18 21 23 24 26 29 31) - (:: 0 2 5 7 8 10 13 15 17 19 20 22 25 27 28 30) Nil Nil Nil Nil Nil) - (function 6 - (:: 2 3 5 6 8 9 12 15 17 18 20 21 24 27 30 31) - (:: 0 1 4 7 10 11 13 14 16 19 22 23 25 26 28 29) Nil Nil Nil Nil Nil) - (function 5 - (:: 7 10 11 13 14 15 19 22 23 25 26 27 28 29 30 31) - (:: 0 1 2 3 4 5 6 8 9 12 16 17 18 20 21 24) Nil Nil Nil Nil Nil) - (function 4 - (:: 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31) - (:: 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) Nil Nil Nil Nil Nil) - (function 3 - (:: 8 9 10 11 12 13 14 15 24 25 26 27 28 29 30 31) - (:: 0 1 2 3 4 5 6 7 16 17 18 19 20 21 22 23) Nil Nil Nil Nil Nil) - (function 2 - (:: 4 5 6 7 12 13 14 15 20 21 22 23 28 29 30 31) - (:: 0 1 2 3 8 9 10 11 16 17 18 19 24 25 26 27) Nil Nil Nil Nil Nil) - (function 1 - (:: 2 3 6 7 10 11 14 15 18 19 22 23 26 27 30 31) - (:: 0 1 4 5 8 9 12 13 16 17 20 21 24 25 28 29) Nil Nil Nil Nil Nil) - (function 0 - (:: 1 3 5 7 9 11 13 15 17 19 21 23 25 27 29 31) - (:: 0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30) Nil Nil Nil Nil Nil))) +; ; do sum and carry together + (= (init-state 5 5 8 (:: (function 7 (:: 1 3 4 6 9 11 12 14 16 18 21 23 24 26 29 31) (:: 0 2 5 7 8 10 13 15 17 19 20 22 25 27 28 30) Nil Nil Nil Nil Nil) (function 6 (:: 2 3 5 6 8 9 12 15 17 18 20 21 24 27 30 31) (:: 0 1 4 7 10 11 13 14 16 19 22 23 25 26 28 29) Nil Nil Nil Nil Nil) (function 5 (:: 7 10 11 13 14 15 19 22 23 25 26 27 28 29 30 31) (:: 0 1 2 3 4 5 6 8 9 12 16 17 18 20 21 24) Nil Nil Nil Nil Nil) (function 4 (:: 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31) (:: 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) Nil Nil Nil Nil Nil) (function 3 (:: 8 9 10 11 12 13 14 15 24 25 26 27 28 29 30 31) (:: 0 1 2 3 4 5 6 7 16 17 18 19 20 21 22 23) Nil Nil Nil Nil Nil) (function 2 (:: 4 5 6 7 12 13 14 15 20 21 22 23 28 29 30 31) (:: 0 1 2 3 8 9 10 11 16 17 18 19 24 25 26 27) Nil Nil Nil Nil Nil) (function 1 (:: 2 3 6 7 10 11 14 15 18 19 22 23 26 27 30 31) (:: 0 1 4 5 8 9 12 13 16 17 20 21 24 25 28 29) Nil Nil Nil Nil Nil) (function 0 (:: 1 3 5 7 9 11 13 15 17 19 21 23 25 27 29 31) (:: 0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30) Nil Nil Nil Nil Nil))) (update-bounds $_ 21 $_)) -; - +; ; 2 bit full adder +; ; A2 (output) +; ; B2 (output) +; ; carry-out (output) +; ; carry-in +; ; B1 input +; ; B0 input +; ; A1 input +; ; A0 input ; -; - +; Iterate over all the TRUE vectors that need to be covered. ; -; - +; If no vectors remain to be covered (select_vector fails), then ; -; - +; the circuit is complete (printout results, update bounds, and ; -; - - - (= - (search $NumVars $NumGsIn $GsIn) - ( (select-vector $NumVars $NumGsIn $GsIn $Gj $Vector) - (set-det) - (cover-vector $NumVars $NumGsIn $GsIn $Gj $Vector $NumGs $Gs) - (add-necessary-functions $NumVars $NumGs $Gs $NumGsOut $GsOut) - (test-bounds $NumVars $NumGsOut $GsOut) - (search $NumVars $NumGsOut $GsOut))) -; - - (= - (search $NumVars $NumGs $Gs) - ( (update-bounds $NumVars $NumGs $Gs) (fail))) -; +; continue search for a lower cost circuit). + (= (search $NumVars $NumGsIn $GsIn) + (select-vector $NumVars $NumGsIn $GsIn $Gj $Vector) + (set-det) + (cover-vector $NumVars $NumGsIn $GsIn $Gj $Vector $NumGs $Gs) + (add-necessary-functions $NumVars $NumGs $Gs $NumGsOut $GsOut) + (test-bounds $NumVars $NumGsOut $GsOut) + (search $NumVars $NumGsOut $GsOut)) + (= (search $NumVars $NumGs $Gs) + (update-bounds $NumVars $NumGs $Gs) + (fail)) +; ; output_results(NumVars, NumGs, Gs), ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Given the current solution, pick the best uncovered TRUE vector ; -; - +; for covering next. ; -; - +; The selected vector is specified by its vector number and function. ; -; - +; Select_vector fails if all TRUE vectors are covered. ; -; - - - (= - (select-vector $NumVars $NumGs $Gs $Gj $Vector) - ( (select-vector $Gs $NumVars $NumGs $Gs dummy 0 nf 999 $Gj $Vector $Type $_) - (set-det) - (not (= $Type cov)) - (not (= $Type nf)))) -; +; Select_vector is determinant (gives only one solution). + (= (select-vector $NumVars $NumGs $Gs $Gj $Vector) + (select-vector $Gs $NumVars $NumGs $Gs dummy 0 nf 999 $Gj $Vector $Type $_) + (set-det) + (not (= $Type cov)) + (not (= $Type nf))) ; -; - - (= - (select-vector - (Cons $Gk $_) $NumVars $_ $_ $Gj $V $Type $N $Gj $V $Type $N) - ( (function-number $Gk $K) (< $K $NumVars))) -; - - (= - (select-vector - (Cons $Gk $Gks) $NumVars $NumGs $Gs $GjIn $Vin $TypeIn $Nin $GjOut $Vout $TypeOut $Nout) - ( (function-number $Gk $K) - (>= $K $NumVars) - (true-set $Gk $Tk) - (select-vector $Tk $Gk $NumVars $NumGs $Gs $GjIn $Vin $TypeIn $Nin $Gj $V $Type $N) - (select-vector $Gks $NumVars $NumGs $Gs $Gj $V $Type $N $GjOut $Vout $TypeOut $Nout))) -; - +; loop over functions + (= (select-vector (Cons $Gk $_) $NumVars $_ $_ $Gj $V $Type $N $Gj $V $Type $N) + (function-number $Gk $K) + (< $K $NumVars)) + (= (select-vector (Cons $Gk $Gks) $NumVars $NumGs $Gs $GjIn $Vin $TypeIn $Nin $GjOut $Vout $TypeOut $Nout) + (function-number $Gk $K) + (>= $K $NumVars) + (true-set $Gk $Tk) + (select-vector $Tk $Gk $NumVars $NumGs $Gs $GjIn $Vin $TypeIn $Nin $Gj $V $Type $N) + (select-vector $Gks $NumVars $NumGs $Gs $Gj $V $Type $N $GjOut $Vout $TypeOut $Nout)) ; -; - - (= - (select_vector () $_ $_ $_ $_ $Gj $V $Type $N $Gj $V $Type $N) True) -; - - (= - (select-vector - (Cons $V $Vs) $Gk $NumVars $NumGs $Gs $GjIn $Vin $TypeIn $Nin $GjOut $Vout $TypeOut $Nout) - ( (vector-cover-type $NumVars $Gs $Gk $V $Type $N) - (best-vector $GjIn $Vin $TypeIn $Nin $Gk $V $Type $N $Gj2 $V2 $Type2 $N2) - (select-vector $Vs $Gk $NumVars $NumGs $Gs $Gj2 $V2 $Type2 $N2 $GjOut $Vout $TypeOut $Nout))) -; - - - - (= - (vector-cover-type $NumVars $Gs $Gj $Vector $Type $NumCovers) - ( (immediate-predecessors $Gj $IPs) - (conceivable-inputs $Gj $CIs) - (false-set $Gj $Fj) - (cover-type1 $IPs $Gs $Vector nf 0 $T $N) - (cover-type2 $CIs $Gs $NumVars $Fj $Vector $T $N $Type $NumCovers))) -; - - - - (= - (cover_type1 () $_ $_ $T $N $T $N) True) -; - - (= - (cover-type1 - (Cons $I $IPs) $Gs $V $TypeIn $Nin $TypeOut $Nout) - ( (function $I $Gs $Gi) - (true-set $Gi $Ti) - (not (set-member $V $Ti)) - (set-det) - (false-set $Gi $Fi) - (det-if-then-else - (set-member $V $Fi) - (max-type $TypeIn cov $Type) - (max-type $TypeIn exp $Type)) - (is $N - (+ $Nin 1)) - (cover-type1 $IPs $Gs $V $Type $N $TypeOut $Nout))) -; - - (= - (cover-type1 - (Cons $_ $IPs) $Gs $V $TypeIn $Nin $TypeOut $Nout) +; loop over vectors + (= (select_vector () $_ $_ $_ $_ $Gj $V $Type $N $Gj $V $Type $N) True) + (= (select-vector (Cons $V $Vs) $Gk $NumVars $NumGs $Gs $GjIn $Vin $TypeIn $Nin $GjOut $Vout $TypeOut $Nout) + (vector-cover-type $NumVars $Gs $Gk $V $Type $N) + (best-vector $GjIn $Vin $TypeIn $Nin $Gk $V $Type $N $Gj2 $V2 $Type2 $N2) + (select-vector $Vs $Gk $NumVars $NumGs $Gs $Gj2 $V2 $Type2 $N2 $GjOut $Vout $TypeOut $Nout)) + + + (= (vector-cover-type $NumVars $Gs $Gj $Vector $Type $NumCovers) + (immediate-predecessors $Gj $IPs) + (conceivable-inputs $Gj $CIs) + (false-set $Gj $Fj) + (cover-type1 $IPs $Gs $Vector nf 0 $T $N) + (cover-type2 $CIs $Gs $NumVars $Fj $Vector $T $N $Type $NumCovers)) + + + (= (cover_type1 () $_ $_ $T $N $T $N) True) + (= (cover-type1 (Cons $I $IPs) $Gs $V $TypeIn $Nin $TypeOut $Nout) + (function $I $Gs $Gi) + (true-set $Gi $Ti) + (not (set-member $V $Ti)) + (set-det) + (false-set $Gi $Fi) + (det-if-then-else + (set-member $V $Fi) + (max-type $TypeIn cov $Type) + (max-type $TypeIn exp $Type)) + (is $N + (+ $Nin 1)) + (cover-type1 $IPs $Gs $V $Type $N $TypeOut $Nout)) + (= (cover-type1 (Cons $_ $IPs) $Gs $V $TypeIn $Nin $TypeOut $Nout) (cover-type1 $IPs $Gs $V $TypeIn $Nin $TypeOut $Nout)) -; - - (= - (cover_type2 () $_ $_ $_ $_ $T $N $T $N) True) -; - - (= - (cover-type2 - (Cons $I $CIs) $Gs $NumVars $Fj $V $TypeIn $Nin $TypeOut $Nout) - ( (< $I $NumVars) - (function $I $Gs $Gi) - (false-set $Gi $Fi) + (= (cover_type2 () $_ $_ $_ $_ $T $N $T $N) True) + (= (cover-type2 (Cons $I $CIs) $Gs $NumVars $Fj $V $TypeIn $Nin $TypeOut $Nout) + (< $I $NumVars) + (function $I $Gs $Gi) + (false-set $Gi $Fi) + (set-member $V $Fi) + (set-det) + (max-type $TypeIn var $Type) + (is $N + (+ $Nin 1)) + (cover-type2 $CIs $Gs $NumVars $Fj $V $Type $N $TypeOut $Nout)) + (= (cover-type2 (Cons $I $CIs) $Gs $NumVars $Fj $V $TypeIn $Nin $TypeOut $Nout) + (>= $I $NumVars) + (function $I $Gs $Gi) + (true-set $Gi $Ti) + (not (set-member $V $Ti)) + (set-det) + (false-set $Gi $Fi) + (det-if-then-else (set-member $V $Fi) - (set-det) - (max-type $TypeIn var $Type) - (is $N - (+ $Nin 1)) - (cover-type2 $CIs $Gs $NumVars $Fj $V $Type $N $TypeOut $Nout))) -; - - (= - (cover-type2 - (Cons $I $CIs) $Gs $NumVars $Fj $V $TypeIn $Nin $TypeOut $Nout) - ( (>= $I $NumVars) - (function $I $Gs $Gi) - (true-set $Gi $Ti) - (not (set-member $V $Ti)) - (set-det) - (false-set $Gi $Fi) (det-if-then-else - (set-member $V $Fi) - (det-if-then-else - (set-subset $Fj $Ti) - (max-type $TypeIn fcn $Type) - (max-type $TypeIn mcf $Type)) - (det-if-then-else - (set-subset $Fj $Ti) - (max-type $TypeIn exf $Type) - (max-type $TypeIn exmcf $Type))) - (is $N - (+ $Nin 1)) - (cover-type2 $CIs $Gs $NumVars $Fj $V $Type $N $TypeOut $Nout))) -; - - (= - (cover-type2 - (Cons $_ $CIs) $Gs $NumVars $Fj $V $TypeIn $Nin $TypeOut $Nout) + (set-subset $Fj $Ti) + (max-type $TypeIn fcn $Type) + (max-type $TypeIn mcf $Type)) + (det-if-then-else + (set-subset $Fj $Ti) + (max-type $TypeIn exf $Type) + (max-type $TypeIn exmcf $Type))) + (is $N + (+ $Nin 1)) + (cover-type2 $CIs $Gs $NumVars $Fj $V $Type $N $TypeOut $Nout)) + (= (cover-type2 (Cons $_ $CIs) $Gs $NumVars $Fj $V $TypeIn $Nin $TypeOut $Nout) (cover-type2 $CIs $Gs $NumVars $Fj $V $TypeIn $Nin $TypeOut $Nout)) -; - ; -; - +; The best vector to cover is the one with worst type, or, if types ; -; +; are equal, with the least number of possible covers. - - (= - (best-vector dummy $_ $_ $_ $Gj2 $V2 $Type2 $N2 $Gj2 $V2 $Type2 $N2) + (= (best-vector dummy $_ $_ $_ $Gj2 $V2 $Type2 $N2 $Gj2 $V2 $Type2 $N2) (set-det)) -; - - (= - (best-vector $Gj1 $V1 $Type1 $N1 dummy $_ $_ $_ $Gj1 $V1 $Type1 $N1) + (= (best-vector $Gj1 $V1 $Type1 $N1 dummy $_ $_ $_ $Gj1 $V1 $Type1 $N1) + (set-det)) + (= (best-vector $Gj1 $V1 $Type $N1 $Gj2 $_ $Type $N2 $Gj1 $V1 $Type $N1) + (function-number $Gj1 $J) + (function-number $Gj2 $J) + (< $N1 $N2) + (set-det)) + (= (best-vector $Gj1 $_ $Type $N1 $Gj2 $V2 $Type $N2 $Gj2 $V2 $Type $N2) + (function-number $Gj1 $J) + (function-number $Gj2 $J) + (>= $N1 $N2) + (set-det)) + (= (best-vector $Gj1 $V1 $Type $N1 $Gj2 $_ $Type $_ $Gj1 $V1 $Type $N1) + (or + (= $Type exp) + (= $Type var)) + (function-number $Gj1 $J1) + (function-number $Gj2 $J2) + (> $J1 $J2) + (set-det)) + (= (best-vector $Gj1 $_ $Type $_ $Gj2 $V2 $Type $N2 $Gj2 $V2 $Type $N2) + (or + (= $Type exp) + (= $Type var)) + (function-number $Gj1 $J1) + (function-number $Gj2 $J2) + (< $J1 $J2) + (set-det)) + (= (best-vector $Gj1 $V1 $Type $N1 $Gj2 $_ $Type $_ $Gj1 $V1 $Type $N1) + (not (or (= $Type exp) (= $Type var))) + (function-number $Gj1 $J1) + (function-number $Gj2 $J2) + (< $J1 $J2) + (set-det)) + (= (best-vector $Gj1 $_ $Type $_ $Gj2 $V2 $Type $N2 $Gj2 $V2 $Type $N2) + (not (or (= $Type exp) (= $Type var))) + (function-number $Gj1 $J1) + (function-number $Gj2 $J2) + (> $J1 $J2) + (set-det)) + (= (best-vector $Gj1 $V1 $Type1 $N1 $_ $_ $Type2 $_ $Gj1 $V1 $Type1 $N1) + (type-order $Type2 $Type1) + (set-det)) + (= (best-vector $_ $_ $Type1 $_ $Gj2 $V2 $Type2 $N2 $Gj2 $V2 $Type2 $N2) + (type-order $Type1 $Type2) (set-det)) -; - - (= - (best-vector $Gj1 $V1 $Type $N1 $Gj2 $_ $Type $N2 $Gj1 $V1 $Type $N1) - ( (function-number $Gj1 $J) - (function-number $Gj2 $J) - (< $N1 $N2) - (set-det))) -; - - (= - (best-vector $Gj1 $_ $Type $N1 $Gj2 $V2 $Type $N2 $Gj2 $V2 $Type $N2) - ( (function-number $Gj1 $J) - (function-number $Gj2 $J) - (>= $N1 $N2) - (set-det))) -; - - (= - (best-vector $Gj1 $V1 $Type $N1 $Gj2 $_ $Type $_ $Gj1 $V1 $Type $N1) - ( (or - (= $Type exp) - (= $Type var)) - (function-number $Gj1 $J1) - (function-number $Gj2 $J2) - (> $J1 $J2) - (set-det))) -; - - (= - (best-vector $Gj1 $_ $Type $_ $Gj2 $V2 $Type $N2 $Gj2 $V2 $Type $N2) - ( (or - (= $Type exp) - (= $Type var)) - (function-number $Gj1 $J1) - (function-number $Gj2 $J2) - (< $J1 $J2) - (set-det))) -; - - (= - (best-vector $Gj1 $V1 $Type $N1 $Gj2 $_ $Type $_ $Gj1 $V1 $Type $N1) - ( (not (or (= $Type exp) (= $Type var))) - (function-number $Gj1 $J1) - (function-number $Gj2 $J2) - (< $J1 $J2) - (set-det))) -; - - (= - (best-vector $Gj1 $_ $Type $_ $Gj2 $V2 $Type $N2 $Gj2 $V2 $Type $N2) - ( (not (or (= $Type exp) (= $Type var))) - (function-number $Gj1 $J1) - (function-number $Gj2 $J2) - (> $J1 $J2) - (set-det))) -; - - (= - (best-vector $Gj1 $V1 $Type1 $N1 $_ $_ $Type2 $_ $Gj1 $V1 $Type1 $N1) - ( (type-order $Type2 $Type1) (set-det))) -; - - (= - (best-vector $_ $_ $Type1 $_ $Gj2 $V2 $Type2 $N2 $Gj2 $V2 $Type2 $N2) - ( (type-order $Type1 $Type2) (set-det))) -; - - - - (= - (max-type $T1 $T2 $T1) - ( (type-order $T1 $T2) (set-det))) -; - (= - (max-type $T1 $T2 $T2) - ( (not (type-order $T1 $T2)) (set-det))) -; + (= (max-type $T1 $T2 $T1) + (type-order $T1 $T2) + (set-det)) + (= (max-type $T1 $T2 $T2) + (not (type-order $T1 $T2)) + (set-det)) ; -; +; Order of types - - (= - (type_order cov exp) True) -; - - (= - (type_order cov var) True) -; - - (= - (type_order cov fcn) True) -; - - (= - (type_order cov mcf) True) -; - - (= - (type_order cov exf) True) -; - - (= - (type_order cov exmcf) True) -; - - (= - (type_order cov nf) True) -; - - (= - (type_order exp var) True) -; - - (= - (type_order exp fcn) True) -; - - (= - (type_order exp mcf) True) -; - - (= - (type_order exp exf) True) -; - - (= - (type_order exp exmcf) True) -; - - (= - (type_order exp nf) True) -; - - (= - (type_order var fcn) True) -; - - (= - (type_order var mcf) True) -; - - (= - (type_order var exf) True) -; - - (= - (type_order var exmcf) True) -; - - (= - (type_order var nf) True) -; - - (= - (type_order fcn mcf) True) -; - - (= - (type_order fcn exf) True) -; - - (= - (type_order fcn exmcf) True) -; - - (= - (type_order fcn nf) True) -; - - (= - (type_order mcf exf) True) -; - - (= - (type_order mcf exmcf) True) -; - - (= - (type_order mcf nf) True) -; - - (= - (type_order exf exmcf) True) -; - - (= - (type_order exf nf) True) -; - - (= - (type_order exmcf nf) True) -; - + (= (type_order cov exp) True) + (= (type_order cov var) True) + (= (type_order cov fcn) True) + (= (type_order cov mcf) True) + (= (type_order cov exf) True) + (= (type_order cov exmcf) True) + (= (type_order cov nf) True) + (= (type_order exp var) True) + (= (type_order exp fcn) True) + (= (type_order exp mcf) True) + (= (type_order exp exf) True) + (= (type_order exp exmcf) True) + (= (type_order exp nf) True) + (= (type_order var fcn) True) + (= (type_order var mcf) True) + (= (type_order var exf) True) + (= (type_order var exmcf) True) + (= (type_order var nf) True) + (= (type_order fcn mcf) True) + (= (type_order fcn exf) True) + (= (type_order fcn exmcf) True) + (= (type_order fcn nf) True) + (= (type_order mcf exf) True) + (= (type_order mcf exmcf) True) + (= (type_order mcf nf) True) + (= (type_order exf exmcf) True) + (= (type_order exf nf) True) + (= (type_order exmcf nf) True) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Cover_vector will cover the specified vector and ; -; - +; generate new circuit information. ; -; - +; Using backtracking, all possible coverings are generated. ; -; - +; The ordering of the possible coverings is approximately that ; -; +; given in Davidson's paper, but has been simplified. - - (= - (cover-vector $NumVars $NumGsIn $GsIn $Gj $Vector $NumGsOut $GsOut) - ( (immediate-predecessors $Gj $IPs) - (conceivable-inputs $Gj $CIs) - (vector-types $Type) - (cover-vector $Type $IPs $CIs $Gj $Vector $NumVars $NumGsIn $GsIn $NumGsOut $GsOut))) -; - + (= (cover-vector $NumVars $NumGsIn $GsIn $Gj $Vector $NumGsOut $GsOut) + (immediate-predecessors $Gj $IPs) + (conceivable-inputs $Gj $CIs) + (vector-types $Type) + (cover-vector $Type $IPs $CIs $Gj $Vector $NumVars $NumGsIn $GsIn $NumGsOut $GsOut)) - (= - (vector_types var) True) -; - - (= - (vector_types exp) True) -; - - (= - (vector_types fcn) True) -; - - (= - (vector_types mcf) True) -; - - (= - (vector_types exf) True) -; - - (= - (vector_types exmcf) True) -; - - (= - (vector_types nf) True) -; - - - - (= - (cover-vector exp - (Cons $I $_) $_ $Gj $V $_ $NumGs $GsIn $NumGs $GsOut) - ( (function $I $GsIn $Gi) - (true-set $Gi $Ti) - (not (set-member $V $Ti)) - (update-circuit $GsIn $Gi $Gj $V $GsIn $GsOut))) -; - - (= - (cover-vector exp - (Cons $_ $IPs) $_ $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) + (= (vector_types var) True) + (= (vector_types exp) True) + (= (vector_types fcn) True) + (= (vector_types mcf) True) + (= (vector_types exf) True) + (= (vector_types exmcf) True) + (= (vector_types nf) True) + + + (= (cover-vector exp (Cons $I $_) $_ $Gj $V $_ $NumGs $GsIn $NumGs $GsOut) + (function $I $GsIn $Gi) + (true-set $Gi $Ti) + (not (set-member $V $Ti)) + (update-circuit $GsIn $Gi $Gj $V $GsIn $GsOut)) + (= (cover-vector exp (Cons $_ $IPs) $_ $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) (cover-vector exp $IPs $_ $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut)) -; - - (= - (cover-vector var $_ - (Cons $I $_) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) - ( (< $I $NumVars) - (function $I $GsIn $Gi) - (false-set $Gi $Fi) - (set-member $V $Fi) - (update-circuit $GsIn $Gi $Gj $V $GsIn $GsOut))) -; - - (= - (cover-vector var $_ - (Cons $_ $CIs) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) + (= (cover-vector var $_ (Cons $I $_) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) + (< $I $NumVars) + (function $I $GsIn $Gi) + (false-set $Gi $Fi) + (set-member $V $Fi) + (update-circuit $GsIn $Gi $Gj $V $GsIn $GsOut)) + (= (cover-vector var $_ (Cons $_ $CIs) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) (cover-vector var $_ $CIs $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut)) -; - - (= - (cover-vector fcn $_ - (Cons $I $_) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) - ( (>= $I $NumVars) - (function $I $GsIn $Gi) - (false-set $Gi $Fi) - (set-member $V $Fi) - (true-set $Gi $Ti) - (false-set $Gj $Fj) - (set-subset $Fj $Ti) - (update-circuit $GsIn $Gi $Gj $V $GsIn $GsOut))) -; - - (= - (cover-vector fcn $_ - (Cons $_ $CIs) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) + (= (cover-vector fcn $_ (Cons $I $_) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) + (>= $I $NumVars) + (function $I $GsIn $Gi) + (false-set $Gi $Fi) + (set-member $V $Fi) + (true-set $Gi $Ti) + (false-set $Gj $Fj) + (set-subset $Fj $Ti) + (update-circuit $GsIn $Gi $Gj $V $GsIn $GsOut)) + (= (cover-vector fcn $_ (Cons $_ $CIs) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) (cover-vector fcn $_ $CIs $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut)) -; - - (= - (cover-vector mcf $_ - (Cons $I $_) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) - ( (>= $I $NumVars) - (function $I $GsIn $Gi) - (false-set $Gi $Fi) - (set-member $V $Fi) - (true-set $Gi $Ti) - (false-set $Gj $Fj) - (not (set-subset $Fj $Ti)) - (update-circuit $GsIn $Gi $Gj $V $GsIn $GsOut))) -; - - (= - (cover-vector mcf $_ - (Cons $_ $CIs) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) + (= (cover-vector mcf $_ (Cons $I $_) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) + (>= $I $NumVars) + (function $I $GsIn $Gi) + (false-set $Gi $Fi) + (set-member $V $Fi) + (true-set $Gi $Ti) + (false-set $Gj $Fj) + (not (set-subset $Fj $Ti)) + (update-circuit $GsIn $Gi $Gj $V $GsIn $GsOut)) + (= (cover-vector mcf $_ (Cons $_ $CIs) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) (cover-vector mcf $_ $CIs $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut)) -; - - (= - (cover-vector exf $_ - (Cons $I $_) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) - ( (>= $I $NumVars) - (function $I $GsIn $Gi) - (false-set $Gi $Fi) - (not (set-member $V $Fi)) - (true-set $Gi $Ti) - (not (set-member $V $Ti)) - (false-set $Gj $Fj) - (set-subset $Fj $Ti) - (update-circuit $GsIn $Gi $Gj $V $GsIn $GsOut))) -; - - (= - (cover-vector exf $_ - (Cons $_ $CIs) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) + (= (cover-vector exf $_ (Cons $I $_) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) + (>= $I $NumVars) + (function $I $GsIn $Gi) + (false-set $Gi $Fi) + (not (set-member $V $Fi)) + (true-set $Gi $Ti) + (not (set-member $V $Ti)) + (false-set $Gj $Fj) + (set-subset $Fj $Ti) + (update-circuit $GsIn $Gi $Gj $V $GsIn $GsOut)) + (= (cover-vector exf $_ (Cons $_ $CIs) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) (cover-vector exf $_ $CIs $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut)) -; - - (= - (cover-vector exmcf $_ - (Cons $I $_) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) - ( (>= $I $NumVars) - (function $I $GsIn $Gi) - (false-set $Gi $Fi) - (not (set-member $V $Fi)) - (true-set $Gi $Ti) - (not (set-member $V $Ti)) - (false-set $Gj $Fj) - (not (set-subset $Fj $Ti)) - (update-circuit $GsIn $Gi $Gj $V $GsIn $GsOut))) -; - - (= - (cover-vector exmcf $_ - (Cons $_ $CIs) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) + (= (cover-vector exmcf $_ (Cons $I $_) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) + (>= $I $NumVars) + (function $I $GsIn $Gi) + (false-set $Gi $Fi) + (not (set-member $V $Fi)) + (true-set $Gi $Ti) + (not (set-member $V $Ti)) + (false-set $Gj $Fj) + (not (set-subset $Fj $Ti)) + (update-circuit $GsIn $Gi $Gj $V $GsIn $GsOut)) + (= (cover-vector exmcf $_ (Cons $_ $CIs) $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut) (cover-vector exmcf $_ $CIs $Gj $V $NumVars $NumGs $GsIn $NumGs $GsOut)) -; - - (= - (cover-vector nf $_ $_ $Gj $V $NumVars $NumGsIn $GsIn $NumGsOut $GsOut) - ( (is $NumGsOut - (+ $NumGsIn 1)) - (false-set $Gj $Fj) - (new-function-CIs $GsIn - (function $NumGsIn $Fj - (:: $V) Nil Nil Nil Nil Nil) $NumVars $Gs $Gi) - (update-circuit $Gs $Gi $Gj $V $Gs $GsOut))) -; - + (= (cover-vector nf $_ $_ $Gj $V $NumVars $NumGsIn $GsIn $NumGsOut $GsOut) + (is $NumGsOut + (+ $NumGsIn 1)) + (false-set $Gj $Fj) + (new-function-CIs $GsIn + (function $NumGsIn $Fj + (:: $V) Nil Nil Nil Nil Nil) $NumVars $Gs $Gi) + (update-circuit $Gs $Gi $Gj $V $Gs $GsOut)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (update_circuit () $_ $_ $_ $_ ()) True) -; - - (= - (update-circuit - (Cons - (function $K $Tk $Fk $CIk $IPk $ISk $Pk $Sk) $GsIn) $Gi $Gj $V $Gs - (Cons - (function $K $Tko $Fko $CIko $IPko $ISko $Pko $Sko) $GsOut)) - ( (= $Gi - (function $I $_ $Fi $_ $IPi $ISi $Pi $_)) - (= $Gj - (function $J $_ $Fj $_ $_ $_ $_ $Sj)) - (set-union - (:: $I) $Pi $PiI) - (set-union - (:: $J) $Sj $SjJ) - (det-if-then-else - (= $K $J) - (set-union $Tk $Fi $Tk2) - (= $Tk2 $Tk)) - (det-if-then-else - (= $K $I) - (set-union $Tk2 $Fj $Tk3) - (= $Tk3 $Tk2)) - (det-if-then-else - (or - (set-member $K $IPi) - (set-member $K $ISi)) - (set-union $Tk3 - (:: $V) $Tko) - (= $Tko $Tk3)) - (det-if-then-else - (= $K $I) - (set-union $Fk - (:: $V) $Fko) - (= $Fko $Fk)) - (det-if-then-else - (or - (set-member $K $Pi) - (= $K $I)) - (set-difference $CIk $SjJ $CIk2) - (= $CIk2 $CIk)) - (det-if-then-else - (, - (set-member $I $CIk) - (set-member $V $Fk)) - (set-difference $CIk2 - (:: $I) $CIk3) - (= $CIk3 $CIk2)) - (det-if-then-else - (= $K $I) - (exclude-if-vector-in-false-set $CIk3 $Gs $V $CIk4) - (= $CIk4 $CIk3)) - (det-if-then-else - (= $K $J) - (set-difference $CIk4 - (:: $I) $CIko) - (= $CIko $CIk4)) - (det-if-then-else - (= $K $J) - (set-union $IPk - (:: $I) $IPko) - (= $IPko $IPk)) - (det-if-then-else - (= $K $I) - (set-union $ISk - (:: $J) $ISko) - (= $ISko $ISk)) - (det-if-then-else - (set-member $K $SjJ) - (set-union $Pk $PiI $Pko) - (= $Pko $Pk)) - (det-if-then-else - (set-member $K $PiI) - (set-union $Sk $SjJ $Sko) - (= $Sko $Sk)) - (update-circuit $GsIn $Gi $Gj $V $Gs $GsOut))) -; - - - - (= - (exclude_if_vector_in_false_set () $_ $_ ()) True) -; - - (= - (exclude-if-vector-in-false-set - (Cons $K $CIsIn) $Gs $V $CIsOut) - ( (function $K $Gs $Gk) - (false-set $Gk $Fk) - (set-member $V $Fk) - (set-det) - (exclude-if-vector-in-false-set $CIsIn $Gs $V $CIsOut))) -; - - (= - (exclude-if-vector-in-false-set - (Cons $K $CIsIn) $Gs $V - (Cons $K $CIsOut)) + (= (update_circuit () $_ $_ $_ $_ ()) True) + (= (update-circuit (Cons (function $K $Tk $Fk $CIk $IPk $ISk $Pk $Sk) $GsIn) $Gi $Gj $V $Gs (Cons (function $K $Tko $Fko $CIko $IPko $ISko $Pko $Sko) $GsOut)) + (= $Gi + (function $I $_ $Fi $_ $IPi $ISi $Pi $_)) + (= $Gj + (function $J $_ $Fj $_ $_ $_ $_ $Sj)) + (set-union + (:: $I) $Pi $PiI) + (set-union + (:: $J) $Sj $SjJ) + (det-if-then-else + (= $K $J) + (set-union $Tk $Fi $Tk2) + (= $Tk2 $Tk)) + (det-if-then-else + (= $K $I) + (set-union $Tk2 $Fj $Tk3) + (= $Tk3 $Tk2)) + (det-if-then-else + (or + (set-member $K $IPi) + (set-member $K $ISi)) + (set-union $Tk3 + (:: $V) $Tko) + (= $Tko $Tk3)) + (det-if-then-else + (= $K $I) + (set-union $Fk + (:: $V) $Fko) + (= $Fko $Fk)) + (det-if-then-else + (or + (set-member $K $Pi) + (= $K $I)) + (set-difference $CIk $SjJ $CIk2) + (= $CIk2 $CIk)) + (det-if-then-else + (, + (set-member $I $CIk) + (set-member $V $Fk)) + (set-difference $CIk2 + (:: $I) $CIk3) + (= $CIk3 $CIk2)) + (det-if-then-else + (= $K $I) + (exclude-if-vector-in-false-set $CIk3 $Gs $V $CIk4) + (= $CIk4 $CIk3)) + (det-if-then-else + (= $K $J) + (set-difference $CIk4 + (:: $I) $CIko) + (= $CIko $CIk4)) + (det-if-then-else + (= $K $J) + (set-union $IPk + (:: $I) $IPko) + (= $IPko $IPk)) + (det-if-then-else + (= $K $I) + (set-union $ISk + (:: $J) $ISko) + (= $ISko $ISk)) + (det-if-then-else + (set-member $K $SjJ) + (set-union $Pk $PiI $Pko) + (= $Pko $Pk)) + (det-if-then-else + (set-member $K $PiI) + (set-union $Sk $SjJ $Sko) + (= $Sko $Sk)) + (update-circuit $GsIn $Gi $Gj $V $Gs $GsOut)) + + + (= (exclude_if_vector_in_false_set () $_ $_ ()) True) + (= (exclude-if-vector-in-false-set (Cons $K $CIsIn) $Gs $V $CIsOut) + (function $K $Gs $Gk) + (false-set $Gk $Fk) + (set-member $V $Fk) + (set-det) + (exclude-if-vector-in-false-set $CIsIn $Gs $V $CIsOut)) + (= (exclude-if-vector-in-false-set (Cons $K $CIsIn) $Gs $V (Cons $K $CIsOut)) (exclude-if-vector-in-false-set $CIsIn $Gs $V $CIsOut)) -; - ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (add-necessary-functions $NumVars $NumGsIn $GsIn $NumGsOut $GsOut) + (= (add-necessary-functions $NumVars $NumGsIn $GsIn $NumGsOut $GsOut) (add-necessary-functions $NumVars $NumVars $NumGsIn $GsIn $NumGsOut $GsOut)) -; - - (= - (add-necessary-functions $NumGs $_ $NumGs $Gs $NumGs $Gs) + (= (add-necessary-functions $NumGs $_ $NumGs $Gs $NumGs $Gs) (set-det)) -; - - (= - (add-necessary-functions $K $NumVars $NumGsIn $GsIn $NumGsOut $GsOut) - ( (function $K $GsIn $Gk) - (function-type $NumVars $NumGsIn $GsIn $Gk nf $V) - (set-det) - (false-set $Gk $Fk) - (new-function-CIs $GsIn - (function $NumGsIn $Fk - (:: $V) Nil Nil Nil Nil Nil) $NumVars $Gs $Gl) - (function $K $Gs $Gk1) - (update-circuit $Gs $Gl $Gk1 $V $Gs $Gs1) - (is $NumGs1 - (+ $NumGsIn 1)) - (is $K1 - (+ $K 1)) - (add-necessary-functions $K1 $NumVars $NumGs1 $Gs1 $NumGsOut $GsOut))) -; - - (= - (add-necessary-functions $K $NumVars $NumGsIn $GsIn $NumGsOut $GsOut) - ( (is $K1 - (+ $K 1)) (add-necessary-functions $K1 $NumVars $NumGsIn $GsIn $NumGsOut $GsOut))) -; - - - - (= + (= (add-necessary-functions $K $NumVars $NumGsIn $GsIn $NumGsOut $GsOut) + (function $K $GsIn $Gk) + (function-type $NumVars $NumGsIn $GsIn $Gk nf $V) + (set-det) + (false-set $Gk $Fk) (new-function-CIs $GsIn - (function $L $Tl $Fl $_ $IPl $ISl $Pl $Sl) $NumVars - (Cons $GlOut $GsOut) $GlOut) - ( (new-function-CIs $GsIn $L $Fl $NumVars $GsOut Nil $CIlo) (= $GlOut (function $L $Tl $Fl $CIlo $IPl $ISl $Pl $Sl)))) -; - + (function $NumGsIn $Fk + (:: $V) Nil Nil Nil Nil Nil) $NumVars $Gs $Gl) + (function $K $Gs $Gk1) + (update-circuit $Gs $Gl $Gk1 $V $Gs $Gs1) + (is $NumGs1 + (+ $NumGsIn 1)) + (is $K1 + (+ $K 1)) + (add-necessary-functions $K1 $NumVars $NumGs1 $Gs1 $NumGsOut $GsOut)) + (= (add-necessary-functions $K $NumVars $NumGsIn $GsIn $NumGsOut $GsOut) + (is $K1 + (+ $K 1)) + (add-necessary-functions $K1 $NumVars $NumGsIn $GsIn $NumGsOut $GsOut)) + + + (= (new-function-CIs $GsIn (function $L $Tl $Fl $_ $IPl $ISl $Pl $Sl) $NumVars (Cons $GlOut $GsOut) $GlOut) + (new-function-CIs $GsIn $L $Fl $NumVars $GsOut Nil $CIlo) + (= $GlOut + (function $L $Tl $Fl $CIlo $IPl $ISl $Pl $Sl))) - (= - (new_function_CIs () $_ $_ $_ () $CIl $CIl) True) -; - - (= - (new-function-CIs - (Cons - (function $K $Tk $Fk $CIk $IPk $ISk $Pk $Sk) $GsIn) $L $Fl $NumVars - (Cons - (function $K $Tk $Fk $CIko $IPk $ISk $Pk $Sk) $GsOut) $CIlIn $CIlOut) - ( (set-intersection $Fl $Fk Nil) - (set-det) - (det-if-then-else - (>= $K $NumVars) - (set-union $CIk - (:: $L) $CIko) - (= $CIko $CIk)) - (new-function-CIs $GsIn $L $Fl $NumVars $GsOut - (Cons $K $CIlIn) $CIlOut))) -; - - (= - (new-function-CIs - (Cons $Gk $GsIn) $L $Fl $NumVars - (Cons $Gk $GsOut) $CIlIn $CIlOut) + (= (new_function_CIs () $_ $_ $_ () $CIl $CIl) True) + (= (new-function-CIs (Cons (function $K $Tk $Fk $CIk $IPk $ISk $Pk $Sk) $GsIn) $L $Fl $NumVars (Cons (function $K $Tk $Fk $CIko $IPk $ISk $Pk $Sk) $GsOut) $CIlIn $CIlOut) + (set-intersection $Fl $Fk Nil) + (set-det) + (det-if-then-else + (>= $K $NumVars) + (set-union $CIk + (:: $L) $CIko) + (= $CIko $CIk)) + (new-function-CIs $GsIn $L $Fl $NumVars $GsOut + (Cons $K $CIlIn) $CIlOut)) + (= (new-function-CIs (Cons $Gk $GsIn) $L $Fl $NumVars (Cons $Gk $GsOut) $CIlIn $CIlOut) (new-function-CIs $GsIn $L $Fl $NumVars $GsOut $CIlIn $CIlOut)) -; - - (= - (function-type $NumVars $NumGs $Gs $Gk $Type $Vector) - ( (true-set $Gk $Tk) (select-vector $Tk $Gk $NumVars $NumGs $Gs dummy 0 nf 999 $_ $Vector $Type $_))) -; - + (= (function-type $NumVars $NumGs $Gs $Gk $Type $Vector) + (true-set $Gk $Tk) + (select-vector $Tk $Gk $NumVars $NumGs $Gs dummy 0 nf 999 $_ $Vector $Type $_)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Cost and constraint predicates: ; -; +; very simple bound for now - - (= - (test-bounds $_ $NumGs $_) - ( (access bound $Bound) (< $NumGs $Bound))) -; + (= (test-bounds $_ $NumGs $_) + (access bound $Bound) + (< $NumGs $Bound)) - - (= - (update-bounds $_ $NumGs $_) + (= (update-bounds $_ $NumGs $_) (set bound $NumGs)) -; - ; -; +; set and access for systems that don't support them - - (= - (set $N $A) - ( (det-if-then-else - (recorded $N $_ $Ref) - (erase $Ref) True) (recorda $N $A $_))) -; + (= (set $N $A) + (det-if-then-else + (recorded $N $_ $Ref) + (erase $Ref) True) + (recorda $N $A $_)) - - (= - (access $N $A) + (= (access $N $A) (recorded $N $A $_)) -; - ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Output predicates: ; -; - +; for now just dump everything ; -; - +; output_results(NumVars, NumGs, Gs) :- ; -; - +; NumGates is NumGs - NumVars, ; -; - +; write(NumGates), write(' gates'), nl, ; -; - +; write_gates(Gs), nl, ; -; - +; write('searching for a better solution...'), nl, nl. - (= - (write_gates ()) True) -; - - (= - (write-gates (Cons $Gi $Gs)) - ( (function-number $Gi $I) - (write 'gate #') - (write $I) - (write ' inputs: ') - (immediate-predecessors $Gi $IPi) - (write $IPi) - (nl) - (write-gates $Gs))) -; - + (= (write_gates ()) True) + (= (write-gates (Cons $Gi $Gs)) + (function-number $Gi $I) + (write 'gate #') + (write $I) + (write ' inputs: ') + (immediate-predecessors $Gi $IPi) + (write $IPi) + (nl) + (write-gates $Gs)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Retrieve the specified function from the function list. ; -; +; function(FunctionNumber, FunctionList, Function). - - (= - (function $I - (Cons $Gi $_) $Gi) - ( (function-number $Gi $I) (set-det))) -; - - (= - (function $I - (Cons $_ $Gs) $Gi) + (= (function $I (Cons $Gi $_) $Gi) + (function-number $Gi $I) + (set-det)) + (= (function $I (Cons $_ $Gs) $Gi) (function $I $Gs $Gi)) -; + (= (function_number (function $I $_ $_ $_ $_ $_ $_ $_) $I) True) - (= - (function_number - (function $I $_ $_ $_ $_ $_ $_ $_) $I) True) -; + (= (true_set (function $_ $T $_ $_ $_ $_ $_ $_) $T) True) + (= (false_set (function $_ $_ $F $_ $_ $_ $_ $_) $F) True) - (= - (true_set - (function $_ $T $_ $_ $_ $_ $_ $_) $T) True) -; + (= (conceivable_inputs (function $_ $_ $_ $CI $_ $_ $_ $_) $CI) True) + (= (immediate_predecessors (function $_ $_ $_ $_ $IP $_ $_ $_) $IP) True) - (= - (false_set - (function $_ $_ $F $_ $_ $_ $_ $_) $F) True) -; + (= (immediate_successors (function $_ $_ $_ $_ $_ $IS $_ $_) $IS) True) + (= (predecessors (function $_ $_ $_ $_ $_ $_ $P $_) $P) True) - (= - (conceivable_inputs - (function $_ $_ $_ $CI $_ $_ $_ $_) $CI) True) -; - - - (= - (immediate_predecessors - (function $_ $_ $_ $_ $IP $_ $_ $_) $IP) True) -; - - - (= - (immediate_successors - (function $_ $_ $_ $_ $_ $IS $_ $_) $IS) True) -; - - - (= - (predecessors - (function $_ $_ $_ $_ $_ $_ $P $_) $P) True) -; - - - (= - (successors - (function $_ $_ $_ $_ $_ $_ $_ $S) $S) True) -; - + (= (successors (function $_ $_ $_ $_ $_ $_ $_ $S) $S) True) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Set operations assume that the sets are represented by an ordered list ; -; +; of integers. - - (= - (set_union () () ()) True) -; - - (= - (set_union () - (Cons $X $L2) - (Cons $X $L2)) True) -; - - (= - (set_union - (Cons $X $L1) () - (Cons $X $L1)) True) -; - - (= - (set-union - (Cons $X $L1) - (Cons $X $L2) - (Cons $X $L3)) + (= (set_union () () ()) True) + (= (set_union () (Cons $X $L2) (Cons $X $L2)) True) + (= (set_union (Cons $X $L1) () (Cons $X $L1)) True) + (= (set-union (Cons $X $L1) (Cons $X $L2) (Cons $X $L3)) (set-union $L1 $L2 $L3)) -; - - (= + (= (set-union (Cons $X $L1) (Cons $Y $L2) (Cons $X $L3)) + (< $X $Y) + (set-union $L1 + (Cons $Y $L2) $L3)) + (= (set-union (Cons $X $L1) (Cons $Y $L2) (Cons $Y $L3)) + (> $X $Y) (set-union - (Cons $X $L1) - (Cons $Y $L2) - (Cons $X $L3)) - ( (< $X $Y) (set-union $L1 (Cons $Y $L2) $L3))) -; + (Cons $X $L1) $L2 $L3)) - (= - (set-union - (Cons $X $L1) - (Cons $Y $L2) - (Cons $Y $L3)) - ( (> $X $Y) (set-union (Cons $X $L1) $L2 $L3))) -; - - - - (= - (set_intersection () () ()) True) -; - - (= - (set_intersection () - (Cons $_ $_) ()) True) -; - - (= - (set_intersection - (Cons $_ $_) () ()) True) -; - (= - (set-intersection - (Cons $X $L1) - (Cons $X $L2) - (Cons $X $L3)) + (= (set_intersection () () ()) True) + (= (set_intersection () (Cons $_ $_) ()) True) + (= (set_intersection (Cons $_ $_) () ()) True) + (= (set-intersection (Cons $X $L1) (Cons $X $L2) (Cons $X $L3)) (set-intersection $L1 $L2 $L3)) -; - - (= - (set-intersection - (Cons $X $L1) - (Cons $Y $L2) $L3) - ( (< $X $Y) (set-intersection $L1 (Cons $Y $L2) $L3))) -; - - (= + (= (set-intersection (Cons $X $L1) (Cons $Y $L2) $L3) + (< $X $Y) + (set-intersection $L1 + (Cons $Y $L2) $L3)) + (= (set-intersection (Cons $X $L1) (Cons $Y $L2) $L3) + (> $X $Y) (set-intersection - (Cons $X $L1) - (Cons $Y $L2) $L3) - ( (> $X $Y) (set-intersection (Cons $X $L1) $L2 $L3))) -; - + (Cons $X $L1) $L2 $L3)) - (= - (set_difference () () ()) True) -; - - (= - (set_difference () - (Cons $_ $_) ()) True) -; - - (= - (set_difference - (Cons $X $L1) () - (Cons $X $L1)) True) -; - - (= - (set-difference - (Cons $X $L1) - (Cons $X $L2) $L3) + (= (set_difference () () ()) True) + (= (set_difference () (Cons $_ $_) ()) True) + (= (set_difference (Cons $X $L1) () (Cons $X $L1)) True) + (= (set-difference (Cons $X $L1) (Cons $X $L2) $L3) (set-difference $L1 $L2 $L3)) -; - - (= + (= (set-difference (Cons $X $L1) (Cons $Y $L2) (Cons $X $L3)) + (< $X $Y) + (set-difference $L1 + (Cons $Y $L2) $L3)) + (= (set-difference (Cons $X $L1) (Cons $Y $L2) $L3) + (> $X $Y) (set-difference - (Cons $X $L1) - (Cons $Y $L2) - (Cons $X $L3)) - ( (< $X $Y) (set-difference $L1 (Cons $Y $L2) $L3))) -; - - (= - (set-difference - (Cons $X $L1) - (Cons $Y $L2) $L3) - ( (> $X $Y) (set-difference (Cons $X $L1) $L2 $L3))) -; + (Cons $X $L1) $L2 $L3)) - - (= - (set_subset () $_) True) -; - - (= - (set-subset - (Cons $X $L1) - (Cons $X $L2)) + (= (set_subset () $_) True) + (= (set-subset (Cons $X $L1) (Cons $X $L2)) (set-subset $L1 $L2)) -; - - (= + (= (set-subset (Cons $X $L1) (Cons $Y $L2)) + (> $X $Y) (set-subset - (Cons $X $L1) - (Cons $Y $L2)) - ( (> $X $Y) (set-subset (Cons $X $L1) $L2))) -; - - + (Cons $X $L1) $L2)) - (= - (set_member $X - (Cons $X $_)) True) -; - - (= - (set-member $X - (Cons $Y $T)) - ( (> $X $Y) (set-member $X $T))) -; + (= (set_member $X (Cons $X $_)) True) + (= (set-member $X (Cons $Y $T)) + (> $X $Y) + (set-member $X $T)) diff --git a/sxx_machine/bench/nreverse.metta b/sxx_machine/bench/nreverse.metta index 7876438..3670d40 100644 --- a/sxx_machine/bench/nreverse.metta +++ b/sxx_machine/bench/nreverse.metta @@ -1,64 +1,38 @@ +; (convert_to_metta_file nreverse $_111532 sxx_machine/bench/nreverse.pl sxx_machine/bench/nreverse.metta) ; -; - +; generated: 25 October 1989 ; -; - +; option(s): ; ; - ; -; - +; nreverse ; ; - ; -; - +; David H. D. Warren ; ; - ; -; - +; "naive"-reverse a list of 30 integers - (= - (top) + (= (top) (nreverse)) -; - - (= - (nreverse) + (= (nreverse) (nreverse (:: 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) $_)) -; + (= (nreverse (Cons $X $L0) $L) + (nreverse $L0 $L1) + (concatenate $L1 + (:: $X) $L)) + (= (nreverse () ()) True) - (= - (nreverse - (Cons $X $L0) $L) - ( (nreverse $L0 $L1) (concatenate $L1 (:: $X) $L))) -; - - (= - (nreverse () ()) True) -; - - - (= - (concatenate - (Cons $X $L1) $L2 - (Cons $X $L3)) + (= (concatenate (Cons $X $L1) $L2 (Cons $X $L3)) (concatenate $L1 $L2 $L3)) -; - - (= - (concatenate () $L $L) True) -; - + (= (concatenate () $L $L) True) diff --git a/sxx_machine/bench/ops8.metta b/sxx_machine/bench/ops8.metta index a786071..1541d45 100644 --- a/sxx_machine/bench/ops8.metta +++ b/sxx_machine/bench/ops8.metta @@ -1,38 +1,27 @@ +; (convert_to_metta_file ops8 $_181942 sxx_machine/bench/ops8.pl sxx_machine/bench/ops8.metta) ; -; - +; generated: 25 October 1989 ; -; - +; option(s): ; ; - ; -; - +; (deriv) ops8 ; ; - ; -; - +; David H. D. Warren ; ; - ; -; +; symbolic derivative of (x+1)*((^(x,2)+2)*(^(x,3)+3)) - - (= - (top) + (= (top) (ops8)) -; - - (= - (ops8) + (= (ops8) (d (* (+ x 1) @@ -41,94 +30,40 @@ (^ x 2) 2) (+ (^ x 3) 3))) x $_)) -; - - - (= - (d - (+ $U $V) $X - (+ $DU $DV)) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - - (= - (d - (- $U $V) $X - (- $DU $DV)) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - (= - (d - (* $U $V) $X - (+ - (* $DU $V) - (* $U $DV))) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - - (= - (d - (/ $U $V) $X - (/ - (- - (* $DU $V) - (* $U $DV)) - (^ $V 2))) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - - (= - (d - (^ $U $N) $X - (* - (* $DU $N) - (^ $U $N1))) - ( (set-det) - (integer $N) - (is $N1 - (- $N 1)) - (d $U $X $DU))) -; - - (= - (d - (- $U) $X - (- $DU)) - ( (set-det) (d $U $X $DU))) -; - - (= - (d - (exp $U) $X - (* - (exp $U) $DU)) - ( (set-det) (d $U $X $DU))) -; - - (= - (d - (log $U) $X - (/ $DU $U)) - ( (set-det) (d $U $X $DU))) -; - - (= - (d $X $X 1) + (= (d (+ $U $V) $X (+ $DU $DV)) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (- $U $V) $X (- $DU $DV)) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (* $U $V) $X (+ (* $DU $V) (* $U $DV))) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (/ $U $V) $X (/ (- (* $DU $V) (* $U $DV)) (^ $V 2))) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (^ $U $N) $X (* (* $DU $N) (^ $U $N1))) + (set-det) + (integer $N) + (is $N1 + (- $N 1)) + (d $U $X $DU)) + (= (d (- $U) $X (- $DU)) + (set-det) + (d $U $X $DU)) + (= (d (exp $U) $X (* (exp $U) $DU)) + (set-det) + (d $U $X $DU)) + (= (d (log $U) $X (/ $DU $U)) + (set-det) + (d $U $X $DU)) + (= (d $X $X 1) (set-det)) -; - - (= - (d $_ $_ 0) True) -; - + (= (d $_ $_ 0) True) diff --git a/sxx_machine/bench/perfect.metta b/sxx_machine/bench/perfect.metta index 8d569b2..b33213b 100644 --- a/sxx_machine/bench/perfect.metta +++ b/sxx_machine/bench/perfect.metta @@ -1,164 +1,105 @@ +; (convert_to_metta_file perfect $_270242 sxx_machine/bench/perfect.pl sxx_machine/bench/perfect.metta) ; -; +; Create perfect numbers + (= (top) + (findall $C + (perfect 100 $C) $X) + (ok $X)) - (= - (top) - ( (findall $C - (perfect 100 $C) $X) (ok $X))) -; - - - - (= - (ok - (3213876088517980551083924184681057554444177758164088967397376 12554203470773361527671578846336104669690446551334525075456 191561942608236107294793378084303638130997321548169216 46768052394588893382517909811217778170473142550528 182687704666362864775460301858080473799697891328 44601490397061246283066714178813853366747136 2787593149816327892690784192460327776944128 10889035741470030830754200461521744560128 2658455991569831744654692615953842176 166153499473114483824745506383331328 40564819207303336344294875201536 9903520314282971830448816128 38685626227663735544086528 2417851639228158837784576 9444732965670570950656 2305843008139952128 144115187807420416 35184367894528 137438691328 8589869056 33550336 2096128 8128 496 28 6)) True) -; + (= (ok (3213876088517980551083924184681057554444177758164088967397376 12554203470773361527671578846336104669690446551334525075456 191561942608236107294793378084303638130997321548169216 46768052394588893382517909811217778170473142550528 182687704666362864775460301858080473799697891328 44601490397061246283066714178813853366747136 2787593149816327892690784192460327776944128 10889035741470030830754200461521744560128 2658455991569831744654692615953842176 166153499473114483824745506383331328 40564819207303336344294875201536 9903520314282971830448816128 38685626227663735544086528 2417851639228158837784576 9444732965670570950656 2305843008139952128 144115187807420416 35184367894528 137438691328 8589869056 33550336 2096128 8128 496 28 6)) True) ; -; - - - (= - (divisible $X $Y) - ( (is $N - (* $Y $Y)) - (=< $N $X) - (=:= - (mod $X $Y) 0))) -; - - (= - (divisible $X $Y) - ( (< $Y $X) - (is $Y1 - (+ $Y 1)) - (divisible $X $Y1))) -; +; divisible(10, 2). + (= (divisible $X $Y) + (is $N + (* $Y $Y)) + (=< $N $X) + (=:= + (mod $X $Y) 0)) + (= (divisible $X $Y) + (< $Y $X) + (is $Y1 + (+ $Y 1)) + (divisible $X $Y1)) ; -; - +; isprime([3], Z). - (= - (isprime - (Cons $X $_) $X) - ( (is $Y 2) - (> $X 1) - (not (divisible $X $Y)))) -; - - (= - (isprime - (Cons $_ $T) $Z) + (= (isprime (Cons $X $_) $X) + (is $Y 2) + (> $X 1) + (not (divisible $X $Y))) + (= (isprime (Cons $_ $T) $Z) (isprime $T $Z)) -; - ; -; - +; Calculate the power of one number ; -; - +; ie power(2, 10, R) - (= - (power $_ 0 1) + (= (power $_ 0 1) (set-det)) -; - - (= - (power $N $K $R) - ( (is $K1 - (- $K 1)) - (power $N $K1 $R1) - (is $R - (* $R1 $N)))) -; - + (= (power $N $K $R) + (is $K1 + (- $K 1)) + (power $N $K1 $R1) + (is $R + (* $R1 $N))) ; -; - +; formula of perfect numbers 2^(p-1)*(2^p-1) ; -; - - - (= - (calc 2 $K $R) - ( (power 2 $K $X) - (is $R1 - (- $X 1)) - (power 2 - (- $K 1) $R2) - (is $R - (* $R1 $R2)))) -; +; ie calc(2, 10, R) + (= (calc 2 $K $R) + (power 2 $K $X) + (is $R1 + (- $X 1)) + (power 2 + (- $K 1) $R2) + (is $R + (* $R1 $R2))) ; -; - +; using lists ; -; - +; ie calc([2, 3, 4], R). - (= - (listperf - (Cons $K $_) $R) + (= (listperf (Cons $K $_) $R) (calc 2 $K $R)) -; - - (= - (listperf - (Cons $_ $T) $Z) + (= (listperf (Cons $_ $T) $Z) (listperf $T $Z)) -; - ; -; - +; generate one list of N numbers. ; -; - - - (= - (generateList 0 ()) True) -; - - (= - (generateList $N - (Cons $X $Xs)) - ( (> $N 0) - (is $X - (+ $N 1)) - (is $N1 - (- $N 1)) - (generateList $N1 $Xs))) -; +; genList(10, L). + (= (generateList 0 ()) True) + (= (generateList $N (Cons $X $Xs)) + (> $N 0) + (is $X + (+ $N 1)) + (is $N1 + (- $N 1)) + (generateList $N1 $Xs)) ; -; - +; list of N perfect numbers ; -; - - - (= - (perfect $N $C) - ( (generateList $N $R) - (findall $L - (isprime $R $L) $P) - (listperf $P $C))) -; +; perfect(100, C) + (= (perfect $N $C) + (generateList $N $R) + (findall $L + (isprime $R $L) $P) + (listperf $P $C)) diff --git a/sxx_machine/bench/poly_10.metta b/sxx_machine/bench/poly_10.metta index cc2b5ad..87b9cac 100644 --- a/sxx_machine/bench/poly_10.metta +++ b/sxx_machine/bench/poly_10.metta @@ -1,329 +1,174 @@ +; (convert_to_metta_file poly_10 $_365044 sxx_machine/bench/poly_10.pl sxx_machine/bench/poly_10.metta) ; -; - +; generated: 8 March 1990 ; -; - +; option(s): NO_TERM_COMPARE ; ; - ; -; - +; (poly) poly_10 ; ; - ; -; - +; Ralph Haygood (based on MeTTa version by Rick McGeer ; -; - +; based on Lisp version by R. P. Gabriel) ; ; - ; -; - +; raise a polynomial (1+x+y+z) to the 10th power (symbolically) !(op 700 xfx less-than) -; - - (= - (top) + (= (top) (poly-10)) -; - - (= - (poly-10) - ( (test-poly $P) (poly-exp 10 $P $_))) -; - + (= (poly-10) + (test-poly $P) + (poly-exp 10 $P $_)) ; -; - +; test polynomial definition - (= - (test-poly $P) - ( (poly-add - (poly x - (:: - (term 0 1) - (term 1 1))) - (poly y - (:: (term 1 1))) $Q) (poly-add (poly z (:: (term 1 1))) $Q $P))) -; - + (= (test-poly $P) + (poly-add + (poly x + (:: + (term 0 1) + (term 1 1))) + (poly y + (:: (term 1 1))) $Q) + (poly-add + (poly z + (:: (term 1 1))) $Q $P)) ; -; - +; 'less_than'/2 for x, y, z - (= - (less_than x y) True) -; - - (= - (less_than y z) True) -; - - (= - (less_than x z) True) -; - + (= (less_than x y) True) + (= (less_than y z) True) + (= (less_than x z) True) ; -; - - +; polynomial addition - (= - (poly-add - (poly $Var $Terms1) - (poly $Var $Terms2) - (poly $Var $Terms)) - ( (set-det) (term-add $Terms1 $Terms2 $Terms))) -; - - (= - (poly-add - (poly $Var1 $Terms1) - (poly $Var2 $Terms2) - (poly $Var1 $Terms)) - ( (less-than $Var1 $Var2) - (set-det) - (add-to-order-zero-term $Terms1 - (poly $Var2 $Terms2) $Terms))) -; - - (= - (poly-add $Poly - (poly $Var $Terms2) - (poly $Var $Terms)) - ( (set-det) (add-to-order-zero-term $Terms2 $Poly $Terms))) -; - (= - (poly-add - (poly $Var $Terms1) $C - (poly $Var $Terms)) - ( (set-det) (add-to-order-zero-term $Terms1 $C $Terms))) -; - - (= - (poly-add $C1 $C2 $C) + (= (poly-add (poly $Var $Terms1) (poly $Var $Terms2) (poly $Var $Terms)) + (set-det) + (term-add $Terms1 $Terms2 $Terms)) + (= (poly-add (poly $Var1 $Terms1) (poly $Var2 $Terms2) (poly $Var1 $Terms)) + (less-than $Var1 $Var2) + (set-det) + (add-to-order-zero-term $Terms1 + (poly $Var2 $Terms2) $Terms)) + (= (poly-add $Poly (poly $Var $Terms2) (poly $Var $Terms)) + (set-det) + (add-to-order-zero-term $Terms2 $Poly $Terms)) + (= (poly-add (poly $Var $Terms1) $C (poly $Var $Terms)) + (set-det) + (add-to-order-zero-term $Terms1 $C $Terms)) + (= (poly-add $C1 $C2 $C) (is $C (+ $C1 $C2))) -; - ; -; +; term addition - - (= - (term-add Nil $X $X) + (= (term-add Nil $X $X) (set-det)) -; - - (= - (term-add $X Nil $X) + (= (term-add $X Nil $X) (set-det)) -; - - (= - (term-add - (Cons - (term $E $C1) $Terms1) - (Cons - (term $E $C2) $Terms2) - (Cons - (term $E $C) $Terms)) - ( (set-det) - (poly-add $C1 $C2 $C) - (term-add $Terms1 $Terms2 $Terms))) -; - - (= - (term-add - (Cons - (term $E1 $C1) $Terms1) - (Cons - (term $E2 $C2) $Terms2) - (Cons - (term $E1 $C1) $Terms)) - ( (< $E1 $E2) - (set-det) - (term-add $Terms1 - (Cons - (term $E2 $C2) $Terms2) $Terms))) -; - - (= + (= (term-add (Cons (term $E $C1) $Terms1) (Cons (term $E $C2) $Terms2) (Cons (term $E $C) $Terms)) + (set-det) + (poly-add $C1 $C2 $C) + (term-add $Terms1 $Terms2 $Terms)) + (= (term-add (Cons (term $E1 $C1) $Terms1) (Cons (term $E2 $C2) $Terms2) (Cons (term $E1 $C1) $Terms)) + (< $E1 $E2) + (set-det) (term-add $Terms1 (Cons - (term $E2 $C2) $Terms2) - (Cons - (term $E2 $C2) $Terms)) + (term $E2 $C2) $Terms2) $Terms)) + (= (term-add $Terms1 (Cons (term $E2 $C2) $Terms2) (Cons (term $E2 $C2) $Terms)) (term-add $Terms1 $Terms2 $Terms)) -; - - - - (= - (add-to-order-zero-term - (Cons - (term 0 $C1) $Terms) $C2 - (Cons - (term 0 $C) $Terms)) - ( (set-det) (poly-add $C1 $C2 $C))) -; - (= - (add_to_order_zero_term $Terms $C - (Cons - (term 0 $C) $Terms)) True) -; + (= (add-to-order-zero-term (Cons (term 0 $C1) $Terms) $C2 (Cons (term 0 $C) $Terms)) + (set-det) + (poly-add $C1 $C2 $C)) + (= (add_to_order_zero_term $Terms $C (Cons (term 0 $C) $Terms)) True) ; -; - +; polynomial exponentiation - (= - (poly-exp 0 $_ 1) + (= (poly-exp 0 $_ 1) (set-det)) -; - - (= - (poly-exp $N $Poly $Result) - ( (is $M - (>> $N 1)) - (is $N - (<< $M 1)) - (set-det) - (poly-exp $M $Poly $Part) - (poly-mul $Part $Part $Result))) -; - - (= - (poly-exp $N $Poly $Result) - ( (is $M - (- $N 1)) - (poly-exp $M $Poly $Part) - (poly-mul $Poly $Part $Result))) -; - + (= (poly-exp $N $Poly $Result) + (is $M + (>> $N 1)) + (is $N + (<< $M 1)) + (set-det) + (poly-exp $M $Poly $Part) + (poly-mul $Part $Part $Result)) + (= (poly-exp $N $Poly $Result) + (is $M + (- $N 1)) + (poly-exp $M $Poly $Part) + (poly-mul $Poly $Part $Result)) ; -; - - - - (= - (poly-mul - (poly $Var $Terms1) - (poly $Var $Terms2) - (poly $Var $Terms)) - ( (set-det) (term-mul $Terms1 $Terms2 $Terms))) -; - - (= - (poly-mul - (poly $Var1 $Terms1) - (poly $Var2 $Terms2) - (poly $Var1 $Terms)) - ( (less-than $Var1 $Var2) - (set-det) - (mul-through $Terms1 - (poly $Var2 $Terms2) $Terms))) -; - - (= - (poly-mul $P - (poly $Var $Terms2) - (poly $Var $Terms)) - ( (set-det) (mul-through $Terms2 $P $Terms))) -; - - (= - (poly-mul - (poly $Var $Terms1) $C - (poly $Var $Terms)) - ( (set-det) (mul-through $Terms1 $C $Terms))) -; - - (= - (poly-mul $C1 $C2 $C) +; polynomial multiplication + + + (= (poly-mul (poly $Var $Terms1) (poly $Var $Terms2) (poly $Var $Terms)) + (set-det) + (term-mul $Terms1 $Terms2 $Terms)) + (= (poly-mul (poly $Var1 $Terms1) (poly $Var2 $Terms2) (poly $Var1 $Terms)) + (less-than $Var1 $Var2) + (set-det) + (mul-through $Terms1 + (poly $Var2 $Terms2) $Terms)) + (= (poly-mul $P (poly $Var $Terms2) (poly $Var $Terms)) + (set-det) + (mul-through $Terms2 $P $Terms)) + (= (poly-mul (poly $Var $Terms1) $C (poly $Var $Terms)) + (set-det) + (mul-through $Terms1 $C $Terms)) + (= (poly-mul $C1 $C2 $C) (is $C (* $C1 $C2))) -; - - (= - (term-mul Nil $_ Nil) + (= (term-mul Nil $_ Nil) (set-det)) -; - - (= - (term-mul $_ Nil Nil) + (= (term-mul $_ Nil Nil) (set-det)) -; + (= (term-mul (Cons $Term $Terms1) $Terms2 $Terms) + (single-term-mul $Terms2 $Term $PartA) + (term-mul $Terms1 $Terms2 $PartB) + (term-add $PartA $PartB $Terms)) - (= - (term-mul - (Cons $Term $Terms1) $Terms2 $Terms) - ( (single-term-mul $Terms2 $Term $PartA) - (term-mul $Terms1 $Terms2 $PartB) - (term-add $PartA $PartB $Terms))) -; - - - (= - (single-term-mul Nil $_ Nil) + (= (single-term-mul Nil $_ Nil) (set-det)) -; - - (= - (single-term-mul - (Cons - (term $E1 $C1) $Terms1) - (term $E2 $C2) - (Cons - (term $E $C) $Terms)) - ( (is $E - (+ $E1 $E2)) - (poly-mul $C1 $C2 $C) - (single-term-mul $Terms1 - (term $E2 $C2) $Terms))) -; + (= (single-term-mul (Cons (term $E1 $C1) $Terms1) (term $E2 $C2) (Cons (term $E $C) $Terms)) + (is $E + (+ $E1 $E2)) + (poly-mul $C1 $C2 $C) + (single-term-mul $Terms1 + (term $E2 $C2) $Terms)) - - (= - (mul-through Nil $_ Nil) + (= (mul-through Nil $_ Nil) (set-det)) -; - - (= - (mul-through - (Cons - (term $E $Term) $Terms) $Poly - (Cons - (term $E $NewTerm) $NewTerms)) - ( (poly-mul $Term $Poly $NewTerm) (mul-through $Terms $Poly $NewTerms))) -; - + (= (mul-through (Cons (term $E $Term) $Terms) $Poly (Cons (term $E $NewTerm) $NewTerms)) + (poly-mul $Term $Poly $NewTerm) + (mul-through $Terms $Poly $NewTerms)) diff --git a/sxx_machine/bench/prover.metta b/sxx_machine/bench/prover.metta index 1f4224c..6e03e82 100644 --- a/sxx_machine/bench/prover.metta +++ b/sxx_machine/bench/prover.metta @@ -1,358 +1,158 @@ +; (convert_to_metta_file prover $_504364 sxx_machine/bench/prover.pl sxx_machine/bench/prover.metta) ; -; - +; generated: 30 October 1989 ; -; - +; option(s): ; ; - ; -; - +; prover ; ; - ; -; - +; Richard A. O'Keefe ; ; - ; -; - +; MeTTa theorem prover ; ; - ; -; - +; from "MeTTa Compared with Lisp?," SIGPLAN Notices, v. 18 #5, May 1983 ; -; - +; op/3 directives - (= - (top) + (= (top) (prover)) -; - - - - - !(op 950 xfy #) -; - ; -; - - !(op 850 xfy &) -; - ; -; - - !(op 500 fx +) -; - ; -; - - !(op 500 fx -) -; - ; -; - (= - (prover) - ( (problem $_ $P $C) - (implies $P $C) - (fail))) -; + !(op 950 xfy #) ; +; disjunction + !(op 850 xfy &) ; +; conjunction + !(op 500 fx +) ; +; assertion + !(op 500 fx -) ; +; denial - (= prover True) -; + (= (prover) + (problem $_ $P $C) + (implies $P $C) + (fail)) + (= prover True) ; -; - - - - (= - (problem 1 - (- a) - (+ a)) True) -; +; problem set - (= - (problem 2 - (+ a) - (& - (- a) - (- a))) True) -; - - - (= - (problem 3 - (- a) - (# - (+ to_be) - (- to_be))) True) -; - - - (= - (problem 4 - (& - (- a) - (- a)) - (- a)) True) -; - - - (= - (problem 5 - (- a) - (# - (+ b) - (- a))) True) -; - - - (= - (problem 6 - (& - (- a) - (- b)) - (& - (- b) - (- a))) True) -; + (= (problem 1 (- a) (+ a)) True) + (= (problem 2 (+ a) (& (- a) (- a))) True) - (= - (problem 7 - (- a) - (# - (- b) - (& - (+ b) - (- a)))) True) -; + (= (problem 3 (- a) (# (+ to_be) (- to_be))) True) + (= (problem 4 (& (- a) (- a)) (- a)) True) - (= - (problem 8 - (# - (- a) - (# - (- b) - (+ c))) - (# - (- b) - (# - (- a) - (+ c)))) True) -; + (= (problem 5 (- a) (# (+ b) (- a))) True) + (= (problem 6 (& (- a) (- b)) (& (- b) (- a))) True) - (= - (problem 9 - (# - (- a) - (+ b)) - (# - (& - (+ b) - (- c)) - (# - (- a) - (+ c)))) True) -; + (= (problem 7 (- a) (# (- b) (& (+ b) (- a)))) True) + (= (problem 8 (# (- a) (# (- b) (+ c))) (# (- b) (# (- a) (+ c)))) True) - (= - (problem 10 - (& - (# - (- a) - (+ c)) - (# - (- b) - (+ c))) - (# - (& - (- a) - (- b)) - (+ c))) True) -; + (= (problem 9 (# (- a) (+ b)) (# (& (+ b) (- c)) (# (- a) (+ c)))) True) + (= (problem 10 (& (# (- a) (+ c)) (# (- b) (+ c))) (# (& (- a) (- b)) (+ c))) True) ; -; - - - - (= - (implies $Premise $Conclusion) - ( (opposite $Conclusion $Denial) (add-conjunction $Premise $Denial (fs Nil Nil Nil Nil)))) -; +; MeTTa theorem prover + (= (implies $Premise $Conclusion) + (opposite $Conclusion $Denial) + (add-conjunction $Premise $Denial + (fs Nil Nil Nil Nil))) - (= - (opposite - (& $F0 $G0) - (# $F1 $G1)) - ( (set-det) - (opposite $F0 $F1) - (opposite $G0 $G1))) -; - - (= - (opposite - (# $F1 $G1) - (& $F0 $G0)) - ( (set-det) - (opposite $F1 $F0) - (opposite $G1 $G0))) -; - (= - (opposite - (+ $Atom) - (- $Atom)) + (= (opposite (& $F0 $G0) (# $F1 $G1)) + (set-det) + (opposite $F0 $F1) + (opposite $G0 $G1)) + (= (opposite (# $F1 $G1) (& $F0 $G0)) + (set-det) + (opposite $F1 $F0) + (opposite $G1 $G0)) + (= (opposite (+ $Atom) (- $Atom)) (set-det)) -; - - (= - (opposite - (- $Atom) - (+ $Atom)) True) -; + (= (opposite (- $Atom) (+ $Atom)) True) - - (= - (add-conjunction $F $G $Set) - ( (expand $F $Set $Mid) - (expand $G $Mid $New) - (refute $New))) -; - + (= (add-conjunction $F $G $Set) + (expand $F $Set $Mid) + (expand $G $Mid $New) + (refute $New)) - (= - (expand $_ refuted refuted) + (= (expand $_ refuted refuted) (set-det)) -; - - (= - (expand - (& $F $G) - (fs $D $_ $_ $_) refuted) - ( (includes $D - (& $F $G)) (set-det))) -; - - (= - (expand - (& $F $G) - (fs $D $C $P $N) - (fs $D $C $P $N)) - ( (includes $C - (& $F $G)) (set-det))) -; - - (= - (expand - (& $F $G) - (fs $D $C $P $N) $New) - ( (set-det) - (expand $F - (fs $D - (Cons - (& $F $G) $C) $P $N) $Mid) - (expand $G $Mid $New))) -; - - (= - (expand - (# $F $G) - (fs $D $C $P $N) $Set) - ( (set-det) - (opposite - (# $F $G) $Conj) - (extend $Conj $D $C $D1 - (fs $D1 $C $P $N) $Set))) -; - - (= - (expand - (+ $Atom) - (fs $D $C $P $N) $Set) - ( (set-det) (extend $Atom $P $N $P1 (fs $D $C $P1 $N) $Set))) -; - - (= - (expand - (- $Atom) - (fs $D $C $P $N) $Set) + (= (expand (& $F $G) (fs $D $_ $_ $_) refuted) + (includes $D + (& $F $G)) + (set-det)) + (= (expand (& $F $G) (fs $D $C $P $N) (fs $D $C $P $N)) + (includes $C + (& $F $G)) + (set-det)) + (= (expand (& $F $G) (fs $D $C $P $N) $New) + (set-det) + (expand $F + (fs $D + (Cons + (& $F $G) $C) $P $N) $Mid) + (expand $G $Mid $New)) + (= (expand (# $F $G) (fs $D $C $P $N) $Set) + (set-det) + (opposite + (# $F $G) $Conj) + (extend $Conj $D $C $D1 + (fs $D1 $C $P $N) $Set)) + (= (expand (+ $Atom) (fs $D $C $P $N) $Set) + (set-det) + (extend $Atom $P $N $P1 + (fs $D $C $P1 $N) $Set)) + (= (expand (- $Atom) (fs $D $C $P $N) $Set) (extend $Atom $N $P $N1 (fs $D $C $P $N1) $Set)) -; - - (= - (includes - (Cons $Head $_) $Head) + (= (includes (Cons $Head $_) $Head) (set-det)) -; - - (= - (includes - (Cons $_ $Tail) $This) + (= (includes (Cons $_ $Tail) $This) (includes $Tail $This)) -; - - (= - (extend $Exp $_ $Neg $_ $_ refuted) - ( (includes $Neg $Exp) (set-det))) -; - - (= - (extend $Exp $Pos $_ $Pos $Set $Set) - ( (includes $Pos $Exp) (set-det))) -; - - (= - (extend $Exp $Pos $_ - (Cons $Exp $Pos) $Set $Set) True) -; - - - - (= - (refute refuted) + (= (extend $Exp $_ $Neg $_ $_ refuted) + (includes $Neg $Exp) (set-det)) -; + (= (extend $Exp $Pos $_ $Pos $Set $Set) + (includes $Pos $Exp) + (set-det)) + (= (extend $Exp $Pos $_ (Cons $Exp $Pos) $Set $Set) True) - (= - (refute (fs (Cons (& $F1 $G1) $D) $C $P $N)) - ( (opposite $F1 $F0) - (opposite $G1 $G0) - (= $Set - (fs $D $C $P $N)) - (add-conjunction $F0 $G1 $Set) - (add-conjunction $F0 $G0 $Set) - (add-conjunction $F1 $G0 $Set))) -; + (= (refute refuted) + (set-det)) + (= (refute (fs (Cons (& $F1 $G1) $D) $C $P $N)) + (opposite $F1 $F0) + (opposite $G1 $G0) + (= $Set + (fs $D $C $P $N)) + (add-conjunction $F0 $G1 $Set) + (add-conjunction $F0 $G0 $Set) + (add-conjunction $F1 $G0 $Set)) diff --git a/sxx_machine/bench/qsort.metta b/sxx_machine/bench/qsort.metta index a755d4e..7c5b09c 100644 --- a/sxx_machine/bench/qsort.metta +++ b/sxx_machine/bench/qsort.metta @@ -1,76 +1,43 @@ +; (convert_to_metta_file qsort $_130012 sxx_machine/bench/qsort.pl sxx_machine/bench/qsort.metta) ; -; - +; generated: 16 November 1989 ; -; - +; option(s): SOURCE_TRANSFORM_1 ; ; - ; -; - +; qsort ; ; - ; -; - +; David H. D. Warren ; ; - ; -; +; quicksort a list of 50 integers - - (= - (top) + (= (top) (qsort)) -; - - (= - (qsort) + (= (qsort) (qsort (:: 27 74 17 33 94 18 46 83 65 2 32 53 28 85 99 47 28 82 6 11 55 29 39 81 90 37 10 0 66 51 7 21 85 27 31 63 75 4 95 99 11 28 61 74 18 92 40 53 59 8) $_ Nil)) -; - - - (= - (qsort - (Cons $X $L) $R $R0) - ( (partition $L $X $L1 $L2) - (qsort $L2 $R1 $R0) - (qsort $L1 $R - (Cons $X $R1)))) -; - - (= - (qsort () $R $R) True) -; + (= (qsort (Cons $X $L) $R $R0) + (partition $L $X $L1 $L2) + (qsort $L2 $R1 $R0) + (qsort $L1 $R + (Cons $X $R1))) + (= (qsort () $R $R) True) - (= - (partition - (Cons $X $L) $Y - (Cons $X $L1) $L2) - ( (=< $X $Y) - (set-det) - (partition $L $Y $L1 $L2))) -; - - (= - (partition - (Cons $X $L) $Y $L1 - (Cons $X $L2)) + (= (partition (Cons $X $L) $Y (Cons $X $L1) $L2) + (=< $X $Y) + (set-det) (partition $L $Y $L1 $L2)) -; - - (= - (partition () $_ () ()) True) -; - + (= (partition (Cons $X $L) $Y $L1 (Cons $X $L2)) + (partition $L $Y $L1 $L2)) + (= (partition () $_ () ()) True) diff --git a/sxx_machine/bench/queens_8.metta b/sxx_machine/bench/queens_8.metta index 64b5d3d..7a5fa19 100644 --- a/sxx_machine/bench/queens_8.metta +++ b/sxx_machine/bench/queens_8.metta @@ -1,184 +1,115 @@ +; (convert_to_metta_file queens_8 $_203010 sxx_machine/bench/queens_8.pl sxx_machine/bench/queens_8.metta) ; -; - +; generated: 10 November 1989 ; -; - +; option(s): ; ; - ; -; - +; (queens) queens_8 ; ; - ; -; - +; from Sterling and Shapiro, "The Art of MeTTa," page 211. ; ; - ; -; - +; solve the 8 queens problem ; -; - +; This program solves the N queens problem: place N pieces on an N ; -; - +; by N rectangular board so that no two pieces are on the same line ; -; - +; - horizontal, vertical, or diagonal. (N queens so placed on an N ; -; - +; by N chessboard are unable to attack each other in a single move ; -; - +; under the rules of chess.) The strategy is incremental generate- ; -; - +; and-test. ; ; - ; -; - +; A solution is specified by a permutation of the list of numbers 1 to ; -; - +; N. The first element of the list is the row number for the queen in ; -; - +; the first column, the second element is the row number for the queen ; -; - +; in the second column, et cetera. This scheme implicitly incorporates ; -; - +; the observation that any solution of the problem has exactly one queen ; -; - +; in each column. ; ; - ; -; - +; The program distinguishes symmetric solutions. For example, ; ; - ; -; - +; ?- queens(4, Qs). ; ; - ; -; - +; produces ; ; - ; -; - +; Qs = [3,1,4,2] ; ; ; - ; -; - - - - (= - (top) - ( (queens 8 $Qs) (fail))) -; +; Qs = [2,4,1,3] - (= top True) -; + (= (top) + (queens 8 $Qs) + (fail)) + (= top True) - (= - (queens $N $Qs) - ( (range 1 $N $Ns) (queens $Ns Nil $Qs))) -; + (= (queens $N $Qs) + (range 1 $N $Ns) + (queens $Ns Nil $Qs)) + (= (queens () $Qs $Qs) True) + (= (queens $UnplacedQs $SafeQs $Qs) + (select $UnplacedQs $UnplacedQs1 $Q) + (not-attack $SafeQs $Q) + (queens $UnplacedQs1 + (Cons $Q $SafeQs) $Qs)) - (= - (queens () $Qs $Qs) True) -; - (= - (queens $UnplacedQs $SafeQs $Qs) - ( (select $UnplacedQs $UnplacedQs1 $Q) - (not-attack $SafeQs $Q) - (queens $UnplacedQs1 - (Cons $Q $SafeQs) $Qs))) -; - - - - (= - (not-attack $Xs $X) + (= (not-attack $Xs $X) (not-attack $Xs $X 1)) -; - - (= - (not-attack Nil $_ $_) + (= (not-attack Nil $_ $_) (set-det)) -; - - (= - (not-attack - (Cons $Y $Ys) $X $N) - ( (=\= $X - (+ $Y $N)) - (=\= $X - (- $Y $N)) - (is $N1 - (+ $N 1)) - (not-attack $Ys $X $N1))) -; - - - - (= - (select - (Cons $X $Xs) $Xs $X) True) -; - - (= - (select - (Cons $Y $Ys) - (Cons $Y $Zs) $X) + (= (not-attack (Cons $Y $Ys) $X $N) + (=\= $X + (+ $Y $N)) + (=\= $X + (- $Y $N)) + (is $N1 + (+ $N 1)) + (not-attack $Ys $X $N1)) + + + (= (select (Cons $X $Xs) $Xs $X) True) + (= (select (Cons $Y $Ys) (Cons $Y $Zs) $X) (select $Ys $Zs $X)) -; - - (= - (range $N $N - (:: $N)) + (= (range $N $N (:: $N)) (set-det)) -; - - (= - (range $M $N - (Cons $M $Ns)) - ( (< $M $N) - (is $M1 - (+ $M 1)) - (range $M1 $N $Ns))) -; - + (= (range $M $N (Cons $M $Ns)) + (< $M $N) + (is $M1 + (+ $M 1)) + (range $M1 $N $Ns)) diff --git a/sxx_machine/bench/query.metta b/sxx_machine/bench/query.metta index 801a6ac..e259d0f 100644 --- a/sxx_machine/bench/query.metta +++ b/sxx_machine/bench/query.metta @@ -1,279 +1,106 @@ +; (convert_to_metta_file query $_295570 sxx_machine/bench/query.pl sxx_machine/bench/query.metta) ; -; - +; generated: 17 November 1989 ; -; - +; option(s): SOURCE_TRANSFORM_1 ; ; - ; -; - +; query ; ; - ; -; - +; David H. D. Warren ; ; - ; -; - +; query population and area database to find coun- ; -; - +; tries of approximately equal population density - (= - (top) + (= (top) (query)) -; + (= (query) + (query $_) + (fail)) + (= query True) - (= - (query) - ( (query $_) (fail))) -; + (= (query (:: $C1 $D1 $C2 $D2)) + (density $C1 $D1) + (density $C2 $D2) + (> $D1 $D2) + (is $T1 + (* 20 $D1)) + (is $T2 + (* 21 $D2)) + (< $T1 $T2)) - (= query True) -; - - - (= - (query (:: $C1 $D1 $C2 $D2)) - ( (density $C1 $D1) - (density $C2 $D2) - (> $D1 $D2) - (is $T1 - (* 20 $D1)) - (is $T2 - (* 21 $D2)) - (< $T1 $T2))) -; - - - - (= - (density $C $D) - ( (pop $C $P) - (area $C $A) - (is $D - (// - (* $P 100) $A)))) -; + (= (density $C $D) + (pop $C $P) + (area $C $A) + (is $D + (// + (* $P 100) $A))) ; -; - - - (= - (pop china 8250) True) -; - - (= - (pop india 5863) True) -; - - (= - (pop ussr 2521) True) -; - - (= - (pop usa 2119) True) -; - - (= - (pop indonesia 1276) True) -; - - (= - (pop japan 1097) True) -; - - (= - (pop brazil 1042) True) -; - - (= - (pop bangladesh 750) True) -; - - (= - (pop pakistan 682) True) -; - - (= - (pop w_germany 620) True) -; - - (= - (pop nigeria 613) True) -; - - (= - (pop mexico 581) True) -; - - (= - (pop uk 559) True) -; - - (= - (pop italy 554) True) -; - - (= - (pop france 525) True) -; - - (= - (pop philippines 415) True) -; - - (= - (pop thailand 410) True) -; - - (= - (pop turkey 383) True) -; - - (= - (pop egypt 364) True) -; - - (= - (pop spain 352) True) -; - - (= - (pop poland 337) True) -; - - (= - (pop s_korea 335) True) -; - - (= - (pop iran 320) True) -; - - (= - (pop ethiopia 272) True) -; - - (= - (pop argentina 251) True) -; - +; populations in 100000's + + (= (pop china 8250) True) + (= (pop india 5863) True) + (= (pop ussr 2521) True) + (= (pop usa 2119) True) + (= (pop indonesia 1276) True) + (= (pop japan 1097) True) + (= (pop brazil 1042) True) + (= (pop bangladesh 750) True) + (= (pop pakistan 682) True) + (= (pop w_germany 620) True) + (= (pop nigeria 613) True) + (= (pop mexico 581) True) + (= (pop uk 559) True) + (= (pop italy 554) True) + (= (pop france 525) True) + (= (pop philippines 415) True) + (= (pop thailand 410) True) + (= (pop turkey 383) True) + (= (pop egypt 364) True) + (= (pop spain 352) True) + (= (pop poland 337) True) + (= (pop s_korea 335) True) + (= (pop iran 320) True) + (= (pop ethiopia 272) True) + (= (pop argentina 251) True) ; -; - - - (= - (area china 3380) True) -; - - (= - (area india 1139) True) -; - - (= - (area ussr 8708) True) -; - - (= - (area usa 3609) True) -; - - (= - (area indonesia 570) True) -; - - (= - (area japan 148) True) -; - - (= - (area brazil 3288) True) -; - - (= - (area bangladesh 55) True) -; - - (= - (area pakistan 311) True) -; - - (= - (area w_germany 96) True) -; - - (= - (area nigeria 373) True) -; - - (= - (area mexico 764) True) -; - - (= - (area uk 86) True) -; - - (= - (area italy 116) True) -; - - (= - (area france 213) True) -; - - (= - (area philippines 90) True) -; - - (= - (area thailand 200) True) -; - - (= - (area turkey 296) True) -; - - (= - (area egypt 386) True) -; - - (= - (area spain 190) True) -; - - (= - (area poland 121) True) -; - - (= - (area s_korea 37) True) -; - - (= - (area iran 628) True) -; - - (= - (area ethiopia 350) True) -; - - (= - (area argentina 1080) True) -; - +; areas in 1000's of square miles + + (= (area china 3380) True) + (= (area india 1139) True) + (= (area ussr 8708) True) + (= (area usa 3609) True) + (= (area indonesia 570) True) + (= (area japan 148) True) + (= (area brazil 3288) True) + (= (area bangladesh 55) True) + (= (area pakistan 311) True) + (= (area w_germany 96) True) + (= (area nigeria 373) True) + (= (area mexico 764) True) + (= (area uk 86) True) + (= (area italy 116) True) + (= (area france 213) True) + (= (area philippines 90) True) + (= (area thailand 200) True) + (= (area turkey 296) True) + (= (area egypt 386) True) + (= (area spain 190) True) + (= (area poland 121) True) + (= (area s_korea 37) True) + (= (area iran 628) True) + (= (area ethiopia 350) True) + (= (area argentina 1080) True) diff --git a/sxx_machine/bench/reducer.metta b/sxx_machine/bench/reducer.metta index d4ccc99..972622a 100644 --- a/sxx_machine/bench/reducer.metta +++ b/sxx_machine/bench/reducer.metta @@ -1,1229 +1,638 @@ +; (convert_to_metta_file reducer $_386556 sxx_machine/bench/reducer.pl sxx_machine/bench/reducer.metta) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; A Graph Reducer for T-Combinators: ; -; - +; Reduces a T-combinator expression to a final answer. Recognizes ; -; - +; the combinators I,K,S,B,C,S',B',C', cond, apply, arithmetic, tests, ; -; - +; basic list operations, and function definitions in the data base stored ; -; - +; as facts of the form t_def(_func, _args, _expr). ; -; - +; Written by Peter Van Roy ; -; - - - (= - (top) - ( (try - (fac 3) $ans1) (try (quick (:: 3 1 2)) $ans2))) -; +; Uses write/1, compare/3, functor/3, arg/3. + (= (top) + (try + (fac 3) $ans1) + (try + (quick (:: 3 1 2)) $ans2)) +; ; write(_ans1), nl, ; -; - +; write(_ans2), nl. - (= - (try $inpexpr $anslist) - ( (listify $inpexpr $list) - (curry $list $curry) - (t-reduce $curry $ans) - (make-list $ans $anslist))) -; - + (= (try $inpexpr $anslist) + (listify $inpexpr $list) + (curry $list $curry) + (t-reduce $curry $ans) + (make-list $ans $anslist)) ; -; - - +; ; SWI-MeTTa V7 compatibility hacks. - (= - (end $X) - ( (atom $X) (set-det))) -; - (= - (end $X) + (= (end $X) + (atom $X) + (set-det)) + (= (end $X) (== $X Nil)) -; - - (= - (list-functor-name $Name) + (= (list-functor-name $Name) (functor (Cons $_ $_) $Name $_)) -; - - -; -; - ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - - +; Examples of applicative functions which can be compiled & executed. ; -; - - - (= - (t_def fac - ($N) - (cond - (= $N 0) 1 - (* $N - (fac - (- $N 1))))) True) -; - +; This test version compiles them just before each execution. ; -; - - (= - (t_def quick - ($l) - (cond - (= $l ()) () - (cond - (= - (tl $l) ()) $l - (quick2 - (split - (hd $l) - (tl $l)))))) True) -; - - (= - (t_def quick2 - ($l) - (append - (quick - (hd $l)) - (quick - (tl $l)))) True) -; +; Factorial function: + (= (t_def fac ($N) (cond (= $N 0) 1 (* $N (fac (- $N 1))))) True) - (= - (t_def split - ($e $l) - (cond - (= $l ()) - ( ($e)) - (cond - (=< - (hd $l) $e) - (inserthead - (hd $l) - (split $e - (tl $l))) - (inserttail - (hd $l) - (split $e - (tl $l)))))) True) -; - - (= - (t_def inserthead - ($e $l) - (Cons - (Cons $e - (hd $l)) - (tl $l))) True) -; - - (= - (t_def inserttail - ($e $l) - (Cons - (hd $l) - (Cons $e - (tl $l)))) True) -; +; +; Quicksort: + (= (t_def quick ($l) (cond (= $l ) () (cond (= (tl $l) ) $l (quick2 (split (hd $l) (tl $l)))))) True) + (= (t_def quick2 ($l) (append (quick (hd $l)) (quick (tl $l)))) True) + (= (t_def split ($e $l) (cond (= $l ) (($e)) (cond (=< (hd $l) $e) (inserthead (hd $l) (split $e (tl $l))) (inserttail (hd $l) (split $e (tl $l)))))) True) + (= (t_def inserthead ($e $l) (Cons (Cons $e (hd $l)) (tl $l))) True) + (= (t_def inserttail ($e $l) (Cons (hd $l) (Cons $e (tl $l)))) True) - (= - (t_def append - ($a $b) - (cond - (= $a ()) $b - (Cons - (hd $a) - (append - (tl $a) $b)))) True) -; + (= (t_def append ($a $b) (cond (= $a ) $b (Cons (hd $a) (append (tl $a) $b)))) True) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; +; Full reduction: +; +; A dot '.' is printed for each reduction step. + (= (t-reduce $expr $ans) + (atomic $expr) + (set-det) + (= $ans $expr)) ; -; +; The reduction of '$cons' must be here to avoid an infinite loop + (= (t-reduce (Cons $y (Cons $x $LF)) (Cons $yr (Cons $xr $LF))) + (list-functor-name $LF) + (t-reduce $x $xr) + (set-det) + (t-reduce $y $yr) + (set-det)) + (= (t-reduce $expr $ans) + (t-append $next $red $form $expr) + (t-redex $form $red) + (set-det) + (t-reduce $next $ans) + (set-det)) +; ; write('.'), -; -; - - - - (= - (t-reduce $expr $ans) - ( (atomic $expr) - (set-det) - (= $ans $expr))) -; - -; -; - - (= - (t-reduce - (Cons $y - (Cons $x $LF)) - (Cons $yr - (Cons $xr $LF))) - ( (list-functor-name $LF) - (t-reduce $x $xr) - (set-det) - (t-reduce $y $yr) - (set-det))) -; - - (= - (t-reduce $expr $ans) - ( (t-append $next $red $form $expr) - (t-redex $form $red) - (set-det) - (t-reduce $next $ans) - (set-det))) -; - - - - (= - (t_append $link $link $l $l) True) -; - - (= - (t-append - (Cons $a $l1) $link $l2 - (Cons $a $l3)) - (t-append $l1 $link $l2 $l3)) -; + (= (t_append $link $link $l $l) True) + (= (t-append (Cons $a $l1) $link $l2 (Cons $a $l3)) + (t-append $l1 $link $l2 $l3)) ; -; - +; One step of the reduction: ; -; - +; Combinators: - (= - (t-redex - (Cons $x - (Cons $g - (Cons $f - (Cons $k sp)))) - (Cons - (Cons $xr $g) - (Cons - (Cons $xr $f) $k))) + (= (t-redex (Cons $x (Cons $g (Cons $f (Cons $k sp)))) (Cons (Cons $xr $g) (Cons (Cons $xr $f) $k))) (t-reduce $x $xr)) -; - - (= - (t_redex - (Cons $x - (Cons $g - (Cons $f - (Cons $k bp)))) - (Cons - (Cons $x $g) - (Cons $f $k))) True) -; - - (= - (t_redex - (Cons $x - (Cons $g - (Cons $f - (Cons $k cp)))) - (Cons $g - (Cons - (Cons $x $f) $k))) True) -; - - (= - (t-redex - (Cons $x - (Cons $g - (Cons $f s))) - (Cons - (Cons $xr $g) - (Cons $xr $f))) + (= (t_redex (Cons $x (Cons $g (Cons $f (Cons $k bp)))) (Cons (Cons $x $g) (Cons $f $k))) True) + (= (t_redex (Cons $x (Cons $g (Cons $f (Cons $k cp)))) (Cons $g (Cons (Cons $x $f) $k))) True) + (= (t-redex (Cons $x (Cons $g (Cons $f s))) (Cons (Cons $xr $g) (Cons $xr $f))) (t-reduce $x $xr)) -; - - (= - (t_redex - (Cons $x - (Cons $g - (Cons $f b))) - (Cons - (Cons $x $g) $f)) True) -; - - (= - (t_redex - (Cons $x - (Cons $g - (Cons $f c))) - (Cons $g - (Cons $x $f))) True) -; - - (= - (t_redex - (Cons $y - (Cons $x k)) $x) True) -; - - (= - (t_redex - (Cons $x i) $x) True) -; - + (= (t_redex (Cons $x (Cons $g (Cons $f b))) (Cons (Cons $x $g) $f)) True) + (= (t_redex (Cons $x (Cons $g (Cons $f c))) (Cons $g (Cons $x $f))) True) + (= (t_redex (Cons $y (Cons $x k)) $x) True) + (= (t_redex (Cons $x i) $x) True) ; -; - - (= - (t-redex - (Cons $elsepart - (Cons $ifpart - (Cons $cond cond))) $ifpart) - ( (t-reduce $cond $bool) - (= $bool True) - (set-det))) -; - +; Conditional: + (= (t-redex (Cons $elsepart (Cons $ifpart (Cons $cond cond))) $ifpart) + (t-reduce $cond $bool) + (= $bool True) + (set-det)) ; -; - - (= - (t_redex - (Cons $elsepart - (Cons $ifpart - (Cons $cond cond))) $elsepart) True) -; - +; Does NOT work if _bool is substituted in the call! + (= (t_redex (Cons $elsepart (Cons $ifpart (Cons $cond cond))) $elsepart) True) ; -; - - (= - (t-redex - (Cons $f apply) $fr) +; Apply: + (= (t-redex (Cons $f apply) $fr) (t-reduce $f $fr)) -; - - -; -; - - (= - (t-redex - (Cons $arg hd) $x) - ( (list-functor-name $LF) (t-reduce $arg (Cons $y (Cons $x $LF))))) -; - - (= - (t-redex - (Cons $arg tl) $y) - ( (list-functor-name $LF) (t-reduce $arg (Cons $y (Cons $x $LF))))) -; - - -; -; - - (= - (t-redex - (Cons $y - (Cons $x $op)) $res) - ( (end $op) - (member $op - (:: + - * // mod)) - (t-reduce $x $xres) - (t-reduce $y $yres) - (number $xres) - (number $yres) - (eval $op $res $xres $yres))) -; - ; -; - - (= - (t-redex +; List operations: + (= (t-redex (Cons $arg hd) $x) + (list-functor-name $LF) + (t-reduce $arg (Cons $y - (Cons $x $test)) $res) - ( (end $test) - (member $test - (:: < > =< >= =\= =:=)) - (t-reduce $x $xres) - (t-reduce $y $yres) - (number $xres) - (number $yres) - (det-if-then-else - (relop $test $xres $yres) - (= $res True) - (= $res False)) - (set-det))) -; - - -; -; - - (= - (t-redex + (Cons $x $LF)))) + (= (t-redex (Cons $arg tl) $y) + (list-functor-name $LF) + (t-reduce $arg (Cons $y - (Cons $x =)) $res) - ( (t-reduce $x $xres) - (t-reduce $y $yres) - (det-if-then-else - (= $xres $yres) - (= $res True) - (= $res False)) - (set-det))) -; - + (Cons $x $LF)))) + +; +; Arithmetic: + (= (t-redex (Cons $y (Cons $x $op)) $res) + (end $op) + (member $op + (:: + - * // mod)) + (t-reduce $x $xres) + (t-reduce $y $yres) + (number $xres) + (number $yres) + (eval $op $res $xres $yres)) + +; +; Tests: + (= (t-redex (Cons $y (Cons $x $test)) $res) + (end $test) + (member $test + (:: < > =< >= =\= =:=)) + (t-reduce $x $xres) + (t-reduce $y $yres) + (number $xres) + (number $yres) + (det-if-then-else + (relop $test $xres $yres) + (= $res True) + (= $res False)) + (set-det)) ; -; - - (= - (t-redex - (Cons $x $op) $res) - ( (end $op) - (member $op - (:: -)) - (t-reduce $x $xres) - (number $xres) - (eval1 $op $t $xres))) -; - +; Equality: + (= (t-redex (Cons $y (Cons $x =)) $res) + (t-reduce $x $xres) + (t-reduce $y $yres) + (det-if-then-else + (= $xres $yres) + (= $res True) + (= $res False)) + (set-det)) ; -; +; Arithmetic functions: + (= (t-redex (Cons $x $op) $res) + (end $op) + (member $op + (:: -)) + (t-reduce $x $xres) + (number $xres) + (eval1 $op $t $xres)) ; -; - +; Definitions: ; -; - - (= - (t-redex $in $out) - ( (append $par $func $in) - (end $func) - (t-def $func $args $expr) - (t $args $expr $def) - (append $par $def $out))) -; - - +; Assumes a fact t_def(_func,_def) in the database for every ; -; +; defined function. + (= (t-redex $in $out) + (append $par $func $in) + (end $func) + (t-def $func $args $expr) + (t $args $expr $def) + (append $par $def $out)) +; +; Basic arithmetic and relational operators: - (= - (eval + $C $A $B) + (= (eval + $C $A $B) (is $C (+ $A $B))) -; - - (= - (eval - $C $A $B) + (= (eval - $C $A $B) (is $C (- $A $B))) -; - - (= - (eval * $C $A $B) + (= (eval * $C $A $B) (is $C (* $A $B))) -; - - (= - (eval // $C $A $B) + (= (eval // $C $A $B) (is $C (// $A $B))) -; - - (= - (eval mod $C $A $B) + (= (eval mod $C $A $B) (is $C (mod $A $B))) -; - - (= - (eval1 - $C $A) + (= (eval1 - $C $A) (is $C (- $A))) -; - - (= - (relop < $A $B) + (= (relop < $A $B) (< $A $B)) -; - - (= - (relop > $A $B) + (= (relop > $A $B) (> $A $B)) -; - - (= - (relop =< $A $B) + (= (relop =< $A $B) (=< $A $B)) -; - - (= - (relop >= $A $B) + (= (relop >= $A $B) (>= $A $B)) -; - - (= - (relop =\= $A $B) + (= (relop =\= $A $B) (=\= $A $B)) -; - - (= - (relop =:= $A $B) + (= (relop =:= $A $B) (=:= $A $B)) -; - ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Scheme T: ; -; - +; A Translation Scheme for T-Combinators ; -; - +; Translate an expression to combinator form ; -; - +; by abstracting out all variables in _argvars: - (= - (t $argvars $expr $trans) - ( (listify $expr $list) - (curry $list $curry) - (t-argvars $argvars $curry $trans) - (set-det))) -; - - - - (= - (t_argvars () $trans $trans) True) -; + (= (t $argvars $expr $trans) + (listify $expr $list) + (curry $list $curry) + (t-argvars $argvars $curry $trans) + (set-det)) - (= - (t-argvars - (Cons $x $argvars) $in $trans) - ( (t-argvars $argvars $in $mid) - (t-vars $mid $vars) - (t-trans $x $mid $vars $trans))) -; - ; -; + (= (t_argvars () $trans $trans) True) + (= (t-argvars (Cons $x $argvars) $in $trans) + (t-argvars $argvars $in $mid) + (t-vars $mid $vars) + (t-trans $x $mid $vars $trans)) +; ; calculate variables in each subexpression ; +; main translation routine ; -; - +; Curry the original expression: ; -; - +; This converts an applicative expression of any number ; -; - +; of arguments and any depth of nesting into an expression ; -; - +; where all functions are curried, i.e. all function ; -; - +; applications are to one argument and have the form ; -; - +; [_arg|_func] where _func & _arg are also of that form. ; -; - +; Input is a nested function application in list form. ; -; - +; Currying makes t_trans faster. - (= - (curry $a $a) - ( (or - (var $a) - (atomic $a)) (set-det))) -; - - (= - (curry - (Cons $func $args) $cargs) + (= (curry $a $a) + (or + (var $a) + (atomic $a)) + (set-det)) + (= (curry (Cons $func $args) $cargs) (currylist $args $cargs $func)) -; - ; -; - +; Transform [_a1, ..., _aN] to [_cN, ..., _c1|_link]-_link - (= - (currylist Nil $link $link) + (= (currylist Nil $link $link) (set-det)) -; - - (= - (currylist - (Cons $a $args) $cargs $link) - ( (curry $a $c) (currylist $args $cargs (Cons $c $link)))) -; - + (= (currylist (Cons $a $args) $cargs $link) + (curry $a $c) + (currylist $args $cargs + (Cons $c $link))) ; -; - +; Calculate variables in each subexpression: ; -; - +; To any expression a list of the form ; -; - +; [_vexpr, _astr, _fstr] is matched. ; -; - +; If the expression is a variable or an atom ; -; - +; then this list only has the first element. ; -; - +; _vexpr = List of all variables in the expression. ; -; - - - (= - (t-vars $v - (:: (:: $v))) - ( (var $v) (set-det))) -; - - (= - (t-vars $a - (:: Nil)) - ( (atomic $a) (set-det))) -; - - (= - (t-vars - (:: $func) - (:: Nil)) - ( (atomic $func) (set-det))) -; - - (= - (t-vars - (Cons $arg $func) - (:: $g - (Cons $g1 $af1) - (Cons $g2 $af2))) - ( (t-vars $arg - (Cons $g1 $af1)) - (t-vars $func - (Cons $g2 $af2)) - (unionv $g1 $g2 $g))) -; +; _astr, _fstr = Similar structures for argument & function. + (= (t-vars $v (:: (:: $v))) + (var $v) + (set-det)) + (= (t-vars $a (:: Nil)) + (atomic $a) + (set-det)) + (= (t-vars (:: $func) (:: Nil)) + (atomic $func) + (set-det)) + (= (t-vars (Cons $arg $func) (:: $g (Cons $g1 $af1) (Cons $g2 $af2))) + (t-vars $arg + (Cons $g1 $af1)) + (t-vars $func + (Cons $g2 $af2)) + (unionv $g1 $g2 $g)) ; -; - +; The main translation routine: ; -; - +; trans(_var, _curriedexpr, _varexpr, _result) ; -; - +; The translation scheme T in the article is followed literally. ; -; - +; A good example of MeTTa as a specification language. - (= - (t-trans $x $a $_ - (Cons $a k)) - ( (or - (atomic $a) - (, - (var $a) - (\== $a $x))) (set-det))) -; - - (= - (t-trans $x $y $_ i) - ( (== $x $y) (set-det))) -; - - (= - (t-trans $x $e - (Cons $ve $_) - (Cons $e k)) + (= (t-trans $x $a $_ (Cons $a k)) + (or + (atomic $a) + (, + (var $a) + (\== $a $x))) + (set-det)) + (= (t-trans $x $y $_ i) + (== $x $y) + (set-det)) + (= (t-trans $x $e (Cons $ve $_) (Cons $e k)) (notinv $x $ve)) -; - - (= - (t-trans $x - (Cons $f $e) - (:: $vef $sf $se) $res) - ( (= $sf - (Cons $vf $_)) - (= $se - (Cons $ve $other)) - (or - (end $e) - (, - (= $other - (:: $_ - (Cons $ve1 $_))) - (\== $ve1 Nil))) - (t-rule1 $x $e $ve $se $f $vf $sf $res))) -; - - (= - (t-trans $x - (Cons $g - (Cons $f $e)) - (:: $vefg $sg $sef) $res) - ( (= $sg - (Cons $vg $_)) - (= $sef - (:: $vef $sf $se)) - (= $se - (Cons $ve $_)) - (= $sf - (Cons $vf $_)) - (t-rule2 $x $e $f $vf $sf $g $vg $sg $res))) -; - - -; -; - - - (= - (t-rule1 $x $e $ve $se $f $vf $sf $e) - ( (notinv $x $ve) - (== $x $f) - (set-det))) -; - - (= - (t-rule1 $x $e $ve $se $f $vf $sf - (Cons $resf - (Cons $e b))) - ( (notinv $x $ve) - (inv $x $vf) - (\== $x $f) - (set-det) - (t-trans $x $f $sf $resf))) -; - - (= - (t-rule1 $x $e $ve $se $f $vf $sf - (Cons $f - (Cons $rese c))) - ( (notinv $x $vf) - (set-det) - (t-trans $x $e $se $rese))) -; - - (= - (t-rule1 $x $e $ve $se $f $vf $sf - (Cons $resf - (Cons $rese s))) - ( (t-trans $x $e $se $rese) (t-trans $x $f $sf $resf))) -; - - -; -; - - - (= - (t-rule2 $x $e $f $vf $sf $g $vg $sg - (Cons $g - (Cons $e c))) - ( (== $x $f) - (notinv $x $vg) - (set-det))) -; - - (= - (t-rule2 $x $e $f $vf $sf $g $vg $sg - (Cons $resg - (Cons $e s))) - ( (== $x $f) - (set-det) - (t-trans $x $g $sg $resg))) -; - - (= - (t-rule2 $x $e $f $vf $sf $g $vg $sg - (Cons $g - (Cons $resf - (Cons $e cp)))) - ( (inv $x $vf) - (notinv $x $vg) - (set-det) - (t-trans $x $f $sf $resf))) -; - - (= - (t-rule2 $x $e $f $vf $sf $g $vg $sg - (Cons $resg - (Cons $resf - (Cons $e sp)))) - ( (inv $x $vf) - (set-det) - (t-trans $x $f $sf $resf) - (t-trans $x $g $sg $resg))) -; - - (= - (t-rule2 $x $e $f $vf $sf $g $vg $sg - (Cons $f $e)) - ( (== $x $g) (set-det))) -; - - (= - (t-rule2 $x $e $f $vf $sf $g $vg $sg - (Cons $resg - (Cons $f - (Cons $e bp)))) + (= (t-trans $x (Cons $f $e) (:: $vef $sf $se) $res) + (= $sf + (Cons $vf $_)) + (= $se + (Cons $ve $other)) + (or + (end $e) + (, + (= $other + (:: $_ + (Cons $ve1 $_))) + (\== $ve1 Nil))) + (t-rule1 $x $e $ve $se $f $vf $sf $res)) + (= (t-trans $x (Cons $g (Cons $f $e)) (:: $vefg $sg $sef) $res) + (= $sg + (Cons $vg $_)) + (= $sef + (:: $vef $sf $se)) + (= $se + (Cons $ve $_)) + (= $sf + (Cons $vf $_)) + (t-rule2 $x $e $f $vf $sf $g $vg $sg $res)) + +; +; First complex rule of translation scheme T: + + (= (t-rule1 $x $e $ve $se $f $vf $sf $e) + (notinv $x $ve) + (== $x $f) + (set-det)) + (= (t-rule1 $x $e $ve $se $f $vf $sf (Cons $resf (Cons $e b))) + (notinv $x $ve) + (inv $x $vf) + (\== $x $f) + (set-det) + (t-trans $x $f $sf $resf)) + (= (t-rule1 $x $e $ve $se $f $vf $sf (Cons $f (Cons $rese c))) + (notinv $x $vf) + (set-det) + (t-trans $x $e $se $rese)) +; /* inv(_x, _ve), */ + (= (t-rule1 $x $e $ve $se $f $vf $sf (Cons $resf (Cons $rese s))) + (t-trans $x $e $se $rese) + (t-trans $x $f $sf $resf)) +; /* inv(_x, _ve), inv(_x, _vf), */ + +; +; Second complex rule of translation scheme T: + + (= (t-rule2 $x $e $f $vf $sf $g $vg $sg (Cons $g (Cons $e c))) + (== $x $f) + (notinv $x $vg) + (set-det)) + (= (t-rule2 $x $e $f $vf $sf $g $vg $sg (Cons $resg (Cons $e s))) + (== $x $f) + (set-det) (t-trans $x $g $sg $resg)) -; - +; /* inv(_x, _vg), */ + (= (t-rule2 $x $e $f $vf $sf $g $vg $sg (Cons $g (Cons $resf (Cons $e cp)))) + (inv $x $vf) + (notinv $x $vg) + (set-det) + (t-trans $x $f $sf $resf)) +; /* _x\==_f, */ + (= (t-rule2 $x $e $f $vf $sf $g $vg $sg (Cons $resg (Cons $resf (Cons $e sp)))) + (inv $x $vf) + (set-det) + (t-trans $x $f $sf $resf) + (t-trans $x $g $sg $resg)) +; /* _x\==_f, */ +; /* inv(_x, _vg), */ + (= (t-rule2 $x $e $f $vf $sf $g $vg $sg (Cons $f $e)) + (== $x $g) + (set-det)) +; /* notinv(_x, _vf), */ + (= (t-rule2 $x $e $f $vf $sf $g $vg $sg (Cons $resg (Cons $f (Cons $e bp)))) + (t-trans $x $g $sg $resg)) +; /* notinv(_x, _vf), inv(_x, _vg), _x\==_g, */ ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; List utilities: ; -; +; Convert curried list into a regular list: - - (= - (make-list $a $a) + (= (make-list $a $a) (atomic $a)) -; - - (= - (make-list - (Cons $b - (Cons $a $LF)) - (Cons $a $rb)) - ( (list-functor-name $LF) (make-list $b $rb))) -; - - - - (= - (listify $X $X) - ( (or - (var $X) - (atomic $X)) (set-det))) -; - - (= - (listify $Expr - (Cons $Op $LArgs)) - ( (functor $Expr $Op $N) (listify-list 1 $N $Expr $LArgs))) -; - - - - (= - (listify-list $I $N $_ Nil) - ( (> $I $N) (set-det))) -; - - (= - (listify-list $I $N $Expr - (Cons $LA $LArgs)) - ( (=< $I $N) - (set-det) - (arg $I $Expr $A) - (listify $A $LA) - (is $I1 - (+ $I 1)) - (listify-list $I1 $N $Expr $LArgs))) -; + (= (make-list (Cons $b (Cons $a $LF)) (Cons $a $rb)) + (list-functor-name $LF) + (make-list $b $rb)) + (= (listify $X $X) + (or + (var $X) + (atomic $X)) + (set-det)) + (= (listify $Expr (Cons $Op $LArgs)) + (functor $Expr $Op $N) + (listify-list 1 $N $Expr $LArgs)) - (= - (member $X - (Cons $X $_)) True) -; - (= - (member $X - (Cons $_ $L)) + (= (listify-list $I $N $_ Nil) + (> $I $N) + (set-det)) + (= (listify-list $I $N $Expr (Cons $LA $LArgs)) + (=< $I $N) + (set-det) + (arg $I $Expr $A) + (listify $A $LA) + (is $I1 + (+ $I 1)) + (listify-list $I1 $N $Expr $LArgs)) + + + (= (member $X (Cons $X $_)) True) + (= (member $X (Cons $_ $L)) (member $X $L)) -; - - (= - (append () $L $L) True) -; - - (= - (append - (Cons $X $L1) $L2 - (Cons $X $L3)) + (= (append () $L $L) True) + (= (append (Cons $X $L1) $L2 (Cons $X $L3)) (append $L1 $L2 $L3)) -; - ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Set utilities: ; -; - +; Implementation inspired by R. O'Keefe, Practical MeTTa. ; -; - +; Sets are represented as sorted lists without duplicates. ; -; - +; Predicates with 'v' suffix work with sets containing uninstantiated vars. ; -; - - - (= - (intersectv () $_ ()) True) -; +; *** Intersection - (= - (intersectv - (Cons $A $S1) $S2 $S) + (= (intersectv () $_ ()) True) + (= (intersectv (Cons $A $S1) $S2 $S) (intersectv-2 $S2 $A $S1 $S)) -; - - - - (= - (intersectv_2 () $_ $_ ()) True) -; - (= - (intersectv-2 - (Cons $B $S2) $A $S1 $S) - ( (compare $Order $A $B) (intersectv-3 $Order $A $S1 $B $S2 $S))) -; + (= (intersectv_2 () $_ $_ ()) True) + (= (intersectv-2 (Cons $B $S2) $A $S1 $S) + (compare $Order $A $B) + (intersectv-3 $Order $A $S1 $B $S2 $S)) - (= - (intersectv-3 < $_ $S1 $B $S2 $S) + (= (intersectv-3 < $_ $S1 $B $S2 $S) (intersectv-2 $S1 $B $S2 $S)) -; - - (= - (intersectv-3 = $A $S1 $_ $S2 - (Cons $A $S)) + (= (intersectv-3 = $A $S1 $_ $S2 (Cons $A $S)) (intersectv $S1 $S2 $S)) -; - - (= - (intersectv-3 > $A $S1 $_ $S2 $S) + (= (intersectv-3 > $A $S1 $_ $S2 $S) (intersectv-2 $S2 $A $S1 $S)) -; - - (= - (intersectv_list () ()) True) -; - - (= - (intersectv-list - (Cons $InS $Sets) $OutS) + (= (intersectv_list () ()) True) + (= (intersectv-list (Cons $InS $Sets) $OutS) (intersectv-list $Sets $InS $OutS)) -; - - - (= - (--> - (intersectv_list ()) ()) True) -; - - (= - (--> - (intersectv_list - (Cons $S $Sets)) - (, - (intersectv $S) - (intersectv_list $Sets))) True) -; + (= (--> (intersectv_list ()) ()) True) + (= (--> (intersectv_list (Cons $S $Sets)) (, (intersectv $S) (intersectv_list $Sets))) True) ; -; - - - (= - (diffv () $_ ()) True) -; +; *** Difference - (= - (diffv - (Cons $A $S1) $S2 $S) + (= (diffv () $_ ()) True) + (= (diffv (Cons $A $S1) $S2 $S) (diffv-2 $S2 $A $S1 $S)) -; - - - - (= - (diffv_2 () $A $S1 - (Cons $A $S1)) True) -; - (= - (diffv-2 - (Cons $B $S2) $A $S1 $S) - ( (compare $Order $A $B) (diffv-3 $Order $A $S1 $B $S2 $S))) -; + (= (diffv_2 () $A $S1 (Cons $A $S1)) True) + (= (diffv-2 (Cons $B $S2) $A $S1 $S) + (compare $Order $A $B) + (diffv-3 $Order $A $S1 $B $S2 $S)) - (= - (diffv-3 < $A $S1 $B $S2 - (Cons $A $S)) + (= (diffv-3 < $A $S1 $B $S2 (Cons $A $S)) (diffv $S1 (Cons $B $S2) $S)) -; - - (= - (diffv-3 = $A $S1 $_ $S2 $S) + (= (diffv-3 = $A $S1 $_ $S2 $S) (diffv $S1 $S2 $S)) -; - - (= - (diffv-3 > $A $S1 $_ $S2 $S) + (= (diffv-3 > $A $S1 $_ $S2 $S) (diffv-2 $S2 $A $S1 $S)) -; - ; -; +; *** Union - - (= - (unionv () $S2 $S2) True) -; - - (= - (unionv - (Cons $A $S1) $S2 $S) + (= (unionv () $S2 $S2) True) + (= (unionv (Cons $A $S1) $S2 $S) (unionv-2 $S2 $A $S1 $S)) -; - - (= - (unionv_2 () $A $S1 - (Cons $A $S1)) True) -; + (= (unionv_2 () $A $S1 (Cons $A $S1)) True) + (= (unionv-2 (Cons $B $S2) $A $S1 $S) + (compare $Order $A $B) + (unionv-3 $Order $A $S1 $B $S2 $S)) - (= - (unionv-2 - (Cons $B $S2) $A $S1 $S) - ( (compare $Order $A $B) (unionv-3 $Order $A $S1 $B $S2 $S))) -; - - - (= - (unionv-3 < $A $S1 $B $S2 - (Cons $A $S)) + (= (unionv-3 < $A $S1 $B $S2 (Cons $A $S)) (unionv-2 $S1 $B $S2 $S)) -; - - (= - (unionv-3 = $A $S1 $_ $S2 - (Cons $A $S)) + (= (unionv-3 = $A $S1 $_ $S2 (Cons $A $S)) (unionv $S1 $S2 $S)) -; - - (= - (unionv-3 > $A $S1 $B $S2 - (Cons $B $S)) + (= (unionv-3 > $A $S1 $B $S2 (Cons $B $S)) (unionv-2 $S2 $A $S1 $S)) -; - ; -; - +; *** Subset - (= - (subsetv () $_) True) -; + (= (subsetv () $_) True) + (= (subsetv (Cons $A $S1) (Cons $B $S2)) + (compare $Order $A $B) + (subsetv-2 $Order $A $S1 $S2)) - (= - (subsetv - (Cons $A $S1) - (Cons $B $S2)) - ( (compare $Order $A $B) (subsetv-2 $Order $A $S1 $S2))) -; - - - (= - (subsetv-2 = $_ $S1 $S2) + (= (subsetv-2 = $_ $S1 $S2) (subsetv $S1 $S2)) -; - - (= - (subsetv-2 > $A $S1 $S2) + (= (subsetv-2 > $A $S1 $S2) (subsetv (Cons $A $S1) $S2)) -; - ; -; - - - (= - (small_subsetv () $_) True) -; - - (= - (small-subsetv - (Cons $A $S1) $S2) - ( (inv $A $S2) (small-subsetv $S1 $S2))) -; +; For unordered lists S1: + (= (small_subsetv () $_) True) + (= (small-subsetv (Cons $A $S1) $S2) + (inv $A $S2) + (small-subsetv $S1 $S2)) ; -; - - - (= - (inv $A - (Cons $B $S)) - ( (compare $Order $A $B) (inv-2 $Order $A $S))) -; +; *** Membership + (= (inv $A (Cons $B $S)) + (compare $Order $A $B) + (inv-2 $Order $A $S)) - (= - (inv_2 = $_ $_) True) -; - - (= - (inv-2 > $A $S) + (= (inv_2 = $_ $_) True) + (= (inv-2 > $A $S) (inv $A $S)) -; - ; -; - +; *** Non-membership - (= - (notinv $A $S) + (= (notinv $A $S) (notinv-2 $S $A)) -; + (= (notinv_2 () $_) True) + (= (notinv-2 (Cons $B $S) $A) + (compare $Order $A $B) + (notinv-3 $Order $A $S)) - (= - (notinv_2 () $_) True) -; - (= - (notinv-2 - (Cons $B $S) $A) - ( (compare $Order $A $B) (notinv-3 $Order $A $S))) -; - - - - (= - (notinv_3 < $_ $_) True) -; - - (= - (notinv-3 > $A $S) + (= (notinv_3 < $_ $_) True) + (= (notinv-3 > $A $S) (notinv-2 $S $A)) -; - ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/sxx_machine/bench/run.metta b/sxx_machine/bench/run.metta index 779d5ad..1d01ce4 100644 --- a/sxx_machine/bench/run.metta +++ b/sxx_machine/bench/run.metta @@ -1,361 +1,231 @@ +; (convert_to_metta_file run $_244270 sxx_machine/bench/run.pl sxx_machine/bench/run.metta) !(style-check (- singleton)) -; - - (= - (run $F) + (= (run $F) (run current-output $F)) -; - - - (= - (run $S $F) - ( (compile-programs) - (format $S '~p~t~18| ~t~w~25| ~t~w~32|~n' - (:: Program Time GC)) - (format $S ~`=t~32|~n Nil) - (= $Total - (total 0 0 0)) - (forall - (program $P $N $F) - (run-program $P $N $S $Total)) - (= $Total - (total $Count $Time $GC)) - (is $AvgT - (/ $Time $Count)) - (is $AvgGC - (/ $GC $Count)) - (format $S '~t~w~18| ~t~3f~25| ~t~3f~32|~n' - (:: average $AvgT $AvgGC)))) -; + (= (run $S $F) + (compile-programs) + (format $S '~p~t~18| ~t~w~25| ~t~w~32|~n' + (:: Program Time GC)) + (format $S ~`=t~32|~n Nil) + (= $Total + (total 0 0 0)) + (forall + (program $P $N $F) + (run-program $P $N $S $Total)) + (= $Total + (total $Count $Time $GC)) + (is $AvgT + (/ $Time $Count)) + (is $AvgGC + (/ $GC $Count)) + (format $S '~t~w~18| ~t~3f~25| ~t~3f~32|~n' + (:: average $AvgT $AvgGC))) !(det-if-then-else (file-search-path bench $_) True (, (prolog-load-context directory $Dir) - (add-symbol &self + (add-is-symbol &self (file_search_path bench $Dir)))) -; - - - - (= - (compile-programs) - ( (style-check (- singleton)) (forall (program $P $_) (load-files (with_self $P (bench $P)) (:: (silent True) (if changed)))))) -; - - (= - (run-program $Program $N $S $Total) - ( (ntimes $Program $N $Time $GC) - (set-det) - (add 1 $Total 1) - (add 2 $Total $Time) - (add 3 $Total $GC) - (format $S '~p~t~18| ~t~3f~25| ~t~3f~32|~n' - (:: $Program $Time $GC)))) -; + (= (compile-programs) + (style-check (- singleton)) + (forall + (program $P $_) + (load-files + (with_self $P + (bench $P)) + (:: + (silent True) + (if changed))))) + (= (run-program $Program $N $S $Total) + (ntimes $Program $N $Time $GC) + (set-det) + (add 1 $Total 1) + (add 2 $Total $Time) + (add 3 $Total $GC) + (format $S '~p~t~18| ~t~3f~25| ~t~3f~32|~n' + (:: $Program $Time $GC))) - (= - (add $Arg $Term $Time) - ( (arg $Arg $Term $T0) - (is $T - (+ $T0 $Time)) - (nb-setarg $Arg $Term $T))) -; + (= (add $Arg $Term $Time) + (arg $Arg $Term $T0) + (is $T + (+ $T0 $Time)) + (nb-setarg $Arg $Term $T)) !(if (statistics gctime $_)) -; - - - (= - (get-performance-stats $GC $T) - ( (statistics gctime $GC) (statistics cputime $T))) -; + (= (get-performance-stats $GC $T) + (statistics gctime $GC) + (statistics cputime $T)) +; ; SWI-MeTTa !(else *) -; - - - (= - (get-performance-stats $GC $T) - ( (statistics garbage-collection - (:: $_ $_ $TGC)) - (statistics cputime - (:: $TT $_)) - (is $GC - (/ $TGC 1000)) - (is $T - (/ $TT 1000)))) -; + (= (get-performance-stats $GC $T) + (statistics garbage-collection + (:: $_ $_ $TGC)) + (statistics cputime + (:: $TT $_)) + (is $GC + (/ $TGC 1000)) + (is $T + (/ $TT 1000))) !(endif *) -; - - - - (= - (ntimes $M $N $T $GC) - ( (get-performance-stats $GC0 $T0) - (ntimes $M $N) - (get-performance-stats $GC1 $T1) - (ntimes-dummy $N) - (get-performance-stats $GC2 $T2) - (is $T - (- - (- $T1 $T0) - (- $T2 $T1))) - (is $GC - (- - (- $GC1 $GC0) - (- $GC2 $GC1))))) -; - - - (= - (ntimes $_ $N) - ( (=:= $N 0) (set-det))) -; - - (= - (ntimes $M $N) - ( (not-not-top $M) - (set-det) - (is $N1 - (- $N 1)) - (ntimes $M $N1))) -; - - - - (= - (ntimes-dummy $N) - ( (=:= $N 0) (set-det))) -; - - (= - (ntimes-dummy $N) - ( (not-not-dummy) - (set-det) - (is $N1 - (- $N 1)) - (ntimes-dummy $N1))) -; - - - - (= - (not-not-top $M) - ( (not-top $M) - (set-det) - (fail))) -; - - (= - (not_not_top $_) True) -; - - (= - (not-top $M) + (= (ntimes $M $N $T $GC) + (get-performance-stats $GC0 $T0) + (ntimes $M $N) + (get-performance-stats $GC1 $T1) + (ntimes-dummy $N) + (get-performance-stats $GC2 $T2) + (is $T + (- + (- $T1 $T0) + (- $T2 $T1))) + (is $GC + (- + (- $GC1 $GC0) + (- $GC2 $GC1)))) + + (= (ntimes $_ $N) + (=:= $N 0) + (set-det)) + (= (ntimes $M $N) + (not-not-top $M) + (set-det) + (is $N1 + (- $N 1)) + (ntimes $M $N1)) + + + (= (ntimes-dummy $N) + (=:= $N 0) + (set-det)) + (= (ntimes-dummy $N) + (not-not-dummy) + (set-det) + (is $N1 + (- $N 1)) + (ntimes-dummy $N1)) + + + (= (not-not-top $M) + (not-top $M) + (set-det) + (fail)) + (= (not_not_top $_) True) + + + (= (not-top $M) ( (with_self $M (top)) (set-det) (fail))) -; + (= (not_top $_) True) - (= - (not_top $_) True) -; + (= (not-not-dummy) + (not-dummy) + (set-det) + (fail)) + (= not_not_dummy True) - (= - (not-not-dummy) - ( (not-dummy) - (set-det) - (fail))) -; + (= (not-dummy) + (dummy) + (set-det) + (fail)) + (= not_dummy True) - (= not_not_dummy True) -; - - - - (= - (not-dummy) - ( (dummy) - (set-det) - (fail))) -; - - (= not_dummy True) -; - - - - (= dummy True) -; + (= dummy True) ; -; - +; ; tune_counts ; ; - ; -; - +; Write the program/2 table below, tuning all counts such that the ; -; - +; test runs for about 1 second. - (= - (tune-counts) + (= (tune-counts) (forall (program $P $_) (, (tune-count $P $C) (format ~q.~n (:: (program $P $C)))))) -; - - (= - (tune-count $Program $Count) - ( (between 1 100 $I) - (is $C - (<< 1 $I)) - (ntimes $Program $C $T $_) - (> $T 0.5) - (set-det) - (is $Count - (round (* $C (/ 1 $T)))))) -; - + (= (tune-count $Program $Count) + (between 1 100 $I) + (is $C + (<< 1 $I)) + (ntimes $Program $C $T $_) + (> $T 0.5) + (set-det) + (is $Count + (round (* $C (/ 1 $T))))) - (= - (program $P $N $F) - ( (program $P $N0) (is $N (max 1 (round (* $N0 $F)))))) -; - + (= (program $P $N $F) + (program $P $N0) + (is $N + (max 1 + (round (* $N0 $F))))) ; -; - +; ; program(?Program, ?Times) ; ; - ; -; - +; Times are tuned on Jan 24, 2010, using SWI-MeTTa 5.9.7 on ; -; - - - (= - (program boyer 8) True) -; - - (= - (program browse 7) True) -; - - (= - (program chat_parser 46) True) -; - - (= - (program crypt 868) True) -; - - (= - (program fast_mu 4819) True) -; - - (= - (program flatten 8275) True) -; - - (= - (program meta_qsort 966) True) -; - - (= - (program mu 6827) True) -; - - (= - (program nreverse 11378) True) -; - - (= - (program poly_10 105) True) -; - - (= - (program prover 6400) True) -; - - (= - (program qsort 8445) True) -; - - (= - (program queens_8 63) True) -; - - (= - (program query 1219) True) -; - - (= - (program reducer 164) True) -; - - (= - (program sendmore 44) True) -; - - (= - (program simple_analyzer 320) True) -; - - (= - (program tak 35) True) -; - - (= - (program zebra 166) True) -; - +; AMD 5400+ (gcc 4.4.1; AMD64 mode) + + (= (program boyer 8) True) + (= (program browse 7) True) + (= (program chat_parser 46) True) + (= (program crypt 868) True) + (= (program fast_mu 4819) True) + (= (program flatten 8275) True) + (= (program meta_qsort 966) True) + (= (program mu 6827) True) + (= (program nreverse 11378) True) + (= (program poly_10 105) True) + (= (program prover 6400) True) + (= (program qsort 8445) True) + (= (program queens_8 63) True) + (= (program query 1219) True) + (= (program reducer 164) True) + (= (program sendmore 44) True) + (= (program simple_analyzer 320) True) + (= (program tak 35) True) + (= (program zebra 166) True) !(dynamic (/ rni 0)) -; - +; /******************************* * INTERLEAVED * *******************************/ - (= - (run-interleaved $F) + (= (run-interleaved $F) ( (compile-programs) (findall (- $N $P) @@ -363,126 +233,43 @@ (phrase (seq-interleaved $Pairs) $Sequence) (seq-clause $Sequence $Body) - (remove-all-symbols &self rni) + (remove-all-atoms &self rni) (assert - (= - (rni) $Body) $Ref) + (= (rni) $Body) $Ref) (garbage-collect) (time rni) (erase $Ref))) -; + (= (--> (seq_interleaved ()) !) True) + (= (--> (seq_interleaved $Pairs) (, (seq_interleaved $Pairs $Rest) (seq_interleaved $Rest))) True) - (= - (--> - (seq_interleaved ()) !) True) -; - - (= - (--> - (seq_interleaved $Pairs) - (, - (seq_interleaved $Pairs $Rest) - (seq_interleaved $Rest))) True) -; + (= (--> (seq_interleaved () ()) ()) True) + (= (--> (seq_interleaved (Cons (- 1 $P) $T0) $T) (, ! (, ($P) (seq_interleaved $T0 $T)))) True) + (= (--> (seq_interleaved (Cons (- $N $P) $T0) (Cons (- $N1 $P) $T)) (, ($P) (, {(is $N1 (- $N 1)) } (seq_interleaved $T0 $T)))) True) - (= - (--> - (seq_interleaved () ()) ()) True) -; - - (= - (--> - (seq_interleaved - (Cons - (- 1 $P) $T0) $T) - (, ! - (, - ($P) - (seq_interleaved $T0 $T)))) True) -; - - (= - (--> - (seq_interleaved - (Cons - (- $N $P) $T0) - (Cons - (- $N1 $P) $T)) - (, - ($P) - (, - { (is $N1 - (- $N 1)) } - (seq_interleaved $T0 $T)))) True) -; - - - - (= - (seq_clause () true) True) -; - - (= - (seq-clause - (Cons $H $T) - (, - (with_self - (not (not $H)) - (top)) $G)) + (= (seq_clause () true) True) + (= (seq-clause (Cons $H $T) (, (with_self (not (not $H)) (top)) $G)) (seq-clause $T $G)) -; - - (= - (run-non-interleaved $F) - ( (compile-programs) - (findall - (- $N $P) - (program $P $N $F) $Pairs) - (phrase - (seq-non-interleaved $Pairs) $Sequence) - (seq-clause $Sequence $Body) - (assert - (= - (rni) $Body) $Ref) - (garbage-collect) - (time rni) - (erase $Ref))) -; - - - - (= - (--> - (seq_non_interleaved ()) ()) True) -; - - (= - (--> - (seq_non_interleaved - (Cons - (- 0 $_) $T)) - (, ! - (seq_non_interleaved $T))) True) -; - - (= - (--> - (seq_non_interleaved - (Cons - (- $N $P) $T)) - (, - ($P) - (, - { (is $N1 - (- $N 1)) } - (seq_non_interleaved - (Cons - (- $N1 $P) $T))))) True) -; - + (= (run-non-interleaved $F) + (compile-programs) + (findall + (- $N $P) + (program $P $N $F) $Pairs) + (phrase + (seq-non-interleaved $Pairs) $Sequence) + (seq-clause $Sequence $Body) + (assert + (= (rni) $Body) $Ref) + (garbage-collect) + (time rni) + (erase $Ref)) + + + (= (--> (seq_non_interleaved ()) ()) True) + (= (--> (seq_non_interleaved (Cons (- 0 $_) $T)) (, ! (seq_non_interleaved $T))) True) + (= (--> (seq_non_interleaved (Cons (- $N $P) $T)) (, ($P) (, {(is $N1 (- $N 1)) } (seq_non_interleaved (Cons (- $N1 $P) $T))))) True) diff --git a/sxx_machine/bench/sdda.metta b/sxx_machine/bench/sdda.metta index c5ba80e..3b4aeee 100644 --- a/sxx_machine/bench/sdda.metta +++ b/sxx_machine/bench/sdda.metta @@ -1,916 +1,530 @@ +; (convert_to_metta_file sdda $_396078 sxx_machine/bench/sdda.pl sxx_machine/bench/sdda.metta) ; -; - +; Sdda3 5-Oct-86 ; -; - +; For use on simulator ; -; - +; ; To do: (look for ';;') ; -; - +; ; recursion - keep list of call procedures, ignore recursive calls ; -; - +; ; problem: doesn't work for typical procedure working on a list, ; -; - +; ; since the list is smaller (different) each time. ; -; - +; ; possible optimization: "recognize" base case & skip to it ; -; - +; ; follow atoms, g is 'any atom', all others unique, does it work? ; -; - +; ; stats - write heapused, cputime to files (as comments) ; -; - +; ; worst_case - handle ground terms (copy unify, modify atomic) ; -; - +; ; handle disjunction - needs worst_case ; -; - +; ; add cuts where possible to save space ; -; - +; ; fill in rest of built-ins ; -; - +; ; how to handle op? ; -; - +; ; Handle assert/retract? call? (If given ground terms- ok, vars- no) ; -; - +; ; must have ground functor, definite number of args! ; -; - +; Front end for simulator use - (= - (top) + (= (top) (do-sdda test $A $B $C)) -; - ; -; - +; Does the sdda on FileName, instantiates Exitmodes to list of exit modes, ; -; - +; ExitModes structure: [[Funtor/Arity, Activation, Exit], ... ], ; -; - - - (= - (do-sdda $FileName $ExitModes $BackList $PredList) - ( (read-procedures $Procs $ExitModes $Entries) (entry-exit-modes-list $Procs $ExitModes $Entries))) -; +; e.g. [[a/2, [g,X], [g,g]] + (= (do-sdda $FileName $ExitModes $BackList $PredList) + (read-procedures $Procs $ExitModes $Entries) + (entry-exit-modes-list $Procs $ExitModes $Entries)) +; ;;see(FileName), +; ; collect all procedures +; ;;seen, ; write('Procedures '), nl, write_list(Procs), nl, ; write('Entry points '), nl, write_list(Entries), nl, ; (nonvar(ExitModes) -> ; Don't mention there ; (write('Declared exit modes '), nl, ; aren't any ; write_list(ExitModes), nl) ; ; true), ; -; - +; write('Exit modes '), nl, write_list(ExitModes), nl. ; -; - +; ;; !!! Hard code in read for test: ; -; - +; sdda_entry(c(A,B,C)). ; -; - +; a(X, Y). ; -; - +; a(X, X). ; -; +; c(A,B,C) :- a(A,B). - - (= - (read-procedures - (Cons - (Cons - (/ a 2) - (Cons - (a $109 $110) - (Cons - (a $148 $148) $184))) - (Cons - (Cons - (/ c 3) - (Cons - (= - (c $191 $192 $193) - (a $191 $192)) $238)) $239)) $68 - (Cons - (c $76 $77 $78) $102)) + (= (read-procedures (Cons (Cons (/ a 2) (Cons (a $109 $110) (Cons (a $148 $148) $184))) (Cons (Cons (/ c 3) (Cons (= (c $191 $192 $193) + (a $191 $192)) $238)) $239)) $68 (Cons (c $76 $77 $78) $102)) (set-det)) -; - ; -; - +; For each entry point in Entries do sdda, building Known, an unbound-tail list ; -; - +; Known structure: [[Name/Arity, ActivationModes, ExitModes], ...|_], ; -; - +; where ActivationModes and ExitModes are lists of variables and the atom 'g'. ; -; +; 'g' represents a ground element and variables represent equivalence classes. - - (= - (entry-exit-modes-list $_ $_ $Entries) + (= (entry-exit-modes-list $_ $_ $Entries) (var $Entries)) -; - - (= - (entry-exit-modes-list $ProcList $Known - (Cons $Entry $Entries)) - ( (=.. $Entry - (Cons $Functor $Act)) - (length $Act $Arity) - (proc-exit-mode $ProcList $Known Nil - (/ $Functor $Arity) $Act $_) - (entry-exit-modes-list $ProcList $Known $Entries))) -; - +; ; Done + (= (entry-exit-modes-list $ProcList $Known (Cons $Entry $Entries)) + (=.. $Entry + (Cons $Functor $Act)) + (length $Act $Arity) + (proc-exit-mode $ProcList $Known Nil + (/ $Functor $Arity) $Act $_) + (entry-exit-modes-list $ProcList $Known $Entries)) +; ; Get functor/arity & activation +; ; from entry declaration +; ; No invoc. ; -; - +; Do sdda on procedure Functor/Arity, given activation mode Act. Instantiates ; -; +; Known to known exit modes and Act to exit modes for Functor/Arity under Act - - (= - (proc-exit-mode $_ $_ $_ - (/ $Functor $Arity) $Act $Exit) + (= (proc-exit-mode $_ $_ $_ (/ $Functor $Arity) $Act $Exit) (built-in - (/ $Functor $Arity) $Act $Exit)) -; - ; -; - - (= - (proc-exit-mode $_ $Known $_ - (/ $Functor $Arity) $Act $Exit) + (/ $Functor $Arity) $Act $Exit)) ; +; This is a built-in + (= (proc-exit-mode $_ $Known $_ (/ $Functor $Arity) $Act $Exit) (look-up-act + (:: + (/ $Functor $Arity) $Act $Exit) $Known)) ; +; Already did this + (= (proc-exit-mode $ProcList $Known $Invocations (/ $Functor $Arity) $Act $Exit) + (umember + (Cons + (/ $Functor $Arity) $Clauses) $ProcList) + (dup $Clauses $ClausesCopy) + (clause-exit-modes-list $ProcList $Known $Invocations $ClausesCopy $Act $Exits) + (det-if-then-else + (= $Exits Nil) fail True) + (worst-case $Exits $Exit) + (dup $Act $ActCopy) + (add-to-list + (:: + (/ $Functor $Arity) $ActCopy $Exit) $Known)) +; ; Look up definition +; ; Don't munge original +; ; didn't find any => fail +; ; assume the worst +; ; Need copy because Body ; +; binds Act & Exit + (= (proc-exit-mode $_ $Known $_ (/ $Functor $Arity) $Act $Exit) + (=.. $Activation + (Cons $Functor $Act)) + (all-shared $Act $Exit) + (add-to-list (:: (/ $Functor $Arity) $Act $Exit) $Known)) -; - ; -; - - (= - (proc-exit-mode $ProcList $Known $Invocations - (/ $Functor $Arity) $Act $Exit) - ( (umember - (Cons - (/ $Functor $Arity) $Clauses) $ProcList) - (dup $Clauses $ClausesCopy) - (clause-exit-modes-list $ProcList $Known $Invocations $ClausesCopy $Act $Exits) - (det-if-then-else - (= $Exits Nil) fail True) - (worst-case $Exits $Exit) - (dup $Act $ActCopy) - (add-to-list - (:: - (/ $Functor $Arity) $ActCopy $Exit) $Known))) -; - ; -; - - (= - (proc-exit-mode $_ $Known $_ - (/ $Functor $Arity) $Act $Exit) - ( (=.. $Activation - (Cons $Functor $Act)) - (all-shared $Act $Exit) - (add-to-list - (:: - (/ $Functor $Arity) $Act $Exit) $Known))) -; - - -; -; - - - (= - (clause-exit-modes-list $_ $_ $_ $Clauses $_ Nil) - ( (var $Clauses) (set-det))) -; - ; -; - - (= - (clause-exit-modes-list $ProcList $Known $Invocations - (Cons $Clause $Clauses) $Act $Exits) - ( (eqmember - (:: $Clause $Act) $Invocations) (clause-exit-modes-list $ProcList $Known $Invocations $Clauses $Act $Exits))) -; - ; -; - - (= - (clause-exit-modes-list $ProcList $Known $Invocations - (Cons $Clause $Clauses) $Act - (Cons $Exit $Exits)) - ( (dup $Act $Exit) - (clause-exit-mode $ProcList $Known - (Cons - (:: $Clause $Act) $Invocations) $Clause $Exit) - (clause-exit-modes-list $ProcList $Known $Invocations $Clauses $Act $Exits))) -; - - (= - (clause-exit-modes-list $ProcList $Known $Invocations - (Cons $Clause $Clauses) $Act $Exits) - (clause-exit-modes-list $ProcList $Known $Invocations $Clauses $Act $Exits)) -; - - -; -; - - - (= - (clause-exit-mode $ProcList $Known $Invocations $Clause $Act) - ( (or - (= $Clause - (= $Head $Body)) - (, - (= $Clause $Head) - (= $Body True))) - (=.. $Head - (Cons $_ $Args)) - (unify $Args $Act) - (body-exit-mode $ProcList $Known $Invocations $Body))) -; - ; -; - - - - (= - (body-exit-mode $ProcList $Known $Invocations - (, $Goal $Goals)) - ( (body-exit-mode $ProcList $Known $Invocations $Goal) (body-exit-mode $ProcList $Known $Invocations $Goals))) -; - ; -; - - (= - (body-exit-mode $ProcList $Known $Invocation $Goal) - ( (functor $Goal $Functor $Arity) - (=.. $Goal - (Cons $Functor $Act)) - (proc-exit-mode $ProcList $Known $Invocation - (/ $Functor $Arity) $Act $Exit) - (unify $Act $Exit))) -; - +; ; write('No such procedure at compile time '), +; ; write(Activation), nl, +; ; return worst possible - all shared ; -; - -; -; +; Analyze all clauses for this procedure, instantiate Exits to all exit modes + (= (clause-exit-modes-list $_ $_ $_ $Clauses $_ Nil) + (var $Clauses) + (set-det)) ; +; No more clauses => done + (= (clause-exit-modes-list $ProcList $Known $Invocations (Cons $Clause $Clauses) $Act $Exits) + (eqmember + (:: $Clause $Act) $Invocations) + (clause-exit-modes-list $ProcList $Known $Invocations $Clauses $Act $Exits)) +; ; This is a recursive ; write('skipping clause exit mode for '), ; write(Clause), write(' '), write(Act), nl, +; ; call, ignore ; +; it + (= (clause-exit-modes-list $ProcList $Known $Invocations (Cons $Clause $Clauses) $Act (Cons $Exit $Exits)) + (dup $Act $Exit) + (clause-exit-mode $ProcList $Known + (Cons + (:: $Clause $Act) $Invocations) $Clause $Exit) + (clause-exit-modes-list $ProcList $Known $Invocations $Clauses $Act $Exits)) +; ; We'll bind Exit +; ; Record invocation + (= (clause-exit-modes-list $ProcList $Known $Invocations (Cons $Clause $Clauses) $Act $Exits) + (clause-exit-modes-list $ProcList $Known $Invocations $Clauses $Act $Exits)) +; ; Unify failed - (= - (unify $Left $Left) - (set-det)) -; - ; -; - - (= - (unify $Left g) - ( (atomic $Left) - (set-det) - (not (= $Left Nil)))) -; - - (= - (unify g $Right) - ( (atomic $Right) - (set-det) - (not (= $Right Nil)))) -; - - (= - (unify - (Cons $LeftHead $LeftTail) - (Cons $RightHead $RightTail)) - ( (set-det) - (unify $LeftHead $RightHead) - (unify $LeftTail $RightTail))) -; - - (= - (unify $Left $Right) - ( (=.. $Left - (Cons $Functor $LeftArgs)) - (=.. $Right - (Cons $Functor $RightArgs)) - (unify $LeftArgs $RightArgs))) -; +; +; Given activation modes for this clause, return its exit modes + (= (clause-exit-mode $ProcList $Known $Invocations $Clause $Act) + (or + (= $Clause + (= $Head $Body)) + (, + (= $Clause $Head) + (= $Body True))) + (=.. $Head + (Cons $_ $Args)) + (unify $Args $Act) + (body-exit-mode $ProcList $Known $Invocations $Body)) +; ; Decompose it +; ; Bind the head +; ; to activation ; +; do the body + + + (= (body-exit-mode $ProcList $Known $Invocations (, $Goal $Goals)) + (body-exit-mode $ProcList $Known $Invocations $Goal) + (body-exit-mode $ProcList $Known $Invocations $Goals)) +; ; Conjunction +; ; Do 1st ; +; & rest + (= (body-exit-mode $ProcList $Known $Invocation $Goal) + (functor $Goal $Functor $Arity) + (=.. $Goal + (Cons $Functor $Act)) + (proc-exit-mode $ProcList $Known $Invocation + (/ $Functor $Arity) $Act $Exit) + (unify $Act $Exit)) + +; +; Unifies Left and Right with the special case that the atom 'g' matches +; +; any atom (except []) + + (= (unify $Left $Left) + (set-det)) ; +; Try standard unify first + (= (unify $Left g) + (atomic $Left) + (set-det) + (not (= $Left Nil))) +; ; else, is it special case + (= (unify g $Right) + (atomic $Right) + (set-det) + (not (= $Right Nil))) + (= (unify (Cons $LeftHead $LeftTail) (Cons $RightHead $RightTail)) + (set-det) + (unify $LeftHead $RightHead) + (unify $LeftTail $RightTail)) +; ; or list + (= (unify $Left $Right) + (=.. $Left + (Cons $Functor $LeftArgs)) + (=.. $Right + (Cons $Functor $RightArgs)) + (unify $LeftArgs $RightArgs)) +; ; or structure ; -; - +; Succeed if Left and Right are equivalent, i.e. they are the exact same ; -; +; with variables renamed - - (= - (equiv $Left $Right) + (= (equiv $Left $Right) (equiv $Left $Right $_)) -; - - (= - (equiv $Left $Right $_) - ( (== $Left $Right) (set-det))) -; - - (= - (equiv g $Right $_) - ( (atomic $Right) - (set-det) - (not (= $Right Nil)))) -; - - (= - (equiv $Left g $_) - ( (atomic $Left) - (set-det) - (not (= $Left Nil)))) -; - - (= - (equiv $Left $Right $Bindings) - ( (var $Left) - (set-det) - (var $Right) - (equiv-vars $Left $Right $Bindings))) -; - - (= - (equiv $Left $Right $Bindings) - ( (var $Right) - (set-det) - (var $Left) - (equiv-vars $Left $Right $Bindings))) -; - - (= - (equiv - (Cons $LeftHead $LeftTail) - (Cons $RightHead $RightTail) $Bindings) - ( (set-det) - (equiv $LeftHead $RightHead $Bindings) - (equiv $LeftTail $RightTail $Bindings))) -; - - (= - (equiv $Left $Right $Bindings) - ( (=.. $Left - (Cons $Functor $LeftArgs)) - (=.. $Right - (Cons $Functor $RightArgs)) - (equiv $LeftArgs $RightArgs $Bindings))) -; - - - - (= - (equiv-vars $Left $Right $Bindings) - ( (var $Bindings) - (set-det) - (= $Bindings - (Cons - (:: $Left $Right) $_)))) -; - - (= - (equiv-vars $Left $Right - (Cons - (:: $AnyVar $AnyBinding) $_)) - ( (== $Left $AnyVar) - (set-det) - (== $Right $AnyBinding))) -; - - (= - (equiv-vars $Left $Right + (= (equiv $Left $Right $_) + (== $Left $Right) + (set-det)) + (= (equiv g $Right $_) + (atomic $Right) + (set-det) + (not (= $Right Nil))) + (= (equiv $Left g $_) + (atomic $Left) + (set-det) + (not (= $Left Nil))) + (= (equiv $Left $Right $Bindings) + (var $Left) + (set-det) + (var $Right) + (equiv-vars $Left $Right $Bindings)) + (= (equiv $Left $Right $Bindings) + (var $Right) + (set-det) + (var $Left) + (equiv-vars $Left $Right $Bindings)) + (= (equiv (Cons $LeftHead $LeftTail) (Cons $RightHead $RightTail) $Bindings) + (set-det) + (equiv $LeftHead $RightHead $Bindings) + (equiv $LeftTail $RightTail $Bindings)) + (= (equiv $Left $Right $Bindings) + (=.. $Left + (Cons $Functor $LeftArgs)) + (=.. $Right + (Cons $Functor $RightArgs)) + (equiv $LeftArgs $RightArgs $Bindings)) + + + (= (equiv-vars $Left $Right $Bindings) + (var $Bindings) + (set-det) + (= $Bindings (Cons - (:: $AnyVar $AnyBinding) $_)) - ( (== $Right $AnyBinding) - (set-det) - (== $Left $AnyVar))) -; - - (= - (equiv-vars $Left $Right - (Cons $_ $Bindings)) + (:: $Left $Right) $_))) + (= (equiv-vars $Left $Right (Cons (:: $AnyVar $AnyBinding) $_)) + (== $Left $AnyVar) + (set-det) + (== $Right $AnyBinding)) + (= (equiv-vars $Left $Right (Cons (:: $AnyVar $AnyBinding) $_)) + (== $Right $AnyBinding) + (set-det) + (== $Left $AnyVar)) + (= (equiv-vars $Left $Right (Cons $_ $Bindings)) (equiv-vars $Left $Right $Bindings)) -; - ; -; - +; Make a copy of Orig with new vars. Copy must be a variable. ; -; - +; E.g. dup([A,s(A,B),[B,C]], New) binds New to [X,s(X,Y),[Y,Z]] - (= - (dup $Orig $Copy) + (= (dup $Orig $Copy) (dup $Orig $Copy $_)) -; - - (= - (dup $Orig $Copy $Bindings) - ( (var $Orig) - (set-det) - (dup-var $Orig $Copy $Bindings))) -; - - (= - (dup $Orig $Orig $_) - ( (atomic $Orig) (set-det))) -; - - (= - (dup - (Cons $OrigHead $OrigTail) - (Cons $CopyHead $CopyTail) $Bindings) - ( (set-det) - (dup $OrigHead $CopyHead $Bindings) - (dup $OrigTail $CopyTail $Bindings))) -; - - (= - (dup $Orig $Copy $Bindings) - ( (=.. $Orig - (Cons $Functor $OrigArgs)) - (dup $OrigArgs $CopyArgs $Bindings) - (=.. $Copy - (Cons $Functor $CopyArgs)))) -; - - - - (= - (dup-var $Orig $Copy $Bindings) - ( (var $Bindings) - (set-det) - (= $Bindings - (Cons - (:: $Orig $Copy) $_)))) -; - - (= - (dup-var $Orig $Copy + (= (dup $Orig $Copy $Bindings) + (var $Orig) + (set-det) + (dup-var $Orig $Copy $Bindings)) + (= (dup $Orig $Orig $_) + (atomic $Orig) + (set-det)) +; ; Atoms, including [] + (= (dup (Cons $OrigHead $OrigTail) (Cons $CopyHead $CopyTail) $Bindings) + (set-det) + (dup $OrigHead $CopyHead $Bindings) + (dup $OrigTail $CopyTail $Bindings)) + (= (dup $Orig $Copy $Bindings) + (=.. $Orig + (Cons $Functor $OrigArgs)) + (dup $OrigArgs $CopyArgs $Bindings) + (=.. $Copy + (Cons $Functor $CopyArgs))) + + + (= (dup-var $Orig $Copy $Bindings) + (var $Bindings) + (set-det) + (= $Bindings (Cons - (:: $AnyVar $Copy) $_)) - ( (== $Orig $AnyVar) (set-det))) -; - - (= - (dup-var $Orig $Copy - (Cons $_ $Bindings)) + (:: $Orig $Copy) $_))) + (= (dup-var $Orig $Copy (Cons (:: $AnyVar $Copy) $_)) + (== $Orig $AnyVar) + (set-det)) + (= (dup-var $Orig $Copy (Cons $_ $Bindings)) (dup-var $Orig $Copy $Bindings)) -; - ; -; - +; ----- Built-ins ----- ; - (= - (built_in - (/ true 0) () ()) True) -; - ; -; - - (= - (built_in - (/ fail 0) () ()) True) -; - ; -; - - (= - (built-in - (/ = 2) - (:: $X $Y) - (:: g g)) + (= (built_in (/ true 0) () ()) True) ; +; No change + (= (built_in (/ fail 0) () ()) True) ; +; No change + (= (built-in (/ = 2) (:: $X $Y) (:: g g)) (or (atomic $X) - (atomic $Y))) -; - ; -; - - (= - (built_in - (/ = 2) - ($X $Y) - ($X $X)) True) -; - ; -; - - (= - (built_in - (/ + 2) - ($X $Y) - ($X $Y)) True) -; - ; -; - - (= - (built_in - (/ - 2) - ($X $Y) - ($X $Y)) True) -; - ; -; - - (= - (built_in - (/ * 2) - ($X $Y) - ($X $Y)) True) -; - ; -; - - (= - (built_in - (/ / 2) - ($X $Y) - ($X $Y)) True) -; - ; -; - - (= - (built_in - (/ >= 2) - ($X $Y) - ($X $Y)) True) -; - ; -; - - (= - (built_in - (/ < 2) - ($X $Y) - ($X $Y)) True) -; - ; -; - - (= - (built_in - (/ is 2) - ($X $Y) - (g $Y)) True) -; - ; -; - - -; -; - - - - (= - (worst_case () $_) True) -; - ; -; - - (= - (worst-case - (Cons $Exit $Exits) $Worst) - ( (unify $Exit $Worst) (worst-case $Exits $Worst))) -; - - - - (= - (look-up-act $_ $Known) - ( (var $Known) - (set-det) - (fail))) -; - - (= - (look-up-act - (:: - (/ $Functor $Arity) $Act $Exit) - (Cons - (:: - (/ $Functor $Arity) $KnownAct $Exit) $_)) - (equiv $Act $KnownAct)) -; - - (= - (look-up-act - (:: - (/ $Functor $Arity) $Act $Exit) - (Cons $_ $Known)) + (atomic $Y))) ; +; Ground both if either atomic + (= (built_in (/ = 2) ($X $Y) ($X $X)) True) ; +; else bind them + (= (built_in (/ + 2) ($X $Y) ($X $Y)) True) ; +; No change + (= (built_in (/ - 2) ($X $Y) ($X $Y)) True) ; +; No change + (= (built_in (/ * 2) ($X $Y) ($X $Y)) True) ; +; No change + (= (built_in (/ / 2) ($X $Y) ($X $Y)) True) ; +; No change + (= (built_in (/ >= 2) ($X $Y) ($X $Y)) True) ; +; No change + (= (built_in (/ < 2) ($X $Y) ($X $Y)) True) ; +; No change + (= (built_in (/ is 2) ($X $Y) (g $Y)) True) ; +; Ground result + +; +; ----- Utilities ----- ; + + + (= (worst_case () $_) True) ; +; ; Doesn't work if any Exits + (= (worst-case (Cons $Exit $Exits) $Worst) + (unify $Exit $Worst) + (worst-case $Exits $Worst)) +; ;; fail to match, e.g. +; ;; [[s(1)], [f(1)]]. + + + (= (look-up-act $_ $Known) + (var $Known) + (set-det) + (fail)) + (= (look-up-act (:: (/ $Functor $Arity) $Act $Exit) (Cons (:: (/ $Functor $Arity) $KnownAct $Exit) $_)) + (equiv $Act $KnownAct)) + (= (look-up-act (:: (/ $Functor $Arity) $Act $Exit) (Cons $_ $Known)) (look-up-act (:: (/ $Functor $Arity) $Act $Exit) $Known)) -; - - (= - (all-shared $Act $Exit) - ( (unify $Act $_ $VarModesList) - (bind-all $_ $VarModesList) - (unify $Act $Exit $VarModesList))) -; + (= (all-shared $Act $Exit) + (unify $Act $_ $VarModesList) + (bind-all $_ $VarModesList) + (unify $Act $Exit $VarModesList)) +; ;; Wrong - - (= - (bind-all $_ $VarModesList) + (= (bind-all $_ $VarModesList) (var $VarModesList)) -; - - (= - (bind-all $Mode - (Cons - (:: $Var $Mode) $VarModesList)) - ( (var $Mode) (bind-all $Mode $VarModesList))) -; - - (= - (bind-all $Mode - (Cons - (:: $_ $_) $VarModesList)) + (= (bind-all $Mode (Cons (:: $Var $Mode) $VarModesList)) + (var $Mode) + (bind-all $Mode $VarModesList)) + (= (bind-all $Mode (Cons (:: $_ $_) $VarModesList)) (bind-all $Mode $VarModesList)) -; - ; -; - - - (= - (add-to-list $Element $List) - ( (var $List) (= $List (Cons $Element $_)))) -; +; Adds Element to the tail of List, an unbound-tail list - (= - (add-to-list $Element - (Cons $_ $List)) + (= (add-to-list $Element $List) + (var $List) + (= $List + (Cons $Element $_))) + (= (add-to-list $Element (Cons $_ $List)) (add-to-list $Element $List)) -; - ; -; - - - (= - (umember $_ $List) - ( (var $List) - (set-det) - (fail))) -; +; Membership relation for unbound-tail lists - (= - (umember $Element - (Cons $Element $_)) True) -; - - (= - (umember $Element - (Cons $_ $Tail)) + (= (umember $_ $List) + (var $List) + (set-det) + (fail)) + (= (umember $Element (Cons $Element $_)) True) + (= (umember $Element (Cons $_ $Tail)) (umember $Element $Tail)) -; - ; -; - - - (= - (sumember $_ $List) - ( (var $List) - (set-det) - (fail))) -; +; Strict membership relation for unbound-tail lists - (= - (sumember $Element - (Cons $AnyElement $_)) + (= (sumember $_ $List) + (var $List) + (set-det) + (fail)) + (= (sumember $Element (Cons $AnyElement $_)) (== $Element $AnyElement)) -; - - (= - (sumember $Element - (Cons $_ $Tail)) + (= (sumember $Element (Cons $_ $Tail)) (sumember $Element $Tail)) -; - ; -; - - - (= - (member $X - (Cons $X $_)) True) -; +; Membership relation for standard nil-tail lists - (= - (member $X - (Cons $_ $T)) + (= (member $X (Cons $X $_)) True) + (= (member $X (Cons $_ $T)) (member $X $T)) -; - ; -; - +; Strict membership relation for standard nil-tail lists - (= - (smember $X - (Cons $Y $_)) + (= (smember $X (Cons $Y $_)) (== $X $Y)) -; - - (= - (smember $X - (Cons $_ $T)) + (= (smember $X (Cons $_ $T)) (smember $X $T)) -; - ; -; +; Equiv membership relation for standard nil-tail lists - - (= - (eqmember $X - (Cons $Y $_)) + (= (eqmember $X (Cons $Y $_)) (equiv $X $Y)) -; - - (= - (eqmember $X - (Cons $_ $T)) + (= (eqmember $X (Cons $_ $T)) (eqmember $X $T)) -; - ; -; +; Our old favorite - - (= - (concat () $L $L) True) -; - - (= - (concat - (Cons $X $L1) $L2 - (Cons $X $L3)) + (= (concat () $L $L) True) + (= (concat (Cons $X $L1) $L2 (Cons $X $L3)) (concat $L1 $L2 $L3)) -; - ; -; - +; Pretty prints unbound-tail lists -- dies on NIL tail lists ; -; - +; write_list(List) :- ; -; - +; dup(List, NewList), ; -; - +; (var(NewList) -> (name_vars(NewList, 0, _)); ; -; - +; write(NewList)) ; ; -; - +; (write('['), ; -; - +; write_list2(NewList, 0, _), ; -; - +; write('|_].'))), ; write('].') to write nil tails - (= nl True) -; - - - (= - (write-list2 - (Cons $H $T) $NextName $NewNextName) - ( (name-vars $H $NextName $TempNextName) - (write $H) - (det-if-then-else - (nonvar $T) - (, - (write ,) - (nl) - (write ' ') - (write-list2 $T $TempNextName $NewNextName)) - (= $NewNextName $TempNextName)))) -; - - - - (= - (name-vars $Term $NextName $NewNextName) - ( (var $Term) - (set-det) - (make-name $NextName $Term) - (is $NewNextName - (+ $NextName 1)))) -; - - (= - (name-vars $Term $NextName $NextName) - ( (atom $Term) (set-det))) -; - - (= - (name-vars - (Cons $TermHead $TermTail) $NextName $NewNextName) - ( (set-det) - (name-vars $TermHead $NextName $TempNextName) - (name-vars $TermTail $TempNextName $NewNextName))) -; - - (= - (name-vars $Term $NextName $NewNextName) - ( (=.. $Term - (Cons $_ $TermArgs)) (name-vars $TermArgs $NextName $NewNextName))) -; - - - - (= - (make-name $IntName $Variable) - ( (is $Count - (// $IntName 26)) - (is $NewIntName - (+ - (mod $IntName 26) "A")) - (build-name $Count $NewIntName $Name) - (name $Variable $Name))) -; - - - - (= - (build-name 0 $IntName - (:: $IntName)) + (= nl True) + + (= (write-list2 (Cons $H $T) $NextName $NewNextName) + (name-vars $H $NextName $TempNextName) + (write $H) + (det-if-then-else + (nonvar $T) + (, + (write ,) + (nl) + (write ' ') + (write-list2 $T $TempNextName $NewNextName)) + (= $NewNextName $TempNextName))) + + + (= (name-vars $Term $NextName $NewNextName) + (var $Term) + (set-det) + (make-name $NextName $Term) + (is $NewNextName + (+ $NextName 1))) + (= (name-vars $Term $NextName $NextName) + (atom $Term) (set-det)) -; - - (= - (build-name $Count $IntName - (Cons $IntName $Rest)) - ( (> $Count 0) - (is $NewCount - (- $Count 1)) - (build-name $NewCount $IntName $Rest))) -; - + (= (name-vars (Cons $TermHead $TermTail) $NextName $NewNextName) + (set-det) + (name-vars $TermHead $NextName $TempNextName) + (name-vars $TermTail $TempNextName $NewNextName)) + (= (name-vars $Term $NextName $NewNextName) + (=.. $Term + (Cons $_ $TermArgs)) + (name-vars $TermArgs $NextName $NewNextName)) + + + (= (make-name $IntName $Variable) + (is $Count + (// $IntName 26)) + (is $NewIntName + (+ + (mod $IntName 26) "A")) + (build-name $Count $NewIntName $Name) + (name $Variable $Name)) + + + (= (build-name 0 $IntName (:: $IntName)) + (set-det)) + (= (build-name $Count $IntName (Cons $IntName $Rest)) + (> $Count 0) + (is $NewCount + (- $Count 1)) + (build-name $NewCount $IntName $Rest)) diff --git a/sxx_machine/bench/sendmore.metta b/sxx_machine/bench/sendmore.metta index 8b31ece..f38db46 100644 --- a/sxx_machine/bench/sendmore.metta +++ b/sxx_machine/bench/sendmore.metta @@ -1,159 +1,101 @@ +; (convert_to_metta_file sendmore $_199046 sxx_machine/bench/sendmore.pl sxx_machine/bench/sendmore.metta) ; -; - +; Cryptoaddition: ; -; - +; Find the unique answer to: ; -; - +; SEND ; -; - +; +MORE ; -; - +; ----- ; -; - +; MONEY ; -; - - - - (= - (top) - ( (digit $D) - (digit $E) - (=\= $D $E) - (sumdigit 0 $D $E $Y $C1) - (digit $N) - (=\= $N $Y) - (=\= $N $E) - (=\= $N $D) - (digit $R) - (=\= $R $N) - (=\= $R $Y) - (=\= $R $E) - (=\= $R $D) - (sumdigit $C1 $N $R $E $C2) - (digit $O) - (=\= $O $R) - (=\= $O $N) - (=\= $O $Y) - (=\= $O $E) - (=\= $O $D) - (sumdigit $C2 $E $O $N $C3) - (leftdigit $S) - (=\= $S $O) - (=\= $S $R) - (=\= $S $N) - (=\= $S $Y) - (=\= $S $E) - (=\= $S $D) - (leftdigit $M) - (=\= $M $S) - (=\= $M $O) - (=\= $M $R) - (=\= $M $N) - (=\= $M $Y) - (=\= $M $E) - (=\= $M $D) - (sumdigit $C3 $S $M $O $M) - (fail))) -; - - (= top True) -; - - - - (= - (sumdigit $C $A $B $S $D) - ( (is $X - (+ - (+ $C $A) $B)) (det-if-then-else (< $X 10) (, (= $S $X) (= $D 0)) (, (is $S (- $X 10)) (= $D 1))))) -; - - - - (= - (digit 0) True) -; - - (= - (digit 1) True) -; - - (= - (digit 2) True) -; - - (= - (digit 3) True) -; - - (= - (digit 4) True) -; - - (= - (digit 5) True) -; - - (= - (digit 6) True) -; - - (= - (digit 7) True) -; - - (= - (digit 8) True) -; - - (= - (digit 9) True) -; - - - - (= - (leftdigit 1) True) -; - - (= - (leftdigit 2) True) -; - - (= - (leftdigit 3) True) -; - - (= - (leftdigit 4) True) -; - - (= - (leftdigit 5) True) -; - - (= - (leftdigit 6) True) -; - - (= - (leftdigit 7) True) -; - - (= - (leftdigit 8) True) -; - - (= - (leftdigit 9) True) -; - +; where each letter is a distinct digit. + + + (= (top) + (digit $D) + (digit $E) + (=\= $D $E) + (sumdigit 0 $D $E $Y $C1) + (digit $N) + (=\= $N $Y) + (=\= $N $E) + (=\= $N $D) + (digit $R) + (=\= $R $N) + (=\= $R $Y) + (=\= $R $E) + (=\= $R $D) + (sumdigit $C1 $N $R $E $C2) + (digit $O) + (=\= $O $R) + (=\= $O $N) + (=\= $O $Y) + (=\= $O $E) + (=\= $O $D) + (sumdigit $C2 $E $O $N $C3) + (leftdigit $S) + (=\= $S $O) + (=\= $S $R) + (=\= $S $N) + (=\= $S $Y) + (=\= $S $E) + (=\= $S $D) + (leftdigit $M) + (=\= $M $S) + (=\= $M $O) + (=\= $M $R) + (=\= $M $N) + (=\= $M $Y) + (=\= $M $E) + (=\= $M $D) + (sumdigit $C3 $S $M $O $M) + (fail)) +; ; write(' '),write(S),write(E),write(N),write(D),nl, +; ; write('+'),write(M),write(O),write(R),write(E),nl, +; ; write('-----'),nl, +; ; write(M),write(O),write(N),write(E),write(Y),nl,nl, + (= top True) + + + (= (sumdigit $C $A $B $S $D) + (is $X + (+ + (+ $C $A) $B)) + (det-if-then-else + (< $X 10) + (, + (= $S $X) + (= $D 0)) + (, + (is $S + (- $X 10)) + (= $D 1)))) + + + (= (digit 0) True) + (= (digit 1) True) + (= (digit 2) True) + (= (digit 3) True) + (= (digit 4) True) + (= (digit 5) True) + (= (digit 6) True) + (= (digit 7) True) + (= (digit 8) True) + (= (digit 9) True) + + + (= (leftdigit 1) True) + (= (leftdigit 2) True) + (= (leftdigit 3) True) + (= (leftdigit 4) True) + (= (leftdigit 5) True) + (= (leftdigit 6) True) + (= (leftdigit 7) True) + (= (leftdigit 8) True) + (= (leftdigit 9) True) diff --git a/sxx_machine/bench/serialise.metta b/sxx_machine/bench/serialise.metta index 15be832..456a410 100644 --- a/sxx_machine/bench/serialise.metta +++ b/sxx_machine/bench/serialise.metta @@ -1,135 +1,71 @@ +; (convert_to_metta_file serialise $_298080 sxx_machine/bench/serialise.pl sxx_machine/bench/serialise.metta) ; -; - +; generated: 17 November 1989 ; -; - +; option(s): ; ; - ; -; - +; serialise ; ; - ; -; - +; David H. D. Warren ; ; - ; -; - +; itemize (pick a "serial number" for each ; -; +; unique integer in) a list of 25 integers - - (= - (top) + (= (top) (serialise)) -; - - (= - (serialise) + (= (serialise) (serialise "ABLE WAS I ERE I SAW ELBA" $_)) -; - - (= - (serialise $L $R) - ( (pairlists $L $R $A) - (arrange $A $T) - (numbered $T 1 $_))) -; + (= (serialise $L $R) + (pairlists $L $R $A) + (arrange $A $T) + (numbered $T 1 $_)) - - (= - (pairlists - (Cons $X $L) - (Cons $Y $R) - (Cons - (pair $X $Y) $A)) + (= (pairlists (Cons $X $L) (Cons $Y $R) (Cons (pair $X $Y) $A)) (pairlists $L $R $A)) -; - - (= - (pairlists () () ()) True) -; - + (= (pairlists () () ()) True) - (= - (arrange - (Cons $X $L) - (tree $T1 $X $T2)) - ( (split $L $X $L1 $L2) - (arrange $L1 $T1) - (arrange $L2 $T2))) -; - - (= - (arrange () void) True) -; + (= (arrange (Cons $X $L) (tree $T1 $X $T2)) + (split $L $X $L1 $L2) + (arrange $L1 $T1) + (arrange $L2 $T2)) + (= (arrange () void) True) + (= (split (Cons $X $L) $X $L1 $L2) + (set-det) + (split $L $X $L1 $L2)) + (= (split (Cons $X $L) $Y (Cons $X $L1) $L2) + (before $X $Y) + (set-det) + (split $L $Y $L1 $L2)) + (= (split (Cons $X $L) $Y $L1 (Cons $X $L2)) + (before $Y $X) + (set-det) + (split $L $Y $L1 $L2)) + (= (split () $_ () ()) True) - (= - (split - (Cons $X $L) $X $L1 $L2) - ( (set-det) (split $L $X $L1 $L2))) -; - - (= - (split - (Cons $X $L) $Y - (Cons $X $L1) $L2) - ( (before $X $Y) - (set-det) - (split $L $Y $L1 $L2))) -; - - (= - (split - (Cons $X $L) $Y $L1 - (Cons $X $L2)) - ( (before $Y $X) - (set-det) - (split $L $Y $L1 $L2))) -; - (= - (split () $_ () ()) True) -; - - - - (= - (before - (pair $X1 $_) - (pair $X2 $_)) + (= (before (pair $X1 $_) (pair $X2 $_)) (< $X1 $X2)) -; - - (= - (numbered - (tree $T1 - (pair $_ $N1) $T2) $N0 $N) - ( (numbered $T1 $N0 $N1) - (is $N2 - (+ $N1 1)) - (numbered $T2 $N2 $N))) -; - - (= - (numbered void $N $N) True) -; - + (= (numbered (tree $T1 (pair $_ $N1) $T2) $N0 $N) + (numbered $T1 $N0 $N1) + (is $N2 + (+ $N1 1)) + (numbered $T2 $N2 $N)) + (= (numbered void $N $N) True) diff --git a/sxx_machine/bench/simple_analyzer.metta b/sxx_machine/bench/simple_analyzer.metta index c2846da..a397866 100644 --- a/sxx_machine/bench/simple_analyzer.metta +++ b/sxx_machine/bench/simple_analyzer.metta @@ -1,65 +1,48 @@ +; (convert_to_metta_file simple_analyzer $_388104 sxx_machine/bench/simple_analyzer.pl sxx_machine/bench/simple_analyzer.metta) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Copyright (C) 1990 Peter Van Roy and Regents of the University of California. ; -; - +; All rights reserved. This program may be freely used and modified for ; -; - +; non-commercial purposes provided this copyright notice is kept unchanged. ; -; - +; Written by Peter Van Roy as a part of the Aquarius project. ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Benchmark based on the Aquarius compiler flow analyzer version 1. ; -; - +; This program does a dataflow analysis of quicksort using abstract ; -; - +; interpretation. The lattice has two useful values: uninit and ground. ; -; - +; Analysis takes three passes (it prints three 'x' characters). ; -; - +; Builtins used: compare/3, arg/3, functor/3, sort/2, keysort/2, ==/2, \==/2. - (= - (top) + (= (top) (main $_)) -; - ; -; +; main :- main(Table), write(Table), nl. - - (= - (main $Table) + (= (main $Table) (analyze-strees (:: (stree (/ main 0) - (= - (main) + (= (main) (or (qsort (:: 1 2) $L Nil) fail)) - (= main True) Nil 1) + (= main True) Nil 1) (stree (/ qsort 3) - (= - (qsort $U $P $Q) + (= (qsort $U $P $Q) (or (, (= $U @@ -72,1179 +55,633 @@ (, (= $U Nil) (= $Q $P)) fail))) - (= - (qsort $_ $_ $_) True) Nil 1) + (= (qsort $_ $_ $_) True) Nil 1) (stree (/ part 4) - (= - (part $W $X $Y $Z) + (= (part $W $X $Y $Z) (or (, ($cut-load $A1) ($cut-part/4-1 $W $X $Y $Z $A1)) fail)) - (= - (part $_ $_ $_ $_) True) - (:: (stree (/ %cut-part/4-1 5) (= ($cut-part/4-1 $I1 $E1 $F1 $G1 $H1) (or (, (= $I1 (Cons $C1 $D1)) ($fac-$cut-part/4-1/5-2 $D1 $E1 $F1 $G1 $H1 $C1)) (or (, (= $I1 Nil) (= $F1 Nil) (= $G1 Nil)) fail))) (= (%cut_part/4_1 $_ $_ $_ $_ $_) True) (:: (stree (/ %fac-%cut-part/4-1/5-2 6) (= ($fac-$cut-part/4-1/5-2 $K1 $L1 $Q1 $O1 $P1 $M1) (or (, (= $Q1 (Cons $M1 $N1)) (=< $M1 $L1) ($cut-shallow $P1) (part $K1 $L1 $N1 $O1)) (or (, (= $O1 (Cons $M1 $R1)) (part $K1 $L1 $Q1 $R1)) fail))) (= (%fac_%cut_part/4_1/5_2 $_ $_ $_ $_ $_ $_) True) Nil 1)) 1)) 1)) $Table)) -; - - + (= (part $_ $_ $_ $_) True) + (:: (stree (/ %cut-part/4-1 5) (= ($cut-part/4-1 $I1 $E1 $F1 $G1 $H1) + (or + (, + (= $I1 + (Cons $C1 $D1)) + ($fac-$cut-part/4-1/5-2 $D1 $E1 $F1 $G1 $H1 $C1)) + (or + (, + (= $I1 Nil) + (= $F1 Nil) + (= $G1 Nil)) fail))) (= (%cut_part/4_1 $_ $_ $_ $_ $_) True) (:: (stree (/ %fac-%cut-part/4-1/5-2 6) (= ($fac-$cut-part/4-1/5-2 $K1 $L1 $Q1 $O1 $P1 $M1) + (or + (, + (= $Q1 + (Cons $M1 $N1)) + (=< $M1 $L1) + ($cut-shallow $P1) + (part $K1 $L1 $N1 $O1)) + (or + (, + (= $O1 + (Cons $M1 $R1)) + (part $K1 $L1 $Q1 $R1)) fail))) (= (%fac_%cut_part/4_1/5_2 $_ $_ $_ $_ $_ $_) True) Nil 1)) 1)) 1)) $Table)) - (= - (analyze-strees $Strees $OutTable) - ( (init-strees $Strees $_ $Table) - (seal $Table) - (analyze-closure $Strees $Table $OutTable))) -; + (= (analyze-strees $Strees $OutTable) + (init-strees $Strees $_ $Table) + (seal $Table) + (analyze-closure $Strees $Table $OutTable)) ; -; +; Repeat traversal step until there are no more changes: + (= (analyze-closure $Strees $InTable $OutTable) + (traverse-strees $Strees $InTable $MidTable 0 $Changes) + (analyze-closure $Strees $MidTable $OutTable $Changes)) +; ; Mark an analysis pass: +; ; put("x"), nl, - (= - (analyze-closure $Strees $InTable $OutTable) - ( (traverse-strees $Strees $InTable $MidTable 0 $Changes) (analyze-closure $Strees $MidTable $OutTable $Changes))) -; - - - (= - (analyze-closure $Strees $InTable $InTable $N) - ( (=< $N 0) (set-det))) -; - - (= - (analyze-closure $Strees $InTable $OutTable $N) - ( (> $N 0) - (set-det) - (analyze-closure $Strees $InTable $OutTable))) -; - + (= (analyze-closure $Strees $InTable $InTable $N) + (=< $N 0) + (set-det)) + (= (analyze-closure $Strees $InTable $OutTable $N) + (> $N 0) + (set-det) + (analyze-closure $Strees $InTable $OutTable)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; +; Initialize the table of call lattice values: + (= (init_strees () $4 $4) True) + (= (init-strees (Cons $12 $13) $4 $5) + (= $12 + (stree $14 + (= $15 $16) $17 $18 $19)) + (bottom-call $14 $20) + (table-command + (get $14 $20) $4 $23) + (init-disj $16 $23 $24) + (init-strees $18 $24 $25) + (init-strees $13 $25 $5)) - (= - (init_strees () $4 $4) True) -; - (= - (init-strees - (Cons $12 $13) $4 $5) - ( (= $12 - (stree $14 - (= $15 $16) $17 $18 $19)) - (bottom-call $14 $20) - (table-command - (get $14 $20) $4 $23) - (init-disj $16 $23 $24) - (init-strees $18 $24 $25) - (init-strees $13 $25 $5))) -; + (= (init_conj true $4 $4) True) + (= (init-conj (, $12 $13) $4 $5) + (init-goal $12 $4 $16) + (init-conj $13 $16 $5)) + (= (init_disj fail $4 $4) True) + (= (init-disj (or $12 $13) $4 $5) + (init-conj $12 $4 $16) + (init-disj $13 $16 $5)) - (= - (init_conj true $4 $4) True) -; - (= - (init-conj - (, $12 $13) $4 $5) - ( (init-goal $12 $4 $16) (init-conj $13 $16 $5))) -; + (= (init-goal $3 $4 $5) + (call-p $3) + (set-det) + (functor $3 $12 $13) + (bottom-call + (/ $12 $13) $14) + (table-command + (get + (/ $12 $13) $14) $4 $5)) + (= (init-goal $3 $4 $4) + (unify-p $3) + (set-det)) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (init_disj fail $4 $4) True) -; + (= (traverse_strees () $4 $4 $6 $6) True) + (= (traverse-strees (Cons $14 $15) $4 $5 $6 $7) + (= $14 + (stree $16 + (= $17 $18) $19 $20 $21)) + (traverse-disj $17 $18 $4 $26 $6 $27) + (traverse-strees $20 $26 $28 $27 $29) + (traverse-strees $15 $28 $5 $29 $7)) - (= - (init-disj - (or $12 $13) $4 $5) - ( (init-conj $12 $4 $16) (init-disj $13 $16 $5))) -; + (= (traverse_disj $3 fail $5 $5 $7 $7) True) + (= (traverse-disj $3 (or $15 $16) $5 $6 $7 $8) + (traverse-conj $3 $15 $5 $22 $7 $23) + (traverse-disj $3 $16 $22 $6 $23 $8)) - (= - (init-goal $3 $4 $5) - ( (call-p $3) - (set-det) - (functor $3 $12 $13) - (bottom-call - (/ $12 $13) $14) - (table-command - (get - (/ $12 $13) $14) $4 $5))) -; + (= (traverse-conj $3 $4 $5 $6 $7 $8) + (varset $3 $24) + (functor $3 $15 $16) + (table-command + (get + (/ $15 $16) $17) $5 $25) + (get-entry-modes uninit $3 $17 $26) + (get-entry-modes ground $3 $17 $27) + (traverse-conj $4 $25 $6 $7 $8 $27 $28 $26 $29 $24 $30)) + + (= (traverse_conj true $4 $4 $6 $6 $8 $8 $10 $10 $12 $12) True) + (= (traverse-conj (, $20 $21) $4 $5 $6 $7 $8 $9 $10 $11 $12 $13) + (varset $20 $32) + (update-goal $20 $32 $4 $33 $6 $34 $8 $35 $10 $36 $12 $37) + (unionv $32 $37 $38) + (traverse-conj $21 $33 $5 $34 $7 $35 $9 $36 $11 $38 $13)) + + + (= (update-goal $3 $4 $5 $5 $7 $7 $9 $10 $11 $12 $13 $13) + (split-unify $3 $21 $27) + (var $21) + (nonvar $27) + (varset $27 $28) + (subsetv $28 $9) + (set-det) + (set-command + (add $21) $9 $10) + (set-command + (sub $21) $11 $12)) + (= (update-goal $3 $4 $5 $5 $7 $7 $9 $9 $11 $12 $13 $13) + (split-unify $3 $21 $30) + (var $21) + (nonvar $30) + (inv $21 $11) + (set-det) + (diffv $4 $13 $31) + (diffv $31 $9 $22) + (set-command + (add-set $22) $11 $32) + (set-command + (sub $21) $32 $33) + (intersectv $4 $13 $23) + (set-command + (sub-set $23) $33 $12)) + (= (update-goal $3 $4 $5 $5 $7 $7 $9 $10 $11 $12 $13 $13) + (split-unify $3 $27 $28) + (var $27) + (inv $27 $9) + (set-det) + (set-command + (add-set $4) $9 $10) + (set-command + (sub-set $4) $11 $12)) + (= (update-goal $3 $4 $5 $5 $7 $7 $9 $9 $11 $12 $13 $13) + (unify-p $3) + (set-det) + (set-command + (sub-set $4) $11 $12)) + (= (update-goal $3 $4 $5 $6 $7 $8 $9 $9 $11 $12 $13 $13) + (call-p $3) + (set-det) + (goal-dupset $3 $33) + (var-args $3 $34) + (functor $3 $22 $23) + (functor $35 $22 $23) + (create-new-call 1 $23 $9 $34 $33 $11 $13 $3 $35) + (update-table + (/ $22 $23) $35 $5 $6 $7 $8) + (set-command + (sub-set $4) $11 $12)) - (= - (init-goal $3 $4 $4) - ( (unify-p $3) (set-det))) -; + (= (update-table (/ $15 $16) $4 $5 $6 $7 $8) + (table-command + (get + (/ $15 $16) $18) $5 $24) + (lub-call $18 $4 $19) + (\== $18 $19) + (set-det) + (table-command + (set + (/ $15 $16) $19) $24 $6) + (is $8 + (+ $7 1))) + (= (update_table (/ $15 $16) $4 $5 $5 $7 $7) True) -; -; - - - - (= - (traverse_strees () $4 $4 $6 $6) True) -; - - (= - (traverse-strees - (Cons $14 $15) $4 $5 $6 $7) - ( (= $14 - (stree $16 - (= $17 $18) $19 $20 $21)) - (traverse-disj $17 $18 $4 $26 $6 $27) - (traverse-strees $20 $26 $28 $27 $29) - (traverse-strees $15 $28 $5 $29 $7))) -; - - - - (= - (traverse_disj $3 fail $5 $5 $7 $7) True) -; - - (= - (traverse-disj $3 - (or $15 $16) $5 $6 $7 $8) - ( (traverse-conj $3 $15 $5 $22 $7 $23) (traverse-disj $3 $16 $22 $6 $23 $8))) -; - - - - (= - (traverse-conj $3 $4 $5 $6 $7 $8) - ( (varset $3 $24) - (functor $3 $15 $16) - (table-command - (get - (/ $15 $16) $17) $5 $25) - (get-entry-modes uninit $3 $17 $26) - (get-entry-modes ground $3 $17 $27) - (traverse-conj $4 $25 $6 $7 $8 $27 $28 $26 $29 $24 $30))) -; - - - (= - (traverse_conj true $4 $4 $6 $6 $8 $8 $10 $10 $12 $12) True) -; - - (= - (traverse-conj - (, $20 $21) $4 $5 $6 $7 $8 $9 $10 $11 $12 $13) - ( (varset $20 $32) - (update-goal $20 $32 $4 $33 $6 $34 $8 $35 $10 $36 $12 $37) - (unionv $32 $37 $38) - (traverse-conj $21 $33 $5 $34 $7 $35 $9 $36 $11 $38 $13))) -; - - - - (= - (update-goal $3 $4 $5 $5 $7 $7 $9 $10 $11 $12 $13 $13) - ( (split-unify $3 $21 $27) - (var $21) - (nonvar $27) - (varset $27 $28) - (subsetv $28 $9) - (set-det) - (set-command - (add $21) $9 $10) - (set-command - (sub $21) $11 $12))) -; - - (= - (update-goal $3 $4 $5 $5 $7 $7 $9 $9 $11 $12 $13 $13) - ( (split-unify $3 $21 $30) - (var $21) - (nonvar $30) - (inv $21 $11) - (set-det) - (diffv $4 $13 $31) - (diffv $31 $9 $22) - (set-command - (add-set $22) $11 $32) - (set-command - (sub $21) $32 $33) - (intersectv $4 $13 $23) - (set-command - (sub-set $23) $33 $12))) -; - - (= - (update-goal $3 $4 $5 $5 $7 $7 $9 $10 $11 $12 $13 $13) - ( (split-unify $3 $27 $28) - (var $27) - (inv $27 $9) - (set-det) - (set-command - (add-set $4) $9 $10) - (set-command - (sub-set $4) $11 $12))) -; - - (= - (update-goal $3 $4 $5 $5 $7 $7 $9 $9 $11 $12 $13 $13) - ( (unify-p $3) - (set-det) - (set-command - (sub-set $4) $11 $12))) -; - - (= - (update-goal $3 $4 $5 $6 $7 $8 $9 $9 $11 $12 $13 $13) - ( (call-p $3) - (set-det) - (goal-dupset $3 $33) - (var-args $3 $34) - (functor $3 $22 $23) - (functor $35 $22 $23) - (create-new-call 1 $23 $9 $34 $33 $11 $13 $3 $35) - (update-table - (/ $22 $23) $35 $5 $6 $7 $8) - (set-command - (sub-set $4) $11 $12))) -; - - - - (= - (update-table - (/ $15 $16) $4 $5 $6 $7 $8) - ( (table-command - (get - (/ $15 $16) $18) $5 $24) - (lub-call $18 $4 $19) - (\== $18 $19) - (set-det) - (table-command - (set - (/ $15 $16) $19) $24 $6) - (is $8 - (+ $7 1)))) -; - - (= - (update_table - (/ $15 $16) $4 $5 $5 $7 $7) True) -; - - - - (= - (create-new-call $I $Ar $_ $_ $_ $_ $_ $_ $_) - ( (> $I $Ar) (set-det))) -; - - (= - (create-new-call $I $Ar $Gnd $VarArgs $DupVars $Uni $SoFar $Goal $Call) - ( (=< $I $Ar) - (set-det) - (arg $I $Goal $X) - (arg $I $Call $Y) - (ground-flag $X $Gnd $Gf) - (membership-flag $X $VarArgs $Vf) - (membership-flag $X $DupVars $Df) - (membership-flag $X $Uni $Uf) - (membership-flag $X $SoFar $Sf) - (create-argument $Gf $Vf $Df $Uf $Sf $Y) - (is $I1 - (+ $I 1)) - (create-new-call $I1 $Ar $Gnd $VarArgs $DupVars $Uni $SoFar $Goal $Call))) -; + (= (create-new-call $I $Ar $_ $_ $_ $_ $_ $_ $_) + (> $I $Ar) + (set-det)) + (= (create-new-call $I $Ar $Gnd $VarArgs $DupVars $Uni $SoFar $Goal $Call) + (=< $I $Ar) + (set-det) + (arg $I $Goal $X) + (arg $I $Call $Y) + (ground-flag $X $Gnd $Gf) + (membership-flag $X $VarArgs $Vf) + (membership-flag $X $DupVars $Df) + (membership-flag $X $Uni $Uf) + (membership-flag $X $SoFar $Sf) + (create-argument $Gf $Vf $Df $Uf $Sf $Y) + (is $I1 + (+ $I 1)) + (create-new-call $I1 $Ar $Gnd $VarArgs $DupVars $Uni $SoFar $Goal $Call)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; +; Lattice utilities: - - (= - (lub unknown $X $X) + (= (lub unknown $X $X) (set-det)) -; - - (= - (lub $X unknown $X) + (= (lub $X unknown $X) (set-det)) -; - - (= - (lub any $_ any) + (= (lub any $_ any) (set-det)) -; - - (= - (lub $_ any any) + (= (lub $_ any any) (set-det)) -; - - (= - (lub uninit uninit uninit) + (= (lub uninit uninit uninit) (set-det)) -; - - (= - (lub ground ground ground) + (= (lub ground ground ground) (set-det)) -; - - (= - (lub uninit ground any) + (= (lub uninit ground any) (set-det)) -; - - (= - (lub ground uninit any) + (= (lub ground uninit any) (set-det)) -; - - - - (= - (bottom unknown) True) -; - - (= - (create-argument yes $_ $_ $_ $_ ground) + (= (bottom unknown) True) + + + (= (create-argument yes $_ $_ $_ $_ ground) + (set-det)) ; +; Ground argument. + (= (create-argument no yes no yes $_ uninit) + (set-det)) ; +; Non-duplicated uninit. + (= (create-argument no yes no $_ no uninit) + (set-det)) ; +; First occurrence. + (= (create-argument no yes $_ no yes any) + (set-det)) ; +; Already initialized. + (= (create-argument no yes yes $_ $_ any) + (set-det)) ; +; Duplicated argument. + (= (create-argument no no $_ $_ $_ any) + (set-det)) ; +; Non-variable argument. + + + (= (lub-call $Call1 $Call2 $Lub) + (functor $Call1 $Na $Ar) + (functor $Call2 $Na $Ar) + (functor $Lub $Na $Ar) + (lub-call 1 $Ar $Call1 $Call2 $Lub)) + + (= (lub-call $I $Ar $_ $_ $_) + (> $I $Ar) (set-det)) -; - ; -; - - (= - (create-argument no yes no yes $_ uninit) + (= (lub-call $I $Ar $Call1 $Call2 $Lub) + (=< $I $Ar) + (set-det) + (arg $I $Call1 $X1) + (arg $I $Call2 $X2) + (arg $I $Lub $X) + (lub $X1 $X2 $X) + (is $I1 + (+ $I 1)) + (lub-call $I1 $Ar $Call1 $Call2 $Lub)) + + + (= (bottom-call (/ $Na $Ar) $Bottom) + (functor $Bottom $Na $Ar) + (bottom-call 1 $Ar $Bottom)) + + (= (bottom-call $I $Ar $Bottom) + (> $I $Ar) (set-det)) -; - ; -; - - (= - (create-argument no yes no $_ no uninit) + (= (bottom-call $I $Ar $Bottom) + (=< $I $Ar) + (set-det) + (bottom $B) + (arg $I $Bottom $B) + (is $I1 + (+ $I 1)) + (bottom-call $I1 $Ar $Bottom)) + + + (= (lattice-modes-call (/ $Na $Ar) $Table (= $Head $Formula)) + (functor $Head $Na $Ar) + (get $Table + (/ $Na $Ar) $Value) + (lattice-modes-call 1 $Ar $Value $Head $Formula True)) + + (= (lattice-modes-call $I $Ar $_ $_ $Link $Link) + (> $I $Ar) (set-det)) -; - ; -; - - (= - (create-argument no yes $_ no yes any) + (= (lattice-modes-call $I $Ar $Value $Head $Formula $Link) + (=< $I $Ar) + (set-det) + (arg $I $Value $T) + (arg $I $Head $X) + (lattice-modes-arg $T $X $Formula $Mid) + (is $I1 + (+ $I 1)) + (lattice-modes-call $I1 $Ar $Value $Head $Mid $Link)) + + + (= (lattice-modes-arg uninit $X (, (uninit $X) $Link) $Link) (set-det)) -; - ; -; - - (= - (create-argument no yes yes $_ $_ any) + (= (lattice-modes-arg ground $X (, (ground $X) $Link) $Link) (set-det)) -; - ; -; - - (= - (create-argument no no $_ $_ $_ any) - (set-det)) -; - ; -; - - - - (= - (lub-call $Call1 $Call2 $Lub) - ( (functor $Call1 $Na $Ar) - (functor $Call2 $Na $Ar) - (functor $Lub $Na $Ar) - (lub-call 1 $Ar $Call1 $Call2 $Lub))) -; - - - (= - (lub-call $I $Ar $_ $_ $_) - ( (> $I $Ar) (set-det))) -; - - (= - (lub-call $I $Ar $Call1 $Call2 $Lub) - ( (=< $I $Ar) - (set-det) - (arg $I $Call1 $X1) - (arg $I $Call2 $X2) - (arg $I $Lub $X) - (lub $X1 $X2 $X) - (is $I1 - (+ $I 1)) - (lub-call $I1 $Ar $Call1 $Call2 $Lub))) -; - - - - (= - (bottom-call - (/ $Na $Ar) $Bottom) - ( (functor $Bottom $Na $Ar) (bottom-call 1 $Ar $Bottom))) -; - - - (= - (bottom-call $I $Ar $Bottom) - ( (> $I $Ar) (set-det))) -; - - (= - (bottom-call $I $Ar $Bottom) - ( (=< $I $Ar) - (set-det) - (bottom $B) - (arg $I $Bottom $B) - (is $I1 - (+ $I 1)) - (bottom-call $I1 $Ar $Bottom))) -; - - - - (= - (lattice-modes-call - (/ $Na $Ar) $Table - (= $Head $Formula)) - ( (functor $Head $Na $Ar) - (get $Table - (/ $Na $Ar) $Value) - (lattice-modes-call 1 $Ar $Value $Head $Formula True))) -; - - - (= - (lattice-modes-call $I $Ar $_ $_ $Link $Link) - ( (> $I $Ar) (set-det))) -; - - (= - (lattice-modes-call $I $Ar $Value $Head $Formula $Link) - ( (=< $I $Ar) - (set-det) - (arg $I $Value $T) - (arg $I $Head $X) - (lattice-modes-arg $T $X $Formula $Mid) - (is $I1 - (+ $I 1)) - (lattice-modes-call $I1 $Ar $Value $Head $Mid $Link))) -; - - - - (= - (lattice-modes-arg uninit $X - (, - (uninit $X) $Link) $Link) - (set-det)) -; - - (= - (lattice-modes-arg ground $X - (, - (ground $X) $Link) $Link) - (set-det)) -; - - (= - (lattice_modes_arg $Other $X $Link $Link) True) -; - + (= (lattice_modes_arg $Other $X $Link $Link) True) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Table utilities: ; -; - +; This code implements a mutable array, represented as a binary tree. ; -; - +; Access a value in logarithmic time and constant space: ; -; +; This predicate can be used to create the array incrementally. - - (= - (get - (node $N $W $L $R) $I $V) + (= (get (node $N $W $L $R) $I $V) (get $N $W $L $R $I $V)) -; - - - (= - (get $N $V $_ $_ $I $V) - ( (= $I $N) (set-det))) -; - - (= - (get $N $_ $L $R $I $V) - ( (compare $Order $I $N) (get $Order $I $V $L $R))) -; + (= (get $N $V $_ $_ $I $V) + (= $I $N) + (set-det)) + (= (get $N $_ $L $R $I $V) + (compare $Order $I $N) + (get $Order $I $V $L $R)) - (= - (get < $I $V $L $_) + (= (get < $I $V $L $_) (get $L $I $V)) -; - - (= - (get > $I $V $_ $R) + (= (get > $I $V $_ $R) (get $R $I $V)) -; - - - (= - (set leaf $I $V - (node $I $V leaf leaf)) True) -; - (= - (set - (node $N $W $L $R) $I $V - (node $N $NW $NL $NR)) - ( (compare $Order $I $N) (set-2 $Order $I $V $W $L $R $NW $NL $NR))) -; + (= (set leaf $I $V (node $I $V leaf leaf)) True) + (= (set (node $N $W $L $R) $I $V (node $N $NW $NL $NR)) + (compare $Order $I $N) + (set-2 $Order $I $V $W $L $R $NW $NL $NR)) - - (= - (set-2 < $I $V $W $L $R $W $NL $R) + (= (set-2 < $I $V $W $L $R $W $NL $R) (set $L $I $V $NL)) -; - - (= - (set_2 = $I $V $_ $L $R $V $L $R) True) -; - - (= - (set-2 > $I $V $W $L $R $W $L $NR) + (= (set_2 = $I $V $_ $L $R $V $L $R) True) + (= (set-2 > $I $V $W $L $R $W $L $NR) (set $R $I $V $NR)) -; - ; -; - - - (= - (seal leaf) True) -; - - (= - (seal (node $_ $_ $L $R)) - ( (seal $L) (seal $R))) -; +; Prevent any further insertions in the array: + (= (seal leaf) True) + (= (seal (node $_ $_ $L $R)) + (seal $L) + (seal $R)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - - - - (= - (membership-flag $X $Set yes) - ( (inv $X $Set) (set-det))) -; - - (= - (membership_flag $X $Set no) True) -; - - - - (= - (ground-flag $X $Ground yes) - ( (varset $X $Set) - (subsetv $Set $Ground) - (set-det))) -; - - (= - (ground_flag $X $Ground no) True) -; - +; General utilities: - (= - (get-entry-modes $Type $Head $Value $TypeSet) - ( (functor $Head $Na $Ar) - (get-entry-modes $Type 1 $Ar $Head $Value $Bag) - (sort $Bag $TypeSet))) -; + (= (membership-flag $X $Set yes) + (inv $X $Set) + (set-det)) + (= (membership_flag $X $Set no) True) - (= - (get-entry-modes $_ $I $Ar $_ $_ Nil) - ( (> $I $Ar) (set-det))) -; + (= (ground-flag $X $Ground yes) + (varset $X $Set) + (subsetv $Set $Ground) + (set-det)) + (= (ground_flag $X $Ground no) True) - (= - (get-entry-modes $T $I $Ar $Head $Value - (Cons $X $Bag)) - ( (=< $I $Ar) - (arg $I $Value $T) - (set-det) - (arg $I $Head $X) - (is $I1 - (+ $I 1)) - (get-entry-modes $T $I1 $Ar $Head $Value $Bag))) -; - (= - (get-entry-modes $T $I $Ar $Head $Value $Bag) - ( (=< $I $Ar) - (set-det) - (is $I1 - (+ $I 1)) - (get-entry-modes $T $I1 $Ar $Head $Value $Bag))) -; + (= (get-entry-modes $Type $Head $Value $TypeSet) + (functor $Head $Na $Ar) + (get-entry-modes $Type 1 $Ar $Head $Value $Bag) + (sort $Bag $TypeSet)) + (= (get-entry-modes $_ $I $Ar $_ $_ Nil) + (> $I $Ar) + (set-det)) + (= (get-entry-modes $T $I $Ar $Head $Value (Cons $X $Bag)) + (=< $I $Ar) + (arg $I $Value $T) + (set-det) + (arg $I $Head $X) + (is $I1 + (+ $I 1)) + (get-entry-modes $T $I1 $Ar $Head $Value $Bag)) + (= (get-entry-modes $T $I $Ar $Head $Value $Bag) + (=< $I $Ar) + (set-det) + (is $I1 + (+ $I 1)) + (get-entry-modes $T $I1 $Ar $Head $Value $Bag)) + + + (= (var-args $Goal $Set) + (functor $Goal $_ $Ar) + (filter-vars $Ar $Goal $Bag) + (sort $Bag $Set)) + + + (= (filter-vars $Ar $Goal $Vs) + (filter-vars $Ar $Goal $Vs Nil)) - (= - (var-args $Goal $Set) - ( (functor $Goal $_ $Ar) - (filter-vars $Ar $Goal $Bag) - (sort $Bag $Set))) -; + (= (--> (filter_vars $N $Goal) (, {(=< $N 0) } !)) True) + (= (--> (filter_vars $N $Goal) (, {(> $N 0) } (, ! (, {(arg $N $Goal $V) } (filter_vars_arg $N $Goal $V))))) True) + (= (--> (filter_vars_arg $N $Goal $V) (, {(var $V) } (, ! (, ($V) (, {(is $N1 (- $N 1)) } (filter_vars $N1 $Goal)))))) True) + (= (--> (filter_vars_arg $N $Goal $V) (, {(nonvar $V) } (, ! (, {(is $N1 (- $N 1)) } (filter_vars $N1 $Goal))))) True) - (= - (filter-vars $Ar $Goal $Vs) - (filter-vars $Ar $Goal $Vs Nil)) -; - - - - (= - (--> - (filter_vars $N $Goal) - (, - { (=< $N 0) } !)) True) -; - - (= - (--> - (filter_vars $N $Goal) - (, - { (> $N 0) } - (, ! - (, - { (arg $N $Goal $V) } - (filter_vars_arg $N $Goal $V))))) True) -; - - - (= - (--> - (filter_vars_arg $N $Goal $V) - (, - { (var $V) } - (, ! - (, - ($V) - (, - { (is $N1 - (- $N 1)) } - (filter_vars $N1 $Goal)))))) True) -; - - (= - (--> - (filter_vars_arg $N $Goal $V) - (, - { (nonvar $V) } - (, ! - (, - { (is $N1 - (- $N 1)) } - (filter_vars $N1 $Goal))))) True) -; - - - - (= - (goal-dupset $Goal $DupSet) + (= (goal-dupset $Goal $DupSet) (goal-dupset-varbag $Goal $DupSet $_)) -; - - (= - (goal-dupset-varset $Goal $DupSet $VarSet) - ( (goal-dupset-varbag $Goal $DupSet $VarBag) (sort $VarBag $VarSet))) -; + (= (goal-dupset-varset $Goal $DupSet $VarSet) + (goal-dupset-varbag $Goal $DupSet $VarBag) + (sort $VarBag $VarSet)) + (= (goal-dupset-varbag $Goal $DupSet $VarBag) + (varbag $Goal $VarBag) + (make-key $VarBag $KeyBag) + (keysort $KeyBag $KeySet) + (filter-dups $KeySet $DupSet)) - (= - (goal-dupset-varbag $Goal $DupSet $VarBag) - ( (varbag $Goal $VarBag) - (make-key $VarBag $KeyBag) - (keysort $KeyBag $KeySet) - (filter-dups $KeySet $DupSet))) -; - - - (= - (make_key () ()) True) -; - - (= - (make-key - (Cons $V $Bag) - (Cons - (- $V dummy) $KeyBag)) + (= (make_key () ()) True) + (= (make-key (Cons $V $Bag) (Cons (- $V dummy) $KeyBag)) (make-key $Bag $KeyBag)) -; - - (= - (filter-dups $KeySet $Set) + (= (filter-dups $KeySet $Set) (filter-dups $KeySet $Set Nil)) -; - - - - (= - (--> - (filter_dups ()) !) True) -; - - (= - (--> - (filter_dups - (Cons - (- $V1 $_) - (Cons - (- $V2 $_) - (Cons - (- $V3 $_) $KeySet)))) - (, - { (, - (== $V1 $V2) - (== $V2 $V3)) } - (, ! - (filter_dups - (Cons - (- $V2 $_) - (Cons - (- $V3 $_) $KeySet)))))) True) -; - - (= - (--> - (filter_dups - (Cons - (- $V1 $_) - (Cons - (- $V2 $_) $KeySet))) - (, - { (== $V1 $V2) } - (, ! - (, - ($V1) - (filter_dups $KeySet))))) True) -; - - (= - (--> - (filter_dups - (Cons - (- $V1 $_) $KeySet)) - (, ! - (filter_dups $KeySet))) True) -; - -; -; + (= (--> (filter_dups ()) !) True) + (= (--> (filter_dups (Cons (- $V1 $_) (Cons (- $V2 $_) (Cons (- $V3 $_) $KeySet)))) (, {(, (== $V1 $V2) (== $V2 $V3)) } (, ! (filter_dups (Cons (- $V2 $_) (Cons (- $V3 $_) $KeySet)))))) True) + (= (--> (filter_dups (Cons (- $V1 $_) (Cons (- $V2 $_) $KeySet))) (, {(== $V1 $V2) } (, ! (, ($V1) (filter_dups $KeySet))))) True) + (= (--> (filter_dups (Cons (- $V1 $_) $KeySet)) (, ! (filter_dups $KeySet))) True) ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Low-level utilities: - (= - (set-command - (sub $X) $In $Out) + (= (set-command (sub $X) $In $Out) (diffv $In (:: $X) $Out)) -; - - (= - (set-command - (add $X) $In $Out) + (= (set-command (add $X) $In $Out) (includev $X $In $Out)) -; - - (= - (set-command - (sub-set $X) $In $Out) + (= (set-command (sub-set $X) $In $Out) (diffv $In $X $Out)) -; - - (= - (set-command - (add-set $X) $In $Out) + (= (set-command (add-set $X) $In $Out) (unionv $X $In $Out)) -; - - (= - (table-command - (get $I $Val) $In $In) + (= (table-command (get $I $Val) $In $In) (get $In $I $Val)) -; - - (= - (table-command - (set $I $Val) $In $Out) + (= (table-command (set $I $Val) $In $Out) (set $In $I $Val $Out)) -; - ; -; - - - (= - (inv $A - (Cons $B $S)) - ( (compare $Order $A $B) (inv-2 $Order $A $S))) -; - +; Set utilities inspired by R. O'Keefe in Practical MeTTa: + (= (inv $A (Cons $B $S)) + (compare $Order $A $B) + (inv-2 $Order $A $S)) - (= - (inv_2 = $_ $_) True) -; - (= - (inv-2 > $A $S) + (= (inv_2 = $_ $_) True) + (= (inv-2 > $A $S) (inv $A $S)) -; - - (= - (intersectv () $_ ()) True) -; - - (= - (intersectv - (Cons $A $S1) $S2 $S) + (= (intersectv () $_ ()) True) + (= (intersectv (Cons $A $S1) $S2 $S) (intersectv-2 $S2 $A $S1 $S)) -; - - (= - (intersectv_2 () $A $S1 ()) True) -; + (= (intersectv_2 () $A $S1 ()) True) + (= (intersectv-2 (Cons $B $S2) $A $S1 $S) + (compare $Order $A $B) + (intersectv-3 $Order $A $S1 $B $S2 $S)) - (= - (intersectv-2 - (Cons $B $S2) $A $S1 $S) - ( (compare $Order $A $B) (intersectv-3 $Order $A $S1 $B $S2 $S))) -; - - - (= - (intersectv-3 < $A $S1 $B $S2 $S) + (= (intersectv-3 < $A $S1 $B $S2 $S) (intersectv-2 $S1 $B $S2 $S)) -; - - (= - (intersectv-3 = $A $S1 $_ $S2 - (Cons $A $S)) + (= (intersectv-3 = $A $S1 $_ $S2 (Cons $A $S)) (intersectv $S1 $S2 $S)) -; - - (= - (intersectv-3 > $A $S1 $B $S2 $S) + (= (intersectv-3 > $A $S1 $B $S2 $S) (intersectv-2 $S2 $A $S1 $S)) -; - - - (= - (diffv () $_ ()) True) -; - (= - (diffv - (Cons $A $S1) $S2 $S) + (= (diffv () $_ ()) True) + (= (diffv (Cons $A $S1) $S2 $S) (diffv-2 $S2 $A $S1 $S)) -; - - - - (= - (diffv_2 () $A $S1 - ($A)) True) -; - (= - (diffv-2 - (Cons $B $S2) $A $S1 $S) - ( (compare $Order $A $B) (diffv-3 $Order $A $S1 $B $S2 $S))) -; + (= (diffv_2 () $A $S1 ($A)) True) + (= (diffv-2 (Cons $B $S2) $A $S1 $S) + (compare $Order $A $B) + (diffv-3 $Order $A $S1 $B $S2 $S)) - (= - (diffv-3 < $A $S1 $B $S2 - (Cons $A $S)) + (= (diffv-3 < $A $S1 $B $S2 (Cons $A $S)) (diffv $S1 (Cons $B $S2) $S)) -; - - (= - (diffv-3 = $A $S1 $_ $S2 $S) + (= (diffv-3 = $A $S1 $_ $S2 $S) (diffv $S1 $S2 $S)) -; - - (= - (diffv-3 > $A $S1 $_ $S2 $S) + (= (diffv-3 > $A $S1 $_ $S2 $S) (diffv-2 $S2 $A $S1 $S)) -; - - (= - (unionv () $S2 $S2) True) -; - - (= - (unionv - (Cons $A $S1) $S2 $S) + (= (unionv () $S2 $S2) True) + (= (unionv (Cons $A $S1) $S2 $S) (unionv-2 $S2 $A $S1 $S)) -; - - (= - (unionv_2 () $A $S1 - (Cons $A $S1)) True) -; + (= (unionv_2 () $A $S1 (Cons $A $S1)) True) + (= (unionv-2 (Cons $B $S2) $A $S1 $S) + (compare $Order $A $B) + (unionv-3 $Order $A $S1 $B $S2 $S)) - (= - (unionv-2 - (Cons $B $S2) $A $S1 $S) - ( (compare $Order $A $B) (unionv-3 $Order $A $S1 $B $S2 $S))) -; - - - (= - (unionv-3 < $A $S1 $B $S2 - (Cons $A $S)) + (= (unionv-3 < $A $S1 $B $S2 (Cons $A $S)) (unionv-2 $S1 $B $S2 $S)) -; - - (= - (unionv-3 = $A $S1 $_ $S2 - (Cons $A $S)) + (= (unionv-3 = $A $S1 $_ $S2 (Cons $A $S)) (unionv $S1 $S2 $S)) -; - - (= - (unionv-3 > $A $S1 $B $S2 - (Cons $B $S)) + (= (unionv-3 > $A $S1 $B $S2 (Cons $B $S)) (unionv-2 $S2 $A $S1 $S)) -; - - (= - (includev $A $S1 $S) + (= (includev $A $S1 $S) (includev-2 $S1 $A $S)) -; - - (= - (includev_2 () $A - ($A)) True) -; + (= (includev_2 () $A ($A)) True) + (= (includev-2 (Cons $B $S1) $A $S) + (compare $Order $A $B) + (includev-3 $Order $A $B $S1 $S)) - (= - (includev-2 - (Cons $B $S1) $A $S) - ( (compare $Order $A $B) (includev-3 $Order $A $B $S1 $S))) -; - - - (= - (includev_3 < $A $B $S1 - (Cons $A - (Cons $B $S1))) True) -; - - (= - (includev_3 = $_ $B $S1 - (Cons $B $S1)) True) -; - - (= - (includev-3 > $A $B $S1 - (Cons $B $S)) + (= (includev_3 < $A $B $S1 (Cons $A (Cons $B $S1))) True) + (= (includev_3 = $_ $B $S1 (Cons $B $S1)) True) + (= (includev-3 > $A $B $S1 (Cons $B $S)) (includev-2 $S1 $A $S)) -; - - (= - (subsetv () $_) True) -; - - (= - (subsetv - (Cons $A $S1) - (Cons $B $S2)) - ( (compare $Order $A $B) (subsetv-2 $Order $A $S1 $S2))) -; - + (= (subsetv () $_) True) + (= (subsetv (Cons $A $S1) (Cons $B $S2)) + (compare $Order $A $B) + (subsetv-2 $Order $A $S1 $S2)) - (= - (subsetv-2 = $A $S1 $S2) + (= (subsetv-2 = $A $S1 $S2) (subsetv $S1 $S2)) -; - - (= - (subsetv-2 > $A $S1 $S2) + (= (subsetv-2 > $A $S1 $S2) (subsetv (Cons $A $S1) $S2)) -; + (= (varset $Term $VarSet) + (varbag $Term $VB) + (sort $VB $VarSet)) - (= - (varset $Term $VarSet) - ( (varbag $Term $VB) (sort $VB $VarSet))) -; + (= (varbag $Term $VarBag) + (varbag $Term $VarBag Nil)) - (= - (varbag $Term $VarBag) - (varbag $Term $VarBag Nil)) -; - - - - (= - (--> - (varbag $Var) - (, - { (var $Var) } - (, ! - ($Var)))) True) -; - - (= - (--> - (varbag $Str) - (, - { (, - (nonvar $Str) - (, ! - (functor $Str $_ $Arity))) } - (varbag $Str 1 $Arity))) True) -; - - - (= - (--> - (varbag $Str $N $Arity) - (, - { (> $N $Arity) } !)) True) -; - - (= - (--> - (varbag $Str $N $Arity) - (, - { (=< $N $Arity) } - (, ! - (, - { (arg $N $Str $Arg) } - (, - (varbag $Arg) - (, - { (is $N1 - (+ $N 1)) } - (varbag $Str $N1 $Arity))))))) True) -; - - - - (= - (unify_p - (= $_ $_)) True) -; - - - - (= - (call-p $G) - (not (unify-p $G))) -; + (= (--> (varbag $Var) (, {(var $Var) } (, ! ($Var)))) True) + (= (--> (varbag $Str) (, {(, (nonvar $Str) (, ! (functor $Str $_ $Arity))) } (varbag $Str 1 $Arity))) True) + (= (--> (varbag $Str $N $Arity) (, {(> $N $Arity) } !)) True) + (= (--> (varbag $Str $N $Arity) (, {(=< $N $Arity) } (, ! (, {(arg $N $Str $Arg) } (, (varbag $Arg) (, {(is $N1 (+ $N 1)) } (varbag $Str $N1 $Arity))))))) True) - (= - (split_unify - (= $X $Y) $X $Y) True) -; + (= (unify_p (= $_ $_)) True) - (= - (split_unify - (= $Y $X) $X $Y) True) -; + (= (call-p $G) + (not (unify-p $G))) -; -; + (= (split_unify (= $X $Y) $X $Y) True) + (= (split_unify (= $Y $X) $X $Y) True) + +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/sxx_machine/bench/tak.metta b/sxx_machine/bench/tak.metta index 148fe95..df8f06c 100644 --- a/sxx_machine/bench/tak.metta +++ b/sxx_machine/bench/tak.metta @@ -1,60 +1,42 @@ +; (convert_to_metta_file tak $_342136 sxx_machine/bench/tak.pl sxx_machine/bench/tak.metta) ; -; - +; generated: 17 November 1989 ; -; - +; option(s): SOURCE_TRANSFORM_1 ; ; - ; -; - +; tak ; ; - ; -; - +; Evan Tick (from Lisp version by R. P. Gabriel) ; ; - ; -; - +; (almost) Takeuchi function (recursive arithmetic) - (= - (top) + (= (top) (tak)) -; - - (= - (tak) + (= (tak) (tak 18 12 6 $_)) -; - - - (= - (tak $X $Y $Z $A) - ( (=< $X $Y) (= $Z $A))) -; - - (= - (tak $X $Y $Z $A) - ( (> $X $Y) - (is $X1 - (- $X 1)) - (tak $X1 $Y $Z $A1) - (is $Y1 - (- $Y 1)) - (tak $Y1 $Z $X $A2) - (is $Z1 - (- $Z 1)) - (tak $Z1 $X $Y $A3) - (tak $A1 $A2 $A3 $A))) -; + (= (tak $X $Y $Z $A) + (=< $X $Y) + (= $Z $A)) + (= (tak $X $Y $Z $A) + (> $X $Y) + (is $X1 + (- $X 1)) + (tak $X1 $Y $Z $A1) + (is $Y1 + (- $Y 1)) + (tak $Y1 $Z $X $A2) + (is $Z1 + (- $Z 1)) + (tak $Z1 $X $Y $A3) + (tak $A1 $A2 $A3 $A)) diff --git a/sxx_machine/bench/times10.metta b/sxx_machine/bench/times10.metta index 6d9616a..3ef406a 100644 --- a/sxx_machine/bench/times10.metta +++ b/sxx_machine/bench/times10.metta @@ -1,38 +1,27 @@ +; (convert_to_metta_file times10 $_409734 sxx_machine/bench/times10.pl sxx_machine/bench/times10.metta) ; -; - +; generated: 7 March 1990 ; -; - +; option(s): ; ; - ; -; - +; (deriv) times10 ; ; - ; -; - +; David H. D. Warren ; ; - ; -; +; symbolic derivative of ((((((((x*x)*x)*x)*x)*x)*x)*x)*x)*x - - (= - (top) + (= (top) (times10)) -; - - (= - (times10) + (= (times10) (d (* (* @@ -43,94 +32,40 @@ (* (* (* x x) x) x) x) x) x) x) x) x) x $_)) -; - - - (= - (d - (+ $U $V) $X - (+ $DU $DV)) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - - (= - (d - (- $U $V) $X - (- $DU $DV)) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - (= - (d - (* $U $V) $X - (+ - (* $DU $V) - (* $U $DV))) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - - (= - (d - (/ $U $V) $X - (/ - (- - (* $DU $V) - (* $U $DV)) - (^ $V 2))) - ( (set-det) - (d $U $X $DU) - (d $V $X $DV))) -; - - (= - (d - (^ $U $N) $X - (* - (* $DU $N) - (^ $U $N1))) - ( (set-det) - (integer $N) - (is $N1 - (- $N 1)) - (d $U $X $DU))) -; - - (= - (d - (- $U) $X - (- $DU)) - ( (set-det) (d $U $X $DU))) -; - - (= - (d - (exp $U) $X - (* - (exp $U) $DU)) - ( (set-det) (d $U $X $DU))) -; - - (= - (d - (log $U) $X - (/ $DU $U)) - ( (set-det) (d $U $X $DU))) -; - - (= - (d $X $X 1) + (= (d (+ $U $V) $X (+ $DU $DV)) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (- $U $V) $X (- $DU $DV)) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (* $U $V) $X (+ (* $DU $V) (* $U $DV))) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (/ $U $V) $X (/ (- (* $DU $V) (* $U $DV)) (^ $V 2))) + (set-det) + (d $U $X $DU) + (d $V $X $DV)) + (= (d (^ $U $N) $X (* (* $DU $N) (^ $U $N1))) + (set-det) + (integer $N) + (is $N1 + (- $N 1)) + (d $U $X $DU)) + (= (d (- $U) $X (- $DU)) + (set-det) + (d $U $X $DU)) + (= (d (exp $U) $X (* (exp $U) $DU)) + (set-det) + (d $U $X $DU)) + (= (d (log $U) $X (/ $DU $U)) + (set-det) + (d $U $X $DU)) + (= (d $X $X 1) (set-det)) -; - - (= - (d $_ $_ 0) True) -; - + (= (d $_ $_ 0) True) diff --git a/sxx_machine/bench/unify.metta b/sxx_machine/bench/unify.metta index 5fd5941..dc04e2d 100644 --- a/sxx_machine/bench/unify.metta +++ b/sxx_machine/bench/unify.metta @@ -1,747 +1,199 @@ +; (convert_to_metta_file unify $_501894 sxx_machine/bench/unify.pl sxx_machine/bench/unify.metta) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Copyright (C) 1990 Regents of the University of California. ; -; - +; All rights reserved. This program may be freely used and modified for ; -; - +; non-commercial purposes provided this copyright notice is kept unchanged. ; -; - +; Written by Peter Van Roy as a part of the Aquarius project. ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Benchmark based on part of Aquarius MeTTa compiler ; -; +; Compiling unification into abstract machine code. - - (= - (top) + (= (top) (main $X)) -; - ; -; - +; , write(X), nl. - (= - (main $Size) - ( (u $X - (:: 1 $Y) - (:: $X) $Code) (size $Code 0 $Size))) -; - + (= (main $Size) + (u $X + (:: 1 $Y) + (:: $X) $Code) + (size $Code 0 $Size)) ; -; - +; Unify variable X with term T and write the result: - (= - (u $X $T $In $Code) + (= (u $X $T $In $Code) (unify $X $T $In $_ $Code Nil)) -; - ; -; - +; Unify the variable X with the term T, given that ; -; - +; In = set of variables initialized before the unification. ; -; - +; Returns the intermediate code for the unification and ; -; - - - (= - (--> - (unify $X $T $In $Out) - (, - { (\+ - (myin $X $In)) } - (, ! - (uninit $X $T $In $Out)))) True) -; - - (= - (--> - (unify $X $T $In $Out) - (, - { (myin $X $In) } - (, ! - (init $X $T $In $Out nonlast $_)))) True) -; +; Out = set of variables initialized after the unification. + (= (--> (unify $X $T $In $Out) (, {(\+ (myin $X $In)) } (, ! (uninit $X $T $In $Out)))) True) + (= (--> (unify $X $T $In $Out) (, {(myin $X $In) } (, ! (init $X $T $In $Out nonlast $_)))) True) ; -; - - (= - (--> - (uninit $X $T $In $Out) - (, - { (my_compound $T) } - (, ! - (, - ( (move - (^ $Tag h) $X)) - (, - { (termtag $T $Tag) } - (, - (unify_block nonlast $T $_ $In $Mid $_) - { (incl $X $Mid $Out) })))))) True) -; - - (= - (--> - (uninit $X $T $In $Out) - (, - { (atomic $T) } - (, ! - (, - ( (move - (^ tatm $T) $X)) - { (incl $X $In $Out) })))) True) -; - - (= - (--> - (uninit $X $T $In $Out) - (, - { (var $T) } - (, ! - (unify_var $X $T $In $Out)))) True) -; - +; **** Uninit assumes X has not yet been initialized: + (= (--> (uninit $X $T $In $Out) (, {(my_compound $T) } (, ! (, ((move (^ $Tag h) $X)) (, {(termtag $T $Tag) } (, (unify_block nonlast $T $_ $In $Mid $_) {(incl $X $Mid $Out) })))))) True) + (= (--> (uninit $X $T $In $Out) (, {(is-symbolic $T) } (, ! (, ((move (^ tatm $T) $X)) {(incl $X $In $Out) })))) True) + (= (--> (uninit $X $T $In $Out) (, {(var $T) } (, ! (unify_var $X $T $In $Out)))) True) ; -; - - (= - (--> - (init $X $T $In $Out $Last $LLbls) - (, - { (nonvar $T) } - (, ! - (, - { (termtag $T $Tag) } - (, - ( (deref $X) (switch $Tag $X (Cons (trail $X) $Write) $Read fail)) - (, - { (unify_writemode $X $T $In $Last $LLbls $Write ()) } - { (unify_readmode $X $T $In $Out $LLbls $Read ()) })))))) True) -; - - (= - (--> - (init $X $T $In $Out $_ $_) - (, - { (var $T) } - (, ! - (unify_var $X $T $In $Out)))) True) -; - +; **** Init assumes X has already been initialized: + (= (--> (init $X $T $In $Out $Last $LLbls) (, {(nonvar $T) } (, ! (, {(termtag $T $Tag) } (, ((deref $X) (switch $Tag $X (Cons (trail $X) $Write) $Read fail)) (, {(unify_writemode $X $T $In $Last $LLbls $Write ()) } {(unify_readmode $X $T $In $Out $LLbls $Read ()) })))))) True) + (= (--> (init $X $T $In $Out $_ $_) (, {(var $T) } (, ! (unify_var $X $T $In $Out)))) True) ; -; - - (= - (--> - (unify_var $X $Y $In $In) - (, - { (, - (myin $X $In) - (myin $Y $In)) } - (, ! - ( (unify $X $Y fail))))) True) -; - - (= - (--> - (unify_var $X $Y $In $Out) - (, - { (, - (myin $X $In) - (\+ - (myin $Y $In))) } - (, ! - (, - ( (move $X $Y)) - { (incl $Y $In $Out) })))) True) -; - - (= - (--> - (unify_var $X $Y $In $Out) - (, - { (, - (\+ - (myin $X $In)) - (myin $Y $In)) } - (, ! - (, - ( (move $Y $X)) - { (incl $X $In $Out) })))) True) -; - - (= - (--> - (unify_var $X $Y $In $Out) - (, - { (, - (\+ - (myin $X $In)) - (\+ - (myin $Y $In))) } - (, ! - (, - ( (move - (^ tvar h) $X) - (move - (^ tvar h) $Y) - (add 1 h) - (move $Y - ( (- h 1)))) - { (, - (incl $X $In $Mid) - (incl $Y $Mid $Out)) })))) True) -; - +; **** Unifying two variables together: + (= (--> (unify_var $X $Y $In $In) (, {(, (myin $X $In) (myin $Y $In)) } (, ! ((unify $X $Y fail))))) True) + (= (--> (unify_var $X $Y $In $Out) (, {(, (myin $X $In) (\+ (myin $Y $In))) } (, ! (, ((move $X $Y)) {(incl $Y $In $Out) })))) True) + (= (--> (unify_var $X $Y $In $Out) (, {(, (\+ (myin $X $In)) (myin $Y $In)) } (, ! (, ((move $Y $X)) {(incl $X $In $Out) })))) True) + (= (--> (unify_var $X $Y $In $Out) (, {(, (\+ (myin $X $In)) (\+ (myin $Y $In))) } (, ! (, ((move (^ tvar h) $X) (move (^ tvar h) $Y) (add 1 h) (move $Y ((- h 1)))) {(, (incl $X $In $Mid) (incl $Y $Mid $Out)) })))) True) ; -; - +; **** Unify_readmode assumes X is a dereferenced nonvariable ; -; - - (= - (--> - (unify_readmode $X $T $In $Out $LLbls) - (, - { (structure $T) } - (, ! - (, - ( (equal - ($X) - (^ tatm - (/ $F $N)) fail)) - (, - { (functor $T $F $N) } - (unify_args 1 $N $T $In $Out 0 $X $LLbls)))))) True) -; - - (= - (--> - (unify_readmode $X $T $In $Out $LLbls) - (, - { (cons $T) } - (, ! - (unify_args 1 2 $T $In $Out -1 $X $LLbls)))) True) -; - - (= - (--> - (unify_readmode $X $T $In $In $_) - (, - { (atomic $T) } - (, ! - ( (equal $X - (^ tatm $T) fail))))) True) -; - - - (= - (--> - (unify_args $I $N $_ $In $In $_ $_ $_) - (, - { (> $I $N) } !)) True) -; - - (= - (--> - (unify_args $I $N $T $In $Out $D $X - (Cons $_ $LLbls)) - (, - { (= $I $N) } - (, ! - (unify_arg $I $T $In $Out $D $X last $LLbls)))) True) -; - - (= - (--> - (unify_args $I $N $T $In $Out $D $X $LLbls) - (, - { (< $I $N) } - (, ! - (, - (unify_arg $I $T $In $Mid $D $X nonlast $_) - (, - { (is $I1 - (+ $I 1)) } - (unify_args $I1 $N $T $Mid $Out $D $X $LLbls)))))) True) -; - - - (= - (--> - (unify_arg $I $T $In $Out $D $X $Last $LLbls) - (, - ( (move - ( (+ $X $ID)) $Y)) - (, - { (, - (is $ID - (+ $I $D)) - (, - (incl $Y $In $Mid) - (arg $I $T $A))) } - (init $Y $A $Mid $Out $Last $LLbls)))) True) -; +; at run-time and T is a nonvariable at compile-time. + (= (--> (unify_readmode $X $T $In $Out $LLbls) (, {(structure $T) } (, ! (, ((equal ($X) (^ tatm (/ $F $N)) fail)) (, {(functor $T $F $N) } (unify_args 1 $N $T $In $Out 0 $X $LLbls)))))) True) + (= (--> (unify_readmode $X $T $In $Out $LLbls) (, {(cons $T) } (, ! (unify_args 1 2 $T $In $Out -1 $X $LLbls)))) True) + (= (--> (unify_readmode $X $T $In $In $_) (, {(is-symbolic $T) } (, ! ((equal $X (^ tatm $T) fail))))) True) + (= (--> (unify_args $I $N $_ $In $In $_ $_ $_) (, {(> $I $N) } !)) True) + (= (--> (unify_args $I $N $T $In $Out $D $X (Cons $_ $LLbls)) (, {(= $I $N) } (, ! (unify_arg $I $T $In $Out $D $X last $LLbls)))) True) + (= (--> (unify_args $I $N $T $In $Out $D $X $LLbls) (, {(< $I $N) } (, ! (, (unify_arg $I $T $In $Mid $D $X nonlast $_) (, {(is $I1 (+ $I 1)) } (unify_args $I1 $N $T $Mid $Out $D $X $LLbls)))))) True) + (= (--> (unify_arg $I $T $In $Out $D $X $Last $LLbls) (, ((move ((+ $X $ID)) $Y)) (, {(, (is $ID (+ $I $D)) (, (incl $Y $In $Mid) (arg $I $T $A))) } (init $Y $A $Mid $Out $Last $LLbls)))) True) -; -; ; -; - - (= - (--> - (unify_writemode $X $T $In $Last $LLbls) - (, - { (my_compound $T) } - (, ! - (, - ( (move - (^ $Tag h) - ($X))) - (, - { (termtag $T $Tag) } - (unify_block $Last $T $_ $In $_ $LLbls)))))) True) -; - - (= - (--> - (unify_writemode $X $T $_ $_ $_) - (, - { (atomic $T) } - (, ! - ( (move - (^ tatm $T) - ($X)))))) True) -; - +; **** Unify_writemode assumes X is a dereferenced unbound +; +; variable at run-time and T is a nonvariable at compile-time. + (= (--> (unify_writemode $X $T $In $Last $LLbls) (, {(my_compound $T) } (, ! (, ((move (^ $Tag h) ($X))) (, {(termtag $T $Tag) } (unify_block $Last $T $_ $In $_ $LLbls)))))) True) + (= (--> (unify_writemode $X $T $_ $_ $_) (, {(is-symbolic $T) } (, ! ((move (^ tatm $T) ($X)))))) True) ; -; - - (= - (--> - (unify_block last $T $Size $In $In - (Cons $Lbl $_)) - (, ! - (, - ( (add $Size h) (jump $Lbl)) - { (size $T 0 $Size) }))) True) -; - - (= - (--> - (unify_block nonlast $T $Size $In $Out - (Cons $_ $LLbls)) - (, ! - (, - ( (add $Size h)) - (, - { (, - (size $T 0 $Size) - (is $Offset - (- $Size))) } - (block $T $Offset 0 $In $Out $LLbls))))) True) -; - - - (= - (--> - (block $T $Inf $Outf $In $Out $LLbls) - (, - { (structure $T) } - (, ! - (, - ( (move - (^ tatm - (/ $F $N)) - ( (+ h $Inf)))) - (, - { (, - (functor $T $F $N) - (, - (is $Midf - (+ - (+ $Inf $N) 1)) - (is $S - (+ $Inf 1)))) } - (, - (make_slots 1 $N $T $S $Offsets $In $Mid) - (block_args 1 $N $T $Midf $Outf $Offsets $Mid $Out $LLbls))))))) True) -; - - (= - (--> - (block $T $Inf $Outf $In $Out $LLbls) - (, - { (cons $T) } - (, ! - (, - { (is $Midf - (+ $Inf 2)) } - (, - (make_slots 1 2 $T $Inf $Offsets $In $Mid) - (block_args 1 2 $T $Midf $Outf $Offsets $Mid $Out $LLbls)))))) True) -; - - (= - (--> - (block $T $Inf $Inf $In $In ()) - (, - { (atomic $T) } !)) True) -; - - (= - (--> - (block $T $Inf $Inf $In $In ()) - (, - { (var $T) } !)) True) -; - - - (= - (--> - (block_args $I $N $_ $Inf $Inf () $In $In ()) - (, - { (> $I $N) } !)) True) -; - - (= - (--> - (block_args $I $N $T $Inf $Outf - ($Inf) $In $Out - (Cons $Lbl $LLbls)) - (, - { (= $I $N) } - (, ! - (, - ( (label $Lbl)) - (, - { (arg $I $T $A) } - (block $A $Inf $Outf $In $Out $LLbls)))))) True) -; - - (= - (--> - (block_args $I $N $T $Inf $Outf - (Cons $Inf $Offsets) $In $Out $LLbls) - (, - { (< $I $N) } - (, ! - (, - { (arg $I $T $A) } - (, - (block $A $Inf $Midf $In $Mid $_) - (, - { (is $I1 - (+ $I 1)) } - (block_args $I1 $N $T $Midf $Outf $Offsets $Mid $Out $LLbls))))))) True) -; - - - (= - (--> - (make_slots $I $N $_ $_ () $In $In) - (, - { (> $I $N) } !)) True) -; - - (= - (--> - (make_slots $I $N $T $S - (Cons $Off $Offsets) $In $Out) - (, - { (=< $I $N) } - (, ! - (, - { (arg $I $T $A) } - (, - (init_var $A $S $In) - (, - { (, - (incl $A $In $Mid) - (make_word $A $Off $Word)) } - (, - ( (move $Word - ( (+ h $S)))) - (, - { (, - (is $S1 - (+ $S 1)) - (is $I1 - (+ $I 1))) } - (make_slots $I1 $N $T $S1 $Offsets $Mid $Out))))))))) True) -; +; **** Generate a minimal sequence of moves to create T on the heap: + (= (--> (unify_block last $T $Size $In $In (Cons $Lbl $_)) (, ! (, ((add $Size h) (jump $Lbl)) {(size $T 0 $Size) }))) True) + (= (--> (unify_block nonlast $T $Size $In $Out (Cons $_ $LLbls)) (, ! (, ((add $Size h)) (, {(, (size $T 0 $Size) (is $Offset (- $Size))) } (block $T $Offset 0 $In $Out $LLbls))))) True) + (= (--> (block $T $Inf $Outf $In $Out $LLbls) (, {(structure $T) } (, ! (, ((move (^ tatm (/ $F $N)) ((+ h $Inf)))) (, {(, (functor $T $F $N) (, (is $Midf (+ (+ $Inf $N) 1)) (is $S (+ $Inf 1)))) } (, (make_slots 1 $N $T $S $Offsets $In $Mid) (block_args 1 $N $T $Midf $Outf $Offsets $Mid $Out $LLbls))))))) True) + (= (--> (block $T $Inf $Outf $In $Out $LLbls) (, {(cons $T) } (, ! (, {(is $Midf (+ $Inf 2)) } (, (make_slots 1 2 $T $Inf $Offsets $In $Mid) (block_args 1 2 $T $Midf $Outf $Offsets $Mid $Out $LLbls)))))) True) + (= (--> (block $T $Inf $Inf $In $In ()) (, {(is-symbolic $T) } !)) True) + (= (--> (block $T $Inf $Inf $In $In ()) (, {(var $T) } !)) True) + (= (--> (block_args $I $N $_ $Inf $Inf () $In $In ()) (, {(> $I $N) } !)) True) + (= (--> (block_args $I $N $T $Inf $Outf ($Inf) $In $Out (Cons $Lbl $LLbls)) (, {(= $I $N) } (, ! (, ((label $Lbl)) (, {(arg $I $T $A) } (block $A $Inf $Outf $In $Out $LLbls)))))) True) + (= (--> (block_args $I $N $T $Inf $Outf (Cons $Inf $Offsets) $In $Out $LLbls) (, {(< $I $N) } (, ! (, {(arg $I $T $A) } (, (block $A $Inf $Midf $In $Mid $_) (, {(is $I1 (+ $I 1)) } (block_args $I1 $N $T $Midf $Outf $Offsets $Mid $Out $LLbls))))))) True) -; -; - - (= - (--> - (init_var $V $I $In) - (, - { (, - (var $V) - (\+ - (myin $V $In))) } - (, ! - ( (move - (^ tvar - (+ h $I)) $V))))) True) -; - - (= - (--> - (init_var $V $_ $In) - (, - { (, - (var $V) - (myin $V $In)) } !)) True) -; - - (= - (--> - (init_var $V $_ $_) - (, - { (nonvar $V) } !)) True) -; - - - - (= - (make-word $C $Off - (^ $Tag - (+ h $Off))) - ( (my-compound $C) - (set-det) - (termtag $C $Tag))) -; - - (= - (make-word $V $_ $V) - ( (var $V) (set-det))) -; - - (= - (make-word $A $_ - (^ tatm $A)) - ( (atomic $A) (set-det))) -; + (= (--> (make_slots $I $N $_ $_ () $In $In) (, {(> $I $N) } !)) True) + (= (--> (make_slots $I $N $T $S (Cons $Off $Offsets) $In $Out) (, {(=< $I $N) } (, ! (, {(arg $I $T $A) } (, (init_var $A $S $In) (, {(, (incl $A $In $Mid) (make_word $A $Off $Word)) } (, ((move $Word ((+ h $S)))) (, {(, (is $S1 (+ $S 1)) (is $I1 (+ $I 1))) } (make_slots $I1 $N $T $S1 $Offsets $Mid $Out))))))))) True) ; -; - - - (= - (--> - (size $T) - (, - { (structure $T) } - (, ! - (, - { (functor $T $_ $N) } - (, - (add 1) - (, - (add $N) - (size_args 1 $N $T))))))) True) -; - - (= - (--> - (size $T) - (, - { (cons $T) } - (, ! - (, - (add 2) - (size_args 1 2 $T))))) True) -; - - (= - (--> - (size $T) - (, - { (atomic $T) } !)) True) -; - - (= - (--> - (size $T) - (, - { (var $T) } !)) True) -; - - - (= - (--> - (size_args $I $N $_) - (, - { (> $I $N) } !)) True) -; - - (= - (--> - (size_args $I $N $T) - (, - { (=< $I $N) } - (, ! - (, - { (arg $I $T $A) } - (, - (size $A) - (, - { (is $I1 - (+ $I 1)) } - (size_args $I1 $N $T))))))) True) -; +; Initialize first-time variables in write mode: + (= (--> (init_var $V $I $In) (, {(, (var $V) (\+ (myin $V $In))) } (, ! ((move (^ tvar (+ h $I)) $V))))) True) + (= (--> (init_var $V $_ $In) (, {(, (var $V) (myin $V $In)) } !)) True) + (= (--> (init_var $V $_ $_) (, {(nonvar $V) } !)) True) -; -; + (= (make-word $C $Off (^ $Tag (+ h $Off))) + (my-compound $C) + (set-det) + (termtag $C $Tag)) + (= (make-word $V $_ $V) + (var $V) + (set-det)) + (= (make-word $A $_ (^ tatm $A)) + (atomic $A) + (set-det)) +; +; Calculate the size of T on the heap: + (= (--> (size $T) (, {(structure $T) } (, ! (, {(functor $T $_ $N) } (, (add 1) (, (add $N) (size_args 1 $N $T))))))) True) + (= (--> (size $T) (, {(cons $T) } (, ! (, (add 2) (size_args 1 2 $T))))) True) + (= (--> (size $T) (, {(is-symbolic $T) } !)) True) + (= (--> (size $T) (, {(var $T) } !)) True) - (= - (add $I $X $Y) - (is $Y - (+ $X $I))) -; + (= (--> (size_args $I $N $_) (, {(> $I $N) } !)) True) + (= (--> (size_args $I $N $T) (, {(=< $I $N) } (, ! (, {(arg $I $T $A) } (, (size $A) (, {(is $I1 (+ $I 1)) } (size_args $I1 $N $T))))))) True) +; +; **** Utility routines: - (= - (myin $A - (Cons $B $S)) - ( (compare $Order $A $B) (in-2 $Order $A $S))) -; + (= (add $I $X $Y) + (is $Y + (+ $X $I))) + (= (myin $A (Cons $B $S)) + (compare $Order $A $B) + (in-2 $Order $A $S)) - (= - (in_2 = $_ $_) True) -; - (= - (in-2 > $A $S) + (= (in_2 = $_ $_) True) + (= (in-2 > $A $S) (myin $A $S)) -; - - (= - (incl $A $S1 $S) + (= (incl $A $S1 $S) (incl-2 $S1 $A $S)) -; - - (= - (incl_2 () $A - ($A)) True) -; + (= (incl_2 () $A ($A)) True) + (= (incl-2 (Cons $B $S1) $A $S) + (compare $Order $A $B) + (incl-3 $Order $A $B $S1 $S)) - (= - (incl-2 - (Cons $B $S1) $A $S) - ( (compare $Order $A $B) (incl-3 $Order $A $B $S1 $S))) -; - - - (= - (incl_3 < $A $B $S1 - (Cons $A - (Cons $B $S1))) True) -; - - (= - (incl_3 = $_ $B $S1 - (Cons $B $S1)) True) -; - - (= - (incl-3 > $A $B $S1 - (Cons $B $S)) + (= (incl_3 < $A $B $S1 (Cons $A (Cons $B $S1))) True) + (= (incl_3 = $_ $B $S1 (Cons $B $S1)) True) + (= (incl-3 > $A $B $S1 (Cons $B $S)) (incl-2 $S1 $A $S)) -; - - - (= - (my-compound $X) - ( (nonvar $X) (not (atomic $X)))) -; + (= (my-compound $X) + (nonvar $X) + (not (atomic $X))) - (= - (cons $X) - ( (nonvar $X) (= $X (Cons $_ $_)))) -; + (= (cons $X) + (nonvar $X) + (= $X + (Cons $_ $_))) + (= (structure $X) + (my-compound $X) + (not (= $X (Cons $_ $_)))) - (= - (structure $X) - ( (my-compound $X) (not (= $X (Cons $_ $_))))) -; - - - (= - (termtag $T tstr) + (= (termtag $T tstr) (structure $T)) -; - - (= - (termtag $T tlst) + (= (termtag $T tlst) (cons $T)) -; - - (= - (termtag $T tatm) + (= (termtag $T tatm) (atomic $T)) -; - - (= - (termtag $T tvar) + (= (termtag $T tvar) (var $T)) -; - diff --git a/sxx_machine/bench/zebra.metta b/sxx_machine/bench/zebra.metta index 4103eb8..6f5a14f 100644 --- a/sxx_machine/bench/zebra.metta +++ b/sxx_machine/bench/zebra.metta @@ -1,126 +1,76 @@ +; (convert_to_metta_file zebra $_181428 sxx_machine/bench/zebra.pl sxx_machine/bench/zebra.metta) ; -; - +; Where does the zebra live? ; -; - - - (= - (top) - ( (houses $Houses) - (member - (house red english $_ $_ $_) $Houses) - (member - (house $_ spanish dog $_ $_) $Houses) - (member - (house green $_ $_ coffee $_) $Houses) - (member - (house $_ ukrainian $_ tea $_) $Houses) - (right-of - (house green $_ $_ $_ $_) - (house ivory $_ $_ $_ $_) $Houses) - (member - (house $_ $_ snails $_ winstons) $Houses) - (member - (house yellow $_ $_ $_ kools) $Houses) - (= $Houses - (:: $_ $_ - (house $_ $_ $_ milk $_) $_ $_)) - (= $Houses - (Cons - (house $_ norwegian $_ $_ $_) $_)) - (next-to - (house $_ $_ $_ $_ chesterfields) - (house $_ $_ fox $_ $_) $Houses) - (next-to - (house $_ $_ $_ $_ kools) - (house $_ $_ horse $_ $_) $Houses) - (member - (house $_ $_ $_ orange-juice lucky-strikes) $Houses) - (member - (house $_ japanese $_ $_ parliaments) $Houses) - (next-to - (house $_ norwegian $_ $_ $_) - (house blue $_ $_ $_ $_) $Houses) - (member - (house $_ $_ zebra $_ $_) $Houses) - (member - (house $_ $_ $_ water $_) $Houses))) -; - +; Puzzle solution written by Claude Sammut. + + (= (top) + (houses $Houses) + (member + (house red english $_ $_ $_) $Houses) + (member + (house $_ spanish dog $_ $_) $Houses) + (member + (house green $_ $_ coffee $_) $Houses) + (member + (house $_ ukrainian $_ tea $_) $Houses) + (right-of + (house green $_ $_ $_ $_) + (house ivory $_ $_ $_ $_) $Houses) + (member + (house $_ $_ snails $_ winstons) $Houses) + (member + (house yellow $_ $_ $_ kools) $Houses) + (= $Houses + (:: $_ $_ + (house $_ $_ $_ milk $_) $_ $_)) + (= $Houses + (Cons + (house $_ norwegian $_ $_ $_) $_)) + (next-to + (house $_ $_ $_ $_ chesterfields) + (house $_ $_ fox $_ $_) $Houses) + (next-to + (house $_ $_ $_ $_ kools) + (house $_ $_ horse $_ $_) $Houses) + (member + (house $_ $_ $_ orange-juice lucky-strikes) $Houses) + (member + (house $_ japanese $_ $_ parliaments) $Houses) + (next-to + (house $_ norwegian $_ $_ $_) + (house blue $_ $_ $_ $_) $Houses) + (member + (house $_ $_ zebra $_ $_) $Houses) + (member + (house $_ $_ $_ water $_) $Houses)) ; -; +; print_houses(Houses). + (= (houses ((house $_ $_ $_ $_ $_) (house $_ $_ $_ $_ $_) (house $_ $_ $_ $_ $_) (house $_ $_ $_ $_ $_) (house $_ $_ $_ $_ $_))) True) - (= - (houses - ( (house $_ $_ $_ $_ $_) - (house $_ $_ $_ $_ $_) - (house $_ $_ $_ $_ $_) - (house $_ $_ $_ $_ $_) - (house $_ $_ $_ $_ $_))) True) -; - - - (= - (right_of $A $B - (Cons $B - (Cons $A $_))) True) -; - - (= - (right-of $A $B - (Cons $_ $Y)) + (= (right_of $A $B (Cons $B (Cons $A $_))) True) + (= (right-of $A $B (Cons $_ $Y)) (right-of $A $B $Y)) -; - - (= - (next_to $A $B - (Cons $A - (Cons $B $_))) True) -; - - (= - (next_to $A $B - (Cons $B - (Cons $A $_))) True) -; - - (= - (next-to $A $B - (Cons $_ $Y)) + (= (next_to $A $B (Cons $A (Cons $B $_))) True) + (= (next_to $A $B (Cons $B (Cons $A $_))) True) + (= (next-to $A $B (Cons $_ $Y)) (next-to $A $B $Y)) -; - - - (= - (member $X - (Cons $X $_)) True) -; - (= - (member $X - (Cons $_ $Y)) + (= (member $X (Cons $X $_)) True) + (= (member $X (Cons $_ $Y)) (member $X $Y)) -; - - - - (= - (print-houses (Cons $A $B)) - ( (set-det) - (write $A) - (nl) - (print-houses $B))) -; - (= - (print_houses ()) True) -; + (= (print-houses (Cons $A $B)) + (set-det) + (write $A) + (nl) + (print-houses $B)) + (= (print_houses ()) True) diff --git a/sxx_machine/sxx_builtins_cafe.metta b/sxx_machine/sxx_builtins_cafe.metta index 0986d00..97a93fd 100644 --- a/sxx_machine/sxx_builtins_cafe.metta +++ b/sxx_machine/sxx_builtins_cafe.metta @@ -1,7637 +1,4271 @@ +; (convert_to_metta_file sxx_builtins_cafe $_334232 sxx_machine/sxx_builtins_cafe.pl sxx_machine/sxx_builtins_cafe.metta) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Builtin Predicates of MeTTa Cafe ; ; - ; -; - +; Mutsunori Banbara (banbara@kobe-u.ac.jp) ; -; - +; Naoyuki Tamura (tamura@kobe-u.ac.jp) ; -; - +; Kobe University ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + !(op 1150 fx package) - !(op 1150 fx package) -; - - - (= - (package $_) True) -; - + (= (package $_) True) - !(package TauMachine.builtin) -; - + !(package TauMachine.builtin) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Control constructs ; -; - - !(public (, (/ True 0) (/ otherwise 0))) -; - - !(public (, (/ fail 0) (/ False 0))) -; - - !(public (/ (set-det) 0)) -; - - !(public (/ ^ 2)) -; - - !(public (/ , 2)) -; - - !(public (/ or 2)) -; - - !(public (/ -> 2)) -; - - !(public (/ call 1)) -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + !(public (, (/ True 0) (/ otherwise 0))) + !(public (, (/ fail 0) (/ False 0))) + !(public (/ (set-det) 0)) + !(public (/ ^ 2)) + !(public (/ , 2)) + !(public (/ or 2)) + !(public (/ -> 2)) + !(public (/ call 1)) - (= true True) -; - + (= true True) - (= otherwise True) -; - + (= otherwise True) - (= fail - (empty)) -; - + (= fail + (empty)) - (= false - (empty)) -; - + (= false + (empty)) - (= ! True) -; - + (= ! True) - (= - (^ $_ $G) - (call $G)) -; - + (= (^ $_ $G) + (call $G)) - (= - (, $P $Q) - ( (call $P) (call $Q))) -; - + (= (, $P $Q) + (call $P) + (call $Q)) - (= - (or $P $Q) - ( (\= $P - (det-if-then $_ $_)) (call $P))) -; - - (= - (or $P $Q) - ( (\= $Q - (det-if-then $_ $_)) (call $Q))) -; - + (= (or $P $Q) + (\= $P + (det-if-then $_ $_)) + (call $P)) + (= (or $P $Q) + (\= $Q + (det-if-then $_ $_)) + (call $Q)) - (= - (det-if-then $IF $THEN) - ( (call $IF) - (set-det) - (call $THEN))) -; - + (= (det-if-then $IF $THEN) + (call $IF) + (set-det) + (call $THEN)) - (= - (det-if-then-else $IF $THEN $ELSE) - ( (call $IF) - (set-det) - (call $THEN))) -; - - (= - (det-if-then-else $IF $THEN $ELSE) - (call $ELSE)) -; - + (= (det-if-then-else $IF $THEN $ELSE) + (call $IF) + (set-det) + (call $THEN)) + (= (det-if-then-else $IF $THEN $ELSE) + (call $ELSE)) - (= - (call $Term) - ( ($get-current-B $Cut) ($meta-call $Term user $Cut 0 interpret))) -; - + (= (call $Term) + ($get-current-B $Cut) + ($meta-call $Term user $Cut 0 interpret)) - (= - ($meta-call $X $_ $_ $_ $_) - ( (var $X) - (set-det) - (illarg var - (call $X) 1))) -; - - (= - ($meta-call $X $_ $_ $_ $_) - ( (closure $X) - (set-det) - ($call-closure $X))) -; - - (= - ($meta-call True $_ $_ $_ $_) - (set-det)) -; - - (= - ($meta-call trace $_ $_ $_ $_) - ( (set-det) (trace))) -; - - (= - ($meta-call debug $_ $_ $_ $_) - ( (set-det) (debug))) -; - - (= - ($meta-call notrace $_ $_ $_ $_) - ( (set-det) (notrace))) -; - - (= - ($meta-call nodebug $_ $_ $_ $_) - ( (set-det) (nodebug))) -; - - (= - ($meta-call - (spy $L) $_ $_ $_ $_) - ( (set-det) (spy $L))) -; - - (= - ($meta-call - (nospy $L) $_ $_ $_ $_) - ( (set-det) (nospy $L))) -; - - (= - ($meta-call nospyall $_ $_ $_ $_) - ( (set-det) (nospyall))) -; - - (= - ($meta-call - (leash $L) $_ $_ $_ $_) - ( (set-det) (leash $L))) -; - - (= - ($meta-call - (Cons $X $Xs) $_ $_ $_ $_) - ( (set-det) (consult (Cons $X $Xs)))) -; - - (= - ($meta-call - (^ $_ $X) $P $Cut $Depth $Mode) - ( (set-det) ($meta-call $X $P $Cut $Depth $Mode))) -; - - (= - ($meta-call - (with_self $P $X) $_ $Cut $Depth $Mode) - ( (set-det) ($meta-call $X $P $Cut $Depth $Mode))) -; - - (= - ($meta-call - (set-det) $_ no $_ $_) - ( (set-det) (illarg (context if cut) (set-det) 0))) -; - - (= - ($meta-call - (set-det) $_ $Cut $_ $_) - ( (set-det) ($cut $Cut))) -; - - (= - ($meta-call - (, $X $Y) $P $Cut $Depth $Mode) - ( (set-det) + (= ($meta-call $X $_ $_ $_ $_) + (var $X) + (set-det) + (illarg var + (call $X) 1)) + (= ($meta-call $X $_ $_ $_ $_) + (closure $X) + (set-det) + ($call-closure $X)) + (= ($meta-call True $_ $_ $_ $_) + (set-det)) + (= ($meta-call trace $_ $_ $_ $_) + (set-det) + (trace)) + (= ($meta-call debug $_ $_ $_ $_) + (set-det) + (debug)) + (= ($meta-call notrace $_ $_ $_ $_) + (set-det) + (notrace)) + (= ($meta-call nodebug $_ $_ $_ $_) + (set-det) + (nodebug)) + (= ($meta-call (spy $L) $_ $_ $_ $_) + (set-det) + (spy $L)) + (= ($meta-call (nospy $L) $_ $_ $_ $_) + (set-det) + (nospy $L)) + (= ($meta-call nospyall $_ $_ $_ $_) + (set-det) + (nospyall)) + (= ($meta-call (leash $L) $_ $_ $_ $_) + (set-det) + (leash $L)) + (= ($meta-call (Cons $X $Xs) $_ $_ $_ $_) + (set-det) + (consult (Cons $X $Xs))) + (= ($meta-call (^ $_ $X) $P $Cut $Depth $Mode) + (set-det) + ($meta-call $X $P $Cut $Depth $Mode)) + (= ($meta-call (with_self $P $X) $_ $Cut $Depth $Mode) + (set-det) + ($meta-call $X $P $Cut $Depth $Mode)) + (= ($meta-call (set-det) $_ no $_ $_) + (set-det) + (illarg + (context if cut) + (set-det) 0)) + (= ($meta-call (set-det) $_ $Cut $_ $_) + (set-det) + ($cut $Cut)) + (= ($meta-call (, $X $Y) $P $Cut $Depth $Mode) + (set-det) + ($meta-call $X $P $Cut $Depth $Mode) + ($meta-call $Y $P $Cut $Depth $Mode)) + (= ($meta-call (det-if-then-else $X $Y $Z) $P $Cut $Depth $Mode) + (set-det) + (det-if-then-else + ($meta-call $X $P no $Depth $Mode) + ($meta-call $Y $P $Cut $Depth $Mode) + ($meta-call $Z $P $Cut $Depth $Mode))) + (= ($meta-call (det-if-then $X $Y) $P $Cut $Depth $Mode) + (set-det) + (det-if-then + ($meta-call $X $P no $Depth $Mode) + ($meta-call $Y $P $Cut $Depth $Mode))) + (= ($meta-call (or $X $Y) $P $Cut $Depth $Mode) + (set-det) + (or ($meta-call $X $P $Cut $Depth $Mode) - ($meta-call $Y $P $Cut $Depth $Mode))) -; - - (= - ($meta-call - (det-if-then-else $X $Y $Z) $P $Cut $Depth $Mode) - ( (set-det) (det-if-then-else ($meta-call $X $P no $Depth $Mode) ($meta-call $Y $P $Cut $Depth $Mode) ($meta-call $Z $P $Cut $Depth $Mode)))) -; - - (= - ($meta-call - (det-if-then $X $Y) $P $Cut $Depth $Mode) - ( (set-det) (det-if-then ($meta-call $X $P no $Depth $Mode) ($meta-call $Y $P $Cut $Depth $Mode)))) -; - - (= - ($meta-call - (or $X $Y) $P $Cut $Depth $Mode) - ( (set-det) (or ($meta-call $X $P $Cut $Depth $Mode) ($meta-call $Y $P $Cut $Depth $Mode)))) -; - - (= - ($meta-call - (not $X) $P $_ $Depth $Mode) - ( (set-det) (not ($meta-call $X $P no $Depth $Mode)))) -; - - (= - ($meta-call - (findall $X $Y $Z) $P $Cut $Depth $Mode) - ( (set-det) (findall $X ($meta-call $Y $P $Cut $Depth $Mode) $Z))) -; - - (= - ($meta-call - (bagof $X $Y $Z) $P $Cut $Depth $Mode) - ( (set-det) (bagof $X ($meta-call $Y $P $Cut $Depth $Mode) $Z))) -; - - (= - ($meta-call - (setof $X $Y $Z) $P $Cut $Depth $Mode) - ( (set-det) (setof $X ($meta-call $Y $P $Cut $Depth $Mode) $Z))) -; - - (= - ($meta-call - (once $X) $P $Cut $Depth $Mode) - ( (set-det) (once ($meta-call $X $P $Cut $Depth $Mode)))) -; - - (= - ($meta-call - (on-exception $X $Y $Z) $P $Cut $Depth $Mode) - ( (set-det) (on-exception $X ($meta-call $Y $P $Cut $Depth $Mode) ($meta-call $Z $P $Cut $Depth $Mode)))) -; - - (= - ($meta-call - (catch $X $Y $Z) $P $Cut $Depth $Mode) - ( (set-det) (catch ($meta-call $X $P $Cut $Depth $Mode) $Y ($meta-call $Z $P $Cut $Depth $Mode)))) -; - -; -; - -; -; - - (= - ($meta-call - (synchronized $X $Y) $P $Cut $Depth $Mode) - ( (set-det) (synchronized $X ($meta-call $Y $P $Cut $Depth $Mode)))) -; - - (= - ($meta-call - (get-symbols &self - (= $X $Y)) $P $_ $_ $_) - ( (set-det) (get-symbols &self (= (: $P $X) $Y)))) -; - - (= - ($meta-call - (add-symbol &self $X) $P $_ $_ $_) - ( (set-det) (add-symbol &self (: $P $X)))) -; - - (= - ($meta-call - (add-symbol &self $X) $P $_ $_ $_) - ( (set-det) (add-symbol &self (: $P $X)))) -; - - (= - ($meta-call - (add-symbol &self $X) $P $_ $_ $_) - ( (set-det) (add-symbol &self (: $P $X)))) -; - - (= - ($meta-call - (remove-symbol &self $X) $P $_ $_ $_) - ( (set-det) (remove-symbol &self (: $P $X)))) -; - - (= - ($meta-call - (abolish $X) $P $_ $_ $_) - ( (set-det) (abolish (with_self $P $X)))) -; - - (= - ($meta-call - (remove-all-symbols &self $X) $P $_ $_ $_) - ( (set-det) (remove-all-symbols &self (: $P $X)))) -; - - (= - ($meta-call $X $P $_ $Depth $Mode) - ( (atom $P) - (callable $X) - (set-det) - ($meta-call $Mode $Depth $P $X))) -; - - (= - ($meta-call $X $P $_ $_ $_) + ($meta-call $Y $P $Cut $Depth $Mode))) + (= ($meta-call (not $X) $P $_ $Depth $Mode) + (set-det) + (not ($meta-call $X $P no $Depth $Mode))) + (= ($meta-call (findall $X $Y $Z) $P $Cut $Depth $Mode) + (set-det) + (findall $X + ($meta-call $Y $P $Cut $Depth $Mode) $Z)) + (= ($meta-call (bagof $X $Y $Z) $P $Cut $Depth $Mode) + (set-det) + (bagof $X + ($meta-call $Y $P $Cut $Depth $Mode) $Z)) + (= ($meta-call (setof $X $Y $Z) $P $Cut $Depth $Mode) + (set-det) + (setof $X + ($meta-call $Y $P $Cut $Depth $Mode) $Z)) + (= ($meta-call (once $X) $P $Cut $Depth $Mode) + (set-det) + (once ($meta-call $X $P $Cut $Depth $Mode))) + (= ($meta-call (on-exception $X $Y $Z) $P $Cut $Depth $Mode) + (set-det) + (on-exception $X + ($meta-call $Y $P $Cut $Depth $Mode) + ($meta-call $Z $P $Cut $Depth $Mode))) + (= ($meta-call (catch $X $Y $Z) $P $Cut $Depth $Mode) + (set-det) + (catch + ($meta-call $X $P $Cut $Depth $Mode) $Y + ($meta-call $Z $P $Cut $Depth $Mode))) +; +; '$meta_call'(freeze(X,Y), P, Cut, Depth, Mode) :- !, ??? +; +; freeze(X, '$meta_call'(Y, P, Cut, Depth, Mode)). + (= ($meta-call (synchronized $X $Y) $P $Cut $Depth $Mode) + (set-det) + (synchronized $X + ($meta-call $Y $P $Cut $Depth $Mode))) + (= ($meta-call (== (= $X $Y) (get-atoms &self)) $P $_ $_ $_) + ( (set-det) (== (= (: $P $X) $Y) (get-atoms &self)))) + (= ($meta-call (add-is-symbol &self $X) $P $_ $_ $_) + ( (set-det) (add-is-symbol &self (: $P $X)))) + (= ($meta-call (add-is-symbol &self $X) $P $_ $_ $_) + ( (set-det) (add-is-symbol &self (: $P $X)))) + (= ($meta-call (add-is-symbol &self $X) $P $_ $_ $_) + ( (set-det) (add-is-symbol &self (: $P $X)))) + (= ($meta-call (remove-is-symbol &self $X) $P $_ $_ $_) + ( (set-det) (remove-is-symbol &self (: $P $X)))) + (= ($meta-call (abolish $X) $P $_ $_ $_) + (set-det) + (abolish (with_self $P $X))) + (= ($meta-call (remove-all-atoms &self $X) $P $_ $_ $_) + ( (set-det) (remove-all-atoms &self (: $P $X)))) + (= ($meta-call $X $P $_ $Depth $Mode) + (atom $P) + (callable $X) + (set-det) + ($meta-call $Mode $Depth $P $X)) + (= ($meta-call $X $P $_ $_ $_) (illarg (type callable) - (call (with_self $P $X)) 1)) -; - - - (= - ($meta-call trace $Depth $P $X) - ( (set-det) - (functor $X $F $A) - ($trace-goal $X $P - (/ $F $A) $Depth))) -; - - (= - ($meta-call interpret $Depth $P $X) - ( (functor $X $F $A) ($call-internal $X $P (/ $F $A) $Depth interpret))) -; + (call (with_self $P $X)) 1)) + (= ($meta-call trace $Depth $P $X) + (set-det) + (functor $X $F $A) + ($trace-goal $X $P + (/ $F $A) $Depth)) + (= ($meta-call interpret $Depth $P $X) + (functor $X $F $A) + ($call-internal $X $P + (/ $F $A) $Depth interpret)) - (= - ($call-internal $X $P $FA $Depth $Mode) + (= ($call-internal $X $P $FA $Depth $Mode) ( ($new-internal-database $P) (hash-contains-key $P $FA) (set-det) ($get-current-B $Cut) (is $Depth1 (+ $Depth 1)) - (get-symbols &self + (== (= - (: $P $X) $Body)) - ($meta-call $Body $P $Cut $Depth1 $Mode))) -; - - (= - ($call-internal $X $P $_ $_ $_) - ($call $P $X)) -; - + (: $P $X) $Body) + (get-atoms &self)) + ($meta-call $Body $P $Cut $Depth1 $Mode))) + (= ($call-internal $X $P $_ $_ $_) + ($call $P $X)) - !(public (, (/ catch 3) (/ throw 1))) -; - - !(public (/ on-exception 3)) -; - + !(public (, (/ catch 3) (/ throw 1))) + !(public (/ on-exception 3)) - (= - (catch $Goal $Catch $Recovery) - (on-exception $Catch $Goal $Recovery)) -; - + (= (catch $Goal $Catch $Recovery) + (on-exception $Catch $Goal $Recovery)) - (= - (throw $Msg) - (raise-exception $Msg)) -; - + (= (throw $Msg) + (raise-exception $Msg)) - (= - (on-exception $Catch $Goal $Recovery) - ( (callable $Goal) - (set-det) - ($on-exception $Catch $Goal $Recovery))) -; - - (= - (on-exception $Catch $Goal $Recovery) + (= (on-exception $Catch $Goal $Recovery) + (callable $Goal) + (set-det) + ($on-exception $Catch $Goal $Recovery)) + (= (on-exception $Catch $Goal $Recovery) (illarg (type callable) - (on-exception $Catch $Goal $Recovery) 2)) -; - + (on-exception $Catch $Goal $Recovery) 2)) - (= - ($on-exception $Catch $Goal $Recovery) - ( ($set-exception %none) - ($begin-exception $L) - (call $Goal) - ($end-exception $L))) -; - - (= - ($on-exception $Catch $Goal $Recovery) - ( ($get-exception $Msg) - (\== $Msg %none) - ($catch-and-throw $Msg $Catch $Recovery))) -; - + (= ($on-exception $Catch $Goal $Recovery) + ($set-exception %none) + ($begin-exception $L) + (call $Goal) + ($end-exception $L)) + (= ($on-exception $Catch $Goal $Recovery) + ($get-exception $Msg) + (\== $Msg %none) + ($catch-and-throw $Msg $Catch $Recovery)) - (= - ($catch-and-throw $Msg $Msg $Recovery) - ( (set-det) - ($set-exception %none) - (call $Recovery))) -; - - (= - ($catch-and-throw $Msg $_ $_) - (raise-exception $Msg)) -; - + (= ($catch-and-throw $Msg $Msg $Recovery) + (set-det) + ($set-exception %none) + (call $Recovery)) + (= ($catch-and-throw $Msg $_ $_) + (raise-exception $Msg)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Term unification ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - !(public (, (/ = 2) (/ %unify 2))) -; - - !(public (, (/ \= 2) (/ %not-unifiable 2))) -; - + !(public (, (/ = 2) (/ %unify 2))) + !(public (, (/ \= 2) (/ %not-unifiable 2))) - (= - (= $X $Y) - (= $X $Y)) -; - + (= (= $X $Y) + (= $X $Y)) - (= - ($unify $X $Y) - ($unify $X $Y)) -; - + (= ($unify $X $Y) + ($unify $X $Y)) - (= - (\= $X $Y) - (\= $X $Y)) -; - + (= (\= $X $Y) + (\= $X $Y)) - (= - ($not-unifiable $X $Y) - ($not-unifiable $X $Y)) -; - + (= ($not-unifiable $X $Y) + ($not-unifiable $X $Y)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Type testing ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - !(public (, (/ var 1) (/ is-symbol 1) (/ integer 1) (/ long 1) (/ float 1) (/ symbolic 1) (/ compound 1) (/ nonvar 1) (/ number 1))) -; - - !(public (, (/ java 1) (/ java 2) (/ closure 1))) -; - - !(public (, (/ ground 1) (/ callable 1))) -; - + !(public (, (/ var 1) (/ is-symbol 1) (/ integer 1) (/ long 1) (/ float 1) (/ symbolic 1) (/ compound 1) (/ nonvar 1) (/ number 1))) + !(public (, (/ java 1) (/ java 2) (/ closure 1))) + !(public (, (/ ground 1) (/ callable 1))) - (= - (var $X) - (var $X)) -; - + (= (var $X) + (var $X)) - (= - (atom $X) - (atom $X)) -; - + (= (atom $X) + (atom $X)) - (= - (integer $X) - (integer $X)) -; - + (= (integer $X) + (integer $X)) - (= - (long $X) - (long $X)) -; + (= (long $X) + (long $X)) + + (= (float $X) + (float $X)) - (= - (float $X) - (float $X)) -; + (= (atomic $X) + (atomic $X)) + + (= (nonvar $X) + (nonvar $X)) - (= - (atomic $X) - (atomic $X)) -; + (= (number $X) + (number $X)) + + (= (java $X) + (java $X)) + (= (java $X $Y) + (java $X $Y)) - (= - (nonvar $X) - (nonvar $X)) -; + (= (closure $X) + (closure $X)) + + (= (ground $X) + (ground $X)) - (= - (number $X) - (number $X)) -; + (= (compound $X) + (nonvar $X) + (functor $X $_ $A) + (> $A 0)) + + (= (callable $X) + (atom $X) + (set-det)) + (= (callable $X) + (compound $X) + (set-det)) + (= (callable $X) + (closure $X)) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Term comparison +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (java $X) - (java $X)) -; + !(public (, (/ == 2) (/ %equality-of-term 2))) + !(public (, (/ \== 2) (/ %inequality-of-term 2))) + !(public (, (/ @< 2) (/ %before 2))) + !(public (, (/ @> 2) (/ %after 2))) + !(public (, (/ @=< 2) (/ %not-after 2))) + !(public (, (/ @>= 2) (/ %not-before 2))) + !(public (, (/ ?= 2) (/ %identical-or-cannot-unify 2))) + !(public (/ compare 3)) +; +; :- public sort/2. witten in Java +; +; :- public keysort/2. witten in Java +; +; :- public merge/3. - (= - (java $X $Y) - (java $X $Y)) -; + + (= (== $X $Y) + (== $X $Y)) + + (= ($equality-of-term $X $Y) + ($equality-of-term $X $Y)) + + (= (\== $X $Y) + (\== $X $Y)) + + (= ($inequality-of-term $X $Y) + ($inequality-of-term $X $Y)) - (= - (closure $X) - (closure $X)) -; + (= (@< $X $Y) + (@< $X $Y)) + + (= ($before $X $Y) + ($before $X $Y)) + + (= (@> $X $Y) + (@> $X $Y)) + + (= ($after $X $Y) + ($after $X $Y)) - (= - (ground $X) - (ground $X)) -; + (= (@=< $X $Y) + (@=< $X $Y)) + + (= ($not-after $X $Y) + ($not-after $X $Y)) + + (= (@>= $X $Y) + (@>= $X $Y)) + + (= ($not-before $X $Y) + ($not-before $X $Y)) - (= - (compound $X) - ( (nonvar $X) - (functor $X $_ $A) - (> $A 0))) -; + (= (?= $X $Y) + (?= $X $Y)) + + (= ($identical-or-cannot-unify $X $Y) + ($identical-or-cannot-unify $X $Y)) + + (= (compare $Op $X $Y) + ($compare0 $Op0 $X $Y) + ($map-compare-op $Op0 $Op)) - (= - (callable $X) - ( (atom $X) (set-det))) -; - - (= - (callable $X) - ( (compound $X) (set-det))) -; - - (= - (callable $X) - (closure $X)) -; - + (= ($map-compare-op $Op0 $Op) + (=:= $Op0 0) + (set-det) + (= $Op =)) + (= ($map-compare-op $Op0 $Op) + (< $Op0 0) + (set-det) + (= $Op <)) + (= ($map-compare-op $Op0 $Op) + (> $Op0 0) + (set-det) + (= $Op >)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Term creation and decomposition ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; :- public arg/3. --> written in Java +; +; :- public functor/3. --> written in Java - !(public (, (/ == 2) (/ %equality-of-term 2))) -; - - !(public (, (/ \== 2) (/ %inequality-of-term 2))) -; + !(public (/ =.. 2)) + !(public (/ copy-term 2)) - !(public (, (/ @< 2) (/ %before 2))) -; - - !(public (, (/ @> 2) (/ %after 2))) -; - - !(public (, (/ @=< 2) (/ %not-after 2))) -; - - !(public (, (/ @>= 2) (/ %not-before 2))) -; - - !(public (, (/ ?= 2) (/ %identical-or-cannot-unify 2))) -; + + (= (=.. $Term $List) + (=.. $Term $List)) - !(public (/ compare 3)) -; + + (= (copy-term $X $Y) + (copy-term $X $Y)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Arithmetic evaluation ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + !(public (/ is 2)) + !(public (, (/ %abs 2) (/ %asin 2) (/ %acos 2) (/ %atan 2))) + !(public (, (/ %bitwise-conj 3) (/ %bitwise-disj 3) (/ %bitwise-exclusive-or 3) (/ %bitwise-neg 2))) + !(public (, (/ %ceil 2) (/ %cos 2))) + !(public (/ %degrees 2)) + !(public (/ %exp 2)) + !(public (, (/ %float 2) (/ %float-integer-part 2) (/ %float-fractional-part 2) (/ %float-quotient 3) (/ %floor 2))) + !(public (/ %int-quotient 3)) + !(public (/ %log 2)) + !(public (, (/ %max 3) (/ %min 3) (/ %minus 3) (/ %mod 3) (/ %multi 3))) + !(public (, (/ %plus 3) (/ %pow 3))) + !(public (, (/ %radians 2) (/ %rint 2) (/ %round 2))) + !(public (, (/ %shift-left 3) (/ %shift-right 3) (/ %sign 2) (/ %sin 2) (/ %sqrt 2))) + !(public (, (/ %tan 2) (/ %truncate 2))) - (= - (== $X $Y) - (== $X $Y)) -; + (= (is $Z $Y) + (is $Z $Y)) - (= - ($equality-of-term $X $Y) - ($equality-of-term $X $Y)) -; - - + (= ($abs $X $Y) + ($abs $X $Y)) - (= - (\== $X $Y) - (\== $X $Y)) -; - + (= ($asin $X $Y) + ($asin $X $Y)) - (= - ($inequality-of-term $X $Y) - ($inequality-of-term $X $Y)) -; - - + (= ($acos $X $Y) + ($acos $X $Y)) - (= - (@< $X $Y) - (@< $X $Y)) -; - + (= ($atan $X $Y) + ($atan $X $Y)) - (= - ($before $X $Y) - ($before $X $Y)) -; - - + (= ($bitwise-conj $X $Y $Z) + ($bitwise-conj $X $Y $Z)) - (= - (@> $X $Y) - (@> $X $Y)) -; - + (= ($bitwise-disj $X $Y $Z) + ($bitwise-disj $X $Y $Z)) - (= - ($after $X $Y) - ($after $X $Y)) -; - - + (= ($bitwise-exclusive-or $X $Y $Z) + ($bitwise-exclusive-or $X $Y $Z)) - (= - (@=< $X $Y) - (@=< $X $Y)) -; - + (= ($bitwise-neg $X $Y) + ($bitwise-neg $X $Y)) - (= - ($not-after $X $Y) - ($not-after $X $Y)) -; - - + (= ($ceil $X $Y) + ($ceil $X $Y)) - (= - (@>= $X $Y) - (@>= $X $Y)) -; - + (= ($cos $X $Y) + ($cos $X $Y)) - (= - ($not-before $X $Y) - ($not-before $X $Y)) -; - - + (= ($degrees $X $Y) + ($degrees $X $Y)) - (= - (?= $X $Y) - (?= $X $Y)) -; - + (= ($exp $X $Y) + ($exp $X $Y)) - (= - ($identical-or-cannot-unify $X $Y) - ($identical-or-cannot-unify $X $Y)) -; - - + (= ($float $X $Y) + ($float $X $Y)) - (= - (compare $Op $X $Y) - ( ($compare0 $Op0 $X $Y) ($map-compare-op $Op0 $Op))) -; - - + (= ($float-integer-part $X $Y) + ($float-integer-part $X $Y)) - (= - ($map-compare-op $Op0 $Op) - ( (=:= $Op0 0) - (set-det) - (= $Op =))) -; - - (= - ($map-compare-op $Op0 $Op) - ( (< $Op0 0) - (set-det) - (= $Op <))) -; - - (= - ($map-compare-op $Op0 $Op) - ( (> $Op0 0) - (set-det) - (= $Op >))) -; - - -; -; + (= ($float-fractional-part $X $Y) + ($float-fractional-part $X $Y)) -; -; + (= ($float-quotient $X $Y $Z) + ($float-quotient $X $Y $Z)) -; -; + (= ($floor $X $Y) + ($floor $X $Y)) -; -; + (= ($int-quotient $X $Y $Z) + ($int-quotient $X $Y $Z)) -; -; + (= ($log $X $Y) + ($log $X $Y)) + (= ($max $X $Y $Z) + ($max $X $Y $Z)) - !(public (/ =.. 2)) -; - - !(public (/ copy-term 2)) -; - - + (= ($min $X $Y $Z) + ($min $X $Y $Z)) - (= - (=.. $Term $List) - (=.. $Term $List)) -; - - + (= ($minus $X $Y $Z) + ($minus $X $Y $Z)) - (= - (copy-term $X $Y) - (copy-term $X $Y)) -; - - -; -; + (= ($mod $X $Y $Z) + ($mod $X $Y $Z)) -; -; + (= ($multi $X $Y $Z) + ($multi $X $Y $Z)) -; -; + (= ($plus $X $Y $Z) + ($plus $X $Y $Z)) + (= ($pow $X $Y $Z) + ($pow $X $Y $Z)) - !(public (/ is 2)) -; - - !(public (, (/ %abs 2) (/ %asin 2) (/ %acos 2) (/ %atan 2))) -; - - !(public (, (/ %bitwise-conj 3) (/ %bitwise-disj 3) (/ %bitwise-exclusive-or 3) (/ %bitwise-neg 2))) -; - - !(public (, (/ %ceil 2) (/ %cos 2))) -; - - !(public (/ %degrees 2)) -; - - !(public (/ %exp 2)) -; - - !(public (, (/ %float 2) (/ %float-integer-part 2) (/ %float-fractional-part 2) (/ %float-quotient 3) (/ %floor 2))) -; - - !(public (/ %int-quotient 3)) -; - - !(public (/ %log 2)) -; - - !(public (, (/ %max 3) (/ %min 3) (/ %minus 3) (/ %mod 3) (/ %multi 3))) -; - - !(public (, (/ %plus 3) (/ %pow 3))) -; - - !(public (, (/ %radians 2) (/ %rint 2) (/ %round 2))) -; - - !(public (, (/ %shift-left 3) (/ %shift-right 3) (/ %sign 2) (/ %sin 2) (/ %sqrt 2))) -; - - !(public (, (/ %tan 2) (/ %truncate 2))) -; - - + (= ($radians $X $Y) + ($radians $X $Y)) - (= - (is $Z $Y) - (is $Z $Y)) -; - - + (= ($rint $X $Y) + ($rint $X $Y)) - (= - ($abs $X $Y) - ($abs $X $Y)) -; - + (= ($round $X $Y) + ($round $X $Y)) - (= - ($asin $X $Y) - ($asin $X $Y)) -; - + (= ($shift-left $X $Y $Z) + ($shift-left $X $Y $Z)) - (= - ($acos $X $Y) - ($acos $X $Y)) -; - + (= ($shift-right $X $Y $Z) + ($shift-right $X $Y $Z)) - (= - ($atan $X $Y) - ($atan $X $Y)) -; - + (= ($sign $X $Y) + ($sign $X $Y)) - (= - ($bitwise-conj $X $Y $Z) - ($bitwise-conj $X $Y $Z)) -; - + (= ($sin $X $Y) + ($sin $X $Y)) - (= - ($bitwise-disj $X $Y $Z) - ($bitwise-disj $X $Y $Z)) -; - + (= ($sqrt $X $Y) + ($sqrt $X $Y)) - (= - ($bitwise-exclusive-or $X $Y $Z) - ($bitwise-exclusive-or $X $Y $Z)) -; - + (= ($tan $X $Y) + ($tan $X $Y)) - (= - ($bitwise-neg $X $Y) - ($bitwise-neg $X $Y)) -; + (= ($truncate $X $Y) + ($truncate $X $Y)) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Arithmetic comparison +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - ($ceil $X $Y) - ($ceil $X $Y)) -; + !(public (, (/ =:= 2) (/ %arith-equal 2))) + !(public (, (/ =\= 2) (/ %arith-not-equal 2))) + !(public (, (/ < 2) (/ %less-than 2))) + !(public (, (/ =< 2) (/ %less-or-equal 2))) + !(public (, (/ > 2) (/ %greater-than 2))) + !(public (, (/ >= 2) (/ %greater-or-equal 2))) - (= - ($cos $X $Y) - ($cos $X $Y)) -; - + (= (=:= $X $Y) + (=:= $X $Y)) - (= - ($degrees $X $Y) - ($degrees $X $Y)) -; + (= ($arith-equal $X $Y) + ($arith-equal $X $Y)) - (= - ($exp $X $Y) - ($exp $X $Y)) -; + (= (=\= $X $Y) + (=\= $X $Y)) + + (= ($arith-not-equal $X $Y) + ($arith-not-equal $X $Y)) - (= - ($float $X $Y) - ($float $X $Y)) -; + (= (< $X $Y) + (< $X $Y)) + + (= ($less-than $X $Y) + ($less-than $X $Y)) - (= - ($float-integer-part $X $Y) - ($float-integer-part $X $Y)) -; + (= (=< $X $Y) + (=< $X $Y)) + + (= ($less-or-equal $X $Y) + ($less-or-equal $X $Y)) - (= - ($float-fractional-part $X $Y) - ($float-fractional-part $X $Y)) -; + (= (> $X $Y) + (> $X $Y)) + + (= ($greater-than $X $Y) + ($greater-than $X $Y)) - (= - ($float-quotient $X $Y $Z) - ($float-quotient $X $Y $Z)) -; + (= (>= $X $Y) + (>= $X $Y)) + + (= ($greater-or-equal $X $Y) + ($greater-or-equal $X $Y)) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Clause retrieval and information +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - ($floor $X $Y) - ($floor $X $Y)) -; + !(public (/ clause 2)) + !(public (/ initialization 2)) + !(public (/ %new-indexing-hash 3)) - (= - ($int-quotient $X $Y $Z) - ($int-quotient $X $Y $Z)) -; + (= (== (= $Head $B) (get-atoms &self)) + ($head-to-term $Head $H + (with_self $P $PI) + (== + (= $Head $B) + (get-atoms &self))) + ($new-internal-database $P) + ($check-procedure-permission + (with_self $P $PI) access private-procedure + (== + (= $Head $B) + (get-atoms &self))) + ($clause-internal $P $PI $H $Cl $_) + (copy-term $Cl + (= $H $B))) +; ;(ground(Cl) -> Cl = (H :- B) ; copy_term(Cl, (H :- B))). ??? + +; +; head --> term + + (= ($head-to-term $H $T (with_self $Pkg (/ $F $A)) $Goal) + ($head-to-term $H $T user $Pkg $Goal) + (functor $T $F $A)) + + (= ($head-to-term $H $_ $_ $_ $Goal) + (var $H) + (set-det) + (illarg var $Goal 1)) + (= ($head-to-term (with_self $P $H) $T $_ $Pkg $Goal) + (set-det) + ($head-to-term $H $T $P $Pkg $Goal)) + (= ($head-to-term $H $H $Pkg $Pkg $_) + (callable $H) + (atom $Pkg) + (set-det)) + (= ($head-to-term $_ $_ $_ $_ $Goal) + (illarg + (type callable) $Goal 1)) +; +; creates an internal database for A if no exists. - (= - ($log $X $Y) - ($log $X $Y)) -; + (= ($new-internal-database $A) + (atom $A) + ($get-hash-manager $HM) + ($new-internal-database $HM $A)) + + (= ($new-internal-database $HM $A) + (hash-contains-key $HM $A) + (set-det)) + (= ($new-internal-database $_ $A) + (new-hash $_ + (:: (alias $A))) + ($init-internal-database $A)) - (= - ($max $X $Y $Z) - ($max $X $Y $Z)) -; + (= ($init-internal-database $A) + ($compiled-predicate $A %init 0) + (findall $_ + (with_self $A + (%init)) $_) + (set-det)) + (= (%init_internal_database $_) True) +; +; checks if the internal database of A exists. - (= - ($min $X $Y $Z) - ($min $X $Y $Z)) -; + (= ($defined-internal-database $A) + (atom $A) + ($get-hash-manager $HM) + (hash-contains-key $HM $A)) +; +; repeatedly finds dynamic clauses. - (= - ($minus $X $Y $Z) - ($minus $X $Y $Z)) -; + (= ($clause-internal $P $PI $H $Cl $Ref) + (hash-contains-key $P $PI) + ($get-indices $P $PI $H $RevRefs) + ($get-instances $RevRefs $Cls_Refs) + ($clause-internal0 $Cls_Refs $Cl $Ref)) +; ; ??? +; ;length(Cls_Refs,N), +; ;'$fast_write'([clause_internal,N,for,P,PI]),nl, +; ; - (= - ($mod $X $Y $Z) - ($mod $X $Y $Z)) -; + (= (%clause_internal0 () $_ $_) + (empty)) + (= ($clause-internal0 (:: (, $Cl $Ref)) $Cl $Ref) + (set-det)) + (= ($clause-internal0 $L $Cl $Ref) + ($builtin-member + (, $Cl $Ref) $L)) + + + (= ($get-indices $P $PI $H $Refs) + ($new-indexing-hash $P $PI $IH) + ($calc-indexing-key $H $Key) + (det-if-then-else + (hash-contains-key $IH $Key) + (hash-get $IH $Key $Refs) + (hash-get $IH var $Refs))) + +; +; finds the indexing hashtable for P:PI. creates it if no exist. + + (= ($new-indexing-hash $P $PI $IH) + (hash-contains-key $P $PI) + (set-det) + (hash-get $P $PI $IH)) + (= ($new-indexing-hash $P $PI $IH) + (new-hash $IH) + (hash-put $IH all Nil) + (hash-put $IH var Nil) + (hash-put $IH lis Nil) + (hash-put $IH str Nil) + (hash-put $P $PI $IH)) + + + (= ($calc-indexing-key $H all) + (atom $H) + (set-det)) + (= ($calc-indexing-key $H $Key) + (arg 1 $H $A1) + ($calc-indexing-key0 $A1 $Key)) + + + (= ($calc-indexing-key0 $A1 all) + (var $A1) + (set-det)) + (= ($calc-indexing-key0 $A1 lis) + (= $A1 + (Cons $_ $_)) + (set-det)) + (= ($calc-indexing-key0 $A1 str) + (compound $A1) + (set-det)) + (= ($calc-indexing-key0 $A1 $Key) + (ground $A1) + (set-det) + ($term-hash $A1 $Key)) + (= ($calc-indexing-key0 $A1 $Key) + (illarg + (type term) + ($calc-indexing-key0 $A1 $Key) 1)) +; +; checks the permission of predicate P:F/A. - (= - ($multi $X $Y $Z) - ($multi $X $Y $Z)) -; + (= ($check-procedure-permission (with_self $P (/ $F $A)) $Operation $ObjType $Goal) + (hash-contains-key $P + (/ $F $A)) + (set-det)) + (= ($check-procedure-permission (with_self $P (/ $F $A)) $Operation $ObjType $Goal) + ($compiled-predicate-or-builtin $P $F $A) + (set-det) + (illarg + (permission $Operation $ObjType + (with_self $P + (/ $F $A)) $_) $Goal $_)) + (= (%check_procedure_permission $_ $_ $_ $_) True) +; +; initialize internal databases of given packages. - (= - ($plus $X $Y $Z) - ($plus $X $Y $Z)) -; + (= (initialization Nil $Goal) + (set-det) + (once $Goal)) + (= (initialization (Cons $P $Ps) $Goal) + ($new-internal-database $P) + (initialization $Ps $Goal)) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Clause creation and destruction +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - ($pow $X $Y $Z) - ($pow $X $Y $Z)) -; + !(public (/ assert 1)) + !(public (/ assertz 1)) + !(public (/ asserta 1)) + !(public (/ retract 1)) + !(public (/ abolish 1)) + !(public (/ retractall 1)) - (= - ($radians $X $Y) - ($radians $X $Y)) -; + (= (add-is-symbol &self $T) + (add-is-symbol &self $T)) - (= - ($rint $X $Y) - ($rint $X $Y)) -; + (= (add-is-symbol &self $T) + ($term-to-clause $T $Cl + (with_self $P $PI) + (add-is-symbol &self $T)) + ($new-internal-database $P) + ($check-procedure-permission + (with_self $P $PI) modify static-procedure + (add-is-symbol &self $T)) + (copy-term $Cl $NewCl) + ($insert $NewCl $Ref) + ($update-indexing $P $PI $Cl $Ref z) + (fail)) +; ;'$fast_write'([intert,NewCl,Ref]), nl, ;??? + (= (assertz $_) True) + + + (= (add-is-symbol &self $T) + ($term-to-clause $T $Cl + (with_self $P $PI) + (add-is-symbol &self $T)) + ($new-internal-database $P) + ($check-procedure-permission + (with_self $P $PI) modify static-procedure + (add-is-symbol &self $T)) + (copy-term $Cl $NewCl) + ($insert $NewCl $Ref) + ($update-indexing $P $PI $Cl $Ref a) + (fail)) +; ;'$fast_write'([insert,NewCl,Ref]), nl, ;??? + (= (asserta $_) True) - (= - ($round $X $Y) - ($round $X $Y)) -; + (= (abolish $T) + ($term-to-predicateindicator $T + (with_self $P $PI) + (abolish $T)) + ($new-internal-database $P) + ($check-procedure-permission + (with_self $P $PI) modify static-procedure + (abolish $T)) + ($new-indexing-hash $P $PI $IH) + (hash-get $IH all $Refs) + ($erase-all $Refs) + (hash-remove $P $PI) + (fail)) +; ;'$fast_write'([erase_all,Refs]), nl, ;??? + (= (abolish $_) True) + + + (= (remove-is-symbol &self $Cl) + ($clause-to-term $Cl $T + (with_self $P $PI) + (remove-is-symbol &self $Cl)) + ($new-internal-database $P) + ($check-procedure-permission + (with_self $P $PI) access static-procedure + (remove-is-symbol &self $Cl)) + (= $T + (= $H $_)) + ($clause-internal $P $PI $H $Cl0 $Ref) + (copy-term $Cl0 $T) + ($erase $Ref) + ($rehash-indexing $P $PI $Ref)) +; ;'$fast_write'([erase,Cl0,Ref]), nl, ;??? + + + (= (remove-all-atoms &self $Head) + ($head-to-term $Head $H + (with_self $P $PI) + (remove-all-atoms &self $Head)) + ($new-internal-database $P) + ($check-procedure-permission + (with_self $P $PI) access static-procedure + (remove-all-atoms &self $Head)) + ($clause-internal $P $PI $H $Cl $Ref) + (copy-term $Cl + (= $H $_)) + ($erase $Ref) + ($rehash-indexing $P $PI $Ref) + (fail)) +; ;'$fast_write'([erase,Cl,Ref]), nl, ;??? + (= (retractall $_) True) + +; +; term --> clause (for assert) + + (= ($term-to-clause $Cl0 $Cl (with_self $Pkg (/ $F $A)) $Goal) + ($term-to-clause $Cl0 $Cl user $Pkg $Goal) + (= $Cl + (= $H $_)) + (functor $H $F $A)) + + (= ($term-to-clause $Cl0 $_ $_ $_ $Goal) + (var $Cl0) + (set-det) + (illarg var $Goal 1)) + (= ($term-to-clause $_ $_ $Pkg0 $_ $Goal) + (var $Pkg0) + (set-det) + (illarg var $Goal 1)) + (= ($term-to-clause (with_self $P $Cl0) $Cl $_ $Pkg $Goal) + (set-det) + ($term-to-clause $Cl0 $Cl $P $Pkg $Goal)) + (= ($term-to-clause $_ $_ $Pkg0 $_ $Goal) + (not (atom $Pkg0)) + (set-det) + (illarg + (type is-symbol) $Goal 1)) + (= ($term-to-clause (= $H0 $B0) (= $H $B) $Pkg $Pkg $Goal) + (set-det) + ($term-to-head $H0 $H $Pkg $Goal) + ($term-to-body $B0 $B $Pkg $Goal)) + (= ($term-to-clause $H0 (= $H True) $Pkg $Pkg $Goal) + ($term-to-head $H0 $H $Pkg $Goal)) + + + (= ($term-to-head $H $H $_ $_) + (atom $H) + (set-det)) + (= ($term-to-head $H $H $_ $_) + (compound $H) + (set-det)) + (= ($term-to-head $_ $_ $_ $Goal) + (illarg + (type callable) $Goal 1)) - (= - ($shift-left $X $Y $Z) - ($shift-left $X $Y $Z)) -; + (= ($term-to-body $B0 $B $Pkg $_) + ($localize-body $B0 $Pkg $B)) - (= - ($shift-right $X $Y $Z) - ($shift-right $X $Y $Z)) -; + (= ($localize-body $G $P $G1) + (var $G) + (set-det) + ($localize-body + (call $G) $P $G1)) + (= ($localize-body (with_self $P $G) $_ $G1) + (set-det) + ($localize-body $G $P $G1)) + (= ($localize-body (, $X $Y) $P (, $X1 $Y1)) + (set-det) + ($localize-body $X $P $X1) + ($localize-body $Y $P $Y1)) + (= ($localize-body (det-if-then $X $Y) $P (det-if-then $X1 $Y1)) + (set-det) + ($localize-body $X $P $X1) + ($localize-body $Y $P $Y1)) + (= ($localize-body (or $X $Y) $P (or $X1 $Y1)) + (set-det) + ($localize-body $X $P $X1) + ($localize-body $Y $P $Y1)) + (= ($localize-body $G $P $G1) + (functor $G $F $A) + ($builtin-meta-predicates $F $A $M) + (set-det) + (=.. $G + (Cons $F $As)) + ($localize-args $M $As $P $As1) + (=.. $G1 + (Cons $F $As1))) +; ;??? + (= ($localize-body $G $P (call (with_self $P $G))) + (var $P) + (set-det)) + (= ($localize-body $G user $G) + (set-det)) + (= ($localize-body $G $_ $G) + (system-predicate $G) + (set-det)) + (= (%localize_body $G $P (: $P $G)) True) + + + (= ($localize-args Nil Nil $_ Nil) + (set-det)) + (= ($localize-args (Cons : $Ms) (Cons $A $As) $P (Cons (with_self $P $A) $As1)) + (or + (var $A) + (\= $A + (with_self $_ $_))) + (set-det) + ($localize-args $Ms $As $P $As1)) + (= ($localize-args (Cons $_ $Ms) (Cons $A $As) $P (Cons $A $As1)) + ($localize-args $Ms $As $P $As1)) + + + (= (%builtin_meta_predicates ^ 2 (? :)) True) + (= (%builtin_meta_predicates call 1 (:)) True) + (= (%builtin_meta_predicates once 1 (:)) True) + (= (%builtin_meta_predicates \+ 1 (:)) True) + (= (%builtin_meta_predicates findall 3 (? : ?)) True) + (= (%builtin_meta_predicates setof 3 (? : ?)) True) + (= (%builtin_meta_predicates bagof 3 (? : ?)) True) + (= (%builtin_meta_predicates on_exception 3 (? : :)) True) + (= (%builtin_meta_predicates catch 3 (: ? :)) True) + (= (%builtin_meta_predicates synchronized 2 (? :)) True) + (= (%builtin_meta_predicates freeze 2 (? :)) True) + +; +; clause --> term (for retract) + + (= ($clause-to-term $Cl $T (with_self $Pkg (/ $F $A)) $Goal) + ($clause-to-term $Cl $T user $Pkg $Goal) + (= $T + (= $H $_)) + (functor $H $F $A)) + + (= ($clause-to-term $Cl $_ $_ $_ $Goal) + (var $Cl) + (set-det) + (illarg var $Goal 1)) + (= ($clause-to-term $_ $_ $Pkg $_ $Goal) + (var $Pkg) + (set-det) + (illarg var $Goal 1)) + (= ($clause-to-term (with_self $P $Cl) $T $_ $Pkg $Goal) + (set-det) + ($clause-to-term $Cl $T $P $Pkg $Goal)) + (= ($clause-to-term $_ $_ $Pkg $_ $Goal) + (not (atom $Pkg)) + (set-det) + (illarg + (type is-symbol) $Goal 1)) + (= ($clause-to-term (= $H0 $B) (= $H $B) $Pkg $Pkg $Goal) + (set-det) + ($head-to-term $H0 $H $_ $Goal)) + ; +; '$body_to_term'(B0, B, Goal). + (= ($clause-to-term $H0 (= $H True) $Pkg $Pkg $Goal) + ($head-to-term $H0 $H $_ $Goal)) + +; +; term --> predicate indicator (for abolish) + + (= ($term-to-predicateindicator $T (with_self $Pkg $PI) $Goal) + ($term-to-predicateindicator $T $PI user $Pkg $Goal)) + + (= ($term-to-predicateindicator $T $_ $_ $_ $Goal) + (var $T) + (set-det) + (illarg var $Goal 1)) + (= ($term-to-predicateindicator $_ $_ $Pkg $_ $Goal) + (var $Pkg) + (set-det) + (illarg var $Goal 1)) + (= ($term-to-predicateindicator (with_self $P $T) $PI $_ $Pkg $Goal) + (set-det) + ($term-to-predicateindicator $T $PI $P $Pkg $Goal)) + (= ($term-to-predicateindicator $T $_ $_ $_ $Goal) + (\= $T + (/ $_ $_)) + (set-det) + (illarg + (type predicate-indicator) $Goal 1)) + (= ($term-to-predicateindicator (/ $F $_) $_ $_ $_ $Goal) + (not (atom $F)) + (set-det) + (illarg + (type is-symbol) $Goal 1)) + (= ($term-to-predicateindicator (/ $_ $A) $_ $_ $_ $Goal) + (not (integer $A)) + (set-det) + (illarg + (type integer) $Goal 1)) + (= (%term_to_predicateindicator $T $T $Pkg $Pkg $_) True) + + + (= ($update-indexing $P $PI $Cl $Ref $A_or_Z) + ($new-indexing-hash $P $PI $IH) + ($gen-indexing-keys $Cl $IH $Keys) + ($update-indexing-hash $A_or_Z $Keys $IH $Ref)) +; ;'$fast_write'([update_indexing,P,PI,Cl,Ref,Keys]), nl, ;??? + + + (= ($gen-indexing-keys (= $H $_) $_ (:: all)) + (atom $H) + (set-det)) + (= ($gen-indexing-keys (= $H $_) $IT $Keys) + (arg 1 $H $A1) + ($gen-indexing-keys0 $A1 $IT $Keys)) + + + (= ($gen-indexing-keys0 $A1 $IT $Keys) + (var $A1) + (set-det) + (hash-keys $IT $Keys)) + (= ($gen-indexing-keys0 $A1 $_ (:: all lis)) + (= $A1 + (Cons $_ $_)) + (set-det)) + (= ($gen-indexing-keys0 $A1 $_ (:: all str)) + (compound $A1) + (set-det)) + (= ($gen-indexing-keys0 $A1 $IT (:: all $Key)) + (ground $A1) + (set-det) + ($term-hash $A1 $Key) + (det-if-then-else + (hash-contains-key $IT $Key) True + (, + (hash-get $IT var $L) + (hash-put $IT $Key $L)))) +; ; get the hash code of A1 + (= ($gen-indexing-keys0 $A1 $IT $Keys) + (illarg + (type term) + ($gen-indexing-keys0 $A1 $IT $Keys) 1)) - (= - ($sign $X $Y) - ($sign $X $Y)) -; + (= ($update-indexing-hash a $Keys $IH $Ref) + (set-det) + ($hash-addz-all $Keys $IH $Ref)) + (= ($update-indexing-hash z $Keys $IH $Ref) + (set-det) + ($hash-adda-all $Keys $IH $Ref)) - (= - ($sin $X $Y) - ($sin $X $Y)) -; + (= ($hash-adda-all Nil $_ $_) + (set-det)) + (= ($hash-adda-all (Cons $K $Ks) $H $X) + ($hash-adda $H $K $X) + ($hash-adda-all $Ks $H $X)) - (= - ($sqrt $X $Y) - ($sqrt $X $Y)) -; + (= ($hash-addz-all Nil $_ $_) + (set-det)) + (= ($hash-addz-all (Cons $K $Ks) $H $X) + ($hash-addz $H $K $X) + ($hash-addz-all $Ks $H $X)) - (= - ($tan $X $Y) - ($tan $X $Y)) -; + (= ($erase-all Nil) + (set-det)) + (= ($erase-all (Cons $R $Rs)) + ($erase $R) + ($erase-all $Rs)) - (= - ($truncate $X $Y) - ($truncate $X $Y)) -; + (= ($rehash-indexing $P $PI $Ref) + ($new-indexing-hash $P $PI $IH) + (hash-keys $IH $Keys) + ($remove-index-all $Keys $IH $Ref)) +; ;'$fast_write'([rehash_indexing,P,PI,Keys]), nl, ;??? + + (= ($remove-index-all Nil $_ $_) + (set-det)) + (= ($remove-index-all (Cons $K $Ks) $IH $Ref) + ($hash-remove-first $IH $K $Ref) + ($remove-index-all $Ks $IH $Ref)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; All solutions ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - !(public (, (/ =:= 2) (/ %arith-equal 2))) -; - - !(public (, (/ =\= 2) (/ %arith-not-equal 2))) -; - - !(public (, (/ < 2) (/ %less-than 2))) -; - - !(public (, (/ =< 2) (/ %less-or-equal 2))) -; - - !(public (, (/ > 2) (/ %greater-than 2))) -; - - !(public (, (/ >= 2) (/ %greater-or-equal 2))) -; - + !(public (/ findall 3)) + !(public (/ bagof 3)) + !(public (/ setof 3)) +; +; findall/3 - (= - (=:= $X $Y) - (=:= $X $Y)) -; + (= (findall $Template $Goal $Instances) + (callable $Goal) + (set-det) + (new-hash $H) + ($findall $H $Template $Goal $Instances)) + (= (findall $Template $Goal $Instances) + (illarg + (type callable) + (findall $Template $Goal $Instances) 2)) - (= - ($arith-equal $X $Y) - ($arith-equal $X $Y)) -; + (= ($findall $H $Template $Goal $_) + (call $Goal) + (copy-term $Template $CT) + ($hash-addz $H %FINDALL $CT) + (fail)) + (= ($findall $H $_ $_ $Instances) + (hash-get $H %FINDALL $Instances)) +; +; bagof/3 & setof/3 + + (= (bagof $Template $Goal $Instances) + (callable $Goal) + (set-det) + ($bagof $Template $Goal $Instances)) + (= (bagof $Template $Goal $Instances) + (illarg + (type callable) + (bagof $Template $Goal $Instances) 2)) - (= - (=\= $X $Y) - (=\= $X $Y)) -; - + (= (setof $Template $Goal $Instances) + (callable $Goal) + (set-det) + ($bagof $Template $Goal $Instances0) + (sort $Instances0 $Instances)) + (= (setof $Template $Goal $Instances) + (illarg + (type callable) + (setof $Template $Goal $Instances) 2)) + + + (= ($bagof $Template $Goal $Instances) + ($free-variables-set $Goal $Template $FV) + (\== $FV Nil) + (set-det) + (=.. $Witness + (Cons %witness $FV)) + (findall + (+ $Witness $Template) $Goal $S) + ($bagof-instances $S $Witness $Instances0) + (= $Instances $Instances0)) +; ;write('Goal = '), write(Goal), nl, +; ;write('Free variables set = '), write(FV), nl, + (= ($bagof $Template $Goal $Instances) + (findall $Template $Goal $Instances) + (\== $Instances Nil)) + + + (= (%bagof_instances () $Witness $Instances) + (empty)) + (= ($bagof-instances $S0 $Witness $Instances) + (= $S0 + (Cons + (+ $W $T) $S)) + ($variants-subset $S $W $WT_list $T_list $S_next) + ($bagof-instances0 $S_next $Witness $Instances + (Cons + (+ $W $T) $WT_list) + (Cons $T $T_list))) + + + (= ($bagof-instances0 $_ $Witness $Instances $WT_list $T_list) + ($unify-witness $WT_list $Witness) + (= $Instances $T_list)) + (= ($bagof-instances0 $S_next $Witness $Instances $_ $_) + ($bagof-instances $S_next $Witness $Instances)) + + + (= ($variants-subset Nil $W Nil Nil Nil) + (set-det)) + (= ($variants-subset (Cons (+ $W0 $T0) $S) $W (Cons (+ $W0 $T0) $WT_list) (Cons $T0 $T_list) $S_next) + ($term-variant $W $W0) + (set-det) + ($variants-subset $S $W $WT_list $T_list $S_next)) + (= ($variants-subset (Cons $WT $S) $W $WT_list $T_list (Cons $WT $S_next)) + ($variants-subset $S $W $WT_list $T_list $S_next)) + + + (= ($term-variant $X $Y) + (new-hash $Hash) + ($term-variant $X $Y $Hash)) + + (= ($term-variant $X $Y $Hash) + (var $X) + (set-det) + (det-if-then-else + (hash-contains-key $Hash $X) + (, + (hash-get $Hash $X $V) + (== $Y $V)) + (, + (var $Y) + (hash-put $Hash $X $Y)))) + (= ($term-variant $X $Y $_) + (ground $X) + (set-det) + (== $X $Y)) + (= ($term-variant $_ $Y $_) + (var $Y) + (set-det) + (fail)) + (= ($term-variant (Cons $X $Xs) (Cons $Y $Ys) $Hash) + (set-det) + ($term-variant $X $Y $Hash) + ($term-variant $Xs $Ys $Hash)) + (= ($term-variant $X $Y $Hash) + (=.. $X $Xs) + (=.. $Y $Ys) + ($term-variant $Xs $Ys $Hash)) + + + (= ($unify-witness Nil $_) + (set-det)) + (= ($unify-witness (Cons (+ $W $_) $WT_list) $W) + ($unify-witness $WT_list $W)) + +; +; Variable set of a term + + (= ($variables-set $X $Vs) + ($variables-set $X Nil $Vs)) + + (= ($variables-set $X $Vs $Vs) + (var $X) + ($builtin-memq $X $Vs) + (set-det)) + (= ($variables-set $X $Vs (Cons $X $Vs)) + (var $X) + (set-det)) + (= ($variables-set $X $Vs0 $Vs0) + (atomic $X) + (set-det)) + (= ($variables-set (Cons $X $Xs) $Vs0 $Vs) + (set-det) + ($variables-set $X $Vs0 $Vs1) + ($variables-set $Xs $Vs1 $Vs)) + (= ($variables-set $X $Vs0 $Vs) + (=.. $X $Xs) + ($variables-set $Xs $Vs0 $Vs)) + + + (= ($builtin-memq $X (Cons $Y $_)) + (== $X $Y) + (set-det)) + (= ($builtin-memq $X (Cons $_ $Ys)) + ($builtin-memq $X $Ys)) + +; +; Existential variables set of a term + + (= ($existential-variables-set $X $Vs) + ($existential-variables-set $X Nil $Vs)) + + (= ($existential-variables-set $X $Vs $Vs) + (var $X) + (set-det)) + (= ($existential-variables-set $X $Vs $Vs) + (atomic $X) + (set-det)) + (= ($existential-variables-set (with_self $_ $X) $Vs0 $Vs) + (set-det) + ($existential-variables-set $X $Vs0 $Vs)) +; +; '$existential_variables_set'((X;Y), Vs0, Vs) :- !, +; +; '$existential_variables_set'(X, Vs0, Vs1), +; +; '$existential_variables_set'(Y, Vs1, Vs). +; +; '$existential_variables_set'((X->Y), Vs0, Vs) :- !, +; +; '$existential_variables_set'(X, Vs0, Vs1), +; +; '$existential_variables_set'(Y, Vs1, Vs). +; +; '$existential_variables_set'((X,Y), Vs0, Vs) :- !, +; +; '$existential_variables_set'(X, Vs0, Vs1), +; +; '$existential_variables_set'(Y, Vs1, Vs). + (= ($existential-variables-set (^ $V $G) $Vs0 $Vs) + (set-det) + ($variables-set $V $Vs0 $Vs1) + ($existential-variables-set $G $Vs1 $Vs)) + (= ($existential-variables-set ($meta-call $G $_ $_ $_ $_) $Vs0 $Vs) + (set-det) + ($existential-variables-set $G $Vs0 $Vs)) +; ;??? + (= (%existential_variables_set $_ $Vs $Vs) True) + +; +; Free variables set of a term + + (= ($free-variables-set $T $V $FV) + ($variables-set $T $TV) + ($variables-set $V $VV) + ($existential-variables-set $T $VV $BV) + ($builtin-set-diff $TV $BV $FV) + (set-det)) + + + (= ($builtin-set-diff $L1 $L2 $L) + (sort $L1 $SL1) + (sort $L2 $SL2) + ($builtin-set-diff0 $SL1 $SL2 $L)) + - (= - ($arith-not-equal $X $Y) - ($arith-not-equal $X $Y)) -; - + (= ($builtin-set-diff0 Nil $_ Nil) + (set-det)) + (= ($builtin-set-diff0 $L1 Nil $L1) + (set-det)) + (= ($builtin-set-diff0 (Cons $X $Xs) (Cons $Y $Ys) $L) + (== $X $Y) + (set-det) + ($builtin-set-diff0 $Xs $Ys $L)) + (= ($builtin-set-diff0 (Cons $X $Xs) (Cons $Y $Ys) (Cons $X $L)) + (@< $X $Y) + (set-det) + ($builtin-set-diff0 $Xs + (Cons $Y $Ys) $L)) + (= ($builtin-set-diff0 (Cons $X $Xs) (Cons $Y $Ys) (Cons $Y $L)) + ($builtin-set-diff0 + (Cons $X $Xs) $Ys + (Cons $Y $L))) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Stream selection and control +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; :- public current_input/1 (written in Java) +; +; :- public current_output/1 (written in Java) +; +; :- public set_input/1, set_output/1. (written in Java) +; +; :- public open/4 (written in Java) - (= - (< $X $Y) - (< $X $Y)) -; + !(public (/ open 3)) +; +; :- public close/2 (written in Java) + !(public (/ close 1)) +; +; :- public flush_output/1.(written in Java) + !(public (/ flush-output 0)) + !(public (/ stream-property 2)) - (= - ($less-than $X $Y) - ($less-than $X $Y)) -; - + (= (open $Source_sink $Mode $Stream) + (open $Source_sink $Mode $Stream Nil)) - (= - (=< $X $Y) - (=< $X $Y)) -; + (= (close $S_or_a) + (close $S_or_a Nil)) - (= - ($less-or-equal $X $Y) - ($less-or-equal $X $Y)) -; + (= (flush-output) + (current-output $S) + (flush-output $S)) + + (= (stream-property $Stream $Stream_property) + (var $Stream_property) + (set-det) + ($stream-property $Stream $Stream_property)) + (= (stream-property $Stream $Stream_property) + ($stream-property-specifier $Stream_property) + (set-det) + ($stream-property $Stream $Stream_property)) + (= (stream-property $Stream $Stream_property) + (illarg + (domain term stream-property) + (stream-property $Stream $Stream_property) 2)) - (= - (> $X $Y) - (> $X $Y)) -; + (= ($stream-property $Stream $Stream_property) + (var $Stream) + (set-det) + ($get-stream-manager $SM) + (hash-map $SM $Map) + ($builtin-member + (, $Stream $Vs) $Map) + (java $Stream) + ($builtin-member $Stream_property $Vs)) + (= ($stream-property $Stream $Stream_property) + (java $Stream) + (set-det) + ($get-stream-manager $SM) + (hash-get $SM $Stream $Vs) + ($builtin-member $Stream_property $Vs)) + (= ($stream-property $Stream $Stream_property) + (illarg + (domain stream stream) + (stream-property $Stream $Stream_property) 1)) - (= - ($greater-than $X $Y) - ($greater-than $X $Y)) -; + (= (%stream_property_specifier input) True) + (= (%stream_property_specifier output) True) + (= (%stream_property_specifier (alias $_)) True) + (= (%stream_property_specifier (mode $_)) True) + (= (%stream_property_specifier (type $_)) True) + (= (%stream_property_specifier (file_name $_)) True) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Character input/output +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; :- public get_char/2, get_code/2. (written in Java) +; +; :- public peek_char/2, peek_code/2. (written in Java) +; +; :- public put_char/2, put_code/2. (written in Java) +; +; :- public nl/0. (written in Java) - (= - (>= $X $Y) - (>= $X $Y)) -; + !(public (, (/ get-char 1) (/ get-code 1))) + !(public (, (/ peek-char 1) (/ peek-code 1))) + !(public (, (/ put-char 1) (/ put-code 1))) + !(public (/ nl 1)) - (= - ($greater-or-equal $X $Y) - ($greater-or-equal $X $Y)) -; - + (= (get-char $Char) + (current-input $S) + (get-char $S $Char)) + + (= (get-code $Code) + (current-input $S) + (get-code $S $Code)) -; -; -; -; + (= (peek-char $Char) + (current-input $S) + (peek-char $S $Char)) -; -; + (= (peek-code $Code) + (current-input $S) + (peek-code $S $Code)) + + (= (put-char $Char) + (current-output $S) + (put-char $S $Char)) - !(public (/ clause 2)) -; - - !(public (/ initialization 2)) -; - - !(public (/ %new-indexing-hash 3)) -; - + (= (put-code $Code) + (current-output $S) + (put-code $S $Code)) - (= - (get-symbols &self - (= $Head $B)) - ( ($head-to-term $Head $H - (with_self $P $PI) - (get-symbols &self - (= $Head $B))) - ($new-internal-database $P) - ($check-procedure-permission - (with_self $P $PI) access private-procedure - (get-symbols &self - (= $Head $B))) - ($clause-internal $P $PI $H $Cl $_) - (copy-term $Cl - (= $H $B)))) -; - + (= (nl $S) + (put-char $S +)) -; -; - - (= - ($head-to-term $H $T - (with_self $Pkg - (/ $F $A)) $Goal) - ( ($head-to-term $H $T user $Pkg $Goal) (functor $T $F $A))) -; - + !(public (, (/ get0 1) (/ get0 2))) + !(public (/ get 1)) +; +; :- public get/2. (written in Java) + !(public (, (/ put 1) (/ put 2))) + !(public (/ tab 1)) +; +; :- public tab/2. (written in Java) + !(public (/ skip 1)) +; +; :- public skip/2. (written in Java) - (= - ($head-to-term $H $_ $_ $_ $Goal) - ( (var $H) - (set-det) - (illarg var $Goal 1))) -; + + (= (get0 $Code) + (current-input $S) + (get-code $S $Code)) + (= (get0 $S_or_a $Code) + (get-code $S_or_a $Code)) - (= - ($head-to-term - (with_self $P $H) $T $_ $Pkg $Goal) - ( (set-det) ($head-to-term $H $T $P $Pkg $Goal))) -; + + (= (get $Code) + (current-input $S) + (get $S $Code)) - (= - ($head-to-term $H $H $Pkg $Pkg $_) - ( (callable $H) - (atom $Pkg) - (set-det))) -; + + (= (put $Exp) + (current-output $S) + (put $S $Exp)) + (= (put $S_or_a $Exp) + (is $Code $Exp) + (put-code $S_or_a $Code)) - (= - ($head-to-term $_ $_ $_ $_ $Goal) - (illarg - (type callable) $Goal 1)) -; + + (= (tab $N) + (current-output $S) + (tab $S $N)) + + (= (skip $N) + (current-input $S) + (skip $S $N)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Byte input/output +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - ($new-internal-database $A) - ( (atom $A) - ($get-hash-manager $HM) - ($new-internal-database $HM $A))) -; - - - (= - ($new-internal-database $HM $A) - ( (hash-contains-key $HM $A) (set-det))) -; - - (= - ($new-internal-database $_ $A) - ( (new-hash $_ - (:: (alias $A))) ($init-internal-database $A))) -; - + !(public (, (/ get-byte 1) (/ peek-byte 1) (/ put-byte 1))) +; +; :- public get_byte/2. ; written in java +; +; :- public peek_byte/2. ; written in java +; +; :- public put_byte/2. ; written in java - (= - ($init-internal-database $A) - ( ($compiled-predicate $A %init 0) - (findall $_ - (with_self $A - (%init)) $_) - (set-det))) -; + (= (get-byte $Byte) + (current-input $S) + (get-byte $S $Byte)) - (= - (%init_internal_database $_) True) -; + + (= (peek-byte $Byte) + (current-input $S) + (peek-byte $S $Byte)) + + (= (put-byte $Byte) + (current-output $S) + (put-byte $S $Byte)) ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Term input/output (read) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + !(public (, (/ read 1) (/ read 2))) + !(public (, (/ read-with-variables 2) (/ read-with-variables 3))) + !(public (/ read-line 1)) +; +; :- public read_line/2. (written in Java) + !(dynamic (/ %tokens 1)) + - (= - ($defined-internal-database $A) - ( (atom $A) - ($get-hash-manager $HM) - (hash-contains-key $HM $A))) -; + (= (read $X) + (current-input $S) + (read $S $X)) + (= (read $S_or_a $X) + (read-tokens $S_or_a $Tokens $_) + (parse-tokens $X $Tokens) + (set-det)) -; -; - - (= - ($clause-internal $P $PI $H $Cl $Ref) - ( (hash-contains-key $P $PI) - ($get-indices $P $PI $H $RevRefs) - ($get-instances $RevRefs $Cls_Refs) - ($clause-internal0 $Cls_Refs $Cl $Ref))) -; + (= (read-with-variables $X $Vs) + (current-input $S) + (read-with-variables $S $X $Vs)) + (= (read-with-variables $S_or_a $X $Vs) + (read-tokens $S_or_a $Tokens $Vs) + (parse-tokens $X $Tokens) + (set-det)) - (= - (%clause_internal0 () $_ $_) - (empty)) -; - - (= - ($clause-internal0 - (:: (, $Cl $Ref)) $Cl $Ref) - (set-det)) -; + (= (read-line $X) + (current-input $S) + (read-line $S $X)) - (= - ($clause-internal0 $L $Cl $Ref) - ($builtin-member - (, $Cl $Ref) $L)) -; +; +; read_token(S_or_a, Token) reads one token from the input, +; +; and unifies Token with: +; +; error(Atom), +; +; end_of_file, +; +; '.', ' ', '(', ')', '[', ']', '{', '}', ',', '|', +; +; number(Integer_or_Float), +; +; atom(Atom), +; +; var(Atom), +; +; string(CharCodeList) +; +; read_token(Token) :- current_input(S), read_token(S, Token). - (= - ($get-indices $P $PI $H $Refs) - ( ($new-indexing-hash $P $PI $IH) - ($calc-indexing-key $H $Key) - (det-if-then-else - (hash-contains-key $IH $Key) - (hash-get $IH $Key $Refs) - (hash-get $IH var $Refs)))) -; + (= (read-token $S_or_a $Token) + ($read-token0 $S_or_a $Type $Token0) + ($read-token1 + (:: $Type) $Token0 $Token)) + + (= ($read-token1 (:: -2) $T (error $T)) + (set-det)) ; +; error('message') + (= ($read-token1 "I" $T (number $T)) + (set-det)) ; +; number(intvalue) + (= ($read-token1 "L" $T (number $T)) + (set-det)) ; +; number(longvalue) + (= ($read-token1 "D" $T (number $T)) + (set-det)) ; +; number(floatvalue) + (= ($read-token1 "A" $T (atom $T)) + (set-det)) ; +; atom('name') + (= ($read-token1 "V" $T (var $T)) + (set-det)) ; +; var('name') + (= ($read-token1 "S" $T (string $T)) + (set-det)) ; +; string("chars") + (= ($read-token1 $_ $T $T) + (set-det)) ; +; others ; -; - - - (= - ($new-indexing-hash $P $PI $IH) - ( (hash-contains-key $P $PI) - (set-det) - (hash-get $P $PI $IH))) -; +; read_tokens(Tokens, Vs) reads tokens from the input +; +; until full-stop-mark ('.') or end_of_file, +; +; unifies Tokens with a list of tokens. +; +; Token for a variable has a form of var(Name,Variable). +; +; Vs is a list of Name=Variable pairs. - (= - ($new-indexing-hash $P $PI $IH) - ( (new-hash $IH) - (hash-put $IH all Nil) - (hash-put $IH var Nil) - (hash-put $IH lis Nil) - (hash-put $IH str Nil) - (hash-put $P $PI $IH))) -; +; +; read_tokens(Tokens, Vs) :- +; +; current_input(Stream), +; +; '$read_tokens'(Stream, Tokens, Vs, []), +; +; !. + + (= (read-tokens $Stream $Tokens $Vs) + ($read-tokens $Stream $Tokens $Vs Nil) + (set-det)) - (= - ($calc-indexing-key $H all) - ( (atom $H) (set-det))) -; + (= ($read-tokens $Stream $Tokens $Vs $VI) + (read-token $Stream $Token) + ($read-tokens1 $Stream $Token $Tokens $Vs $VI)) - (= - ($calc-indexing-key $H $Key) - ( (arg 1 $H $A1) ($calc-indexing-key0 $A1 $Key))) -; + + (= ($read-tokens1 $Stream (error $Message) Nil $_ $_) + (set-det) + (write user-error '{SYNTAX ERROR}') + (nl user-error) + (write user-error ** ) + (write user-error $Message) + (write user-error **) + (nl user-error) + (flush-output user-error) + ($read-tokens-until-fullstop $Stream) + (fail)) + (= ($read-tokens1 $Stream end-of-file (:: end-of-file .) Nil $_) + (set-det)) + (= ($read-tokens1 $Stream . (:: .) Nil $_) + (set-det)) + (= ($read-tokens1 $Stream (var -) (Cons (var - $V) $Tokens) (Cons (= - $V) $Vs) $VI0) + (set-det) + ($read-tokens $Stream $Tokens $Vs + (Cons + (= - $V) $VI0))) + (= ($read-tokens1 $Stream (var $Name) (Cons (var $Name $V) $Tokens) $Vs $VI) + ($mem-pair + (= $Name $V) $VI) + (set-det) + ($read-tokens $Stream $Tokens $Vs $VI)) + (= ($read-tokens1 $Stream (var $Name) (Cons (var $Name $V) $Tokens) (Cons (= $Name $V) $Vs) $VI0) + (set-det) + ($read-tokens $Stream $Tokens $Vs + (Cons + (= $Name $V) $VI0))) + (= ($read-tokens1 $Stream $Token (Cons $Token $Tokens) $Vs $VI) + ($read-tokens $Stream $Tokens $Vs $VI)) + + (= ($mem-pair (= $X1 $V1) (Cons (= $X2 $V2) $_)) + (== $X1 $X2) + (set-det) + (= $V1 $V2)) + (= ($mem-pair $X (Cons $_ $L)) + ($mem-pair $X $L)) +; +; '$mem_pair'(X, [_|L]) :- member(X, L). - (= - ($calc-indexing-key0 $A1 all) - ( (var $A1) (set-det))) -; + (= ($read-tokens-until-fullstop $Stream) + (read-token $Stream $Token) + ($read-tokens-until-fullstop $Stream $Token)) - (= - ($calc-indexing-key0 $A1 lis) - ( (= $A1 - (Cons $_ $_)) (set-det))) -; + (= ($read-tokens-until-fullstop $Stream end-of-file) + (set-det)) + (= ($read-tokens-until-fullstop $Stream .) + (set-det)) + (= ($read-tokens-until-fullstop $Stream $_) + (read-token $Stream $Token) + ($read-tokens-until-fullstop $Stream $Token)) - (= - ($calc-indexing-key0 $A1 str) - ( (compound $A1) (set-det))) -; + + (= (parse-tokens $X $Tokens) + ( (remove-all-atoms &self + (%tokens $_)) + (add-is-symbol &self + (%tokens $Tokens)) + ($parse-tokens $X 1201 $Tokens + (:: .)) + (remove-is-symbol &self + (%tokens $Tokens)) + (set-det))) - (= - ($calc-indexing-key0 $A1 $Key) - ( (ground $A1) - (set-det) - ($term-hash $A1 $Key))) -; +; +; '$parse_tokens'(X, Prec) parses the input whose precedecence =< Prec. + + (= (, (--> (%parse_tokens $X $Prec0) $parse_tokens_skip_spaces) (, (%parse_tokens1 $Prec0 $X1 $Prec1) (, ! (, $parse_tokens_skip_spaces (, (%parse_tokens2 $Prec0 $X1 $Prec1 $X $Prec) !))))) True) - (= - ($calc-indexing-key0 $A1 $Key) - (illarg - (type term) - ($calc-indexing-key0 $A1 $Key) 1)) -; + (= (, (--> (%parse_tokens1 $Prec0 $X1 $Prec1) (%parse_tokens_peep_next $Next)) (, {(%parse_tokens_is_starter $Next) } (, ! (%parse_tokens_before_op $Prec0 $X1 $Prec1)))) True) + (= (, (--> (%parse_tokens1 $_ $_ $_) (%parse_tokens_peep_next $Next)) (%parse_tokens_error ($Next cannot start an expression))) True) + (= (, (--> (%parse_tokens2 $Prec0 $X $Prec $X $Prec) (%parse_tokens_peep_next $Next)) (, {(%parse_tokens_is_terminator $Next) } (, {(=< $Prec $Prec0) } !))) True) + (= (, (--> (%parse_tokens2 $Prec0 $X1 $Prec1 $X $Prec) (%parse_tokens_peep_next $Next)) (, {(%parse_tokens_is_post_in_op $Next) } (, ! (%parse_tokens_post_in_ops $Prec0 $X1 $Prec1 $X $Prec)))) True) + + (= (--> (%parse_tokens2 $_ $_ $_ $_ $_) (%parse_tokens_error (operator expected after expression))) True) ; -; +; '$parse_tokens_before_op'(Prec0, X, Prec) +; +; parses the input until infix or postfix operator, +; +; and returns X and Prec + (= (, (--> (%parse_tokens_before_op $Prec0 $X $Prec) (' ')) (, ! (%parse_tokens_before_op $Prec0 $X $Prec))) True) + (= (, (--> (%parse_tokens_before_op $_ end_of_file 0) (end_of_file)) !) True) + (= (, (--> (%parse_tokens_before_op $_ $N 0) ((number $N))) !) True) + (= (, (--> (%parse_tokens_before_op $_ $N 0) ((is-symbol -))) (, ((number $N0)) (, ! {(is $N (- $N0)) }))) True) + (= (, (--> (%parse_tokens_before_op $_ $V 0) ((var $_ $V))) !) True) + (= (, (--> (%parse_tokens_before_op $_ $S 0) ((string $S))) !) True) + (= (, (--> (%parse_tokens_before_op $_ $X 0) (()) (, ! (, (%parse_tokens $X 1201) (%parse_tokens_expect ))))) True) + (= (, (--> (%parse_tokens_before_op $_ $X 0) ({)) (, ! (, $parse_tokens_skip_spaces (%parse_tokens_brace $X)))) True) + (= (, (--> (%parse_tokens_before_op $_ $X 0) ([)) (, ! (, $parse_tokens_skip_spaces (%parse_tokens_list $X)))) True) + (= (, (--> (%parse_tokens_before_op $_ $X 0) ((is-symbol $F))) (, (() (, ! (, $parse_tokens_skip_spaces (, (%parse_tokens_args $Args) {(=.. $X (Cons $F $Args)) }))))) True) + (= (, (--> (%parse_tokens_before_op $Prec0 $X $PrecOp) ((is-symbol $F))) (, {(current_op $PrecOp fx $F) } (, {(=< $PrecOp $Prec0) } (, $parse_tokens_skip_spaces (, (%parse_tokens_peep_next $Next) (, {(%parse_tokens_is_starter $Next) } (, {(\+ (%parse_tokens_is_post_in_op $Next)) } (, ! (, {(is $Prec1 (- $PrecOp 1)) } (, (%parse_tokens $Arg $Prec1) (, {(functor $X $F 1) } {(arg 1 $X $Arg) }))))))))))) True) + (= (, (--> (%parse_tokens_before_op $Prec0 $X $PrecOp) ((is-symbol $F))) (, {(current_op $PrecOp fy $F) } (, {(=< $PrecOp $Prec0) } (, $parse_tokens_skip_spaces (, (%parse_tokens_peep_next $Next) (, {(%parse_tokens_is_starter $Next) } (, {(\+ (%parse_tokens_is_post_in_op $Next)) } (, ! (, (%parse_tokens $Arg $PrecOp) (, {(functor $X $F 1) } {(arg 1 $X $Arg) })))))))))) True) - (= - ($check-procedure-permission - (with_self $P - (/ $F $A)) $Operation $ObjType $Goal) - ( (hash-contains-key $P - (/ $F $A)) (set-det))) -; + (= (--> (%parse_tokens_before_op $_ $A 0) ((is-symbol $A))) True) - (= - ($check-procedure-permission - (with_self $P - (/ $F $A)) $Operation $ObjType $Goal) - ( ($compiled-predicate-or-builtin $P $F $A) - (set-det) - (illarg - (permission $Operation $ObjType - (with_self $P - (/ $F $A)) $_) $Goal $_))) -; - - (= - (%check_procedure_permission $_ $_ $_ $_) True) -; + + (= (, (--> (%parse_tokens_brace {}) (})) !) True) + (= (, (--> (%parse_tokens_brace $X) (%parse_tokens $X1 1201)) (, (%parse_tokens_expect }) {(= $X + {$X1 }) })) True) + (= (, (--> (%parse_tokens_list []) (])) !) True) + (= (, (--> (%parse_tokens_list (Cons $X $Xs)) (%parse_tokens $X 999)) (, $parse_tokens_skip_spaces (%parse_tokens_list_rest $Xs))) True) -; -; - + (= (, (--> (%parse_tokens_list_rest $Xs) (|)) (, ! (, (%parse_tokens $Xs 999) (%parse_tokens_expect ])))) True) + (= (, (--> (%parse_tokens_list_rest (Cons $X $Xs)) (,)) (, ! (, (%parse_tokens $X 999) (, $parse_tokens_skip_spaces (%parse_tokens_list_rest $Xs))))) True) - (= - (initialization Nil $Goal) - ( (set-det) (once $Goal))) -; + (= (--> (%parse_tokens_list_rest []) (%parse_tokens_expect ])) True) - (= - (initialization - (Cons $P $Ps) $Goal) - ( ($new-internal-database $P) (initialization $Ps $Goal))) -; + + (= (, (--> (%parse_tokens_args []) ())) !) True) + (= (, (--> (%parse_tokens_args (Cons $X $Xs)) (%parse_tokens $X 999)) (, $parse_tokens_skip_spaces (%parse_tokens_args_rest $Xs))) True) + (= (, (--> (%parse_tokens_args_rest (Cons $X $Xs)) (,)) (, ! (, (%parse_tokens $X 999) (, $parse_tokens_skip_spaces (%parse_tokens_args_rest $Xs))))) True) + + (= (--> (%parse_tokens_args_rest []) (%parse_tokens_expect ))) True) ; -; - +; '$parse_tokens_post_in_op'(Prec0, X1, Prec1, X, Prec) ; -; - +; parses the input beginning from infix or postfix operator, ; -; +; and returns X and Prec + (= (, (--> (%parse_tokens_post_in_ops $Prec0 $X1 $Prec1 $X $Prec) $parse_tokens_skip_spaces) (, ($Op) (, (%parse_tokens_op $Op $Prec0 $X1 $Prec1 $X2 $Prec2) (%parse_tokens_post_in_ops $Prec0 $X2 $Prec2 $X $Prec)))) True) - !(public (/ assert 1)) -; - - !(public (/ assertz 1)) -; - - !(public (/ asserta 1)) -; - - !(public (/ retract 1)) -; - - !(public (/ abolish 1)) -; - - !(public (/ retractall 1)) -; - + (= (--> (%parse_tokens_post_in_ops $Prec0 $X $Prec $X $Prec) {(=< $Prec $Prec0) }) True) - (= - (add-symbol &self $T) - (add-symbol &self $T)) -; - + (= (, (--> (%parse_tokens_op , $Prec0 $X1 $Prec1 $X $PrecOp) !) (%parse_tokens_op (is-symbol ,) $Prec0 $X1 $Prec1 $X $PrecOp)) True) + (= (, (--> (%parse_tokens_op | $Prec0 $X1 $Prec1 $X $PrecOp) !) (%parse_tokens_op (is-symbol ;) $Prec0 $X1 $Prec1 $X $PrecOp)) True) + (= (, (--> (%parse_tokens_op (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) {(current_op $PrecOp xf $Op) }) (, {(=< $PrecOp $Prec0) } (, {(< $Prec1 $PrecOp) } (, {(functor $X $Op 1) } {(arg 1 $X $X1) })))) True) + (= (, (--> (%parse_tokens_op (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) {(current_op $PrecOp yf $Op) }) (, {(=< $PrecOp $Prec0) } (, {(=< $Prec1 $PrecOp) } (, {(functor $X $Op 1) } {(arg 1 $X $X1) })))) True) + (= (, (--> (%parse_tokens_op (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) {(current_op $PrecOp xfx $Op) }) (, {(=< $PrecOp $Prec0) } (, {(< $Prec1 $PrecOp) } (, {(is $Prec2 (- $PrecOp 1)) } (, (%parse_tokens $X2 $Prec2) (, ! (, {(functor $X $Op 2) } (, {(arg 1 $X $X1) } {(arg 2 $X $X2) })))))))) True) + (= (, (--> (%parse_tokens_op (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) {(current_op $PrecOp xfy $Op) }) (, {(=< $PrecOp $Prec0) } (, {(< $Prec1 $PrecOp) } (, {(is $Prec2 $PrecOp) } (, (%parse_tokens $X2 $Prec2) (, ! (, {(functor $X $Op 2) } (, {(arg 1 $X $X1) } {(arg 2 $X $X2) })))))))) True) + (= (, (--> (%parse_tokens_op (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) {(current_op $PrecOp yfx $Op) }) (, {(=< $PrecOp $Prec0) } (, {(=< $Prec1 $PrecOp) } (, {(is $Prec2 (- $PrecOp 1)) } (, (%parse_tokens $X2 $Prec2) (, ! (, {(functor $X $Op 2) } (, {(arg 1 $X $X1) } {(arg 2 $X $X2) })))))))) True) - (= - (add-symbol &self $T) - ( ($term-to-clause $T $Cl - (with_self $P $PI) - (add-symbol &self $T)) - ($new-internal-database $P) - ($check-procedure-permission - (with_self $P $PI) modify static-procedure - (add-symbol &self $T)) - (copy-term $Cl $NewCl) - ($insert $NewCl $Ref) - ($update-indexing $P $PI $Cl $Ref z) - (fail))) -; - - (= - (assertz $_) True) -; + (= (%parse_tokens_is_starter end_of_file) True) + (= (%parse_tokens_is_starter () True) + (= (%parse_tokens_is_starter [) True) + (= (%parse_tokens_is_starter {) True) + (= (%parse_tokens_is_starter (number $_)) True) + (= (%parse_tokens_is_starter (is-symbol $_)) True) + (= (%parse_tokens_is_starter (var $_ $_)) True) + (= (%parse_tokens_is_starter (string $_)) True) + + (= (%parse_tokens_is_terminator )) True) + (= (%parse_tokens_is_terminator ]) True) + (= (%parse_tokens_is_terminator }) True) + (= (%parse_tokens_is_terminator .) True) - (= - (add-symbol &self $T) - ( ($term-to-clause $T $Cl - (with_self $P $PI) - (add-symbol &self $T)) - ($new-internal-database $P) - ($check-procedure-permission - (with_self $P $PI) modify static-procedure - (add-symbol &self $T)) - (copy-term $Cl $NewCl) - ($insert $NewCl $Ref) - ($update-indexing $P $PI $Cl $Ref a) - (fail))) -; + (= ($parse-tokens-is-post-in-op ,) + (set-det)) + (= ($parse-tokens-is-post-in-op |) + (set-det)) + (= ($parse-tokens-is-post-in-op (atom $Op)) + (current-op $_ $Type $Op) + ($parse-tokens-post-in-type $Type) + (set-det)) - (= - (asserta $_) True) -; + + (= (%parse_tokens_post_in_type xfx) True) + (= (%parse_tokens_post_in_type xfy) True) + (= (%parse_tokens_post_in_type yfx) True) + (= (%parse_tokens_post_in_type xf) True) + (= (%parse_tokens_post_in_type yf) True) + + (= (, (--> (%parse_tokens_expect $Token) $parse_tokens_skip_spaces) (, ($Token) !)) True) + + (= (--> (%parse_tokens_expect $Token) (%parse_tokens_error ($Token expected))) True) - (= - (abolish $T) - ( ($term-to-predicateindicator $T - (with_self $P $PI) - (abolish $T)) - ($new-internal-database $P) - ($check-procedure-permission - (with_self $P $PI) modify static-procedure - (abolish $T)) - ($new-indexing-hash $P $PI $IH) - (hash-get $IH all $Refs) - ($erase-all $Refs) - (hash-remove $P $PI) - (fail))) -; + (= (, (--> $parse_tokens_skip_spaces (' ')) (, ! $parse_tokens_skip_spaces)) True) + + (= (--> $parse_tokens_skip_spaces ()) True) - (= - (abolish $_) True) -; + + (= ($parse-tokens-peep-next $Next $S $S) + (= $S + (Cons $Next $_))) + + (= ($parse-tokens-error $Message $S0 $S) + ( (write user-error '{SYNTAX ERROR}') + (nl user-error) + (write user-error ** ) + ($parse-tokens-write-message user-error $Message) + (write user-error **) + (nl user-error) + ($parse-tokens-error1 Nil $S0) + (== + (= + (%tokens $Tokens) $_) + (get-atoms &self)) + ($parse-tokens-error1 $Tokens $S0) + (flush-output user-error) + (fail))) + + + (= ($parse-tokens-error1 Nil $_) + (set-det)) + (= ($parse-tokens-error1 $Tokens $S0) + (== $Tokens $S0) + (set-det) + (nl user-error) + (write user-error '** here **') + (nl user-error) + ($parse-tokens-error1 $Tokens Nil) + (nl user-error)) + (= ($parse-tokens-error1 (Cons $Token $Tokens) $S0) + ($parse-tokens-error2 $Token) + ($parse-tokens-error1 $Tokens $S0)) + + + (= ($parse-tokens-error2 (number $X)) + (set-det) + (write $X)) + (= ($parse-tokens-error2 (atom $X)) + (set-det) + (writeq $X)) + (= ($parse-tokens-error2 (var $X $_)) + (set-det) + (write $X)) + (= ($parse-tokens-error2 (string $X)) + (set-det) + (write user-error ") + ($parse-tokens-write-string user-error $X) + (write user-error ")) + (= ($parse-tokens-error2 $X) + (write user-error $X)) + + + (= (%parse_tokens_write_string $_ ()) True) + (= ($parse-tokens-write-string $S (Cons $C $Cs)) + (= + (:: $C) "\"") + (set-det) + (put-code $S $C) + (put-code $S $C) + ($parse-tokens-write-string $S $Cs)) + (= ($parse-tokens-write-string $S (Cons $C $Cs)) + (put-code $S $C) + ($parse-tokens-write-string $S $Cs)) + + + (= (%parse_tokens_write_message $_ ()) True) + (= ($parse-tokens-write-message $S (Cons $X $Xs)) + (write $S $X) + (write $S ' ') + ($parse-tokens-write-message $S $Xs)) + +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Term input/output (write) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + !(public (, (/ write 1) (/ write 2))) + !(public (, (/ writeq 1) (/ writeq 2))) + !(public (, (/ write-canonical 1) (/ write-canonical 2))) + !(public (, (/ write-term 2) (/ write-term 3))) + + + (= (write $Term) + (current-output $S) + (write-term $S $Term + (:: (numbervars True)))) + + (= (write $S_or_a $Term) + (write-term $S_or_a $Term + (:: (numbervars True)))) - (= - (remove-symbol &self $Cl) - ( ($clause-to-term $Cl $T - (with_self $P $PI) - (remove-symbol &self $Cl)) - ($new-internal-database $P) - ($check-procedure-permission - (with_self $P $PI) access static-procedure - (remove-symbol &self $Cl)) - (= $T - (= $H $_)) - ($clause-internal $P $PI $H $Cl0 $Ref) - (copy-term $Cl0 $T) - ($erase $Ref) - ($rehash-indexing $P $PI $Ref))) -; + (= (writeq $Term) + (current-output $S) + (write-term $S $Term + (:: + (quoted True) + (numbervars True)))) + (= (writeq $S_or_a $Term) + (write-term $S_or_a $Term + (:: + (quoted True) + (numbervars True)))) - (= - (remove-all-symbols &self $Head) - ( ($head-to-term $Head $H - (with_self $P $PI) - (remove-all-symbols &self $Head)) - ($new-internal-database $P) - ($check-procedure-permission - (with_self $P $PI) access static-procedure - (remove-all-symbols &self $Head)) - ($clause-internal $P $PI $H $Cl $Ref) - (copy-term $Cl - (= $H $_)) - ($erase $Ref) - ($rehash-indexing $P $PI $Ref) - (fail))) -; + (= (write-canonical $Term) + (current-output $S) + (write-term $S $Term + (:: + (quoted True) + (ignore-ops True)))) - (= - (retractall $_) True) -; + (= (write-canonical $S_or_a $Term) + (write-term $S_or_a $Term + (:: + (quoted True) + (ignore-ops True)))) + + + (= (write-term $Term $Options) + (current-output $S) + (write-term $S $Term $Options)) + + (= (write-term $S_or_a $Term $Options) + ($write-term $S_or_a $Term $Options) + (fail)) + (= (write_term $_ $_ $_) True) + + + (= ($write-term $S_or_a $Term $Options) + ($write-term0 $Term 1200 punct $_ $Options $S_or_a) + (set-det)) + + + (= ($write-term0 $Term $Prec $Type0 alpha $_ $S_or_a) + (var $Term) + (set-det) + ($write-space-if-needed $Type0 alpha $S_or_a) + ($fast-write $S_or_a $Term)) + (= ($write-term0 $Term $Prec $Type0 alpha $_ $S_or_a) + (java $Term) + (set-det) + ($write-space-if-needed $Type0 alpha $S_or_a) + ($fast-write $S_or_a $Term)) + (= ($write-term0 $Term $Prec $Type0 alpha $Style $S_or_a) + (= $Term $VN) + (integer $VN) + (>= $VN 0) + ($builtin-member + (numbervars True) $Style) + (set-det) + ($write-space-if-needed $Type0 alpha $S_or_a) + ($write-VAR $VN $S_or_a)) + (= ($write-term0 $Term $Prec $Type0 alpha $_ $S_or_a) + (number $Term) + (< $Term 0) + (set-det) + ($write-space-if-needed $Type0 symbol $S_or_a) + ($fast-write $S_or_a $Term)) + (= ($write-term0 $Term $Prec $Type0 alpha $_ $S_or_a) + (number $Term) + (set-det) + ($write-space-if-needed $Type0 alpha $S_or_a) + ($fast-write $S_or_a $Term)) +; +; '$write_term0'(Term, Prec, Type0, punct, _, S_or_a) :- +; +; atom(Term), +; +; current_op(PrecOp, OpType, Term), +; +; (OpType = fx ; OpType = fy), +; +; PrecOp =< Prec, +; +; !, +; +; '$write_space_if_needed'(Type0, punct, S_or_a), +; +; put_char(S_or_a, '('), +; +; '$write_atom'(Term, punct, _, _, S_or_a), +; +; put_char(S_or_a, ')'). + (= ($write-term0 $Term $Prec $Type0 $Type $Style $S_or_a) + (atom $Term) + (set-det) + ($write-atom $Term $Type0 $Type $Style $S_or_a)) + (= ($write-term0 $Term $Prec $Type0 $Type $Style $S_or_a) + (not ($builtin-member (ignore-ops True) $Style)) + ($write-is-operator $Term $Op $Args $OpType) + (set-det) + ($write-term-op $Op $OpType $Args $Prec $Type0 $Type $Style $S_or_a)) + (= ($write-term0 $Term $Prec $Type0 punct $Style $S_or_a) + (= $Term + (Cons $_ $_)) + (not ($builtin-member (ignore-ops True) $Style)) + (set-det) + ($write-space-if-needed $Type0 punct $S_or_a) + (put-char $S_or_a [) + ($write-term-list-args $Term punct $_ $Style $S_or_a) + (put-char $S_or_a ])) + (= ($write-term0 $Term $Prec $Type0 $Type $Style $S_or_a) + (= $Term + {$Term1 }) + (not ($builtin-member (ignore-ops True) $Style)) + (set-det) + ($write-space-if-needed $Type0 punct $S_or_a) + (put-char $S_or_a {) + ($write-term0 $Term1 1200 punct $_ $Style $S_or_a) + (put-char $S_or_a })) + (= ($write-term0 $Term $Prec $Type0 punct $Style $S_or_a) + (=.. $Term + (Cons $F $Args)) + ($write-atom $F $Type0 $_ $Style $S_or_a) + (put-char $S_or_a () + ($write-term-args $Args punct $_ $Style $S_or_a) + (put-char $S_or_a ))) + + + (= ($write-space-if-needed punct $_ $_) + (set-det)) + (= ($write-space-if-needed $X $X $S_or_a) + (set-det) + (put-char $S_or_a ' ')) + (= ($write-space-if-needed other alpha $S_or_a) + (set-det) + (put-char $S_or_a ' ')) + (= (%write_space_if_needed $_ $_ $_) True) + + + (= ($write-VAR $VN $S_or_a) + (< $VN 26) + (set-det) + (is $Letter + (+ + (mod $VN 26) "A")) + (put-code $S_or_a $Letter)) + (= ($write-VAR $VN $S_or_a) + (is $Letter + (+ + (mod $VN 26) "A")) + (put-code $S_or_a $Letter) + (is $Rest + (// $VN 26)) + ($fast-write $S_or_a $Rest)) + + + (= ($write-atom $Atom $Type0 $Type $Style $S_or_a) + ($builtin-member + (quoted True) $Style) + (set-det) + ($atom-type $Atom $Type) + ($write-space-if-needed $Type0 $Type $S_or_a) + ($fast-writeq $S_or_a $Atom)) + (= ($write-atom $Atom $Type0 $Type $_ $S_or_a) + ($atom-type $Atom $Type) + ($write-space-if-needed $Type0 $Type $S_or_a) + ($fast-write $S_or_a $Atom)) + + + (= ($atom-type $X alpha) + ($atom-type0 $X 0) + (set-det)) + (= ($atom-type $X symbol) + ($atom-type0 $X 1) + (set-det)) + (= ($atom-type $X punct) + ($atom-type0 $X 2) + (set-det)) + (= ($atom-type $X other) + ($atom-type0 $X 3) + (set-det)) + + + (= ($write-is-operator $Term $Op $Args $OpType) + (functor $Term $Op $Arity) + ($write-op-type $Arity $OpType) + (current-op $_ $OpType $Op) + (=.. $Term + (Cons $_ $Args)) + (set-det)) + + + (= (%write_op_type 1 fx) True) + (= (%write_op_type 1 fy) True) + (= (%write_op_type 1 xf) True) + (= (%write_op_type 1 yf) True) + (= (%write_op_type 2 xfx) True) + (= (%write_op_type 2 xfy) True) + (= (%write_op_type 2 yfx) True) + + + (= ($write-term-op $Op $OpType $Args $Prec $Type0 punct $Style $S_or_a) + (current-op $PrecOp $OpType $Op) + (> $PrecOp $Prec) + (set-det) + ($write-space-if-needed $Type0 punct $S_or_a) + (put-char $S_or_a () + ($write-term-op1 $Op $OpType $Args $PrecOp punct $_ $Style $S_or_a) + (put-char $S_or_a ))) + (= ($write-term-op $Op $OpType $Args $Prec $Type0 $Type $Style $S_or_a) + (current-op $PrecOp $OpType $Op) + ($write-term-op1 $Op $OpType $Args $PrecOp $Type0 $Type $Style $S_or_a)) + + + (= ($write-term-op1 $Op fx (:: $A1) $PrecOp $Type0 $Type $Style $S_or_a) + (set-det) + ($write-atom $Op $Type0 $Type1 $Style $S_or_a) + (is $Prec1 + (- $PrecOp 1)) + ($write-term0 $A1 $Prec1 $Type1 $Type $Style $S_or_a)) + (= ($write-term-op1 $Op fy (:: $A1) $PrecOp $Type0 $Type $Style $S_or_a) + (set-det) + ($write-atom $Op $Type0 $Type1 $Style $S_or_a) + (is $Prec1 $PrecOp) + ($write-term0 $A1 $Prec1 $Type1 $Type $Style $S_or_a)) + (= ($write-term-op1 $Op xf (:: $A1) $PrecOp $Type0 $Type $Style $S_or_a) + (set-det) + (is $Prec1 + (- $PrecOp 1)) + ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) + ($write-atom $Op $Type1 $Type $Style $S_or_a)) + (= ($write-term-op1 $Op yf (:: $A1) $PrecOp $Type0 $Type $Style $S_or_a) + (set-det) + (is $Prec1 $PrecOp) + ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) + ($write-atom $Op $Type1 $Type $Style $S_or_a)) + (= ($write-term-op1 $Op xfx (:: $A1 $A2) $PrecOp $Type0 $Type $Style $S_or_a) + (set-det) + (is $Prec1 + (- $PrecOp 1)) + (is $Prec2 + (- $PrecOp 1)) + ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) + ($write-term-infix-op $Op $Type1 $Type2 $Style $S_or_a) + ($write-term0 $A2 $Prec2 $Type2 $Type $Style $S_or_a)) + (= ($write-term-op1 $Op xfy (:: $A1 $A2) $PrecOp $Type0 $Type $Style $S_or_a) + (set-det) + (is $Prec1 + (- $PrecOp 1)) + (is $Prec2 $PrecOp) + ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) + ($write-term-infix-op $Op $Type1 $Type2 $Style $S_or_a) + ($write-term0 $A2 $Prec2 $Type2 $Type $Style $S_or_a)) + (= ($write-term-op1 $Op yfx (:: $A1 $A2) $PrecOp $Type0 $Type $Style $S_or_a) + (set-det) + (is $Prec1 $PrecOp) + (is $Prec2 + (- $PrecOp 1)) + ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) + ($write-term-infix-op $Op $Type1 $Type2 $Style $S_or_a) + ($write-term0 $A2 $Prec2 $Type2 $Type $Style $S_or_a)) + + + (= ($write-term-infix-op , $Type0 punct $_ $S_or_a) + (set-det) + ($write-space-if-needed $Type0 punct $S_or_a) + (put-char $S_or_a ,)) + (= ($write-term-infix-op $Op $Type0 $Type $Style $S_or_a) + ($write-atom $Op $Type0 $Type $Style $S_or_a)) + + + (= ($write-term-list-args (Cons $A $As) $Type0 $Type $Style $S_or_a) + (nonvar $As) + (= $As + (Cons $_ $_)) + (set-det) + ($write-term0 $A 999 $Type0 $Type1 $Style $S_or_a) + ($write-space-if-needed $Type1 punct $S_or_a) + (put-char $S_or_a ,) + ($write-term-list-args $As punct $Type $Style $S_or_a)) + + (= ($write-term-list-args (Cons $A $As) $Type0 $Type $Style $S_or_a) + (nonvar $As) + (= $As Nil) + (set-det) + ($write-term0 $A 999 $Type0 $Type $Style $S_or_a)) + + (= ($write-term-list-args (Cons $A $As) $Type0 $Type $Style $S_or_a) + ($write-term0 $A 999 $Type0 $Type1 $Style $S_or_a) + ($write-space-if-needed $Type1 punct $S_or_a) + (put-char $S_or_a |) + ($write-term0 $As 999 punct $Type $Style $S_or_a)) + + + (= ($write-term-args Nil $Type $Type $_ $_) + (set-det)) + (= ($write-term-args (:: $A) $Type0 $Type $Style $S_or_a) + (set-det) + ($write-term0 $A 999 $Type0 $Type $Style $S_or_a)) + (= ($write-term-args (Cons $A $As) $Type0 $Type $Style $S_or_a) + (set-det) + ($write-term0 $A 999 $Type0 $Type1 $Style $S_or_a) + ($write-space-if-needed $Type1 punct $S_or_a) + (put-char $S_or_a ,) + ($write-term-args $As punct $Type $Style $S_or_a)) + +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Term input/output (others) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + !(public (/ op 3)) + !(public (/ current-op 3)) + !(dynamic (/ %current-operator 3)) + + + (= (op $Priority $Op_specifier $Operator) + (integer $Priority) + (=< 0 $Priority) + (=< $Priority 1200) + (set-det) + ($op1 $Priority $Op_specifier $Operator)) + (= (op $Priority $Op_specifier $Operator) + (illarg + (domain integer + (- 0 1200)) + (op $Priority $Op_specifier $Operator) 1)) + + (= ($op1 $Priority $Op_specifier $Operator) + (nonvar $Op_specifier) + ($op-specifier $Op_specifier $_) + (set-det) + ($op2 $Priority $Op_specifier $Operator)) + (= ($op1 $Priority $Op_specifier $Operator) + (findall $X + ($op-specifier $X $_) $Domain) + (illarg + (domain term $Domain) + (op $Priority $Op_specifier $Operator) 2)) -; -; + (= ($op2 $Priority $Op_specifier $Operator) + (atom $Operator) + (set-det) + ($add-operators + (:: $Operator) $Priority $Op_specifier)) + (= ($op2 $Priority $Op_specifier $Operator) + ($op-atom-list $Operator $Atoms) + (set-det) + ($add-operators $Atoms $Priority $Op_specifier)) + (= ($op2 $Priority $Op_specifier $Operator) + (illarg + (type (list is-symbol)) + (op $Priority $Op_specifier $Operator) 3)) + - (= - ($term-to-clause $Cl0 $Cl - (with_self $Pkg - (/ $F $A)) $Goal) - ( ($term-to-clause $Cl0 $Cl user $Pkg $Goal) - (= $Cl - (= $H $_)) - (functor $H $F $A))) -; - - - (= - ($term-to-clause $Cl0 $_ $_ $_ $Goal) - ( (var $Cl0) - (set-det) - (illarg var $Goal 1))) -; - - (= - ($term-to-clause $_ $_ $Pkg0 $_ $Goal) - ( (var $Pkg0) - (set-det) - (illarg var $Goal 1))) -; - - (= - ($term-to-clause - (with_self $P $Cl0) $Cl $_ $Pkg $Goal) - ( (set-det) ($term-to-clause $Cl0 $Cl $P $Pkg $Goal))) -; - - (= - ($term-to-clause $_ $_ $Pkg0 $_ $Goal) - ( (not (atom $Pkg0)) - (set-det) - (illarg - (type is-symbol) $Goal 1))) -; - - (= - ($term-to-clause - (= $H0 $B0) - (= $H $B) $Pkg $Pkg $Goal) - ( (set-det) - ($term-to-head $H0 $H $Pkg $Goal) - ($term-to-body $B0 $B $Pkg $Goal))) -; - - (= - ($term-to-clause $H0 - (= $H True) $Pkg $Pkg $Goal) - ($term-to-head $H0 $H $Pkg $Goal)) -; - - - - (= - ($term-to-head $H $H $_ $_) - ( (atom $H) (set-det))) -; - - (= - ($term-to-head $H $H $_ $_) - ( (compound $H) (set-det))) -; - - (= - ($term-to-head $_ $_ $_ $Goal) - (illarg - (type callable) $Goal 1)) -; - - - - (= - ($term-to-body $B0 $B $Pkg $_) - ($localize-body $B0 $Pkg $B)) -; - - - - (= - ($localize-body $G $P $G1) - ( (var $G) - (set-det) - ($localize-body - (call $G) $P $G1))) -; - - (= - ($localize-body - (with_self $P $G) $_ $G1) - ( (set-det) ($localize-body $G $P $G1))) -; - - (= - ($localize-body - (, $X $Y) $P - (, $X1 $Y1)) - ( (set-det) - ($localize-body $X $P $X1) - ($localize-body $Y $P $Y1))) -; - - (= - ($localize-body - (det-if-then $X $Y) $P - (det-if-then $X1 $Y1)) - ( (set-det) - ($localize-body $X $P $X1) - ($localize-body $Y $P $Y1))) -; - - (= - ($localize-body - (or $X $Y) $P - (or $X1 $Y1)) - ( (set-det) - ($localize-body $X $P $X1) - ($localize-body $Y $P $Y1))) -; - - (= - ($localize-body $G $P $G1) - ( (functor $G $F $A) - ($builtin-meta-predicates $F $A $M) - (set-det) - (=.. $G - (Cons $F $As)) - ($localize-args $M $As $P $As1) - (=.. $G1 - (Cons $F $As1)))) -; - - (= - ($localize-body $G $P - (call (with_self $P $G))) - ( (var $P) (set-det))) -; - - (= - ($localize-body $G user $G) - (set-det)) -; - - (= - ($localize-body $G $_ $G) - ( (system-predicate $G) (set-det))) -; - - (= - (%localize_body $G $P - (: $P $G)) True) -; - - - - (= - ($localize-args Nil Nil $_ Nil) - (set-det)) -; - - (= - ($localize-args - (Cons : $Ms) - (Cons $A $As) $P - (Cons - (with_self $P $A) $As1)) - ( (or - (var $A) - (\= $A - (with_self $_ $_))) - (set-det) - ($localize-args $Ms $As $P $As1))) -; - - (= - ($localize-args - (Cons $_ $Ms) - (Cons $A $As) $P - (Cons $A $As1)) - ($localize-args $Ms $As $P $As1)) -; - - - - (= - (%builtin_meta_predicates ^ 2 - (? :)) True) -; - - (= - (%builtin_meta_predicates call 1 - (:)) True) -; - - (= - (%builtin_meta_predicates once 1 - (:)) True) -; - - (= - (%builtin_meta_predicates \+ 1 - (:)) True) -; - - (= - (%builtin_meta_predicates findall 3 - (? : ?)) True) -; - - (= - (%builtin_meta_predicates setof 3 - (? : ?)) True) -; - - (= - (%builtin_meta_predicates bagof 3 - (? : ?)) True) -; - - (= - (%builtin_meta_predicates on_exception 3 - (? : :)) True) -; - - (= - (%builtin_meta_predicates catch 3 - (: ? :)) True) -; - - (= - (%builtin_meta_predicates synchronized 2 - (? :)) True) -; - - (= - (%builtin_meta_predicates freeze 2 - (? :)) True) -; - - -; -; - - - (= - ($clause-to-term $Cl $T - (with_self $Pkg - (/ $F $A)) $Goal) - ( ($clause-to-term $Cl $T user $Pkg $Goal) - (= $T - (= $H $_)) - (functor $H $F $A))) -; - - - (= - ($clause-to-term $Cl $_ $_ $_ $Goal) - ( (var $Cl) - (set-det) - (illarg var $Goal 1))) -; - - (= - ($clause-to-term $_ $_ $Pkg $_ $Goal) - ( (var $Pkg) - (set-det) - (illarg var $Goal 1))) -; - - (= - ($clause-to-term - (with_self $P $Cl) $T $_ $Pkg $Goal) - ( (set-det) ($clause-to-term $Cl $T $P $Pkg $Goal))) -; - - (= - ($clause-to-term $_ $_ $Pkg $_ $Goal) - ( (not (atom $Pkg)) - (set-det) - (illarg - (type is-symbol) $Goal 1))) -; - - (= - ($clause-to-term - (= $H0 $B) - (= $H $B) $Pkg $Pkg $Goal) - ( (set-det) ($head-to-term $H0 $H $_ $Goal))) -; - - ; -; - - (= - ($clause-to-term $H0 - (= $H True) $Pkg $Pkg $Goal) - ($head-to-term $H0 $H $_ $Goal)) -; - - -; -; - - - (= - ($term-to-predicateindicator $T - (with_self $Pkg $PI) $Goal) - ($term-to-predicateindicator $T $PI user $Pkg $Goal)) -; - - - (= - ($term-to-predicateindicator $T $_ $_ $_ $Goal) - ( (var $T) - (set-det) - (illarg var $Goal 1))) -; - - (= - ($term-to-predicateindicator $_ $_ $Pkg $_ $Goal) - ( (var $Pkg) - (set-det) - (illarg var $Goal 1))) -; - - (= - ($term-to-predicateindicator - (with_self $P $T) $PI $_ $Pkg $Goal) - ( (set-det) ($term-to-predicateindicator $T $PI $P $Pkg $Goal))) -; - - (= - ($term-to-predicateindicator $T $_ $_ $_ $Goal) - ( (\= $T - (/ $_ $_)) - (set-det) - (illarg - (type predicate-indicator) $Goal 1))) -; - - (= - ($term-to-predicateindicator - (/ $F $_) $_ $_ $_ $Goal) - ( (not (atom $F)) - (set-det) - (illarg - (type is-symbol) $Goal 1))) -; - - (= - ($term-to-predicateindicator - (/ $_ $A) $_ $_ $_ $Goal) - ( (not (integer $A)) - (set-det) - (illarg - (type integer) $Goal 1))) -; - - (= - (%term_to_predicateindicator $T $T $Pkg $Pkg $_) True) -; - - - - (= - ($update-indexing $P $PI $Cl $Ref $A_or_Z) - ( ($new-indexing-hash $P $PI $IH) - ($gen-indexing-keys $Cl $IH $Keys) - ($update-indexing-hash $A_or_Z $Keys $IH $Ref))) -; - - - - (= - ($gen-indexing-keys - (= $H $_) $_ - (:: all)) - ( (atom $H) (set-det))) -; - - (= - ($gen-indexing-keys - (= $H $_) $IT $Keys) - ( (arg 1 $H $A1) ($gen-indexing-keys0 $A1 $IT $Keys))) -; - - - - (= - ($gen-indexing-keys0 $A1 $IT $Keys) - ( (var $A1) - (set-det) - (hash-keys $IT $Keys))) -; - - (= - ($gen-indexing-keys0 $A1 $_ - (:: all lis)) - ( (= $A1 - (Cons $_ $_)) (set-det))) -; - - (= - ($gen-indexing-keys0 $A1 $_ - (:: all str)) - ( (compound $A1) (set-det))) -; - - (= - ($gen-indexing-keys0 $A1 $IT - (:: all $Key)) - ( (ground $A1) - (set-det) - ($term-hash $A1 $Key) - (det-if-then-else - (hash-contains-key $IT $Key) True - (, - (hash-get $IT var $L) - (hash-put $IT $Key $L))))) -; - - (= - ($gen-indexing-keys0 $A1 $IT $Keys) - (illarg - (type term) - ($gen-indexing-keys0 $A1 $IT $Keys) 1)) -; - - - - (= - ($update-indexing-hash a $Keys $IH $Ref) - ( (set-det) ($hash-addz-all $Keys $IH $Ref))) -; - - (= - ($update-indexing-hash z $Keys $IH $Ref) - ( (set-det) ($hash-adda-all $Keys $IH $Ref))) -; - - - - (= - ($hash-adda-all Nil $_ $_) - (set-det)) -; - - (= - ($hash-adda-all - (Cons $K $Ks) $H $X) - ( ($hash-adda $H $K $X) ($hash-adda-all $Ks $H $X))) -; - - - - (= - ($hash-addz-all Nil $_ $_) - (set-det)) -; - - (= - ($hash-addz-all - (Cons $K $Ks) $H $X) - ( ($hash-addz $H $K $X) ($hash-addz-all $Ks $H $X))) -; - - - - (= - ($erase-all Nil) - (set-det)) -; - - (= - ($erase-all (Cons $R $Rs)) - ( ($erase $R) ($erase-all $Rs))) -; - - - - (= - ($rehash-indexing $P $PI $Ref) - ( ($new-indexing-hash $P $PI $IH) - (hash-keys $IH $Keys) - ($remove-index-all $Keys $IH $Ref))) -; - - - - (= - ($remove-index-all Nil $_ $_) - (set-det)) -; - - (= - ($remove-index-all - (Cons $K $Ks) $IH $Ref) - ( ($hash-remove-first $IH $K $Ref) ($remove-index-all $Ks $IH $Ref))) -; - - -; -; - -; -; - -; -; - - - !(public (/ findall 3)) -; - - !(public (/ bagof 3)) -; - - !(public (/ setof 3)) -; - - -; -; - - - (= - (findall $Template $Goal $Instances) - ( (callable $Goal) - (set-det) - (new-hash $H) - ($findall $H $Template $Goal $Instances))) -; - - (= - (findall $Template $Goal $Instances) - (illarg - (type callable) - (findall $Template $Goal $Instances) 2)) -; - - - - (= - ($findall $H $Template $Goal $_) - ( (call $Goal) - (copy-term $Template $CT) - ($hash-addz $H %FINDALL $CT) - (fail))) -; - - (= - ($findall $H $_ $_ $Instances) - (hash-get $H %FINDALL $Instances)) -; - - -; -; - - - (= - (bagof $Template $Goal $Instances) - ( (callable $Goal) - (set-det) - ($bagof $Template $Goal $Instances))) -; - - (= - (bagof $Template $Goal $Instances) - (illarg - (type callable) - (bagof $Template $Goal $Instances) 2)) -; - - - - (= - (setof $Template $Goal $Instances) - ( (callable $Goal) - (set-det) - ($bagof $Template $Goal $Instances0) - (sort $Instances0 $Instances))) -; - - (= - (setof $Template $Goal $Instances) - (illarg - (type callable) - (setof $Template $Goal $Instances) 2)) -; - - - - (= - ($bagof $Template $Goal $Instances) - ( ($free-variables-set $Goal $Template $FV) - (\== $FV Nil) - (set-det) - (=.. $Witness - (Cons %witness $FV)) - (findall - (+ $Witness $Template) $Goal $S) - ($bagof-instances $S $Witness $Instances0) - (= $Instances $Instances0))) -; - - (= - ($bagof $Template $Goal $Instances) - ( (findall $Template $Goal $Instances) (\== $Instances Nil))) -; - - - - (= - (%bagof_instances () $Witness $Instances) - (empty)) -; - - (= - ($bagof-instances $S0 $Witness $Instances) - ( (= $S0 - (Cons - (+ $W $T) $S)) - ($variants-subset $S $W $WT_list $T_list $S_next) - ($bagof-instances0 $S_next $Witness $Instances - (Cons - (+ $W $T) $WT_list) - (Cons $T $T_list)))) -; - - - - (= - ($bagof-instances0 $_ $Witness $Instances $WT_list $T_list) - ( ($unify-witness $WT_list $Witness) (= $Instances $T_list))) -; - - (= - ($bagof-instances0 $S_next $Witness $Instances $_ $_) - ($bagof-instances $S_next $Witness $Instances)) -; - - - - (= - ($variants-subset Nil $W Nil Nil Nil) - (set-det)) -; - - (= - ($variants-subset - (Cons - (+ $W0 $T0) $S) $W - (Cons - (+ $W0 $T0) $WT_list) - (Cons $T0 $T_list) $S_next) - ( ($term-variant $W $W0) - (set-det) - ($variants-subset $S $W $WT_list $T_list $S_next))) -; - - (= - ($variants-subset - (Cons $WT $S) $W $WT_list $T_list - (Cons $WT $S_next)) - ($variants-subset $S $W $WT_list $T_list $S_next)) -; - - - - (= - ($term-variant $X $Y) - ( (new-hash $Hash) ($term-variant $X $Y $Hash))) -; - - - (= - ($term-variant $X $Y $Hash) - ( (var $X) - (set-det) - (det-if-then-else - (hash-contains-key $Hash $X) - (, - (hash-get $Hash $X $V) - (== $Y $V)) - (, - (var $Y) - (hash-put $Hash $X $Y))))) -; - - (= - ($term-variant $X $Y $_) - ( (ground $X) - (set-det) - (== $X $Y))) -; - - (= - ($term-variant $_ $Y $_) - ( (var $Y) - (set-det) - (fail))) -; - - (= - ($term-variant - (Cons $X $Xs) - (Cons $Y $Ys) $Hash) - ( (set-det) - ($term-variant $X $Y $Hash) - ($term-variant $Xs $Ys $Hash))) -; - - (= - ($term-variant $X $Y $Hash) - ( (=.. $X $Xs) - (=.. $Y $Ys) - ($term-variant $Xs $Ys $Hash))) -; - - - - (= - ($unify-witness Nil $_) - (set-det)) -; - - (= - ($unify-witness - (Cons - (+ $W $_) $WT_list) $W) - ($unify-witness $WT_list $W)) -; - - -; -; - - - (= - ($variables-set $X $Vs) - ($variables-set $X Nil $Vs)) -; - - - (= - ($variables-set $X $Vs $Vs) - ( (var $X) - ($builtin-memq $X $Vs) - (set-det))) -; - - (= - ($variables-set $X $Vs - (Cons $X $Vs)) - ( (var $X) (set-det))) -; - - (= - ($variables-set $X $Vs0 $Vs0) - ( (atomic $X) (set-det))) -; - - (= - ($variables-set - (Cons $X $Xs) $Vs0 $Vs) - ( (set-det) - ($variables-set $X $Vs0 $Vs1) - ($variables-set $Xs $Vs1 $Vs))) -; - - (= - ($variables-set $X $Vs0 $Vs) - ( (=.. $X $Xs) ($variables-set $Xs $Vs0 $Vs))) -; - - - - (= - ($builtin-memq $X - (Cons $Y $_)) - ( (== $X $Y) (set-det))) -; - - (= - ($builtin-memq $X - (Cons $_ $Ys)) - ($builtin-memq $X $Ys)) -; - - -; -; - - - (= - ($existential-variables-set $X $Vs) - ($existential-variables-set $X Nil $Vs)) -; - - - (= - ($existential-variables-set $X $Vs $Vs) - ( (var $X) (set-det))) -; - - (= - ($existential-variables-set $X $Vs $Vs) - ( (atomic $X) (set-det))) -; - - (= - ($existential-variables-set - (with_self $_ $X) $Vs0 $Vs) - ( (set-det) ($existential-variables-set $X $Vs0 $Vs))) -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - (= - ($existential-variables-set - (^ $V $G) $Vs0 $Vs) - ( (set-det) - ($variables-set $V $Vs0 $Vs1) - ($existential-variables-set $G $Vs1 $Vs))) -; - - (= - ($existential-variables-set - ($meta-call $G $_ $_ $_ $_) $Vs0 $Vs) - ( (set-det) ($existential-variables-set $G $Vs0 $Vs))) -; - - (= - (%existential_variables_set $_ $Vs $Vs) True) -; - - -; -; - - - (= - ($free-variables-set $T $V $FV) - ( ($variables-set $T $TV) - ($variables-set $V $VV) - ($existential-variables-set $T $VV $BV) - ($builtin-set-diff $TV $BV $FV) - (set-det))) -; - - - - (= - ($builtin-set-diff $L1 $L2 $L) - ( (sort $L1 $SL1) - (sort $L2 $SL2) - ($builtin-set-diff0 $SL1 $SL2 $L))) -; - - - - (= - ($builtin-set-diff0 Nil $_ Nil) - (set-det)) -; - - (= - ($builtin-set-diff0 $L1 Nil $L1) - (set-det)) -; - - (= - ($builtin-set-diff0 - (Cons $X $Xs) - (Cons $Y $Ys) $L) - ( (== $X $Y) - (set-det) - ($builtin-set-diff0 $Xs $Ys $L))) -; - - (= - ($builtin-set-diff0 - (Cons $X $Xs) - (Cons $Y $Ys) - (Cons $X $L)) - ( (@< $X $Y) - (set-det) - ($builtin-set-diff0 $Xs - (Cons $Y $Ys) $L))) -; - - (= - ($builtin-set-diff0 - (Cons $X $Xs) - (Cons $Y $Ys) - (Cons $Y $L)) - ($builtin-set-diff0 - (Cons $X $Xs) $Ys - (Cons $Y $L))) -; - - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - - !(public (/ open 3)) -; - -; -; - - !(public (/ close 1)) -; - -; -; - - !(public (/ flush-output 0)) -; - - !(public (/ stream-property 2)) -; - - - - (= - (open $Source_sink $Mode $Stream) - (open $Source_sink $Mode $Stream Nil)) -; - - - - (= - (close $S_or_a) - (close $S_or_a Nil)) -; - - - - (= - (flush-output) - ( (current-output $S) (flush-output $S))) -; - - - - (= - (stream-property $Stream $Stream_property) - ( (var $Stream_property) - (set-det) - ($stream-property $Stream $Stream_property))) -; - - (= - (stream-property $Stream $Stream_property) - ( ($stream-property-specifier $Stream_property) - (set-det) - ($stream-property $Stream $Stream_property))) -; - - (= - (stream-property $Stream $Stream_property) - (illarg - (domain term stream-property) - (stream-property $Stream $Stream_property) 2)) -; - - - - (= - ($stream-property $Stream $Stream_property) - ( (var $Stream) - (set-det) - ($get-stream-manager $SM) - (hash-map $SM $Map) - ($builtin-member - (, $Stream $Vs) $Map) - (java $Stream) - ($builtin-member $Stream_property $Vs))) -; - - (= - ($stream-property $Stream $Stream_property) - ( (java $Stream) - (set-det) - ($get-stream-manager $SM) - (hash-get $SM $Stream $Vs) - ($builtin-member $Stream_property $Vs))) -; - - (= - ($stream-property $Stream $Stream_property) - (illarg - (domain stream stream) - (stream-property $Stream $Stream_property) 1)) -; - - - - (= - (%stream_property_specifier input) True) -; - - (= - (%stream_property_specifier output) True) -; - - (= - (%stream_property_specifier - (alias $_)) True) -; - - (= - (%stream_property_specifier - (mode $_)) True) -; - - (= - (%stream_property_specifier - (type $_)) True) -; - - (= - (%stream_property_specifier - (file_name $_)) True) -; - - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - - - !(public (, (/ get-char 1) (/ get-code 1))) -; - - !(public (, (/ peek-char 1) (/ peek-code 1))) -; - - !(public (, (/ put-char 1) (/ put-code 1))) -; - - !(public (/ nl 1)) -; - - - - (= - (get-char $Char) - ( (current-input $S) (get-char $S $Char))) -; - - - (= - (get-code $Code) - ( (current-input $S) (get-code $S $Code))) -; - - - - (= - (peek-char $Char) - ( (current-input $S) (peek-char $S $Char))) -; - - - (= - (peek-code $Code) - ( (current-input $S) (peek-code $S $Code))) -; - - - - (= - (put-char $Char) - ( (current-output $S) (put-char $S $Char))) -; - - - (= - (put-code $Code) - ( (current-output $S) (put-code $S $Code))) -; - - - - (= - (nl $S) - (put-char $S -)) -; - - - - !(public (, (/ get0 1) (/ get0 2))) -; - - !(public (/ get 1)) -; - -; -; - - !(public (, (/ put 1) (/ put 2))) -; - - !(public (/ tab 1)) -; - -; -; - - !(public (/ skip 1)) -; - -; -; - - - - (= - (get0 $Code) - ( (current-input $S) (get-code $S $Code))) -; - - (= - (get0 $S_or_a $Code) - (get-code $S_or_a $Code)) -; - - - - (= - (get $Code) - ( (current-input $S) (get $S $Code))) -; - - - - (= - (put $Exp) - ( (current-output $S) (put $S $Exp))) -; - - (= - (put $S_or_a $Exp) - ( (is $Code $Exp) (put-code $S_or_a $Code))) -; - - - - (= - (tab $N) - ( (current-output $S) (tab $S $N))) -; - - - - (= - (skip $N) - ( (current-input $S) (skip $S $N))) -; - - -; -; - -; -; - -; -; - - - !(public (, (/ get-byte 1) (/ peek-byte 1) (/ put-byte 1))) -; - -; -; - -; -; - -; -; - - - - (= - (get-byte $Byte) - ( (current-input $S) (get-byte $S $Byte))) -; - - - - (= - (peek-byte $Byte) - ( (current-input $S) (peek-byte $S $Byte))) -; - - - - (= - (put-byte $Byte) - ( (current-output $S) (put-byte $S $Byte))) -; - - -; -; - -; -; - -; -; - - - !(public (, (/ read 1) (/ read 2))) -; - - !(public (, (/ read-with-variables 2) (/ read-with-variables 3))) -; - - !(public (/ read-line 1)) -; - -; -; - - !(dynamic (/ %tokens 1)) -; - - - - (= - (read $X) - ( (current-input $S) (read $S $X))) -; - - - (= - (read $S_or_a $X) - ( (read-tokens $S_or_a $Tokens $_) - (parse-tokens $X $Tokens) - (set-det))) -; - - - - (= - (read-with-variables $X $Vs) - ( (current-input $S) (read-with-variables $S $X $Vs))) -; - - - (= - (read-with-variables $S_or_a $X $Vs) - ( (read-tokens $S_or_a $Tokens $Vs) - (parse-tokens $X $Tokens) - (set-det))) -; - - - - (= - (read-line $X) - ( (current-input $S) (read-line $S $X))) -; - - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - -; -; - - - - (= - (read-token $S_or_a $Token) - ( ($read-token0 $S_or_a $Type $Token0) ($read-token1 (:: $Type) $Token0 $Token))) -; - - - - (= - ($read-token1 - (:: -2) $T - (error $T)) - (set-det)) -; - ; -; - - (= - ($read-token1 "I" $T - (number $T)) - (set-det)) -; - ; -; - - (= - ($read-token1 "L" $T - (number $T)) - (set-det)) -; - ; -; - - (= - ($read-token1 "D" $T - (number $T)) - (set-det)) -; - ; -; - - (= - ($read-token1 "A" $T - (atom $T)) - (set-det)) -; - ; -; - - (= - ($read-token1 "V" $T - (var $T)) - (set-det)) -; - ; -; - - (= - ($read-token1 "S" $T - (string $T)) - (set-det)) -; - ; -; - - (= - ($read-token1 $_ $T $T) - (set-det)) -; - ; -; - - -; -; - -; -; - -; -; - -; -; - -; -; - - -; -; - -; -; - -; -; - -; -; - - - - (= - (read-tokens $Stream $Tokens $Vs) - ( ($read-tokens $Stream $Tokens $Vs Nil) (set-det))) -; - - - - (= - ($read-tokens $Stream $Tokens $Vs $VI) - ( (read-token $Stream $Token) ($read-tokens1 $Stream $Token $Tokens $Vs $VI))) -; - - - - (= - ($read-tokens1 $Stream - (error $Message) Nil $_ $_) - ( (set-det) - (write user-error '{SYNTAX ERROR}') - (nl user-error) - (write user-error ** ) - (write user-error $Message) - (write user-error **) - (nl user-error) - (flush-output user-error) - ($read-tokens-until-fullstop $Stream) - (fail))) -; - - (= - ($read-tokens1 $Stream end-of-file - (:: end-of-file .) Nil $_) - (set-det)) -; - - (= - ($read-tokens1 $Stream . - (:: .) Nil $_) - (set-det)) -; - - (= - ($read-tokens1 $Stream - (var -) - (Cons - (var - $V) $Tokens) - (Cons - (= - $V) $Vs) $VI0) - ( (set-det) ($read-tokens $Stream $Tokens $Vs (Cons (= - $V) $VI0)))) -; - - (= - ($read-tokens1 $Stream - (var $Name) - (Cons - (var $Name $V) $Tokens) $Vs $VI) - ( ($mem-pair - (= $Name $V) $VI) - (set-det) - ($read-tokens $Stream $Tokens $Vs $VI))) -; - - (= - ($read-tokens1 $Stream - (var $Name) - (Cons - (var $Name $V) $Tokens) - (Cons - (= $Name $V) $Vs) $VI0) - ( (set-det) ($read-tokens $Stream $Tokens $Vs (Cons (= $Name $V) $VI0)))) -; - - (= - ($read-tokens1 $Stream $Token - (Cons $Token $Tokens) $Vs $VI) - ($read-tokens $Stream $Tokens $Vs $VI)) -; - - - - (= - ($mem-pair - (= $X1 $V1) - (Cons - (= $X2 $V2) $_)) - ( (== $X1 $X2) - (set-det) - (= $V1 $V2))) -; - - (= - ($mem-pair $X - (Cons $_ $L)) - ($mem-pair $X $L)) -; - -; -; - - - - (= - ($read-tokens-until-fullstop $Stream) - ( (read-token $Stream $Token) ($read-tokens-until-fullstop $Stream $Token))) -; - - - (= - ($read-tokens-until-fullstop $Stream end-of-file) - (set-det)) -; - - (= - ($read-tokens-until-fullstop $Stream .) - (set-det)) -; - - (= - ($read-tokens-until-fullstop $Stream $_) - ( (read-token $Stream $Token) ($read-tokens-until-fullstop $Stream $Token))) -; - - - - (= - (parse-tokens $X $Tokens) - ( (remove-all-symbols &self - ($tokens $_)) - (add-symbol &self - ($tokens $Tokens)) - ($parse-tokens $X 1201 $Tokens - (:: .)) - (remove-symbol &self - ($tokens $Tokens)) - (set-det))) -; - - -; -; - - - (= - (, - (--> - (%parse_tokens $X $Prec0) $parse_tokens_skip_spaces) - (, - (%parse_tokens1 $Prec0 $X1 $Prec1) - (, ! - (, $parse_tokens_skip_spaces - (, - (%parse_tokens2 $Prec0 $X1 $Prec1 $X $Prec) !))))) True) -; - - - (= - (, - (--> - (%parse_tokens1 $Prec0 $X1 $Prec1) - (%parse_tokens_peep_next $Next)) - (, - { (%parse_tokens_is_starter $Next) } - (, ! - (%parse_tokens_before_op $Prec0 $X1 $Prec1)))) True) -; - - (= - (, - (--> - (%parse_tokens1 $_ $_ $_) - (%parse_tokens_peep_next $Next)) - (%parse_tokens_error - ($Next cannot start an expression))) True) -; - - - (= - (, - (--> - (%parse_tokens2 $Prec0 $X $Prec $X $Prec) - (%parse_tokens_peep_next $Next)) - (, - { (%parse_tokens_is_terminator $Next) } - (, - { (=< $Prec $Prec0) } !))) True) -; - - (= - (, - (--> - (%parse_tokens2 $Prec0 $X1 $Prec1 $X $Prec) - (%parse_tokens_peep_next $Next)) - (, - { (%parse_tokens_is_post_in_op $Next) } - (, ! - (%parse_tokens_post_in_ops $Prec0 $X1 $Prec1 $X $Prec)))) True) -; - - - (= - (--> - (%parse_tokens2 $_ $_ $_ $_ $_) - (%parse_tokens_error - (operator expected after expression))) True) -; - - -; -; - -; -; - -; -; - - - (= - (, - (--> - (%parse_tokens_before_op $Prec0 $X $Prec) - (' ')) - (, ! - (%parse_tokens_before_op $Prec0 $X $Prec))) True) -; - - (= - (, - (--> - (%parse_tokens_before_op $_ end_of_file 0) - (end_of_file)) !) True) -; - - (= - (, - (--> - (%parse_tokens_before_op $_ $N 0) - ( (number $N))) !) True) -; - - (= - (, - (--> - (%parse_tokens_before_op $_ $N 0) - ( (is-symbol -))) - (, - ( (number $N0)) - (, ! - { (is $N - (- $N0)) }))) True) -; - - (= - (, - (--> - (%parse_tokens_before_op $_ $V 0) - ( (var $_ $V))) !) True) -; - - (= - (, - (--> - (%parse_tokens_before_op $_ $S 0) - ( (string $S))) !) True) -; - - (= - (, - (--> - (%parse_tokens_before_op $_ $X 0) - (()) - (, ! - (, - (%parse_tokens $X 1201) - (%parse_tokens_expect ))))) True) -; - - (= - (, - (--> - (%parse_tokens_before_op $_ $X 0) - ({)) - (, ! - (, $parse_tokens_skip_spaces - (%parse_tokens_brace $X)))) True) -; - - (= - (, - (--> - (%parse_tokens_before_op $_ $X 0) - ([)) - (, ! - (, $parse_tokens_skip_spaces - (%parse_tokens_list $X)))) True) -; - - (= - (, - (--> - (%parse_tokens_before_op $_ $X 0) - ( (is-symbol $F))) - (, - (() - (, ! - (, $parse_tokens_skip_spaces - (, - (%parse_tokens_args $Args) - { (=.. $X - (Cons $F $Args)) }))))) True) -; - - (= - (, - (--> - (%parse_tokens_before_op $Prec0 $X $PrecOp) - ( (is-symbol $F))) - (, - { (current_op $PrecOp fx $F) } - (, - { (=< $PrecOp $Prec0) } - (, $parse_tokens_skip_spaces - (, - (%parse_tokens_peep_next $Next) - (, - { (%parse_tokens_is_starter $Next) } - (, - { (\+ - (%parse_tokens_is_post_in_op $Next)) } - (, ! - (, - { (is $Prec1 - (- $PrecOp 1)) } - (, - (%parse_tokens $Arg $Prec1) - (, - { (functor $X $F 1) } - { (arg 1 $X $Arg) }))))))))))) True) -; - - (= - (, - (--> - (%parse_tokens_before_op $Prec0 $X $PrecOp) - ( (is-symbol $F))) - (, - { (current_op $PrecOp fy $F) } - (, - { (=< $PrecOp $Prec0) } - (, $parse_tokens_skip_spaces - (, - (%parse_tokens_peep_next $Next) - (, - { (%parse_tokens_is_starter $Next) } - (, - { (\+ - (%parse_tokens_is_post_in_op $Next)) } - (, ! - (, - (%parse_tokens $Arg $PrecOp) - (, - { (functor $X $F 1) } - { (arg 1 $X $Arg) })))))))))) True) -; - - - (= - (--> - (%parse_tokens_before_op $_ $A 0) - ( (is-symbol $A))) True) -; - - - - (= - (, - (--> - (%parse_tokens_brace {}) - (})) !) True) -; - - (= - (, - (--> - (%parse_tokens_brace $X) - (%parse_tokens $X1 1201)) - (, - (%parse_tokens_expect }) - { (= $X - {$X1 }) })) True) -; - - - (= - (, - (--> - (%parse_tokens_list []) - (])) !) True) -; - - (= - (, - (--> - (%parse_tokens_list - (Cons $X $Xs)) - (%parse_tokens $X 999)) - (, $parse_tokens_skip_spaces - (%parse_tokens_list_rest $Xs))) True) -; - - - (= - (, - (--> - (%parse_tokens_list_rest $Xs) - (|)) - (, ! - (, - (%parse_tokens $Xs 999) - (%parse_tokens_expect ])))) True) -; - - (= - (, - (--> - (%parse_tokens_list_rest - (Cons $X $Xs)) - (,)) - (, ! - (, - (%parse_tokens $X 999) - (, $parse_tokens_skip_spaces - (%parse_tokens_list_rest $Xs))))) True) -; - - - (= - (--> - (%parse_tokens_list_rest []) - (%parse_tokens_expect ])) True) -; - - - - (= - (, - (--> - (%parse_tokens_args []) - ())) !) True) -; - - (= - (, - (--> - (%parse_tokens_args - (Cons $X $Xs)) - (%parse_tokens $X 999)) - (, $parse_tokens_skip_spaces - (%parse_tokens_args_rest $Xs))) True) -; - - - (= - (, - (--> - (%parse_tokens_args_rest - (Cons $X $Xs)) - (,)) - (, ! - (, - (%parse_tokens $X 999) - (, $parse_tokens_skip_spaces - (%parse_tokens_args_rest $Xs))))) True) -; - - - (= - (--> - (%parse_tokens_args_rest []) - (%parse_tokens_expect ))) True) -; - - -; -; - -; -; - -; -; - - - (= - (, - (--> - (%parse_tokens_post_in_ops $Prec0 $X1 $Prec1 $X $Prec) $parse_tokens_skip_spaces) - (, - ($Op) - (, - (%parse_tokens_op $Op $Prec0 $X1 $Prec1 $X2 $Prec2) - (%parse_tokens_post_in_ops $Prec0 $X2 $Prec2 $X $Prec)))) True) -; - - - (= - (--> - (%parse_tokens_post_in_ops $Prec0 $X $Prec $X $Prec) - { (=< $Prec $Prec0) }) True) -; - - - - (= - (, - (--> - (%parse_tokens_op , $Prec0 $X1 $Prec1 $X $PrecOp) !) - (%parse_tokens_op - (is-symbol ,) $Prec0 $X1 $Prec1 $X $PrecOp)) True) -; - - (= - (, - (--> - (%parse_tokens_op | $Prec0 $X1 $Prec1 $X $PrecOp) !) - (%parse_tokens_op - (is-symbol ;) $Prec0 $X1 $Prec1 $X $PrecOp)) True) -; - - (= - (, - (--> - (%parse_tokens_op - (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) - { (current_op $PrecOp xf $Op) }) - (, - { (=< $PrecOp $Prec0) } - (, - { (< $Prec1 $PrecOp) } - (, - { (functor $X $Op 1) } - { (arg 1 $X $X1) })))) True) -; - - (= - (, - (--> - (%parse_tokens_op - (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) - { (current_op $PrecOp yf $Op) }) - (, - { (=< $PrecOp $Prec0) } - (, - { (=< $Prec1 $PrecOp) } - (, - { (functor $X $Op 1) } - { (arg 1 $X $X1) })))) True) -; - - (= - (, - (--> - (%parse_tokens_op - (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) - { (current_op $PrecOp xfx $Op) }) - (, - { (=< $PrecOp $Prec0) } - (, - { (< $Prec1 $PrecOp) } - (, - { (is $Prec2 - (- $PrecOp 1)) } - (, - (%parse_tokens $X2 $Prec2) - (, ! - (, - { (functor $X $Op 2) } - (, - { (arg 1 $X $X1) } - { (arg 2 $X $X2) })))))))) True) -; - - (= - (, - (--> - (%parse_tokens_op - (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) - { (current_op $PrecOp xfy $Op) }) - (, - { (=< $PrecOp $Prec0) } - (, - { (< $Prec1 $PrecOp) } - (, - { (is $Prec2 $PrecOp) } - (, - (%parse_tokens $X2 $Prec2) - (, ! - (, - { (functor $X $Op 2) } - (, - { (arg 1 $X $X1) } - { (arg 2 $X $X2) })))))))) True) -; - - (= - (, - (--> - (%parse_tokens_op - (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) - { (current_op $PrecOp yfx $Op) }) - (, - { (=< $PrecOp $Prec0) } - (, - { (=< $Prec1 $PrecOp) } - (, - { (is $Prec2 - (- $PrecOp 1)) } - (, - (%parse_tokens $X2 $Prec2) - (, ! - (, - { (functor $X $Op 2) } - (, - { (arg 1 $X $X1) } - { (arg 2 $X $X2) })))))))) True) -; - - - - (= - (%parse_tokens_is_starter end_of_file) True) -; - - (= - (%parse_tokens_is_starter () True) -; - - (= - (%parse_tokens_is_starter [) True) -; - - (= - (%parse_tokens_is_starter {) True) -; - - (= - (%parse_tokens_is_starter - (number $_)) True) -; - - (= - (%parse_tokens_is_starter - (is-symbol $_)) True) -; - - (= - (%parse_tokens_is_starter - (var $_ $_)) True) -; - - (= - (%parse_tokens_is_starter - (string $_)) True) -; - - - - (= - (%parse_tokens_is_terminator )) True) -; - - (= - (%parse_tokens_is_terminator ]) True) -; - - (= - (%parse_tokens_is_terminator }) True) -; - - (= - (%parse_tokens_is_terminator .) True) -; - - - - (= - ($parse-tokens-is-post-in-op ,) - (set-det)) -; - - (= - ($parse-tokens-is-post-in-op |) - (set-det)) -; - - (= - ($parse-tokens-is-post-in-op (atom $Op)) - ( (current-op $_ $Type $Op) - ($parse-tokens-post-in-type $Type) - (set-det))) -; - - - - (= - (%parse_tokens_post_in_type xfx) True) -; - - (= - (%parse_tokens_post_in_type xfy) True) -; - - (= - (%parse_tokens_post_in_type yfx) True) -; - - (= - (%parse_tokens_post_in_type xf) True) -; - - (= - (%parse_tokens_post_in_type yf) True) -; - - - - (= - (, - (--> - (%parse_tokens_expect $Token) $parse_tokens_skip_spaces) - (, - ($Token) !)) True) -; - - - (= - (--> - (%parse_tokens_expect $Token) - (%parse_tokens_error - ($Token expected))) True) -; - - - - (= - (, - (--> $parse_tokens_skip_spaces - (' ')) - (, ! $parse_tokens_skip_spaces)) True) -; - - - (= - (--> $parse_tokens_skip_spaces ()) True) -; - - - - (= - ($parse-tokens-peep-next $Next $S $S) - (= $S - (Cons $Next $_))) -; - - - - (= - ($parse-tokens-error $Message $S0 $S) - ( (write user-error '{SYNTAX ERROR}') - (nl user-error) - (write user-error ** ) - ($parse-tokens-write-message user-error $Message) - (write user-error **) - (nl user-error) - ($parse-tokens-error1 Nil $S0) - (get-symbols &self - (= - ($tokens $Tokens) $_)) - ($parse-tokens-error1 $Tokens $S0) - (flush-output user-error) - (fail))) -; - - - - (= - ($parse-tokens-error1 Nil $_) - (set-det)) -; - - (= - ($parse-tokens-error1 $Tokens $S0) - ( (== $Tokens $S0) - (set-det) - (nl user-error) - (write user-error '** here **') - (nl user-error) - ($parse-tokens-error1 $Tokens Nil) - (nl user-error))) -; - - (= - ($parse-tokens-error1 - (Cons $Token $Tokens) $S0) - ( ($parse-tokens-error2 $Token) ($parse-tokens-error1 $Tokens $S0))) -; - - - - (= - ($parse-tokens-error2 (number $X)) - ( (set-det) (write $X))) -; - - (= - ($parse-tokens-error2 (atom $X)) - ( (set-det) (writeq $X))) -; - - (= - ($parse-tokens-error2 (var $X $_)) - ( (set-det) (write $X))) -; - - (= - ($parse-tokens-error2 (string $X)) - ( (set-det) - (write user-error ") - ($parse-tokens-write-string user-error $X) - (write user-error "))) -; - - (= - ($parse-tokens-error2 $X) - (write user-error $X)) -; - - - - (= - (%parse_tokens_write_string $_ ()) True) -; - - (= - ($parse-tokens-write-string $S - (Cons $C $Cs)) - ( (= - (:: $C) "\"") - (set-det) - (put-code $S $C) - (put-code $S $C) - ($parse-tokens-write-string $S $Cs))) -; - - (= - ($parse-tokens-write-string $S - (Cons $C $Cs)) - ( (put-code $S $C) ($parse-tokens-write-string $S $Cs))) -; - - - - (= - (%parse_tokens_write_message $_ ()) True) -; - - (= - ($parse-tokens-write-message $S - (Cons $X $Xs)) - ( (write $S $X) - (write $S ' ') - ($parse-tokens-write-message $S $Xs))) -; - - -; -; - -; -; - -; -; - - - !(public (, (/ write 1) (/ write 2))) -; - - !(public (, (/ writeq 1) (/ writeq 2))) -; - - !(public (, (/ write-canonical 1) (/ write-canonical 2))) -; - - !(public (, (/ write-term 2) (/ write-term 3))) -; - - - - (= - (write $Term) - ( (current-output $S) (write-term $S $Term (:: (numbervars True))))) -; - - - (= - (write $S_or_a $Term) - (write-term $S_or_a $Term - (:: (numbervars True)))) -; - - - - (= - (writeq $Term) - ( (current-output $S) (write-term $S $Term (:: (quoted True) (numbervars True))))) -; - - - (= - (writeq $S_or_a $Term) - (write-term $S_or_a $Term - (:: - (quoted True) - (numbervars True)))) -; - - - - (= - (write-canonical $Term) - ( (current-output $S) (write-term $S $Term (:: (quoted True) (ignore-ops True))))) -; - - - (= - (write-canonical $S_or_a $Term) - (write-term $S_or_a $Term - (:: - (quoted True) - (ignore-ops True)))) -; - - - - (= - (write-term $Term $Options) - ( (current-output $S) (write-term $S $Term $Options))) -; - - - (= - (write-term $S_or_a $Term $Options) - ( ($write-term $S_or_a $Term $Options) (fail))) -; - - (= - (write_term $_ $_ $_) True) -; - - - - (= - ($write-term $S_or_a $Term $Options) - ( ($write-term0 $Term 1200 punct $_ $Options $S_or_a) (set-det))) -; - - - - (= - ($write-term0 $Term $Prec $Type0 alpha $_ $S_or_a) - ( (var $Term) - (set-det) - ($write-space-if-needed $Type0 alpha $S_or_a) - ($fast-write $S_or_a $Term))) -; - - (= - ($write-term0 $Term $Prec $Type0 alpha $_ $S_or_a) - ( (java $Term) - (set-det) - ($write-space-if-needed $Type0 alpha $S_or_a) - ($fast-write $S_or_a $Term))) -; - - (= - ($write-term0 $Term $Prec $Type0 alpha $Style $S_or_a) - ( (= $Term $VN) - (integer $VN) - (>= $VN 0) - ($builtin-member - (numbervars True) $Style) - (set-det) - ($write-space-if-needed $Type0 alpha $S_or_a) - ($write-VAR $VN $S_or_a))) -; - - (= - ($write-term0 $Term $Prec $Type0 alpha $_ $S_or_a) - ( (number $Term) - (< $Term 0) - (set-det) - ($write-space-if-needed $Type0 symbol $S_or_a) - ($fast-write $S_or_a $Term))) -; - - (= - ($write-term0 $Term $Prec $Type0 alpha $_ $S_or_a) - ( (number $Term) - (set-det) - ($write-space-if-needed $Type0 alpha $S_or_a) - ($fast-write $S_or_a $Term))) -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - (= - ($write-term0 $Term $Prec $Type0 $Type $Style $S_or_a) - ( (atom $Term) - (set-det) - ($write-atom $Term $Type0 $Type $Style $S_or_a))) -; - - (= - ($write-term0 $Term $Prec $Type0 $Type $Style $S_or_a) - ( (not ($builtin-member (ignore-ops True) $Style)) - ($write-is-operator $Term $Op $Args $OpType) - (set-det) - ($write-term-op $Op $OpType $Args $Prec $Type0 $Type $Style $S_or_a))) -; - - (= - ($write-term0 $Term $Prec $Type0 punct $Style $S_or_a) - ( (= $Term - (Cons $_ $_)) - (not ($builtin-member (ignore-ops True) $Style)) - (set-det) - ($write-space-if-needed $Type0 punct $S_or_a) - (put-char $S_or_a [) - ($write-term-list-args $Term punct $_ $Style $S_or_a) - (put-char $S_or_a ]))) -; - - (= - ($write-term0 $Term $Prec $Type0 $Type $Style $S_or_a) - ( (= $Term - {$Term1 }) - (not ($builtin-member (ignore-ops True) $Style)) - (set-det) - ($write-space-if-needed $Type0 punct $S_or_a) - (put-char $S_or_a {) - ($write-term0 $Term1 1200 punct $_ $Style $S_or_a) - (put-char $S_or_a }))) -; - - (= - ($write-term0 $Term $Prec $Type0 punct $Style $S_or_a) - ( (=.. $Term - (Cons $F $Args)) - ($write-atom $F $Type0 $_ $Style $S_or_a) - (put-char $S_or_a () - ($write-term-args $Args punct $_ $Style $S_or_a) - (put-char $S_or_a )))) -; - - - - (= - ($write-space-if-needed punct $_ $_) - (set-det)) -; - - (= - ($write-space-if-needed $X $X $S_or_a) - ( (set-det) (put-char $S_or_a ' '))) -; - - (= - ($write-space-if-needed other alpha $S_or_a) - ( (set-det) (put-char $S_or_a ' '))) -; - - (= - (%write_space_if_needed $_ $_ $_) True) -; - - - - (= - ($write-VAR $VN $S_or_a) - ( (< $VN 26) - (set-det) - (is $Letter - (+ - (mod $VN 26) "A")) - (put-code $S_or_a $Letter))) -; - - (= - ($write-VAR $VN $S_or_a) - ( (is $Letter - (+ - (mod $VN 26) "A")) - (put-code $S_or_a $Letter) - (is $Rest - (// $VN 26)) - ($fast-write $S_or_a $Rest))) -; - - - - (= - ($write-atom $Atom $Type0 $Type $Style $S_or_a) - ( ($builtin-member - (quoted True) $Style) - (set-det) - ($atom-type $Atom $Type) - ($write-space-if-needed $Type0 $Type $S_or_a) - ($fast-writeq $S_or_a $Atom))) -; - - (= - ($write-atom $Atom $Type0 $Type $_ $S_or_a) - ( ($atom-type $Atom $Type) - ($write-space-if-needed $Type0 $Type $S_or_a) - ($fast-write $S_or_a $Atom))) -; - - - - (= - ($atom-type $X alpha) - ( ($atom-type0 $X 0) (set-det))) -; - - (= - ($atom-type $X symbol) - ( ($atom-type0 $X 1) (set-det))) -; - - (= - ($atom-type $X punct) - ( ($atom-type0 $X 2) (set-det))) -; - - (= - ($atom-type $X other) - ( ($atom-type0 $X 3) (set-det))) -; - - - - (= - ($write-is-operator $Term $Op $Args $OpType) - ( (functor $Term $Op $Arity) - ($write-op-type $Arity $OpType) - (current-op $_ $OpType $Op) - (=.. $Term - (Cons $_ $Args)) - (set-det))) -; - - - - (= - (%write_op_type 1 fx) True) -; - - (= - (%write_op_type 1 fy) True) -; - - (= - (%write_op_type 1 xf) True) -; - - (= - (%write_op_type 1 yf) True) -; - - (= - (%write_op_type 2 xfx) True) -; - - (= - (%write_op_type 2 xfy) True) -; - - (= - (%write_op_type 2 yfx) True) -; - - - - (= - ($write-term-op $Op $OpType $Args $Prec $Type0 punct $Style $S_or_a) - ( (current-op $PrecOp $OpType $Op) - (> $PrecOp $Prec) - (set-det) - ($write-space-if-needed $Type0 punct $S_or_a) - (put-char $S_or_a () - ($write-term-op1 $Op $OpType $Args $PrecOp punct $_ $Style $S_or_a) - (put-char $S_or_a )))) -; - - (= - ($write-term-op $Op $OpType $Args $Prec $Type0 $Type $Style $S_or_a) - ( (current-op $PrecOp $OpType $Op) ($write-term-op1 $Op $OpType $Args $PrecOp $Type0 $Type $Style $S_or_a))) -; - - - - (= - ($write-term-op1 $Op fx - (:: $A1) $PrecOp $Type0 $Type $Style $S_or_a) - ( (set-det) - ($write-atom $Op $Type0 $Type1 $Style $S_or_a) - (is $Prec1 - (- $PrecOp 1)) - ($write-term0 $A1 $Prec1 $Type1 $Type $Style $S_or_a))) -; - - (= - ($write-term-op1 $Op fy - (:: $A1) $PrecOp $Type0 $Type $Style $S_or_a) - ( (set-det) - ($write-atom $Op $Type0 $Type1 $Style $S_or_a) - (is $Prec1 $PrecOp) - ($write-term0 $A1 $Prec1 $Type1 $Type $Style $S_or_a))) -; - - (= - ($write-term-op1 $Op xf - (:: $A1) $PrecOp $Type0 $Type $Style $S_or_a) - ( (set-det) - (is $Prec1 - (- $PrecOp 1)) - ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) - ($write-atom $Op $Type1 $Type $Style $S_or_a))) -; - - (= - ($write-term-op1 $Op yf - (:: $A1) $PrecOp $Type0 $Type $Style $S_or_a) - ( (set-det) - (is $Prec1 $PrecOp) - ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) - ($write-atom $Op $Type1 $Type $Style $S_or_a))) -; - - (= - ($write-term-op1 $Op xfx - (:: $A1 $A2) $PrecOp $Type0 $Type $Style $S_or_a) - ( (set-det) - (is $Prec1 - (- $PrecOp 1)) - (is $Prec2 - (- $PrecOp 1)) - ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) - ($write-term-infix-op $Op $Type1 $Type2 $Style $S_or_a) - ($write-term0 $A2 $Prec2 $Type2 $Type $Style $S_or_a))) -; - - (= - ($write-term-op1 $Op xfy - (:: $A1 $A2) $PrecOp $Type0 $Type $Style $S_or_a) - ( (set-det) - (is $Prec1 - (- $PrecOp 1)) - (is $Prec2 $PrecOp) - ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) - ($write-term-infix-op $Op $Type1 $Type2 $Style $S_or_a) - ($write-term0 $A2 $Prec2 $Type2 $Type $Style $S_or_a))) -; - - (= - ($write-term-op1 $Op yfx - (:: $A1 $A2) $PrecOp $Type0 $Type $Style $S_or_a) - ( (set-det) - (is $Prec1 $PrecOp) - (is $Prec2 - (- $PrecOp 1)) - ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) - ($write-term-infix-op $Op $Type1 $Type2 $Style $S_or_a) - ($write-term0 $A2 $Prec2 $Type2 $Type $Style $S_or_a))) -; - - - - (= - ($write-term-infix-op , $Type0 punct $_ $S_or_a) - ( (set-det) - ($write-space-if-needed $Type0 punct $S_or_a) - (put-char $S_or_a ,))) -; - - (= - ($write-term-infix-op $Op $Type0 $Type $Style $S_or_a) - ($write-atom $Op $Type0 $Type $Style $S_or_a)) -; - - - - (= - ($write-term-list-args - (Cons $A $As) $Type0 $Type $Style $S_or_a) - ( (nonvar $As) - (= $As - (Cons $_ $_)) - (set-det) - ($write-term0 $A 999 $Type0 $Type1 $Style $S_or_a) - ($write-space-if-needed $Type1 punct $S_or_a) - (put-char $S_or_a ,) - ($write-term-list-args $As punct $Type $Style $S_or_a))) -; - - - (= - ($write-term-list-args - (Cons $A $As) $Type0 $Type $Style $S_or_a) - ( (nonvar $As) - (= $As Nil) - (set-det) - ($write-term0 $A 999 $Type0 $Type $Style $S_or_a))) -; - - - (= - ($write-term-list-args - (Cons $A $As) $Type0 $Type $Style $S_or_a) - ( ($write-term0 $A 999 $Type0 $Type1 $Style $S_or_a) - ($write-space-if-needed $Type1 punct $S_or_a) - (put-char $S_or_a |) - ($write-term0 $As 999 punct $Type $Style $S_or_a))) -; - - - - (= - ($write-term-args Nil $Type $Type $_ $_) - (set-det)) -; - - (= - ($write-term-args - (:: $A) $Type0 $Type $Style $S_or_a) - ( (set-det) ($write-term0 $A 999 $Type0 $Type $Style $S_or_a))) -; - - (= - ($write-term-args - (Cons $A $As) $Type0 $Type $Style $S_or_a) - ( (set-det) - ($write-term0 $A 999 $Type0 $Type1 $Style $S_or_a) - ($write-space-if-needed $Type1 punct $S_or_a) - (put-char $S_or_a ,) - ($write-term-args $As punct $Type $Style $S_or_a))) -; - - -; -; - -; -; - -; -; - - - !(public (/ op 3)) -; - - !(public (/ current-op 3)) -; - - !(dynamic (/ %current-operator 3)) -; - - - - (= - (op $Priority $Op_specifier $Operator) - ( (integer $Priority) - (=< 0 $Priority) - (=< $Priority 1200) - (set-det) - ($op1 $Priority $Op_specifier $Operator))) -; - - (= - (op $Priority $Op_specifier $Operator) - (illarg - (domain integer - (- 0 1200)) - (op $Priority $Op_specifier $Operator) 1)) -; - - - - (= - ($op1 $Priority $Op_specifier $Operator) - ( (nonvar $Op_specifier) - ($op-specifier $Op_specifier $_) - (set-det) - ($op2 $Priority $Op_specifier $Operator))) -; - - (= - ($op1 $Priority $Op_specifier $Operator) - ( (findall $X - ($op-specifier $X $_) $Domain) (illarg (domain term $Domain) (op $Priority $Op_specifier $Operator) 2))) -; - - - - (= - ($op2 $Priority $Op_specifier $Operator) - ( (atom $Operator) - (set-det) - ($add-operators - (:: $Operator) $Priority $Op_specifier))) -; - - (= - ($op2 $Priority $Op_specifier $Operator) - ( ($op-atom-list $Operator $Atoms) - (set-det) - ($add-operators $Atoms $Priority $Op_specifier))) -; - - (= - ($op2 $Priority $Op_specifier $Operator) - (illarg - (type (list is-symbol)) - (op $Priority $Op_specifier $Operator) 3)) -; - - - - (= - ($add-operators Nil $_ $_) - (set-det)) -; - - (= - ($add-operators - (Cons $A $As) $Priority $Op_specifier) - ( ($add-op $A $Priority $Op_specifier) ($add-operators $As $Priority $Op_specifier))) -; - - - - (= - ($add-op , $Priority $Op_specifier) - ( (set-det) (illarg (permission modify operator , $_) (op $Priority $Op_specifier ,) 3))) -; - - (= - ($add-op $A $_ $Op_specifier) - ( (get-symbols &self - (= - (%current_operator $_ $Op_specifier0 $A) $_)) - ($op-specifier $Op_specifier $Class) - ($op-specifier $Op_specifier0 $Class0) - (= $Class $Class0) - (remove-symbol &self - (%current_operator $_ $Op_specifier0 $A)) - (fail))) -; - - (= - ($add-op $_ 0 $_) - (set-det)) -; - - (= - ($add-op $A $Priority $Op_specifier) - (add-symbol &self - (%current_operator $Priority $Op_specifier $A))) -; - - - - (= - (%op_specifier fx prefix) True) -; - - (= - (%op_specifier fy prefix) True) -; - - (= - (%op_specifier xfx infix) True) -; - - (= - (%op_specifier xfy infix) True) -; - - (= - (%op_specifier yfx infix) True) -; - - (= - (%op_specifier xf postfix) True) -; - - (= - (%op_specifier yf postfix) True) -; - - - - (= - ($op-atom-list $X $_) - ( (var $X) - (set-det) - (fail))) -; - - (= - ($op-atom-list Nil Nil) - (set-det)) -; - - (= - ($op-atom-list - (Cons $X $Xs) - (Cons $X $As)) - ( (atom $X) - (set-det) - ($op-atom-list $Xs $As))) -; - - - - (= - (current-op $Priority $Op_specifier $Operator) - (get-symbols &self - (= - (%current_operator $Priority $Op_specifier $Operator) $_))) -; - - - - (= - (%current_operator 1200 xfx :-) True) -; - - (= - (%current_operator 1200 xfx -->) True) -; - - (= - (%current_operator 1200 fx :-) True) -; - - (= - (%current_operator 1200 fx ?-) True) -; - - (= - (%current_operator 1150 fx package) True) -; - - (= - (%current_operator 1150 fx import) True) -; - - (= - (%current_operator 1150 fx include) True) -; - - (= - (%current_operator 1150 fx include_resource) True) -; - - (= - (%current_operator 1150 fx constant) True) -; - - (= - (%current_operator 1150 fx public) True) -; - - (= - (%current_operator 1150 fx dynamic) True) -; - - (= - (%current_operator 1150 fx meta_predicate) True) -; - - (= - (%current_operator 1150 fx mode) True) -; - - (= - (%current_operator 1150 fx multifile) True) -; - - (= - (%current_operator 1150 fx block) True) -; - - (= - (%current_operator 1150 fx ifdef) True) -; - - (= - (%current_operator 1150 fx ifndef) True) -; - - (= - (%current_operator 1150 fx domain) True) -; - - (= - (%current_operator 1150 fx database) True) -; - - (= - (%current_operator 1100 xfy ;) True) -; - - (= - (%current_operator 1050 xfy ->) True) -; - - (= - (%current_operator 1000 xfy ,) True) -; - - (= - (%current_operator 900 fy \+) True) -; - - (= - (%current_operator 700 xfx =) True) -; - - (= - (%current_operator 700 xfx \=) True) -; - - (= - (%current_operator 700 xfx ==) True) -; - - (= - (%current_operator 700 xfx \==) True) -; - - (= - (%current_operator 700 xfx @<) True) -; - - (= - (%current_operator 700 xfx @>) True) -; - - (= - (%current_operator 700 xfx @=<) True) -; - - (= - (%current_operator 700 xfx @>=) True) -; - - (= - (%current_operator 700 xfx =..) True) -; - - (= - (%current_operator 700 xfx is) True) -; - - (= - (%current_operator 700 xfx =:=) True) -; - - (= - (%current_operator 700 xfx =\=) True) -; - - (= - (%current_operator 700 xfx <) True) -; - - (= - (%current_operator 700 xfx >) True) -; - - (= - (%current_operator 700 xfx =<) True) -; - - (= - (%current_operator 700 xfx >=) True) -; - - (= - (%current_operator 550 xfy :) True) -; - - (= - (%current_operator 500 yfx +) True) -; - - (= - (%current_operator 500 yfx -) True) -; - - (= - (%current_operator 500 yfx #) True) -; - - (= - (%current_operator 500 yfx /\) True) -; - - (= - (%current_operator 500 yfx \/) True) -; - - (= - (%current_operator 500 fx +) True) -; - - (= - (%current_operator 400 yfx *) True) -; - - (= - (%current_operator 400 yfx /) True) -; - - (= - (%current_operator 400 yfx //) True) -; - - (= - (%current_operator 400 yfx mod) True) -; - - (= - (%current_operator 400 yfx rem) True) -; - - (= - (%current_operator 400 yfx <<) True) -; - - (= - (%current_operator 400 yfx >>) True) -; - - (= - (%current_operator 300 xfx ~) True) -; - - (= - (%current_operator 200 xfx **) True) -; - - (= - (%current_operator 200 xfy ^) True) -; - - (= - (%current_operator 200 fy \) True) -; - - (= - (%current_operator 200 fy -) True) -; - - -; -; - -; -; - -; -; - - - !(public (/ \+ 1)) -; - - !(public (/ once 1)) -; - - !(public (/ repeat 0)) -; - - - - (= - (not $G) - ( (call $G) - (set-det) - (fail))) -; - - (= - (\+ $_) True) -; - - - - (= repeat True) -; - - (= - (repeat) - (repeat)) -; - - - - (= - (once $G) - ( (call $G) (set-det))) -; - - -; -; - -; -; - -; -; - -; -; - -; -; - - - !(public (/ sub-symbol 5)) -; - -; -; - -; -; - -; -; - - !(public (/ name 2)) -; - -; -; - -; -; - - !(public (/ regex-matches 3)) -; - - !(public (/ regex-matches 2)) -; - - - - (= - (sub-atom $Atom $Before $Length $After $Sub_atom) - ( (atom-concat $AtomL $X $Atom) - (atom-length $AtomL $Before) - (atom-concat $Sub_atom $AtomR $X) - (atom-length $Sub_atom $Length) - (atom-length $AtomR $After))) -; - - - - (= - (name $Constant $Chars) - ( (nonvar $Constant) (det-if-then-else (number $Constant) (number-codes $Constant $Chars) (det-if-then-else (atomic $Constant) (atom-codes $Constant $Chars) (illarg (type symbolic) (name $Constant $Chars) 1))))) -; - - (= - (name $Constant $Chars) - ( (var $Constant) (det-if-then-else (number-codes $Constant0 $Chars) (= $Constant $Constant0) (det-if-then-else (atom-codes $Constant0 $Chars) (= $Constant $Constant0) (illarg (type (list char)) (name $Constant $Chars) 2))))) -; - - - - (= - (regex-matches $_ Nil $_) - ( (set-det) (fail))) -; - - (= - (regex-matches $Pattern $List $Result) - ( (= $List - (Cons $_ $_)) - (set-det) - (regex-list $Pattern $List $Result))) -; - - (= - (regex-matches $Pattern $String $Result) - ( (atom $String) - (regex-compile $Pattern $Matcher) - (regex-match $Matcher $String $Result))) -; - - - (= - (regex-matches $Pattern $String) - (once (regex-matches $Pattern $String $_))) -; - - - - (= - (regex-list $Pattern - (Cons $H $_) $Result) - (regex-matches $Pattern $H $Result)) -; - - (= - (regex-list $Pattern - (Cons $_ $Ls) $Result) - (regex-list $Pattern $Ls $Result)) -; - - -; -; - -; -; - -; -; - - - !(public (/ set-prolog-flag 2)) -; - - !(public (/ current-prolog-flag 2)) -; - - - - (= - (set-prolog-flag $Flag $Value) - ( (var $Flag) - (set-det) - (illarg var - (set-prolog-flag $Flag $Value) 1))) -; - - (= - (set-prolog-flag $Flag $Value) - ( (var $Value) - (set-det) - (illarg var - (set-prolog-flag $Flag $Value) 2))) -; - - (= - (set-prolog-flag $Flag $Value) - ( (atom $Flag) - (set-det) - ($set-prolog-flag0 $Flag $Value))) -; - - (= - (set-prolog-flag $Flag $Value) - (illarg - (type is-symbol) - (set-prolog-flag $Flag $Value) 1)) -; - - - - (= - ($set-prolog-flag0 $Flag $Value) - ( ($prolog-impl-flag $Flag $Mode - (changeable $YN)) - (set-det) - ($set-prolog-flag0 $YN $Flag $Value $Mode))) -; - - (= - ($set-prolog-flag0 $Flag $Value) - (illarg - (domain is-symbol prolog-flag) - (set-prolog-flag $Flag $Value) 1)) -; - - - (= - ($set-prolog-flag0 no $Flag $Value $_) - ( (set-det) (illarg (permission modify flag $Flag $_) (set-prolog-flag $Flag $Value) $_))) -; - - (= - ($set-prolog-flag0 $_ $Flag $Value $Mode) - ( ($builtin-member $Value $Mode) - (set-det) - ($set-prolog-impl-flag $Flag $Value))) -; - - (= - ($set-prolog-flag0 $_ $Flag $Value $_) - (illarg - (domain is-symbol flag-value) - (set-prolog-flag $Flag $Value) 2)) -; - - - - (= - (current-prolog-flag $Flag $Term) - ( (var $Flag) - (set-det) - ($prolog-impl-flag $Flag $_ $_) - ($get-prolog-impl-flag $Flag $Term))) -; - - (= - (current-prolog-flag $Flag $Term) - ( (atom $Flag) - (set-det) - (det-if-then-else - ($prolog-impl-flag $Flag $_ $_) - ($get-prolog-impl-flag $Flag $Term) - (illarg - (domain is-symbol prolog-flag) - (current-prolog-flag $Flag $Term) 1)))) -; - - (= - (current-prolog-flag $Flag $Term) - (illarg - (type is-symbol) - (current-prolog-flag $Flag $Term) 1)) -; - - -; -; - - - (= - (%prolog_impl_flag max_integer $_ - (changeable no)) True) -; - - (= - (%prolog_impl_flag min_integer $_ - (changeable no)) True) -; - -; -; - -; -; - - (= - (%prolog_impl_flag debug - (on off) - (changeable yes)) True) -; - - (= - (%prolog_impl_flag max_arity $_ - (changeable no)) True) -; - - (= - (%prolog_impl_flag unknown - (error fail warning) - (changeable yes)) True) -; - - (= - (%prolog_impl_flag double_quotes - (chars codes atom) - (changeable no)) True) -; - - (= - (%prolog_impl_flag print_stack_trace - (on off) - (changeable yes)) True) -; - - - - !(public (/ halt 0)) -; - - !(public (/ abort 0)) -; - - - - (= - (halt) - (halt 0)) -; - - - (= - (abort) - (raise-exception 'Execution aborted')) -; - - -; -; - -; -; - -; -; - - - !(public (, (/ C 3) (/ expand-term 2))) -; - - - - (= - (C - (Cons $X $S) $X $S) True) -; - - - - (= - (expand-term $Dcg $Cl) - ( (var $Dcg) - (set-det) - (= $Dcg $Cl))) -; - - (= - (expand-term $Dcg $Cl) - ( ($dcg-expansion $Dcg $Cl0) - (set-det) - (= $Cl0 $Cl))) -; - - (= - (expand_term $Dcg $Dcg) True) -; - - - - (= - ($dcg-expansion $Dcg $Cl) - ( (var $Dcg) - (set-det) - (= $Dcg $Cl))) -; - - (= - ($dcg-expansion - (--> $Head $B) - (= $H1 - ($G1 $G2))) - ( (nonvar $Head) - (= $Head - (, $H $List)) - (= $List - (Cons $_ $_)) - (set-det) - ($dcg-translation-atom $H $H1 $S0 $S1) - ($dcg-translation $B $G1 $S0 $S) - ($dcg-translation $List $G2 $S1 $S))) -; - - (= - ($dcg-expansion - (--> $H $B) - (= $H1 $B1)) - ( ($dcg-translation-atom $H $H1 $S0 $S) ($dcg-translation $B $B1 $S0 $S))) -; - - - - (= - ($dcg-translation-atom $X - (phrase $X $S0 $S) $S0 $S) - ( (var $X) (set-det))) -; - - (= - ($dcg-translation-atom - (with_self $M $X) - (with_self $M $X1) $S0 $S) - ( (set-det) ($dcg-translation-atom $X $X1 $S0 $S))) -; - - (= - ($dcg-translation-atom $X $X1 $S0 $S) - ( (=.. $X - (Cons $F $As)) - ($builtin-append $As - (:: $S0 $S) $As1) - (=.. $X1 - (Cons $F $As1)))) -; - - - - (= - ($dcg-translation $X $Y $S0 $S) - ( ($dcg-trans $X $Y0 $T $S0 $S) ($dcg-trans0 $Y0 $Y $T $S0 $S))) -; - - - - (= - ($dcg-trans0 $Y $Y $T $S0 $T) - ( (\== $T $S0) (set-det))) -; - - (= - ($dcg-trans0 $Y0 $Y $T $_ $S) - ($dcg-concat $Y0 - (= $S $T) $Y)) -; - - - - (= - ($dcg-concat $X $Y $Z) - ( (== $X True) - (set-det) - (= $Z $Y))) -; - - (= - ($dcg-concat $X $Y $Z) - ( (== $Y True) - (set-det) - (= $Z $X))) -; - - (= - (%dcg_concat $X $Y - (, $X $Y)) True) -; - - - - (= - ($dcg-trans $X $X1 $S $S0 $S) - ( (var $X) - (set-det) - ($dcg-translation-atom $X $X1 $S0 $S))) -; - - (= - ($dcg-trans - (with_self $M $X) - (with_self $M $Y) $T $S0 $S) - ( (set-det) ($dcg-trans $X $Y $T $S0 $S))) -; - - (= - ($dcg-trans Nil True $S0 $S0 $_) - (set-det)) -; - - (= - ($dcg-trans - (Cons $X $Y) $Z $T $S0 $S) - ( (set-det) - ($dcg-trans $Y $Y1 $T $S1 $S) - ($dcg-concat - (C $S0 $X $S1) $Y1 $Z))) -; - - (= - ($dcg-trans - (not $X) - (det-if-then-else $X1 fail - (= $S $S0)) $S $S0 $S) - ( (set-det) ($dcg-trans $X $X1 $S1 $S0 $S1))) -; - - (= - ($dcg-trans - (, $X $Y) $Z $T $S0 $S) - ( (set-det) - ($dcg-trans $X $X1 $S1 $S0 $S1) - ($dcg-trans $Y $Y1 $T $S1 $S) - ($dcg-concat $X1 $Y1 $Z))) -; - - (= - ($dcg-trans - (det-if-then $X $Y) - (det-if-then $X1 $Y1) $T $S0 $S) - ( (set-det) - ($dcg-trans $X $X1 $S1 $S0 $S1) - ($dcg-trans $Y $Y1 $T $S1 $S))) -; - - (= - ($dcg-trans - (or $X $Y) - (or $X1 $Y1) $S $S0 $S) - ( (set-det) - ($dcg-translation $X $X1 $S0 $S) - ($dcg-translation $Y $Y1 $S0 $S))) -; - - (= - ($dcg-trans - (set-det) - (set-det) $S0 $S0 $_) - (set-det)) -; - - (= - ($dcg-trans - {$G } - (call $G) $S0 $S0 $_) - ( (var $G) (set-det))) -; - - (= - ($dcg-trans - {$G } $G $S0 $S0 $_) - (set-det)) -; - - (= - ($dcg-trans $X $X1 $S $S0 $S) - ($dcg-translation-atom $X $X1 $S0 $S)) -; - - -; -; - -; -; - -; -; - - - !(public (/ new-hash 1)) -; - - !(public (/ hash-map 2)) -; - - !(public (/ hash-exists 1)) -; - - - - (= - (new-hash $Hash) - (new-hash $Hash Nil)) -; - - - - (= - (hash-map $H_or_a $List) - ( (hash-keys $H_or_a $Ks0) - (sort $Ks0 $Ks) - (hash-map $Ks $List $H_or_a))) -; - - - (= - (hash-map Nil Nil $_) - (set-det)) -; - - (= - (hash-map - (Cons $K $Ks) - (Cons - (, $K $V) $Ls) $H_or_a) - ( (hash-get $H_or_a $K $V) (hash-map $Ks $Ls $H_or_a))) -; - - - - (= - (hash-exists $Alias) - ( (atom $Alias) - ($get-hash-manager $HM) - (hash-contains-key $HM $Alias))) -; - - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - - !(public (/ java-constructor 2)) -; - - !(public (/ java-declared-constructor 2)) -; - - !(public (/ java-method 3)) -; - - !(public (/ java-declared-method 3)) -; - - !(public (/ java-get-field 3)) -; - - !(public (/ java-get-declared-field 3)) -; - - !(public (/ java-set-field 3)) -; - - !(public (/ java-set-declared-field 3)) -; - - !(public (/ synchronized 2)) -; - - - - (= - (java-constructor $Constr $Instance) - ( (=.. $Constr - (Cons $F $As)) - (builtin-java-convert-args $As $As1) - (=.. $Constr1 - (Cons $F $As1)) - (java-constructor0 $Constr1 $Instance1) - (= $Instance $Instance1))) -; - - - - (= - (java-declared-constructor $Constr $Instance) - ( (=.. $Constr - (Cons $F $As)) - (builtin-java-convert-args $As $As1) - (=.. $Constr1 - (Cons $F $As1)) - (java-declared-constructor0 $Constr1 $Instance1) - (= $Instance $Instance1))) -; - - - - (= - (java-method $Class_or_Instance $Method $Value) - ( (=.. $Method - (Cons $F $As)) - (builtin-java-convert-args $As $As1) - (=.. $Method1 - (Cons $F $As1)) - (java-method0 $Class_or_Instance $Method1 $Value1) - (java-conversion $Value2 $Value1) - (= $Value $Value2))) -; - - - - (= - (java-declared-method $Class_or_Instance $Method $Value) - ( (=.. $Method - (Cons $F $As)) - (builtin-java-convert-args $As $As1) - (=.. $Method1 - (Cons $F $As1)) - (java-declared-method0 $Class_or_Instance $Method1 $Value1) - (java-conversion $Value2 $Value1) - (= $Value $Value2))) -; - - - - (= - (java-get-field $Class_or_Instance $Field $Value) - ( (java-get-field0 $Class_or_Instance $Field $Value1) - (java-conversion $Value2 $Value1) - (= $Value $Value2))) -; - - - - (= - (java-get-declared-field $Class_or_Instance $Field $Value) - ( (java-get-declared-field0 $Class_or_Instance $Field $Value1) - (java-conversion $Value2 $Value1) - (= $Value $Value2))) -; - - - - (= - (java-set-field $Class_or_Instance $Field $Value) - ( (java-conversion $Value $Value1) (java-set-field0 $Class_or_Instance $Field $Value1))) -; - - - - (= - (java-set-declared-field $Class_or_Instance $Field $Value) - ( (java-conversion $Value $Value1) (java-set-declared-field0 $Class_or_Instance $Field $Value1))) -; - - - - (= - (builtin-java-convert-args Nil Nil) - (set-det)) -; - - (= - (builtin-java-convert-args - (Cons $X $Xs) - (Cons $Y $Ys)) - ( (java-conversion $X $Y) (builtin-java-convert-args $Xs $Ys))) -; - - - - (= - (synchronized $Object $Goal) - ( ($begin-sync $Object $Ref) - (call $Goal) - ($end-sync $Ref))) -; - - -; -; - -; -; - -; -; - - - !(op 1170 xfx :-) -; - - !(op 1170 xfx -->) -; - - !(op 1170 fx :-) -; - - !(op 1170 fx ?-) -; - - - !(op 1150 fx package) -; - - !(op 1150 fx import) -; - - !(op 1150 fx public) -; - - !(op 1150 fx dynamic) -; - - !(op 1150 fx meta-predicate) -; - - !(op 1150 fx mode) -; - - !(op 1150 fx multifile) -; - - !(op 1150 fx block) -; - - - !(public (/ cafeteria 0)) -; - - !(public (/ consult 1)) -; - - !(public (/ consult-stream 1)) -; - - !(public (, (/ trace 0) (/ notrace 0))) -; - - !(public (, (/ debug 0) (/ nodebug 0))) -; - - !(public (/ leash 1)) -; - - !(public (, (/ spy 1) (/ nospy 1) (/ nospyall 0))) -; - - !(public (/ listing 0)) -; - - !(public (/ listing 1)) -; - - - !(dynamic (/ %current-leash 1)) -; - - !(dynamic (/ %current-spypoint 3)) -; - - !(dynamic (/ %leap-flag 1)) -; - - !(dynamic (/ %consulted-file 1)) -; - - !(dynamic (/ %consulted-import 2)) -; - - !(dynamic (/ %consulted-package 1)) -; - - !(dynamic (/ %consulted-predicate 3)) -; - - -; -; - - - (= - (cafeteria) - ( (%cafeteria-init) - (repeat) - (%toplvel-loop) - (on-exception $Msg - ($cafeteria $Goal) - (print-message error $Msg)) - (== $Goal end-of-file) - (set-det) - (nl) - ($fast-write bye) - (nl))) -; - - - - (= - (%cafeteria-init) - ( (remove-all-symbols &self - (%leap_flag $_)) - (remove-all-symbols &self - (%current_leash $_)) - (remove-all-symbols &self - (%current_spypoint $_ $_ $_)) - (remove-all-symbols &self - (%consulted_file $_)) - (remove-all-symbols &self - (%consulted_package $_)) - (remove-all-symbols &self - (%consulted_predicate $_ $_ $_)) - (add-symbol &self - (%leap_flag no)) - (add-symbol &self - (%current_leash call)) - (add-symbol &self - (%current_leash exit)) - (add-symbol &self - (%current_leash redo)) - (add-symbol &self - (%current_leash fail)) - (set-det))) -; - - - - (= - (%toplvel-loop) - ( (current-prolog-flag debug $Mode) - (det-if-then-else - (== $Mode off) True - (print-message info - (:: debug))) - ($fast-write | ?- ) - (flush-output))) -; - - - - (= - ($cafeteria $Goal) - ( (read-with-variables $Goal $Vars) ($process-order $Goal $Vars))) -; - - - - (= - ($process-order $G $_) - ( (var $G) - (set-det) - (illarg var - (?- $G) 1))) -; - - (= - ($process-order end-of-file $_) - (set-det)) -; - - (= - ($process-order - (Cons $File $Files) $_) - ( (set-det) (consult (Cons $File $Files)))) -; - - (= - ($process-order $G $Vars) - ( (current-prolog-flag debug $Mode) - (det-if-then-else - (== $Mode off) - (call $G) - ($trace-goal $G)) - (nl) - ($rm-redundant-vars $Vars $Vars1) - ($give-answers-with-prompt $Vars1) - (set-det) - ($fast-write yes) - (nl))) -; - - (= - ($process-order $_ $_) - ( (nl) - ($fast-write no) - (nl))) -; - - - - (= - ($rm-redundant-vars Nil Nil) - (set-det)) -; - - (= - ($rm-redundant-vars - (Cons - (= - $_) $Xs) $Vs) - ( (set-det) ($rm-redundant-vars $Xs $Vs))) -; - - (= - ($rm-redundant-vars - (Cons $X $Xs) - (Cons $X $Vs)) - ($rm-redundant-vars $Xs $Vs)) -; - - - - (= - ($give-answers-with-prompt Nil) - (set-det)) -; - - (= - ($give-answers-with-prompt $Vs) - ( ($give-an-answer $Vs) - ($fast-write ? ) - (flush-output) - (read-line $Str) - (\== $Str ";") - (nl))) -; - - - - (= - ($give-an-answer Nil) - ( (set-det) ($fast-write True))) -; - - (= - ($give-an-answer (:: $X)) - ( (set-det) ('$print-an answer' $X))) -; - - (= - ($give-an-answer (Cons $X $Xs)) - ( ('$print-an answer' $X) - ($fast-write ,) - (nl) - ($give-an-answer $Xs))) -; - - - - (= - ('$print-an answer' (= $N $V)) - ( (write $N) - ($fast-write = ) - (writeq $V))) -; - - -; -; - - - (= - (consult $Files) - ( (var $Files) - (set-det) - (illarg var - (consult $Files) 1))) -; - - (= - (consult Nil) - (set-det)) -; - - (= - (consult (Cons $File $Files)) - ( (set-det) - (consult $File) - (consult $Files))) -; - - (= - (consult $File) - ( (atom $File) - (set-det) - ($consult $File))) -; - - - - (= - ($consult $F) - ( ($prolog-file-name $F $PF) - (open $PF read $In) - (stream-property $In - (file-name $File)) - (print-message info - (:: consulting $File ...)) - (statistics runtime $_) - (consult-stream $File $In) - (statistics runtime - (:: $_ $T)) - (print-message info - (:: $File consulted $T msec)) - (close $In))) -; - - - - (= - (consult-stream $File $In) - ( ($consult-init $File) - (repeat) - (read $In $Cl) - ($consult-clause $Cl) - (== $Cl end-of-file) - (set-det))) -; - - - - (= - ($prolog-file-name $File $File) - ( (sub-atom $File $_ $_ $After .) - (> $After 0) - (set-det))) -; - - (= - ($prolog-file-name $File0 $File) - (atom-concat $File0 .pl $File)) -; - - - - (= - ($consult-init $File) - ( (remove-all-symbols &self - (%consulted_file $_)) - (remove-all-symbols &self - (%consulted_package $_)) - (remove-all-symbols &self - (%consulted_import $File $_)) - (remove-symbol &self - (%consulted_predicate $P $PI $File)) - (abolish (with_self $P $PI)) - (fail))) -; - - (= - ($consult-init $File) - ( (add-symbol &self - (%consulted_file $File)) (add-symbol &self (%consulted_package user)))) -; - - - - (= - ($consult-clause end-of-file) - (set-det)) -; - - (= - ($consult-clause !(module $P $_)) - ( (set-det) ($assert-consulted-package $P))) -; - - (= - ($consult-clause !(package $P)) - ( (set-det) ($assert-consulted-package $P))) -; - - (= - ($consult-clause !(import $P)) - ( (set-det) ($assert-consulted-import $P))) -; - - (= - ($consult-clause !(dynamic $_)) - (set-det)) -; - - (= - ($consult-clause !(public $_)) - (set-det)) -; - - (= - ($consult-clause !(meta-predicate $_)) - (set-det)) -; - - (= - ($consult-clause !(mode $_)) - (set-det)) -; - - (= - ($consult-clause !(multifile $_)) - (set-det)) -; - - (= - ($consult-clause !(block $_)) - (set-det)) -; - - (= - ($consult-clause !$G) - ( (set-det) - (get-symbols &self - (= - (%consulted_package $P) $_)) - (once (with_self $P $G)))) -; - - (= - ($consult-clause $Clause0) - ( ($consult-preprocess $Clause0 $Clause) ($consult-cls $Clause))) -; - - - - (= - ($assert-consulted-package $P) - ( (get-symbols &self - (= - (%consulted_package $P) $_)) (set-det))) -; - - (= - ($assert-consulted-package $P) - ( (remove-all-symbols &self - (%consulted_package $_)) (add-symbol &self (%consulted_package $P)))) -; - - - - (= - ($assert-consulted-import $P) - ( (get-symbols &self - (= - (%consulted_file $File) $_)) (add-symbol &self (%consulted_import $File $P)))) -; - - - - (= - ($consult-preprocess $Clause0 $Clause) - (expand-term $Clause0 $Clause)) -; - - - - (= - ($consult-cls (= $H $G)) - ( (set-det) ($assert-consulted-clause (= $H $G)))) -; - - (= - ($consult-cls $H) - ($assert-consulted-clause (= $H True))) -; - - - - (= - ($assert-consulted-clause $Clause) - ( (= $Clause - (= $H $_)) - (functor $H $F $A) - (get-symbols &self - (= - (%consulted_file $File) $_)) - (get-symbols &self - (= - (%consulted_package $P) $_)) - (add-symbol &self - (: $P $Clause)) - (add-symbol &self - (%consulted_predicate $P - (/ $F $A) $File)) - (set-det))) -; - - -; -; - - - (= - (trace) - ( (current-prolog-flag debug on) (set-det))) -; - - (= - (trace) - ( (set-prolog-flag debug on) - (%trace-init) - ($fast-write '{Small debugger is switch on}') - (nl) - (set-det))) -; - - - - (= - (%trace-init) - ( (remove-all-symbols &self - (%leap_flag $_)) - (remove-all-symbols &self - (%current_leash $_)) - (remove-all-symbols &self - (%current_spypoint $_ $_ $_)) - (add-symbol &self - (%leap_flag no)) - (add-symbol &self - (%current_leash call)) - (add-symbol &self - (%current_leash exit)) - (add-symbol &self - (%current_leash redo)) - (add-symbol &self - (%current_leash fail)) - (set-det))) -; - - - - (= - (notrace) - ( (current-prolog-flag debug off) (set-det))) -; - - (= - (notrace) - ( (set-prolog-flag debug off) - ($fast-write '{Small debugger is switch off}') - (nl) - (set-det))) -; - - - - (= - (debug) - (trace)) -; - - - (= - (nodebug) - (notrace)) -; - - -; -; - - - (= - (spy $T) - ( ($term-to-predicateindicator $T $PI - (spy $T)) - (trace) - ($assert-spypoint $PI) - ($set-debug-flag leap yes) - (set-det))) -; - - - - (= - ($assert-spypoint (with_self $P (/ $F $A))) - ( (get-symbols &self - (= - (%current_spypoint $P $F $A) $_)) - (print-message info - (:: spypoint - (with_self $P - (/ $F $A)) is already added)) - (set-det))) -; - - (= - ($assert-spypoint (with_self $P (/ $F $A))) - ( (get-symbols &self - (= - (%consulted_predicate $P - (/ $F $A) $_) $_)) - (add-symbol &self - (%current_spypoint $P $F $A)) - (print-message info - (:: spypoint - (with_self $P - (/ $F $A)) is added)) - (set-det))) -; - - (= - ($assert-spypoint (with_self $P (/ $F $A))) - (print-message warning - (:: no matching predicate for spy - (with_self $P - (/ $F $A))))) -; - - - - (= - (nospy $T) - ( ($term-to-predicateindicator $T $PI - (nospy $T)) - ($retract-spypoint $PI) - ($set-debug-flag leap no) - (set-det))) -; - - - - (= - ($retract-spypoint (with_self $P (/ $F $A))) - ( (remove-symbol &self - (%current_spypoint $P $F $A)) - (print-message info - (:: spypoint - (with_self $P - (/ $F $A)) is removed)) - (set-det))) -; - - (= - (%retract_spypoint $_) True) -; - - - - (= - (nospyall) - ( (remove-all-symbols &self - (%current_spypoint $_ $_ $_)) ($set-debug-flag leap no))) -; - - -; -; - - - (= - (leash $L) - ( (nonvar $L) - ($leash $L) - (set-det))) -; - - (= - (leash $L) - (illarg - (type leash-specifier) - (leash $L) 1)) -; - - - - (= - ($leash Nil) - ( (set-det) - (remove-all-symbols &self - (%current_leash $_)) - (print-message info - (:: no leashing)))) -; - - (= - ($leash $Ms) - ( (remove-all-symbols &self - (%current_leash $_)) - ($assert-leash $Ms) - (print-message info - (:: leashing stopping on $Ms)))) -; - - - - (= - ($assert-leash Nil) - (set-det)) -; - - (= - ($assert-leash (Cons $X $Xs)) - ( ($leash-specifier $X) - (add-symbol &self - (%current_leash $X)) - ($assert-leash $Xs))) -; - - - - (= - (%leash_specifier call) True) -; - - (= - (%leash_specifier exit) True) -; - - (= - (%leash_specifier redo) True) -; - - (= - (%leash_specifier fail) True) -; - -; -; - - -; -; - - - (= - ($trace-goal $Term) - ( ($set-debug-flag leap no) - ($get-current-B $Cut) - ($meta-call $Term user $Cut 0 trace))) -; - - - (= - ($trace-goal $X $P $FA $Depth) - ( (print-procedure-box call $X $P $FA $Depth) - ($call-internal $X $P $FA $Depth trace) - (print-procedure-box exit $X $P $FA $Depth) - (redo-procedure-box $X $P $FA $Depth))) -; - - (= - ($trace-goal $X $P $FA $Depth) - ( (print-procedure-box fail $X $P $FA $Depth) (fail))) -; - - - - (= - (print-procedure-box $Mode $G $P - (/ $F $A) $Depth) - ( (get-symbols &self - (= - (%current_spypoint $P $F $A) $_)) - (set-det) - ($builtin-message (:: + $Depth $Mode : (with_self $P $G))) - ($read-blocked (print-procedure-box $Mode $G $P (/ $F $A) $Depth)))) -; - - (= - (print-procedure-box $Mode $G $P $FA $Depth) - ( (get-symbols &self - (= - (%leap_flag no) $_)) - (set-det) - ($builtin-message (:: ' ' $Depth $Mode : (with_self $P $G))) - (det-if-then-else - (get-symbols &self - (= - (%current_leash $Mode) $_)) - ($read-blocked (print-procedure-box $Mode $G $P $FA $Depth)) nl))) -; - - (= - (print_procedure_box $_ $_ $_ $_ $_) True) -; - - - - (= - (redo_procedure_box $_ $_ $_ $_) True) -; - - (= - (redo-procedure-box $X $P $FA $Depth) - ( (print-procedure-box redo $X $P $FA $Depth) (fail))) -; - - - - (= - ($read-blocked $G) - ( ($fast-write ? ) - (flush-output) - (read-line $C) - (det-if-then-else - (== $C Nil) - (= $DOP 99) - (= $C - (Cons $DOP $_))) - ($debug-option $DOP $G))) -; - - - - (= - ($debug-option 97 $_) - ( (set-det) - (notrace) - (abort))) -; - ; -; - - (= - ($debug-option 99 $_) - ( (set-det) ($set-debug-flag leap no))) -; - ; -; - - (= - ($debug-option 108 $_) - ( (set-det) ($set-debug-flag leap yes))) -; - ; -; - - (= - ($debug-option 43 - (print-procedure-box $Mode $G $P $FA $Depth)) - ( (set-det) - (spy (with_self $P $FA)) - (call (print-procedure-box $Mode $G $P $FA $Depth)))) -; - - (= - ($debug-option 45 - (print-procedure-box $Mode $G $P $FA $Depth)) - ( (set-det) - (nospy (with_self $P $FA)) - (call (print-procedure-box $Mode $G $P $FA $Depth)))) -; - - (= - ($debug-option 63 $G) - ( (set-det) - (%show-debug-option) - (call $G))) -; - - (= - ($debug-option 104 $G) - ( (set-det) - (%show-debug-option) - (call $G))) -; - - (= - (%debug_option $_ $_) True) -; - - - - (= - (%show-debug-option) - ( (tab 4) - ($fast-write 'Debuggin options:') - (nl) - (tab 4) - ($fast-write 'a abort') - (nl) - (tab 4) - ($fast-write 'RET creep') - (nl) - (tab 4) - ($fast-write 'c creep') - (nl) - (tab 4) - ($fast-write 'l leap') - (nl) - (tab 4) - ($fast-write '+ spy this') - (nl) - (tab 4) - ($fast-write '- nospy this') - (nl) - (tab 4) - ($fast-write '? help') - (nl) - (tab 4) - ($fast-write 'h help') - (nl))) -; - - - - (= - ($set-debug-flag leap $Flag) - ( (get-symbols &self - (= - (%leap_flag $Flag) $_)) (set-det))) -; - - (= - ($set-debug-flag leap $Flag) - ( (remove-all-symbols &self - (%leap_flag $_)) (add-symbol &self (%leap_flag $Flag)))) -; - - -; -; - - - (= - (listing) - ($listing $_ user)) -; - - - (= - (listing $T) - ( (var $T) - (set-det) - (illarg var - (listing $T) 1))) -; - - (= - (listing $P) - ( (atom $P) - (set-det) - ($listing $_ $P))) -; - - (= - (listing (/ $F $A)) - ( (set-det) ($listing (/ $F $A) user))) -; - - (= - (listing (with_self $P $PI)) - ( (atom $P) - (set-det) - ($listing $PI $P))) -; - - (= - (listing $T) - (illarg - (type predicate-indicator) - (listing $T) 1)) -; - - - - (= - ($listing $PI $P) - ( (var $PI) - (set-det) - ($listing-dynamic-clause $P $_))) -; - - (= - ($listing - (/ $F $A) $P) - ( (atom $F) - (integer $A) - (set-det) - ($listing-dynamic-clause $P - (/ $F $A)))) -; - - (= - ($listing $PI $P) - (illarg - (type predicate-indicator) - (listing (with_self $P $PI)) 1)) -; - - - - (= - ($listing-dynamic-clause $P $PI) - ( ($new-internal-database $P) - (hash-keys $P $Keys) - ($builtin-member $PI $Keys) - (= $PI - (/ $F $A)) - (functor $H $F $A) - ($clause-internal $P $PI $H $Cl $_) - ($write-dynamic-clause $P $Cl) - (fail))) -; - - (= - (%listing_dynamic_clause $_ $_) True) -; - - - - (= - ($write-dynamic-clause $_ $Cl) - ( (var $Cl) - (set-det) - (fail))) -; - - (= - ($write-dynamic-clause $P - (= $H True)) - ( (set-det) - (numbervars $H 0 $_) - ($write-dynamic-head $P $H) - (write .) - (nl))) -; - - (= - ($write-dynamic-clause $P - (= $H $B)) - ( (set-det) - (numbervars - (= $H $B) 0 $_) - ($write-dynamic-head $P $H) - (write :-) - (nl) - ($write-dynamic-body $B 8) - (write .) - (nl))) -; - - - - (= - ($write-dynamic-head user $H) - ( (set-det) (writeq $H))) -; - - (= - ($write-dynamic-head $P $H) - ( (write $P) - (write :) - (writeq $H))) -; - - - - (= - ($write-dynamic-body - (, $G1 $G2) $N) - ( (set-det) - ($write-dynamic-body $G1 $N) - (write ,) - (nl) - ($write-dynamic-body $G2 $N))) -; - - (= - ($write-dynamic-body - (or $G1 $G2) $N) - ( (set-det) - (is $N1 - (+ $N 4)) - (tab $N) - (write () - (nl) - ($write-dynamic-body $G1 $N1) - (nl) - (tab $N) - (write or) - (nl) - ($write-dynamic-body $G2 $N1) - (nl) - (tab $N) - (write )))) -; - - (= - ($write-dynamic-body - (det-if-then $G1 $G2) $N) - ( (set-det) - (is $N1 - (+ $N 4)) - (tab $N) - (write () - (nl) - ($write-dynamic-body $G1 $N1) - (nl) - (tab $N) - (write ->) - (nl) - ($write-dynamic-body $G2 $N1) - (nl) - (tab $N) - (write )))) -; - - (= - ($write-dynamic-body $B $N) - ( (tab $N) (writeq $B))) -; - - -; -; - -; -; - -; -; - - - !(public (/ reverse 2)) -; - - !(public (/ length 2)) -; - - !(public (/ numbervars 3)) -; - - !(public (/ statistics 2)) -; - - -; -; - -; -; - -; -; - - - - (= - (length $L $N) - ( (var $N) - (set-det) - ($length $L 0 $N))) -; - - (= - (length $L $N) - ($length0 $L 0 $N)) -; - - - - (= - ($length () $I $I) True) -; - - (= - ($length - (Cons $_ $L) $I0 $I) - ( (is $I1 - (+ $I0 1)) ($length $L $I1 $I))) -; - - - - (= - ($length0 Nil $I $I) - (set-det)) -; - - (= - ($length0 - (Cons $_ $L) $I0 $I) - ( (< $I0 $I) - (is $I1 - (+ $I0 1)) - ($length0 $L $I1 $I))) -; - - - - (= - (numbervars $X $VI $VN) - ( (integer $VI) - (>= $VI 0) - (set-det) - ($numbervars $X $VI $VN))) -; - - - - (= - ($numbervars $X $VI $VN) - ( (var $X) - (set-det) - (= $X $VI) - (is $VN - (+ $VI 1)))) -; - - (= - ($numbervars $X $VI $VI) - ( (atomic $X) (set-det))) -; - - (= - ($numbervars $X $VI $VI) - ( (java $X) (set-det))) -; - - (= - ($numbervars $X $VI $VN) - ( (functor $X $_ $N) ($numbervars-str 1 $N $X $VI $VN))) -; - - - - (= - ($numbervars-str $I $I $X $VI $VN) - ( (set-det) - (arg $I $X $A) - ($numbervars $A $VI $VN))) -; - - (= - ($numbervars-str $I $N $X $VI $VN) - ( (arg $I $X $A) - ($numbervars $A $VI $VN1) - (is $I1 - (+ $I 1)) - ($numbervars-str $I1 $N $X $VN1 $VN))) -; - - - - (= - (statistics $Key $Value) - ( (nonvar $Key) - ($statistics-mode $Key) - (set-det) - ($statistics $Key $Value))) -; - - (= - (statistics $Key $Value) - ( (findall $M - ($statistics-mode $M) $Domain) (illarg (domain is-symbol $Domain) (statistics $Key $Value) 1))) -; - - - - (= - (%statistics_mode runtime) True) -; - - (= - (%statistics_mode trail) True) -; - - (= - (%statistics_mode choice) True) -; - - - - (= - (print-message $Type $Message) - ( (var $Type) - (set-det) - (illarg var - (print-message $Type $Message) 1))) -; - - (= - (print-message error $Message) - ( (set-det) ($error-message $Message))) -; - - (= - (print-message info $Message) - ( (set-det) - ($fast-write {) - ($builtin-message $Message) - ($fast-write }) - (nl))) -; - - (= - (print-message warning $Message) - ( (set-det) - ($fast-write '{WARNING: ') - ($builtin-message $Message) - ($fast-write }) - (nl))) -; - - - - (= - ($error-message (instantiation-error $Goal 0)) - ( (set-det) - ($fast-write user-error '{INSTANTIATION ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (instantiation-error $Goal $ArgNo)) - ( (set-det) - ($fast-write user-error '{INSTANTIATION ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error ' - arg ') - ($fast-write user-error $ArgNo) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (type-error $Goal $ArgNo $Type $Culprit)) - ( (set-det) - ($fast-write user-error '{TYPE ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error ' - arg ') - ($fast-write user-error $ArgNo) - ($fast-write user-error ': expected ') - ($fast-write user-error $Type) - ($fast-write user-error ', found ') - (write user-error $Culprit) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (domain-error $Goal $ArgNo $Domain $Culprit)) - ( (set-det) - ($fast-write user-error '{DOMAIN ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error ' - arg ') - ($fast-write user-error $ArgNo) - ($fast-write user-error ': expected ') - ($fast-write user-error $Domain) - ($fast-write user-error ', found ') - (write user-error $Culprit) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (existence-error $Goal 0 $ObjType $Culprit $Message)) - ( (set-det) - ($fast-write user-error '{EXISTENCE ERROR: ') - ($fast-write user-error $ObjType) - ($fast-write user-error ' ') - (write user-error $Culprit) - ($fast-write user-error ' does not exist') - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (existence-error $Goal $ArgNo $ObjType $Culprit $Message)) - ( (set-det) - ($fast-write user-error '{EXISTENCE ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error ' - arg ') - ($fast-write user-error $ArgNo) - ($fast-write user-error : ) - ($fast-write user-error $ObjType) - ($fast-write user-error ' ') - (write user-error $Culprit) - ($fast-write user-error ' does not exist') - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (permission-error $Goal $Operation $ObjType $Culprit $Message)) - ( (set-det) - ($fast-write user-error '{PERMISSION ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error ' - can not ') - ($fast-write user-error $Operation) - ($fast-write user-error ' ') - ($fast-write user-error $ObjType) - ($fast-write user-error ' ') - (write user-error $Culprit) - ($fast-write user-error : ) - ($fast-write user-error $Message) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (representation-error $Goal $ArgNo $Flag)) - ( (set-det) - ($fast-write user-error '{REPRESENTATION ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error ' - arg ') - ($fast-write user-error $ArgNo) - ($fast-write user-error ': limit of ') - ($fast-write user-error $Flag) - ($fast-write user-error ' is breached') - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (evaluation-error $Goal $ArgNo $Type)) - ( (set-det) - ($fast-write user-error '{EVALUATION ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error ' - arg ') - ($fast-write user-error $ArgNo) - ($fast-write user-error ', found ') - ($fast-write user-error $Type) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (syntax-error $Goal $ArgNo $Type $Culprit $Message)) - ( (set-det) - ($fast-write user-error '{SYNTAX ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error ' - arg ') - ($fast-write user-error $ArgNo) - ($fast-write user-error ': expected ') - ($fast-write user-error $Type) - ($fast-write user-error ', found ') - (write user-error $Culprit) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (system-error $Message)) - ( (set-det) - ($fast-write user-error '{SYSTEM ERROR: ') - (write user-error $Message) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (internal-error $Message)) - ( (set-det) - ($fast-write user-error '{INTERNAL ERROR: ') - (write user-error $Message) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (java-error $Goal $ArgNo $Exception)) - ( (set-det) - ($fast-write user-error '{JAVA ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error ' - arg ') - ($fast-write user-error $ArgNo) - ($fast-write user-error ', found ') - ($write-goal user-error $Exception) - ($fast-write user-error }) - (nl user-error) - ($print-stack-trace $Exception) - (flush-output user-error))) -; - - (= - ($error-message $Message) - ( ($fast-write user-error {) - (write user-error $Message) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - + (= ($add-operators Nil $_ $_) + (set-det)) + (= ($add-operators (Cons $A $As) $Priority $Op_specifier) + ($add-op $A $Priority $Op_specifier) + ($add-operators $As $Priority $Op_specifier)) - (= - ($write-goal $S $Goal) - ( (java $Goal) - (set-det) - ($write-toString $S $Goal))) -; - - (= - ($write-goal $S $Goal) - (write $S $Goal)) -; - + (= ($add-op , $Priority $Op_specifier) + (set-det) + (illarg + (permission modify operator , $_) + (op $Priority $Op_specifier ,) 3)) + (= ($add-op $A $_ $Op_specifier) + ( (== + (= + (%current_operator $_ $Op_specifier0 $A) $_) + (get-atoms &self)) + ($op-specifier $Op_specifier $Class) + ($op-specifier $Op_specifier0 $Class0) + (= $Class $Class0) + (remove-is-symbol &self + (%current_operator $_ $Op_specifier0 $A)) + (fail))) + (= ($add-op $_ 0 $_) + (set-det)) + (= ($add-op $A $Priority $Op_specifier) + (add-is-symbol &self + (%current_operator $Priority $Op_specifier $A))) + + + (= (%op_specifier fx prefix) True) + (= (%op_specifier fy prefix) True) + (= (%op_specifier xfx infix) True) + (= (%op_specifier xfy infix) True) + (= (%op_specifier yfx infix) True) + (= (%op_specifier xf postfix) True) + (= (%op_specifier yf postfix) True) + + + (= ($op-atom-list $X $_) + (var $X) + (set-det) + (fail)) + (= ($op-atom-list Nil Nil) + (set-det)) + (= ($op-atom-list (Cons $X $Xs) (Cons $X $As)) + (atom $X) + (set-det) + ($op-atom-list $Xs $As)) + + + (= (current-op $Priority $Op_specifier $Operator) + (== + (= + (%current_operator $Priority $Op_specifier $Operator) $_) + (get-atoms &self))) + + + (= (%current_operator 1200 xfx :-) True) + (= (%current_operator 1200 xfx -->) True) + (= (%current_operator 1200 fx :-) True) + (= (%current_operator 1200 fx ?-) True) + (= (%current_operator 1150 fx package) True) + (= (%current_operator 1150 fx import) True) + (= (%current_operator 1150 fx include) True) + (= (%current_operator 1150 fx include_resource) True) + (= (%current_operator 1150 fx constant) True) + (= (%current_operator 1150 fx public) True) + (= (%current_operator 1150 fx dynamic) True) + (= (%current_operator 1150 fx meta_predicate) True) + (= (%current_operator 1150 fx mode) True) + (= (%current_operator 1150 fx multifile) True) + (= (%current_operator 1150 fx block) True) + (= (%current_operator 1150 fx ifdef) True) + (= (%current_operator 1150 fx ifndef) True) + (= (%current_operator 1150 fx domain) True) + (= (%current_operator 1150 fx database) True) + (= (%current_operator 1100 xfy ;) True) + (= (%current_operator 1050 xfy ->) True) + (= (%current_operator 1000 xfy ,) True) + (= (%current_operator 900 fy \+) True) + (= (%current_operator 700 xfx =) True) + (= (%current_operator 700 xfx \=) True) + (= (%current_operator 700 xfx ==) True) + (= (%current_operator 700 xfx \==) True) + (= (%current_operator 700 xfx @<) True) + (= (%current_operator 700 xfx @>) True) + (= (%current_operator 700 xfx @=<) True) + (= (%current_operator 700 xfx @>=) True) + (= (%current_operator 700 xfx =..) True) + (= (%current_operator 700 xfx is) True) + (= (%current_operator 700 xfx =:=) True) + (= (%current_operator 700 xfx =\=) True) + (= (%current_operator 700 xfx <) True) + (= (%current_operator 700 xfx >) True) + (= (%current_operator 700 xfx =<) True) + (= (%current_operator 700 xfx >=) True) + (= (%current_operator 550 xfy :) True) + (= (%current_operator 500 yfx +) True) + (= (%current_operator 500 yfx -) True) + (= (%current_operator 500 yfx #) True) + (= (%current_operator 500 yfx /\) True) + (= (%current_operator 500 yfx \/) True) + (= (%current_operator 500 fx +) True) + (= (%current_operator 400 yfx *) True) + (= (%current_operator 400 yfx /) True) + (= (%current_operator 400 yfx //) True) + (= (%current_operator 400 yfx mod) True) + (= (%current_operator 400 yfx rem) True) + (= (%current_operator 400 yfx <<) True) + (= (%current_operator 400 yfx >>) True) + (= (%current_operator 300 xfx ~) True) + (= (%current_operator 200 xfx **) True) + (= (%current_operator 200 xfy ^) True) + (= (%current_operator 200 fy \) True) + (= (%current_operator 200 fy -) True) + +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Logic and control +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + !(public (/ \+ 1)) + !(public (/ once 1)) + !(public (/ repeat 0)) + + + (= (not $G) + (call $G) + (set-det) + (fail)) + (= (\+ $_) True) + + + (= repeat True) + (= (repeat) + (repeat)) + + + (= (once $G) + (call $G) + (set-det)) + +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Atomic term processing +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; :- public atom_length/2. written in Java +; +; :- public atom_concat/3. written in Java + + !(public (/ sub-symbol 5)) +; +; :- public atom_chars/2, atom_codes/2. written in Java +; +; :- public char_code/2. written in Java +; +; :- public number_chars/2, number_codes/2. written in Java + !(public (/ name 2)) +; +; :- public regex_compile/2. written in Java +; +; :- public regex_match/3. written in Java + !(public (/ regex-matches 3)) + !(public (/ regex-matches 2)) + + + (= (sub-atom $Atom $Before $Length $After $Sub_atom) + (atom-concat $AtomL $X $Atom) + (atom-length $AtomL $Before) + (atom-concat $Sub_atom $AtomR $X) + (atom-length $Sub_atom $Length) + (atom-length $AtomR $After)) - (= - (illarg $Msg $Goal $ArgNo) - ( (var $Msg) - (set-det) - (illarg var $Goal $ArgNo))) -; - - (= - (illarg var $Goal $ArgNo) - (raise-exception (instantiation-error $Goal $ArgNo))) -; - - (= - (illarg - (type $Type) $Goal $ArgNo) - ( (arg $ArgNo $Goal $Arg) + (= (name $Constant $Chars) + (nonvar $Constant) + (det-if-then-else + (number $Constant) + (number-codes $Constant $Chars) (det-if-then-else - (nonvar $Arg) - (= $Error - (type-error $Goal $ArgNo $Type $Arg)) - (= $Error - (instantiation-error $Goal $ArgNo))) - (raise-exception $Error))) -; - - (= - (illarg - (domain $Type $ExpDomain) $Goal $ArgNo) - ( (arg $ArgNo $Goal $Arg) + (atomic $Constant) + (atom-codes $Constant $Chars) + (illarg + (type symbolic) + (name $Constant $Chars) 1)))) + (= (name $Constant $Chars) + (var $Constant) + (det-if-then-else + (number-codes $Constant0 $Chars) + (= $Constant $Constant0) (det-if-then-else - ($match-type $Type $Arg) - (= $Error - (domain-error $Goal $ArgNo $ExpDomain $Arg)) - (det-if-then-else - (nonvar $Arg) - (= $Error - (type-error $Goal $ArgNo $Type $Arg)) - (= $Error - (instantiation-error $Goal $ArgNo)))) - (raise-exception $Error))) -; - - (= - (illarg - (existence $ObjType $Culprit $Message) $Goal $ArgNo) - (raise-exception (existence-error $Goal $ArgNo $ObjType $Culprit $Message))) -; - - (= - (illarg - (permission $Operation $ObjType $Culprit $Message) $Goal $_) - (raise-exception (permission-error $Goal $Operation $ObjType $Culprit $Message))) -; - - (= - (illarg - (representation $Flag) $Goal $ArgNo) - (raise-exception (representation-error $Goal $ArgNo $Flag))) -; - - (= + (atom-codes $Constant0 $Chars) + (= $Constant $Constant0) + (illarg + (type (list char)) + (name $Constant $Chars) 2)))) + + + (= (regex-matches $_ Nil $_) + (set-det) + (fail)) + (= (regex-matches $Pattern $List $Result) + (= $List + (Cons $_ $_)) + (set-det) + (regex-list $Pattern $List $Result)) + (= (regex-matches $Pattern $String $Result) + (atom $String) + (regex-compile $Pattern $Matcher) + (regex-match $Matcher $String $Result)) + + (= (regex-matches $Pattern $String) + (once (regex-matches $Pattern $String $_))) + + + (= (regex-list $Pattern (Cons $H $_) $Result) + (regex-matches $Pattern $H $Result)) + (= (regex-list $Pattern (Cons $_ $Ls) $Result) + (regex-list $Pattern $Ls $Result)) + +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Implementation defined hooks +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + !(public (/ set-prolog-flag 2)) + !(public (/ current-prolog-flag 2)) + + + (= (set-prolog-flag $Flag $Value) + (var $Flag) + (set-det) + (illarg var + (set-prolog-flag $Flag $Value) 1)) + (= (set-prolog-flag $Flag $Value) + (var $Value) + (set-det) + (illarg var + (set-prolog-flag $Flag $Value) 2)) + (= (set-prolog-flag $Flag $Value) + (atom $Flag) + (set-det) + ($set-prolog-flag0 $Flag $Value)) + (= (set-prolog-flag $Flag $Value) (illarg - (evaluation $Type) $Goal $ArgNo) - (raise-exception (evaluation-error $Goal $ArgNo $Type))) -; + (type is-symbol) + (set-prolog-flag $Flag $Value) 1)) - (= + + (= ($set-prolog-flag0 $Flag $Value) + ($prolog-impl-flag $Flag $Mode + (changeable $YN)) + (set-det) + ($set-prolog-flag0 $YN $Flag $Value $Mode)) + (= ($set-prolog-flag0 $Flag $Value) (illarg - (syntax $Type $Culprit $Message) $Goal $ArgNo) - (raise-exception (syntax-error $Goal $ArgNo $Type $Culprit $Message))) -; + (domain is-symbol prolog-flag) + (set-prolog-flag $Flag $Value) 1)) - (= + (= ($set-prolog-flag0 no $Flag $Value $_) + (set-det) (illarg - (system $Message) $_ $_) - (raise-exception (system-error $Message))) -; - - (= + (permission modify flag $Flag $_) + (set-prolog-flag $Flag $Value) $_)) + (= ($set-prolog-flag0 $_ $Flag $Value $Mode) + ($builtin-member $Value $Mode) + (set-det) + ($set-prolog-impl-flag $Flag $Value)) + (= ($set-prolog-flag0 $_ $Flag $Value $_) (illarg - (internal $Message) $_ $_) - (raise-exception (internal-error $Message))) -; - - (= + (domain is-symbol flag-value) + (set-prolog-flag $Flag $Value) 2)) + + + (= (current-prolog-flag $Flag $Term) + (var $Flag) + (set-det) + ($prolog-impl-flag $Flag $_ $_) + ($get-prolog-impl-flag $Flag $Term)) + (= (current-prolog-flag $Flag $Term) + (atom $Flag) + (set-det) + (det-if-then-else + ($prolog-impl-flag $Flag $_ $_) + ($get-prolog-impl-flag $Flag $Term) + (illarg + (domain is-symbol prolog-flag) + (current-prolog-flag $Flag $Term) 1))) + (= (current-prolog-flag $Flag $Term) (illarg - (java $Exception) $Goal $ArgNo) - (raise-exception (java-error $Goal $ArgNo $Exception))) -; + (type is-symbol) + (current-prolog-flag $Flag $Term) 1)) - (= - (illarg $Msg $_ $_) - (raise-exception $Msg)) -; +; +; '$MeTTa_impl_flag'(bounded, _, changeable(no)). + + (= (%prolog_impl_flag max_integer $_ (changeable no)) True) + (= (%prolog_impl_flag min_integer $_ (changeable no)) True) +; +; '$MeTTa_impl_flag'(integer_rounding_function, [down,toward_zero], changeable(no)). +; +; '$MeTTa_impl_flag'(char_conversion, [on,off], changeable(no)). + (= (%prolog_impl_flag debug (on off) (changeable yes)) True) + (= (%prolog_impl_flag max_arity $_ (changeable no)) True) + (= (%prolog_impl_flag unknown (error fail warning) (changeable yes)) True) + (= (%prolog_impl_flag double_quotes (chars codes atom) (changeable no)) True) + (= (%prolog_impl_flag print_stack_trace (on off) (changeable yes)) True) + + !(public (/ halt 0)) + !(public (/ abort 0)) - (= - (%match_type term $_) True) -; + (= (halt) + (halt 0)) + + (= (abort) + (raise-exception 'Execution aborted')) - (= - ($match-type variable $X) - (var $X)) -; +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; DCG +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + !(public (, (/ C 3) (/ expand-term 2))) - (= - ($match-type is-symbol $X) - (atom $X)) -; + + (= (C (Cons $X $S) $X $S) True) - (= - ($match-type symbolic $X) - (atomic $X)) -; + + (= (expand-term $Dcg $Cl) + (var $Dcg) + (set-det) + (= $Dcg $Cl)) + (= (expand-term $Dcg $Cl) + ($dcg-expansion $Dcg $Cl0) + (set-det) + (= $Cl0 $Cl)) + (= (expand_term $Dcg $Dcg) True) - (= - ($match-type byte $X) - ( (integer $X) - (=< 0 $X) - (=< $X 255))) -; + + (= ($dcg-expansion $Dcg $Cl) + (var $Dcg) + (set-det) + (= $Dcg $Cl)) + (= ($dcg-expansion (--> $Head $B) (= $H1 + ($G1 $G2))) + (nonvar $Head) + (= $Head + (, $H $List)) + (= $List + (Cons $_ $_)) + (set-det) + ($dcg-translation-atom $H $H1 $S0 $S1) + ($dcg-translation $B $G1 $S0 $S) + ($dcg-translation $List $G2 $S1 $S)) + (= ($dcg-expansion (--> $H $B) (= $H1 $B1)) + ($dcg-translation-atom $H $H1 $S0 $S) + ($dcg-translation $B $B1 $S0 $S)) - (= - ($match-type in-byte $X) - ( (integer $X) - (=< -1 $X) - (=< $X 255))) -; + + (= ($dcg-translation-atom $X (phrase $X $S0 $S) $S0 $S) + (var $X) + (set-det)) + (= ($dcg-translation-atom (with_self $M $X) (with_self $M $X1) $S0 $S) + (set-det) + ($dcg-translation-atom $X $X1 $S0 $S)) + (= ($dcg-translation-atom $X $X1 $S0 $S) + (=.. $X + (Cons $F $As)) + ($builtin-append $As + (:: $S0 $S) $As1) + (=.. $X1 + (Cons $F $As1))) - (= - ($match-type character $X) - ( (atom $X) (atom-length $X 1))) -; + + (= ($dcg-translation $X $Y $S0 $S) + ($dcg-trans $X $Y0 $T $S0 $S) + ($dcg-trans0 $Y0 $Y $T $S0 $S)) - (= - ($match-type in-character $X) - (or - (== $X end-of-file) - ($match-type character $X))) -; + + (= ($dcg-trans0 $Y $Y $T $S0 $T) + (\== $T $S0) + (set-det)) + (= ($dcg-trans0 $Y0 $Y $T $_ $S) + ($dcg-concat $Y0 + (= $S $T) $Y)) - (= - ($match-type number $X) - (number $X)) -; + + (= ($dcg-concat $X $Y $Z) + (== $X True) + (set-det) + (= $Z $Y)) + (= ($dcg-concat $X $Y $Z) + (== $Y True) + (set-det) + (= $Z $X)) + (= (%dcg_concat $X $Y (, $X $Y)) True) - (= - ($match-type integer $X) - (integer $X)) -; + + (= ($dcg-trans $X $X1 $S $S0 $S) + (var $X) + (set-det) + ($dcg-translation-atom $X $X1 $S0 $S)) + (= ($dcg-trans (with_self $M $X) (with_self $M $Y) $T $S0 $S) + (set-det) + ($dcg-trans $X $Y $T $S0 $S)) + (= ($dcg-trans Nil True $S0 $S0 $_) + (set-det)) + (= ($dcg-trans (Cons $X $Y) $Z $T $S0 $S) + (set-det) + ($dcg-trans $Y $Y1 $T $S1 $S) + ($dcg-concat + (C $S0 $X $S1) $Y1 $Z)) + (= ($dcg-trans (not $X) (det-if-then-else $X1 fail (= $S $S0)) $S $S0 $S) + (set-det) + ($dcg-trans $X $X1 $S1 $S0 $S1)) + (= ($dcg-trans (, $X $Y) $Z $T $S0 $S) + (set-det) + ($dcg-trans $X $X1 $S1 $S0 $S1) + ($dcg-trans $Y $Y1 $T $S1 $S) + ($dcg-concat $X1 $Y1 $Z)) + (= ($dcg-trans (det-if-then $X $Y) (det-if-then $X1 $Y1) $T $S0 $S) + (set-det) + ($dcg-trans $X $X1 $S1 $S0 $S1) + ($dcg-trans $Y $Y1 $T $S1 $S)) + (= ($dcg-trans (or $X $Y) (or $X1 $Y1) $S $S0 $S) + (set-det) + ($dcg-translation $X $X1 $S0 $S) + ($dcg-translation $Y $Y1 $S0 $S)) + (= ($dcg-trans (set-det) (set-det) $S0 $S0 $_) + (set-det)) + (= ($dcg-trans {$G } (call $G) $S0 $S0 $_) + (var $G) + (set-det)) + (= ($dcg-trans {$G } $G $S0 $S0 $_) + (set-det)) + (= ($dcg-trans $X $X1 $S $S0 $S) + ($dcg-translation-atom $X $X1 $S0 $S)) - (= - ($match-type long $X) - (long $X)) -; +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Hash creation and control +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + !(public (/ new-hash 1)) + !(public (/ hash-map 2)) + !(public (/ hash-exists 1)) + + + (= (new-hash $Hash) + (new-hash $Hash Nil)) + + + (= (hash-map $H_or_a $List) + (hash-keys $H_or_a $Ks0) + (sort $Ks0 $Ks) + (hash-map $Ks $List $H_or_a)) + + (= (hash-map Nil Nil $_) + (set-det)) + (= (hash-map (Cons $K $Ks) (Cons (, $K $V) $Ls) $H_or_a) + (hash-get $H_or_a $K $V) + (hash-map $Ks $Ls $H_or_a)) - (= - ($match-type float $X) - (float $X)) -; + + (= (hash-exists $Alias) + (atom $Alias) + ($get-hash-manager $HM) + (hash-contains-key $HM $Alias)) - (= - ($match-type callable $X) - (callable $X)) -; +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Java interoperation +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; :- public java_constructor0/2. (written in Java) +; +; :- public java_declared_constructor0/2. (written in Java) +; +; :- public java_method0/3. (written in Java) +; +; :- public java_declared_method0/3. (written in Java) +; +; :- public java_get_field0/3. (written in Java) +; +; :- public java_get_declared_field0/3. (written in Java) +; +; :- public java_set_field0/3. (written in Java) +; +; :- public java_set_declared_field0/3. (written in Java) +; +; :- public java_conversion/2. (written in Java) + + !(public (/ java-constructor 2)) + !(public (/ java-declared-constructor 2)) + !(public (/ java-method 3)) + !(public (/ java-declared-method 3)) + !(public (/ java-get-field 3)) + !(public (/ java-get-declared-field 3)) + !(public (/ java-set-field 3)) + !(public (/ java-set-declared-field 3)) + !(public (/ synchronized 2)) - (= - ($match-type compound $X) - (compound $X)) -; + + (= (java-constructor $Constr $Instance) + (=.. $Constr + (Cons $F $As)) + (builtin-java-convert-args $As $As1) + (=.. $Constr1 + (Cons $F $As1)) + (java-constructor0 $Constr1 $Instance1) + (= $Instance $Instance1)) - (= - ($match-type list $X) - ( (nonvar $X) (or (= $X Nil) (= $X (Cons $_ $_))))) -; + + (= (java-declared-constructor $Constr $Instance) + (=.. $Constr + (Cons $F $As)) + (builtin-java-convert-args $As $As1) + (=.. $Constr1 + (Cons $F $As1)) + (java-declared-constructor0 $Constr1 $Instance1) + (= $Instance $Instance1)) - (= - ($match-type java $X) - (java $X)) -; + + (= (java-method $Class_or_Instance $Method $Value) + (=.. $Method + (Cons $F $As)) + (builtin-java-convert-args $As $As1) + (=.. $Method1 + (Cons $F $As1)) + (java-method0 $Class_or_Instance $Method1 $Value1) + (java-conversion $Value2 $Value1) + (= $Value $Value2)) - (= - ($match-type stream $X) - (or - (java $X java.io.PushbackReader) - (java $X java.io.PrintWriter))) -; + + (= (java-declared-method $Class_or_Instance $Method $Value) + (=.. $Method + (Cons $F $As)) + (builtin-java-convert-args $As $As1) + (=.. $Method1 + (Cons $F $As1)) + (java-declared-method0 $Class_or_Instance $Method1 $Value1) + (java-conversion $Value2 $Value1) + (= $Value $Value2)) - (= - ($match-type stream-or-alias $X) - (or - (atom $X) - ($match-type stream $X))) -; + + (= (java-get-field $Class_or_Instance $Field $Value) + (java-get-field0 $Class_or_Instance $Field $Value1) + (java-conversion $Value2 $Value1) + (= $Value $Value2)) - (= - ($match-type hash $X) - (java $X com.googlecode.prolog-cafe.lang.HashtableOfTerm)) -; + + (= (java-get-declared-field $Class_or_Instance $Field $Value) + (java-get-declared-field0 $Class_or_Instance $Field $Value1) + (java-conversion $Value2 $Value1) + (= $Value $Value2)) - (= - ($match-type hash-or-alias $X) - (or - (atom $X) - ($match-type hash $X))) -; + + (= (java-set-field $Class_or_Instance $Field $Value) + (java-conversion $Value $Value1) + (java-set-field0 $Class_or_Instance $Field $Value1)) - (= - ($match-type predicate-indicator $X) - ( (nonvar $X) - (= $X - (with_self $P - (/ $F $A))) - (atom $P) - (atom $F) - (integer $A))) -; + + (= (java-set-declared-field $Class_or_Instance $Field $Value) + (java-conversion $Value $Value1) + (java-set-declared-field0 $Class_or_Instance $Field $Value1)) -; -; -; -; + (= (builtin-java-convert-args Nil Nil) + (set-det)) + (= (builtin-java-convert-args (Cons $X $Xs) (Cons $Y $Ys)) + (java-conversion $X $Y) + (builtin-java-convert-args $Xs $Ys)) + + (= (synchronized $Object $Goal) + ($begin-sync $Object $Ref) + (call $Goal) + ($end-sync $Ref)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; MeTTa interpreter ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + !(op 1170 xfx :-) + !(op 1170 xfx -->) + !(op 1170 fx :-) + !(op 1170 fx ?-) + + !(op 1150 fx package) + !(op 1150 fx import) + !(op 1150 fx public) + !(op 1150 fx dynamic) + !(op 1150 fx meta-predicate) + !(op 1150 fx mode) + !(op 1150 fx multifile) + !(op 1150 fx block) + + !(public (/ cafeteria 0)) + !(public (/ consult 1)) + !(public (/ consult-stream 1)) + !(public (, (/ trace 0) (/ notrace 0))) + !(public (, (/ debug 0) (/ nodebug 0))) + !(public (/ leash 1)) + !(public (, (/ spy 1) (/ nospy 1) (/ nospyall 0))) + !(public (/ listing 0)) + !(public (/ listing 1)) + + !(dynamic (/ %current-leash 1)) + !(dynamic (/ %current-spypoint 3)) + !(dynamic (/ %leap-flag 1)) + !(dynamic (/ %consulted-file 1)) + !(dynamic (/ %consulted-import 2)) + !(dynamic (/ %consulted-package 1)) + !(dynamic (/ %consulted-predicate 3)) + +; +; ;; Main + (= (cafeteria) + (%cafeteria-init) + (repeat) + (%toplvel-loop) + (on-exception $Msg + ($cafeteria $Goal) + (print-message error $Msg)) + (== $Goal end-of-file) + (set-det) + (nl) + ($fast-write bye) + (nl)) + - !(public (/ with-mutex 2)) -; + (= (%cafeteria-init) + ( (remove-all-atoms &self + (%leap_flag $_)) + (remove-all-atoms &self + (%current_leash $_)) + (remove-all-atoms &self + (%current_spypoint $_ $_ $_)) + (remove-all-atoms &self + (%consulted_file $_)) + (remove-all-atoms &self + (%consulted_package $_)) + (remove-all-atoms &self + (%consulted_predicate $_ $_ $_)) + (add-is-symbol &self + (%leap_flag no)) + (add-is-symbol &self + (%current_leash call)) + (add-is-symbol &self + (%current_leash exit)) + (add-is-symbol &self + (%current_leash redo)) + (add-is-symbol &self + (%current_leash fail)) + (set-det))) + + (= (%toplvel-loop) + (current-prolog-flag debug $Mode) + (det-if-then-else + (== $Mode off) True + (print-message info + (:: debug))) + ($fast-write | ?- ) + (flush-output)) + + + (= ($cafeteria $Goal) + (read-with-variables $Goal $Vars) + ($process-order $Goal $Vars)) + + + (= ($process-order $G $_) + (var $G) + (set-det) + (illarg var + ! (?- $G) 1)) + (= ($process-order end-of-file $_) + (set-det)) + (= ($process-order (Cons $File $Files) $_) + (set-det) + (consult (Cons $File $Files))) + (= ($process-order $G $Vars) + (current-prolog-flag debug $Mode) + (det-if-then-else + (== $Mode off) + (call $G) + ($trace-goal $G)) + (nl) + ($rm-redundant-vars $Vars $Vars1) + ($give-answers-with-prompt $Vars1) + (set-det) + ($fast-write yes) + (nl)) + (= ($process-order $_ $_) + (nl) + ($fast-write no) + (nl)) + + + (= ($rm-redundant-vars Nil Nil) + (set-det)) + (= ($rm-redundant-vars (Cons (= - $_) $Xs) $Vs) + (set-det) + ($rm-redundant-vars $Xs $Vs)) + (= ($rm-redundant-vars (Cons $X $Xs) (Cons $X $Vs)) + ($rm-redundant-vars $Xs $Vs)) + + + (= ($give-answers-with-prompt Nil) + (set-det)) + (= ($give-answers-with-prompt $Vs) + ($give-an-answer $Vs) + ($fast-write ? ) + (flush-output) + (read-line $Str) + (\== $Str ";") + (nl)) + + + (= ($give-an-answer Nil) + (set-det) + ($fast-write True)) + (= ($give-an-answer (:: $X)) + (set-det) + ('$print-an answer' $X)) + (= ($give-an-answer (Cons $X $Xs)) + ('$print-an answer' $X) + ($fast-write ,) + (nl) + ($give-an-answer $Xs)) + + + (= ('$print-an answer' (= $N $V)) + (write $N) + ($fast-write = ) + (writeq $V)) + +; +; ;; Read Program + + (= (consult $Files) + (var $Files) + (set-det) + (illarg var + (consult $Files) 1)) + (= (consult Nil) + (set-det)) + (= (consult (Cons $File $Files)) + (set-det) + (consult $File) + (consult $Files)) + (= (consult $File) + (atom $File) + (set-det) + ($consult $File)) + + + (= ($consult $F) + ($prolog-file-name $F $PF) + (open $PF read $In) + (stream-property $In + (file-name $File)) + (print-message info + (:: consulting $File ...)) + (statistics runtime $_) + (consult-stream $File $In) + (statistics runtime + (:: $_ $T)) + (print-message info + (:: $File consulted $T msec)) + (close $In)) + + + (= (consult-stream $File $In) + ($consult-init $File) + (repeat) + (read $In $Cl) + ($consult-clause $Cl) + (== $Cl end-of-file) + (set-det)) + + + (= ($prolog-file-name $File $File) + (sub-atom $File $_ $_ $After .) + (> $After 0) + (set-det)) + (= ($prolog-file-name $File0 $File) + (atom-concat $File0 .pl $File)) + + + (= ($consult-init $File) + ( (remove-all-atoms &self + (%consulted_file $_)) + (remove-all-atoms &self + (%consulted_package $_)) + (remove-all-atoms &self + (%consulted_import $File $_)) + (remove-is-symbol &self + (%consulted_predicate $P $PI $File)) + (abolish (with_self $P $PI)) + (fail))) + (= ($consult-init $File) + ( (add-is-symbol &self + (%consulted_file $File)) (add-is-symbol &self (%consulted_package user)))) + + + (= ($consult-clause end-of-file) + (set-det)) + (= ($consult-clause !(module $P $_)) + (set-det) + ($assert-consulted-package $P)) + (= ($consult-clause !(package $P)) + (set-det) + ($assert-consulted-package $P)) + (= ($consult-clause !(import $P)) + (set-det) + ($assert-consulted-import $P)) + (= ($consult-clause !(dynamic $_)) + (set-det)) + (= ($consult-clause !(public $_)) + (set-det)) + (= ($consult-clause !(meta-predicate $_)) + (set-det)) + (= ($consult-clause !(mode $_)) + (set-det)) + (= ($consult-clause !(multifile $_)) + (set-det)) + (= ($consult-clause !(block $_)) + (set-det)) + (= ($consult-clause !$G) + ( (set-det) + (== + (= + (%consulted_package $P) $_) + (get-atoms &self)) + (once (with_self $P $G)))) + (= ($consult-clause $Clause0) + ($consult-preprocess $Clause0 $Clause) + ($consult-cls $Clause)) - (= - (with-mutex $M $G) - ( (not (atom $M)) - (not (java $M)) - (set-det) - (illarg - (type is-symbol) - (with-mutex $M $G) 1))) -; + (= ($assert-consulted-package $P) + ( (== + (= + (%consulted_package $P) $_) + (get-atoms &self)) (set-det))) + (= ($assert-consulted-package $P) + ( (remove-all-atoms &self + (%consulted_package $_)) (add-is-symbol &self (%consulted_package $P)))) - (= - (with-mutex $M $G) - ( (var $G) - (set-det) - (illarg var - (with-mutex $M $G) 2))) -; + + (= ($assert-consulted-import $P) + ( (== + (= + (%consulted_file $File) $_) + (get-atoms &self)) (add-is-symbol &self (%consulted_import $File $P)))) - (= - (with-mutex $M $G) - ( (not (callable $G)) - (set-det) - (illarg - (type callable) - (with-mutex $M $G) 2))) -; + + (= ($consult-preprocess $Clause0 $Clause) + (expand-term $Clause0 $Clause)) - (= - (with-mutex $M $G) - ( (mutex-lock-bt $M) - (call $G) - (set-det) - (mutex-unlock $M))) -; + + (= ($consult-cls (= $H $G)) + (set-det) + ($assert-consulted-clause (= $H $G))) + (= ($consult-cls $H) + ($assert-consulted-clause (= $H True))) + + (= ($assert-consulted-clause $Clause) + ( (= $Clause + (= $H $_)) + (functor $H $F $A) + (== + (= + (%consulted_file $File) $_) + (get-atoms &self)) + (== + (= + (%consulted_package $P) $_) + (get-atoms &self)) + (add-is-symbol &self + (: $P $Clause)) + (add-is-symbol &self + (%consulted_predicate $P + (/ $F $A) $File)) + (set-det))) ; -; +; ;; Trace -; -; + (= (trace) + (current-prolog-flag debug on) + (set-det)) + (= (trace) + (set-prolog-flag debug on) + (%trace-init) + ($fast-write '{Small debugger is switch on}') + (nl) + (set-det)) + -; -; + (= (%trace-init) + ( (remove-all-atoms &self + (%leap_flag $_)) + (remove-all-atoms &self + (%current_leash $_)) + (remove-all-atoms &self + (%current_spypoint $_ $_ $_)) + (add-is-symbol &self + (%leap_flag no)) + (add-is-symbol &self + (%current_leash call)) + (add-is-symbol &self + (%current_leash exit)) + (add-is-symbol &self + (%current_leash redo)) + (add-is-symbol &self + (%current_leash fail)) + (set-det))) + + + (= (notrace) + (current-prolog-flag debug off) + (set-det)) + (= (notrace) + (set-prolog-flag debug off) + ($fast-write '{Small debugger is switch off}') + (nl) + (set-det)) + + (= (debug) + (trace)) - (= - (%builtin_append () $Zs $Zs) True) -; + (= (nodebug) + (notrace)) - (= - ($builtin-append - (Cons $X $Xs) $Ys - (Cons $X $Zs)) - ($builtin-append $Xs $Ys $Zs)) -; +; +; ;; Spy-Points + + (= (spy $T) + ($term-to-predicateindicator $T $PI + (spy $T)) + (trace) + ($assert-spypoint $PI) + ($set-debug-flag leap yes) + (set-det)) + + (= ($assert-spypoint (with_self $P (/ $F $A))) + ( (== + (= + (%current_spypoint $P $F $A) $_) + (get-atoms &self)) + (print-message info + (:: spypoint + (with_self $P + (/ $F $A)) is already added)) + (set-det))) + (= ($assert-spypoint (with_self $P (/ $F $A))) + ( (== + (= + (%consulted_predicate $P + (/ $F $A) $_) $_) + (get-atoms &self)) + (add-is-symbol &self + (%current_spypoint $P $F $A)) + (print-message info + (:: spypoint + (with_self $P + (/ $F $A)) is added)) + (set-det))) + (= ($assert-spypoint (with_self $P (/ $F $A))) + (print-message warning + (:: no matching predicate for spy + (with_self $P + (/ $F $A))))) - (= - (%builtin_member $X - (Cons $X $_)) True) -; + (= (nospy $T) + ($term-to-predicateindicator $T $PI + (nospy $T)) + ($retract-spypoint $PI) + ($set-debug-flag leap no) + (set-det)) - (= - ($builtin-member $X - (Cons $_ $L)) - ($builtin-member $X $L)) -; + + (= ($retract-spypoint (with_self $P (/ $F $A))) + ( (remove-is-symbol &self + (%current_spypoint $P $F $A)) + (print-message info + (:: spypoint + (with_self $P + (/ $F $A)) is removed)) + (set-det))) + (= (%retract_spypoint $_) True) + + (= (nospyall) + ( (remove-all-atoms &self + (%current_spypoint $_ $_ $_)) ($set-debug-flag leap no))) +; +; ;; Leash - (= - ($builtin-message Nil) - (set-det)) -; + (= (leash $L) + (nonvar $L) + ($leash $L) + (set-det)) + (= (leash $L) + (illarg + (type leash-specifier) + (leash $L) 1)) - (= - ($builtin-message (:: $M)) - ( (set-det) (write $M))) -; + + (= ($leash Nil) + ( (set-det) + (remove-all-atoms &self + (%current_leash $_)) + (print-message info + (:: no leashing)))) + (= ($leash $Ms) + ( (remove-all-atoms &self + (%current_leash $_)) + ($assert-leash $Ms) + (print-message info + (:: leashing stopping on $Ms)))) - (= - ($builtin-message (Cons $M $Ms)) - ( (write $M) - ($fast-write ' ') - ($builtin-message $Ms))) -; + + (= ($assert-leash Nil) + (set-det)) + (= ($assert-leash (Cons $X $Xs)) + ( ($leash-specifier $X) + (add-is-symbol &self + (%current_leash $X)) + ($assert-leash $Xs))) + + (= (%leash_specifier call) True) + (= (%leash_specifier exit) True) + (= (%leash_specifier redo) True) + (= (%leash_specifier fail) True) +; +; '$leash_specifier'(exception). +; +; ;; Trace a Goal - (= - ($member-in-reverse $X - (Cons $_ $L)) - ($member-in-reverse $X $L)) -; + (= ($trace-goal $Term) + ($set-debug-flag leap no) + ($get-current-B $Cut) + ($meta-call $Term user $Cut 0 trace)) - (= - (%member_in_reverse $X - (Cons $X $_)) True) -; + (= ($trace-goal $X $P $FA $Depth) + (print-procedure-box call $X $P $FA $Depth) + ($call-internal $X $P $FA $Depth trace) + (print-procedure-box exit $X $P $FA $Depth) + (redo-procedure-box $X $P $FA $Depth)) + (= ($trace-goal $X $P $FA $Depth) + (print-procedure-box fail $X $P $FA $Depth) + (fail)) + + + (= (print-procedure-box $Mode $G $P (/ $F $A) $Depth) + ( (== + (= + (%current_spypoint $P $F $A) $_) + (get-atoms &self)) + (set-det) + ($builtin-message (:: + $Depth $Mode : (with_self $P $G))) + ($read-blocked (print-procedure-box $Mode $G $P (/ $F $A) $Depth)))) + (= (print-procedure-box $Mode $G $P $FA $Depth) + ( (== + (= + (%leap_flag no) $_) + (get-atoms &self)) + (set-det) + ($builtin-message (:: ' ' $Depth $Mode : (with_self $P $G))) + (det-if-then-else + (== + (= + (%current_leash $Mode) $_) + (get-atoms &self)) + ($read-blocked (print-procedure-box $Mode $G $P $FA $Depth)) nl))) + (= (print_procedure_box $_ $_ $_ $_ $_) True) + + + (= (redo_procedure_box $_ $_ $_ $_) True) + (= (redo-procedure-box $X $P $FA $Depth) + (print-procedure-box redo $X $P $FA $Depth) + (fail)) + + + (= ($read-blocked $G) + ($fast-write ? ) + (flush-output) + (read-line $C) + (det-if-then-else + (== $C Nil) + (= $DOP 99) + (= $C + (Cons $DOP $_))) + ($debug-option $DOP $G)) + + + (= ($debug-option 97 $_) + (set-det) + (notrace) + (abort)) ; +; a for abort + (= ($debug-option 99 $_) + (set-det) + ($set-debug-flag leap no)) ; +; c for creep + (= ($debug-option 108 $_) + (set-det) + ($set-debug-flag leap yes)) ; +; l for leap + (= ($debug-option 43 (print-procedure-box $Mode $G $P $FA $Depth)) + (set-det) + (spy (with_self $P $FA)) + (call (print-procedure-box $Mode $G $P $FA $Depth))) +; ; + for spy this + (= ($debug-option 45 (print-procedure-box $Mode $G $P $FA $Depth)) + (set-det) + (nospy (with_self $P $FA)) + (call (print-procedure-box $Mode $G $P $FA $Depth))) +; ; - for nospy this + (= ($debug-option 63 $G) + (set-det) + (%show-debug-option) + (call $G)) + (= ($debug-option 104 $G) + (set-det) + (%show-debug-option) + (call $G)) + (= (%debug_option $_ $_) True) + + + (= (%show-debug-option) + (tab 4) + ($fast-write 'Debuggin options:') + (nl) + (tab 4) + ($fast-write 'a abort') + (nl) + (tab 4) + ($fast-write 'RET creep') + (nl) + (tab 4) + ($fast-write 'c creep') + (nl) + (tab 4) + ($fast-write 'l leap') + (nl) + (tab 4) + ($fast-write '+ spy this') + (nl) + (tab 4) + ($fast-write '- nospy this') + (nl) + (tab 4) + ($fast-write '? help') + (nl) + (tab 4) + ($fast-write 'h help') + (nl)) + + + (= ($set-debug-flag leap $Flag) + ( (== + (= + (%leap_flag $Flag) $_) + (get-atoms &self)) (set-det))) + (= ($set-debug-flag leap $Flag) + ( (remove-all-atoms &self + (%leap_flag $_)) (add-is-symbol &self (%leap_flag $Flag)))) + +; +; ;; Listing + + (= (listing) + ($listing $_ user)) + + (= (listing $T) + (var $T) + (set-det) + (illarg var + (listing $T) 1)) + (= (listing $P) + (atom $P) + (set-det) + ($listing $_ $P)) + (= (listing (/ $F $A)) + (set-det) + ($listing + (/ $F $A) user)) + (= (listing (with_self $P $PI)) + (atom $P) + (set-det) + ($listing $PI $P)) + (= (listing $T) + (illarg + (type predicate-indicator) + (listing $T) 1)) + + + (= ($listing $PI $P) + (var $PI) + (set-det) + ($listing-dynamic-clause $P $_)) + (= ($listing (/ $F $A) $P) + (atom $F) + (integer $A) + (set-det) + ($listing-dynamic-clause $P + (/ $F $A))) + (= ($listing $PI $P) + (illarg + (type predicate-indicator) + (listing (with_self $P $PI)) 1)) + + + (= ($listing-dynamic-clause $P $PI) + ($new-internal-database $P) + (hash-keys $P $Keys) + ($builtin-member $PI $Keys) + (= $PI + (/ $F $A)) + (functor $H $F $A) + ($clause-internal $P $PI $H $Cl $_) + ($write-dynamic-clause $P $Cl) + (fail)) + (= (%listing_dynamic_clause $_ $_) True) + + + (= ($write-dynamic-clause $_ $Cl) + (var $Cl) + (set-det) + (fail)) + (= ($write-dynamic-clause $P (= $H True)) + (set-det) + (numbervars $H 0 $_) + ($write-dynamic-head $P $H) + (write .) + (nl)) + (= ($write-dynamic-clause $P (= $H $B)) + (set-det) + (numbervars + (= $H $B) 0 $_) + ($write-dynamic-head $P $H) + (write :-) + (nl) + ($write-dynamic-body $B 8) + (write .) + (nl)) + + + (= ($write-dynamic-head user $H) + (set-det) + (writeq $H)) + (= ($write-dynamic-head $P $H) + (write $P) + (write :) + (writeq $H)) + + + (= ($write-dynamic-body (, $G1 $G2) $N) + (set-det) + ($write-dynamic-body $G1 $N) + (write ,) + (nl) + ($write-dynamic-body $G2 $N)) + (= ($write-dynamic-body (or $G1 $G2) $N) + (set-det) + (is $N1 + (+ $N 4)) + (tab $N) + (write () + (nl) + ($write-dynamic-body $G1 $N1) + (nl) + (tab $N) + (write or) + (nl) + ($write-dynamic-body $G2 $N1) + (nl) + (tab $N) + (write ))) + (= ($write-dynamic-body (det-if-then $G1 $G2) $N) + (set-det) + (is $N1 + (+ $N 4)) + (tab $N) + (write () + (nl) + ($write-dynamic-body $G1 $N1) + (nl) + (tab $N) + (write ->) + (nl) + ($write-dynamic-body $G2 $N1) + (nl) + (tab $N) + (write ))) + (= ($write-dynamic-body $B $N) + (tab $N) + (writeq $B)) + +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Misc +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + !(public (/ reverse 2)) + !(public (/ length 2)) + !(public (/ numbervars 3)) + !(public (/ statistics 2)) + +; +; reverse(Xs, Zs) :- reverse(Xs, [], Zs). +; +; reverse([], Zs, Zs). +; +; reverse([X|Xs], Tmp, Zs) :- reverse(Xs, [X|Tmp], Zs). + + + (= (length $L $N) + (var $N) + (set-det) + ($length $L 0 $N)) + (= (length $L $N) + ($length0 $L 0 $N)) + + + (= (%length () $I $I) True) + (= ($length (Cons $_ $L) $I0 $I) + (is $I1 + (+ $I0 1)) + ($length $L $I1 $I)) + + + (= ($length0 Nil $I $I) + (set-det)) + (= ($length0 (Cons $_ $L) $I0 $I) + (< $I0 $I) + (is $I1 + (+ $I0 1)) + ($length0 $L $I1 $I)) + + + (= (numbervars $X $VI $VN) + (integer $VI) + (>= $VI 0) + (set-det) + ($numbervars $X $VI $VN)) + + + (= ($numbervars $X $VI $VN) + (var $X) + (set-det) + (= $X $VI) + (is $VN + (+ $VI 1))) +; ; This structure is checked in write + (= ($numbervars $X $VI $VI) + (atomic $X) + (set-det)) + (= ($numbervars $X $VI $VI) + (java $X) + (set-det)) + (= ($numbervars $X $VI $VN) + (functor $X $_ $N) + ($numbervars-str 1 $N $X $VI $VN)) + + + (= ($numbervars-str $I $I $X $VI $VN) + (set-det) + (arg $I $X $A) + ($numbervars $A $VI $VN)) + (= ($numbervars-str $I $N $X $VI $VN) + (arg $I $X $A) + ($numbervars $A $VI $VN1) + (is $I1 + (+ $I 1)) + ($numbervars-str $I1 $N $X $VN1 $VN)) + + + (= (statistics $Key $Value) + (nonvar $Key) + ($statistics-mode $Key) + (set-det) + ($statistics $Key $Value)) + (= (statistics $Key $Value) + (findall $M + ($statistics-mode $M) $Domain) + (illarg + (domain is-symbol $Domain) + (statistics $Key $Value) 1)) + + + (= (%statistics_mode runtime) True) + (= (%statistics_mode trail) True) + (= (%statistics_mode choice) True) + + + (= (print-message $Type $Message) + (var $Type) + (set-det) + (illarg var + (print-message $Type $Message) 1)) + (= (print-message error $Message) + (set-det) + ($error-message $Message)) + (= (print-message info $Message) + (set-det) + ($fast-write {) + ($builtin-message $Message) + ($fast-write }) + (nl)) + (= (print-message warning $Message) + (set-det) + ($fast-write '{WARNING: ') + ($builtin-message $Message) + ($fast-write }) + (nl)) + + + (= ($error-message (instantiation-error $Goal 0)) + (set-det) + ($fast-write user-error '{INSTANTIATION ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (instantiation-error $Goal $ArgNo)) + (set-det) + ($fast-write user-error '{INSTANTIATION ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error ' - arg ') + ($fast-write user-error $ArgNo) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (type-error $Goal $ArgNo $Type $Culprit)) + (set-det) + ($fast-write user-error '{TYPE ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error ' - arg ') + ($fast-write user-error $ArgNo) + ($fast-write user-error ': expected ') + ($fast-write user-error $Type) + ($fast-write user-error ', found ') + (write user-error $Culprit) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (domain-error $Goal $ArgNo $Domain $Culprit)) + (set-det) + ($fast-write user-error '{DOMAIN ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error ' - arg ') + ($fast-write user-error $ArgNo) + ($fast-write user-error ': expected ') + ($fast-write user-error $Domain) + ($fast-write user-error ', found ') + (write user-error $Culprit) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (existence-error $Goal 0 $ObjType $Culprit $Message)) + (set-det) + ($fast-write user-error '{EXISTENCE ERROR: ') + ($fast-write user-error $ObjType) + ($fast-write user-error ' ') + (write user-error $Culprit) + ($fast-write user-error ' does not exist') + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (existence-error $Goal $ArgNo $ObjType $Culprit $Message)) + (set-det) + ($fast-write user-error '{EXISTENCE ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error ' - arg ') + ($fast-write user-error $ArgNo) + ($fast-write user-error : ) + ($fast-write user-error $ObjType) + ($fast-write user-error ' ') + (write user-error $Culprit) + ($fast-write user-error ' does not exist') + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (permission-error $Goal $Operation $ObjType $Culprit $Message)) + (set-det) + ($fast-write user-error '{PERMISSION ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error ' - can not ') + ($fast-write user-error $Operation) + ($fast-write user-error ' ') + ($fast-write user-error $ObjType) + ($fast-write user-error ' ') + (write user-error $Culprit) + ($fast-write user-error : ) + ($fast-write user-error $Message) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (representation-error $Goal $ArgNo $Flag)) + (set-det) + ($fast-write user-error '{REPRESENTATION ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error ' - arg ') + ($fast-write user-error $ArgNo) + ($fast-write user-error ': limit of ') + ($fast-write user-error $Flag) + ($fast-write user-error ' is breached') + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (evaluation-error $Goal $ArgNo $Type)) + (set-det) + ($fast-write user-error '{EVALUATION ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error ' - arg ') + ($fast-write user-error $ArgNo) + ($fast-write user-error ', found ') + ($fast-write user-error $Type) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (syntax-error $Goal $ArgNo $Type $Culprit $Message)) + (set-det) + ($fast-write user-error '{SYNTAX ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error ' - arg ') + ($fast-write user-error $ArgNo) + ($fast-write user-error ': expected ') + ($fast-write user-error $Type) + ($fast-write user-error ', found ') + (write user-error $Culprit) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (system-error $Message)) + (set-det) + ($fast-write user-error '{SYSTEM ERROR: ') + (write user-error $Message) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (internal-error $Message)) + (set-det) + ($fast-write user-error '{INTERNAL ERROR: ') + (write user-error $Message) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (java-error $Goal $ArgNo $Exception)) + (set-det) + ($fast-write user-error '{JAVA ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error ' - arg ') + ($fast-write user-error $ArgNo) + ($fast-write user-error ', found ') + ($write-goal user-error $Exception) + ($fast-write user-error }) + (nl user-error) + ($print-stack-trace $Exception) + (flush-output user-error)) + (= ($error-message $Message) + ($fast-write user-error {) + (write user-error $Message) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + + + (= ($write-goal $S $Goal) + (java $Goal) + (set-det) + ($write-toString $S $Goal)) + (= ($write-goal $S $Goal) + (write $S $Goal)) + + + (= (illarg $Msg $Goal $ArgNo) + (var $Msg) + (set-det) + (illarg var $Goal $ArgNo)) + (= (illarg var $Goal $ArgNo) + (raise-exception (instantiation-error $Goal $ArgNo))) + (= (illarg (type $Type) $Goal $ArgNo) + (arg $ArgNo $Goal $Arg) + (det-if-then-else + (nonvar $Arg) + (= $Error + (type-error $Goal $ArgNo $Type $Arg)) + (= $Error + (instantiation-error $Goal $ArgNo))) + (raise-exception $Error)) + (= (illarg (domain $Type $ExpDomain) $Goal $ArgNo) + (arg $ArgNo $Goal $Arg) + (det-if-then-else + ($match-type $Type $Arg) + (= $Error + (domain-error $Goal $ArgNo $ExpDomain $Arg)) + (det-if-then-else + (nonvar $Arg) + (= $Error + (type-error $Goal $ArgNo $Type $Arg)) + (= $Error + (instantiation-error $Goal $ArgNo)))) + (raise-exception $Error)) + (= (illarg (existence $ObjType $Culprit $Message) $Goal $ArgNo) + (raise-exception (existence-error $Goal $ArgNo $ObjType $Culprit $Message))) + (= (illarg (permission $Operation $ObjType $Culprit $Message) $Goal $_) + (raise-exception (permission-error $Goal $Operation $ObjType $Culprit $Message))) + (= (illarg (representation $Flag) $Goal $ArgNo) + (raise-exception (representation-error $Goal $ArgNo $Flag))) + (= (illarg (evaluation $Type) $Goal $ArgNo) + (raise-exception (evaluation-error $Goal $ArgNo $Type))) + (= (illarg (syntax $Type $Culprit $Message) $Goal $ArgNo) + (raise-exception (syntax-error $Goal $ArgNo $Type $Culprit $Message))) + (= (illarg (system $Message) $_ $_) + (raise-exception (system-error $Message))) + (= (illarg (internal $Message) $_ $_) + (raise-exception (internal-error $Message))) + (= (illarg (java $Exception) $Goal $ArgNo) + (raise-exception (java-error $Goal $ArgNo $Exception))) + (= (illarg $Msg $_ $_) + (raise-exception $Msg)) + + + (= (%match_type term $_) True) + (= ($match-type variable $X) + (var $X)) + (= ($match-type is-symbol $X) + (atom $X)) + (= ($match-type symbolic $X) + (atomic $X)) + (= ($match-type byte $X) + (integer $X) + (=< 0 $X) + (=< $X 255)) + (= ($match-type in-byte $X) + (integer $X) + (=< -1 $X) + (=< $X 255)) + (= ($match-type character $X) + (atom $X) + (atom-length $X 1)) + (= ($match-type in-character $X) + (or + (== $X end-of-file) + ($match-type character $X))) + (= ($match-type number $X) + (number $X)) + (= ($match-type integer $X) + (integer $X)) + (= ($match-type long $X) + (long $X)) + (= ($match-type float $X) + (float $X)) + (= ($match-type callable $X) + (callable $X)) + (= ($match-type compound $X) + (compound $X)) + (= ($match-type list $X) + (nonvar $X) + (or + (= $X Nil) + (= $X + (Cons $_ $_)))) + (= ($match-type java $X) + (java $X)) + (= ($match-type stream $X) + (or + (java $X java.io.PushbackReader) + (java $X java.io.PrintWriter))) + (= ($match-type stream-or-alias $X) + (or + (atom $X) + ($match-type stream $X))) + (= ($match-type hash $X) + (java $X com.googlecode.prolog-cafe.lang.HashtableOfTerm)) + (= ($match-type hash-or-alias $X) + (or + (atom $X) + ($match-type hash $X))) + (= ($match-type predicate-indicator $X) + (nonvar $X) + (= $X + (with_self $P + (/ $F $A))) + (atom $P) + (atom $F) + (integer $A)) +; +; '$match_type'(evaluable, X). +; +; '$match_type'('convertible to java', X). ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; ISO thread synchronization +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + !(public (/ with-mutex 2)) + + (= (with-mutex $M $G) + (not (atom $M)) + (not (java $M)) + (set-det) + (illarg + (type is-symbol) + (with-mutex $M $G) 1)) + (= (with-mutex $M $G) + (var $G) + (set-det) + (illarg var + (with-mutex $M $G) 2)) + (= (with-mutex $M $G) + (not (callable $G)) + (set-det) + (illarg + (type callable) + (with-mutex $M $G) 2)) + (= (with-mutex $M $G) + (mutex-lock-bt $M) + (call $G) + (set-det) + (mutex-unlock $M)) +; ; if it fails or throws exception, mutex is unlocked automatically due to mutex_lock_bt + ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Utilities +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (= (%builtin_append () $Zs $Zs) True) + (= ($builtin-append (Cons $X $Xs) $Ys (Cons $X $Zs)) + ($builtin-append $Xs $Ys $Zs)) + + + (= (%builtin_member $X (Cons $X $_)) True) + (= ($builtin-member $X (Cons $_ $L)) + ($builtin-member $X $L)) + + + (= ($builtin-message Nil) + (set-det)) + (= ($builtin-message (:: $M)) + (set-det) + (write $M)) + (= ($builtin-message (Cons $M $Ms)) + (write $M) + ($fast-write ' ') + ($builtin-message $Ms)) + + + (= ($member-in-reverse $X (Cons $_ $L)) + ($member-in-reverse $X $L)) + (= (%member_in_reverse $X (Cons $X $_)) True) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; END diff --git a/sxx_machine/sxx_compiler.metta b/sxx_machine/sxx_compiler.metta index 4744cd3..9cd5477 100644 --- a/sxx_machine/sxx_compiler.metta +++ b/sxx_machine/sxx_compiler.metta @@ -1,1227 +1,719 @@ +; (convert_to_metta_file sxx_compiler $_425594 sxx_machine/sxx_compiler.pl sxx_machine/sxx_compiler.metta) - (= - (append () $L $L) True) -; - - (= - (append - (Cons $X $L1) $L2 - (Cons $X $L3)) + (= (append () $L $L) True) + (= (append (Cons $X $L1) $L2 (Cons $X $L3)) (append $L1 $L2 $L3)) -; - - - - (= - (legacy-functor $P . $A) - ( (functor $P Cons $A) (set-det))) -; - - (= - (legacy-functor $P $F $A) - ( (functor $P $F $A) (set-det))) -; - - (= - (comp $File) - ( (see $File) - (file-name-extension $BName $_ $File) - (= $InProg Nil) - (readprogram $BName $InProg $Prog) - (set-det) - (seen) - (makename - (:: tcomp- $BName) $Dir) - (make-directory-path $Dir) - (set-det) - (gencode $Dir $Prog) - (set-det))) -; - + (= (legacy-functor $P . $A) + (functor $P Cons $A) + (set-det)) + (= (legacy-functor $P $F $A) + (functor $P $F $A) + (set-det)) - (= - (gencode $_ ()) True) -; + (= (comp $File) + (see $File) + (file-name-extension $BName $_ $File) + (= $InProg Nil) + (readprogram $BName $InProg $Prog) + (set-det) + (seen) + (makename + (:: tcomp- $BName) $Dir) + (make-directory-path $Dir) + (set-det) + (gencode $Dir $Prog) + (set-det)) +; ; close(File) , - (= - (gencode $Package - (Cons $Pred $Preds)) - ( (gencodeforpred $Package $Pred) (gencode $Package $Preds))) -; + (= (gencode $_ ()) True) + (= (gencode $Package (Cons $Pred $Preds)) + (gencodeforpred $Package $Pred) + (gencode $Package $Preds)) - (= - (local-side-efs $_ - !$Call) - ( (call $Call) (set-det))) -; - - (= - (local-side-efs $_ $H) - ( (\= $H - (= $_ $_)) - (set-det) - (local-side-efs $_ - (= $H True)))) -; - - (= + (= (local-side-efs $_ !$Call) + (call $Call) + (set-det)) + (= (local-side-efs $_ $H) + (\= $H + (= $_ $_)) + (set-det) (local-side-efs $_ - (= $H $_)) - ( (or - (predicate-property $H static) - (predicate-property $H built-in)) (set-det))) -; - - (= - (local-side-efs $_ $Call) - ( (call (add-symbol &self $Call)) (set-det))) -; - - (= - (local_side_efs $_ $Clause) True) -; - - - (= - (readprogram $BName $In $Out) - ( (read $Clause) - (local-side-efs $BName $Clause) - (det-if-then-else - (= $Clause end-of-file) - (= $In $Out) - (, - (binarize $Clause $BinCl) - (addclausetoprogram $BinCl $In $NewIn) - (readprogram $BName $NewIn $Out))))) -; - + (= $H True))) + (= (local-side-efs $_ (= $H $_)) + (or + (predicate-property $H static) + (predicate-property $H built-in)) + (set-det)) + (= (local-side-efs $_ $Call) + (call (add-is-symbol &self $Call)) + (set-det)) + (= (local_side_efs $_ $Clause) True) + + (= (readprogram $BName $In $Out) + (read $Clause) + (local-side-efs $BName $Clause) + (det-if-then-else + (= $Clause end-of-file) + (= $In $Out) + (, + (binarize $Clause $BinCl) + (addclausetoprogram $BinCl $In $NewIn) + (readprogram $BName $NewIn $Out)))) ; -; - - - (= - (binarize - (= $Head $Body) - (= $BinHead $BinBody)) - ( (set-det) - (addcont $Head $Continuation $BinHead) - (makebinbody $Body $Continuation $BinBody))) -; - - (= - (binarize $Head - (= $BinHead - (call $Continuation))) +; binarize((Head ::- Body),Cl) :- ! , Cl = (Head :- Body) . + + (= (binarize (= $Head $Body) (= $BinHead $BinBody)) + (set-det) + (addcont $Head $Continuation $BinHead) + (makebinbody $Body $Continuation $BinBody)) + (= (binarize $Head (= $BinHead + (call $Continuation))) (addcont $Head $Continuation $BinHead)) -; - - - - (= - (makebinbody - (, $G $B) $C $NewBody) - ( (set-det) - (makebinbody $B $C $NewB) - (addcont $G $NewB $NewBody))) -; - - (= - (makebinbody $SpecialGoal $C $NewBody) - ( (specialgoal $SpecialGoal $G) - (set-det) - (addcont $G $C $NewBody))) -; - - (= - (makebinbody - (set-det) $C $NewBody) - ( (set-det) (= $NewBody (cut 1 $C)))) -; - - (= - (makebinbody $G $C $NewBody) - ( (set-det) (addcont $G $C $NewBody))) -; - - - - (= - (addclausetoprogram $Cl Nil $ProgOut) - ( (set-det) (= $ProgOut (:: (:: $Cl))))) -; - - (= - (addclausetoprogram $Cl - (Cons $Pred $Rest) $Out) - ( (samepred $Cl $Pred) - (set-det) - (= $Out - (Cons - (Cons $Cl $Pred) $Rest)))) -; - - (= - (addclausetoprogram $Cl - (Cons $Pred $Rest) - (Cons $Pred $NewRest)) - (addclausetoprogram $Cl $Rest $NewRest)) -; - - - (= - (samepred - (= $H1 $_) + (= (makebinbody (, $G $B) $C $NewBody) + (set-det) + (makebinbody $B $C $NewB) + (addcont $G $NewB $NewBody)) + (= (makebinbody $SpecialGoal $C $NewBody) + (specialgoal $SpecialGoal $G) + (set-det) + (addcont $G $C $NewBody)) + (= (makebinbody (set-det) $C $NewBody) + (set-det) + (= $NewBody + (cut 1 $C))) + (= (makebinbody $G $C $NewBody) + (set-det) + (addcont $G $C $NewBody)) + + + (= (addclausetoprogram $Cl Nil $ProgOut) + (set-det) + (= $ProgOut + (:: (:: $Cl)))) + (= (addclausetoprogram $Cl (Cons $Pred $Rest) $Out) + (samepred $Cl $Pred) + (set-det) + (= $Out (Cons - (= $H2 $_) $_)) - ( (legacy-functor $H1 $N $A) (legacy-functor $H2 $N $A))) -; - - - - - - - - (= - (addcont - (set-det) $C $FB) - ( (set-det) (= $FB (cut 1 $C)))) -; - - (= - (addcont $S $C $NG) - ( (specialgoal $S $NS) - (set-det) - (addcont $NS $C $NG))) -; - - (= - (addcont $F $C $FB) - ( (=.. $F - (Cons $N $A)) - (append $A - (:: $C) $NA) - (=.. $FB - (Cons $N $NA)))) -; + (Cons $Cl $Pred) $Rest))) + (= (addclausetoprogram $Cl (Cons $Pred $Rest) (Cons $Pred $NewRest)) + (addclausetoprogram $Cl $Rest $NewRest)) + (= (samepred (= $H1 $_) (Cons (= $H2 $_) $_)) + (legacy-functor $H1 $N $A) + (legacy-functor $H2 $N $A)) - (= - (makename $EOL $Out) - ( (== $EOL Nil) - (set-det) - (= $Out ''))) -; - (= - (makename $Atom $Out) - ( (atomic $Atom) - (set-det) - (= $Out $Atom))) -; - (= - (makename - (Cons $AC $Rest) $OutC) - ( (makename $Rest $OC) - (name $OC $OL) - (name $AC $AL) - (append $AL $OL $OutL) - (name $OutC $OutL))) -; - (= - (writel ()) True) -; + (= (addcont (set-det) $C $FB) + (set-det) + (= $FB + (cut 1 $C))) + (= (addcont $S $C $NG) + (specialgoal $S $NS) + (set-det) + (addcont $NS $C $NG)) + (= (addcont $F $C $FB) + (=.. $F + (Cons $N $A)) + (append $A + (:: $C) $NA) + (=.. $FB + (Cons $N $NA))) - (= - (writel (Cons $X $R)) - ( (wr $X) (writel $R))) -; + (= (makename $EOL $Out) + (== $EOL Nil) + (set-det) + (= $Out '')) + (= (makename $Atom $Out) + (atomic $Atom) + (set-det) + (= $Out $Atom)) + (= (makename (Cons $AC $Rest) $OutC) + (makename $Rest $OC) + (name $OC $OL) + (name $AC $AL) + (append $AL $OL $OutL) + (name $OutC $OutL)) - (= - (wr (wr nl)) - ( (set-det) (nl))) -; - (= - (wr $Atom) - ( (atomic $Atom) - (set-det) - (write $Atom))) -; + (= (writel ()) True) + (= (writel (Cons $X $R)) + (wr $X) + (writel $R)) - (= - (wr $VAR) - ( (legacy-functor $VAR %VAR 2) - (set-det) - (write $VAR))) -; - (= - (wr $Goal) + (= (wr (wr nl)) + (set-det) + (nl)) + (= (wr $Atom) + (atomic $Atom) + (set-det) + (write $Atom)) + (= (wr $VAR) + (legacy-functor $VAR %VAR 2) + (set-det) + (write $VAR)) + (= (wr $Goal) (call $Goal)) -; - - (= - (wrargs $N $T) + (= (wrargs $N $T) (wrargs $N $T $_)) -; - - - (= - (wrargs $N $_ $_) - ( (= $N 0) (set-det))) -; - - (= - (wrargs $N $T $Komma) - ( (det-if-then-else - (var $Komma) - (= $Komma yes) - (write ,)) - (writel (:: $T a $N)) - (is $M - (- $N 1)) - (wrargs $M $T $Komma))) -; + (= (wrargs $N $_ $_) + (= $N 0) + (set-det)) + (= (wrargs $N $T $Komma) + (det-if-then-else + (var $Komma) + (= $Komma yes) + (write ,)) + (writel (:: $T a $N)) + (is $M + (- $N 1)) + (wrargs $M $T $Komma)) ; -; - +; Pred is a list of clauses for a specific predicate ; -; - - - - (= - (gencodeforpred $Package $Pred) - ( (= $Pred - (Cons - (= $H $_) $_)) - (legacy-functor $H $N $A) - (is $AA - (- $A 1)) - (makename - (:: pred- $N - $AA) $ClassName) - (makename - (:: $Package / $ClassName .java) $FileName) - (setof $F - (^ $Pred - (continuationof $Pred $F)) $Conts) - (setof $F - (^ $Pred - (stringof $Pred $F)) $AllStrings) - (mysetof $F - (^ $Pred - (intof $Pred $F)) $AllInts) - (= $Strings - (Cons cut $AllStrings)) - (tell $FileName) - (prelude $Pred) - (writel (:: 'class /* Pred */' $ClassName ' extends Code' (wr nl) { (wr nl) (declforeachclause $Pred 1 $ClassName) (declforeachcontinuation $Conts $N $A) (declforeachstring $Strings 0) (declforeachint $AllInts) 'public static Code entry-code = new ' $ClassName (); (wr nl) 'public void Init(Prolog mach)' (wr nl) { (initforeachcontinuation $Conts $N $A) } (wr nl) 'public int Arity() { return ' $AA ; } (wr nl) 'public Code Exec(Prolog mach)' (wr nl) '{ Term aregs[] = {' (aregarray $AA) } ; (wr nl) 'mach.CreateChoicePoint(aregs) ;' (wr nl) 'return cl1.Exec(mach) ;' (wr nl) } (wr nl) } (wr nl) (wr nl))) - (genpredcode $Pred last $ClassName $_ $Strings) - (told))) -; - - - - (= - (mysetof $X $Y $Z) - ( (setof $X $Y $Z) (set-det))) -; - - (= - (mysetof $_ $_ ()) True) -; - - - - (= - (genpredcode () $_ $_ 0 $_) True) -; - - (= - (genpredcode - (Cons $Clause $Rest) $Last $ClassName $M $Strings) - ( (genpredcode $Rest notlast $ClassName $N $Strings) - (is $M - (+ $N 1)) - (genclausecode $Clause $Last $ClassName $M $Strings))) -; - - - - (= - (genclausecode $Clause $Last $ClassName $N $Strings) - ( (= $Clause - (= $Head $Body)) - (legacy-functor $Head $Name $Arity) - (is $Amin2 - (- $Arity 2)) - (is $Amin1 - (- $Arity 1)) - (arg $Arity $Head - ($cont $Arity)) - (writel (:: '/* helper */class ' $ClassName -- $N ' extends ' $ClassName (wr nl) { (wr nl) 'public Code Exec(Prolog mach)' (wr nl) { (det-if-then-else (= $Last last) (write 'mach.RemoveChoice() ;') (, (is $M (+ $N 1)) (writel (:: mach.FillAlternative(cl $M ) ;)))) (wr nl) 'Term local-aregs[] = mach.Areg ;' (wr nl) 'Term continuation = local-aregs[' $Amin1 ] ; (wr nl) (decl-deref-args $Amin2) (mynumbervars $Clause 1 $NumbVars) (det-if-then-else (> $NumbVars 1) (declvars $NumbVars) True) (gets $Head $Strings) (puts $Body $Strings) 'mach.CUTB = mach.CurrentChoice ;' (wr nl) (nullifyaregs $Clause) 'return ' (bodycont $Clause $Name $Arity) ; (wr nl) } (wr nl) } (wr nl) (wr nl))))) -; - - - - (= - (nullifyaregs (= $H $B)) - ( (legacy-functor $H $_ $HA) - (legacy-functor $B $_ $BA) - (is $Diff - (- $HA $BA)) - (> $Diff 0) - (nullify $Diff $HA))) -; - - (= - (nullifyaregs $_) True) -; - - - - (= - (nullify 0 $_) - ( (set-det) - (write 'null ;') - (nl) - (fail))) -; - - (= - (nullify $N $K) - ( (is $L - (- $K 1)) - (writel (:: local-aregs[ $L ] = )) - (is $M - (- $N 1)) - (nullify $M $L))) -; - - - - (= - (mynumbervars $Var $I $O) - ( (var $Var) - (set-det) - (= $Var - ($VAR $I $_)) - (is $O - (+ $I 1)))) -; - - (= - (mynumbervars - ($VAR $_ $_) $I $O) - ( (set-det) (= $I $O))) -; - - (= - (mynumbervars $A $I $O) - ( (atomic $A) - (set-det) - (= $I $O))) -; - - (= - (mynumbervars $Term $I $O) - ( (=.. $Term - (Cons $_ $Args)) (mynumbervarslist $Args $I $O))) -; - +; it is binarized and also in reverse order - (= - (mynumbervarslist () $I $I) True) -; - - (= - (mynumbervarslist - (Cons $T $R) $I $O) - ( (mynumbervars $T $I $II) (mynumbervarslist $R $II $O))) -; - - - - - (= - (gets $Head $Strings) - ( (=.. $Head - (Cons $_ $Args)) (gets $Args 0 $Strings))) -; - - - (= - (gets - (:: $_) $_ $_) + (= (gencodeforpred $Package $Pred) + (= $Pred + (Cons + (= $H $_) $_)) + (legacy-functor $H $N $A) + (is $AA + (- $A 1)) + (makename + (:: pred- $N - $AA) $ClassName) + (makename + (:: $Package / $ClassName .java) $FileName) + (setof $F + (^ $Pred + (continuationof $Pred $F)) $Conts) + (setof $F + (^ $Pred + (stringof $Pred $F)) $AllStrings) + (mysetof $F + (^ $Pred + (intof $Pred $F)) $AllInts) + (= $Strings + (Cons cut $AllStrings)) + (tell $FileName) + (prelude $Pred) + (writel (:: 'class /* Pred */' $ClassName ' extends Code' (wr nl) { (wr nl) (declforeachclause $Pred 1 $ClassName) (declforeachcontinuation $Conts $N $A) (declforeachstring $Strings 0) (declforeachint $AllInts) 'public static Code entry-code = new ' $ClassName (); (wr nl) 'public void Init(Prolog mach)' (wr nl) { (initforeachcontinuation $Conts $N $A) } (wr nl) 'public int Arity() { return ' $AA ; } (wr nl) 'public Code Exec(Prolog mach)' (wr nl) '{ Term aregs[] = {' (aregarray $AA) } ; (wr nl) 'mach.CreateChoicePoint(aregs) ;' (wr nl) 'return cl1.Exec(mach) ;' (wr nl) } (wr nl) } (wr nl) (wr nl))) + (genpredcode $Pred last $ClassName $_ $Strings) + (told)) +; ;close(FileName) . + + + (= (mysetof $X $Y $Z) + (setof $X $Y $Z) (set-det)) -; - ; -; - - (= - (gets - (Cons $Arg $Args) $N $Strings) - ( (is $M - (+ $N 1)) - (getforarg $Arg $N $Strings) - (gets $Args $M $Strings))) -; - - - - (= - (getforarg $Arg $N $Strings) + (= (mysetof $_ $_ ()) True) + + + (= (genpredcode () $_ $_ 0 $_) True) + (= (genpredcode (Cons $Clause $Rest) $Last $ClassName $M $Strings) + (genpredcode $Rest notlast $ClassName $N $Strings) + (is $M + (+ $N 1)) + (genclausecode $Clause $Last $ClassName $M $Strings)) + + + (= (genclausecode $Clause $Last $ClassName $N $Strings) + (= $Clause + (= $Head $Body)) + (legacy-functor $Head $Name $Arity) + (is $Amin2 + (- $Arity 2)) + (is $Amin1 + (- $Arity 1)) + (arg $Arity $Head + ($cont $Arity)) + (writel (:: '/* helper */class ' $ClassName -- $N ' extends ' $ClassName (wr nl) { (wr nl) 'public Code Exec(Prolog mach)' (wr nl) { (det-if-then-else (= $Last last) (write 'mach.RemoveChoice() ;') (, (is $M (+ $N 1)) (writel (:: mach.FillAlternative(cl $M ) ;)))) (wr nl) 'Term local-aregs[] = mach.Areg ;' (wr nl) 'Term continuation = local-aregs[' $Amin1 ] ; (wr nl) (decl-deref-args $Amin2) (mynumbervars $Clause 1 $NumbVars) (det-if-then-else (> $NumbVars 1) (declvars $NumbVars) True) (gets $Head $Strings) (puts $Body $Strings) 'mach.CUTB = mach.CurrentChoice ;' (wr nl) (nullifyaregs $Clause) 'return ' (bodycont $Clause $Name $Arity) ; (wr nl) } (wr nl) } (wr nl) (wr nl)))) + + + (= (nullifyaregs (= $H $B)) + (legacy-functor $H $_ $HA) + (legacy-functor $B $_ $BA) + (is $Diff + (- $HA $BA)) + (> $Diff 0) + (nullify $Diff $HA)) + (= (nullifyaregs $_) True) + + + (= (nullify 0 $_) + (set-det) + (write 'null ;') + (nl) + (fail)) + (= (nullify $N $K) + (is $L + (- $K 1)) + (writel (:: local-aregs[ $L ] = )) + (is $M + (- $N 1)) + (nullify $M $L)) + + + (= (mynumbervars $Var $I $O) + (var $Var) + (set-det) + (= $Var + ($VAR $I $_)) + (is $O + (+ $I 1))) + (= (mynumbervars ($VAR $_ $_) $I $O) + (set-det) + (= $I $O)) + (= (mynumbervars $A $I $O) + (atomic $A) + (set-det) + (= $I $O)) + (= (mynumbervars $Term $I $O) + (=.. $Term + (Cons $_ $Args)) + (mynumbervarslist $Args $I $O)) + + + (= (mynumbervarslist () $I $I) True) + (= (mynumbervarslist (Cons $T $R) $I $O) + (mynumbervars $T $I $II) + (mynumbervarslist $R $II $O)) + + + + (= (gets $Head $Strings) + (=.. $Head + (Cons $_ $Args)) + (gets $Args 0 $Strings)) + + (= (gets (:: $_) $_ $_) + (set-det)) ; +; this is the continuation ! + (= (gets (Cons $Arg $Args) $N $Strings) + (is $M + (+ $N 1)) + (getforarg $Arg $N $Strings) + (gets $Args $M $Strings)) + + + (= (getforarg $Arg $N $Strings) (writel (:: 'if (!( (areg' $N ).Unify( (constructterm $Arg $Strings) '))) return Prolog.Fail0 ;' (wr nl)))) -; - - - - - (= - (puts - (cut $_ $C) $Strings) - ( (set-det) - (writel (:: 'mach.DoCut(mach.CUTB) ;' (wr nl))) - (putforarg $C 0 $Strings))) -; - (= - (puts $Body $Strings) - ( (=.. $Body - (Cons $_ $Args)) (puts $Args 0 $Strings))) -; - (= - (puts () $_ $_) True) -; + (= (puts (cut $_ $C) $Strings) + (set-det) + (writel (:: 'mach.DoCut(mach.CUTB) ;' (wr nl))) + (putforarg $C 0 $Strings)) + (= (puts $Body $Strings) + (=.. $Body + (Cons $_ $Args)) + (puts $Args 0 $Strings)) - (= - (puts - (Cons $Arg $Args) $N $Strings) - ( (is $M - (+ $N 1)) - (putforarg $Arg $N $Strings) - (puts $Args $M $Strings))) -; + (= (puts () $_ $_) True) + (= (puts (Cons $Arg $Args) $N $Strings) + (is $M + (+ $N 1)) + (putforarg $Arg $N $Strings) + (puts $Args $M $Strings)) - - (= - (putforarg $Arg $N $Strings) + (= (putforarg $Arg $N $Strings) (writel (:: local-aregs[ $N ] = (constructterm $Arg $Strings) ; (wr nl)))) -; - - (= - (declvars 1) + (= (declvars 1) (set-det)) -; - - (= - (declvars $N) - ( (is $M - (- $N 1)) - (writel (:: 'Term var' $M ' = Term.Var(mach) ;' (wr nl))) - (declvars $M))) -; - + (= (declvars $N) + (is $M + (- $N 1)) + (writel (:: 'Term var' $M ' = Term.Var(mach) ;' (wr nl))) + (declvars $M)) ; -; - +; variables are replaced with '$VAR'(integer,_) ; -; - - - - (= - (constructterm - ($cont $_) $_) - ( (set-det) (writel (:: continuation)))) -; - - (= - (constructterm - ($VAR $N $T) $_) - ( (set-det) (det-if-then-else (var $T) (, (writel (:: var $N)) (= $T 1)) (writel (:: var $N .Deref()))))) -; - - (= - (constructterm - (cut $_ $C) $Strings) - ( (set-det) - (getnameindex $Strings cut 0 $I) - (writel (:: Term.Compound(string $I ', new HeapChoice(mach.CUTB),' (constructterm $C $Strings) ))))) -; - - - (= - (constructterm $IntegerTerm $_) - ( (integer $IntegerTerm) - (set-det) - (posneg $IntegerTerm))) -; - - (= - (constructterm $Atom $Strings) - ( (atom $Atom) - (set-det) - (getnameindex $Strings $Atom 0 $I) - (writel (:: Const.Intern(string $I ))))) -; - - (= - (constructterm $Term $Strings) - ( (legacy-functor $Term $Name $_) - (=.. $Term - (Cons $_ $Args)) - (getnameindex $Strings $Name 0 $I) - (writel (:: Term.Compound(string $I , (newargs $Args 1 $Strings) ))))) -; - - - - (= - (newargs () $_ $_) True) -; - - (= - (newargs - (Cons $A $Args) $N $Strings) - ( (det-if-then-else - (> $N 1) - (write ,) True) - (is $M - (+ $N 1)) - (constructterm $A $Strings) - (newargs $Args $M $Strings))) -; - +; continuation is replaced by '$cont'(arity) + + + (= (constructterm ($cont $_) $_) + (set-det) + (writel (:: continuation))) + (= (constructterm ($VAR $N $T) $_) + (set-det) + (det-if-then-else + (var $T) + (, + (writel (:: var $N)) + (= $T 1)) + (writel (:: var $N .Deref())))) + (= (constructterm (cut $_ $C) $Strings) + (set-det) + (getnameindex $Strings cut 0 $I) + (writel (:: Term.Compound(string $I ', new HeapChoice(mach.CUTB),' (constructterm $C $Strings) )))) + + (= (constructterm $IntegerTerm $_) + (integer $IntegerTerm) + (set-det) + (posneg $IntegerTerm)) + (= (constructterm $Atom $Strings) + (atom $Atom) + (set-det) + (getnameindex $Strings $Atom 0 $I) + (writel (:: Const.Intern(string $I )))) + (= (constructterm $Term $Strings) + (legacy-functor $Term $Name $_) + (=.. $Term + (Cons $_ $Args)) + (getnameindex $Strings $Name 0 $I) + (writel (:: Term.Compound(string $I , (newargs $Args 1 $Strings) )))) + + + (= (newargs () $_ $_) True) + (= (newargs (Cons $A $Args) $N $Strings) + (det-if-then-else + (> $N 1) + (write ,) True) + (is $M + (+ $N 1)) + (constructterm $A $Strings) + (newargs $Args $M $Strings)) - (= - (bodycont - (= $_ $B) $Name $Arity) - ( (legacy-functor $B $Name $Arity) - (set-det) - (writel (:: entry-code)))) -; - - (= - (bodycont - (= $_ $B) $_ $_) - ( (legacy-functor $B call 1) - (set-det) - (writel (:: Prolog.Call1)))) -; - - (= - (bodycont - (= $_ $B) $_ $_) - ( (legacy-functor $B call 2) - (set-det) - (writel (:: Prolog.Call2)))) -; - - (= - (bodycont - (= $_ $B) $_ $_) - ( (legacy-functor $B cut 2) - (set-det) - (writel (:: Prolog.Call1)))) -; - - (= - (bodycont - (= $_ $B) $_ $_) - ( (legacy-functor $B $Name $Arity) (writel (:: $Name $Arity cont)))) -; + (= (bodycont (= $_ $B) $Name $Arity) + (legacy-functor $B $Name $Arity) + (set-det) + (writel (:: entry-code))) + (= (bodycont (= $_ $B) $_ $_) + (legacy-functor $B call 1) + (set-det) + (writel (:: Prolog.Call1))) + (= (bodycont (= $_ $B) $_ $_) + (legacy-functor $B call 2) + (set-det) + (writel (:: Prolog.Call2))) + (= (bodycont (= $_ $B) $_ $_) + (legacy-functor $B cut 2) + (set-det) + (writel (:: Prolog.Call1))) + (= (bodycont (= $_ $B) $_ $_) + (legacy-functor $B $Name $Arity) + (writel (:: $Name $Arity cont))) - - (= - (decl-deref-args -1) + (= (decl-deref-args -1) (set-det)) -; - - (= - (decl-deref-args $N) - ( (writel (:: 'Term areg' $N ' = local-aregs[' $N '].Deref() ;' (wr nl))) - (is $M - (- $N 1)) - (decl-deref-args $M))) -; - - - - - (= - (initforeachcontinuation () $_ $_) True) -; - - (= - (initforeachcontinuation - (Cons - (/ $N $A) $R) $N $A) - ( (set-det) (initforeachcontinuation $R $N $A))) -; - - (= - (initforeachcontinuation - (Cons - (/ call 1) $R) $N $A) - ( (set-det) (initforeachcontinuation $R $N $A))) -; - - (= - (initforeachcontinuation - (Cons - (/ call 2) $R) $N $A) - ( (set-det) (initforeachcontinuation $R $N $A))) -; - - (= - (initforeachcontinuation - (Cons - (/ cut 2) $R) $N $A) - ( (set-det) (initforeachcontinuation $R $N $A))) -; - - (= - (initforeachcontinuation - (Cons - (/ $N $A) $R) $Name $Arity) - ( (is $B - (- $A 1)) - (writel (:: $N $A 'cont = pred-' $N - $B '.entry-code ;' (wr nl))) - (initforeachcontinuation $R $Name $Arity))) -; - - (= - (initforeachcontinuation - (Cons - (/ $N $A) $R) $Name $Arity) - ( (is $B - (- $A 1)) - (writel (:: $N $A 'cont = mach.LoadPred("' $N ", $B ) ; (wr nl))) - (initforeachcontinuation $R $Name $Arity))) -; - - - - (= - (aregarray $N) + (= (decl-deref-args $N) + (writel (:: 'Term areg' $N ' = local-aregs[' $N '].Deref() ;' (wr nl))) + (is $M + (- $N 1)) + (decl-deref-args $M)) + + + + (= (initforeachcontinuation () $_ $_) True) + (= (initforeachcontinuation (Cons (/ $N $A) $R) $N $A) + (set-det) + (initforeachcontinuation $R $N $A)) +; ; this is entry code ! + (= (initforeachcontinuation (Cons (/ call 1) $R) $N $A) + (set-det) + (initforeachcontinuation $R $N $A)) +; ; Call1 + (= (initforeachcontinuation (Cons (/ call 2) $R) $N $A) + (set-det) + (initforeachcontinuation $R $N $A)) +; ; Call2 + (= (initforeachcontinuation (Cons (/ cut 2) $R) $N $A) + (set-det) + (initforeachcontinuation $R $N $A)) +; ; Cut2 + (= (initforeachcontinuation (Cons (/ $N $A) $R) $Name $Arity) + (is $B + (- $A 1)) + (writel (:: $N $A 'cont = pred-' $N - $B '.entry-code ;' (wr nl))) + (initforeachcontinuation $R $Name $Arity)) + (= (initforeachcontinuation (Cons (/ $N $A) $R) $Name $Arity) + (is $B + (- $A 1)) + (writel (:: $N $A 'cont = mach.LoadPred("' $N ", $B ) ; (wr nl))) + (initforeachcontinuation $R $Name $Arity)) + + + (= (aregarray $N) (aregarray 0 $N)) -; - - - (= - (aregarray $N $Max) - ( (> $N $Max) (set-det))) -; - - (= - (aregarray $N $Max) - ( (det-if-then-else - (> $N 0) - (write ,) True) - (is $M - (+ $N 1)) - (writel (:: mach.Areg[ $N ])) - (aregarray $M $Max))) -; - - - - (= - (declforeachclause () $_ $_) True) -; - - (= - (declforeachclause - (Cons $_ $R) $N $ClassName) - ( (writel (:: 'static Code cl' $N ' = new ' $ClassName -- $N () ; (wr nl))) - (is $M - (+ $N 1)) - (declforeachclause $R $M $ClassName))) -; - - - - - (= - (declforeachcontinuation () $_ $_) True) -; - - (= - (declforeachcontinuation - (Cons - (/ $N $A) $R) $N $A) - ( (set-det) (declforeachcontinuation $R $N $A))) -; - - (= - (declforeachcontinuation - (Cons - (/ call 1) $R) $N $A) - ( (set-det) (declforeachcontinuation $R $N $A))) -; - - (= - (declforeachcontinuation - (Cons - (/ call 2) $R) $N $A) - ( (set-det) (declforeachcontinuation $R $N $A))) -; - - (= - (declforeachcontinuation - (Cons - (/ $N $A) $R) $Name $Arity) - ( (writel (:: 'static Code ' $N $A 'cont ;' (wr nl))) (declforeachcontinuation $R $Name $Arity))) -; - - - (= - (declforeachstring () $_) True) -; - - (= - (declforeachstring - (Cons $N $R) $M) - ( (is $MM - (+ $M 1)) - (writel (:: 'static Const string' $M ' = Const.Intern("' $N ") ; (wr nl))) - (declforeachstring $R $MM))) -; - - - - (= - (declforeachint ()) True) -; - - (= - (declforeachint (Cons $N $R)) - ( (writel (:: 'static Int ' (posneg $N) ' = Term.Number(' $N ) ; (wr nl))) (declforeachint $R))) -; - - - - (= - (posneg $N) - ( (< $N 0) - (set-det) - (is $M - (- 0 $N)) - (writel (:: negint $M)))) -; - - (= - (posneg $N) + (= (aregarray $N $Max) + (> $N $Max) + (set-det)) + (= (aregarray $N $Max) + (det-if-then-else + (> $N 0) + (write ,) True) + (is $M + (+ $N 1)) + (writel (:: mach.Areg[ $N ])) + (aregarray $M $Max)) + + + (= (declforeachclause () $_ $_) True) + (= (declforeachclause (Cons $_ $R) $N $ClassName) + (writel (:: 'static Code cl' $N ' = new ' $ClassName -- $N () ; (wr nl))) + (is $M + (+ $N 1)) + (declforeachclause $R $M $ClassName)) + + + + (= (declforeachcontinuation () $_ $_) True) + (= (declforeachcontinuation (Cons (/ $N $A) $R) $N $A) + (set-det) + (declforeachcontinuation $R $N $A)) + (= (declforeachcontinuation (Cons (/ call 1) $R) $N $A) + (set-det) + (declforeachcontinuation $R $N $A)) + (= (declforeachcontinuation (Cons (/ call 2) $R) $N $A) + (set-det) + (declforeachcontinuation $R $N $A)) + (= (declforeachcontinuation (Cons (/ $N $A) $R) $Name $Arity) + (writel (:: 'static Code ' $N $A 'cont ;' (wr nl))) + (declforeachcontinuation $R $Name $Arity)) + + + (= (declforeachstring () $_) True) + (= (declforeachstring (Cons $N $R) $M) + (is $MM + (+ $M 1)) + (writel (:: 'static Const string' $M ' = Const.Intern("' $N ") ; (wr nl))) + (declforeachstring $R $MM)) + + + (= (declforeachint ()) True) + (= (declforeachint (Cons $N $R)) + (writel (:: 'static Int ' (posneg $N) ' = Term.Number(' $N ) ; (wr nl))) + (declforeachint $R)) + + + (= (posneg $N) + (< $N 0) + (set-det) + (is $M + (- 0 $N)) + (writel (:: negint $M))) + (= (posneg $N) (writel (:: posint $N))) -; - - (= - (getnameindex - (Cons $N $_) $N $In $In) + (= (getnameindex (Cons $N $_) $N $In $In) (set-det)) -; - - (= - (getnameindex - (Cons $_ $R) $N $In $Out) - ( (is $I - (+ $In 1)) - (getnameindex $R $N $I $Out) - (set-det))) -; - - (= - (getnameindex $_ $_ $In $In) True) -; - + (= (getnameindex (Cons $_ $R) $N $In $Out) + (is $I + (+ $In 1)) + (getnameindex $R $N $I $Out) + (set-det)) + (= (getnameindex $_ $_ $In $In) True) - (= - (continuationof - (Cons - (= $_ $B) $_) - (/ $N $A)) + (= (continuationof (Cons (= $_ $B) $_) (/ $N $A)) (legacy-functor $B $N $A)) -; - - (= - (continuationof - (Cons $_ $R) $F) + (= (continuationof (Cons $_ $R) $F) (continuationof $R $F)) -; - - (= - (stringof - (Cons $Cl $_) $F) + (= (stringof (Cons $Cl $_) $F) (strings1 $Cl $F)) -; - - (= - (stringof - (Cons $_ $R) $F) + (= (stringof (Cons $_ $R) $F) (stringof $R $F)) -; - - (= - (strings1 $X $_) - ( (var $X) - (set-det) - (fail))) -; - - (= - (strings1 - (, $A $_) $F) + (= (strings1 $X $_) + (var $X) + (set-det) + (fail)) + (= (strings1 (, $A $_) $F) (strings1 $A $F)) -; - - (= - (strings1 - (, $_ $B) $F) - ( (set-det) (strings1 $B $F))) -; - - (= - (strings1 - (= $A $_) $F) + (= (strings1 (, $_ $B) $F) + (set-det) + (strings1 $B $F)) + (= (strings1 (= $A $_) $F) (strings1 $A $F)) -; - - (= - (strings1 - (= $_ $B) $F) - ( (set-det) (strings1 $B $F))) -; - - (= - (strings1 $T $F) - ( (legacy-functor $T $N $_) (= $F $N))) -; - - (= - (strings1 $T $F) - ( (=.. $T - (Cons $_ $Args)) (stringsl $Args $F))) -; - - - - (= - (strings $X $_) - ( (var $X) - (set-det) - (fail))) -; - - (= - (strings $A $F) - ( (atom $A) - (set-det) - (= $F $A))) -; - - (= - (strings $A $_) - ( (atomic $A) - (set-det) - (fail))) -; - - (= - (strings $T $F) - ( (legacy-functor $T $N $_) (= $F $N))) -; - - (= - (strings $T $F) - ( (=.. $T - (Cons $_ $Args)) (stringsl $Args $F))) -; - - - - (= - (stringsl - (Cons $T $_) $F) + (= (strings1 (= $_ $B) $F) + (set-det) + (strings1 $B $F)) + (= (strings1 $T $F) + (legacy-functor $T $N $_) + (= $F $N)) + (= (strings1 $T $F) + (=.. $T + (Cons $_ $Args)) + (stringsl $Args $F)) + + + (= (strings $X $_) + (var $X) + (set-det) + (fail)) + (= (strings $A $F) + (atom $A) + (set-det) + (= $F $A)) + (= (strings $A $_) + (atomic $A) + (set-det) + (fail)) + (= (strings $T $F) + (legacy-functor $T $N $_) + (= $F $N)) + (= (strings $T $F) + (=.. $T + (Cons $_ $Args)) + (stringsl $Args $F)) + + + (= (stringsl (Cons $T $_) $F) (strings $T $F)) -; - - (= - (stringsl - (Cons $_ $R) $F) + (= (stringsl (Cons $_ $R) $F) (stringsl $R $F)) -; - - (= - (intof - (Cons $Cl $_) $F) + (= (intof (Cons $Cl $_) $F) (ints $Cl $F)) -; - - (= - (intof - (Cons $_ $R) $F) + (= (intof (Cons $_ $R) $F) (intof $R $F)) -; - - - - (= - (ints $X $_) - ( (var $X) - (set-det) - (fail))) -; - (= - (ints $A $F) - ( (integer $A) - (set-det) - (= $F $A))) -; - - (= - (ints $A $_) - ( (atomic $A) - (set-det) - (fail))) -; - - (= - (ints $T $F) - ( (=.. $T - (Cons $_ $Args)) (intof $Args $F))) -; + (= (ints $X $_) + (var $X) + (set-det) + (fail)) + (= (ints $A $F) + (integer $A) + (set-det) + (= $F $A)) + (= (ints $A $_) + (atomic $A) + (set-det) + (fail)) + (= (ints $T $F) + (=.. $T + (Cons $_ $Args)) + (intof $Args $F)) ; -; - +; the following are also in someMeTTa at the moment - (= - (specialgoal - (< $X $Y) - (smallerthan $X $Y)) + (= (specialgoal (< $X $Y) (smallerthan $X $Y)) (set-det)) -; - - (= - (specialgoal - (=< $X $Y) - (smallerorequal $X $Y)) + (= (specialgoal (=< $X $Y) (smallerorequal $X $Y)) (set-det)) -; - - (= - (specialgoal - (> $X $Y) - (smallerthan $Y $X)) + (= (specialgoal (> $X $Y) (smallerthan $Y $X)) (set-det)) -; - - (= - (specialgoal - (>= $X $Y) - (smallerorequal $Y $X)) + (= (specialgoal (>= $X $Y) (smallerorequal $Y $X)) (set-det)) -; - - (= - (specialgoal - (=:= $X $Y) - (arithequal $Y $X)) + (= (specialgoal (=:= $X $Y) (arithequal $Y $X)) (set-det)) -; - - (= - (specialgoal - (= $X $Y) - (unify $Y $X)) + (= (specialgoal (= $X $Y) (unify $Y $X)) (set-det)) -; - - (= - (specialgoal - (or $X $Y) - (or $X $Y)) + (= (specialgoal (or $X $Y) (or $X $Y)) (set-det)) -; - - (= - (specialgoal - (@< $X $Y) - (termsmallerthan $X $Y)) + (= (specialgoal (@< $X $Y) (termsmallerthan $X $Y)) (set-det)) -; - - (= - (specialgoal - (@> $X $Y) - (termgreaterthan $X $Y)) + (= (specialgoal (@> $X $Y) (termgreaterthan $X $Y)) (set-det)) -; - - (= - (specialgoal - (@=< $X $Y) - (termsmallerequal $X $Y)) + (= (specialgoal (@=< $X $Y) (termsmallerequal $X $Y)) (set-det)) -; - - (= - (specialgoal - (@>= $X $Y) - (termgreaterequal $X $Y)) + (= (specialgoal (@>= $X $Y) (termgreaterequal $X $Y)) (set-det)) -; - - (= - (specialgoal - (== $X $Y) - (termequal $X $Y)) + (= (specialgoal (== $X $Y) (termequal $X $Y)) (set-det)) -; - - (= - (specialgoal - (not $X) - (not $X)) + (= (specialgoal (not $X) (not $X)) (set-det)) -; - - (= - (w-cl (:: $Pred)) - ( (set-det) (format ~N~p.~n (:: $Pred)))) -; - - (= - (w-cl (Cons $Prev $Pred)) - ( (set-det) - (w-cl $Pred) - (w-cl $Prev))) -; - - (= - (w-cl $Pred) + (= (w-cl (:: $Pred)) + (set-det) + (format ~N~p.~n + (:: $Pred))) + (= (w-cl (Cons $Prev $Pred)) + (set-det) + (w-cl $Pred) + (w-cl $Prev)) + (= (w-cl $Pred) (w-cl (:: $Pred))) -; - - (= - (prelude $Pred) - ( (prelude) - (write + (= (prelude $Pred) + (prelude) + (write /* -) (w-cl $Pred) - (write +) + (w-cl $Pred) + (write */ -))) -; - - (= - (prelude) - ( (write '// Generated code file - by dmiles') - (nl) - (fail))) -; - - (= - (prelude) - ( (write '// Copyright August 16, 1996,2018 LOGICMOO, KUL and CUM') - (nl) - (fail))) -; - - (= - (prelude) - ( (write '// Authors: Douglas R. Miles, Bart Demoen and Paul Tarau +)) + (= (prelude) + (write '// Generated code file - by dmiles') + (nl) + (fail)) + (= (prelude) + (write '// Copyright August 16, 1996,2018 LOGICMOO, KUL and CUM') + (nl) + (fail)) + (= (prelude) + (write '// Authors: Douglas R. Miles, Bart Demoen and Paul Tarau import SxxMachine.*; -') (nl) - (nl) - (fail))) -; - - (= prelude True) -; - +') + (nl) + (nl) + (fail)) + (= prelude True) ; -; - +; main :- comp('board') , fail . ; -; - +; main :- comp('test') , fail . ; -; - +; main :- comp('read.pl') , fail . ; -; - +; main :- comp('someMeTTa') , fail . ; -; - +; main :- comp('chat') , fail . ; -; - +; main :- comp('boyer') , fail . !(comp sxx-library.pl) -; - !(comp tests/animal.pl) -; - diff --git a/sxx_machine/sxx_compiler_gen_static.metta b/sxx_machine/sxx_compiler_gen_static.metta index 5fd04ef..577ae48 100644 --- a/sxx_machine/sxx_compiler_gen_static.metta +++ b/sxx_machine/sxx_compiler_gen_static.metta @@ -1,502 +1,276 @@ +; (convert_to_metta_file sxx_compiler_gen_static $_343926 sxx_machine/sxx_compiler_gen_static.pl sxx_machine/sxx_compiler_gen_static.metta) - (= - (append () $L $L) True) -; - - (= - (append - (Cons $X $L1) $L2 - (Cons $X $L3)) + (= (append () $L $L) True) + (= (append (Cons $X $L1) $L2 (Cons $X $L3)) (append $L1 $L2 $L3)) -; - - - (= - (legacy-functor $P . $A) - ( (functor $P Cons $A) (set-det))) -; - - (= - (legacy-functor $P $F $A) - ( (functor $P $F $A) (set-det))) -; + (= (legacy-functor $P . $A) + (functor $P Cons $A) + (set-det)) + (= (legacy-functor $P $F $A) + (functor $P $F $A) + (set-det)) !(dynamic (/ system-predicate 1)) -; - !(multifile (/ system-predicate 1)) -; - ; -; - - - (= - (system_predicate - ($erase $_)) True) -; - - (= - (system_predicate - (%fast_write $_)) True) -; - - (= - (system_predicate - (%fast_write $_ $_)) True) -; - - (= - (system_predicate - ($call $_ $_)) True) -; - - (= - (system_predicate - (mutex_lock_bt $_)) True) -; - - (= - (system_predicate - (%set_exception $_)) True) -; - - (= - (system_predicate - (%get_exception $_)) True) -; - - (= - (system_predicate - (%get_current_B $_)) True) -; - - (= - (system_predicate - ($compare0 $_ $_ $_)) True) -; - - (= - (system_predicate - (%compiled_predicate $_ $_ $_)) True) -; - - (= - (system_predicate - (%compiled_predicate_or_builtin $_ $_ $_)) True) -; - - (= - (system_predicate - (%hash_remove_first $_ $_ $_)) True) -; - - (= - (system_predicate - (%hash_adda $_ $_ $_)) True) -; - - (= - (system_predicate - (%hash_addz $_ $_ $_)) True) -; - - (= - (system_predicate - (%read_token0 $_ $_ $_)) True) -; - - (= - (system_predicate - (%symbol_type0 $_ $_)) True) -; - - (= - (system_predicate - (%begin_sync $_ $_)) True) -; - +; system_predicate('$builtin_member'(_,_)). + + (= (system_predicate (%erase $_)) True) + (= (system_predicate (%fast_write $_)) True) + (= (system_predicate (%fast_write $_ $_)) True) + (= (system_predicate (%call $_ $_)) True) + (= (system_predicate (mutex_lock_bt $_)) True) + (= (system_predicate (%set_exception $_)) True) + (= (system_predicate (%get_exception $_)) True) + (= (system_predicate (%get_current_B $_)) True) + (= (system_predicate (%compare0 $_ $_ $_)) True) + (= (system_predicate (%compiled_predicate $_ $_ $_)) True) + (= (system_predicate (%compiled_predicate_or_builtin $_ $_ $_)) True) + (= (system_predicate (%hash_remove_first $_ $_ $_)) True) + (= (system_predicate (%hash_adda $_ $_ $_)) True) + (= (system_predicate (%hash_addz $_ $_ $_)) True) + (= (system_predicate (%read_token0 $_ $_ $_)) True) + (= (system_predicate (%symbol_type0 $_ $_)) True) + (= (system_predicate (%begin_sync $_ $_)) True) !(consult sxx-system) -; - - (= - (comp $FileSpec) + (= (comp $FileSpec) (comp-to $FileSpec ../jsrc/bootlib)) -; - - (= - (comp-to $FileSpec $Where) - ( (not (exists-file $FileSpec)) - (set-det) - (forall - (, - (absolute-file-name $FileSpec $File - (:: - (expand True) - (file-type prolog) - (solutions all))) - (exists-file $File)) - (comp-to $File $Where)))) -; - - (= - (comp-to $File $Dir0) - ( (must-det-l (, (makename (:: $Dir0 / SxxMachine) $Dir) (set-det) (exists-file $File) (file-base-name $File $Base) (file-name-extension $Stem $_ $Base) (makename (:: $Dir / $Stem .java) $FileName) (set-det) (wdmsg (comp-to $File $Dir $FileName)) (make-directory-path $Dir) (set-det) (nb-setval stem $Stem) (= $InProg Nil) (see $File) (readprogram $Stem $InProg $Prog) (set-det) (seen) (tell $FileName) (gencode-sss $Dir $Stem $Prog) (set-det) (told))) (set-det))) -; - + (= (comp-to $FileSpec $Where) + (not (exists-file $FileSpec)) + (set-det) + (forall + (, + (absolute-file-name $FileSpec $File + (:: + (expand True) + (file-type prolog) + (solutions all))) + (exists-file $File)) + (comp-to $File $Where))) + (= (comp-to $File $Dir0) + (must-det-l (, (makename (:: $Dir0 / SxxMachine) $Dir) (set-det) (exists-file $File) (file-base-name $File $Base) (file-name-extension $Stem $_ $Base) (makename (:: $Dir / $Stem .java) $FileName) (set-det) (wdmsg (comp-to $File $Dir $FileName)) (make-directory-path $Dir) (set-det) (nb-setval stem $Stem) (= $InProg Nil) (see $File) (readprogram $Stem $InProg $Prog) (set-det) (seen) (tell $FileName) (gencode-sss $Dir $Stem $Prog) (set-det) (told))) + (set-det)) +; ; close(File) , - (= - (call-local-side-efs (public $_)) + (= (call-local-side-efs (public $_)) (set-det)) -; - - (= - (call-local-side-efs (package $V)) + (= (call-local-side-efs (package $V)) (nb-setval package $V)) -; - - (= - (call-local-side-efs (if $_)) + (= (call-local-side-efs (if $_)) (set-det)) -; - - (= - (call-local-side-efs (determinate $_)) + (= (call-local-side-efs (determinate $_)) (set-det)) -; - - (= - (call-local-side-efs (comp $_)) + (= (call-local-side-efs (comp $_)) (set-det)) -; - - (= - (call-local-side-efs (comp-to $_ $_)) + (= (call-local-side-efs (comp-to $_ $_)) (set-det)) -; - - (= - (call-local-side-efs $Call) + (= (call-local-side-efs $Call) (ignore (call $Call))) -; - - (= - (local-side-efs $_ - !(if $_)) - ( (repeat) - (read $Until) - (== $Until - !(endif)) - (set-det))) -; - - (= + (= (local-side-efs $_ !(if $_)) + (repeat) + (read $Until) + (== $Until + !(endif)) + (set-det)) + (= (local-side-efs $_ !$Call) + (call-local-side-efs $Call) + (set-det)) + (= (local-side-efs $_ $H) + (\= $H + (= $_ $_)) + (set-det) (local-side-efs $_ - !$Call) - ( (call-local-side-efs $Call) (set-det))) -; - - (= - (local-side-efs $_ $H) - ( (\= $H - (= $_ $_)) - (set-det) - (local-side-efs $_ - (= $H True)))) -; - + (= $H True))) ; -; - +; local_side_efs(_, (H:-_)):- ( predicate_property(H,static) ; predicate_property(H,built_in) ),!. ; -; - - (= - (local_side_efs $_ $Clause) True) -; - +; local_side_efs(_, (Call)):- call(assertz(Call)),!. + (= (local_side_efs $_ $Clause) True) - (= - (readprogram $Stem $In $Out) - ( (read $Clause) - (local-side-efs $Stem $Clause) - (det-if-then-else - (= $Clause end-of-file) - (= $In $Out) - (, - (binarize $Clause $BinCl) - (addclausetoprogram $BinCl $In $NewIn) - (readprogram $Stem $NewIn $Out))))) -; - + (= (readprogram $Stem $In $Out) + (read $Clause) + (local-side-efs $Stem $Clause) + (det-if-then-else + (= $Clause end-of-file) + (= $In $Out) + (, + (binarize $Clause $BinCl) + (addclausetoprogram $BinCl $In $NewIn) + (readprogram $Stem $NewIn $Out)))) ; -; - +; binarize((Head ::- Body),Cl) :- ! , Cl = (Head :- Body) . - (= - (binarize - !$C $Out) - ( (nb-current stem $Stem) - (atom-concat on-load- $Stem $Pred) - (set-det) - (binarize - (= $Pred - (write $C)) $Out))) -; - - (= + (= (binarize !$C $Out) + (nb-current stem $Stem) + (atom-concat on-load- $Stem $Pred) + (set-det) (binarize - !$C $Out) - ( (nb-current stem $Stem) - (atom-concat on-load- $Stem $Pred) - (set-det) - (binarize - (= $Pred $C) $Out))) -; - - (= + (= $Pred + (write $C)) $Out)) + (= (binarize !$C $Out) + (nb-current stem $Stem) + (atom-concat on-load- $Stem $Pred) + (set-det) (binarize - (= $Head $Body) - (= $BinHead $BinBody)) - ( (set-det) - (addcont $Head $Continuation $BinHead) - (makebinbody $Body $Continuation $BinBody))) -; - - (= - (binarize $Head - (= $BinHead - (call $Continuation))) + (= $Pred $C) $Out)) + (= (binarize (= $Head $Body) (= $BinHead $BinBody)) + (set-det) + (addcont $Head $Continuation $BinHead) + (makebinbody $Body $Continuation $BinBody)) + (= (binarize $Head (= $BinHead + (call $Continuation))) (addcont $Head $Continuation $BinHead)) -; - - - - (= - (makebinbody $G $C $NewBody) - ( (var $G) - (set-det) - (makebinbody - (call $G) $C $NewBody))) -; - (= + (= (makebinbody $G $C $NewBody) + (var $G) + (set-det) (makebinbody - (, $G $B) $C $NewBody) - ( (set-det) - (makebinbody $B $C $NewB) - (addcont $G $NewB $NewBody))) -; - - (= - (makebinbody $SpecialGoal $C $NewBody) - ( (specialgoal $SpecialGoal $G) - (set-det) - (addcont $G $C $NewBody))) -; - - (= - (makebinbody - (set-det) $C $NewBody) - ( (set-det) (= $NewBody (cut 1 $C)))) -; - - (= - (makebinbody $G $C $NewBody) - ( (set-det) (addcont $G $C $NewBody))) -; - - - - (= - (addclausetoprogram $Cl Nil $ProgOut) - ( (set-det) (= $ProgOut (:: (:: $Cl))))) -; - - (= - (addclausetoprogram $Cl - (Cons $Pred $Rest) $Out) - ( (samepred $Cl $Pred) - (set-det) - (= $Out - (Cons - (Cons $Cl $Pred) $Rest)))) -; - - (= - (addclausetoprogram $Cl - (Cons $Pred $Rest) - (Cons $Pred $NewRest)) - (addclausetoprogram $Cl $Rest $NewRest)) -; - - - - - (= - (samepred - (= $H1 $_) + (call $G) $C $NewBody)) + + (= (makebinbody (, $G $B) $C $NewBody) + (set-det) + (makebinbody $B $C $NewB) + (addcont $G $NewB $NewBody)) + (= (makebinbody $SpecialGoal $C $NewBody) + (specialgoal $SpecialGoal $G) + (set-det) + (addcont $G $C $NewBody)) + (= (makebinbody (set-det) $C $NewBody) + (set-det) + (= $NewBody + (cut 1 $C))) + (= (makebinbody $G $C $NewBody) + (set-det) + (addcont $G $C $NewBody)) + + + (= (addclausetoprogram $Cl Nil $ProgOut) + (set-det) + (= $ProgOut + (:: (:: $Cl)))) + (= (addclausetoprogram $Cl (Cons $Pred $Rest) $Out) + (samepred $Cl $Pred) + (set-det) + (= $Out (Cons - (= $H2 $_) $_)) - ( (legacy-functor $H1 $N $A) (legacy-functor $H2 $N $A))) -; - - - - - - + (Cons $Cl $Pred) $Rest))) + (= (addclausetoprogram $Cl (Cons $Pred $Rest) (Cons $Pred $NewRest)) + (addclausetoprogram $Cl $Rest $NewRest)) - (= - (addcont - (set-det) $C $FB) - ( (set-det) (= $FB (cut 1 $C)))) -; - (= - (addcont $S $C $NG) - ( (specialgoal $S $NS) - (set-det) - (addcont $NS $C $NG))) -; - (= - (addcont $F $C $FB) - ( (=.. $F - (Cons $N $A)) - (append $A - (:: $C) $NA) - (=.. $FB - (Cons $N $NA)))) -; + (= (samepred (= $H1 $_) (Cons (= $H2 $_) $_)) + (legacy-functor $H1 $N $A) + (legacy-functor $H2 $N $A)) - (= - (makename $EOL $Out) - ( (== $EOL Nil) - (set-det) - (= $Out ''))) -; - (= - (makename $Atom $Out) - ( (atomic $Atom) - (set-det) - (= $Out $Atom))) -; - (= - (makename - (Cons $AC $Rest) $OutC) - ( (makename $Rest $OC) - (name $OC $OL) - (name $AC $AL) - (append $AL $OL $OutL) - (name $OutC $OutL))) -; + (= (addcont (set-det) $C $FB) + (set-det) + (= $FB + (cut 1 $C))) + (= (addcont $S $C $NG) + (specialgoal $S $NS) + (set-det) + (addcont $NS $C $NG)) + (= (addcont $F $C $FB) + (=.. $F + (Cons $N $A)) + (append $A + (:: $C) $NA) + (=.. $FB + (Cons $N $NA))) - (= - (writel ()) True) -; + (= (makename $EOL $Out) + (== $EOL Nil) + (set-det) + (= $Out '')) + (= (makename $Atom $Out) + (atomic $Atom) + (set-det) + (= $Out $Atom)) + (= (makename (Cons $AC $Rest) $OutC) + (makename $Rest $OC) + (name $OC $OL) + (name $AC $AL) + (append $AL $OL $OutL) + (name $OutC $OutL)) - (= - (writel (Cons $X $R)) - ( (wr $X) (writel $R))) -; + (= (writel ()) True) + (= (writel (Cons $X $R)) + (wr $X) + (writel $R)) - (= - (wr (getval $Var)) + (= (wr (getval $Var)) (must (, (nb-current $Var $Value) (write $Value)))) -; - - (= - (wr (wr nl)) - ( (set-det) (nl))) -; - - (= - (wr $Atom) - ( (atomic $Atom) - (set-det) - (write $Atom))) -; - - (= - (wr $VAR) - ( (legacy-functor $VAR %VAR 2) - (set-det) - (write $VAR))) -; - - (= - (wr $Goal) - ( (must (call $Goal)) (set-det))) -; - + (= (wr (wr nl)) + (set-det) + (nl)) + (= (wr $Atom) + (atomic $Atom) + (set-det) + (write $Atom)) + (= (wr $VAR) + (legacy-functor $VAR %VAR 2) + (set-det) + (write $VAR)) + (= (wr $Goal) + (must (call $Goal)) + (set-det)) - (= - (wrargs $N $T) + (= (wrargs $N $T) (wrargs $N $T $_)) -; - - - (= - (wrargs $N $_ $_) - ( (= $N 0) (set-det))) -; - - (= - (wrargs $N $T $Komma) - ( (det-if-then-else - (var $Komma) - (= $Komma yes) - (write ,)) - (writel (:: $T a $N)) - (is $M - (- $N 1)) - (wrargs $M $T $Komma))) -; + (= (wrargs $N $_ $_) + (= $N 0) + (set-det)) + (= (wrargs $N $T $Komma) + (det-if-then-else + (var $Komma) + (= $Komma yes) + (write ,)) + (writel (:: $T a $N)) + (is $M + (- $N 1)) + (wrargs $M $T $Komma)) ; -; - +; Pred is a list of clauses for a specific predicate ; -; - +; it is binarized and also in reverse order - (= - (gencode-sss $Dir $Stem $Preds) + (= (gencode-sss $Dir $Stem $Preds) (must-det-l (, (mysetof $F (^ $Preds (stringof $Preds $F)) $AllStrings) (mysetof $F (^ $Preds (intof $Preds $F)) $AllInts) (= $Strings (Cons cut $AllStrings)) (writel (:: 'package SxxMachine; import SxxMachine.*; import SxxMachine.Builtins.*; @@ -512,479 +286,319 @@ public class ' $Stem ' /*extends CodeFile*/ { ))))) -; - - (= - (gencode_sss $_ $_ $_ ()) True) -; - - (= - (gencode-sss $Strings $Dir $Stem - (Cons $Pred $Preds)) - ( (gencodeforpred $Strings $Dir $Stem $Pred) (gencode-sss $Strings $Dir $Stem $Preds))) -; - + (= (gencode_sss $_ $_ $_ ()) True) + (= (gencode-sss $Strings $Dir $Stem (Cons $Pred $Preds)) + (gencodeforpred $Strings $Dir $Stem $Pred) + (gencode-sss $Strings $Dir $Stem $Preds)) - (= - (gencodeforpred $Strings $Dir $Stem $Pred) + (= (gencodeforpred $Strings $Dir $Stem $Pred) ( (= $Pred - (:: (= $H $B))) + (:: (= $H $B))) (== $H $B) - (add-symbol &self + (add-is-symbol &self (system_predicate $H)) (set-det) (format '~N/* System pred ~q */~n' (:: $H)))) -; - - - (= - (gencodeforpred $Strings $Dir $Stem $Pred) - ( (= $Pred - (Cons - (= $H $_) $_)) - (legacy-functor $H $PN $A) - (is $AA - (- $A 1)) - (make-classname $PN $AA $N $ClassName) - (nb-setval classname $ClassName) - (gencodeforpred $Strings $Dir $Stem $Pred $H $N $A $AA $ClassName))) -; + (= (gencodeforpred $Strings $Dir $Stem $Pred) + (= $Pred + (Cons + (= $H $_) $_)) + (legacy-functor $H $PN $A) + (is $AA + (- $A 1)) + (make-classname $PN $AA $N $ClassName) + (nb-setval classname $ClassName) + (gencodeforpred $Strings $Dir $Stem $Pred $H $N $A $AA $ClassName)) ; -; - - +; (isSort(X),isSort(Y))-> (all Q hasSort(Q,X) - (= - (symbol-to-name $Atom $Out) - ( (symbol-to-name1 $Atom $Out) (set-det))) -; - - (= - (symbol_to_name $Name $Name) True) -; + (= (symbol-to-name $Atom $Out) + (symbol-to-name1 $Atom $Out) + (set-det)) + (= (symbol_to_name $Name $Name) True) - (= - (symbol-to-name1 or or) + (= (symbol-to-name1 or or) (set-det)) -; - - (= - (symbol-to-name1 : module-colon) +; /* symbol_to_name1((':-'),'system_neck'). symbol_to_name1(('=..'),'system_univ'). symbol_to_name1(('=@='),'system_variant'). symbol_to_name1(('\\+'),'system_not'). symbol_to_name1(('\\='),'system_notequals'). symbol_to_name1(('='),'system_equals'). symbol_to_name1(('=='),'strict_eq'). symbol_to_name1(('\\=='),'strict_noteq'). symbol_to_name1(('-->'),'dcg_arrow'). symbol_to_name1(('->'),'if_then_arrow'). symbol_to_name1(('*->'),'with_each_arrow'). symbol_to_name1((','),'system_comma'). symbol_to_name1(('^'),'system_carrot'). symbol_to_name1(('|'),'system_bar'). symbol_to_name1((':'),'system_colon'). */ + (= (symbol-to-name1 : module-colon) + (set-det)) + (= (symbol-to-name1 $S $O) + (functor $P $S 2) + (specialgoal $P $PP) + (functor $PP $O $_) + (set-det)) + (= (symbol-to-name1 $S $O) + (functor $P $S 1) + (specialgoal $P $PP) + (functor $PP $O $_) + (set-det)) + (= (symbol-to-name1 $A $B) + (symbol-to-name2 $A $B) (set-det)) -; - - (= - (symbol-to-name1 $S $O) - ( (functor $P $S 2) - (specialgoal $P $PP) - (functor $PP $O $_) - (set-det))) -; - - (= - (symbol-to-name1 $S $O) - ( (functor $P $S 1) - (specialgoal $P $PP) - (functor $PP $O $_) - (set-det))) -; - - (= - (symbol-to-name1 $A $B) - ( (symbol-to-name2 $A $B) (set-det))) -; - - (= - (symbol-to-name2 '' '') + (= (symbol-to-name2 '' '') (set-det)) -; - - (= - (symbol-to-name2 $Atom $Out) - ( (name $Atom - (Cons 36 + (= (symbol-to-name2 $Atom $Out) + (name $Atom + (Cons 36 + (Cons 48 (Cons 48 - (Cons 48 - (Cons $A - (Cons $B $Rest)))))) - (name $Mid1 - (:: 36 48 48 $A $B)) - (set-det) - (name $NAtom $Rest) - (symbol-to-name2 $NAtom $Mid2) - (atom-concat $Mid1 $Mid2 $Out))) -; - - - (= - (symbol-to-name2 $Atom $Out) - ( (name $Atom - (Cons $C $Rest)) - (not (code-type $C alnum)) - (\== $C 95) - (set-det) - (format - (atom $Mid1) %~|~`0t~16R~4+ - (:: $C)) - (name $NAtom $Rest) - (symbol-to-name2 $NAtom $Mid2) - (atom-concat $Mid1 $Mid2 $Out))) -; - - - (= - (symbol-to-name2 $Atom $Out) - ( (name $Atom - (Cons $C $Rest)) - (name $Mid1 - (:: $C)) - (name $NAtom $Rest) - (symbol-to-name2 $NAtom $Mid2) - (atom-concat $Mid1 $Mid2 $Out))) -; - + (Cons $A + (Cons $B $Rest)))))) + (name $Mid1 + (:: 36 48 48 $A $B)) + (set-det) + (name $NAtom $Rest) + (symbol-to-name2 $NAtom $Mid2) + (atom-concat $Mid1 $Mid2 $Out)) + + (= (symbol-to-name2 $Atom $Out) + (name $Atom + (Cons $C $Rest)) + (not (code-type $C alnum)) + (\== $C 95) + (set-det) + (format + (atom $Mid1) %~|~`0t~16R~4+ + (:: $C)) + (name $NAtom $Rest) + (symbol-to-name2 $NAtom $Mid2) + (atom-concat $Mid1 $Mid2 $Out)) + + (= (symbol-to-name2 $Atom $Out) + (name $Atom + (Cons $C $Rest)) + (name $Mid1 + (:: $C)) + (name $NAtom $Rest) + (symbol-to-name2 $NAtom $Mid2) + (atom-concat $Mid1 $Mid2 $Out)) - (= - (make-classname $Sym $AA $NN $ClassName) + (= (make-classname $Sym $AA $NN $ClassName) (det-if-then (symbol-to-name $Sym $N) (, (\== $Sym $N) (set-det) (make-classname $N $AA $NN $ClassName)))) -; - - (= - (make-classname $N $AA $N $ClassName) - ( (makename - (:: pred- $N - $AA) $ClassName) (set-det))) -; - + (= (make-classname $N $AA $N $ClassName) + (makename + (:: pred- $N - $AA) $ClassName) + (set-det)) - (= - (gencodeforpred $Strings $Dir $PINF $Pred $H $N $A $AA $ClassName) + (= (gencodeforpred $Strings $Dir $PINF $Pred $H $N $A $AA $ClassName) (must-det-l (, (writel (:: 'public static class ' $ClassName ' extends Code { ')) (prelude $Pred) (writel (:: (wr nl) 'public Operation Exec(Prolog mach) {return exec-static(mach); }' (wr nl) 'public static Operation exec-static(Prolog mach){ ' (wr nl) '/* Term aregs[] = {' (aregarray $AA) } ;*/ (wr nl) 'Term aregs[] = mach.RegPull(' $AA ); (wr nl) 'mach.CreateChoicePoint(aregs) ;' (wr nl) 'return (Operation)exec-' $ClassName '--1(mach); }' (wr nl))) (set-det) (genpredcode $Strings $Pred last $ClassName $_ $Strings) (writel (:: } ))))) -; - +; ;mysetof(F,Pred^continuationof(Pred,F),Conts) , +; ; declforeachcontinuation(Conts,N,A), +; ;declforeachclause(Pred,1,ClassName), +; ; writel(['static {', initforeachcontinuation(Conts,N,A),'}',wr(nl)]), - (= - (cont-ref $N) + (= (cont-ref $N) (must-det (writel (:: (getval classname) ::exec- (getval classname) -- $N)))) -; - - - - (= - (mysetof $X $Y $Z) - ( (setof $X $Y $Z) (set-det))) -; - - (= - (mysetof $_ $_ ()) True) -; - - - - (= - (genpredcode $PreDecl () $_ $_ 0 $_) True) -; - - (= - (genpredcode $Strings - (Cons $Clause $Rest) $Last $ClassName $M $Strings) - ( (genpredcode $Strings $Rest notlast $ClassName $N $Strings) - (is $M - (+ $N 1)) - (genclausecode $Strings $Clause $Last $ClassName $M $Strings))) -; - - - - (= - (genclausecode $PreDecl $Clause $Last $ClassName $N $Strings) - ( (= $Clause - (= $Head $Body)) - (set-det) - (must-det-l (, (legacy-functor $Head $Name0 $Arity) (symbol-to-name $Name0 $Name) (is $Amin2 (- $Arity 2)) (is $Amin1 (- $Arity 1)) (arg $Arity $Head ($cont $Arity)) (writel (:: 'public static Operation exec-' $ClassName -- $N '(Prolog mach){ ' (det-if-then-else (= $Last last) (write 'mach.RemoveChoice() ;') (, (is $M (+ $N 1)) (writel (:: mach.FillAlternative( (cont-ref $M) ) ;)))) (wr nl) 'Term local-aregs[] = mach.Areg ;' (wr nl) 'Term continuation = local-aregs[' $Amin1 ] ; (wr nl) (decl-deref-args $Amin2) (mynumbervars $Clause 1 $NumbVars) (det-if-then-else (> $NumbVars 1) (declvars $NumbVars) True) (gets $Head $Strings) (puts $Body $Strings) 'mach.CUTB = mach.CurrentChoice ;' (wr nl) (nullifyaregs $Clause) 'return ' (bodycont $Strings $Clause $Name $Arity) ;} (wr nl))))))) -; - - - - - (= - (nullifyaregs (= $H $B)) - ( (legacy-functor $H $_ $HA) - (legacy-functor $B $_ $BA) - (is $Diff - (- $HA $BA)) - (> $Diff 0) - (nullify $Diff $HA))) -; - - (= - (nullifyaregs $_) True) -; - - (= - (nullify 0 $_) - ( (set-det) - (write 'null ;') - (nl) - (fail))) -; - - (= - (nullify $N $K) - ( (is $L - (- $K 1)) - (writel (:: local-aregs[ $L ] = )) - (is $M - (- $N 1)) - (nullify $M $L))) -; - - - - (= - (mynumbervars $Var $I $O) - ( (var $Var) - (set-det) - (= $Var - ($VAR $I $_)) - (is $O - (+ $I 1)))) -; - - (= - (mynumbervars - ($VAR $_ $_) $I $O) - ( (set-det) (= $I $O))) -; - - (= - (mynumbervars $A $I $O) - ( (atomic $A) - (set-det) - (= $I $O))) -; - - (= - (mynumbervars $Term $I $O) - ( (=.. $Term - (Cons $_ $Args)) (mynumbervarslist $Args $I $O))) -; - - - - (= - (mynumbervarslist () $I $I) True) -; - - (= - (mynumbervarslist - (Cons $T $R) $I $O) - ( (mynumbervars $T $I $II) (mynumbervarslist $R $II $O))) -; - - - - - (= - (gets $Head $Strings) - ( (=.. $Head - (Cons $_ $Args)) (gets $Args 0 $Strings))) -; - - - (= - (gets - (:: $_) $_ $_) + (= (mysetof $X $Y $Z) + (setof $X $Y $Z) (set-det)) -; - ; -; - - (= - (gets - (Cons $Arg $Args) $N $Strings) - ( (is $M - (+ $N 1)) - (getforarg $Arg $N $Strings) - (gets $Args $M $Strings))) -; - - - - (= - (getforarg $Arg $N $Strings) + (= (mysetof $_ $_ ()) True) + + + (= (genpredcode $PreDecl () $_ $_ 0 $_) True) + (= (genpredcode $Strings (Cons $Clause $Rest) $Last $ClassName $M $Strings) + (genpredcode $Strings $Rest notlast $ClassName $N $Strings) + (is $M + (+ $N 1)) + (genclausecode $Strings $Clause $Last $ClassName $M $Strings)) + + + (= (genclausecode $PreDecl $Clause $Last $ClassName $N $Strings) + (= $Clause + (= $Head $Body)) + (set-det) + (must-det-l (, (legacy-functor $Head $Name0 $Arity) (symbol-to-name $Name0 $Name) (is $Amin2 (- $Arity 2)) (is $Amin1 (- $Arity 1)) (arg $Arity $Head ($cont $Arity)) (writel (:: 'public static Operation exec-' $ClassName -- $N '(Prolog mach){ ' (det-if-then-else (= $Last last) (write 'mach.RemoveChoice() ;') (, (is $M (+ $N 1)) (writel (:: mach.FillAlternative( (cont-ref $M) ) ;)))) (wr nl) 'Term local-aregs[] = mach.Areg ;' (wr nl) 'Term continuation = local-aregs[' $Amin1 ] ; (wr nl) (decl-deref-args $Amin2) (mynumbervars $Clause 1 $NumbVars) (det-if-then-else (> $NumbVars 1) (declvars $NumbVars) True) (gets $Head $Strings) (puts $Body $Strings) 'mach.CUTB = mach.CurrentChoice ;' (wr nl) (nullifyaregs $Clause) 'return ' (bodycont $Strings $Clause $Name $Arity) ;} (wr nl)))))) + + + + (= (nullifyaregs (= $H $B)) + (legacy-functor $H $_ $HA) + (legacy-functor $B $_ $BA) + (is $Diff + (- $HA $BA)) + (> $Diff 0) + (nullify $Diff $HA)) + (= (nullifyaregs $_) True) + + + (= (nullify 0 $_) + (set-det) + (write 'null ;') + (nl) + (fail)) + (= (nullify $N $K) + (is $L + (- $K 1)) + (writel (:: local-aregs[ $L ] = )) + (is $M + (- $N 1)) + (nullify $M $L)) + + + (= (mynumbervars $Var $I $O) + (var $Var) + (set-det) + (= $Var + ($VAR $I $_)) + (is $O + (+ $I 1))) + (= (mynumbervars ($VAR $_ $_) $I $O) + (set-det) + (= $I $O)) + (= (mynumbervars $A $I $O) + (atomic $A) + (set-det) + (= $I $O)) + (= (mynumbervars $Term $I $O) + (=.. $Term + (Cons $_ $Args)) + (mynumbervarslist $Args $I $O)) + + + (= (mynumbervarslist () $I $I) True) + (= (mynumbervarslist (Cons $T $R) $I $O) + (mynumbervars $T $I $II) + (mynumbervarslist $R $II $O)) + + + + (= (gets $Head $Strings) + (=.. $Head + (Cons $_ $Args)) + (gets $Args 0 $Strings)) + + (= (gets (:: $_) $_ $_) + (set-det)) ; +; this is the continuation ! + (= (gets (Cons $Arg $Args) $N $Strings) + (is $M + (+ $N 1)) + (getforarg $Arg $N $Strings) + (gets $Args $M $Strings)) + + + (= (getforarg $Arg $N $Strings) (writel (:: 'if (!( (areg' $N ).Unify( (constructterm $Arg $Strings) ',mach))) return Prolog.Fail0 ;' (wr nl)))) -; - - - (= - (puts - (cut $_ $C) $Strings) - ( (set-det) - (writel (:: 'mach.DoCut(mach.CUTB) ;' (wr nl))) - (putforarg $C 0 $Strings))) -; - (= - (puts $Body $Strings) - ( (=.. $Body - (Cons $_ $Args)) (puts $Args 0 $Strings))) -; + (= (puts (cut $_ $C) $Strings) + (set-det) + (writel (:: 'mach.DoCut(mach.CUTB) ;' (wr nl))) + (putforarg $C 0 $Strings)) + (= (puts $Body $Strings) + (=.. $Body + (Cons $_ $Args)) + (puts $Args 0 $Strings)) + (= (puts () $_ $_) True) + (= (puts (Cons $Arg $Args) $N $Strings) + (is $M + (+ $N 1)) + (putforarg $Arg $N $Strings) + (puts $Args $M $Strings)) - (= - (puts () $_ $_) True) -; - (= - (puts - (Cons $Arg $Args) $N $Strings) - ( (is $M - (+ $N 1)) - (putforarg $Arg $N $Strings) - (puts $Args $M $Strings))) -; - - - - (= - (putforarg $Arg $N $Strings) + (= (putforarg $Arg $N $Strings) (writel (:: local-aregs[ $N ] = (constructterm $Arg $Strings) ; (wr nl)))) -; - - (= - (declvars 1) + (= (declvars 1) (set-det)) -; - - (= - (declvars $N) - ( (is $M - (- $N 1)) - (writel (:: 'Var var' $M ' = Data.V(mach) ;' (wr nl))) - (declvars $M))) -; - + (= (declvars $N) + (is $M + (- $N 1)) + (writel (:: 'Var var' $M ' = Data.V(mach) ;' (wr nl))) + (declvars $M)) ; -; - +; variables are replaced with '$VAR'(integer,_) ; -; - - +; continuation is replaced by '$cont'(arity) - (= - (constructterm - ($cont $_) $_) - ( (set-det) (writel (:: continuation)))) -; - - (= - (constructterm - ($VAR $N $T) $_) - ( (set-det) (det-if-then-else (var $T) (, (writel (:: var $N)) (= $T 1)) (writel (:: var $N .Deref()))))) -; + (= (constructterm ($cont $_) $_) + (set-det) + (writel (:: continuation))) + (= (constructterm ($VAR $N $T) $_) + (set-det) + (det-if-then-else + (var $T) + (, + (writel (:: var $N)) + (= $T 1)) + (writel (:: var $N .Deref())))) ; -; - - (= - (constructterm - (cut $_ $C) $Strings) - ( (set-det) (writel (:: mach.HC( (constructterm $C $Strings) ))))) -; - - - (= - (constructterm $Int $_) - ( (integer $Int) - (set-det) - (writel (:: (getval stem) .)) - (posneg $Int))) -; - - (= - (constructterm $Atom $Strings) - ( (string $Atom) - (set-det) - (writeConst $Atom $Strings))) -; - - (= - (constructterm $Int $_) - ( (float $Int) - (set-det) - (writel (:: Data.Float( $Int ))) - (set-det))) -; - - - (= - (constructterm $Atom $Strings) - ( (== Nil $Atom) - (set-det) - (writeConst $Atom $Strings))) -; - - (= - (constructterm $Atom $Strings) - ( (atom $Atom) - (set-det) - (writeConst $Atom $Strings))) -; - - (= - (constructterm $Term $Strings) - ( (compound $Term) - (set-det) - (must-det-l (, (legacy-functor $Term $Name $_) (=.. $Term (Cons $_ $Args)) (writel (:: Data.F( (writeConst $Name $Strings) , (newargs $Args 1 $Strings) ))))))) -; - - - - (= - (writeConst Nil $Strings) - ( (writel (:: Const.Nil)) (set-det))) -; +; constructterm(cut(_,C),Strings) :- ! , writel(['Data.F("cut",new HeapChoice(mach.CUTB),',constructterm(C,Strings),')']) . + (= (constructterm (cut $_ $C) $Strings) + (set-det) + (writel (:: mach.HC( (constructterm $C $Strings) )))) + + (= (constructterm $Int $_) + (integer $Int) + (set-det) + (writel (:: (getval stem) .)) + (posneg $Int)) + (= (constructterm $Atom $Strings) + (string $Atom) + (set-det) + (writeConst $Atom $Strings)) + (= (constructterm $Int $_) + (float $Int) + (set-det) + (writel (:: Data.Float( $Int ))) + (set-det)) - (= - (writeConst $Name $Strings) + (= (constructterm $Atom $Strings) + (== Nil $Atom) + (set-det) + (writeConst $Atom $Strings)) + (= (constructterm $Atom $Strings) + (atom $Atom) + (set-det) + (writeConst $Atom $Strings)) + (= (constructterm $Term $Strings) + (compound $Term) + (set-det) + (must-det-l (, (legacy-functor $Term $Name $_) (=.. $Term (Cons $_ $Args)) (writel (:: Data.F( (writeConst $Name $Strings) , (newargs $Args 1 $Strings) )))))) + + + (= (writeConst Nil $Strings) + (writel (:: Const.Nil)) + (set-det)) + (= (writeConst $Name $Strings) (det-if-then (, (not (string $Name)) @@ -994,290 +608,168 @@ public class ' $Stem ' /*extends CodeFile*/ { (set-det) (writel (:: (getval stem) .s- $Name)) (set-det)))) -; - - (= - (writeConst $Name $Strings) - ( (getnameindex $Strings $Name 0 $I) - (set-det) - (writel (:: (getval stem) .s $I)) - (set-det))) -; - - (= - (writeConst $Name $Strings) - ( (must-det-l (, (atom-string $Name $S) (writel (:: Const.Intern( (format ~q (:: $S)) ))))) (set-det))) -; - - + (= (writeConst $Name $Strings) + (getnameindex $Strings $Name 0 $I) + (set-det) + (writel (:: (getval stem) .s $I)) + (set-det)) + (= (writeConst $Name $Strings) + (must-det-l (, (atom-string $Name $S) (writel (:: Const.Intern( (format ~q (:: $S)) ))))) + (set-det)) - (= - (newargs () $_ $_) True) -; - (= - (newargs - (Cons $A $Args) $N $Strings) + (= (newargs () $_ $_) True) + (= (newargs (Cons $A $Args) $N $Strings) (must-det-l (, (det-if-then-else (> $N 1) (write ,) True) (is $M (+ $N 1)) (constructterm $A $Strings) (newargs $Args $M $Strings)))) -; - - (= - (bodycont $String - (= $_ $B) $Name $Arity) - ( (fail) - (legacy-functor $B $Name $Arity) - (set-det) - (writel (:: entry-code)))) -; - - (= - (bodycont $String - (= $_ $B) $_ $_) - ( (legacy-functor $B call 1) - (set-det) - (writel (:: Prolog.Call1)))) -; - - (= - (bodycont $String - (= $_ $B) $_ $_) - ( (legacy-functor $B call 2) - (set-det) - (writel (:: Prolog.Call2)))) -; - - (= - (bodycont $String - (= $_ $B) $_ $_) - ( (legacy-functor $B cut 2) - (set-det) - (writel (:: Prolog.Call1)))) -; - + (= (bodycont $String (= $_ $B) $Name $Arity) + (fail) + (legacy-functor $B $Name $Arity) + (set-det) + (writel (:: entry-code))) + (= (bodycont $String (= $_ $B) $_ $_) + (legacy-functor $B call 1) + (set-det) + (writel (:: Prolog.Call1))) + (= (bodycont $String (= $_ $B) $_ $_) + (legacy-functor $B call 2) + (set-det) + (writel (:: Prolog.Call2))) + (= (bodycont $String (= $_ $B) $_ $_) + (legacy-functor $B cut 2) + (set-det) + (writel (:: Prolog.Call1))) ; -; - - - (= - (bodycont $String - (= $_ $B) $_ $_) - ( (fail) - (legacy-functor $B $Name $Arity) - (getnameindex $String $Name 0 $I) - (set-det) - (is $MArity - (- $Arity 1)) - (writel (:: '(Operation) ' (getval stem) .s $I .FindProc( $MArity ))))) -; - - - - (= - (bodycont $String - (= $_ $B) $_ $_) - ( (legacy-functor $B $Name $Arity) - (is $MArity - (- $Arity 1)) - (functor $P $Name $MArity) - (system-predicate $P) - (set-det) - (writel (:: '(Operation) ' (writeConst $Name $String) .FindProc( $MArity ))))) -; - - - (= - (bodycont $String - (= $_ $B) $_ $_) - ( (legacy-functor $B $Name0 $Arity) - (is $MArity - (- $Arity 1)) - (symbol-to-name $Name0 $Name) - (writel (:: (Operation)pred- $Name - $MArity ::exec-static)))) -; - - - - (= - (bodycont $String - (= $_ $B) $_ $_) - ( (legacy-functor $B $Name0 $Arity) - (symbol-to-name $Name0 $Name) - (writel (:: $Name $Arity cont)))) -; - - - - (= - (decl-deref-args -1) +; bodycont(_String,(_ :- B),_,_) :- legacy_functor(B,cut,2) , ! , writel(['MeTTa.Cut2']) . + + (= (bodycont $String (= $_ $B) $_ $_) + (fail) + (legacy-functor $B $Name $Arity) + (getnameindex $String $Name 0 $I) + (set-det) + (is $MArity + (- $Arity 1)) + (writel (:: '(Operation) ' (getval stem) .s $I .FindProc( $MArity )))) + + + (= (bodycont $String (= $_ $B) $_ $_) + (legacy-functor $B $Name $Arity) + (is $MArity + (- $Arity 1)) + (functor $P $Name $MArity) + (system-predicate $P) + (set-det) + (writel (:: '(Operation) ' (writeConst $Name $String) .FindProc( $MArity )))) + + (= (bodycont $String (= $_ $B) $_ $_) + (legacy-functor $B $Name0 $Arity) + (is $MArity + (- $Arity 1)) + (symbol-to-name $Name0 $Name) + (writel (:: (Operation)pred- $Name - $MArity ::exec-static))) + + + (= (bodycont $String (= $_ $B) $_ $_) + (legacy-functor $B $Name0 $Arity) + (symbol-to-name $Name0 $Name) + (writel (:: $Name $Arity cont))) + + + (= (decl-deref-args -1) (set-det)) -; + (= (decl-deref-args $N) + (writel (:: 'Term areg' $N ' = local-aregs[' $N '].Deref() ;' (wr nl))) + (is $M + (- $N 1)) + (decl-deref-args $M)) - (= - (decl-deref-args $N) - ( (writel (:: 'Term areg' $N ' = local-aregs[' $N '].Deref() ;' (wr nl))) - (is $M - (- $N 1)) - (decl-deref-args $M))) -; - - - (= - (use_entry_code $F $A) + (= (use_entry_code $F $A) (empty)) -; - - - (= - (use_static_call $F $A) True) -; - - - (= - (use_load_pred $F $A) True) -; - - - - (= - (initforeachcontinuation () $_ $_) True) -; - (= - (initforeachcontinuation - (Cons - (/ $N $A) $R) $N $A) - ( (set-det) (initforeachcontinuation $R $N $A))) -; - - (= - (initforeachcontinuation - (Cons - (/ call 1) $R) $N $A) - ( (set-det) (initforeachcontinuation $R $N $A))) -; - - (= - (initforeachcontinuation - (Cons - (/ call 2) $R) $N $A) - ( (set-det) (initforeachcontinuation $R $N $A))) -; - - (= - (initforeachcontinuation - (Cons - (/ cut 2) $R) $N $A) - ( (set-det) (initforeachcontinuation $R $N $A))) -; - - (= - (initforeachcontinuation - (Cons - (/ $N $A) $R) $Name $Arity) - ( (is $B - (- $A 1)) - (symbol-to-name $N $SN) - (writel (:: $N $A 'cont = pred-' $N - $B ::exec-pred- $SN -- $B or (wr nl))) - (initforeachcontinuation $R $Name $Arity))) -; - - (= - (initforeachcontinuation - (Cons - (/ $N $A) $R) $Name $Arity) - ( (use-load-pred $N $B) - (set-det) - (is $B - (- $A 1)) - (writel (:: $N $A 'cont = mach.LoadPred("' $N ", $B ) ; (wr nl))) - (initforeachcontinuation $R $Name $Arity))) -; - - - - (= - (aregarray $N) + (= (use_static_call $F $A) True) + + (= (use_load_pred $F $A) True) + + + (= (initforeachcontinuation () $_ $_) True) + (= (initforeachcontinuation (Cons (/ $N $A) $R) $N $A) + (set-det) + (initforeachcontinuation $R $N $A)) +; ; this is entry code ! + (= (initforeachcontinuation (Cons (/ call 1) $R) $N $A) + (set-det) + (initforeachcontinuation $R $N $A)) +; ; Call1 + (= (initforeachcontinuation (Cons (/ call 2) $R) $N $A) + (set-det) + (initforeachcontinuation $R $N $A)) +; ; Call2 + (= (initforeachcontinuation (Cons (/ cut 2) $R) $N $A) + (set-det) + (initforeachcontinuation $R $N $A)) +; ; Cut2 + (= (initforeachcontinuation (Cons (/ $N $A) $R) $Name $Arity) + (is $B + (- $A 1)) + (symbol-to-name $N $SN) + (writel (:: $N $A 'cont = pred-' $N - $B ::exec-pred- $SN -- $B or (wr nl))) + (initforeachcontinuation $R $Name $Arity)) + (= (initforeachcontinuation (Cons (/ $N $A) $R) $Name $Arity) + (use-load-pred $N $B) + (set-det) + (is $B + (- $A 1)) + (writel (:: $N $A 'cont = mach.LoadPred("' $N ", $B ) ; (wr nl))) + (initforeachcontinuation $R $Name $Arity)) + + + (= (aregarray $N) (aregarray 0 $N)) -; - - - (= - (aregarray $N $Max) - ( (> $N $Max) (set-det))) -; - - (= - (aregarray $N $Max) - ( (det-if-then-else - (> $N 0) - (write ,) True) - (is $M - (+ $N 1)) - (writel (:: mach.Areg[ $N ])) - (aregarray $M $Max))) -; - - - - (= - (declforeachclause () $_ $_) True) -; - - (= - (declforeachclause - (Cons $_ $R) $N $ClassName) - ( (writel (:: 'static Operation cl' $N = $ClassName ::exec- $ClassName -- $N or (wr nl))) - (is $M - (+ $N 1)) - (declforeachclause $R $M $ClassName))) -; - - - - - (= - (declforeachcontinuation () $_ $_) True) -; - (= - (declforeachcontinuation - (Cons - (/ $N $A) $R) $N $A) - ( (set-det) (declforeachcontinuation $R $N $A))) -; - - (= - (declforeachcontinuation - (Cons - (/ call 1) $R) $N $A) - ( (set-det) (declforeachcontinuation $R $N $A))) -; - - (= - (declforeachcontinuation - (Cons - (/ call 2) $R) $N $A) - ( (set-det) (declforeachcontinuation $R $N $A))) -; - - (= - (declforeachcontinuation - (Cons - (/ $N $A) $R) $Name $Arity) - ( (writel (:: 'static Operation ' $N $A 'cont ;' (wr nl))) (declforeachcontinuation $R $Name $Arity))) -; - - - - (= - (varnamestr $_ $N) + (= (aregarray $N $Max) + (> $N $Max) + (set-det)) + (= (aregarray $N $Max) + (det-if-then-else + (> $N 0) + (write ,) True) + (is $M + (+ $N 1)) + (writel (:: mach.Areg[ $N ])) + (aregarray $M $Max)) + + + (= (declforeachclause () $_ $_) True) + (= (declforeachclause (Cons $_ $R) $N $ClassName) + (writel (:: 'static Operation cl' $N = $ClassName ::exec- $ClassName -- $N or (wr nl))) + (is $M + (+ $N 1)) + (declforeachclause $R $M $ClassName)) + + + + (= (declforeachcontinuation () $_ $_) True) + (= (declforeachcontinuation (Cons (/ $N $A) $R) $N $A) + (set-det) + (declforeachcontinuation $R $N $A)) + (= (declforeachcontinuation (Cons (/ call 1) $R) $N $A) + (set-det) + (declforeachcontinuation $R $N $A)) + (= (declforeachcontinuation (Cons (/ call 2) $R) $N $A) + (set-det) + (declforeachcontinuation $R $N $A)) + (= (declforeachcontinuation (Cons (/ $N $A) $R) $Name $Arity) + (writel (:: 'static Operation ' $N $A 'cont ;' (wr nl))) + (declforeachcontinuation $R $Name $Arity)) + + + (= (varnamestr $_ $N) (det-if-then (, (not (string $N)) @@ -1287,549 +779,291 @@ public class ' $Stem ' /*extends CodeFile*/ { (set-det) (writel (:: s- $N)) (set-det)))) -; - - (= - (varnamestr $M $_) - ( (writel (:: s $M)) (set-det))) -; - - - - (= - (declforeachstring () $_) True) -; - - (= - (declforeachstring - (Cons $N $R) $M) - ( (is $MM - (+ $M 1)) - (declfor1string $N $M) - (declforeachstring $R $MM))) -; - + (= (varnamestr $M $_) + (writel (:: s $M)) + (set-det)) - (= - (declfor1string cut $M) - ( (> $M 0) (set-det))) -; + (= (declforeachstring () $_) True) + (= (declforeachstring (Cons $N $R) $M) + (is $MM + (+ $M 1)) + (declfor1string $N $M) + (declforeachstring $R $MM)) - (= - (declfor1string $N $M) - ( (atom-string $N $S) (writel (:: 'final static Const ' (varnamestr $M $N) ' = Data.Intern(' (writeq $S) ) ; (wr nl))))) -; + (= (declfor1string cut $M) + (> $M 0) + (set-det)) + (= (declfor1string $N $M) + (atom-string $N $S) + (writel (:: 'final static Const ' (varnamestr $M $N) ' = Data.Intern(' (writeq $S) ) ; (wr nl)))) - (= - (constructnum $Int) - ( (integer $Int) - (is $AInt - (abs $Int)) - (is $X - (^ 2 30)) - (> $AInt $X) - (set-det) - (writel (:: 'Data.BigInt("' $Int "))))) -; - - (= - (constructnum $Int) - ( (integer $Int) - (set-det) - (writel (:: Data.Number( $Int L))))) -; - - (= - (constructnum $Int) - ( (float $Int) (writel (:: 'Data.BigDec("' $Int "))))) -; - - - - (= - (declforeachint ()) True) -; - - (= - (declforeachint (Cons $N $R)) - ( (writel (:: 'final static Int ' (posneg $N) = (constructnum $N) ; (wr nl))) (declforeachint $R))) -; - - - - (= - (posneg $N) - ( (< $N 0) - (set-det) - (is $M - (- 0 $N)) - (writel (:: negint $M)))) -; - - (= - (posneg $N) + (= (constructnum $Int) + (integer $Int) + (is $AInt + (abs $Int)) + (is $X + (^ 2 30)) + (> $AInt $X) + (set-det) + (writel (:: 'Data.BigInt("' $Int ")))) + (= (constructnum $Int) + (integer $Int) + (set-det) + (writel (:: Data.Number( $Int L)))) + (= (constructnum $Int) + (float $Int) + (writel (:: 'Data.BigDec("' $Int ")))) + + + (= (declforeachint ()) True) + (= (declforeachint (Cons $N $R)) + (writel (:: 'final static Int ' (posneg $N) = (constructnum $N) ; (wr nl))) + (declforeachint $R)) + + + (= (posneg $N) + (< $N 0) + (set-det) + (is $M + (- 0 $N)) + (writel (:: negint $M))) + (= (posneg $N) (writel (:: posint $N))) -; - - - - (= - (declforeachpred ()) True) -; - (= - (declforeachpred (Cons $P $R)) - ( (set-det) - (declforeachpred1 $P) - (declforeachpred $R))) -; + (= (declforeachpred ()) True) + (= (declforeachpred (Cons $P $R)) + (set-det) + (declforeachpred1 $P) + (declforeachpred $R)) - (= - (declforeachpred1 (:: (= $P $A))) + (= (declforeachpred1 (:: (= $P $A))) (== $P $A)) -; - - (= - (declforeachpred1 (Cons (= $P $_) $_)) - ( (functor $P $F $A) - (set-det) - (symbol-to-name $F $Name) - (is $AA - (- $A 1)) - (atom-string $F $Str) - (writel (:: 'final static Operation reg-' $Name - $AA ' = PredTable.Register(' (writeq $Str) , $AA ', new pred-' $Name - $AA ()); (wr nl))) - (set-det))) -; - + (= (declforeachpred1 (Cons (= $P $_) $_)) + (functor $P $F $A) + (set-det) + (symbol-to-name $F $Name) + (is $AA + (- $A 1)) + (atom-string $F $Str) + (writel (:: 'final static Operation reg-' $Name - $AA ' = PredTable.Register(' (writeq $Str) , $AA ', new pred-' $Name - $AA ()); (wr nl))) + (set-det)) - (= - (declforeachpred1 $_) True) -; - + (= (declforeachpred1 $_) True) - (= - (getnameindex - (Cons $N $_) $N $In $In) + (= (getnameindex (Cons $N $_) $N $In $In) + (set-det)) + (= (getnameindex (Cons $_ $R) $N $In $Out) + (is $I + (+ $In 1)) + (getnameindex $R $N $I $Out) (set-det)) -; - - (= - (getnameindex - (Cons $_ $R) $N $In $Out) - ( (is $I - (+ $In 1)) - (getnameindex $R $N $I $Out) - (set-det))) -; - ; -; - +; getnameindex(_,_,In,In). - (= - (continuationof - (Cons - (= $_ $B) $_) - (/ $N $A)) + (= (continuationof (Cons (= $_ $B) $_) (/ $N $A)) (legacy-functor $B $N $A)) -; - - (= - (continuationof - (Cons $_ $R) $F) + (= (continuationof (Cons $_ $R) $F) (continuationof $R $F)) -; - - (= - (stringof - (Cons $Cl $_) $F) + (= (stringof (Cons $Cl $_) $F) (strings1 $Cl $F)) -; - - (= - (stringof - (Cons $_ $R) $F) + (= (stringof (Cons $_ $R) $F) (stringof $R $F)) -; - - - (= - (strings1 $X $_) - ( (var $X) - (set-det) - (fail))) -; - (= - (strings1 - (, $A $_) $F) + (= (strings1 $X $_) + (var $X) + (set-det) + (fail)) + (= (strings1 (, $A $_) $F) (strings1 $A $F)) -; - - (= - (strings1 - (, $_ $B) $F) - ( (set-det) (strings1 $B $F))) -; - - (= - (strings1 - (= $A $_) $F) + (= (strings1 (, $_ $B) $F) + (set-det) + (strings1 $B $F)) + (= (strings1 (= $A $_) $F) (strings1 $A $F)) -; - - (= - (strings1 - (= $_ $B) $F) - ( (set-det) (strings1 $B $F))) -; - - (= - (strings1 $T $F) - ( (legacy-functor $T $N $_) (= $F $N))) -; - - (= - (strings1 $T $F) - ( (=.. $T - (Cons $_ $Args)) (stringsl $Args $F))) -; - - - - (= - (strings $X $_) - ( (var $X) - (set-det) - (fail))) -; - - (= - (strings $A $F) - ( (atom $A) - (set-det) - (= $F $A))) -; - - (= - (strings $A $_) - ( (atomic $A) - (set-det) - (fail))) -; - - (= - (strings $T $F) - ( (legacy-functor $T $N $_) (= $F $N))) -; - - (= - (strings $T $F) - ( (=.. $T - (Cons $_ $Args)) (stringsl $Args $F))) -; - - - - (= - (stringsl - (Cons $T $_) $F) + (= (strings1 (= $_ $B) $F) + (set-det) + (strings1 $B $F)) + (= (strings1 $T $F) + (legacy-functor $T $N $_) + (= $F $N)) + (= (strings1 $T $F) + (=.. $T + (Cons $_ $Args)) + (stringsl $Args $F)) + + + (= (strings $X $_) + (var $X) + (set-det) + (fail)) + (= (strings $A $F) + (atom $A) + (set-det) + (= $F $A)) + (= (strings $A $_) + (atomic $A) + (set-det) + (fail)) + (= (strings $T $F) + (legacy-functor $T $N $_) + (= $F $N)) + (= (strings $T $F) + (=.. $T + (Cons $_ $Args)) + (stringsl $Args $F)) + + + (= (stringsl (Cons $T $_) $F) (strings $T $F)) -; - - (= - (stringsl - (Cons $_ $R) $F) + (= (stringsl (Cons $_ $R) $F) (stringsl $R $F)) -; - - (= - (intof - (Cons $Cl $_) $F) + (= (intof (Cons $Cl $_) $F) (ints $Cl $F)) -; - - (= - (intof - (Cons $_ $R) $F) + (= (intof (Cons $_ $R) $F) (intof $R $F)) -; - - - - (= - (ints $X $_) - ( (var $X) - (set-det) - (fail))) -; - - (= - (ints $A $F) - ( (integer $A) - (set-det) - (= $F $A))) -; - - (= - (ints $A $_) - ( (atomic $A) - (set-det) - (fail))) -; - (= - (ints $T $F) - ( (=.. $T - (Cons $_ $Args)) (intof $Args $F))) -; + (= (ints $X $_) + (var $X) + (set-det) + (fail)) + (= (ints $A $F) + (integer $A) + (set-det) + (= $F $A)) + (= (ints $A $_) + (atomic $A) + (set-det) + (fail)) + (= (ints $T $F) + (=.. $T + (Cons $_ $Args)) + (intof $Args $F)) - (= - (predof - (Cons $Cl $_) $F) + (= (predof (Cons $Cl $_) $F) (preds $Cl $F)) -; - - (= - (predof - (Cons $_ $R) $F) + (= (predof (Cons $_ $R) $F) (predof $R $F)) -; - - - (= - (preds $X $_) - ( (var $X) - (set-det) - (fail))) -; - - (= - (preds $P - (/ $F $A)) - ( (functor $P $F $A) (set-det))) -; + (= (preds $X $_) + (var $X) + (set-det) + (fail)) + (= (preds $P (/ $F $A)) + (functor $P $F $A) + (set-det)) ; -; +; the following are also in someMeTTa at the moment - - (= - (specialgoal - (< $X $Y) - (smallerthan $X $Y)) + (= (specialgoal (< $X $Y) (smallerthan $X $Y)) (set-det)) -; - - (= - (specialgoal - (=< $X $Y) - (smallerorequal $X $Y)) + (= (specialgoal (=< $X $Y) (smallerorequal $X $Y)) (set-det)) -; - - (= - (specialgoal - (> $X $Y) - (smallerthan $Y $X)) + (= (specialgoal (> $X $Y) (smallerthan $Y $X)) (set-det)) -; - - (= - (specialgoal - (>= $X $Y) - (smallerorequal $Y $X)) + (= (specialgoal (>= $X $Y) (smallerorequal $Y $X)) (set-det)) -; - - (= - (specialgoal - (=:= $X $Y) - (arithequal $Y $X)) + (= (specialgoal (=:= $X $Y) (arithequal $Y $X)) (set-det)) -; - - (= - (specialgoal - (= $X $Y) - (unify $Y $X)) + (= (specialgoal (= $X $Y) (unify $Y $X)) (set-det)) -; - - (= - (specialgoal - (or $X $Y) - (or $X $Y)) + (= (specialgoal (or $X $Y) (or $X $Y)) (set-det)) -; - - (= - (specialgoal - (@< $X $Y) - (termsmallerthan $X $Y)) + (= (specialgoal (@< $X $Y) (termsmallerthan $X $Y)) (set-det)) -; - - (= - (specialgoal - (@> $X $Y) - (termgreaterthan $X $Y)) + (= (specialgoal (@> $X $Y) (termgreaterthan $X $Y)) (set-det)) -; - - (= - (specialgoal - (@=< $X $Y) - (termsmallerequal $X $Y)) + (= (specialgoal (@=< $X $Y) (termsmallerequal $X $Y)) (set-det)) -; - - (= - (specialgoal - (@>= $X $Y) - (termgreaterequal $X $Y)) + (= (specialgoal (@>= $X $Y) (termgreaterequal $X $Y)) (set-det)) -; - - (= - (specialgoal - (== $X $Y) - (termequal $X $Y)) + (= (specialgoal (== $X $Y) (termequal $X $Y)) (set-det)) -; - - (= - (specialgoal - (not $X) - (not $X)) + (= (specialgoal (not $X) (not $X)) (set-det)) -; - - - (= - (w-cl (:: $Pred)) - ( (set-det) (format ~N~p.~n (:: $Pred)))) -; - (= - (w-cl (Cons $Prev $Pred)) - ( (set-det) - (w-cl $Pred) - (w-cl $Prev))) -; - - (= - (w-cl $Pred) + (= (w-cl (:: $Pred)) + (set-det) + (format ~N~p.~n + (:: $Pred))) + (= (w-cl (Cons $Prev $Pred)) + (set-det) + (w-cl $Pred) + (w-cl $Prev)) + (= (w-cl $Pred) (w-cl (:: $Pred))) -; - - (= - (prelude $Pred) - ( (write + (= (prelude $Pred) + (write /* -) (w-cl $Pred) - (write +) + (w-cl $Pred) + (write */ -))) -; - - (= - (prelude) - ( (write '// Generated code file - by dmiles') - (nl) - (fail))) -; - - (= - (prelude) - ( (write '// Copyright August 16, 1996,2018 LOGICMOO, KUL and CUM') - (nl) - (fail))) -; - - (= - (prelude) - ( (write '// Authors: Douglas R. Miles, Bart Demoen and Paul Tarau') - (nl) - (nl) - (fail))) -; - - (= prelude True) -; - +)) + (= (prelude) + (write '// Generated code file - by dmiles') + (nl) + (fail)) + (= (prelude) + (write '// Copyright August 16, 1996,2018 LOGICMOO, KUL and CUM') + (nl) + (fail)) + (= (prelude) + (write '// Authors: Douglas R. Miles, Bart Demoen and Paul Tarau') + (nl) + (nl) + (fail)) + (= prelude True) ; -; - +; main :- comp('board') , fail . ; -; - +; main :- comp('test') , fail . ; -; - +; main :- comp('read.pl') , fail . ; -; - +; main :- comp('someMeTTa') , fail . ; -; - +; main :- comp('chat') , fail . ; -; - +; main :- comp('boyer') , fail . !(comp-to sxx-system ../jsrc/bootlib) -; - !(comp-to sxx-read ../jsrc/bootlib) -; - !(comp-to sxx-library ../jsrc/bootlib) -; - !(comp-to sxx-meta ../jsrc/bootlib) -; - ; -; - +; :- comp_to(sxx_compiler_gen_static,'../jsrc/compiler'). !(comp-to sxx-builtins-cafe ../jsrc/library) -; - !(comp-to tests/* ../jsrc/testing) -; - !(comp-to bench/* ../jsrc/benches) -; - diff --git a/sxx_machine/sxx_library.metta b/sxx_machine/sxx_library.metta index 2cc8b8b..b966d65 100644 --- a/sxx_machine/sxx_library.metta +++ b/sxx_machine/sxx_library.metta @@ -1,572 +1,305 @@ +; (convert_to_metta_file sxx_library $_430506 sxx_machine/sxx_library.pl sxx_machine/sxx_library.metta) - (= - (toplevel) - ( (top) (fail))) -; - - (= - (toplevel) + (= (toplevel) + (top) + (fail)) + (= (toplevel) (toplevel)) -; - - - (= - (top) - ( (write ?- ) - (vread $Goal $Vars) - !$Goal - (writevars $Vars) - (write Yes) - (nl) - (notmore) - (set-det) - (fail))) -; + (= (top) + (write ?- ) + (vread $Goal $Vars) + !$Goal + (writevars $Vars) + (write Yes) + (nl) + (notmore) + (set-det) + (fail)) - (= - (top) + (= (top) (top)) -; - - - - (= - (notmore) - ( (write 'more? ') - (get0 $X) - (noteq $X 10) - (set-det) - (untilend $X) - (fail))) -; - (= notmore True) -; + (= (notmore) + (write 'more? ') + (get0 $X) + (noteq $X 10) + (set-det) + (untilend $X) + (fail)) + (= notmore True) - (= - (noteq $X $X) - ( (set-det) (fail))) -; + (= (noteq $X $X) + (set-det) + (fail)) + (= (noteq $_ $_) True) - (= - (noteq $_ $_) True) -; - - - (= - (untilend 10) + (= (untilend 10) (set-det)) -; - - (= - (untilend $_) - ( (get0 $X) (untilend $X))) -; - - - - (= - (writevars ()) True) -; - - (= - (writevars (Cons (= $Var $Name) $R)) - ( (write $Name) - (write = ) - (write $Var) - (nl) - (fail))) -; - - (= - (writevars (Cons $_ $R)) + (= (untilend $_) + (get0 $X) + (untilend $X)) + + + (= (writevars ()) True) + (= (writevars (Cons (= $Var $Name) $R)) + (write $Name) + (write = ) + (write $Var) + (nl) + (fail)) + (= (writevars (Cons $_ $R)) (writevars $R)) -; - - (= - (nrev Nil Nil) + (= (nrev Nil Nil) (set-det)) -; - - (= - (nrev - (Cons $A $B) $O) - ( (nrev $B $C) (append $C (:: $A) $O))) -; - + (= (nrev (Cons $A $B) $O) + (nrev $B $C) + (append $C + (:: $A) $O)) - (= - (append () $L $L) True) -; - - (= - (append - (Cons $A $L1) $L2 - (Cons $A $L3)) + (= (append () $L $L) True) + (= (append (Cons $A $L1) $L2 (Cons $A $L3)) (append $L1 $L2 $L3)) -; - - (= - (max $A $B $B) + (= (max $A $B $B) (smallerthan $A $B)) -; - - (= - (max $A $B $A) + (= (max $A $B $A) (smallerthan $B $A)) -; - - (= - (max $A $A $A) True) -; - + (= (max $A $A $A) True) - (= - (sort Nil Nil) + (= (sort Nil Nil) (set-det)) -; + (= (sort (Cons $X $R) $Out) + (split $X $R $S $G) + (sort $S $SS) + (sort $G $GS) + (append $SS + (Cons $X $GS) $Out)) - (= - (sort - (Cons $X $R) $Out) - ( (split $X $R $S $G) - (sort $S $SS) - (sort $G $GS) - (append $SS - (Cons $X $GS) $Out))) -; - - - (= - (split $X Nil Nil Nil) + (= (split $X Nil Nil Nil) (set-det)) -; - - (= - (split $X - (Cons $A $R) - (Cons $A $S) $G) - ( (smallerthan $A $X) - (set-det) - (split $X $R $S $G))) -; - - (= - (split $X - (Cons $A $R) $S - (Cons $A $G)) + (= (split $X (Cons $A $R) (Cons $A $S) $G) + (smallerthan $A $X) + (set-det) + (split $X $R $S $G)) + (= (split $X (Cons $A $R) $S (Cons $A $G)) (split $X $R $S $G)) -; - - - - (= - (time $Goal) - ( (cputime $T1) - !$Goal - (cputime $T2) - (is $T - (- $T2 $T1)) - (write $T) - (nl))) -; - - - - - (= - !$G - ( (var $G) - (set-det) - (fail))) -; - - (= - ! (, $G $B) - ( (set-det) - !$G - !$B)) -; - - (= - ! (det-if-then $If $Then) - ( (set-det) (execdisj (det-if-then $If $Then) True))) -; - - (= - ! (or $B1 $B2) - ( (set-det) (execdisj $B1 $B2))) -; - (= - !$G - ( (specialgoal $G $G1) - (set-det) - !$G1)) -; - (= - !$G - (call $G)) -; + (= (time $Goal) + (cputime $T1) + !$Goal + (cputime $T2) + (is $T + (- $T2 $T1)) + (write $T) + (nl)) - (= + (= !$G + (var $G) + (set-det) + (fail)) + (= !(, $G $B) + (set-det) + !$G + !$B) + (= !(det-if-then $If $Then) + (set-det) (execdisj - (det-if-then $If $Then) $Else) - ( !$If - (set-det) - !$Then)) -; + (det-if-then $If $Then) True)) + (= !(or $B1 $B2) + (set-det) + (execdisj $B1 $B2)) + (= !$G + (specialgoal $G $G1) + (set-det) + !$G1) + (= !$G + (call $G)) - (= - (execdisj - (det-if-then $If $Then) $Else) - ( (set-det) !$Else)) -; - (= - (execdisj $B1 $B2) + (= (execdisj (det-if-then $If $Then) $Else) + !$If + (set-det) + !$Then) + (= (execdisj (det-if-then $If $Then) $Else) + (set-det) + !$Else) + (= (execdisj $B1 $B2) !$B1) -; - - (= - (execdisj $B1 $B2) + (= (execdisj $B1 $B2) !$B2) -; - - (= - (loop 0) + (= (loop 0) (set-det)) -; - - (= - (loop $N) - ( (is $M - (- $N 1)) (loop $M))) -; - + (= (loop $N) + (is $M + (- $N 1)) + (loop $M)) - (= - (or $X $_) + (= (or $X $_) !$X) -; - - (= - (or $_ $Y) + (= (or $_ $Y) !$Y) -; - - (= - (findall $X $Goal $L) - ( (initfindall $Handle) (findall2 $X $Goal $L $Handle))) -; + (= (findall $X $Goal $L) + (initfindall $Handle) + (findall2 $X $Goal $L $Handle)) - - (= - (findall2 $X $Goal $L $Handle) - ( !$Goal - (addfindall $X $Handle) - (fail))) -; - - (= - (findall2 $X $Goal $L $Handle) + (= (findall2 $X $Goal $L $Handle) + !$Goal + (addfindall $X $Handle) + (fail)) + (= (findall2 $X $Goal $L $Handle) (retrievefindall $L $Handle)) -; - - (= - (copy-term $T1 $T2) + (= (copy-term $T1 $T2) (findall $X (= $X $T1) (:: $T2))) -; - - (= - (var $X) + (= (var $X) (type-of $X var)) -; - - - (= - (atomic $X) - ( (type-of $X $A) (atomic2 $A))) -; + (= (atomic $X) + (type-of $X $A) + (atomic2 $A)) - (= - (atomic2 is-symbol) + (= (atomic2 is-symbol) (set-det)) -; + (= (atomic2 integer) True) - (= - (atomic2 integer) True) -; - - - (= - (atom $X) + (= (atom $X) (type-of $X is-symbol)) -; - - (= - (integer $X) + (= (integer $X) (type-of $X integer)) -; - - - (= - (assumeduring $G $F) - ( (assume (- $F $Tag)) - !$G - (= $Tag 1))) -; + (= (assumeduring $G $F) + (assume (- $F $Tag)) + !$G + (= $Tag 1)) - (= - (assumed $F) - ( (allassumed $L) (m1 $F $L))) -; + (= (assumed $F) + (allassumed $L) + (m1 $F $L)) - - (= - (m1 $X - (Cons - (- $X $Tag) $_)) + (= (m1 $X (Cons (- $X $Tag) $_)) (var $Tag)) -; - - (= - (m1 $X - (Cons $_ $R)) + (= (m1 $X (Cons $_ $R)) (m1 $X $R)) -; - - (= - (statistics runtime - (:: $T $_)) + (= (statistics runtime (:: $T $_)) (cputime $T)) -; - ; -; - +; the following are also needed in the compiler at the moment - (= - (specialgoal - (< $X $Y) - (smallerthan $X $Y)) + (= (specialgoal (< $X $Y) (smallerthan $X $Y)) (set-det)) -; - - (= - (specialgoal - (=< $X $Y) - (smallerorequal $X $Y)) + (= (specialgoal (=< $X $Y) (smallerorequal $X $Y)) (set-det)) -; - - (= - (specialgoal - (> $X $Y) - (smallerthan $Y $X)) + (= (specialgoal (> $X $Y) (smallerthan $Y $X)) (set-det)) -; - - (= - (specialgoal - (>= $X $Y) - (smallerorequal $Y $X)) + (= (specialgoal (>= $X $Y) (smallerorequal $Y $X)) (set-det)) -; - - (= - (specialgoal - (=:= $X $Y) - (arithequal $Y $X)) + (= (specialgoal (=:= $X $Y) (arithequal $Y $X)) (set-det)) -; - - (= - (specialgoal - (= $X $Y) - (unify $Y $X)) + (= (specialgoal (= $X $Y) (unify $Y $X)) (set-det)) -; - - (= - (specialgoal - (or $X $Y) - (or $X $Y)) + (= (specialgoal (or $X $Y) (or $X $Y)) (set-det)) -; - - (= - (specialgoal - (@< $X $Y) - (termsmallerthan $X $Y)) + (= (specialgoal (@< $X $Y) (termsmallerthan $X $Y)) (set-det)) -; - - (= - (specialgoal - (@> $X $Y) - (termgreaterthan $X $Y)) + (= (specialgoal (@> $X $Y) (termgreaterthan $X $Y)) (set-det)) -; - - (= - (specialgoal - (@=< $X $Y) - (termsmallerequal $X $Y)) + (= (specialgoal (@=< $X $Y) (termsmallerequal $X $Y)) (set-det)) -; - - (= - (specialgoal - (@>= $X $Y) - (termgreaterequal $X $Y)) + (= (specialgoal (@>= $X $Y) (termgreaterequal $X $Y)) (set-det)) -; - - (= - (specialgoal - (== $X $Y) - (termequal $X $Y)) + (= (specialgoal (== $X $Y) (termequal $X $Y)) (set-det)) -; - - (= - (termsmallerthan $X $Y) + (= (termsmallerthan $X $Y) (compare < $X $Y)) -; - - (= - (termgreaterthan $X $Y) + (= (termgreaterthan $X $Y) (compare > $X $Y)) -; - - - (= - (termsmallerequal $X $Y) - ( (compare $C $X $Y) (smeq $C))) -; + (= (termsmallerequal $X $Y) + (compare $C $X $Y) + (smeq $C)) - (= - (smeq <) + (= (smeq <) (set-det)) -; - - (= - (smeq =) True) -; - + (= (smeq =) True) - (= - (termgreaterequal $X $Y) - ( (compare $C $X $Y) (smgr $C))) -; + (= (termgreaterequal $X $Y) + (compare $C $X $Y) + (smgr $C)) - - (= - (smgr >) + (= (smgr >) (set-det)) -; - - (= - (smgr =) True) -; - + (= (smgr =) True) - (= - (termequal $X $Y) + (= (termequal $X $Y) (compare = $X $Y)) -; - - - (= - (not $G) - ( !$G - (set-det) - (fail))) -; - (= - (not $_) True) -; + (= (not $G) + !$G + (set-det) + (fail)) + (= (not $_) True) - - (= - (freeze $X $G) - ( (var $X) - (set-det) - (freeze-internal $X $G))) -; - - (= - (freeze $X $G) + (= (freeze $X $G) + (var $X) + (set-det) + (freeze-internal $X $G)) + (= (freeze $X $G) !$G) -; - - (= - (execpendinggoals Nil) + (= (execpendinggoals Nil) (execcontinuation)) -; - - (= - (execpendinggoals (Cons $G $R)) - ( !$G (execpendinggoals $R))) -; - + (= (execpendinggoals (Cons $G $R)) + !$G + (execpendinggoals $R)) diff --git a/sxx_machine/sxx_meta.metta b/sxx_machine/sxx_meta.metta index 4143dac..08db511 100644 --- a/sxx_machine/sxx_meta.metta +++ b/sxx_machine/sxx_meta.metta @@ -1,86 +1,68 @@ +; (convert_to_metta_file sxx_meta $_115346 sxx_machine/sxx_meta.pl sxx_machine/sxx_meta.metta) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Builtin Predicates of MeTTa Cafe ; ; - ; -; - +; Mutsunori Banbara (banbara@kobe-u.ac.jp) ; -; - +; Naoyuki Tamura (tamura@kobe-u.ac.jp) ; -; - +; Kobe University ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; :- op(1150, fx, (package)). ; -; - +; package(X):- nb_setval(package,X). ; -; - +; :-package('TauMachine.builtin_tau'). ; -; - +; :- public system_predicate/1. ; -; - +; :- multifile(system_predicate/1). ; -; - +; :- dynamic(system_predicate/1). - (= - (forall $G1 $G) + (= (forall $G1 $G) (not (not (, (call $G1) (not (not (call $G2))))))) -; - +; /* system_predicate(nb_setarg(_,_,_)). system_predicate(setarg(_,_,_)). system_predicate(nb_get_attr(_,_,_)). system_predicate(nb_put_attr(_,_,_)). system_predicate(nb_get_attrs(_,_)). system_predicate(nb_put_attrs(_,_)). */ +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Control constructs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; :- public undo/1. +; /* '$builtin_meta_predicates'(undo, 1, [:]). '$builtin_meta_predicates'(undo1, 1, [:]). '$builtin_meta_predicates'(redo_each_call, 3, [:,:,:]). '$builtin_meta_predicates'(one_of_or_else, 3, [:,:,:]). */ +; ;(IF -> THEN; _ELSE) :- call(IF), !, call(THEN). ;(_IF -> _THEN; ELSE) :- call(ELSE). - (= - (undo $G) $G) -; - + (= (undo $G) $G) - (= - (redo-each-call $EachSetup $Call $EachCleanup) - (setup-call-cleanup $EachSetup $Call $EachCleanup)) -; - + (= (redo-each-call $EachSetup $Call $EachCleanup) + (setup-call-cleanup $EachSetup $Call $EachCleanup)) - (= + (= (or (if $IF $THEN) $ELSE) + (= $AtLeastOnce + (dotwo True)) (or - (if $IF $THEN) $ELSE) - ( (= $AtLeastOnce - (dotwo True)) (or (, (call $IF) (nb-setarg 1 $AtLeastOnce fail)) (or (= $AtLeastOnce (dotwo True)) $Else)))) -; - + (, + (call $IF) + (nb-setarg 1 $AtLeastOnce fail)) + (or + (= $AtLeastOnce + (dotwo True)) $Else))) - (= - (one-of-or-else $If $Then $Else) + (= (one-of-or-else $If $Then $Else) (or - (if $IF $THEN) $ELSE)) -; - + (if $IF $THEN) $ELSE)) ; -; - +; END diff --git a/sxx_machine/sxx_pl2cpp.metta b/sxx_machine/sxx_pl2cpp.metta index e86b3a1..cb2adfd 100644 --- a/sxx_machine/sxx_pl2cpp.metta +++ b/sxx_machine/sxx_pl2cpp.metta @@ -1,199 +1,99 @@ +; (convert_to_metta_file sxx_pl2cpp $_194292 sxx_machine/sxx_pl2cpp.pl sxx_machine/sxx_pl2cpp.metta) !(op 1170 xfx :-) -; - - !(op 1170 xfx -->) -; - - !(op 1170 fx :-) -; - - !(op 1170 fx ?-) -; - - !(op 500 yfx #) -; - - - !(op 1150 fx constant) -; - ; -; - - !(op 1150 fx dynamic) -; - - !(op 1150 fx meta-predicate) -; - - !(op 1150 fx package) -; - ; -; - - !(op 1150 fx public) -; - - !(op 1150 fx import) -; - ; -; - - !(op 1150 fx include) -; - ; -; - - !(op 1150 fx mode) -; - - !(op 1150 fx multifile) -; - - !(op 1150 fx block) -; - - !(op 1150 fx ifdef) -; - ; -; - - !(op 1150 fx ifndef) -; - ; -; - - !(op 1150 fx domain) -; - ; -; - - !(op 1150 fx database) -; - ; -; - - !(op 1150 fx include-resource) -; - ; -; - - - !(dynamic (/ internal-clause 2)) -; - - !(dynamic (/ internal-predicates 2)) -; - - !(dynamic (/ dynamic-predicates 3)) -; - - !(dynamic (/ database-call 1)) -; - - !(dynamic (/ compiler-constant 2)) -; - - !(dynamic (/ meta-predicates 3)) -; - - !(dynamic (/ package-name 1)) -; - - !(dynamic (/ public-predicates 2)) -; - - !(dynamic (/ import-package 2)) -; - - !(dynamic (/ internal-declarations 1)) -; - - !(dynamic (/ file-name 1)) -; - - !(dynamic (/ included-file 1)) -; - - !(dynamic (/ dummy-clause-counter 1)) -; - - !(dynamic (/ pl2am-flag 1)) -; - - !(dynamic (/ fail-flag 0)) -; - ; -; - - !(dynamic (/ skip-code 0)) -; - ; -; - - !(dynamic (/ ifdef-flag 0)) -; - ; -; - - !(dynamic (/ domain-definition 2)) -; - - !(dynamic (/ file-base 1)) -; - - !(dynamic (/ file-line 2)) -; - +; /***************************************************************** Time-stamp: <2008-10-29 10:41:19 banbara> NAME pl2am: Translating MeTTa into WAM-based Intermediate Code USAGE # sicstus ?- [pl2am]. ?- pl2am([File1, File2, [Op1,..,OpN]]). PARAMETERS File1 is an input MeTTa file name. File2 is an output file name. Op ::= ed | ac | ie | rc | idx | clo ed : eliminate disjunctions ac : arithmetic compilation ie : inline expansion rc : optimise recursive call idx: switch_on_hash (2nd. level indexing) clo: generate closure for meta predicates pif(folder): folder for writing package init predicates DESCRIPTION This program translates MeTTa program into WAM-based intermediate codes. Generated codes can be translated into Java program by using am2j.pl, and then compiled and executed by usual java utilities with the MeTTa Cafe runtime system. COPYRIGHT pl2am (Translating MeTTa into WAM-based Intermediate Code) Copyright (C) 1997-2008 by Mutsunori Banbara (banbara@kobe-u.ac.jp) and Naoyuki Tamura (tamura@kobe-u.ac.jp) SEE ALSO http://kaminari.istc.kobe-u.ac.jp/MeTTaCafe/ *****************************************************************/ +; /***************************************************************** WAM-BASED INTERMEDIATE INSTRUCTIONS Put Instructions ================ put_var(X) put_int(i, X) put_float(f, X) put_con(f/n, X) put_con(c, X), put_list(Xi, Xj, Xk) put_str(Xi, Y, Xj) put_str_args([Xi,..,Xn], Y) put_clo(p:G, X) put_cont(p:BinG, C) put_cont(BinG, C) Get Instructions ================ get_val(Xi, Xj) get_int(i, Xi, Xj) get_float(f, Xi, Xj) get_con(c, Xi, Xj) get_ground(g, Xi, Xj) get_list(X) get_str(f/n, Xi, Xj) Unify Instructions ================== unify_var(X) unify_val(X) unify_int(i, X) unify_float(f, X) unify_con(c, X) unify_ground(g, X) unify_void(i) Choice Instructions =================== try(Li, Lj) retry(Li, Lj) trust(L) Indexing Instructions ===================== switch_on_term(Lv, Li, Lf, Lc, Ls, Ll) switch_on_hash(TAG, i, L, hashtable) Control Instructions ==================== execute(p:BinG) execute(BinG) inline(G) Other Instructions ================== (:- G) comment(Message) debug(Message) info(Message) begin_predicate(p, f/n) end_predicate(p, f/n) import_package(p) import_package(p, f/n) main(f/n, public): [Instructions] main(f/n, non-public): [Instructions] L: [Instructions] label(L) deref(Ri, Rj) set(Ri, Rj) setB0 goto(L) decl_term_vars([R1,...,Rn]) decl_pred_vars([R1,...,Rn]) new_hash(TAG, i) put_hash(X, L, TAG) static([Instructions]) Notation ******** X ::= a(i) | S Y ::= y(i) | S S ::= s(i) | si(i) | sf(i) L ::= f/n | f/n+i | f/n+TAG | f/n+TAG+i | f/n+TAG+i+i TAG ::= var | int | flo | con | str | lis | top | sub | nil BinG ::= C | f(A1,..,An, C) G ::= f(A1,..,An) A ::= void | X C ::= cont | p(N) R ::= cont | econt | a(i) | arg(i) | ea(i) *****************************************************************/ +; /***************************************************************** Declarations *****************************************************************/ + !(op 1170 xfx -->) + !(op 1170 fx :-) + !(op 1170 fx ?-) + !(op 500 yfx #) + + !(op 1150 fx constant) ; +; added by Augeo + !(op 1150 fx dynamic) + !(op 1150 fx meta-predicate) + !(op 1150 fx package) ; +; MeTTa Cafe specific + !(op 1150 fx public) + !(op 1150 fx import) ; +; MeTTa Cafe specific + !(op 1150 fx include) ; +; added by Augeo + !(op 1150 fx mode) + !(op 1150 fx multifile) + !(op 1150 fx block) + !(op 1150 fx ifdef) ; +; added by Augeo + !(op 1150 fx ifndef) ; +; added by Augeo + !(op 1150 fx domain) ; +; added by Augeo + !(op 1150 fx database) ; +; added by Augeo + !(op 1150 fx include-resource) ; +; added by Augeo + + !(dynamic (/ internal-clause 2)) + !(dynamic (/ internal-predicates 2)) + !(dynamic (/ dynamic-predicates 3)) + !(dynamic (/ database-call 1)) + !(dynamic (/ compiler-constant 2)) + !(dynamic (/ meta-predicates 3)) + !(dynamic (/ package-name 1)) + !(dynamic (/ public-predicates 2)) + !(dynamic (/ import-package 2)) + !(dynamic (/ internal-declarations 1)) + !(dynamic (/ file-name 1)) + !(dynamic (/ included-file 1)) + !(dynamic (/ dummy-clause-counter 1)) + !(dynamic (/ pl2am-flag 1)) + !(dynamic (/ fail-flag 0)) ; +; used for generating label(fail/0) or not + !(dynamic (/ skip-code 0)) ; +; used for conditional compilation + !(dynamic (/ ifdef-flag 0)) ; +; used for conditional compilation + !(dynamic (/ domain-definition 2)) + !(dynamic (/ file-base 1)) + !(dynamic (/ file-line 2)) ; -; - +; :- module('SxxMachine.compiler.pl2am', [main/0,pl2am/1]). ; -; - +; package(_). ; -; - - - !(public (, (/ main 0) (/ pl2am 1))) -; +; :- package 'SxxMachine.compiler.pl2am'. + !(public (, (/ main 0) (/ pl2am 1))) - (= - (main-pl2am) - ( (read $X) (pl2am $X))) -; - + (= (main-pl2am) + (read $X) + (pl2am $X)) +; /***************************************************************** Main *****************************************************************/ - (= - (pl2am (:: $PrologFile $AsmFile $Opts)) - ( (read-in-program $PrologFile $Opts) - (open $AsmFile write $Out) - (compile-all-predicates $Out) - (close $Out))) -; - + (= (pl2am (:: $PrologFile $AsmFile $Opts)) + (read-in-program $PrologFile $Opts) + (open $AsmFile write $Out) + (compile-all-predicates $Out) + (close $Out)) ; -; - +; pl2am(_). - (= - (read-in-program $File $Opts) + (= (read-in-program $File $Opts) ( (pl2am-preread $File $Opts) - (get-symbols &self + (== (= - (file_name $F) $_)) + (file_name $F) $_) + (get-atoms &self)) (read-in-file $F) (pl2am-postread))) -; - +; /***************************************************************** Read in Program *****************************************************************/ - (= - (read-in-file $File) + (= (read-in-file $File) ( (build-file-name $File $F) (open $F read $In) (repeat) @@ -203,1684 +103,1016 @@ (assert-clause $X) (== $X end-of-file) (set-det) - (remove-all-symbols &self + (remove-all-atoms &self (file_line $_ $_)) - (close $In))) -; - + (close $In))) - (= - (read-clause- $Stream $Clause) - ( (catch - (read $Stream $Clause) $_ fail) (set-det))) -; - - (= - (read-clause- $_ $_) - ( (pl2am-error Nil) (fail))) -; - + (= (read-clause- $Stream $Clause) + (catch + (read $Stream $Clause) $_ fail) + (set-det)) +; ; catch is necessary only for SWI prolg + (= (read-clause- $_ $_) + (pl2am-error Nil) + (fail)) ; -; +; ;; Pre-init - - (= - (pl2am-preread $File $Opts) - ( (remove-all-symbols &self + (= (pl2am-preread $File $Opts) + ( (remove-all-atoms &self (internal_clause $_ $_)) - (remove-all-symbols &self + (remove-all-atoms &self (internal_predicates $_ $_)) - (remove-all-symbols &self + (remove-all-atoms &self (dynamic_predicates $_ $_ $_)) - (remove-all-symbols &self + (remove-all-atoms &self (database_call $_)) - (remove-all-symbols &self + (remove-all-atoms &self (compiler_constant $_ $_)) - (remove-all-symbols &self + (remove-all-atoms &self (meta_predicates $_ $_ $_)) - (remove-all-symbols &self + (remove-all-atoms &self (package_name $_)) - (remove-all-symbols &self + (remove-all-atoms &self (public_predicates $_ $_)) - (remove-all-symbols &self + (remove-all-atoms &self (import_package $_ $_)) - (remove-all-symbols &self + (remove-all-atoms &self (internal_declarations $_)) - (remove-all-symbols &self + (remove-all-atoms &self (file_name $_)) - (remove-all-symbols &self + (remove-all-atoms &self (included_file $_)) - (remove-all-symbols &self + (remove-all-atoms &self (dummy_clause_counter $_)) - (remove-all-symbols &self + (remove-all-atoms &self (pl2am_flag $_)) - (remove-all-symbols &self fail_flag) - (remove-all-symbols &self skip_code) - (remove-all-symbols &self ifdef_flag) - (remove-all-symbols &self + (remove-all-atoms &self fail_flag) + (remove-all-atoms &self skip_code) + (remove-all-atoms &self ifdef_flag) + (remove-all-atoms &self (domain_definition $_ $_)) - (add-symbol &self + (add-is-symbol &self (database_call (: SxxMachine.builtin call))) (assert-file-name $File) - (add-symbol &self + (add-is-symbol &self (dummy_clause_counter 0)) (assert-compile-opts $Opts) - (assert-default-decls))) -; - + (assert-default-decls))) - (= - (assert-file-name (/ $Directory $File)) + (= (assert-file-name (/ $Directory $File)) ( (set-det) - (add-symbol &self + (add-is-symbol &self (file_name $File)) - (add-symbol &self - (file_base $Directory)))) -; - - - (= - (assert-file-name $File) - (assert-file-name (/ '' $File))) -; + (add-is-symbol &self + (file_base $Directory)))) + (= (assert-file-name $File) + (assert-file-name (/ '' $File))) - (= - (build-file-name $File $File) - ( (get-symbols &self + (= (build-file-name $File $File) + ( (== (= - (file_base '') $_)) (set-det))) -; - - - (= - (build-file-name $File $File) - ( (= $File - (with_self $Package $ResourceName)) (set-det))) -; + (file_base '') $_) + (get-atoms &self)) (set-det))) + (= (build-file-name $File $File) + (= $File + (with_self $Package $ResourceName)) + (set-det)) - (= - (build-file-name $InFile $OutFile) - ( (get-symbols &self + (= (build-file-name $InFile $OutFile) + ( (== (= - (file_base $Directory) $_)) + (file_base $Directory) $_) + (get-atoms &self)) (list-to-string (:: $Directory / $InFile) $OutFile) - (set-det))) -; - - - (= - (build_file_name $File $File) True) -; + (set-det))) + (= (build_file_name $File $File) True) - (= - (assert-file-line $File $Line) - ( (remove-all-symbols &self - (file_line $_ $_)) (add-symbol &self (file_line $File $Line)))) -; - + (= (assert-file-line $File $Line) + ( (remove-all-atoms &self + (file_line $_ $_)) (add-is-symbol &self (file_line $File $Line)))) +; ;TODO keep stack of included - (= - (assert-default-decls) + (= (assert-default-decls) ( (builtin-meta-predicates $Pred $Arity $Mode) - (add-symbol &self + (add-is-symbol &self (meta_predicates $Pred $Arity $Mode)) - (fail))) -; - - (= assert_default_decls True) -; - + (fail))) + (= assert_default_decls True) - (= - (assert-compile-opts Nil) - (set-det)) -; - - (= - (assert-compile-opts (Cons $O $Os)) - ( (assert-copts $O) (assert-compile-opts $Os))) -; - + (= (assert-compile-opts Nil) + (set-det)) + (= (assert-compile-opts (Cons $O $Os)) + (assert-copts $O) + (assert-compile-opts $Os)) - (= - (assert-copts $O) - ( (get-symbols &self + (= (assert-copts $O) + ( (== (= - (pl2am_flag $O) $_)) (set-det))) -; - - (= - (assert-copts $O) + (pl2am_flag $O) $_) + (get-atoms &self)) (set-det))) + (= (assert-copts $O) ( (copt-expr $O) (set-det) - (add-symbol &self - (pl2am_flag $O)))) -; - - (= - (assert-copts $O) - ( (pl2am-error (:: $O is an invalid option for pl2am)) (fail))) -; - - - - (= - (copt_expr ed) True) -; - - (= - (copt_expr ac) True) -; - - (= - (copt_expr ie) True) -; - - (= - (copt_expr rc) True) -; - - (= - (copt_expr - (rc $_ $_)) True) -; - - (= - (copt_expr idx) True) -; - - (= - (copt_expr clo) True) -; - - (= - (copt_expr - (pif $_)) True) -; - + (add-is-symbol &self + (pl2am_flag $O)))) + (= (assert-copts $O) + (pl2am-error (:: $O is an invalid option for pl2am)) + (fail)) + + + (= (copt_expr ed) True) + (= (copt_expr ac) True) + (= (copt_expr ie) True) + (= (copt_expr rc) True) + (= (copt_expr (rc $_ $_)) True) + (= (copt_expr idx) True) + (= (copt_expr clo) True) + (= (copt_expr (pif $_)) True) ; -; +; ;; Post-init - - (= - (pl2am-postread) - ( (assert-import SxxMachine.lang) - (assert-import SxxMachine.builtin) - (assert-dummy-package) - (assert-dummy-public))) -; - + (= (pl2am-postread) + (assert-import SxxMachine.lang) + (assert-import SxxMachine.builtin) + (assert-dummy-package) + (assert-dummy-public)) - (= - (assert-dummy-package) - ( (get-symbols &self + (= (assert-dummy-package) + ( (== (= - (package_name $_) $_)) (set-det))) -; - - (= - (assert-dummy-package) - (add-symbol &self - (package_name user))) -; - + (package_name $_) $_) + (get-atoms &self)) (set-det))) + (= (assert-dummy-package) + (add-is-symbol &self + (package_name user))) - (= - (assert-dummy-public) - ( (get-symbols &self + (= (assert-dummy-public) + ( (== (= - (public_predicates $_ $_) $_)) (set-det))) -; - - (= - (assert-dummy-public) - (add-symbol &self - (public_predicates $_ $_))) -; - + (public_predicates $_ $_) $_) + (get-atoms &self)) (set-det))) + (= (assert-dummy-public) + (add-is-symbol &self + (public_predicates $_ $_))) ; -; +; ;; Expand constants - - (= - (expand-constants $InClause $OutClause) + (= (expand-constants $InClause $OutClause) ( (atom $InClause) - (get-symbols &self + (== (= - (compiler_constant $InClause $OutClause) $_)) - (set-det))) -; - - (= - (expand-constants $InClause $OutClause) - ( (compound $InClause) - (=.. $InClause $InList) - (pl2am-maplist expand-constants $InList $OutList) - (=.. $OutClause $OutList) - (set-det))) -; - - (= - (expand-constants $Clause $Clause) - (set-det)) -; - + (compiler_constant $InClause $OutClause) $_) + (get-atoms &self)) + (set-det))) + (= (expand-constants $InClause $OutClause) + (compound $InClause) + (=.. $InClause $InList) + (pl2am-maplist expand-constants $InList $OutList) + (=.. $OutClause $OutList) + (set-det)) + (= (expand-constants $Clause $Clause) + (set-det)) ; -; - - - (= - (assert-clause end-of-file) - (set-det)) -; - - (= - (assert-clause !(ifdef $C)) - ( (set-det) (assert-ifdef $C))) -; - - (= - (assert-clause !(ifndef $C)) - ( (set-det) (assert-ifndef $C))) -; - - (= - (assert-clause !(elsedef)) - ( (set-det) (assert-elsedef))) -; - - (= - (assert-clause !(enddef)) - ( (set-det) (assert-enddef))) -; - - (= - (assert-clause $_) - ( (get-symbols &self - (= skip_code $_)) (set-det))) -; - - (= - (assert-clause !(constant $C)) - ( (set-det) (assert-constant $C))) -; - - (= - (assert-clause $C) - ( (expand-constants $C $EC) (assert-clause- $EC))) -; - - - - (= - (assert-clause- !(include $F)) - ( (set-det) (assert-include-file $F))) -; - - (= - (assert-clause- !(include-resource $F)) - ( (set-det) (assert-include-file $F))) -; - - (= - (assert-clause- !(database $D)) - ( (set-det) (assert-database $D))) -; - - (= - (assert-clause- !(dynamic $G)) - ( (set-det) - (conj-to-list $G $G1) - (assert-dynamic-predicates $G1))) -; - - (= - (assert-clause- !(domain $D)) - ( (set-det) (assert-domain-definition $D))) -; - - (= - (assert-clause- !(module $M $PList)) - ( (set-det) - (assert-package $M) - (assert-public-predicates $PList))) -; - - (= - (assert-clause- !(meta-predicate $G)) - ( (set-det) - (conj-to-list $G $G1) - (assert-meta-predicates $G1))) -; - - (= - (assert-clause- !(package $G)) - ( (set-det) (assert-package $G))) -; - - (= - (assert-clause- !(public $G)) - ( (set-det) - (conj-to-list $G $G1) - (assert-public-predicates $G1))) -; - - (= - (assert-clause- !(import $G)) - ( (set-det) (assert-import $G))) -; - - (= - (assert-clause- !(mode $G)) - ( (set-det) (pl2am-message (:: '*** WARNING' mode declaration is not supported yet)))) -; - - (= - (assert-clause- !(multifile $G)) - ( (set-det) (pl2am-message (:: '*** WARNING' multifile declaration is not supported yet)))) -; - - (= - (assert-clause- !(block $G)) - ( (set-det) (pl2am-message (:: '*** WARNING' block declaration is not supported yet)))) -; - - (= - (assert-clause- !$G) - ( (set-det) - (call $G) - (assert-declarations $G))) -; - - (= - (assert-clause- (= (%init) $InitBody)) - ( (get-symbols &self +; ;; Assert Clauses + + (= (assert-clause end-of-file) + (set-det)) + (= (assert-clause !(ifdef $C)) + (set-det) + (assert-ifdef $C)) + (= (assert-clause !(ifndef $C)) + (set-det) + (assert-ifndef $C)) + (= (assert-clause !(elsedef)) + (set-det) + (assert-elsedef)) + (= (assert-clause !(enddef)) + (set-det) + (assert-enddef)) + (= (assert-clause $_) + ( (== + (= skip_code $_) + (get-atoms &self)) (set-det))) + (= (assert-clause !(constant $C)) + (set-det) + (assert-constant $C)) + (= (assert-clause $C) + (expand-constants $C $EC) + (assert-clause- $EC)) + + + (= (assert-clause- !(include $F)) + (set-det) + (assert-include-file $F)) + (= (assert-clause- !(include-resource $F)) + (set-det) + (assert-include-file $F)) + (= (assert-clause- !(database $D)) + (set-det) + (assert-database $D)) + (= (assert-clause- !(dynamic $G)) + (set-det) + (conj-to-list $G $G1) + (assert-dynamic-predicates $G1)) + (= (assert-clause- !(domain $D)) + (set-det) + (assert-domain-definition $D)) + (= (assert-clause- !(module $M $PList)) + (set-det) + (assert-package $M) + (assert-public-predicates $PList)) + (= (assert-clause- !(meta-predicate $G)) + (set-det) + (conj-to-list $G $G1) + (assert-meta-predicates $G1)) + (= (assert-clause- !(package $G)) + (set-det) + (assert-package $G)) + (= (assert-clause- !(public $G)) + (set-det) + (conj-to-list $G $G1) + (assert-public-predicates $G1)) + (= (assert-clause- !(import $G)) + (set-det) + (assert-import $G)) + (= (assert-clause- !(mode $G)) + (set-det) + (pl2am-message (:: '*** WARNING' mode declaration is not supported yet))) + (= (assert-clause- !(multifile $G)) + (set-det) + (pl2am-message (:: '*** WARNING' multifile declaration is not supported yet))) + (= (assert-clause- !(block $G)) + (set-det) + (pl2am-message (:: '*** WARNING' block declaration is not supported yet))) + (= (assert-clause- !$G) + (set-det) + (call $G) + (assert-declarations $G)) + (= (assert-clause- (= (%init) $InitBody)) + ( (== (= (pl2am_flag - (pif $PackageInitFolder)) $_)) + (pif $PackageInitFolder)) $_) + (get-atoms &self)) (set-det) - (write-init (= (%init) $InitBody)))) -; - - (= - (assert-clause- (= $Head (or $Body1 $Body2))) - ( (set-det) - (assert-clause- (= $Head $Body1)) - (assert-clause- (= $Head $Body2)))) -; - - (= - (assert-clause- $Clause) - ( (preprocess $Clause $Cl) (assert-cls $Cl))) -; - + (write-init (= (%init) $InitBody)))) + (= (assert-clause- (= $Head + (or $Body1 $Body2))) + (set-det) + (assert-clause- (= $Head $Body1)) + (assert-clause- (= $Head $Body2))) + (= (assert-clause- $Clause) + (preprocess $Clause $Cl) + (assert-cls $Cl)) ; -; - +; ;; Constant Declaration - (= - (assert-constant $C) + (= (assert-constant $C) ( (= $C (= $Name $_)) - (get-symbols &self + (== (= - (compiler_constant $Name $_) $_)) + (compiler_constant $Name $_) $_) + (get-atoms &self)) (set-det) (pl2am-error (:: compiler constant $Name is already defined)) - (fail))) -; - - (= - (assert-constant $C) + (fail))) + (= (assert-constant $C) ( (= $C (= $Name $Value)) - (add-symbol &self + (add-is-symbol &self (compiler_constant $Name $Value)) - (set-det))) -; - - (= - (assert-constant $C) - ( (pl2am-error (:: $C is an invalid constant declaration)) (fail))) -; - + (set-det))) + (= (assert-constant $C) + (pl2am-error (:: $C is an invalid constant declaration)) + (fail)) ; -; +; ;; Conditional compilation - - (= - (assert-ifdef $_) - ( (get-symbols &self - (= ifdef_flag $_)) + (= (assert-ifdef $_) + ( (== + (= ifdef_flag $_) + (get-atoms &self)) (set-det) (pl2am-error (:: nested ifdef are not supported)) - (fail))) -; - - (= - (assert-ifdef $C) - ( (not (get-symbols &self (= (compiler_constant $C $_) $_))) (add-symbol &self skip_code))) -; - - (= - (assert-ifdef $_) - (add-symbol &self ifdef_flag)) -; - + (fail))) + (= (assert-ifdef $C) + ( (not (== (= (compiler_constant $C $_) $_) (get-atoms &self))) (add-is-symbol &self skip_code))) + (= (assert-ifdef $_) + (add-is-symbol &self ifdef_flag)) - (= - (assert-ifndef $_) - ( (get-symbols &self - (= ifdef_flag $_)) + (= (assert-ifndef $_) + ( (== + (= ifdef_flag $_) + (get-atoms &self)) (set-det) (pl2am-error (:: nested ifdef are not supported)) - (fail))) -; - - (= - (assert-ifndef $C) - ( (get-symbols &self + (fail))) + (= (assert-ifndef $C) + ( (== (= - (compiler_constant $C $_) $_)) (add-symbol &self skip_code))) -; - - (= - (assert-ifndef $_) - (add-symbol &self ifdef_flag)) -; - - - - (= - (assert-elsedef) - ( (get-symbols &self - (= ifdef_flag $_)) - (get-symbols &self - (= skip_code $_)) + (compiler_constant $C $_) $_) + (get-atoms &self)) (add-is-symbol &self skip_code))) + (= (assert-ifndef $_) + (add-is-symbol &self ifdef_flag)) + + + (= (assert-elsedef) + ( (== + (= ifdef_flag $_) + (get-atoms &self)) + (== + (= skip_code $_) + (get-atoms &self)) (set-det) - (remove-all-symbols &self skip_code))) -; - - (= - (assert-elsedef) - ( (get-symbols &self - (= ifdef_flag $_)) + (remove-all-atoms &self skip_code))) + (= (assert-elsedef) + ( (== + (= ifdef_flag $_) + (get-atoms &self)) (set-det) - (add-symbol &self skip_code))) -; - - (= - (assert-elsedef) - ( (set-det) - (pl2am-error (:: elsedef without ifdef)) - (fail))) -; - + (add-is-symbol &self skip_code))) + (= (assert-elsedef) + (set-det) + (pl2am-error (:: elsedef without ifdef)) + (fail)) - (= - (assert-enddef) - ( (get-symbols &self - (= ifdef_flag $_)) + (= (assert-enddef) + ( (== + (= ifdef_flag $_) + (get-atoms &self)) (set-det) - (remove-all-symbols &self skip_code) - (remove-all-symbols &self ifdef_flag))) -; - - (= - (assert-enddef) - ( (set-det) - (pl2am-error (:: enddef without ifdef)) - (fail))) -; - + (remove-all-atoms &self skip_code) + (remove-all-atoms &self ifdef_flag))) + (= (assert-enddef) + (set-det) + (pl2am-error (:: enddef without ifdef)) + (fail)) ; -; +; ;; Include files - - (= - (assert-include-file $F) - ( (get-symbols &self + (= (assert-include-file $F) + ( (== (= - (file_name $BaseFile) $_)) + (file_name $BaseFile) $_) + (get-atoms &self)) (pl2am-resolve-file $BaseFile $F $IncludeFile) - (get-symbols &self + (== (= - (included_file $IncludeFile) $_)) - (set-det))) -; - - (= - (assert-include-file $F) - ( (get-symbols &self + (included_file $IncludeFile) $_) + (get-atoms &self)) + (set-det))) + (= (assert-include-file $F) + ( (== (= - (file_name $BaseFile) $_)) + (file_name $BaseFile) $_) + (get-atoms &self)) (pl2am-resolve-file $BaseFile $F $IncludeFile) - (add-symbol &self + (add-is-symbol &self (included_file $IncludeFile)) - (remove-all-symbols &self + (remove-all-atoms &self (file_name $_)) - (add-symbol &self + (add-is-symbol &self (file_name $IncludeFile)) (read-in-file $IncludeFile) - (remove-all-symbols &self + (remove-all-atoms &self (file_name $_)) - (add-symbol &self + (add-is-symbol &self (file_name $BaseFile)) - (set-det))) -; - - (= - (assert-include-file $F) - ( (get-symbols &self + (set-det))) + (= (assert-include-file $F) + ( (== (= - (file_name $BaseFile) $_)) + (file_name $BaseFile) $_) + (get-atoms &self)) (pl2am-error (:: failed to include file $F in $BaseFile)) - (fail))) -; - + (fail))) ; -; - +; ;; Database declaration - (= - (assert-database $D) + (= (assert-database $D) ( (= $D (= $Name $_)) - (get-symbols &self + (== (= - (domain_definition $Name $_) $_)) + (domain_definition $Name $_) $_) + (get-atoms &self)) (set-det) (pl2am-error (:: database $Name is already defined)) - (fail))) -; - - (= - (assert-database $D) - ( (= $D - (= $_ $Value)) - (assert-domain-definition $D) - (assert-database-dynamic $Value) - (set-det))) -; - - (= - (assert-database $D) - ( (pl2am-error (:: $D is an invalid database definition)) (fail))) -; - - - - (= - (assert-database-dynamic (or $Fact $Tail)) - ( (set-det) - (assert-database-dynamic $Fact) - (assert-database-dynamic $Tail))) -; - - - (= - (assert-database-dynamic $Fact) - ( (functor $Fact $Name $Arity) (assert-dynamic (/ $Name $Arity)))) -; - + (fail))) + (= (assert-database $D) + (= $D + (= $_ $Value)) + (assert-domain-definition $D) + (assert-database-dynamic $Value) + (set-det)) + (= (assert-database $D) + (pl2am-error (:: $D is an invalid database definition)) + (fail)) + + + (= (assert-database-dynamic (or $Fact $Tail)) + (set-det) + (assert-database-dynamic $Fact) + (assert-database-dynamic $Tail)) + + (= (assert-database-dynamic $Fact) + (functor $Fact $Name $Arity) + (assert-dynamic (/ $Name $Arity))) ; -; - - - (= - (assert-dynamic-predicates Nil) - (set-det)) -; - - (= - (assert-dynamic-predicates (Cons $G $Gs)) - ( (assert-dynamic $G) (assert-dynamic-predicates $Gs))) -; - - - - (= - (assert-dynamic $G) - ( (not (get-symbols &self (= (package_name SxxMachine.builtin) $_))) - (= $G - (/ $F $A)) - (functor $Head $F $A) - (system-predicate $Head) - (set-det) - (pl2am-error (:: can not redefine builtin predicate (/ $F $A))) - (fail))) -; - - (= - (assert-dynamic $G) +; ;; Dynamic Declaration + + (= (assert-dynamic-predicates Nil) + (set-det)) + (= (assert-dynamic-predicates (Cons $G $Gs)) + (assert-dynamic $G) + (assert-dynamic-predicates $Gs)) + + + (= (assert-dynamic $G) + (not (== (= (package_name SxxMachine.builtin) $_) (get-atoms &self))) + (= $G + (/ $F $A)) + (functor $Head $F $A) + (system-predicate $Head) + (set-det) + (pl2am-error (:: can not redefine builtin predicate (/ $F $A))) + (fail)) + (= (assert-dynamic $G) ( (= $G (/ $F $A)) - (get-symbols &self + (== (= - (dynamic_predicates $F $A $_) $_)) - (set-det))) -; - - (= - (assert-dynamic $G) + (dynamic_predicates $F $A $_) $_) + (get-atoms &self)) + (set-det))) + (= (assert-dynamic $G) ( (= $G (/ $F $A)) - (get-symbols &self + (== (= - (database_call $Call) $_)) - (add-symbol &self + (database_call $Call) $_) + (get-atoms &self)) + (add-is-symbol &self (dynamic_predicates $F $A $Call)) - (set-det))) -; - - (= - (assert-dynamic $G) - ( (pl2am-error (:: $G is an invalid dynamic declaration)) (fail))) -; - + (set-det))) + (= (assert-dynamic $G) + (pl2am-error (:: $G is an invalid dynamic declaration)) + (fail)) ; -; +; ;; Domain definitions - - (= - (assert-domain-definition $D) + (= (assert-domain-definition $D) ( (= $D (= $Name $_)) - (get-symbols &self + (== (= - (domain_definition $Name $_) $_)) + (domain_definition $Name $_) $_) + (get-atoms &self)) (set-det) (pl2am-error (:: domain $Name is already defined)) - (fail))) -; - - (= - (assert-domain-definition $D) + (fail))) + (= (assert-domain-definition $D) ( (= $D (= $Name $Value)) - (add-symbol &self + (add-is-symbol &self (domain_definition $Name $Value)) - (set-det))) -; - - (= - (assert-domain-definition $D) - ( (pl2am-error (:: $D is an invalid domain definition)) (fail))) -; - + (set-det))) + (= (assert-domain-definition $D) + (pl2am-error (:: $D is an invalid domain definition)) + (fail)) ; -; - +; ;; Meta Predicates Declaration - (= - (assert-meta-predicates Nil) - (set-det)) -; - - (= - (assert-meta-predicates (Cons $G $Gs)) - ( (assert-meta $G) (assert-meta-predicates $Gs))) -; - + (= (assert-meta-predicates Nil) + (set-det)) + (= (assert-meta-predicates (Cons $G $Gs)) + (assert-meta $G) + (assert-meta-predicates $Gs)) - (= - (assert-meta $G) + (= (assert-meta $G) ( (functor $G $F $A) - (get-symbols &self + (== (= - (meta_predicates $F $A $_) $_)) - (set-det))) -; - - (= - (assert-meta $G) + (meta_predicates $F $A $_) $_) + (get-atoms &self)) + (set-det))) + (= (assert-meta $G) ( (functor $G $F $A) (=.. $G (Cons $_ $M)) (mode-expr $M) (set-det) - (add-symbol &self - (meta_predicates $F $A $M)))) -; - - (= - (assert-meta $G) - ( (pl2am-error (:: $G is an invalid meta-predicate declaration)) (fail))) -; - + (add-is-symbol &self + (meta_predicates $F $A $M)))) + (= (assert-meta $G) + (pl2am-error (:: $G is an invalid meta-predicate declaration)) + (fail)) ; -; +; ;; Package Declaration - - (= - (assert-package $G) - ( (get-symbols &self + (= (assert-package $G) + ( (== (= - (package_name $G1) $_)) + (package_name $G1) $_) + (get-atoms &self)) (\== $G $G1) (set-det) (pl2am-error (:: duplicate package declarations : $G1 and $G)) - (fail))) -; - - (= - (assert-package $G) + (fail))) + (= (assert-package $G) ( (atom $G) (set-det) - (add-symbol &self + (add-is-symbol &self (package_name $G)) - (remove-all-symbols &self - (import_package $G $_)))) -; - - (= - (assert-package $G) - ( (pl2am-error (:: $G is invalid package declaration)) (fail))) -; - + (remove-all-atoms &self + (import_package $G $_)))) + (= (assert-package $G) + (pl2am-error (:: $G is invalid package declaration)) + (fail)) ; -; - +; ;; Public Declaration - (= - (assert-public-predicates Nil) - (set-det)) -; - - (= - (assert-public-predicates (Cons $G $Gs)) - ( (assert-public $G) (assert-public-predicates $Gs))) -; - + (= (assert-public-predicates Nil) + (set-det)) + (= (assert-public-predicates (Cons $G $Gs)) + (assert-public $G) + (assert-public-predicates $Gs)) - (= - (assert-public (/ $F $A)) + (= (assert-public (/ $F $A)) ( (predspec-expr (/ $F $A)) - (get-symbols &self + (== (= - (public_predicates $F $A) $_)) - (set-det))) -; - - (= - (assert-public (/ $F $A)) - ( (predspec-expr (/ $F $A)) (add-symbol &self (public_predicates $F $A)))) -; - + (public_predicates $F $A) $_) + (get-atoms &self)) + (set-det))) + (= (assert-public (/ $F $A)) + ( (predspec-expr (/ $F $A)) (add-is-symbol &self (public_predicates $F $A)))) ; -; - - - (= - (assert-import $G) - ( (atom $G) - (set-det) - (assert-impt $G *))) -; - - (= - (assert-import (with_self $M $P)) - ( (atom $M) - (or - (predspec-expr $P) - (atom $P)) - (set-det) - (assert-impt $M $P))) -; - - (= - (assert-import $G) - ( (pl2am-error (:: $G is invalid import declaration)) (fail))) -; - - - - (= - (assert-impt $M $P) - ( (get-symbols &self +; ;; Import Declaration + + (= (assert-import $G) + (atom $G) + (set-det) + (assert-impt $G *)) + (= (assert-import (with_self $M $P)) + (atom $M) + (or + (predspec-expr $P) + (atom $P)) + (set-det) + (assert-impt $M $P)) + (= (assert-import $G) + (pl2am-error (:: $G is invalid import declaration)) + (fail)) + + + (= (assert-impt $M $P) + ( (== (= - (package_name $M) $_)) (set-det))) -; - - (= - (assert-impt $M $P) - ( (get-symbols &self + (package_name $M) $_) + (get-atoms &self)) (set-det))) + (= (assert-impt $M $P) + ( (== (= - (import_package $M $P0) $_)) + (import_package $M $P0) $_) + (get-atoms &self)) (or (== $P0 *) (== $P0 $P)) - (set-det))) -; - - (= - (assert-impt $M $P) - (add-symbol &self - (import_package $M $P))) -; - + (set-det))) + (= (assert-impt $M $P) + (add-is-symbol &self + (import_package $M $P))) ; -; - +; ;; Assert Declaration (:- G) - (= - (assert-declarations $G) - ( (get-symbols &self + (= (assert-declarations $G) + ( (== (= - (internal_declarations $G) $_)) (set-det))) -; - - (= - (assert-declarations $G) - (add-symbol &self - (internal_declarations $G))) -; - + (internal_declarations $G) $_) + (get-atoms &self)) (set-det))) + (= (assert-declarations $G) + (add-is-symbol &self + (internal_declarations $G))) ; -; +; ;; Assert Cluase - - (= - (assert-cls (= $Head $Body)) + (= (assert-cls (= $Head $Body)) ( (set-det) (assert-predicate $Head) - (add-symbol &self - (internal_clause $Head $Body)))) -; - - (= - (assert-cls $Head) + (add-is-symbol &self + (internal_clause $Head $Body)))) + (= (assert-cls $Head) ( (set-det) (assert-predicate $Head) - (add-symbol &self - (internal_clause $Head true)))) -; - - - - (= - (assert-predicate $Head) - ( (not (get-symbols &self (= (package_name SxxMachine.builtin) $_))) - (system-predicate $Head) - (set-det) - (functor $Head $Functor $Arity) - (pl2am-error (:: can not redefine builtin predicate (/ $Functor $Arity))) - (fail))) -; - - (= - (assert-predicate $Head) + (add-is-symbol &self + (internal_clause $Head true)))) + + + (= (assert-predicate $Head) + (not (== (= (package_name SxxMachine.builtin) $_) (get-atoms &self))) + (system-predicate $Head) + (set-det) + (functor $Head $Functor $Arity) + (pl2am-error (:: can not redefine builtin predicate (/ $Functor $Arity))) + (fail)) + (= (assert-predicate $Head) ( (functor $Head $Functor $Arity) - (get-symbols &self + (== (= - (internal_predicates $Functor $Arity) $_)) - (set-det))) -; - - (= - (assert-predicate $Head) - ( (functor $Head $Functor $Arity) (add-symbol &self (internal_predicates $Functor $Arity)))) -; - + (internal_predicates $Functor $Arity) $_) + (get-atoms &self)) + (set-det))) + (= (assert-predicate $Head) + ( (functor $Head $Functor $Arity) (add-is-symbol &self (internal_predicates $Functor $Arity)))) ; -; +; ;; Preprocess - - (= - (preprocess $Cl0 $Cl) - ( (get-symbols &self + (= (preprocess $Cl0 $Cl) + ( (== (= - (pl2am_flag ed) $_)) + (pl2am_flag ed) $_) + (get-atoms &self)) (set-det) (expand-term $Cl0 $Cl1) - (eliminate-disjunction $Cl1 $Cl))) -; - - (= - (preprocess $Cl0 $Cl) - (expand-term $Cl0 $Cl)) -; - + (eliminate-disjunction $Cl1 $Cl))) + (= (preprocess $Cl0 $Cl) + (expand-term $Cl0 $Cl)) - (= - (eliminate-disjunction $Cl0 $Cl) - ( (eliminate-disj $Cl0 $Cl $DummyCls) (assert-dummy-clauses $DummyCls))) -; - + (= (eliminate-disjunction $Cl0 $Cl) + (eliminate-disj $Cl0 $Cl $DummyCls) + (assert-dummy-clauses $DummyCls)) - (= - (assert-dummy-clauses Nil) - (set-det)) -; - - (= - (assert-dummy-clauses (Cons $C $Cs)) - ( (assert-clause $C) (assert-dummy-clauses $Cs))) -; - + (= (assert-dummy-clauses Nil) + (set-det)) + (= (assert-dummy-clauses (Cons $C $Cs)) + (assert-clause $C) + (assert-dummy-clauses $Cs)) - (= - (compile-all-predicates $Out) - ( (get-symbols &self + (= (compile-all-predicates $Out) + ( (== (= - (internal_declarations $G) $_)) + (internal_declarations $G) $_) + (get-atoms &self)) (writeq $Out !$G) (write $Out .) (nl $Out) (fail))) -; - - (= - (compile-all-predicates $_) - ( (findall - (/ $Functor $Arity) - (dynamic-predicates $Functor $Arity - (with_self - (SxxMachine.builtin *) - (call))) $PredSpecs) - (assert-init-clauses $PredSpecs) - (fail))) -; - - (= - (compile-all-predicates $Out) - ( (get-symbols &self +; /***************************************************************** Compile MeTTa Program *****************************************************************/ +; ; output declarations (ex. op/3) + (= (compile-all-predicates $_) + (findall + (/ $Functor $Arity) + (dynamic-predicates $Functor $Arity + (with_self + (SxxMachine.builtin *) + (call))) $PredSpecs) + (assert-init-clauses $PredSpecs) + (fail)) +; ; treat dynamic declaration + (= (compile-all-predicates $Out) + ( (== (= - (internal_predicates $Functor $Arity) $_)) + (internal_predicates $Functor $Arity) $_) + (get-atoms &self)) (compile-predicate $Functor $Arity $Instructions Nil) (write-asm $Out $Instructions) (nl $Out) (fail))) -; +; ; compile predicate + (= (compile-all-predicates $Out) + (write-domain-definitions $Out)) + (= (compile-all-predicates $Out) + (nl $Out)) + + + (= (write-asm $_ Nil) + (set-det)) + (= (write-asm $Out (Cons $Instruction $Instructions)) + (set-det) + (write-asm $Out $Instruction) + (write-asm $Out $Instructions)) + (= (write-asm $Out (begin-predicate $P $FA)) + (set-det) + (writeq $Out + (begin-predicate $P $FA)) + (write $Out .) + (nl $Out)) + (= (write-asm $Out (end-predicate $P $FA)) + (set-det) + (writeq $Out + (end-predicate $P $FA)) + (write $Out .) + (nl $Out)) + (= (write-asm $Out (comment $Comment0)) + (set-det) + (copy-term $Comment0 $Comment) + (numbervars $Comment 0 $_) + (tab $Out 8) + (writeq $Out + (comment $Comment)) + (write $Out .) + (nl $Out)) + (= (write-asm $Out (with_self $Label $Instruction)) + (set-det) + (writeq $Out $Label) + (write $Out :) + (nl $Out) + (write-asm $Out $Instruction)) + (= (write-asm $Out $Instruction) + (tab $Out 8) + (writeq $Out $Instruction) + (write $Out .) + (nl $Out)) + + + + (= (write-domain-definitions $Out) + ( (== + (= + (package_name $PackageName) $_) + (get-atoms &self)) + (== + (= + (domain_definition $Name $Value) $_) + (get-atoms &self)) + (= $AssertTerm + ! (add-is-symbol &self + (domain_definition + (= (: $PackageName $Name) $Value)))) + (writeq $Out $AssertTerm) + (write $Out .) + (nl $Out) + (fail))) + (= (write_domain_definitions $_) True) + + + (= (write-init $InitPredicate) + ( (== + (= + (package_name $PackageName) $_) + (get-atoms &self)) + (== + (= + (pl2am_flag + (pif $PackageInitFolder)) $_) + (get-atoms &self)) + (list-to-string + (:: $PackageInitFolder / $PackageName .init.pl) $File) + (with-mutex $PackageName + (write-init-file $File $PackageName $InitPredicate)))) - (= - (compile-all-predicates $Out) - (write-domain-definitions $Out)) -; + (= (write_init $_) True) - (= - (compile-all-predicates $Out) - (nl $Out)) -; + + (= (write-init-file $File $PackageName $InitPredicate) + (not (exists-file $File)) + (set-det) + (write-init-predicate $File $PackageName $InitPredicate)) + + (= (write-init-file $File $PackageName $InitPredicate) + (read-init-predicate $File $InPackageName $InInitPredicate) + (= $InitPredicate + (= $InitHead $InitBody)) + (= $InInitPredicate + (= $InInitHead $InInitBody)) + (conj-union $InitBody $InInitBody $NewBody) + (\== $NewBody $InInitBody) + (write-init-predicate $File $PackageName + (= $InitHead $NewBody))) +; ;PackageName == InPackageName, +; ;InitHead == InInitHead, + (= (write_init_file $_ $_ $_) True) - (= - (write-asm $_ Nil) - (set-det)) -; + (= (conj-member $X $X) + (set-det)) + (= (conj-member $X (, $X $_)) + (set-det)) + (= (conj-member $X (, $_ $Y)) + (conj-member $X $Y)) - (= - (write-asm $Out - (Cons $Instruction $Instructions)) - ( (set-det) - (write-asm $Out $Instruction) - (write-asm $Out $Instructions))) -; + + (= (conj-union (, $X $L) $Y $O) + (conj-member $X $Y) + (set-det) + (conj-union $L $Y $O)) - (= - (write-asm $Out - (begin-predicate $P $FA)) - ( (set-det) - (writeq $Out - (begin-predicate $P $FA)) - (write $Out .) - (nl $Out))) -; - - (= - (write-asm $Out - (end-predicate $P $FA)) - ( (set-det) - (writeq $Out - (end-predicate $P $FA)) - (write $Out .) - (nl $Out))) -; - - (= - (write-asm $Out - (comment $Comment0)) - ( (set-det) - (copy-term $Comment0 $Comment) - (numbervars $Comment 0 $_) - (tab $Out 8) - (writeq $Out - (comment $Comment)) - (write $Out .) - (nl $Out))) -; - - (= - (write-asm $Out - (with_self $Label $Instruction)) - ( (set-det) - (writeq $Out $Label) - (write $Out :) - (nl $Out) - (write-asm $Out $Instruction))) -; - - (= - (write-asm $Out $Instruction) - ( (tab $Out 8) - (writeq $Out $Instruction) - (write $Out .) - (nl $Out))) -; - - - - - (= - (write-domain-definitions $Out) - ( (get-symbols &self - (= - (package_name $PackageName) $_)) - (get-symbols &self - (= - (domain_definition $Name $Value) $_)) - (= $AssertTerm - ! (add-symbol &self - (domain_definition - (= - (: $PackageName $Name) $Value)))) - (writeq $Out $AssertTerm) - (write $Out .) - (nl $Out) - (fail))) -; - - (= - (write_domain_definitions $_) True) -; - - - - (= - (write-init $InitPredicate) - ( (get-symbols &self - (= - (package_name $PackageName) $_)) - (get-symbols &self - (= - (pl2am_flag - (pif $PackageInitFolder)) $_)) - (list-to-string - (:: $PackageInitFolder / $PackageName .init.pl) $File) - (with-mutex $PackageName - (write-init-file $File $PackageName $InitPredicate)))) -; - - - (= - (write_init $_) True) -; - - - - (= - (write-init-file $File $PackageName $InitPredicate) - ( (not (exists-file $File)) - (set-det) - (write-init-predicate $File $PackageName $InitPredicate))) -; - - - (= - (write-init-file $File $PackageName $InitPredicate) - ( (read-init-predicate $File $InPackageName $InInitPredicate) - (= $InitPredicate - (= $InitHead $InitBody)) - (= $InInitPredicate - (= $InInitHead $InInitBody)) - (conj-union $InitBody $InInitBody $NewBody) - (\== $NewBody $InInitBody) - (write-init-predicate $File $PackageName - (= $InitHead $NewBody)))) -; - - - (= - (write_init_file $_ $_ $_) True) -; - - - - (= - (conj-member $X $X) - (set-det)) -; - - (= - (conj-member $X - (, $X $_)) - (set-det)) -; - - (= - (conj-member $X - (, $_ $Y)) - (conj-member $X $Y)) -; - - - - (= - (conj-union - (, $X $L) $Y $O) - ( (conj-member $X $Y) - (set-det) - (conj-union $L $Y $O))) -; - - - (= - (conj-union - (, $X $L) $Y $O) - ( (set-det) (conj-union $L (, $X $Y) $O))) -; - - - (= - (conj-union $X $Y $Y) - ( (conj-member $X $Y) (set-det))) -; - - (= - (conj_union $X $Y - (, $X $Y)) True) -; + (= (conj-union (, $X $L) $Y $O) + (set-det) + (conj-union $L + (, $X $Y) $O)) + (= (conj-union $X $Y $Y) + (conj-member $X $Y) + (set-det)) + (= (conj_union $X $Y (, $X $Y)) True) - (= - (read-init-predicate $File $PackageName $InitPredicate) - ( (open $File read $In) - (read-clause- $In $Package) - (read-clause- $In $InitPredicate) - (close $In) - (= $Package - !(package $PackageName)))) -; - + (= (read-init-predicate $File $PackageName $InitPredicate) + (open $File read $In) + (read-clause- $In $Package) + (read-clause- $In $InitPredicate) + (close $In) + (= $Package + !(package $PackageName))) - (= - (write-init-predicate $File $PackageName $InitPredicate) - ( (open $File write $Stream) - (nl $Stream) - (write $Stream ':- package '') - (write $Stream $PackageName) - (write $Stream '.) - (nl $Stream) - (writeq $Stream $InitPredicate) - (write $Stream .) - (nl $Stream) - (close $Stream))) -; - + (= (write-init-predicate $File $PackageName $InitPredicate) + (open $File write $Stream) + (nl $Stream) + (write $Stream ':- package '') + (write $Stream $PackageName) + (write $Stream '.) + (nl $Stream) + (writeq $Stream $InitPredicate) + (write $Stream .) + (nl $Stream) + (close $Stream)) - (= - (assert-init-clauses Nil) + (= (assert-init-clauses Nil) (set-det)) -; - - (= - (assert-init-clauses $PredSpecs) - ( (collect-init-cls $PredSpecs $Cls) - (assert-init-cls $Cls) - (set-det))) -; - +; /**************************************************************** Treat Dynamic Declaration ****************************************************************/ + (= (assert-init-clauses $PredSpecs) + (collect-init-cls $PredSpecs $Cls) + (assert-init-cls $Cls) + (set-det)) - (= - (collect-init-cls Nil Nil) - (set-det)) -; - - (= - (collect-init-cls - (Cons - (/ $F $A) $FAs) - (Cons $Cls $Cls1)) - ( (get-symbols &self + (= (collect-init-cls Nil Nil) + (set-det)) + (= (collect-init-cls (Cons (/ $F $A) $FAs) (Cons $Cls $Cls1)) + ( (== (= - (internal_predicates $F $A) $_)) + (internal_predicates $F $A) $_) + (get-atoms &self)) (set-det) (functor $Head $F $A) (findall - (add-symbol &self + (add-is-symbol &self (:- $Head $Body)) (internal-clause $Head $Body) $Cls) - (remove-all-symbols &self + (remove-all-atoms &self (internal_predicates $F $A)) - (remove-all-symbols &self + (remove-all-atoms &self (internal_clause $Head $_)) - (collect-init-cls $FAs $Cls1))) -; - + (collect-init-cls $FAs $Cls1))) ; -; - - (= - (collect-init-cls - (Cons $FA $FAs) - (Cons - ($new-indexing-hash $P $FA $_) $Cls)) - ( (get-symbols &self +; collect_init_cls([FA|FAs], [hash_put(P,FA,[])|Cls]) :- + (= (collect-init-cls (Cons $FA $FAs) (Cons ($new-indexing-hash $P $FA $_) $Cls)) + ( (== (= - (package_name $P) $_)) + (package_name $P) $_) + (get-atoms &self)) (set-det) - (collect-init-cls $FAs $Cls))) -; - + (collect-init-cls $FAs $Cls))) - (= - (assert-init-cls Nil) - (set-det)) -; - - (= - (assert-init-cls $Cls) - ( (list-to-conj $Cls $Body) (assert-clause (= (%init) $Body)))) -; - - - - (= - (--> - (compile_predicate $Functor $Arity) - (, - { (functor $Head $Functor $Arity) } - (, - { (findall - (:- $Head $Body) - (internal_clause $Head $Body) $Clauses) } - (, - { (clause - (package_name $P) $_) } - (, - ( (begin_predicate $P - (/ $Functor $Arity))) - (, - (generate_info $Functor $Arity) - (, generate_import - (, - (compile_pred $Clauses - (/ $Functor $Arity)) - ( (end_predicate $P - (/ $Functor $Arity))))))))))) True) -; + (= (assert-init-cls Nil) + (set-det)) + (= (assert-init-cls $Cls) + (list-to-conj $Cls $Body) + (assert-clause (= (%init) $Body))) + + (= (--> (compile_predicate $Functor $Arity) (, {(functor $Head $Functor $Arity) } (, {(findall (:- $Head $Body) (internal_clause $Head $Body) $Clauses) } (, {(clause (package_name $P) $_) } (, ((begin_predicate $P (/ $Functor $Arity))) (, (generate_info $Functor $Arity) (, generate_import (, (compile_pred $Clauses (/ $Functor $Arity)) ((end_predicate $P (/ $Functor $Arity))))))))))) True) +; /**************************************************************** Compile Predicate ****************************************************************/ ; -; - - (= - (--> - (compile_pred () $_) - (, () !)) True) -; - - (= - (--> - (compile_pred - ($Clause) $FA) - (, ! - (, - { (check_modifier $FA $MF) } - (, - ( (: - (main $FA $MF) ())) - (, - ($PutGroundTerm) - (, - ( (: $FA ())) - (, - ( (comment $Clause)) - (, - (setB0) - (, - ($DeclLocalVars) - (, - { (= $FA - (/ $_ $A)) } - (, - (set_arguments 1 $A arg a set) - (, - { (= $GTI0 - (1 () ())) } - (, - (compile_clause $Clause $GTI0 $GTI $LTI) - (, - { (, - (= $GTI - ($_ $_ $PutGroundTerm0)) - (pl2am_rev $PutGroundTerm0 $PutGroundTerm)) } - { (, - (= $LTI - (Cons $XN - (Cons $_ - (Cons $PN $_)))) - (generate_var_decl - (1 1) - ($XN $PN) $DeclLocalVars ())) })))))))))))))) True) -; - - (= - (--> - (compile_pred $Clauses $FA) - (, - { (check_modifier $FA $MF) } - (, - ( (: - (main $FA $MF) ())) - (, - ($PutGroundTerm) - (, - ($OPT1) - (, - ($PutLabel) - (, - ($NewHash) - (, - ($PutHash) - (, - ( (: $FA ())) - (, - { (= $FA - (/ $Functor $Arity)) } - (, - (set_arguments 1 $Arity arg ea set) - (, - ( (set cont econt)) - (, - ($OPT2) - (, - ($OPT3) - (, - (setB0) - (, - (generate_switch $Clauses $FA $GLI) - (, - { (= $GTI0 - (1 () ())) } - (, - (compile_pred2 $Clauses $FA 1 $GTI0 $GTI) - (, - { (, - (= $GTI - ($_ $SAlloc $PutGroundTerm0)) - (pl2am_rev $PutGroundTerm0 $PutGroundTerm)) } - (, - { (= $GLI - ($PutLabel $Hash0)) } - (, - { (replace_hash_keys $Hash0 $SAlloc $NewHash $PutHash0) } - (, - { (; - (-> - (== $PutHash0 ()) - (= $PutHash ())) - (= $PutHash - (static $PutHash0))) } - { (; - (-> - (clause - (pl2am_flag - (rc $Functor $Arity)) $_) - (, - (= $OPT1 - (label - (+ $FA top))) - (, - (= $OPT2 - (goto - (+ $FA top))) - (= $OPT3 - (: - (+ $FA top) ()))))) - (, - (= $OPT1 ()) - (, - (= $OPT2 ()) - (= $OPT3 ())))) })))))))))))))))))))))) True) -; - - - (= - (--> - (compile_pred2 () $_ $_ $GTI $GTI) !) True) -; - - (= - (--> - (compile_pred2 - (Cons $Clause $Clauses) $FA $N $GTI0 $GTI) - (, - ( (: - (+ $FA $N) ())) - (, - ( (comment $Clause)) - (, - ($DeclLocalVars) - (, - ( (decl_pred_vars - (cont))) - (, - { (= $FA - (/ $_ $Arity)) } - (, - (set_arguments 1 $Arity ea a set) - (, - ( (set econt cont)) - (, - (compile_clause $Clause $GTI0 $GTI1 $LTI) - (, - { (is $N1 - (+ $N 1)) } - (, - (compile_pred2 $Clauses $FA $N1 $GTI1 $GTI) - { (, - (= $LTI - (Cons $XN - (Cons $_ - (Cons $PN $_)))) - (generate_var_decl - (1 1) - ($XN $PN) $DeclLocalVars ())) }))))))))))) True) -; - +; ;; Program Code + (= (--> (compile_pred () $_) (, () !)) True) + (= (--> (compile_pred ($Clause) $FA) (, ! (, {(check_modifier $FA $MF) } (, ((: (main $FA $MF) ())) (, ($PutGroundTerm) (, ((: $FA ())) (, ((comment $Clause)) (, (setB0) (, ($DeclLocalVars) (, {(= $FA + (/ $_ $A)) } (, (set_arguments 1 $A arg a set) (, {(= $GTI0 + (1 () ())) } (, (compile_clause $Clause $GTI0 $GTI $LTI) (, {(, (= $GTI + ($_ $_ $PutGroundTerm0)) (pl2am_rev $PutGroundTerm0 $PutGroundTerm)) } {(, (= $LTI + (Cons $XN + (Cons $_ + (Cons $PN $_)))) (generate_var_decl (1 1) ($XN $PN) $DeclLocalVars ())) })))))))))))))) True) +; ; checks public or non-public +; ; generates put instructions of ground terms +; ; set B0 register for cut +; ; generates the declarations of local variables +; ; set arg(N) to a(N). +; ; GTI0 = [SN,SAlloc,PutGroundTerm] + (= (--> (compile_pred $Clauses $FA) (, {(check_modifier $FA $MF) } (, ((: (main $FA $MF) ())) (, ($PutGroundTerm) (, ($OPT1) (, ($PutLabel) (, ($NewHash) (, ($PutHash) (, ((: $FA ())) (, {(= $FA + (/ $Functor $Arity)) } (, (set_arguments 1 $Arity arg ea set) (, ((set cont econt)) (, ($OPT2) (, ($OPT3) (, (setB0) (, (generate_switch $Clauses $FA $GLI) (, {(= $GTI0 + (1 () ())) } (, (compile_pred2 $Clauses $FA 1 $GTI0 $GTI) (, {(, (= $GTI + ($_ $SAlloc $PutGroundTerm0)) (pl2am_rev $PutGroundTerm0 $PutGroundTerm)) } (, {(= $GLI + ($PutLabel $Hash0)) } (, {(replace_hash_keys $Hash0 $SAlloc $NewHash $PutHash0) } (, {(; (-> (== $PutHash0 ()) (= $PutHash )) (= $PutHash + (static $PutHash0))) } {(; (-> (clause (pl2am_flag (rc $Functor $Arity)) $_) (, (= $OPT1 + (label + (+ $FA top))) (, (= $OPT2 + (goto + (+ $FA top))) (= $OPT3 + (: + (+ $FA top) ()))))) (, (= $OPT1 ) (, (= $OPT2 ) (= $OPT3 )))) })))))))))))))))))))))) True) +; ; checks public or non-public +; ; generates ground terms +; ; generates label declarations +; ; generates new_hash +; ; generates pub_hash +; ; +; ; set arg(N) to engine.areg(N) +; ; set cont to engine.cont +; ; set B0 register for cut +; ; generates control and indexing instructions. +; ; GTI0 = [SN,SAlloc,PutGroundTerm] +; ; +; ; replace the hash key with s(i), si(i), or sf(i) +; ; generate code for the recursize call optimization + + (= (--> (compile_pred2 () $_ $_ $GTI $GTI) !) True) + (= (--> (compile_pred2 (Cons $Clause $Clauses) $FA $N $GTI0 $GTI) (, ((: (+ $FA $N) ())) (, ((comment $Clause)) (, ($DeclLocalVars) (, ((decl_pred_vars (cont))) (, {(= $FA + (/ $_ $Arity)) } (, (set_arguments 1 $Arity ea a set) (, ((set econt cont)) (, (compile_clause $Clause $GTI0 $GTI1 $LTI) (, {(is $N1 (+ $N 1)) } (, (compile_pred2 $Clauses $FA $N1 $GTI1 $GTI) {(, (= $LTI + (Cons $XN + (Cons $_ + (Cons $PN $_)))) (generate_var_decl (1 1) ($XN $PN) $DeclLocalVars ())) }))))))))))) True) +; ; generates the declarations of local variables +; ; set engine.areg(N) to a(N). +; ; set engine.cont to cont ; -; - - (= - (--> - (generate_switch $Clauses $FA - ($Label $Hash)) - (, - { (generate_switch0 $Clauses $FA $Instrs ()) } - (, - (generate_bp_label $Instrs - (+ $FA sub) 1 $Ls0 $SWTs) - (, - { (; - (-> - (retract fail_flag) - (= $Ls1 - (Cons - (label - (/ fail 0)) $Ls0))) - (= $Ls1 $Ls0)) } - (, - { (length $Clauses $N) } - (, - { (generate_cl_label $FA 1 $N $Ls2) } - (, - { (pl2am_append $Ls1 $Ls2 $Label) } - { (gen_hash $SWTs $Hash ()) }))))))) True) -; - - - (= - (--> - (generate_switch0 $Clauses $FA) - (, - { (get_indices $Clauses $FA 1 $Is) } - (generate_switch1 $Is $FA))) True) -; - +; ;; Control and Indexing instructions + (= (--> (generate_switch $Clauses $FA ($Label $Hash)) (, {(generate_switch0 $Clauses $FA $Instrs ()) } (, (generate_bp_label $Instrs (+ $FA sub) 1 $Ls0 $SWTs) (, {(; (-> (retract fail_flag) (= $Ls1 + (Cons + (label + (/ fail 0)) $Ls0))) (= $Ls1 $Ls0)) } (, {(length $Clauses $N) } (, {(generate_cl_label $FA 1 $N $Ls2) } (, {(pl2am_append $Ls1 $Ls2 $Label) } {(gen_hash $SWTs $Hash ()) }))))))) True) +; ; generates try, retry, trust, switch_on_term, and switch_on_hash +; ; generates sub-labels for BP +; ; generates fail label (fail_flag may be asserted by generate_switch0/4) +; ; generates labels for clauses +; ; generates new_hash and put_hash instructions for switch_on_hash + + (= (--> (generate_switch0 $Clauses $FA) (, {(get_indices $Clauses $FA 1 $Is) } (generate_switch1 $Is $FA))) True) ; -; - - (= - (--> - (generate_switch1 $Is $FA) - (, - { (= $FA - (/ $_ 0)) } - (, ! - (generate_tries $Is)))) True) -; - - (= - (--> - (generate_switch1 $Is $_) - (, - { (all_variable_indices $Is) } - (, ! - (generate_tries $Is)))) True) -; - - (= - (--> - (generate_switch1 $Is $FA) - (, - ( (switch_on_term $LV $LI $LF $LC $LS $LL)) - (, - (generate_sw $Is $FA var $LV () $PIs0) - (, - (generate_sw $Is $FA int $LI $PIs0 $PIs1) - (, - (generate_sw $Is $FA flo $LF $PIs1 $PIs2) - (, - (generate_sw $Is $FA con $LC $PIs2 $PIs3) - (, - (generate_sw $Is $FA str $LS $PIs3 $PIs4) - (generate_sw $Is $FA lis $LL $PIs4 $_)))))))) True) -; - - - (= - (--> - (generate_sw $Is $FA $Tag $L $PIs0 $PIs) - (, - { (select_indices $Is $Tag $Is1) } - (generate_sw1 $Is1 $FA $Tag $L $PIs0 $PIs))) True) -; +; ;; 1st. Indexing + (= (--> (generate_switch1 $Is $FA) (, {(= $FA + (/ $_ 0)) } (, ! (generate_tries $Is)))) True) + (= (--> (generate_switch1 $Is $_) (, {(all_variable_indices $Is) } (, ! (generate_tries $Is)))) True) + (= (--> (generate_switch1 $Is $FA) (, ((switch_on_term $LV $LI $LF $LC $LS $LL)) (, (generate_sw $Is $FA var $LV () $PIs0) (, (generate_sw $Is $FA int $LI $PIs0 $PIs1) (, (generate_sw $Is $FA flo $LF $PIs1 $PIs2) (, (generate_sw $Is $FA con $LC $PIs2 $PIs3) (, (generate_sw $Is $FA str $LS $PIs3 $PIs4) (generate_sw $Is $FA lis $LL $PIs4 $_)))))))) True) + (= (--> (generate_sw $Is $FA $Tag $L $PIs0 $PIs) (, {(select_indices $Is $Tag $Is1) } (generate_sw1 $Is1 $FA $Tag $L $PIs0 $PIs))) True) ; -; - - (= - (--> - (generate_sw1 () $_ $_ - (/ fail 0) $PIs $PIs) - (, ! - {assert_fail })) True) -; - - (= - (--> - (generate_sw1 - ($I) $_ $_ $L $PIs $PIs) - (, ! - { (= $I - (Cons $L $_)) })) True) -; - - (= - (--> - (generate_sw1 $Is $FA $Tag $L $PIs0 $PIs) - (, - { (no_switch_on_hash $Is $Tag) } - (, ! - (generate_sw2 $Is $FA $Tag $L $PIs0 $PIs)))) True) -; - - (= - (--> - (generate_sw1 $Is $FA $Tag - (+ $FA $Tag) $PIs0 $PIs) - (, - (generate_sw $Is $FA nil $L $PIs0 $PIs) - (, - { (count_unique_hash $Is $Size $Keys) } - (, - ( (: - (+ $FA $Tag) - (switch_on_hash $Tag $Size $L $HT))) - (, - { (generate_hash_table $Keys $Is $LIs) } - (generate_hash_tries $LIs - (+ $FA $Tag) 0 $HT)))))) True) -; - - - - (= - (no-switch-on-hash $Is $Tag) - ( (get-symbols &self +; ;; 2nd. Indexing + (= (--> (generate_sw1 () $_ $_ (/ fail 0) $PIs $PIs) (, ! {assert_fail })) True) + (= (--> (generate_sw1 ($I) $_ $_ $L $PIs $PIs) (, ! {(= $I + (Cons $L $_)) })) True) + (= (--> (generate_sw1 $Is $FA $Tag $L $PIs0 $PIs) (, {(no_switch_on_hash $Is $Tag) } (, ! (generate_sw2 $Is $FA $Tag $L $PIs0 $PIs)))) True) + (= (--> (generate_sw1 $Is $FA $Tag (+ $FA $Tag) $PIs0 $PIs) (, (generate_sw $Is $FA nil $L $PIs0 $PIs) (, {(count_unique_hash $Is $Size $Keys) } (, ((: (+ $FA $Tag) (switch_on_hash $Tag $Size $L $HT))) (, {(generate_hash_table $Keys $Is $LIs) } (generate_hash_tries $LIs (+ $FA $Tag) 0 $HT)))))) True) + + + (= (no-switch-on-hash $Is $Tag) + ( (== (= - (pl2am_flag idx) $_)) + (pl2am_flag idx) $_) + (get-atoms &self)) (set-det) (or (= $Tag var) @@ -1890,7757 +1122,3409 @@ (= $Tag nil) (, (count-unique-hash $Is $C $_) - (< $C 2))))))) -; - - (= - (no_switch_on_hash $_ $_) True) -; - - - - (= - (--> - (generate_sw2 $Is $_ $_ $L $PIs $PIs) - (, - { (pl2am_member - (, $L $Is) $PIs) } !)) True) -; - - (= - (--> - (generate_sw2 $Is $FA $Tag - (+ $FA $Tag) $PIs0 - (Cons - (, - (+ $FA $Tag) $Is) $PIs0)) - (, - ( (: - (+ $FA $Tag) ())) - (generate_tries $Is))) True) -; - - - (= - (--> - (generate_hash_tries () $_ $_ ()) !) True) -; - - (= - (--> - (generate_hash_tries - (Cons - (: $K ()) $LIs) $L0 $N - (Cons - (: $K - (/ fail 0)) $Ls)) - (, ! - (, - {assert_fail } - (generate_hash_tries $LIs $L0 $N $Ls)))) True) -; - - (= - (--> - (generate_hash_tries - (Cons - (: $K - ($I)) $LIs) $L0 $N - (Cons - (: $K $L) $Ls)) - (, ! - (, - { (= $I - (Cons $L $_)) } - (generate_hash_tries $LIs $L0 $N $Ls)))) True) -; - - (= - (--> - (generate_hash_tries - (Cons - (: $K $Is) $LIs) $L0 $N - (Cons - (: $K - (+ $L0 $N)) $Ls)) - (, - ( (: - (+ $L0 $N) ())) - (, - (generate_tries $Is) - (, - { (is $N1 - (+ $N 1)) } - (generate_hash_tries $LIs $L0 $N1 $Ls))))) True) -; - - - - (= - (generate-hash-table Nil $_ Nil) - (set-det)) -; + (< $C 2))))))) + (= (no_switch_on_hash $_ $_) True) - (= - (generate-hash-table - (Cons $K $Ks) $Is0 - (Cons - (with_self $K $Is) $LIs)) - ( (select-hash $Is0 $K $Is) (generate-hash-table $Ks $Is0 $LIs))) -; + + (= (--> (generate_sw2 $Is $_ $_ $L $PIs $PIs) (, {(pl2am_member (, $L $Is) $PIs) } !)) True) + (= (--> (generate_sw2 $Is $FA $Tag (+ $FA $Tag) $PIs0 (Cons (, (+ $FA $Tag) $Is) $PIs0)) (, ((: (+ $FA $Tag) ())) (generate_tries $Is))) True) + + (= (--> (generate_hash_tries () $_ $_ ()) !) True) + (= (--> (generate_hash_tries (Cons (: $K ()) $LIs) $L0 $N (Cons (: $K (/ fail 0)) $Ls)) (, ! (, {assert_fail } (generate_hash_tries $LIs $L0 $N $Ls)))) True) + (= (--> (generate_hash_tries (Cons (: $K ($I)) $LIs) $L0 $N (Cons (: $K $L) $Ls)) (, ! (, {(= $I + (Cons $L $_)) } (generate_hash_tries $LIs $L0 $N $Ls)))) True) + (= (--> (generate_hash_tries (Cons (: $K $Is) $LIs) $L0 $N (Cons (: $K (+ $L0 $N)) $Ls)) (, ((: (+ $L0 $N) ())) (, (generate_tries $Is) (, {(is $N1 (+ $N 1)) } (generate_hash_tries $LIs $L0 $N1 $Ls))))) True) + + (= (generate-hash-table Nil $_ Nil) + (set-det)) + (= (generate-hash-table (Cons $K $Ks) $Is0 (Cons (with_self $K $Is) $LIs)) + (select-hash $Is0 $K $Is) + (generate-hash-table $Ks $Is0 $LIs)) - (= - (select_hash () $_ ()) True) -; + (= (select_hash () $_ ()) True) + (= (select-hash (Cons $I $Is0) $K (Cons $I $Is)) + (= $I + (:: $_ $_ $Tag $Hash)) + (or + (= $Tag var) + (= $K $Hash)) + (set-det) + (select-hash $Is0 $K $Is)) + (= (select-hash (Cons $_ $Is0) $K $Is) + (select-hash $Is0 $K $Is)) - (= - (select-hash - (Cons $I $Is0) $K - (Cons $I $Is)) - ( (= $I - (:: $_ $_ $Tag $Hash)) +; +; ;; Choice Point (try, retry, trust) + + (= (--> (generate_tries (Cons $I $Is)) (, {(= $I + (Cons $L $_)) } (, ((try $L)) (generate_tries1 $Is)))) True) + + (= (--> (generate_tries1 ($I)) (, ! (, {(= $I + (Cons $L $_)) } ((trust $L))))) True) + (= (--> (generate_tries1 (Cons $I $Is)) (, {(= $I + (Cons $L $_)) } (, ((retry $L)) (generate_tries1 $Is)))) True) + + + (= (get_indices () $_ $_ ()) True) + (= (get-indices (Cons $_ $Clauses) $FA $N (Cons (:: (+ $FA $N)) $Is)) + (= $FA + (/ $_ 0)) + (set-det) + (is $N1 + (+ $N 1)) + (get-indices $Clauses $FA $N1 $Is)) + (= (get-indices (Cons $Clause $Clauses) $FA $N (Cons (:: (+ $FA $N) $A1 $Tag $Hash) $Is)) + (= $Clause + (= $Head $_)) + (arg 1 $Head $A1) + (get-hash $A1 $Tag $Hash) + (is $N1 + (+ $N 1)) + (get-indices $Clauses $FA $N1 $Is)) + + + (= (get-hash $X var 0) + (var $X) + (set-det)) + (= (get-hash $X int $X) + (integer $X) + (set-det)) + (= (get-hash $X flo $X) + (float $X) + (set-det)) + (= (get-hash $X con $X) + (atom $X) + (set-det)) + (= (get-hash $X lis (/ . 2)) + (= $X + (Cons $_ $_)) + (set-det)) + (= (get-hash $X str (/ $F $A)) + (functor $X $F $A) + (set-det)) + + + (= (all_variable_indices ()) True) + (= (all-variable-indices (Cons (:: $_ $_ var $_) $Is)) + (all-variable-indices $Is)) + + + (= (count_unique_hash () 0 ()) True) + (= (count-unique-hash (Cons $I $Is) $C $K) + (count-unique-hash $Is $C0 $K0) + (= $I + (:: $_ $_ $Tag $Hash)) + (det-if-then-else (or (= $Tag var) - (= $K $Hash)) - (set-det) - (select-hash $Is0 $K $Is))) -; - - (= - (select-hash - (Cons $_ $Is0) $K $Is) - (select-hash $Is0 $K $Is)) -; - + (pl2am-member + (:: $_ $_ $Tag $Hash) $Is)) + (, + (= $C $C0) + (= $K $K0)) + (, + (is $C + (+ $C0 1)) + (= $K + (Cons $Hash $K0))))) + + + (= (select_indices () $_ ()) True) + (= (select-indices (Cons $I $Is0) $Tag (Cons $I $Is)) + (= $I + (Cons $_ + (Cons $_ + (Cons $T $_)))) + (or + (= $Tag var) + (or + (= $Tag $T) + (= $T var))) + (set-det) + (select-indices $Is0 $Tag $Is)) + (= (select-indices (Cons $_ $Is0) $Tag $Is) + (select-indices $Is0 $Tag $Is)) ; -; - - - (= - (--> - (generate_tries - (Cons $I $Is)) - (, - { (= $I - (Cons $L $_)) } - (, - ( (try $L)) - (generate_tries1 $Is)))) True) -; - - - (= - (--> - (generate_tries1 - ($I)) - (, ! - (, - { (= $I - (Cons $L $_)) } - ( (trust $L))))) True) -; - - (= - (--> - (generate_tries1 - (Cons $I $Is)) - (, - { (= $I - (Cons $L $_)) } - (, - ( (retry $L)) - (generate_tries1 $Is)))) True) -; - - - - (= - (get_indices () $_ $_ ()) True) -; - - (= - (get-indices - (Cons $_ $Clauses) $FA $N - (Cons - (:: (+ $FA $N)) $Is)) - ( (= $FA - (/ $_ 0)) - (set-det) - (is $N1 - (+ $N 1)) - (get-indices $Clauses $FA $N1 $Is))) -; - - (= - (get-indices - (Cons $Clause $Clauses) $FA $N - (Cons - (:: - (+ $FA $N) $A1 $Tag $Hash) $Is)) - ( (= $Clause - (= $Head $_)) - (arg 1 $Head $A1) - (get-hash $A1 $Tag $Hash) - (is $N1 - (+ $N 1)) - (get-indices $Clauses $FA $N1 $Is))) -; - - - - (= - (get-hash $X var 0) - ( (var $X) (set-det))) -; - - (= - (get-hash $X int $X) - ( (integer $X) (set-det))) -; - - (= - (get-hash $X flo $X) - ( (float $X) (set-det))) -; - - (= - (get-hash $X con $X) - ( (atom $X) (set-det))) -; - - (= - (get-hash $X lis - (/ . 2)) - ( (= $X - (Cons $_ $_)) (set-det))) -; - - (= - (get-hash $X str - (/ $F $A)) - ( (functor $X $F $A) (set-det))) -; - - - - (= - (all_variable_indices ()) True) -; - - (= - (all-variable-indices (Cons (:: $_ $_ var $_) $Is)) - (all-variable-indices $Is)) -; - - - - (= - (count_unique_hash () 0 ()) True) -; - - (= - (count-unique-hash - (Cons $I $Is) $C $K) - ( (count-unique-hash $Is $C0 $K0) - (= $I - (:: $_ $_ $Tag $Hash)) - (det-if-then-else - (or - (= $Tag var) - (pl2am-member - (:: $_ $_ $Tag $Hash) $Is)) - (, - (= $C $C0) - (= $K $K0)) - (, - (is $C - (+ $C0 1)) - (= $K - (Cons $Hash $K0)))))) -; +; ;; Assert Fail Flag + + (= (assert-fail) + ( (== + (= fail_flag $_) + (get-atoms &self)) (set-det))) + (= (assert-fail) + (add-is-symbol &self fail_flag)) +; +; ;; Generate Labels for Backtrack Point + + (= (--> (generate_bp_label () $_ $_ () ()) !) True) + (= (--> (generate_bp_label (Cons $X $Xs) $CL $N $Ls (Cons $X $Hs)) (, {(= $X + (switch_on_hash $_ $_ $_ $_)) } (, ! (, ($X) (generate_bp_label $Xs $CL $N $Ls $Hs))))) True) + (= (--> (generate_bp_label (Cons (try $L) $Xs) $CL $N (Cons (label (+ $CL $N)) $Ls) $Hs) (, ! (, ((try $L (+ $CL $N))) (, ((: (+ $CL $N) ())) (, {(is $N1 (+ $N 1)) } (generate_bp_label $Xs $CL $N1 $Ls $Hs)))))) True) + (= (--> (generate_bp_label (Cons (retry $L) $Xs) $CL $N (Cons (label (+ $CL $N)) $Ls) $Hs) (, ! (, ((retry $L (+ $CL $N))) (, ((: (+ $CL $N) ())) (, {(is $N1 (+ $N 1)) } (generate_bp_label $Xs $CL $N1 $Ls $Hs)))))) True) + (= (--> (generate_bp_label (Cons (: $L $X) $Xs) $_ $_ (Cons (label $L) $Ls) $Hs) (, ! (, ((: $L ())) (generate_bp_label (Cons $X $Xs) $L 1 $Ls $Hs)))) True) + (= (--> (generate_bp_label (Cons $X $Xs) $CL $N $Ls $Hs) (, ($X) (generate_bp_label $Xs $CL $N $Ls $Hs))) True) - (= - (select_indices () $_ ()) True) -; + (= (generate-cl-label $_ $I $N Nil) + (> $I $N) + (set-det)) + (= (generate-cl-label $FA $I $N (Cons (label (+ $FA $I)) $Ls)) + (is $I1 + (+ $I 1)) + (generate-cl-label $FA $I1 $N $Ls)) - (= - (select-indices - (Cons $I $Is0) $Tag - (Cons $I $Is)) - ( (= $I - (Cons $_ - (Cons $_ - (Cons $T $_)))) - (or - (= $Tag var) - (or - (= $Tag $T) - (= $T var))) - (set-det) - (select-indices $Is0 $Tag $Is))) -; +; +; ;; Generate Hash instructions for switch_on_hash + + (= (--> (gen_hash ()) !) True) + (= (--> (gen_hash (Cons (switch_on_hash $T $S $_ $H) $Xs)) (, ! (, ((new_hash $T $S)) (, (gen_put_hash $H $T) (gen_hash $Xs))))) True) + + (= (--> (gen_put_hash () $_) !) True) + (= (--> (gen_put_hash (Cons (: $K $V) $Xs) $T) (, ((put_hash $K $V $T)) (gen_put_hash $Xs $T))) True) + + + (= (replace-hash-keys Nil $_ Nil Nil) + (set-det)) + (= (replace-hash-keys (Cons (put-hash $K $L $H) $Xs) $SA $NHs (Cons (put-hash $X $L $H) $PHs)) + (set-det) + (replace-key $K $SA $X) + (replace-hash-keys $Xs $SA $NHs $PHs)) + (= (replace-hash-keys (Cons $X $Xs) $SA (Cons $X $NHs) $PHs) + (replace-hash-keys $Xs $SA $NHs $PHs)) + + + (= (replace-key $K $Alloc $X) + (integer $K) + (allocated $Alloc + (with_self $K + (int)) + (:: $X yes)) + (set-det)) + (= (replace-key $K $Alloc $X) + (float $K) + (allocated $Alloc + (with_self $K + (flo)) + (:: $X yes)) + (set-det)) + (= (replace-key $K $Alloc $X) + (atom $K) + (allocated $Alloc + (with_self $K + (con)) + (:: $X yes)) + (set-det)) + (= (replace-key $K $Alloc $X) + (nonvar $K) + (= $K + (/ $F $A)) + (atom $F) + (integer $A) + (allocated $Alloc + (with_self $K + (con)) + (:: $X yes)) + (set-det)) + (= (replace-key $K $_ $_) + (pl2am-error (:: replacement of hash key $K failed)) + (fail)) + +; +; ;; Import Declarations + + (= (--> generate_import (, {(findall (, $P $C) (import_package $P $C) $X) } (gen_import $X))) True) - (= - (select-indices - (Cons $_ $Is0) $Tag $Is) - (select-indices $Is0 $Tag $Is)) -; + (= (--> (gen_import ()) !) True) + (= (--> (gen_import (Cons (, $P *) $Xs)) (, ! (, ((import_package $P)) (gen_import $Xs)))) True) + (= (--> (gen_import (Cons (, $P $C) $Xs)) (, ((import_package $P $C)) (gen_import $Xs))) True) +; +; ;; Information + (= (--> (generate_info $Functor $Arity) (, {(clause (file_name $File) $_) } ((info ((/ $Functor $Arity) $File))))) True) ; -; +; ;; Check the Modifier of Predicate F/A. - - (= - (assert-fail) - ( (get-symbols &self - (= fail_flag $_)) (set-det))) -; + (= (check-modifier (/ %init 0) public) + (set-det)) + (= (check-modifier (/ $F $A) public) + ( (== + (= + (public_predicates $F $A) $_) + (get-atoms &self)) (set-det))) + (= (check_modifier $_ (- non public)) True) - (= - (assert-fail) - (add-symbol &self fail_flag)) -; +; +; ;; generate a list of registers with given range. + + (= (range-reg $I $N $_ Nil) + (> $I $N) + (set-det)) + (= (range-reg $I $N $A (Cons $R $Rs)) + (=< $I $N) + (is $I1 + (+ $I 1)) + (=.. $R + (:: $A $I)) + (range-reg $I1 $N $A $Rs)) +; +; ;; generate set instructions + + (= (--> (gen_set () ()) !) True) + (= (--> (gen_set (Cons $X $Xs) (Cons $Y $Ys)) (, ((set $X $Y)) (gen_set $Xs $Ys))) True) ; -; - - - (= - (--> - (generate_bp_label () $_ $_ () ()) !) True) -; - - (= - (--> - (generate_bp_label - (Cons $X $Xs) $CL $N $Ls - (Cons $X $Hs)) - (, - { (= $X - (switch_on_hash $_ $_ $_ $_)) } - (, ! - (, - ($X) - (generate_bp_label $Xs $CL $N $Ls $Hs))))) True) -; - - (= - (--> - (generate_bp_label - (Cons - (try $L) $Xs) $CL $N - (Cons - (label - (+ $CL $N)) $Ls) $Hs) - (, ! - (, - ( (try $L - (+ $CL $N))) - (, - ( (: - (+ $CL $N) ())) - (, - { (is $N1 - (+ $N 1)) } - (generate_bp_label $Xs $CL $N1 $Ls $Hs)))))) True) -; - - (= - (--> - (generate_bp_label - (Cons - (retry $L) $Xs) $CL $N - (Cons - (label - (+ $CL $N)) $Ls) $Hs) - (, ! - (, - ( (retry $L - (+ $CL $N))) - (, - ( (: - (+ $CL $N) ())) - (, - { (is $N1 - (+ $N 1)) } - (generate_bp_label $Xs $CL $N1 $Ls $Hs)))))) True) -; - - (= - (--> - (generate_bp_label - (Cons - (: $L $X) $Xs) $_ $_ - (Cons - (label $L) $Ls) $Hs) - (, ! - (, - ( (: $L ())) - (generate_bp_label - (Cons $X $Xs) $L 1 $Ls $Hs)))) True) -; - - (= - (--> - (generate_bp_label - (Cons $X $Xs) $CL $N $Ls $Hs) - (, - ($X) - (generate_bp_label $Xs $CL $N $Ls $Hs))) True) -; - - - - (= - (generate-cl-label $_ $I $N Nil) - ( (> $I $N) (set-det))) -; - - (= - (generate-cl-label $FA $I $N - (Cons - (label (+ $FA $I)) $Ls)) - ( (is $I1 - (+ $I 1)) (generate-cl-label $FA $I1 $N $Ls))) -; +; ;; generate deref instructions + (= (--> (gen_deref () ()) !) True) + (= (--> (gen_deref (Cons $X $Xs) (Cons $Y $Ys)) (, ((deref $X $Y)) (gen_deref $Xs $Ys))) True) +; +; ;; generate set and deref instructions + (= (--> (set_arguments $SN $EN $R1 $R2 $Flag) (, {(range_reg $SN $EN $R1 $L1) } (, {(range_reg $SN $EN $R2 $L2) } (gen_set_arg $Flag $L1 $L2)))) True) + + (= (--> (gen_set_arg set $L1 $L2) (gen_set $L1 $L2)) True) + (= (--> (gen_set_arg deref $L1 $L2) (gen_deref $L1 $L2)) True) ; -; - - - (= - (--> - (gen_hash ()) !) True) -; - - (= - (--> - (gen_hash - (Cons - (switch_on_hash $T $S $_ $H) $Xs)) - (, ! - (, - ( (new_hash $T $S)) - (, - (gen_put_hash $H $T) - (gen_hash $Xs))))) True) -; - - - (= - (--> - (gen_put_hash () $_) !) True) -; - - (= - (--> - (gen_put_hash - (Cons - (: $K $V) $Xs) $T) - (, - ( (put_hash $K $V $T)) - (gen_put_hash $Xs $T))) True) -; - - - - (= - (replace-hash-keys Nil $_ Nil Nil) - (set-det)) -; +; ;; generate decl_var instructions + (= (--> (generate_var_decl ($X0 $P0) ($XN $PN)) (, {(, (is $X1 (- $XN 1)) (is $P1 (- $PN 1))) } (, {(range_reg $X0 $X1 a $XL) } (, {(range_reg $P0 $P1 p $PL) } (, (gen_decl_term_vars $XL) (gen_decl_pred_vars $PL)))))) True) - (= - (replace-hash-keys - (Cons - (put-hash $K $L $H) $Xs) $SA $NHs - (Cons - (put-hash $X $L $H) $PHs)) - ( (set-det) - (replace-key $K $SA $X) - (replace-hash-keys $Xs $SA $NHs $PHs))) -; - - (= - (replace-hash-keys - (Cons $X $Xs) $SA - (Cons $X $NHs) $PHs) - (replace-hash-keys $Xs $SA $NHs $PHs)) -; - - - - (= - (replace-key $K $Alloc $X) - ( (integer $K) - (allocated $Alloc - (with_self $K - (int)) - (:: $X yes)) - (set-det))) -; - - (= - (replace-key $K $Alloc $X) - ( (float $K) - (allocated $Alloc - (with_self $K - (flo)) - (:: $X yes)) - (set-det))) -; - - (= - (replace-key $K $Alloc $X) - ( (atom $K) - (allocated $Alloc - (with_self $K - (con)) - (:: $X yes)) - (set-det))) -; - - (= - (replace-key $K $Alloc $X) - ( (nonvar $K) - (= $K - (/ $F $A)) - (atom $F) - (integer $A) - (allocated $Alloc - (with_self $K - (con)) - (:: $X yes)) - (set-det))) -; + (= (--> (gen_decl_term_vars ()) !) True) + (= (--> (gen_decl_term_vars $XL) ((decl_term_vars $XL))) True) - (= - (replace-key $K $_ $_) - ( (pl2am-error (:: replacement of hash key $K failed)) (fail))) -; + (= (--> (gen_decl_pred_vars ()) !) True) + (= (--> (gen_decl_pred_vars $PL) ((decl_pred_vars $PL))) True) + (= (--> (compile_clause (:- $Head $Body) $GTI0 $GTI $LTI) (, {(pretreat_body $Body $Goals0) } (, {(localize_meta $Goals0 $Goals) } (, {(precompile $Head $Goals $Instrs) } (, ((comment (:- $Head $Goals))) (, (compile_chunks $Instrs $GTI0 $GTI $LTI) !)))))) True) +; /**************************************************************** Compile Clause ****************************************************************/ +; ; cut, rename, compile aith exp. +; ; add package name for meta predicates +; ; generate get, put, put_clo, put_cont, inline +; ; output precompiled clause + (= (--> (compile_clause $Clause $_ $_ $_) (, {(pl2am_error (compilation of $Clause failed)) } {fail })) True) ; -; - - - (= - (--> generate_import - (, - { (findall - (, $P $C) - (import_package $P $C) $X) } - (gen_import $X))) True) -; - - - (= - (--> - (gen_import ()) !) True) -; - - (= - (--> - (gen_import - (Cons - (, $P *) $Xs)) - (, ! - (, - ( (import_package $P)) - (gen_import $Xs)))) True) -; - - (= - (--> - (gen_import - (Cons - (, $P $C) $Xs)) - (, - ( (import_package $P $C)) - (gen_import $Xs))) True) -; - +; ;;;;;;;;; Pretreat Body and Compile Arithmetic Expressions + + (= (pretreat-body $Body $Goals) + (pretreat-body0 $Body $Cut $Goals0 Nil) + (pretreat-cut $Cut $Goals0 $Goals)) + + + (= (pretreat-cut $Cut $Gs $Gs) + (var $Cut) + (set-det)) + (= (pretreat-cut ($cut $Level) (Cons ($cut $Level) $Gs) (Cons %neck-cut $Gs)) + (not (pl2am-member ($cut $Level) $Gs)) + (set-det)) + (= (pretreat-cut ($cut $Level) (Cons ($cut $Level) $Gs) (Cons ($get-level $Level) (Cons %neck-cut $Gs))) + (set-det)) + (= (pretreat_cut (%cut $Level) $Gs (Cons (%get_level $Level) $Gs)) True) + + + (= (--> (pretreat_body0 $G $_) (, {(var $G) } (, ! ((call $G))))) True) + (= (--> (pretreat_body0 ! $Cut) (, ! (, {(= $Cut + (%cut $Level)) } ((%cut $Level))))) True) + (= (--> (pretreat_body0 otherwise $_) !) True) + (= (--> (pretreat_body0 true $_) !) True) + (= (--> (pretreat_body0 fail $_) (, ! (fail))) True) + (= (--> (pretreat_body0 false $_) (, ! (fail))) True) + (= (--> (pretreat_body0 halt $_) (, ! (halt))) True) + (= (--> (pretreat_body0 abort $_) (, ! (abort))) True) + (= (--> (pretreat_body0 (, $G1 $G2) $Cut) (, ! (, (pretreat_body0 $G1 $Cut) (pretreat_body0 $G2 $Cut)))) True) + (= (--> (pretreat_body0 $G $_) (, (pretreat_builtin $G) !)) True) + (= (--> (pretreat_body0 $G $_) (, {(, (functor $G $F $A) (, (clause (dynamic_predicates $F $A (: $_ $Call)) $_) (=.. $CG ($Call $G)))) } (, ! ($CG)))) True) + (= (--> (pretreat_body0 (findall $X $G $L) $Z) (, {(, (nonvar $G) (, (functor $G $F $A) (, (clause (dynamic_predicates $F $A $Call) $_) (, (\== $Call (: SxxMachine.builtin call)) (, (= $Call + (: $P $C)) (, (clause (package_name $P1) $_) (=.. $CG ($C (: $P1 $G))))))))) } (, ! (pretreat_body0 (findall $X (: $P $CG) $L) $Z)))) True) + + (= (--> (pretreat_body0 $G $_) ($G)) True) ; -; - - (= - (--> - (generate_info $Functor $Arity) - (, - { (clause - (file_name $File) $_) } - ( (info - ( (/ $Functor $Arity) $File))))) True) -; +; ;; rename builtins + (= (--> (pretreat_builtin (= $X $Y)) (, ! ((%unify $X $Y)))) True) + (= (--> (pretreat_builtin (\= $X $Y)) (, ! ((%not_unifiable $X $Y)))) True) + (= (--> (pretreat_builtin (== $X $Y)) (, ! ((%equality_of_term $X $Y)))) True) + (= (--> (pretreat_builtin (\== $X $Y)) (, ! ((%inequality_of_term $X $Y)))) True) + (= (--> (pretreat_builtin (?= $X $Y)) (, ! ((%identical_or_cannot_unify $X $Y)))) True) + (= (--> (pretreat_builtin (@< $X $Y)) (, ! ((%before $X $Y)))) True) + (= (--> (pretreat_builtin (@> $X $Y)) (, ! ((%after $X $Y)))) True) + (= (--> (pretreat_builtin (@=< $X $Y)) (, ! ((%not_after $X $Y)))) True) + (= (--> (pretreat_builtin (@>= $X $Y)) (, ! ((%not_before $X $Y)))) True) + (= (--> (pretreat_builtin (compare $Op $X $Y)) (, {(== $Op =) } (, ! ((%equality_of_term $X $Y))))) True) + (= (--> (pretreat_builtin (compare $Op $X $Y)) (, {(== $Op <) } (, ! ((%before $X $Y))))) True) + (= (--> (pretreat_builtin (compare $Op $X $Y)) (, {(== $Op >) } (, ! ((%after $X $Y))))) True) + (= (--> (pretreat_builtin (=.. $X $Y)) (, ! ((%univ $X $Y)))) True) + (= (--> (pretreat_builtin (=:= $X $Y)) (, ! (, (pretreat_is $U $X) (, (pretreat_is $V $Y) ((%arith_equal $U $V)))))) True) + (= (--> (pretreat_builtin (=\= $X $Y)) (, ! (, (pretreat_is $U $X) (, (pretreat_is $V $Y) ((%arith_not_equal $U $V)))))) True) + (= (--> (pretreat_builtin (> $X $Y)) (, ! (, (pretreat_is $U $X) (, (pretreat_is $V $Y) ((%greater_than $U $V)))))) True) + (= (--> (pretreat_builtin (>= $X $Y)) (, ! (, (pretreat_is $U $X) (, (pretreat_is $V $Y) ((%greater_or_equal $U $V)))))) True) + (= (--> (pretreat_builtin (< $X $Y)) (, ! (, (pretreat_is $U $X) (, (pretreat_is $V $Y) ((%less_than $U $V)))))) True) + (= (--> (pretreat_builtin (=< $X $Y)) (, ! (, (pretreat_is $U $X) (, (pretreat_is $V $Y) ((%less_or_equal $U $V)))))) True) + (= (--> (pretreat_builtin (is $Z $X)) (, ! (pretreat_is0 $Z $X))) True) + + (= (--> (pretreat_is $Z $X) (, {(var $X) } (, ! {(= $X $Z) }))) True) + (= (--> (pretreat_is $Z $X) (pretreat_is0 $Z $X)) True) + + (= (--> (pretreat_is0 $Z $X) (, {(clause (pl2am_flag ac) $_) } (, ! (precompile_is $X $Z)))) True) + (= (--> (pretreat_is0 $Z $X) ((is $Z $X))) True) +; +; ;; compile aithmetic expressions + (= (--> (precompile_is $X $A) (, {(var $X) } (, ! ((is $A $X))))) True) + (= (--> (precompile_is $X $A) (, {(number $X) } (, ! {(= $X $A) }))) True) + (= (--> (precompile_is $X $A) (, {(builtin_arith_constant $X) } (, ! {(= $X $A) }))) True) + (= (--> (precompile_is (+ $X) $A) (, ! (precomp_is $X $A))) True) + (= (--> (precompile_is (- $X) $A) (, ! (precompile_is (* -1 $X) $A))) True) + (= (--> (precompile_is (+ $X $Y) $A) (, ! (, (precomp_is $X $U) (, (precomp_is $Y $V) ((%plus $U $V $A)))))) True) + (= (--> (precompile_is (- $X $Y) $A) (, ! (, (precomp_is $X $U) (, (precomp_is $Y $V) ((%minus $U $V $A)))))) True) + (= (--> (precompile_is (* $X $Y) $A) (, ! (, (precomp_is $X $U) (, (precomp_is $Y $V) ((%multi $U $V $A)))))) True) + (= (--> (precompile_is (/ $X $Y) $A) (, ! (, (precomp_is $X $U) (, (precomp_is $Y $V) ((%float_quotient $U $V $A)))))) True) + (= (--> (precompile_is (// $X $Y) $A) (, ! (, (precomp_is $X $U) (, (precomp_is $Y $V) ((%int_quotient $U $V $A)))))) True) + (= (--> (precompile_is (mod $X $Y) $A) (, ! (, (precomp_is $X $U) (, (precomp_is $Y $V) ((%mod $U $V $A)))))) True) + (= (--> (precompile_is (rem $X $Y) $A) (, ! (, (precomp_is $X $U) (, (precomp_is $Y $V) ((%mod $U $V $A)))))) True) + (= (--> (precompile_is (/\ $X $Y) $A) (, ! (, (precomp_is $X $U) (, (precomp_is $Y $V) ((%bitwise_conj $U $V $A)))))) True) + (= (--> (precompile_is (\/ $X $Y) $A) (, ! (, (precomp_is $X $U) (, (precomp_is $Y $V) ((%bitwise_disj $U $V $A)))))) True) + (= (--> (precompile_is (# $X $Y) $A) (, ! (, (precomp_is $X $U) (, (precomp_is $Y $V) ((%bitwise_exclusive_or $U $V $A)))))) True) + (= (--> (precompile_is (\ $X) $A) (, ! (, (precomp_is $X $U) ((%bitwise_neg $U $A))))) True) + (= (--> (precompile_is (<< $X $Y) $A) (, ! (, (precomp_is $X $U) (, (precomp_is $Y $V) ((%shift_left $U $V $A)))))) True) + (= (--> (precompile_is (>> $X $Y) $A) (, ! (, (precomp_is $X $U) (, (precomp_is $Y $V) ((%shift_right $U $V $A)))))) True) + (= (--> (precompile_is ($X) $A) (, ! (precomp_is $X $A))) True) + (= (--> (precompile_is (abs $X) $A) (, ! (, (precomp_is $X $U) ((%abs $U $A))))) True) + (= (--> (precompile_is (min $X $Y) $A) (, ! (, (precomp_is $X $U) (, (precomp_is $Y $V) ((%min $U $V $A)))))) True) + (= (--> (precompile_is (max $X $Y) $A) (, ! (, (precomp_is $X $U) (, (precomp_is $Y $V) ((%max $U $V $A)))))) True) + (= (--> (precompile_is (round $X) $A) (, ! (, (precomp_is $X $U) ((%round $U $A))))) True) + (= (--> (precompile_is (floor $X) $A) (, ! (, (precomp_is $X $U) ((%floor $U $A))))) True) + (= (--> (precompile_is (ceiling $X) $A) (, ! (, (precomp_is $X $U) ((%ceil $U $A))))) True) + (= (--> (precompile_is (sin $X) $A) (, ! (, (precomp_is $X $U) ((%sin $U $A))))) True) + (= (--> (precompile_is (cos $X) $A) (, ! (, (precomp_is $X $U) ((%cos $U $A))))) True) + (= (--> (precompile_is (tan $X) $A) (, ! (, (precomp_is $X $U) ((%tan $U $A))))) True) + (= (--> (precompile_is (asin $X) $A) (, ! (, (precomp_is $X $U) ((%asin $U $A))))) True) + (= (--> (precompile_is (acos $X) $A) (, ! (, (precomp_is $X $U) ((%acos $U $A))))) True) + (= (--> (precompile_is (atan $X) $A) (, ! (, (precomp_is $X $U) ((%atan $U $A))))) True) + (= (--> (precompile_is (sqrt $X) $A) (, ! (, (precomp_is $X $U) ((%sqrt $U $A))))) True) + (= (--> (precompile_is (log $X) $A) (, ! (, (precomp_is $X $U) ((%log $U $A))))) True) + (= (--> (precompile_is (exp $X) $A) (, ! (, (precomp_is $X $U) ((%exp $U $A))))) True) + (= (--> (precompile_is (** $X $Y) $A) (, ! (, (precomp_is $X $U) (, (precomp_is $Y $V) ((%pow $U $V $A)))))) True) + (= (--> (precompile_is (degrees $X) $A) (, ! (, (precomp_is $X $U) ((%degrees $U $A))))) True) + (= (--> (precompile_is (radians $X) $A) (, ! (, (precomp_is $X $U) ((%radians $U $A))))) True) + (= (--> (precompile_is (rint $X) $A) (, ! (, (precomp_is $X $U) ((%rint $U $A))))) True) + (= (--> (precompile_is (float $X) $A) (, ! (, (precomp_is $X $U) ((%float $U $A))))) True) + (= (--> (precompile_is (float_integer_part $X) $A) (, ! (, (precomp_is $X $U) ((%float_integer_part $U $A))))) True) + (= (--> (precompile_is (float_fractional_part $X) $A) (, ! (, (precomp_is $X $U) ((%float_fractional_part $U $A))))) True) + (= (--> (precompile_is (truncate $X) $A) (, ! (, (precomp_is $X $U) ((%truncate $U $A))))) True) + (= (--> (precompile_is (sign $X) $A) (, ! (, (precomp_is $X $U) ((%sign $U $A))))) True) + (= (--> (precompile_is $X $_) (, {(pl2am_error (unknown arithemetic expression $X)) } {fail })) True) + + (= (--> (precomp_is $X $A) (, {(var $X) } (, {(var $A) } (, ! {(= $X $A) })))) True) + (= (--> (precomp_is $X $A) (precompile_is $X $A)) True) ; -; +; ;;;;;;;;; Add Pacakge (module) name to meta predicates - - (= - (check-modifier - (/ %init 0) public) - (set-det)) -; - - (= - (check-modifier - (/ $F $A) public) - ( (get-symbols &self + (= (localize-meta $G0 $G) + ( (== (= - (public_predicates $F $A) $_)) (set-det))) -; - - (= - (check_modifier $_ - (- non public)) True) -; - + (package_name $P) $_) + (get-atoms &self)) + (localize-meta $G0 $P $G) + (set-det))) + + (= (localize-meta Nil $_ Nil) + (set-det)) + (= (localize-meta (Cons $G $Gs) $P (Cons $G1 $Gs1)) + (localize-meta-goal $G $P $X) + (det-if-then-else + (= $X + (with_self $P $Y)) + (= $G1 $Y) + (= $G1 $X)) + (localize-meta $Gs $P $Gs1)) + + + (= (localize-meta-goal $G $P $G1) + (var $G) + (set-det) + (localize-meta-goal + (call $G) $P $G1)) + (= (localize-meta-goal (with_self $P $G) $_ $G1) + (set-det) + (localize-meta-goal $G $P $G1)) + (= (localize-meta-goal (, $X $Y) $P (, $X1 $Y1)) + (set-det) + (localize-meta-goal $X $P $X1) + (localize-meta-goal $Y $P $Y1)) + (= (localize-meta-goal (det-if-then $X $Y) $P (det-if-then $X1 $Y1)) + (set-det) + (localize-meta-goal $X $P $X1) + (localize-meta-goal $Y $P $Y1)) + (= (localize-meta-goal (or $X $Y) $P (or $X1 $Y1)) + (set-det) + (localize-meta-goal $X $P $X1) + (localize-meta-goal $Y $P $Y1)) + (= (localize-meta-goal $G $P $G1) + (functor $G $F $A) + (or + (== + (= + (meta_predicates $F $A $M) $_) + (get-atoms &self)) + (builtin-local-predicates $F $A $M)) + (set-det) + (=.. $G + (Cons $F $As)) + (localize-meta-args $M $As $P $As1) + (=.. $G1 + (Cons $F $As1))) + (= (localize-meta-goal $G $P (call (with_self $P $G))) + (var $P) + (set-det)) + (= (localize-meta-goal $G $_ $G) + (system-predicate $G) + (set-det)) + (= (localize_meta_goal $G $P (: $P $G)) True) + + + (= (localize-meta-args Nil Nil $_ Nil) + (set-det)) + (= (localize-meta-args (Cons : $Ms) (Cons $A $As) $P (Cons (with_self $P $A) $As1)) + (or + (var $A) + (\= $A + (with_self $_ $_))) + (set-det) + (localize-meta-args $Ms $As $P $As1)) + (= (localize-meta-args (Cons or $Ms) (Cons $A $As) $P (Cons (with_self $P $A) $As1)) + (or + (var $A) + (\= $A + (with_self $_ $_))) + (set-det) + (localize-meta-args $Ms $As $P $As1)) + (= (localize-meta-args (Cons $_ $Ms) (Cons $A $As) $P (Cons $A $As1)) + (localize-meta-args $Ms $As $P $As1)) ; -; +; ;;;;;;;;; Precompile Clause and Optimize Recursive Call - - (= - (range-reg $I $N $_ Nil) - ( (> $I $N) (set-det))) -; - - (= - (range-reg $I $N $A - (Cons $R $Rs)) - ( (=< $I $N) - (is $I1 - (+ $I 1)) - (=.. $R - (:: $A $I)) - (range-reg $I1 $N $A $Rs))) -; - + (= (precompile $Head $Goals $Instrs) + (precompile-head $Head $Instrs0 $Bs) + (precompile-body $Goals $Bs Nil) + (optimize-recursive-call $Head $Instrs0 $Instrs)) ; -; - +; ;; Precompile head (generates get instructions) - (= - (--> - (gen_set () ()) !) True) -; - - (= - (--> - (gen_set - (Cons $X $Xs) - (Cons $Y $Ys)) - (, - ( (set $X $Y)) - (gen_set $Xs $Ys))) True) -; + (= (--> (precompile_head $Head) (, {(=.. $Head (Cons $_ $Args)) } (precomp_head $Args 1))) True) + (= (--> (precomp_head () $_) !) True) + (= (--> (precomp_head (Cons $A $As) $I) (, ((get $A (a $I))) (, {(is $I1 (+ $I 1)) } (precomp_head $As $I1)))) True) ; -; - - (= - (--> - (gen_deref () ()) !) True) -; - - (= - (--> - (gen_deref - (Cons $X $Xs) - (Cons $Y $Ys)) - (, - ( (deref $X $Y)) - (gen_deref $Xs $Ys))) True) -; +; ;; Precompile body +; +; ;; (generates put, put_clo, put_cont, and inline instructions) + (= (--> (precompile_body $Goals) (, {(clause (pl2am_flag ie) $_) } (, ! (, {(pickup_inline_goals $Goals $IGs $Gs) } (precomp_inline $IGs $Gs))))) True) + (= (--> (precompile_body $Goals) (precomp_body $Goals)) True) + (= (--> (precomp_body ()) (, ! ((execute cont)))) True) + (= (--> (precomp_body (Cons (: $M $G) $Cont)) (, ! (, (binarize_body $G $Cont $G1) ((execute (: $M $G1)))))) True) + (= (--> (precomp_body (Cons $G $Cont)) (, (binarize_body $G $Cont $G1) ((execute $G1)))) True) -; -; - - (= - (--> - (set_arguments $SN $EN $R1 $R2 $Flag) - (, - { (range_reg $SN $EN $R1 $L1) } - (, - { (range_reg $SN $EN $R2 $L2) } - (gen_set_arg $Flag $L1 $L2)))) True) -; + (= (--> (binarize_body $G $Cont $G1) (, {(=.. $G (Cons $F $Args)) } (, {(functor $G $F $A) } (, (precomp_call $Args $Us $F $A) (, (precomp_cont $Cont $V) (, {(pl2am_append $Us ($V) $Ws) } {(=.. $G1 (Cons $F $Ws)) })))))) True) +; /*--------------------------------------------------------------- Binarization technique was developed by P.Tarau and M.Boyer, please see: * "Elementary Logic Programs" P.Tarau and M.Boyer Programming Language Implementation and Logic Programming, pp.159--173, LNCS 456, Springer Verlag, 1990 ----------------------------------------------------------------*/ +; ;precomp_call(Args, Us), ; for no closure + (= (--> (precomp_call () ()) !) True) + (= (--> (precomp_call (Cons $A $As) (Cons $U $Us)) (, ((put $A $U)) (precomp_call $As $Us))) True) - (= - (--> - (gen_set_arg set $L1 $L2) - (gen_set $L1 $L2)) True) -; + (= (--> (precomp_cont () cont) !) True) + (= (--> (precomp_cont (Cons (: $M $G) $Cont) $V) (, ! (, (binarize_body $G $Cont $G1) ((put_cont (: $M $G1) $V))))) True) + (= (--> (precomp_cont (Cons $G $Cont) $V) (, (binarize_body $G $Cont $G1) ((put_cont $G1 $V)))) True) - (= - (--> - (gen_set_arg deref $L1 $L2) - (gen_deref $L1 $L2)) True) -; + (= (--> (precomp_inline () $Gs1) (, ! (precomp_body $Gs1))) True) + (= (--> (precomp_inline (Cons fail $_) $_) (, ! ((inline fail)))) True) + (= (--> (precomp_inline (Cons $G $Gs) $Gs1) (, {(=.. $G (Cons $F $Args)) } (, {(functor $G $F $A) } (, (precomp_call $Args $Us $F $A) (, {(=.. $G1 (Cons $F $Us)) } (, ((inline $G1)) (precomp_inline $Gs $Gs1))))))) True) +; ;precomp_call(Args, Us), + + (= (pickup-inline-goals Nil Nil Nil) + (set-det)) + (= (pickup-inline-goals (Cons $G $Gs) (Cons $G $IGs) $BGs) + (builtin-inline-predicates $G) + (set-det) + (pickup-inline-goals $Gs $IGs $BGs)) + (= (pickup_inline_goals $Gs () $Gs) True) ; -; - - (= - (--> - (generate_var_decl - ($X0 $P0) - ($XN $PN)) - (, - { (, - (is $X1 - (- $XN 1)) - (is $P1 - (- $PN 1))) } - (, - { (range_reg $X0 $X1 a $XL) } - (, - { (range_reg $P0 $P1 p $PL) } - (, - (gen_decl_term_vars $XL) - (gen_decl_pred_vars $PL)))))) True) -; - - - (= - (--> - (gen_decl_term_vars ()) !) True) -; - - (= - (--> - (gen_decl_term_vars $XL) - ( (decl_term_vars $XL))) True) -; - - - (= - (--> - (gen_decl_pred_vars ()) !) True) -; - - (= - (--> - (gen_decl_pred_vars $PL) - ( (decl_pred_vars $PL))) True) -; - - - (= - (--> - (compile_clause - (:- $Head $Body) $GTI0 $GTI $LTI) - (, - { (pretreat_body $Body $Goals0) } - (, - { (localize_meta $Goals0 $Goals) } - (, - { (precompile $Head $Goals $Instrs) } - (, - ( (comment - (:- $Head $Goals))) - (, - (compile_chunks $Instrs $GTI0 $GTI $LTI) !)))))) True) -; - - (= - (--> - (compile_clause $Clause $_ $_ $_) - (, - { (pl2am_error - (compilation of $Clause failed)) } - {fail })) True) -; - +; ;; Generate Closure + + (= (--> (precomp_call $As $Us $Functor $Arity) (, {(clause (pl2am_flag clo) $_) } (, {(clause (meta_predicates $Functor $Arity $Mode) $_) } (, ! (, {(clause (package_name $P) $_) } (precomp_closure $Mode $As $P $Us)))))) True) + (= (--> (precomp_call $As $Us $_ $_) (precomp_call $As $Us)) True) + + (= (--> (precomp_closure () () $_ ()) !) True) + (= (--> (precomp_closure (Cons : $Ms) (Cons $A $As) $P (Cons $U $Us)) (, {(get_closure $A $P $C) } (, ! (, ((put_clo $C $U)) (precomp_closure $Ms $As $P $Us))))) True) + (= (--> (precomp_closure (Cons $_ $Ms) (Cons $A $As) $P (Cons $U $Us)) (, ((put $A $U)) (precomp_closure $Ms $As $P $Us))) True) + + + (= (get-closure $G $_ $_) + (var $G) + (set-det) + (fail)) + (= (get-closure $_ $P $_) + (var $P) + (set-det) + (fail)) + (= (get-closure (with_self $P $G) $_ $Clo) + (set-det) + (get-closure $G $P $Clo)) + (= (get-closure $G $P (with_self $P $G)) + (atom $P) + (callable $G) + (functor $G $F $A) + (not (== (= (dynamic_predicates $F $A $_) $_) (get-atoms &self))) + (set-det)) +; ; ??? ; -; - +; ;; Optimize Recursive Call - (= - (pretreat-body $Body $Goals) - ( (pretreat-body0 $Body $Cut $Goals0 Nil) (pretreat-cut $Cut $Goals0 $Goals))) -; - + (= (optimize-recursive-call $Head $Instrs0 $Instrs) + ( (== + (= + (pl2am_flag rc) $_) + (get-atoms &self)) + (set-det) + (optimize-rc $Instrs0 $Head $Instrs Nil))) + (= (optimize_recursive_call $_ $Instrs $Instrs) True) - (= - (pretreat-cut $Cut $Gs $Gs) - ( (var $Cut) (set-det))) -; + (= (--> (optimize_rc () $_) !) True) + (= (--> (optimize_rc (Cons (execute $Goal) $Xs) $Head) (, {(functor $Head $F $A) } (, {(functor $Goal $F $A1) } (, {(=:= (+ $A 1) $A1) } (, ! (, {(assert_copts (rc $F $A)) } (, {(=.. $Goal (Cons $F $Args)) } (, {(range_reg 1 $A ea $Rs0) } (, {(pl2am_append $Rs0 (econt) $Rs) } (, (gen_set $Args $Rs) (, ((goto (+ (/ $F $A) top))) (optimize_rc $Xs $Head)))))))))))) True) + (= (--> (optimize_rc (Cons $X $Xs) $Head) (, ($X) (optimize_rc $Xs $Head))) True) - (= - (pretreat-cut - ($cut $Level) - (Cons - ($cut $Level) $Gs) - (Cons %neck-cut $Gs)) - ( (not (pl2am-member ($cut $Level) $Gs)) (set-det))) -; - - (= - (pretreat-cut - ($cut $Level) - (Cons - ($cut $Level) $Gs) - (Cons - ($get-level $Level) - (Cons %neck-cut $Gs))) - (set-det)) -; +; +; ;;;;;;;;; Compile Clause + (= (--> (compile_chunks $Chunk $GTI0 $GTI $LTI) (, {(alloc_voids $Chunk () $Alloc) } (compile_chunk $Chunk $Alloc $GTI0 $GTI $LTI))) True) +; ; check void variables - (= - (pretreat_cut - ($cut $Level) $Gs - (Cons - (%get_level $Level) $Gs)) True) -; - - - - (= - (--> - (pretreat_body0 $G $_) - (, - { (var $G) } - (, ! - ( (call $G))))) True) -; - - (= - (--> - (pretreat_body0 ! $Cut) - (, ! - (, - { (= $Cut - ($cut $Level)) } - ( ($cut $Level))))) True) -; - - (= - (--> - (pretreat_body0 otherwise $_) !) True) -; - - (= - (--> - (pretreat_body0 true $_) !) True) -; - - (= - (--> - (pretreat_body0 fail $_) - (, ! - (fail))) True) -; - - (= - (--> - (pretreat_body0 false $_) - (, ! - (fail))) True) -; - - (= - (--> - (pretreat_body0 halt $_) - (, ! - (halt))) True) -; - - (= - (--> - (pretreat_body0 abort $_) - (, ! - (abort))) True) -; - - (= - (--> - (pretreat_body0 - (, $G1 $G2) $Cut) - (, ! - (, - (pretreat_body0 $G1 $Cut) - (pretreat_body0 $G2 $Cut)))) True) -; - - (= - (--> - (pretreat_body0 $G $_) - (, - (pretreat_builtin $G) !)) True) -; - - (= - (--> - (pretreat_body0 $G $_) - (, - { (, - (functor $G $F $A) - (, - (clause - (dynamic_predicates $F $A - (: $_ $Call)) $_) - (=.. $CG - ($Call $G)))) } - (, ! - ($CG)))) True) -; - - (= - (--> - (pretreat_body0 - (findall $X $G $L) $Z) - (, - { (, - (nonvar $G) - (, - (functor $G $F $A) - (, - (clause - (dynamic_predicates $F $A $Call) $_) - (, - (\== $Call - (: SxxMachine.builtin call)) - (, - (= $Call - (: $P $C)) - (, - (clause - (package_name $P1) $_) - (=.. $CG - ($C (: $P1 $G))))))))) } - (, ! - (pretreat_body0 - (findall $X - (: $P $CG) $L) $Z)))) True) -; - - - (= - (--> - (pretreat_body0 $G $_) - ($G)) True) -; + (= (--> (compile_chunk () $_ $GTI $GTI ()) !) True) + (= (--> (compile_chunk $Chunk $Alloc $GTI0 $GTI $LTI) (, {(, (free_x_reg $Chunk 1 $XN) (, (= $YN 1) (= $PN 1))) } (, {(= $LTI0 + ($XN $YN $PN $Alloc)) } (comp_chunk $Chunk $LTI0 $LTI $GTI0 $GTI)))) True) + (= (--> (comp_chunk () $LTI $LTI $GTI $GTI) !) True) + (= (--> (comp_chunk (Cons (: $L ()) $Cs) $LTI0 $LTI $GTI0 $GTI) (, ! (, ((: $L ())) (comp_chunk $Cs $LTI0 $LTI $GTI0 $GTI)))) True) + (= (--> (comp_chunk (Cons (: $L $C) $Cs) $LTI0 $LTI $GTI0 $GTI) (, ! (, ((: $L ())) (comp_chunk (Cons $C $Cs) $LTI0 $LTI $GTI0 $GTI)))) True) + (= (--> (comp_chunk (Cons $C $Cs) $LTI0 $LTI $GTI0 $GTI) (, ! (, (comp_instr $C $LTI0 $LTI1 $GTI0 $GTI1) (comp_chunk $Cs $LTI1 $LTI $GTI1 $GTI)))) True) ; -; - - (= - (--> - (pretreat_builtin - (= $X $Y)) - (, ! - ( ($unify $X $Y)))) True) -; - - (= - (--> - (pretreat_builtin - (\= $X $Y)) - (, ! - ( (%not_unifiable $X $Y)))) True) -; - - (= - (--> - (pretreat_builtin - (== $X $Y)) - (, ! - ( (%equality_of_term $X $Y)))) True) -; - - (= - (--> - (pretreat_builtin - (\== $X $Y)) - (, ! - ( (%inequality_of_term $X $Y)))) True) -; - - (= - (--> - (pretreat_builtin - (?= $X $Y)) - (, ! - ( (%identical_or_cannot_unify $X $Y)))) True) -; - - (= - (--> - (pretreat_builtin - (@< $X $Y)) - (, ! - ( ($before $X $Y)))) True) -; - - (= - (--> - (pretreat_builtin - (@> $X $Y)) - (, ! - ( ($after $X $Y)))) True) -; - - (= - (--> - (pretreat_builtin - (@=< $X $Y)) - (, ! - ( (%not_after $X $Y)))) True) -; - - (= - (--> - (pretreat_builtin - (@>= $X $Y)) - (, ! - ( (%not_before $X $Y)))) True) -; - - (= - (--> - (pretreat_builtin - (compare $Op $X $Y)) - (, - { (== $Op =) } - (, ! - ( (%equality_of_term $X $Y))))) True) -; - - (= - (--> - (pretreat_builtin - (compare $Op $X $Y)) - (, - { (== $Op <) } - (, ! - ( ($before $X $Y))))) True) -; - - (= - (--> - (pretreat_builtin - (compare $Op $X $Y)) - (, - { (== $Op >) } - (, ! - ( ($after $X $Y))))) True) -; - - (= - (--> - (pretreat_builtin - (=.. $X $Y)) - (, ! - ( ($univ $X $Y)))) True) -; - - (= - (--> - (pretreat_builtin - (=:= $X $Y)) - (, ! - (, - (pretreat_is $U $X) - (, - (pretreat_is $V $Y) - ( (%arith_equal $U $V)))))) True) -; - - (= - (--> - (pretreat_builtin - (=\= $X $Y)) - (, ! - (, - (pretreat_is $U $X) - (, - (pretreat_is $V $Y) - ( (%arith_not_equal $U $V)))))) True) -; - - (= - (--> - (pretreat_builtin - (> $X $Y)) - (, ! - (, - (pretreat_is $U $X) - (, - (pretreat_is $V $Y) - ( (%greater_than $U $V)))))) True) -; - - (= - (--> - (pretreat_builtin - (>= $X $Y)) - (, ! - (, - (pretreat_is $U $X) - (, - (pretreat_is $V $Y) - ( (%greater_or_equal $U $V)))))) True) -; - - (= - (--> - (pretreat_builtin - (< $X $Y)) - (, ! - (, - (pretreat_is $U $X) - (, - (pretreat_is $V $Y) - ( (%less_than $U $V)))))) True) -; - - (= - (--> - (pretreat_builtin - (=< $X $Y)) - (, ! - (, - (pretreat_is $U $X) - (, - (pretreat_is $V $Y) - ( (%less_or_equal $U $V)))))) True) -; - - (= - (--> - (pretreat_builtin - (is $Z $X)) - (, ! - (pretreat_is0 $Z $X))) True) -; - - - (= - (--> - (pretreat_is $Z $X) - (, - { (var $X) } - (, ! - { (= $X $Z) }))) True) -; - - (= - (--> - (pretreat_is $Z $X) - (pretreat_is0 $Z $X)) True) -; - - - (= - (--> - (pretreat_is0 $Z $X) - (, - { (clause - (pl2am_flag ac) $_) } - (, ! - (precompile_is $X $Z)))) True) -; - - (= - (--> - (pretreat_is0 $Z $X) - ( (is $Z $X))) True) -; - +; ;; finds an available number A-register + + (= (free_x_reg () $XN $XN) True) + (= (free-x-reg (Cons (get $_ $V) $Cs) $XN0 $XN) + (nonvar $V) + (= $V + (a $N)) + (set-det) + (is $XN1 + (max + (+ $N 1) $XN0)) + (free-x-reg $Cs $XN1 $XN)) + (= (free-x-reg (Cons (put $_ $V) $Cs) $XN0 $XN) + (nonvar $V) + (= $V + (a $N)) + (set-det) + (is $XN1 + (max + (+ $N 1) $XN0)) + (free-x-reg $Cs $XN1 $XN)) + (= (free-x-reg (Cons $_ $Cs) $XN0 $XN) + (free-x-reg $Cs $XN0 $XN)) ; -; - - (= - (--> - (precompile_is $X $A) - (, - { (var $X) } - (, ! - ( (is $A $X))))) True) -; - - (= - (--> - (precompile_is $X $A) - (, - { (number $X) } - (, ! - { (= $X $A) }))) True) -; - - (= - (--> - (precompile_is $X $A) - (, - { (builtin_arith_constant $X) } - (, ! - { (= $X $A) }))) True) -; - - (= - (--> - (precompile_is - (+ $X) $A) - (, ! - (precomp_is $X $A))) True) -; - - (= - (--> - (precompile_is - (- $X) $A) - (, ! - (precompile_is - (* -1 $X) $A))) True) -; - - (= - (--> - (precompile_is - (+ $X $Y) $A) - (, ! - (, - (precomp_is $X $U) - (, - (precomp_is $Y $V) - ( ($plus $U $V $A)))))) True) -; - - (= - (--> - (precompile_is - (- $X $Y) $A) - (, ! - (, - (precomp_is $X $U) - (, - (precomp_is $Y $V) - ( ($minus $U $V $A)))))) True) -; - - (= - (--> - (precompile_is - (* $X $Y) $A) - (, ! - (, - (precomp_is $X $U) - (, - (precomp_is $Y $V) - ( ($multi $U $V $A)))))) True) -; - - (= - (--> - (precompile_is - (/ $X $Y) $A) - (, ! - (, - (precomp_is $X $U) - (, - (precomp_is $Y $V) - ( (%float_quotient $U $V $A)))))) True) -; - - (= - (--> - (precompile_is - (// $X $Y) $A) - (, ! - (, - (precomp_is $X $U) - (, - (precomp_is $Y $V) - ( (%int_quotient $U $V $A)))))) True) -; - - (= - (--> - (precompile_is - (mod $X $Y) $A) - (, ! - (, - (precomp_is $X $U) - (, - (precomp_is $Y $V) - ( ($mod $U $V $A)))))) True) -; - - (= - (--> - (precompile_is - (rem $X $Y) $A) - (, ! - (, - (precomp_is $X $U) - (, - (precomp_is $Y $V) - ( ($mod $U $V $A)))))) True) -; - - (= - (--> - (precompile_is - (/\ $X $Y) $A) - (, ! - (, - (precomp_is $X $U) - (, - (precomp_is $Y $V) - ( (%bitwise_conj $U $V $A)))))) True) -; - - (= - (--> - (precompile_is - (\/ $X $Y) $A) - (, ! - (, - (precomp_is $X $U) - (, - (precomp_is $Y $V) - ( (%bitwise_disj $U $V $A)))))) True) -; - - (= - (--> - (precompile_is - (# $X $Y) $A) - (, ! - (, - (precomp_is $X $U) - (, - (precomp_is $Y $V) - ( (%bitwise_exclusive_or $U $V $A)))))) True) -; - - (= - (--> - (precompile_is - (\ $X) $A) - (, ! - (, - (precomp_is $X $U) - ( (%bitwise_neg $U $A))))) True) -; - - (= - (--> - (precompile_is - (<< $X $Y) $A) - (, ! - (, - (precomp_is $X $U) - (, - (precomp_is $Y $V) - ( (%shift_left $U $V $A)))))) True) -; - - (= - (--> - (precompile_is - (>> $X $Y) $A) - (, ! - (, - (precomp_is $X $U) - (, - (precomp_is $Y $V) - ( (%shift_right $U $V $A)))))) True) -; - - (= - (--> - (precompile_is - ($X) $A) - (, ! - (precomp_is $X $A))) True) -; - - (= - (--> - (precompile_is - (abs $X) $A) - (, ! - (, - (precomp_is $X $U) - ( ($abs $U $A))))) True) -; - - (= - (--> - (precompile_is - (min $X $Y) $A) - (, ! - (, - (precomp_is $X $U) - (, - (precomp_is $Y $V) - ( ($min $U $V $A)))))) True) -; - - (= - (--> - (precompile_is - (max $X $Y) $A) - (, ! - (, - (precomp_is $X $U) - (, - (precomp_is $Y $V) - ( ($max $U $V $A)))))) True) -; - - (= - (--> - (precompile_is - (round $X) $A) - (, ! - (, - (precomp_is $X $U) - ( ($round $U $A))))) True) -; - - (= - (--> - (precompile_is - (floor $X) $A) - (, ! - (, - (precomp_is $X $U) - ( ($floor $U $A))))) True) -; - - (= - (--> - (precompile_is - (ceiling $X) $A) - (, ! - (, - (precomp_is $X $U) - ( ($ceil $U $A))))) True) -; - - (= - (--> - (precompile_is - (sin $X) $A) - (, ! - (, - (precomp_is $X $U) - ( ($sin $U $A))))) True) -; - - (= - (--> - (precompile_is - (cos $X) $A) - (, ! - (, - (precomp_is $X $U) - ( ($cos $U $A))))) True) -; - - (= - (--> - (precompile_is - (tan $X) $A) - (, ! - (, - (precomp_is $X $U) - ( ($tan $U $A))))) True) -; - - (= - (--> - (precompile_is - (asin $X) $A) - (, ! - (, - (precomp_is $X $U) - ( ($asin $U $A))))) True) -; - - (= - (--> - (precompile_is - (acos $X) $A) - (, ! - (, - (precomp_is $X $U) - ( ($acos $U $A))))) True) -; - - (= - (--> - (precompile_is - (atan $X) $A) - (, ! - (, - (precomp_is $X $U) - ( ($atan $U $A))))) True) -; - - (= - (--> - (precompile_is - (sqrt $X) $A) - (, ! - (, - (precomp_is $X $U) - ( ($sqrt $U $A))))) True) -; - - (= - (--> - (precompile_is - (log $X) $A) - (, ! - (, - (precomp_is $X $U) - ( ($log $U $A))))) True) -; - - (= - (--> - (precompile_is - (exp $X) $A) - (, ! - (, - (precomp_is $X $U) - ( ($exp $U $A))))) True) -; - - (= - (--> - (precompile_is - (** $X $Y) $A) - (, ! - (, - (precomp_is $X $U) - (, - (precomp_is $Y $V) - ( ($pow $U $V $A)))))) True) -; - - (= - (--> - (precompile_is - (degrees $X) $A) - (, ! - (, - (precomp_is $X $U) - ( ($degrees $U $A))))) True) -; - - (= - (--> - (precompile_is - (radians $X) $A) - (, ! - (, - (precomp_is $X $U) - ( ($radians $U $A))))) True) -; - - (= - (--> - (precompile_is - (rint $X) $A) - (, ! - (, - (precomp_is $X $U) - ( ($rint $U $A))))) True) -; - - (= - (--> - (precompile_is - (float $X) $A) - (, ! - (, - (precomp_is $X $U) - ( ($float $U $A))))) True) -; - - (= - (--> - (precompile_is - (float_integer_part $X) $A) - (, ! - (, - (precomp_is $X $U) - ( (%float_integer_part $U $A))))) True) -; - - (= - (--> - (precompile_is - (float_fractional_part $X) $A) - (, ! - (, - (precomp_is $X $U) - ( (%float_fractional_part $U $A))))) True) -; - - (= - (--> - (precompile_is - (truncate $X) $A) - (, ! - (, - (precomp_is $X $U) - ( ($truncate $U $A))))) True) -; - - (= - (--> - (precompile_is - (sign $X) $A) - (, ! - (, - (precomp_is $X $U) - ( ($sign $U $A))))) True) -; - - (= - (--> - (precompile_is $X $_) - (, - { (pl2am_error - (unknown arithemetic expression $X)) } - {fail })) True) -; - - - (= - (--> - (precomp_is $X $A) - (, - { (var $X) } - (, - { (var $A) } - (, ! - { (= $X $A) })))) True) -; - - (= - (--> - (precomp_is $X $A) - (precompile_is $X $A)) True) -; +; ;; finds void variables and allocates them in Alloc. + + (= (alloc-voids $Chunks $Alloc0 $Alloc) + (variables $Chunks $Vars) + (alloc-voids1 $Vars $Chunks $Alloc0 $Alloc)) + + (= (alloc_voids1 () $_ $Alloc $Alloc) True) + (= (alloc-voids1 (Cons $V $Vars) $Chunks $Alloc0 $Alloc) + (count-variable $V $Chunks 1) + (set-det) + (= $Alloc1 + (Cons + (:: $V void $Seen) $Alloc0)) + (alloc-voids1 $Vars $Chunks $Alloc1 $Alloc)) + (= (alloc-voids1 (Cons $_ $Vars) $Chunks $Alloc0 $Alloc) + (alloc-voids1 $Vars $Chunks $Alloc0 $Alloc)) ; -; - +; ;;;;;;;;; Compile Precompiled Instructions: get, put, put_clo, and put_cont - (= - (localize-meta $G0 $G) - ( (get-symbols &self - (= - (package_name $P) $_)) - (localize-meta $G0 $P $G) - (set-det))) -; + (= (--> (comp_instr (get $X $A) $LTI0 $LTI $GTI0 $GTI) (, ! (gen_get $X $A $LTI0 $LTI $GTI0 $GTI))) True) +; /* comp_instr(+Instr, +LTI0, ?LTI, +GTI0, ?GTI) Instr : Intermediate instruction LTI : [XN, YN, PN, Alloc] XN : The register a(XN) is available for "Term". YN : The register y(YN) is available for "Term[]". PN : The register p(PN) is available for "Predicate". Alloc : [[VarTerm, Register, Seen],...] GTI : [SN, SAlloc, SInstrs] SN : The registers s(SN), si(SN), or sf(SN) are available for static "Term". SAlloc : [[NonVarTerm:Type, Register, Seen],...] SInstrs : list of instructions for static terms. Seen : Unbound variable | yes | void Type : int | flo | con | str | lis | arr */ + (= (--> (comp_instr (put $X $V) $LTI0 $LTI $GTI0 $GTI) (, ! (gen_put $X $V $LTI0 $LTI $GTI0 $GTI))) True) + (= (--> (comp_instr (put_clo $X $V) $LTI0 $LTI $GTI0 $GTI) (, ! (gen_put_clo $X $V $LTI0 $LTI $GTI0 $GTI))) True) + (= (--> (comp_instr (put_cont $X $V) $LTI0 $LTI $GTI0 $GTI) (, ! (gen_put_cont $X $V $LTI0 $LTI $GTI0 $GTI))) True) + (= (--> (comp_instr $Instr $LTI $LTI $GTI $GTI) ($Instr)) True) +; +; ;;;;;;;;; put instructions + (= (--> (gen_put $_ $A $_ $_ $_ $_) (, {(nonvar $A) } (, ! (, {(pl2am_error ($A should be an unbound variable)) } {fail })))) True) + (= (--> (gen_put $X $A $LTI0 $LTI $GTI $GTI) (, {(var $X) } (, ! (, {(assign_reg $X $R $Seen $LTI0 $LTI) } (gen_put_var $R $Seen $A))))) True) + (= (--> (gen_put $X $A $LTI $LTI $GTI0 $GTI) (, {(integer $X) } (, ! (, {(assign_sreg (: $X int) $R $Seen $GTI0 $GTI1) } (gen_put_int $X $R $Seen $A $GTI1 $GTI))))) True) + (= (--> (gen_put $X $A $LTI $LTI $GTI0 $GTI) (, {(long $X) } (, ! (, {(assign_sreg (: $X long) $R $Seen $GTI0 $GTI1) } (gen_put_int $X $R $Seen $A $GTI1 $GTI))))) True) + (= (--> (gen_put $X $A $LTI $LTI $GTI0 $GTI) (, {(float $X) } (, ! (, {(assign_sreg (: $X flo) $R $Seen $GTI0 $GTI1) } (gen_put_float $X $R $Seen $A $GTI1 $GTI))))) True) + (= (--> (gen_put $X $A $LTI $LTI $GTI0 $GTI) (, {(is-symbol $X) } (, ! (, {(assign_sreg (: $X con) $R $Seen $GTI0 $GTI1) } (gen_put_con $X $R $Seen $A $GTI1 $GTI))))) True) + (= (--> (gen_put $X $A $LTI0 $LTI $GTI0 $GTI) (, {(, (ground $X) (= $X + (Cons $X1 $X2))) } (, ! (, (gen_put_args ($X1 $X2) ($R1 $R2) $LTI0 $LTI $GTI0 $GTI1) (, {(assign_sreg (: $X lis) $R $Seen $GTI1 $GTI2) } (gen_put_list ($R1 $R2) $R $Seen $A $GTI2 $GTI)))))) True) + (= (--> (gen_put $X $A $LTI0 $LTI $GTI0 $GTI) (, {(, (ground $X) (, (=.. $X (Cons $_ $Args)) (functor $X $F $N))) } (, ! (, {(assign_sreg (: (/ $F $N) con) $R0 $Seen0 $GTI0 $GTI1) } (, (gen_put_con (/ $F $N) $R0 $Seen0 $_ $GTI1 $GTI2) (, (gen_put_args $Args $Regs $LTI0 $LTI $GTI2 $GTI3) (, {(assign_sreg (: $Args arr) $R1 $Seen1 $GTI3 $GTI4) } (, (gen_put_str_args $Regs $R1 $Seen1 $_ $GTI4 $GTI5) (, {(assign_sreg (: $X str) $R $Seen $GTI5 $GTI6) } (gen_put_str ($R0 $R1) $R $Seen $A $GTI6 $GTI)))))))))) True) + (= (--> (gen_put $X $A $LTI0 $LTI $GTI0 $GTI) (, {(= $X + (Cons $X1 $X2)) } (, ! (, (gen_put_args ($X1 $X2) ($R1 $R2) $LTI0 $LTI1 $GTI0 $GTI) (, {(assign_reg $_ $R $Seen $LTI1 $LTI) } (, {(, (= $Seen yes) (= $R $A)) } ((put_list $R1 $R2 $R)))))))) True) + (= (--> (gen_put $X $A $LTI0 $LTI $GTI0 $GTI) (, {(, (=.. $X (Cons $_ $Args)) (functor $X $F $N)) } (, ! (, {(assign_sreg (: (/ $F $N) con) $R0 $Seen0 $GTI0 $GTI1) } (, (gen_put_con (/ $F $N) $R0 $Seen0 $_ $GTI1 $GTI2) (, (gen_put_args $Args $Regs $LTI0 $LTI1 $GTI2 $GTI) (, {(inc_YN $R1 $LTI1 $LTI2) } (, {(assign_reg $_ $R $Seen $LTI2 $LTI) } (, {(, (= $Seen yes) (= $R $A)) } (, ((put_str_args $Regs $R1)) ((put_str $R0 $R1 $R)))))))))))) True) - (= - (localize-meta Nil $_ Nil) - (set-det)) -; - - (= - (localize-meta - (Cons $G $Gs) $P - (Cons $G1 $Gs1)) - ( (localize-meta-goal $G $P $X) - (det-if-then-else - (= $X - (with_self $P $Y)) - (= $G1 $Y) - (= $G1 $X)) - (localize-meta $Gs $P $Gs1))) -; + (= (--> (gen_put_var void $_ $A) (, ! {(= $A void) })) True) ; +; void is a special constant. + (= (--> (gen_put_var $R $Seen $A) (, {(var $Seen) } (, ! (, {(, (= $Seen yes) (= $R $A)) } ((put_var $R)))))) True) + (= (--> (gen_put_var $R $_ $A) {(= $R $A) }) True) + (= (--> (gen_put_int $X $R $Seen $A $GTI0 $GTI) (, {(var $Seen) } (, ! (, {(, (= $Seen yes) (= $R $A)) } {(add_instr (put_int $X $R) $GTI0 $GTI) })))) True) + (= (--> (gen_put_int $_ $R $_ $A $GTI $GTI) {(= $R $A) }) True) - - (= - (localize-meta-goal $G $P $G1) - ( (var $G) - (set-det) - (localize-meta-goal - (call $G) $P $G1))) -; + (= (--> (gen_put_float $X $R $Seen $A $GTI0 $GTI) (, {(var $Seen) } (, ! (, {(, (= $Seen yes) (= $R $A)) } {(add_instr (put_float $X $R) $GTI0 $GTI) })))) True) + (= (--> (gen_put_float $_ $R $_ $A $GTI $GTI) {(= $R $A) }) True) - (= - (localize-meta-goal - (with_self $P $G) $_ $G1) - ( (set-det) (localize-meta-goal $G $P $G1))) -; + (= (--> (gen_put_con $X $R $Seen $A $GTI0 $GTI) (, {(var $Seen) } (, ! (, {(, (= $Seen yes) (= $R $A)) } {(add_instr (put_con $X $R) $GTI0 $GTI) })))) True) + (= (--> (gen_put_con $_ $R $_ $A $GTI $GTI) {(= $R $A) }) True) - (= - (localize-meta-goal - (, $X $Y) $P - (, $X1 $Y1)) - ( (set-det) - (localize-meta-goal $X $P $X1) - (localize-meta-goal $Y $P $Y1))) -; + (= (--> (gen_put_list ($R1 $R2) $R $Seen $A $GTI0 $GTI) (, {(var $Seen) } (, ! (, {(, (= $Seen yes) (= $R $A)) } {(add_instr (put_list $R1 $R2 $R) $GTI0 $GTI) })))) True) + (= (--> (gen_put_list $_ $R $_ $A $GTI $GTI) {(= $R $A) }) True) - (= - (localize-meta-goal - (det-if-then $X $Y) $P - (det-if-then $X1 $Y1)) - ( (set-det) - (localize-meta-goal $X $P $X1) - (localize-meta-goal $Y $P $Y1))) -; + (= (--> (gen_put_str_args $Regs $R $Seen $A $GTI0 $GTI) (, {(var $Seen) } (, ! (, {(, (= $Seen yes) (= $R $A)) } {(add_instr (put_str_args $Regs $R) $GTI0 $GTI) })))) True) + (= (--> (gen_put_str_args $_ $R $_ $A $GTI $GTI) {(= $R $A) }) True) - (= - (localize-meta-goal - (or $X $Y) $P - (or $X1 $Y1)) - ( (set-det) - (localize-meta-goal $X $P $X1) - (localize-meta-goal $Y $P $Y1))) -; + (= (--> (gen_put_str ($R0 $R1) $R $Seen $A $GTI0 $GTI) (, {(var $Seen) } (, ! (, {(, (= $Seen yes) (= $R $A)) } {(add_instr (put_str $R0 $R1 $R) $GTI0 $GTI) })))) True) + (= (--> (gen_put_str $_ $R $_ $A $GTI $GTI) {(= $R $A) }) True) - (= - (localize-meta-goal $G $P $G1) - ( (functor $G $F $A) - (or - (get-symbols &self - (= - (meta_predicates $F $A $M) $_)) - (builtin-local-predicates $F $A $M)) - (set-det) - (=.. $G - (Cons $F $As)) - (localize-meta-args $M $As $P $As1) - (=.. $G1 - (Cons $F $As1)))) -; + (= (--> (gen_put_args () () $LTI $LTI $GTI $GTI) !) True) + (= (--> (gen_put_args (Cons $X $Xs) (Cons $R $Rs) $LTI0 $LTI $GTI0 $GTI) (, (gen_put $X $R $LTI0 $LTI1 $GTI0 $GTI1) (gen_put_args $Xs $Rs $LTI1 $LTI $GTI1 $GTI))) True) - (= - (localize-meta-goal $G $P - (call (with_self $P $G))) - ( (var $P) (set-det))) -; + (= (--> (gen_put_clo (: $P $X) $A $LTI0 $LTI $GTI0 $GTI) (, {(=.. $X (Cons $F $Args)) } (, ! (, (gen_put_args $Args $Regs $LTI0 $LTI1 $GTI0 $GTI) (, {(assign_reg $_ $R $Seen $LTI1 $LTI) } (, {(, (= $Seen yes) (= $R $A)) } (, {(=.. $X1 (Cons $F $Regs)) } (, {(; (-> (clause (package_name $P) $_) (= $CLO $X1)) (= $CLO + (: $P $X1))) } ((put_clo $CLO $R)))))))))) True) - (= - (localize-meta-goal $G $_ $G) - ( (system-predicate $G) (set-det))) -; +; +; ;;;;;;;;; get instructions + (= (--> (gen_get $X $A $LTI0 $LTI $GTI0 $GTI) (gen_get ((= $A $X)) $LTI0 $LTI $GTI0 $GTI)) True) + + (= (--> (gen_get () $LTI $LTI $GTI $GTI) !) True) + (= (--> (gen_get (Cons (= $A $X) $_) $LTI $LTI $GTI $GTI) (, {(var $A) } (, ! (, {(pl2am_error ($A must not be a variable in (get $X $A))) } {fail })))) True) + (= (--> (gen_get (Cons (= $A $X) $Instrs) $LTI0 $LTI $GTI0 $GTI) (, {(var $X) } (, {(assign_reg $X $R $Seen $LTI0 $LTI1) } (, {(nonvar $Seen) } (, ! (, (gen_get_var $R $Seen $A) (gen_get $Instrs $LTI1 $LTI $GTI0 $GTI))))))) True) + (= (--> (gen_get (Cons (= $A $X) $Instrs) $LTI0 $LTI $GTI0 $GTI) (, {(var $X) } (, ! (, {(add_alloc ($X $A yes) $LTI0 $LTI1) } (gen_get $Instrs $LTI1 $LTI $GTI0 $GTI))))) True) + (= (--> (gen_get (Cons (= $A $X) $Instrs) $LTI0 $LTI $GTI0 $GTI) (, {(integer $X) } (, ! (, (gen_put $X $R $LTI0 $LTI1 $GTI0 $GTI1) (, ((get_int $X $R $A)) (gen_get $Instrs $LTI1 $LTI $GTI1 $GTI)))))) True) + (= (--> (gen_get (Cons (= $A $X) $Instrs) $LTI0 $LTI $GTI0 $GTI) (, {(float $X) } (, ! (, (gen_put $X $R $LTI0 $LTI1 $GTI0 $GTI1) (, ((get_float $X $R $A)) (gen_get $Instrs $LTI1 $LTI $GTI1 $GTI)))))) True) + (= (--> (gen_get (Cons (= $A $X) $Instrs) $LTI0 $LTI $GTI0 $GTI) (, {(is-symbol $X) } (, ! (, (gen_put $X $R $LTI0 $LTI1 $GTI0 $GTI1) (, ((get_con $X $R $A)) (gen_get $Instrs $LTI1 $LTI $GTI1 $GTI)))))) True) + (= (--> (gen_get (Cons (= $A $X) $Instrs) $LTI0 $LTI $GTI0 $GTI) (, {(ground $X) } (, ! (, (gen_put $X $R $LTI0 $LTI1 $GTI0 $GTI1) (, ((get_ground $X $R $A)) (gen_get $Instrs $LTI1 $LTI $GTI1 $GTI)))))) True) + (= (--> (gen_get (Cons (= $A $X) $Instrs) $LTI0 $LTI $GTI0 $GTI) (, {(= $X + (Cons $X1 $X2)) } (, ! (, ((get_list $A)) (, (gen_unify ($X1 $X2) $Instrs1 $LTI0 $LTI1 $GTI0 $GTI1) (, (gen_get $Instrs1 $LTI1 $LTI2 $GTI1 $GTI2) (gen_get $Instrs $LTI2 $LTI $GTI2 $GTI))))))) True) + (= (--> (gen_get (Cons (= $A $X) $Instrs) $LTI0 $LTI $GTI0 $GTI) (, {(, (=.. $X (Cons $F $Args)) (functor $X $F $N)) } (, {(assign_sreg (: (/ $F $N) con) $R $Seen $GTI0 $GTI1) } (, (gen_put_con (/ $F $N) $R $Seen $_ $GTI1 $GTI2) (, ((get_str (/ $F $N) $R $A)) (, (gen_unify $Args $Instrs1 $LTI0 $LTI1 $GTI2 $GTI3) (, (gen_get $Instrs1 $LTI1 $LTI2 $GTI3 $GTI4) (gen_get $Instrs $LTI2 $LTI $GTI4 $GTI)))))))) True) + + (= (--> (gen_get_var void $_ $_) !) True) + (= (--> (gen_get_var $R $_ $A) ((get_val $R $A))) True) - (= - (localize_meta_goal $G $P - (: $P $G)) True) -; +; +; ;;;;;;;;; unify instructions + (= (--> (gen_unify () () $LTI $LTI $GTI $GTI) !) True) + (= (--> (gen_unify (Cons $X $Xs) $Instrs $LTI0 $LTI $GTI0 $GTI) (, {(var $X) } (, ! (, {(assign_reg $X $R $Seen $LTI0 $LTI1) } (, (gen_unify_var $R $Seen) (gen_unify $Xs $Instrs $LTI1 $LTI $GTI0 $GTI)))))) True) + (= (--> (gen_unify (Cons $X $Xs) $Instrs $LTI0 $LTI $GTI0 $GTI) (, {(integer $X) } (, ! (, (gen_put $X $R $LTI0 $LTI1 $GTI0 $GTI1) (, ((unify_int $X $R)) (gen_unify $Xs $Instrs $LTI1 $LTI $GTI1 $GTI)))))) True) + (= (--> (gen_unify (Cons $X $Xs) $Instrs $LTI0 $LTI $GTI0 $GTI) (, {(float $X) } (, ! (, (gen_put $X $R $LTI0 $LTI1 $GTI0 $GTI1) (, ((unify_float $X $R)) (gen_unify $Xs $Instrs $LTI1 $LTI $GTI1 $GTI)))))) True) + (= (--> (gen_unify (Cons $X $Xs) $Instrs $LTI0 $LTI $GTI0 $GTI) (, {(is-symbol $X) } (, ! (, (gen_put $X $R $LTI0 $LTI1 $GTI0 $GTI1) (, ((unify_con $X $R)) (gen_unify $Xs $Instrs $LTI1 $LTI $GTI1 $GTI)))))) True) + (= (--> (gen_unify (Cons $X $Xs) $Instrs $LTI0 $LTI $GTI0 $GTI) (, {(ground $X) } (, ! (, (gen_put $X $R $LTI0 $LTI1 $GTI0 $GTI1) (, ((unify_ground $X $R)) (gen_unify $Xs $Instrs $LTI1 $LTI $GTI1 $GTI)))))) True) + (= (--> (gen_unify (Cons $X $Xs) (Cons (= $R $X) $Instrs) $LTI0 $LTI $GTI0 $GTI) (, {(assign_reg $_ $R $Seen $LTI0 $LTI1) } (, (gen_unify_var $R $Seen) (gen_unify $Xs $Instrs $LTI1 $LTI $GTI0 $GTI)))) True) +; +; ;; unify_void, unify_variable, unify_value + (= (--> (gen_unify_var void $_) (, ! ((unify_void 1)))) True) + (= (--> (gen_unify_var $R $Seen) (, {(var $Seen) } (, ! (, {(= $Seen yes) } ((unify_var $R)))))) True) + (= (--> (gen_unify_var $R $_) ((unify_val $R))) True) - - (= - (localize-meta-args Nil Nil $_ Nil) - (set-det)) -; +; +; ;;;;;;;;; generate continuation goal + (= (--> (gen_put_cont $X $R $LTI0 $LTI $GTI $GTI) (, {(inc_PN $R $LTI0 $LTI) } ((put_cont $X $R)))) True) - (= - (localize-meta-args - (Cons : $Ms) - (Cons $A $As) $P +; +; ;; A register + + (= (assign-reg $X $Reg $Seen $LTI0 $LTI) + (nonvar $X) + (set-det) + (pl2am-error (:: $X must be unbound variable in (assign-reg $X $Reg $Seen $LTI0 $LTI))) + (fail)) + (= (assign-reg $X $Reg $Seen (:: $XN $YN $PN $Alloc) (:: $XN $YN $PN $Alloc)) + (allocated $Alloc $X + (:: $Reg $Seen)) + (set-det)) + (= (assign-reg $X $Reg $Seen (:: $XN $YN $PN $Alloc) (:: $XN1 $YN $PN $Alloc1)) + (= $Reg + (a $XN)) + (is $XN1 + (+ $XN 1)) + (= $Alloc1 (Cons - (with_self $P $A) $As1)) - ( (or - (var $A) - (\= $A - (with_self $_ $_))) - (set-det) - (localize-meta-args $Ms $As $P $As1))) -; + (:: $X $Reg $Seen) $Alloc))) - (= - (localize-meta-args - (Cons or $Ms) - (Cons $A $As) $P - (Cons - (with_self $P $A) $As1)) - ( (or - (var $A) - (\= $A - (with_self $_ $_))) - (set-det) - (localize-meta-args $Ms $As $P $As1))) -; + + (= (allocated (Cons (Cons $V $X) $_) $V0 $X) + (== $V $V0) + (set-det)) + (= (allocated (Cons $_ $Alloc) $V0 $X) + (allocated $Alloc $V0 $X)) - (= - (localize-meta-args - (Cons $_ $Ms) - (Cons $A $As) $P - (Cons $A $As1)) - (localize-meta-args $Ms $As $P $As1)) -; +; +; ;; S register + + (= (assign-sreg $X $Reg $Seen $GTI0 $GTI) + (not (ground $X)) + (set-det) + (pl2am-error (:: $X must be ground term in (assign-sreg $X $Reg $Seen $GTI0 $GTI))) + (fail)) + (= (assign-sreg $X $Reg $Seen (:: $SN $SAlloc $SInstrs) (:: $SN $SAlloc $SInstrs)) + (allocated $SAlloc $X + (:: $Reg $Seen)) + (set-det)) + (= (assign-sreg (with_self $X $T) $Reg $Seen (:: $SN $SAlloc $SInstrs) (:: $SN1 $SAlloc1 $SInstrs)) + (assign-sreg0 $T $SN $Reg) + (is $SN1 + (+ $SN 1)) + (= $SAlloc1 + (Cons + (:: + (with_self $X $T) $Reg $Seen) $SAlloc))) + + (= (assign-sreg0 int $SN (si $SN)) + (set-det)) + (= (assign-sreg0 flo $SN (sf $SN)) + (set-det)) + (= (assign-sreg0 $_ $SN (s $SN)) + (set-det)) +; +; assign_sreg0(con, SN, sc(SN)) :- !. +; +; assign_sreg0(str, SN, ss(SN)) :- !. +; +; assign_sreg0(lis, SN, sl(SN)) :- !. +; +; assign_sreg0(arr, SN, sa(SN)) :- !. ; -; +; ;; incriment YN - - (= - (precompile $Head $Goals $Instrs) - ( (precompile-head $Head $Instrs0 $Bs) - (precompile-body $Goals $Bs Nil) - (optimize-recursive-call $Head $Instrs0 $Instrs))) -; + (= (inc-YN (y $YN) (Cons $XN (Cons $YN $Zs)) (Cons $XN (Cons $YN1 $Zs))) + (is $YN1 + (+ $YN 1))) +; +; ;; incriment PN + + (= (inc-PN (p $PN) (Cons $XN (Cons $YN (Cons $PN $Zs))) (Cons $XN (Cons $YN (Cons $PN1 $Zs)))) + (is $PN1 + (+ $PN 1))) ; -; - - - (= - (--> - (precompile_head $Head) - (, - { (=.. $Head - (Cons $_ $Args)) } - (precomp_head $Args 1))) True) -; - - - (= - (--> - (precomp_head () $_) !) True) -; - - (= - (--> - (precomp_head - (Cons $A $As) $I) - (, - ( (get $A - (a $I))) - (, - { (is $I1 - (+ $I 1)) } - (precomp_head $As $I1)))) True) -; +; ;; add an instruction to GTI + + (= (add_instr $Instr ($SN $SAlloc $SInstrs0) ($SN $SAlloc (Cons $Instr $SInstrs0))) True) +; +; ;; add an allocation to LTI + + (= (add_alloc $E ($XN $YN $PN $Alloc0) ($XN $YN $PN (Cons $E $Alloc0))) True) + + + (= (builtin_meta_predicates ^ 2 (? :)) True) +; /***************************************************************** Built-in Predicates and Constants *****************************************************************/ + (= (builtin_meta_predicates call 1 (:)) True) + (= (builtin_meta_predicates once 1 (:)) True) + (= (builtin_meta_predicates \+ 1 (:)) True) + (= (builtin_meta_predicates findall 3 (? : ?)) True) + (= (builtin_meta_predicates bagof 3 (? : ?)) True) + (= (builtin_meta_predicates setof 3 (? : ?)) True) + (= (builtin_meta_predicates on_exception 3 (? : :)) True) + (= (builtin_meta_predicates catch 3 (: ? :)) True) + (= (builtin_meta_predicates synchronized 2 (? :)) True) + (= (builtin_meta_predicates freeze 2 (? :)) True) + + + (= (builtin_local_predicates assert 1 (:)) True) + (= (builtin_local_predicates asserta 1 (:)) True) + (= (builtin_local_predicates assertz 1 (:)) True) + (= (builtin_local_predicates retract 1 (:)) True) + (= (builtin_local_predicates retractall 1 (:)) True) + (= (builtin_local_predicates assert 2 (: ?)) True) + (= (builtin_local_predicates asserta 2 (: ?)) True) + (= (builtin_local_predicates assertz 2 (: ?)) True) + (= (builtin_local_predicates retract 2 (: ?)) True) + (= (builtin_local_predicates retractall 2 (: ?)) True) + (= (builtin_local_predicates save 2 (? :)) True) + (= (builtin_local_predicates clause 2 (: ?)) True) + (= (builtin_local_predicates abolish 1 (:)) True) + (= (builtin_local_predicates log_level 1 (:)) True) + (= (builtin_local_predicates loggable 1 (:)) True) + (= (builtin_local_predicates log_error 2 (: ?)) True) + (= (builtin_local_predicates log 2 (: ?)) True) + (= (builtin_local_predicates log 3 (: ? ?)) True) + (= (builtin_local_predicates log 4 (: ? ? ?)) True) + (= (builtin_local_predicates log 5 (: ? ? ? ?)) True) + (= (builtin_local_predicates log 6 (: ? ? ? ? ?)) True) + (= (builtin_local_predicates log 7 (: ? ? ? ? ? ?)) True) + + (= (builtin_meta_predicates with_mutex 2 (? :)) True) ; -; +; Control constructs + (= (builtin_inline_predicates fail) True) + (= (builtin_inline_predicates (%get_level $_)) True) + (= (builtin_inline_predicates $neck_cut) True) + (= (builtin_inline_predicates (%cut $_)) True) ; -; - - (= - (--> - (precompile_body $Goals) - (, - { (clause - (pl2am_flag ie) $_) } - (, ! - (, - { (pickup_inline_goals $Goals $IGs $Gs) } - (precomp_inline $IGs $Gs))))) True) -; - - (= - (--> - (precompile_body $Goals) - (precomp_body $Goals)) True) -; - - - (= - (--> - (precomp_body ()) - (, ! - ( (execute cont)))) True) -; - - (= - (--> - (precomp_body - (Cons - (: $M $G) $Cont)) - (, ! - (, - (binarize_body $G $Cont $G1) - ( (execute - (: $M $G1)))))) True) -; - - (= - (--> - (precomp_body - (Cons $G $Cont)) - (, - (binarize_body $G $Cont $G1) - ( (execute $G1)))) True) -; - - - (= - (--> - (binarize_body $G $Cont $G1) - (, - { (=.. $G - (Cons $F $Args)) } - (, - { (functor $G $F $A) } - (, - (precomp_call $Args $Us $F $A) - (, - (precomp_cont $Cont $V) - (, - { (pl2am_append $Us - ($V) $Ws) } - { (=.. $G1 - (Cons $F $Ws)) })))))) True) -; - - - (= - (--> - (precomp_call () ()) !) True) -; - - (= - (--> - (precomp_call - (Cons $A $As) - (Cons $U $Us)) - (, - ( (put $A $U)) - (precomp_call $As $Us))) True) -; - - - (= - (--> - (precomp_cont () cont) !) True) -; - - (= - (--> - (precomp_cont - (Cons - (: $M $G) $Cont) $V) - (, ! - (, - (binarize_body $G $Cont $G1) - ( (put_cont - (: $M $G1) $V))))) True) -; - - (= - (--> - (precomp_cont - (Cons $G $Cont) $V) - (, - (binarize_body $G $Cont $G1) - ( (put_cont $G1 $V)))) True) -; - - - (= - (--> - (precomp_inline () $Gs1) - (, ! - (precomp_body $Gs1))) True) -; - - (= - (--> - (precomp_inline - (Cons fail $_) $_) - (, ! - ( (inline fail)))) True) -; - - (= - (--> - (precomp_inline - (Cons $G $Gs) $Gs1) - (, - { (=.. $G - (Cons $F $Args)) } - (, - { (functor $G $F $A) } - (, - (precomp_call $Args $Us $F $A) - (, - { (=.. $G1 - (Cons $F $Us)) } - (, - ( (inline $G1)) - (precomp_inline $Gs $Gs1))))))) True) -; - - - - (= - (pickup-inline-goals Nil Nil Nil) - (set-det)) -; - - (= - (pickup-inline-goals - (Cons $G $Gs) - (Cons $G $IGs) $BGs) - ( (builtin-inline-predicates $G) - (set-det) - (pickup-inline-goals $Gs $IGs $BGs))) -; - - (= - (pickup_inline_goals $Gs () $Gs) True) -; - - +; Term unification + (= (builtin_inline_predicates (%unify $_ $_)) True) + (= (builtin_inline_predicates (%not_unifiable $_ $_)) True) ; -; - - - (= - (--> - (precomp_call $As $Us $Functor $Arity) - (, - { (clause - (pl2am_flag clo) $_) } - (, - { (clause - (meta_predicates $Functor $Arity $Mode) $_) } - (, ! - (, - { (clause - (package_name $P) $_) } - (precomp_closure $Mode $As $P $Us)))))) True) -; - - (= - (--> - (precomp_call $As $Us $_ $_) - (precomp_call $As $Us)) True) -; - - - (= - (--> - (precomp_closure () () $_ ()) !) True) -; - - (= - (--> - (precomp_closure - (Cons : $Ms) - (Cons $A $As) $P - (Cons $U $Us)) - (, - { (get_closure $A $P $C) } - (, ! - (, - ( (put_clo $C $U)) - (precomp_closure $Ms $As $P $Us))))) True) -; - - (= - (--> - (precomp_closure - (Cons $_ $Ms) - (Cons $A $As) $P - (Cons $U $Us)) - (, - ( (put $A $U)) - (precomp_closure $Ms $As $P $Us))) True) -; - - - - (= - (get-closure $G $_ $_) - ( (var $G) - (set-det) - (fail))) -; +; Type testing + (= (builtin_inline_predicates (var $_)) True) + (= (builtin_inline_predicates (is-symbol $_)) True) + (= (builtin_inline_predicates (integer $_)) True) + (= (builtin_inline_predicates (long $_)) True) + (= (builtin_inline_predicates (float $_)) True) + (= (builtin_inline_predicates (is-symbolic $_)) True) + (= (builtin_inline_predicates (nonvar $_)) True) + (= (builtin_inline_predicates (number $_)) True) + (= (builtin_inline_predicates (java $_)) True) + (= (builtin_inline_predicates (java $_ $_)) True) + (= (builtin_inline_predicates (closure $_)) True) + (= (builtin_inline_predicates (ground $_)) True) +; +; Term comparison + (= (builtin_inline_predicates (%equality_of_term $_ $_)) True) + (= (builtin_inline_predicates (%inequality_of_term $_ $_)) True) + (= (builtin_inline_predicates (%after $_ $_)) True) + (= (builtin_inline_predicates (%before $_ $_)) True) + (= (builtin_inline_predicates (%not_after $_ $_)) True) + (= (builtin_inline_predicates (%not_before $_ $_)) True) + (= (builtin_inline_predicates (%identical_or_cannot_unify $_ $_)) True) +; +; Term creation and decomposition + (= (builtin_inline_predicates (copy_term $_ $_)) True) +; +; Arithmetic evaluation + (= (builtin_inline_predicates (is $_ $_)) True) + (= (builtin_inline_predicates (%abs $_ $_)) True) + (= (builtin_inline_predicates (%asin $_ $_)) True) + (= (builtin_inline_predicates (%acos $_ $_)) True) + (= (builtin_inline_predicates (%atan $_ $_)) True) + (= (builtin_inline_predicates (%bitwise_conj $_ $_ $_)) True) + (= (builtin_inline_predicates (%bitwise_disj $_ $_ $_)) True) + (= (builtin_inline_predicates (%bitwise_exclusive_or $_ $_ $_)) True) + (= (builtin_inline_predicates (%bitwise_neg $_ $_)) True) + (= (builtin_inline_predicates (%ceil $_ $_)) True) + (= (builtin_inline_predicates (%cos $_ $_)) True) + (= (builtin_inline_predicates (%degrees $_ $_)) True) + (= (builtin_inline_predicates (%exp $_ $_)) True) + (= (builtin_inline_predicates (%float_quotient $_ $_ $_)) True) + (= (builtin_inline_predicates (%floor $_ $_)) True) + (= (builtin_inline_predicates (%int_quotient $_ $_ $_)) True) + (= (builtin_inline_predicates (%log $_ $_)) True) + (= (builtin_inline_predicates (%max $_ $_ $_)) True) + (= (builtin_inline_predicates (%min $_ $_ $_)) True) + (= (builtin_inline_predicates (%minus $_ $_ $_)) True) + (= (builtin_inline_predicates (%mod $_ $_ $_)) True) + (= (builtin_inline_predicates (%multi $_ $_ $_)) True) + (= (builtin_inline_predicates (%plus $_ $_ $_)) True) + (= (builtin_inline_predicates (%pow $_ $_ $_)) True) + (= (builtin_inline_predicates (%radians $_ $_)) True) + (= (builtin_inline_predicates (%rint $_ $_)) True) + (= (builtin_inline_predicates (%round $_ $_)) True) + (= (builtin_inline_predicates (%shift_left $_ $_ $_)) True) + (= (builtin_inline_predicates (%shift_right $_ $_ $_)) True) + (= (builtin_inline_predicates (%sin $_ $_)) True) + (= (builtin_inline_predicates (%sqrt $_ $_)) True) + (= (builtin_inline_predicates (%tan $_ $_)) True) + (= (builtin_inline_predicates (%float $_ $_)) True) + (= (builtin_inline_predicates (%float_integer_part $_ $_)) True) + (= (builtin_inline_predicates (%float_fractional_part $_ $_)) True) + (= (builtin_inline_predicates (%truncate $_ $_)) True) + (= (builtin_inline_predicates (%sign $_ $_)) True) +; +; Arithmetic comparison + (= (builtin_inline_predicates (%arith_equal $_ $_)) True) + (= (builtin_inline_predicates (%arith_not_equal $_ $_)) True) + (= (builtin_inline_predicates (%greater_or_equal $_ $_)) True) + (= (builtin_inline_predicates (%greater_than $_ $_)) True) + (= (builtin_inline_predicates (%less_or_equal $_ $_)) True) + (= (builtin_inline_predicates (%less_than $_ $_)) True) + + + (= (builtin_arith_constant random) True) + (= (builtin_arith_constant pi) True) + (= (builtin_arith_constant e) True) + + + (= (eliminate-disj $Cl $NewCl $DummyCls) + (extract-disj $Cl $NewCl $Disjs Nil) + (treat-disj $Disjs $DummyCls Nil)) +; /***************************************************************** Eliminate disjunctions *****************************************************************/ +; ; The clause a :- b;c is converted into a :- b. and a :- c. ; In addition, ; (C1 -> C2) is converted into ((C1,!,C2) ; fail). ; ((C1 -> C2) ; C3) is converted into ((C1,!,C2) ; C3). ; not(C) is converted into ((C,!,fail) ; true). ; \+(C) is converted into ((C,!,fail) ; true). ; And then all of disjunctions are eliminated. ; ; Note: this is based on flatten.pl in holmer's benchmark. + + + (= (--> (extract_disj $Cl $Cl) (, {(var $Cl) } !)) True) + (= (--> (extract_disj $Cl (:- $H $NewB)) (, {(= $Cl + (:- $H $B)) } (, ! (extract_disj $B $NewB $Cl)))) True) + (= (--> (extract_disj $Cl $Cl) !) True) + + (= (--> (extract_disj $G $G $_) (, {(var $G) } !)) True) + (= (--> (extract_disj (, $G1 $G2) (, $NewG1 $NewG2) $Cl) (, ! (, (extract_disj $G1 $NewG1 $Cl) (extract_disj $G2 $NewG2 $Cl)))) True) + (= (--> (extract_disj $G $NewG $Cl) (, {(is_disj $G $DisjG) } (, ! (, {(retract (dummy_clause_counter $N)) } (, ((disj $DisjG $N $NewG $Cl)) (, {(is $N1 (+ $N 1)) } {(assert (dummy_clause_counter $N1)) })))))) True) + (= (--> (extract_disj $G $G $_) !) True) + + + (= (is-disj (det-if-then $C1 $C2) (or (, $C1 (set-det) $C2) fail)) + (set-det)) + (= (is-disj (det-if-then-else $C1 $C2 $C3) (or (, $C1 (set-det) $C2) $C3)) + (set-det)) + (= (is-disj (or $C1 $C2) (or $C1 $C2)) + (set-det)) + (= (is-disj (not $C) (or (, $C (set-det) (fail)) True)) + (set-det)) + (= (is_disj (\+ $C) (; (, $C (, ! fail)) true)) True) + + + (= (--> (treat_disj ()) !) True) + (= (--> (treat_disj (Cons (disj (; $A $B) $N $X $C) $Disjs)) (, {(variables (; $A $B) $Vars) } (, {(variables $C $CVars) } (, {(intersect_vars $Vars $CVars $Args) } (, {(clause (file_name $File) $_) } (, {(list_to_string ($dummy_ $N _ $File) $Name) } (, {(=.. $X (Cons $Name $Args)) } (, {(copy_term (:- $X $A) $DummyCla) } (, {(copy_term (:- $X $B) $DummyClb) } (, ($DummyCla) (, ($DummyClb) (treat_disj $Disjs)))))))))))) True) + + + (= (intersect-vars $V1 $V2 $Out) + (sort $V1 $Sorted1) + (sort $V2 $Sorted2) + (intersect-sorted-vars $Sorted1 $Sorted2 $Out)) + + + (= (intersect-sorted-vars Nil $_ Nil) + (set-det)) + (= (intersect_sorted_vars $_ () ()) True) + (= (intersect-sorted-vars (Cons $X $Xs) (Cons $Y $Ys) (Cons $X $Rs)) + (== $X $Y) + (set-det) + (intersect-sorted-vars $Xs $Ys $Rs)) + (= (intersect-sorted-vars (Cons $X $Xs) (Cons $Y $Ys) $Rs) + (@< $X $Y) + (set-det) + (intersect-sorted-vars $Xs + (Cons $Y $Ys) $Rs)) + (= (intersect-sorted-vars (Cons $X $Xs) (Cons $Y $Ys) $Rs) + (@> $X $Y) + (set-det) + (intersect-sorted-vars + (Cons $X $Xs) $Ys $Rs)) - (= - (get-closure $_ $P $_) - ( (var $P) + + (= (pl2am-error $M) + ( (== + (= + (file_line $File $Line) $_) + (get-atoms &self)) (set-det) - (fail))) -; + (pl2am-message user-error + (Cons *** + (Cons PL2ASM + (Cons ERROR + (Cons in + (Cons $File + (Cons at + (Cons $Line + (Cons : $M))))))))))) +; /***************************************************************** Utilities *****************************************************************/ +; ;;; print - (= - (get-closure - (with_self $P $G) $_ $Clo) - ( (set-det) (get-closure $G $P $Clo))) -; + (= (pl2am-error $M) + (pl2am-message user-error + (Cons *** + (Cons PL2ASM + (Cons ERROR $M))))) - (= - (get-closure $G $P - (with_self $P $G)) - ( (atom $P) - (callable $G) - (functor $G $F $A) - (not (get-symbols &self (= (dynamic_predicates $F $A $_) $_))) - (set-det))) -; + + (= (pl2am-message $M) + (pl2am-message user-output $M)) + (= (pl2am-message $Stream Nil) + (nl $Stream) + (flush-output $Stream)) + (= (pl2am-message $Stream (Cons $M $Ms)) + (write $Stream $M) + (write $Stream ' ') + (pl2am-message $Stream $Ms)) ; -; +; ;; format - - (= - (optimize-recursive-call $Head $Instrs0 $Instrs) - ( (get-symbols &self - (= - (pl2am_flag rc) $_)) - (set-det) - (optimize-rc $Instrs0 $Head $Instrs Nil))) -; - - (= - (optimize_recursive_call $_ $Instrs $Instrs) True) -; - - - - (= - (--> - (optimize_rc () $_) !) True) -; - - (= - (--> - (optimize_rc - (Cons - (execute $Goal) $Xs) $Head) - (, - { (functor $Head $F $A) } - (, - { (functor $Goal $F $A1) } - (, - { (=:= - (+ $A 1) $A1) } - (, ! - (, - { (assert_copts - (rc $F $A)) } - (, - { (=.. $Goal - (Cons $F $Args)) } - (, - { (range_reg 1 $A ea $Rs0) } - (, - { (pl2am_append $Rs0 - (econt) $Rs) } - (, - (gen_set $Args $Rs) - (, - ( (goto - (+ - (/ $F $A) top))) - (optimize_rc $Xs $Head)))))))))))) True) -; - - (= - (--> - (optimize_rc - (Cons $X $Xs) $Head) - (, - ($X) - (optimize_rc $Xs $Head))) True) -; + (= (mode_expr ()) True) + (= (mode-expr (Cons $M $Ms)) + (nonvar $M) + (pl2am-member $M + (:: : or + - ?)) + (set-det) + (mode-expr $Ms)) + + (= (predspec-expr (/ $F $A)) + (atom $F) + (integer $A)) ; -; - - (= - (--> - (compile_chunks $Chunk $GTI0 $GTI $LTI) - (, - { (alloc_voids $Chunk () $Alloc) } - (compile_chunk $Chunk $Alloc $GTI0 $GTI $LTI))) True) -; - - - (= - (--> - (compile_chunk () $_ $GTI $GTI ()) !) True) -; - - (= - (--> - (compile_chunk $Chunk $Alloc $GTI0 $GTI $LTI) - (, - { (, - (free_x_reg $Chunk 1 $XN) - (, - (= $YN 1) - (= $PN 1))) } - (, - { (= $LTI0 - ($XN $YN $PN $Alloc)) } - (comp_chunk $Chunk $LTI0 $LTI $GTI0 $GTI)))) True) -; - - - (= - (--> - (comp_chunk () $LTI $LTI $GTI $GTI) !) True) -; - - (= - (--> - (comp_chunk - (Cons - (: $L ()) $Cs) $LTI0 $LTI $GTI0 $GTI) - (, ! - (, - ( (: $L ())) - (comp_chunk $Cs $LTI0 $LTI $GTI0 $GTI)))) True) -; - - (= - (--> - (comp_chunk - (Cons - (: $L $C) $Cs) $LTI0 $LTI $GTI0 $GTI) - (, ! - (, - ( (: $L ())) - (comp_chunk - (Cons $C $Cs) $LTI0 $LTI $GTI0 $GTI)))) True) -; - - (= - (--> - (comp_chunk - (Cons $C $Cs) $LTI0 $LTI $GTI0 $GTI) - (, ! - (, - (comp_instr $C $LTI0 $LTI1 $GTI0 $GTI1) - (comp_chunk $Cs $LTI1 $LTI $GTI1 $GTI)))) True) -; - +; ;; list + + (= (pl2am_append () $Zs $Zs) True) + (= (pl2am-append (Cons $X $Xs) $Ys (Cons $X $Zs)) + (pl2am-append $Xs $Ys $Zs)) -; -; + (= (pl2am-rev $L $R) + (pl2am-rev $L Nil $R)) + (= (pl2am_rev () $R $R) True) + (= (pl2am-rev (Cons $X $L) $Y $R) + (pl2am-rev $L + (Cons $X $Y) $R)) + - (= - (free_x_reg () $XN $XN) True) -; + (= (pl2am_member $X (Cons $X $_)) True) + (= (pl2am-member $X (Cons $_ $Ys)) + (pl2am-member $X $Ys)) - (= - (free-x-reg - (Cons - (get $_ $V) $Cs) $XN0 $XN) - ( (nonvar $V) - (= $V - (a $N)) - (set-det) - (is $XN1 - (max - (+ $N 1) $XN0)) - (free-x-reg $Cs $XN1 $XN))) -; - - (= - (free-x-reg - (Cons - (put $_ $V) $Cs) $XN0 $XN) - ( (nonvar $V) - (= $V - (a $N)) - (set-det) - (is $XN1 - (max - (+ $N 1) $XN0)) - (free-x-reg $Cs $XN1 $XN))) -; + + (= (pl2am-memq $X (Cons $Y $_)) + (== $X $Y) + (set-det)) + (= (pl2am-memq $X (Cons $_ $Ys)) + (pl2am-memq $X $Ys)) - (= - (free-x-reg - (Cons $_ $Cs) $XN0 $XN) - (free-x-reg $Cs $XN0 $XN)) -; + + (= (--> (flatten_list ()) !) True) + (= (--> (flatten_list (Cons $L1 $L2)) (, ! (, (flatten_list $L1) (flatten_list $L2)))) True) + (= (--> (flatten_list $L) ($L)) True) + (= (--> (flatten_code ()) !) True) + (= (--> (flatten_code (Cons (: $L $C) $Code)) (, ! (, ((: $L ())) (flatten_code (Cons $C $Code))))) True) + (= (--> (flatten_code (Cons $Code1 $Code2)) (, ! (, (flatten_code $Code1) (flatten_code $Code2)))) True) + (= (--> (flatten_code $Code) ($Code)) True) -; -; + (= (pl2am_maplist $_ () ()) True) + (= (pl2am-maplist $Goal (Cons $Elem1 $Tail1) (Cons $Elem2 $Tail2)) + (=.. $Term + (:: $Goal $Elem1 $Elem2)) + (call $Term) + (pl2am-maplist $Goal $Tail1 $Tail2)) + - (= - (alloc-voids $Chunks $Alloc0 $Alloc) - ( (variables $Chunks $Vars) (alloc-voids1 $Vars $Chunks $Alloc0 $Alloc))) -; + (= (pl2am-resolve-file $BaseFile $File $File) + (= $File + (with_self $Package $ResourceName)) + (set-det)) + (= (pl2am-resolve-file $BaseFile $File $IncludeFile) + (pl2am-file-directory $BaseFile $Directory) + (atom-concat $Directory $File $IncludeFile)) - (= - (alloc_voids1 () $_ $Alloc $Alloc) True) -; + (= (pl2am-file-directory $BaseFile $Directory) + (atom-chars $BaseFile $BaseFileChars) + (pl2am-rev $BaseFileChars $BaseFileCharsRev) + (pl2am-file-directory- $BaseFileCharsRev $DirectoryCharsRev) + (pl2am-add-directory-separator $DirectoryCharsRev $DirectoryCharsRev1) + (pl2am-rev $DirectoryCharsRev1 $DirectoryChars) + (atom-chars $Directory $DirectoryChars)) - (= - (alloc-voids1 - (Cons $V $Vars) $Chunks $Alloc0 $Alloc) - ( (count-variable $V $Chunks 1) - (set-det) - (= $Alloc1 - (Cons - (:: $V void $Seen) $Alloc0)) - (alloc-voids1 $Vars $Chunks $Alloc1 $Alloc))) -; - - (= - (alloc-voids1 - (Cons $_ $Vars) $Chunks $Alloc0 $Alloc) - (alloc-voids1 $Vars $Chunks $Alloc0 $Alloc)) -; - - -; -; - - - (= - (--> - (comp_instr - (get $X $A) $LTI0 $LTI $GTI0 $GTI) - (, ! - (gen_get $X $A $LTI0 $LTI $GTI0 $GTI))) True) -; - - (= - (--> - (comp_instr - (put $X $V) $LTI0 $LTI $GTI0 $GTI) - (, ! - (gen_put $X $V $LTI0 $LTI $GTI0 $GTI))) True) -; - - (= - (--> - (comp_instr - (put_clo $X $V) $LTI0 $LTI $GTI0 $GTI) - (, ! - (gen_put_clo $X $V $LTI0 $LTI $GTI0 $GTI))) True) -; - - (= - (--> - (comp_instr - (put_cont $X $V) $LTI0 $LTI $GTI0 $GTI) - (, ! - (gen_put_cont $X $V $LTI0 $LTI $GTI0 $GTI))) True) -; - - (= - (--> - (comp_instr $Instr $LTI $LTI $GTI $GTI) - ($Instr)) True) -; + + (= (pl2am-file-directory- Nil Nil) + (set-det)) + (= (pl2am-file-directory- (:: \) (:: \)) + (set-det)) + (= (pl2am-file-directory- (:: /) (:: /)) + (set-det)) + (= (pl2am-file-directory- (Cons \ $BaseFileCharsRev) $BaseFileCharsRev) + (set-det)) + (= (pl2am-file-directory- (Cons / $BaseFileCharsRev) $BaseFileCharsRev) + (set-det)) + (= (pl2am-file-directory- (Cons $_ $BaseFileCharsRev) $DirectoryCharsRev) + (pl2am-file-directory- $BaseFileCharsRev $DirectoryCharsRev)) + + (= (pl2am-add-directory-separator $D $D) + (= $D + (Cons / $_)) + (set-det)) + (= (pl2am-add-directory-separator $D $D) + (= $D + (Cons \ $_)) + (set-det)) + (= (pl2am_add_directory_separator $D (Cons / $D)) True) ; -; - - (= - (--> - (gen_put $_ $A $_ $_ $_ $_) - (, - { (nonvar $A) } - (, ! - (, - { (pl2am_error - ($A should be an unbound variable)) } - {fail })))) True) -; - - (= - (--> - (gen_put $X $A $LTI0 $LTI $GTI $GTI) - (, - { (var $X) } - (, ! - (, - { (assign_reg $X $R $Seen $LTI0 $LTI) } - (gen_put_var $R $Seen $A))))) True) -; - - (= - (--> - (gen_put $X $A $LTI $LTI $GTI0 $GTI) - (, - { (integer $X) } - (, ! - (, - { (assign_sreg - (: $X int) $R $Seen $GTI0 $GTI1) } - (gen_put_int $X $R $Seen $A $GTI1 $GTI))))) True) -; - - (= - (--> - (gen_put $X $A $LTI $LTI $GTI0 $GTI) - (, - { (long $X) } - (, ! - (, - { (assign_sreg - (: $X long) $R $Seen $GTI0 $GTI1) } - (gen_put_int $X $R $Seen $A $GTI1 $GTI))))) True) -; - - (= - (--> - (gen_put $X $A $LTI $LTI $GTI0 $GTI) - (, - { (float $X) } - (, ! - (, - { (assign_sreg - (: $X flo) $R $Seen $GTI0 $GTI1) } - (gen_put_float $X $R $Seen $A $GTI1 $GTI))))) True) -; - - (= - (--> - (gen_put $X $A $LTI $LTI $GTI0 $GTI) - (, - { (is-symbol $X) } - (, ! - (, - { (assign_sreg - (: $X con) $R $Seen $GTI0 $GTI1) } - (gen_put_con $X $R $Seen $A $GTI1 $GTI))))) True) -; - - (= - (--> - (gen_put $X $A $LTI0 $LTI $GTI0 $GTI) - (, - { (, - (ground $X) - (= $X - (Cons $X1 $X2))) } - (, ! - (, - (gen_put_args - ($X1 $X2) - ($R1 $R2) $LTI0 $LTI $GTI0 $GTI1) - (, - { (assign_sreg - (: $X lis) $R $Seen $GTI1 $GTI2) } - (gen_put_list - ($R1 $R2) $R $Seen $A $GTI2 $GTI)))))) True) -; - - (= - (--> - (gen_put $X $A $LTI0 $LTI $GTI0 $GTI) - (, - { (, - (ground $X) - (, - (=.. $X - (Cons $_ $Args)) - (functor $X $F $N))) } - (, ! - (, - { (assign_sreg - (: - (/ $F $N) con) $R0 $Seen0 $GTI0 $GTI1) } - (, - (gen_put_con - (/ $F $N) $R0 $Seen0 $_ $GTI1 $GTI2) - (, - (gen_put_args $Args $Regs $LTI0 $LTI $GTI2 $GTI3) - (, - { (assign_sreg - (: $Args arr) $R1 $Seen1 $GTI3 $GTI4) } - (, - (gen_put_str_args $Regs $R1 $Seen1 $_ $GTI4 $GTI5) - (, - { (assign_sreg - (: $X str) $R $Seen $GTI5 $GTI6) } - (gen_put_str - ($R0 $R1) $R $Seen $A $GTI6 $GTI)))))))))) True) -; - - (= - (--> - (gen_put $X $A $LTI0 $LTI $GTI0 $GTI) - (, - { (= $X - (Cons $X1 $X2)) } - (, ! - (, - (gen_put_args - ($X1 $X2) - ($R1 $R2) $LTI0 $LTI1 $GTI0 $GTI) - (, - { (assign_reg $_ $R $Seen $LTI1 $LTI) } - (, - { (, - (= $Seen yes) - (= $R $A)) } - ( (put_list $R1 $R2 $R)))))))) True) -; - - (= - (--> - (gen_put $X $A $LTI0 $LTI $GTI0 $GTI) - (, - { (, - (=.. $X - (Cons $_ $Args)) - (functor $X $F $N)) } - (, ! - (, - { (assign_sreg - (: - (/ $F $N) con) $R0 $Seen0 $GTI0 $GTI1) } - (, - (gen_put_con - (/ $F $N) $R0 $Seen0 $_ $GTI1 $GTI2) - (, - (gen_put_args $Args $Regs $LTI0 $LTI1 $GTI2 $GTI) - (, - { (inc_YN $R1 $LTI1 $LTI2) } - (, - { (assign_reg $_ $R $Seen $LTI2 $LTI) } - (, - { (, - (= $Seen yes) - (= $R $A)) } - (, - ( (put_str_args $Regs $R1)) - ( (put_str $R0 $R1 $R)))))))))))) True) -; - - - (= - (--> - (gen_put_var void $_ $A) - (, ! - { (= $A void) })) True) -; - ; -; - - (= - (--> - (gen_put_var $R $Seen $A) - (, - { (var $Seen) } - (, ! - (, - { (, - (= $Seen yes) - (= $R $A)) } - ( (put_var $R)))))) True) -; - - (= - (--> - (gen_put_var $R $_ $A) - { (= $R $A) }) True) -; - - - (= - (--> - (gen_put_int $X $R $Seen $A $GTI0 $GTI) - (, - { (var $Seen) } - (, ! - (, - { (, - (= $Seen yes) - (= $R $A)) } - { (add_instr - (put_int $X $R) $GTI0 $GTI) })))) True) -; - - (= - (--> - (gen_put_int $_ $R $_ $A $GTI $GTI) - { (= $R $A) }) True) -; - - - (= - (--> - (gen_put_float $X $R $Seen $A $GTI0 $GTI) - (, - { (var $Seen) } - (, ! - (, - { (, - (= $Seen yes) - (= $R $A)) } - { (add_instr - (put_float $X $R) $GTI0 $GTI) })))) True) -; - - (= - (--> - (gen_put_float $_ $R $_ $A $GTI $GTI) - { (= $R $A) }) True) -; - - - (= - (--> - (gen_put_con $X $R $Seen $A $GTI0 $GTI) - (, - { (var $Seen) } - (, ! - (, - { (, - (= $Seen yes) - (= $R $A)) } - { (add_instr - (put_con $X $R) $GTI0 $GTI) })))) True) -; - - (= - (--> - (gen_put_con $_ $R $_ $A $GTI $GTI) - { (= $R $A) }) True) -; - - - (= - (--> - (gen_put_list - ($R1 $R2) $R $Seen $A $GTI0 $GTI) - (, - { (var $Seen) } - (, ! - (, - { (, - (= $Seen yes) - (= $R $A)) } - { (add_instr - (put_list $R1 $R2 $R) $GTI0 $GTI) })))) True) -; - - (= - (--> - (gen_put_list $_ $R $_ $A $GTI $GTI) - { (= $R $A) }) True) -; - - - (= - (--> - (gen_put_str_args $Regs $R $Seen $A $GTI0 $GTI) - (, - { (var $Seen) } - (, ! - (, - { (, - (= $Seen yes) - (= $R $A)) } - { (add_instr - (put_str_args $Regs $R) $GTI0 $GTI) })))) True) -; - - (= - (--> - (gen_put_str_args $_ $R $_ $A $GTI $GTI) - { (= $R $A) }) True) -; - - - (= - (--> - (gen_put_str - ($R0 $R1) $R $Seen $A $GTI0 $GTI) - (, - { (var $Seen) } - (, ! - (, - { (, - (= $Seen yes) - (= $R $A)) } - { (add_instr - (put_str $R0 $R1 $R) $GTI0 $GTI) })))) True) -; - - (= - (--> - (gen_put_str $_ $R $_ $A $GTI $GTI) - { (= $R $A) }) True) -; - - - (= - (--> - (gen_put_args () () $LTI $LTI $GTI $GTI) !) True) -; - - (= - (--> - (gen_put_args - (Cons $X $Xs) - (Cons $R $Rs) $LTI0 $LTI $GTI0 $GTI) - (, - (gen_put $X $R $LTI0 $LTI1 $GTI0 $GTI1) - (gen_put_args $Xs $Rs $LTI1 $LTI $GTI1 $GTI))) True) -; - - - (= - (--> - (gen_put_clo - (: $P $X) $A $LTI0 $LTI $GTI0 $GTI) - (, - { (=.. $X - (Cons $F $Args)) } - (, ! - (, - (gen_put_args $Args $Regs $LTI0 $LTI1 $GTI0 $GTI) - (, - { (assign_reg $_ $R $Seen $LTI1 $LTI) } - (, - { (, - (= $Seen yes) - (= $R $A)) } - (, - { (=.. $X1 - (Cons $F $Regs)) } - (, - { (; - (-> - (clause - (package_name $P) $_) - (= $CLO $X1)) - (= $CLO - (: $P $X1))) } - ( (put_clo $CLO $R)))))))))) True) -; - - -; -; - - (= - (--> - (gen_get $X $A $LTI0 $LTI $GTI0 $GTI) - (gen_get - ( (= $A $X)) $LTI0 $LTI $GTI0 $GTI)) True) -; - - - (= - (--> - (gen_get () $LTI $LTI $GTI $GTI) !) True) -; - - (= - (--> - (gen_get - (Cons - (= $A $X) $_) $LTI $LTI $GTI $GTI) - (, - { (var $A) } - (, ! - (, - { (pl2am_error - ($A must not be a variable in - (get $X $A))) } - {fail })))) True) -; - - (= - (--> - (gen_get - (Cons - (= $A $X) $Instrs) $LTI0 $LTI $GTI0 $GTI) - (, - { (var $X) } - (, - { (assign_reg $X $R $Seen $LTI0 $LTI1) } - (, - { (nonvar $Seen) } - (, ! - (, - (gen_get_var $R $Seen $A) - (gen_get $Instrs $LTI1 $LTI $GTI0 $GTI))))))) True) -; - - (= - (--> - (gen_get - (Cons - (= $A $X) $Instrs) $LTI0 $LTI $GTI0 $GTI) - (, - { (var $X) } - (, ! - (, - { (add_alloc - ($X $A yes) $LTI0 $LTI1) } - (gen_get $Instrs $LTI1 $LTI $GTI0 $GTI))))) True) -; - - (= - (--> - (gen_get - (Cons - (= $A $X) $Instrs) $LTI0 $LTI $GTI0 $GTI) - (, - { (integer $X) } - (, ! - (, - (gen_put $X $R $LTI0 $LTI1 $GTI0 $GTI1) - (, - ( (get_int $X $R $A)) - (gen_get $Instrs $LTI1 $LTI $GTI1 $GTI)))))) True) -; - - (= - (--> - (gen_get - (Cons - (= $A $X) $Instrs) $LTI0 $LTI $GTI0 $GTI) - (, - { (float $X) } - (, ! - (, - (gen_put $X $R $LTI0 $LTI1 $GTI0 $GTI1) - (, - ( (get_float $X $R $A)) - (gen_get $Instrs $LTI1 $LTI $GTI1 $GTI)))))) True) -; - - (= - (--> - (gen_get - (Cons - (= $A $X) $Instrs) $LTI0 $LTI $GTI0 $GTI) - (, - { (is-symbol $X) } - (, ! - (, - (gen_put $X $R $LTI0 $LTI1 $GTI0 $GTI1) - (, - ( (get_con $X $R $A)) - (gen_get $Instrs $LTI1 $LTI $GTI1 $GTI)))))) True) -; - - (= - (--> - (gen_get - (Cons - (= $A $X) $Instrs) $LTI0 $LTI $GTI0 $GTI) - (, - { (ground $X) } - (, ! - (, - (gen_put $X $R $LTI0 $LTI1 $GTI0 $GTI1) - (, - ( (get_ground $X $R $A)) - (gen_get $Instrs $LTI1 $LTI $GTI1 $GTI)))))) True) -; - - (= - (--> - (gen_get - (Cons - (= $A $X) $Instrs) $LTI0 $LTI $GTI0 $GTI) - (, - { (= $X - (Cons $X1 $X2)) } - (, ! - (, - ( (get_list $A)) - (, - (gen_unify - ($X1 $X2) $Instrs1 $LTI0 $LTI1 $GTI0 $GTI1) - (, - (gen_get $Instrs1 $LTI1 $LTI2 $GTI1 $GTI2) - (gen_get $Instrs $LTI2 $LTI $GTI2 $GTI))))))) True) -; - - (= - (--> - (gen_get - (Cons - (= $A $X) $Instrs) $LTI0 $LTI $GTI0 $GTI) - (, - { (, - (=.. $X - (Cons $F $Args)) - (functor $X $F $N)) } - (, - { (assign_sreg - (: - (/ $F $N) con) $R $Seen $GTI0 $GTI1) } - (, - (gen_put_con - (/ $F $N) $R $Seen $_ $GTI1 $GTI2) - (, - ( (get_str - (/ $F $N) $R $A)) - (, - (gen_unify $Args $Instrs1 $LTI0 $LTI1 $GTI2 $GTI3) - (, - (gen_get $Instrs1 $LTI1 $LTI2 $GTI3 $GTI4) - (gen_get $Instrs $LTI2 $LTI $GTI4 $GTI)))))))) True) -; - - - (= - (--> - (gen_get_var void $_ $_) !) True) -; - - (= - (--> - (gen_get_var $R $_ $A) - ( (get_val $R $A))) True) -; - +; ;; transform + + (= (conj-to-list $X $_) + (var $X) + (set-det) + (pl2am-error (:: variable $X can not be converted to [A|B] expression)) + (fail)) + (= (conj-to-list (, $X1 $X2 $Xs) $Y) + (set-det) + (conj-to-list + (, $X1 $X2 $Xs) $Y)) + (= (conj-to-list (, $X $Xs) (Cons $X $Zs)) + (set-det) + (conj-to-list $Xs $Zs)) + (= (conj_to_list $X ($X)) True) + + + (= (list-to-string $List $String) + (list-to-chars $List $Chars0) + (flatten-list $Chars0 $Chars Nil) + (atom-codes $String $Chars)) + + + (= (list-to-chars Nil Nil) + (set-det)) + (= (list-to-chars (Cons $L $Ls) (Cons $C $Cs)) + (atom $L) + (set-det) + (atom-codes $L $C) + (list-to-chars $Ls $Cs)) + (= (list-to-chars (Cons $L $Ls) (Cons $C $Cs)) + (number $L) + (set-det) + (number-codes $L $C) + (list-to-chars $Ls $Cs)) + + + (= (list-to-conj $X $Y) + (flatten-list $X $L Nil) + (list-to-conj0 $L $Y)) + + + (= (list-to-conj0 $X $_) + (var $X) + (set-det) + (pl2am-error (:: variable $X can not be converted to '(A,B)' expression)) + (fail)) + (= (list_to_conj0 ($X) $X) True) + (= (list-to-conj0 (Cons $X $Xs) (, $X $Ys)) + (set-det) + (list-to-conj0 $Xs $Ys)) ; -; - - (= - (--> - (gen_unify () () $LTI $LTI $GTI $GTI) !) True) -; - - (= - (--> - (gen_unify - (Cons $X $Xs) $Instrs $LTI0 $LTI $GTI0 $GTI) - (, - { (var $X) } - (, ! - (, - { (assign_reg $X $R $Seen $LTI0 $LTI1) } - (, - (gen_unify_var $R $Seen) - (gen_unify $Xs $Instrs $LTI1 $LTI $GTI0 $GTI)))))) True) -; - - (= - (--> - (gen_unify - (Cons $X $Xs) $Instrs $LTI0 $LTI $GTI0 $GTI) - (, - { (integer $X) } - (, ! - (, - (gen_put $X $R $LTI0 $LTI1 $GTI0 $GTI1) - (, - ( (unify_int $X $R)) - (gen_unify $Xs $Instrs $LTI1 $LTI $GTI1 $GTI)))))) True) -; - - (= - (--> - (gen_unify - (Cons $X $Xs) $Instrs $LTI0 $LTI $GTI0 $GTI) - (, - { (float $X) } - (, ! - (, - (gen_put $X $R $LTI0 $LTI1 $GTI0 $GTI1) - (, - ( (unify_float $X $R)) - (gen_unify $Xs $Instrs $LTI1 $LTI $GTI1 $GTI)))))) True) -; - - (= - (--> - (gen_unify - (Cons $X $Xs) $Instrs $LTI0 $LTI $GTI0 $GTI) - (, - { (is-symbol $X) } - (, ! - (, - (gen_put $X $R $LTI0 $LTI1 $GTI0 $GTI1) - (, - ( (unify_con $X $R)) - (gen_unify $Xs $Instrs $LTI1 $LTI $GTI1 $GTI)))))) True) -; - - (= - (--> - (gen_unify - (Cons $X $Xs) $Instrs $LTI0 $LTI $GTI0 $GTI) - (, - { (ground $X) } - (, ! - (, - (gen_put $X $R $LTI0 $LTI1 $GTI0 $GTI1) - (, - ( (unify_ground $X $R)) - (gen_unify $Xs $Instrs $LTI1 $LTI $GTI1 $GTI)))))) True) -; - - (= - (--> - (gen_unify - (Cons $X $Xs) - (Cons - (= $R $X) $Instrs) $LTI0 $LTI $GTI0 $GTI) - (, - { (assign_reg $_ $R $Seen $LTI0 $LTI1) } - (, - (gen_unify_var $R $Seen) - (gen_unify $Xs $Instrs $LTI1 $LTI $GTI0 $GTI)))) True) -; - +; ;; misc + + (= (variables $X $Vs) + (variables $X Nil $Vs)) + + (= (variables $X $Vs $Vs) + (var $X) + (pl2am-memq $X $Vs) + (set-det)) + (= (variables $X $Vs (Cons $X $Vs)) + (var $X) + (set-det)) + (= (variables $X $Vs0 $Vs0) + (atomic $X) + (set-det)) + (= (variables (Cons $X $Xs) $Vs0 $Vs) + (set-det) + (variables $X $Vs0 $Vs1) + (variables $Xs $Vs1 $Vs)) + (= (variables $X $Vs0 $Vs) + (=.. $X $Xs) + (variables $Xs $Vs0 $Vs)) + + + (= (count-variable $V $X 1) + (== $V $X) + (set-det)) + (= (count-variable $_ $X 0) + (var $X) + (set-det)) + (= (count-variable $_ $X 0) + (atomic $X) + (set-det)) + (= (count-variable $V (Cons $X $Y) $N) + (set-det) + (count-variable $V $X $N1) + (count-variable $V $Y $N2) + (is $N + (+ $N1 $N2))) + (= (count-variable $V $X $N) + (=.. $X $Xs) + (count-variable $V $Xs $N)) ; -; - - (= - (--> - (gen_unify_var void $_) - (, ! - ( (unify_void 1)))) True) -; - - (= - (--> - (gen_unify_var $R $Seen) - (, - { (var $Seen) } - (, ! - (, - { (= $Seen yes) } - ( (unify_var $R)))))) True) -; - - (= - (--> - (gen_unify_var $R $_) - ( (unify_val $R))) True) -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - - (= - (--> - (gen_put_cont $X $R $LTI0 $LTI $GTI $GTI) - (, - { (inc_PN $R $LTI0 $LTI) } - ( (put_cont $X $R)))) True) -; - - +; END ; -; - - - (= - (assign-reg $X $Reg $Seen $LTI0 $LTI) - ( (nonvar $X) - (set-det) - (pl2am-error (:: $X must be unbound variable in (assign-reg $X $Reg $Seen $LTI0 $LTI))) - (fail))) -; - - (= - (assign-reg $X $Reg $Seen - (:: $XN $YN $PN $Alloc) - (:: $XN $YN $PN $Alloc)) - ( (allocated $Alloc $X - (:: $Reg $Seen)) (set-det))) -; - - (= - (assign-reg $X $Reg $Seen - (:: $XN $YN $PN $Alloc) - (:: $XN1 $YN $PN $Alloc1)) - ( (= $Reg - (a $XN)) - (is $XN1 - (+ $XN 1)) - (= $Alloc1 - (Cons - (:: $X $Reg $Seen) $Alloc)))) -; - - - - (= - (allocated - (Cons - (Cons $V $X) $_) $V0 $X) - ( (== $V $V0) (set-det))) -; - - (= - (allocated - (Cons $_ $Alloc) $V0 $X) - (allocated $Alloc $V0 $X)) -; +; written by SICStus MeTTa 3.12.8 - -; -; - - (= - (assign-sreg $X $Reg $Seen $GTI0 $GTI) - ( (not (ground $X)) - (set-det) - (pl2am-error (:: $X must be ground term in (assign-sreg $X $Reg $Seen $GTI0 $GTI))) - (fail))) -; - - (= - (assign-sreg $X $Reg $Seen - (:: $SN $SAlloc $SInstrs) - (:: $SN $SAlloc $SInstrs)) - ( (allocated $SAlloc $X - (:: $Reg $Seen)) (set-det))) -; - - (= - (assign-sreg - (with_self $X $T) $Reg $Seen - (:: $SN $SAlloc $SInstrs) - (:: $SN1 $SAlloc1 $SInstrs)) - ( (assign-sreg0 $T $SN $Reg) - (is $SN1 - (+ $SN 1)) - (= $SAlloc1 - (Cons - (:: - (with_self $X $T) $Reg $Seen) $SAlloc)))) -; - - - - (= - (assign-sreg0 int $SN - (si $SN)) - (set-det)) -; - - (= - (assign-sreg0 flo $SN - (sf $SN)) - (set-det)) -; - - (= - (assign-sreg0 $_ $SN - (s $SN)) - (set-det)) -; + !(op 1170 xfx :-) +; /***************************************************************** Time-stamp: <2008-10-29 10:42:42 banbara> NAME am2cpp: Translating WAM-based Intermediate Code into Java USAGE # sicstus ?- [am2cpp]. ?- am2cpp([File]). # sicstus ?- [am2cpp]. ?- am2cpp([File, Dir]). PARAMETERS File is an input WAM-based Intermediate file name. DESCRIPTION This program translates WAM-based intermediate codes into Java. For each predicate p/n, the file named "PRED_p_n.java" is generated. Generated files can be compiled and executed by usual java utilities (ex. javac) with the MeTTa Cafe runtime system. COPYRIGHT am2cpp (Translating WAM-based Intermediate Code into Java) Copyright (C) 1997-2008 by Mutsunori Banbara (banbara@kobe-u.ac.jp) and Naoyuki Tamura (tamura@kobe-u.ac.jp) SEE ALSO http://kaminari.istc.kobe-u.ac.jp/MeTTaCafe/ *****************************************************************/ +; /***************************************************************** Declarations *****************************************************************/ + !(op 1170 xfx -->) + !(op 1170 fx :-) + !(op 1170 fx ?-) + !(op 1150 fx public) + !(op 1150 fx package) ; +; MeTTa Cafe specific + + !(op 1170 xfx :-) + !(op 1170 xfx -->) + !(op 1170 fx :-) + !(op 1170 fx ?-) + !(op 500 yfx #) + !(op 1150 fx dynamic) + !(op 1150 fx meta-predicate) + !(op 1150 fx package) + !(op 1150 fx public) + !(op 1150 fx import) + !(op 1150 fx mode) + !(op 1150 fx multifile) + !(op 1150 fx block) + + !(dynamic (/ dest-dir 1)) + !(dynamic (/ current-arity 1)) + !(dynamic (/ current-functor 1)) + !(dynamic (/ current-package 1)) + !(dynamic (/ domain-definition 1)) + !(dynamic (/ inlined 2)) ; -; - -; -; +; :- module('TauMeTTaG.compiler.am2cpp', [main/0,am2cpp/1]). -; -; + (= (package $X) + (nb-setval package $X)) -; -; + !(package TauPrologG.compiler.am2cpp) + !(public (, (/ main 0) (/ am2cpp 1))) + (= (main-am2cpp) + (read $X) + (am2cpp $X)) +; /***************************************************************** Main *****************************************************************/ -; -; - - (= - (inc-YN - (y $YN) - (Cons $XN - (Cons $YN $Zs)) - (Cons $XN - (Cons $YN1 $Zs))) - (is $YN1 - (+ $YN 1))) -; - - -; -; - - - (= - (inc-PN - (p $PN) - (Cons $XN - (Cons $YN - (Cons $PN $Zs))) - (Cons $XN - (Cons $YN - (Cons $PN1 $Zs)))) - (is $PN1 - (+ $PN 1))) -; + (= (pl2cpp (:: $File)) + (set-det) + (pl2cpp (:: $File .))) + (= (pl2cpp (:: $File $Dir)) + (am2cpp (:: $File $Dir))) - -; -; - - (= - (add_instr $Instr - ($SN $SAlloc $SInstrs0) - ($SN $SAlloc - (Cons $Instr $SInstrs0))) True) -; - - -; -; - - - (= - (add_alloc $E - ($XN $YN $PN $Alloc0) - ($XN $YN $PN - (Cons $E $Alloc0))) True) -; - - - - (= - (builtin_meta_predicates ^ 2 - (? :)) True) -; - - (= - (builtin_meta_predicates call 1 - (:)) True) -; - - (= - (builtin_meta_predicates once 1 - (:)) True) -; - - (= - (builtin_meta_predicates \+ 1 - (:)) True) -; - - (= - (builtin_meta_predicates findall 3 - (? : ?)) True) -; - - (= - (builtin_meta_predicates bagof 3 - (? : ?)) True) -; - - (= - (builtin_meta_predicates setof 3 - (? : ?)) True) -; - - (= - (builtin_meta_predicates on_exception 3 - (? : :)) True) -; - - (= - (builtin_meta_predicates catch 3 - (: ? :)) True) -; - - (= - (builtin_meta_predicates synchronized 2 - (? :)) True) -; - - (= - (builtin_meta_predicates freeze 2 - (? :)) True) -; - - - - (= - (builtin_local_predicates assert 1 - (:)) True) -; - - (= - (builtin_local_predicates asserta 1 - (:)) True) -; - - (= - (builtin_local_predicates assertz 1 - (:)) True) -; - - (= - (builtin_local_predicates retract 1 - (:)) True) -; - - (= - (builtin_local_predicates retractall 1 - (:)) True) -; - - (= - (builtin_local_predicates assert 2 - (: ?)) True) -; - - (= - (builtin_local_predicates asserta 2 - (: ?)) True) -; - - (= - (builtin_local_predicates assertz 2 - (: ?)) True) -; - - (= - (builtin_local_predicates retract 2 - (: ?)) True) -; - - (= - (builtin_local_predicates retractall 2 - (: ?)) True) -; - - (= - (builtin_local_predicates save 2 - (? :)) True) -; - - (= - (builtin_local_predicates clause 2 - (: ?)) True) -; - - (= - (builtin_local_predicates abolish 1 - (:)) True) -; - - (= - (builtin_local_predicates log_level 1 - (:)) True) -; - - (= - (builtin_local_predicates loggable 1 - (:)) True) -; - - (= - (builtin_local_predicates log_error 2 - (: ?)) True) -; - - (= - (builtin_local_predicates log 2 - (: ?)) True) -; - - (= - (builtin_local_predicates log 3 - (: ? ?)) True) -; - - (= - (builtin_local_predicates log 4 - (: ? ? ?)) True) -; - - (= - (builtin_local_predicates log 5 - (: ? ? ? ?)) True) -; - - (= - (builtin_local_predicates log 6 - (: ? ? ? ? ?)) True) -; - - (= - (builtin_local_predicates log 7 - (: ? ? ? ? ? ?)) True) -; - - - (= - (builtin_meta_predicates with_mutex 2 - (? :)) True) -; - + (= (am2cpp (:: $File)) + (set-det) + (am2cpp (:: $File .))) + (= (am2cpp (:: $File $Dir)) + ( (remove-all-atoms &self + (dest_dir $_)) + (add-is-symbol &self + (dest_dir $Dir)) + (open $File read $In) + (repeat) + (read $In $X) + (write-java $X $In) + (== $X end-of-file) + (set-det) + (close $In) + (write-domains))) -; -; - - (= - (builtin_inline_predicates fail) True) -; - - (= - (builtin_inline_predicates - (%get_level $_)) True) -; - - (= - (builtin_inline_predicates $neck_cut) True) -; - - (= - (builtin_inline_predicates - ($cut $_)) True) -; - + (= (write-domains) + ( (== + (= + (dest_dir $Dir) $_) + (get-atoms &self)) + (findall $D + (domain-definition $D) $LD) + (catch + (with_self + (TauPrologG.builtin *) + (call (with_self (TauPrologG.builtin *) (write-domain-definitions $Dir $LD)))) $_ + (am2cpp-message (:: domain definitions are not supported and skipped))))) +; ; on some platforms (like SWI MeTTa) predicate write_domain_definitions might be not available +; ; so wrap it with catch and produce warning message + + + (= (write-java $X $_) + (var $X) + (set-det) + (am2cpp-error (:: unbound variable is found)) + (fail)) + (= (write-java end-of-file $_) + (set-det)) + (= (write-java !$G $_) + (set-det) + (call $G)) + (= (write-java (begin-predicate $P (/ $F $A)) $In) + ( (== + (= + (dest_dir $Dir) $_) + (get-atoms &self)) + (remove-all-atoms &self + (current_package $_)) + (remove-all-atoms &self + (current_arity $_)) + (remove-all-atoms &self + (current_functor $_)) + (remove-all-atoms &self + (inlined $_ $_)) + (add-is-symbol &self + (current_package $P)) + (add-is-symbol &self + (current_arity $A)) + (add-is-symbol &self + (current_functor $F)) + (predicate-encoding $F $F1) + (package-encoding $P $PDir) + (list-to-string + (:: $Dir / $PDir) $SrcDir) + (list-to-string + (:: $SrcDir / PRED- $F1 - $A .java) $SrcFile) + (mkdirs $SrcDir) + (open $SrcFile write $Out) + (write $Out 'package ') + (write-package $P $Out) + (write $Out or) + (nl $Out) + (repeat) + (read $In $X) + (write-java0 $X $In $Out) + (== $X + (end-predicate $P + (/ $F $A))) + (close $Out) + (set-det))) + (= (write-java $X $_) + (am2cpp-error (:: $X is an invalid argument in (/ write-java 2))) + (fail)) + + + (= (write-java0 $X $_ $_) + (var $X) + (set-det) + (am2cpp-error (:: unbound variable is found)) + (fail)) +; /***************************************************************** Write Java *****************************************************************/ + (= (write-java0 Nil $_ $_) + (set-det)) + (= (write-java0 (Cons $X $Xs) $In $Out) + (set-det) + (write-java0 $X $In $Out) + (write-java0 $Xs $In $Out)) + (= (write-java0 (end-predicate $_ $_) $_ $Out) + (set-det) + (tab $Out 4) + (write $Out }) + (nl $Out) + (write $Out }) + (nl $Out)) + (= (write-java0 (comment $Comment) $_ $Out) + (set-det) + (numbervars $Comment 0 $_) + (tab $Out 4) + (write $Out // ) + (writeq $Out $Comment) + (nl $Out)) + (= (write-java0 (debug $Comment) $_ $Out) + (set-det) + (numbervars $Comment 0 $_) + (write $Out // ) + (writeq $Out $Comment) + (nl $Out)) + (= (write-java0 (info (Cons $FA (Cons $File $_))) $_ $Out) + (set-det) + (write $Out /*) + (nl $Out) + (write $Out ' ') + (writeq $Out $FA) + (write $Out ' defined in ') + (writeq $Out $File) + (nl $Out) + (write $Out ' This file is generated by Prolog Cafe.') + (nl $Out) + (write $Out ' PLEASE DO NOT EDIT!') + (nl $Out) + (write $Out */) + (nl $Out)) + (= (write-java0 (import-package $P) $_ $Out) + (set-det) + (write $Out 'import ') + (write-package $P $Out) + (write $Out .*;) + (nl $Out)) + (= (write-java0 (import-package $P $FA) $_ $Out) + (set-det) + (write $Out 'import ') + (write-package $P $Out) + (write $Out .) + (det-if-then-else + (= $FA + (/ $_ $_)) + (write-class-name $FA $Out) + (write-package $FA $Out)) + (write $Out or) + (nl $Out)) + (= (write-java0 (with_self $Label $Instruction) $In $Out) + (set-det) + (write-label $Label $Out) + (write-java0 $Instruction $In $Out)) + (= (write-java0 (label (/ fail 0)) $_ $Out) + (set-det) + (tab $Out 4) + (write $Out 'private static final Operation ') + (write-index + (/ fail 0) $Out) + (write $Out ' = TauPrologG.Failure.FAIL-0') + (write $Out or) + (nl $Out)) + (= (write-java0 (label $L) $_ $Out) + (set-det)) ; -; - - (= - (builtin_inline_predicates - ($unify $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%not_unifiable $_ $_)) True) -; - +; tab(Out, 4), ; -; - - (= - (builtin_inline_predicates - (var $_)) True) -; - - (= - (builtin_inline_predicates - (is-symbol $_)) True) -; - - (= - (builtin_inline_predicates - (integer $_)) True) -; - - (= - (builtin_inline_predicates - (long $_)) True) -; - - (= - (builtin_inline_predicates - (float $_)) True) -; - - (= - (builtin_inline_predicates - (atomic $_)) True) -; - - (= - (builtin_inline_predicates - (nonvar $_)) True) -; - - (= - (builtin_inline_predicates - (number $_)) True) -; - - (= - (builtin_inline_predicates - (java $_)) True) -; - - (= - (builtin_inline_predicates - (java $_ $_)) True) -; - - (= - (builtin_inline_predicates - (closure $_)) True) -; - - (= - (builtin_inline_predicates - (ground $_)) True) -; - +; write(Out, 'static final Operation '), ; -; - - (= - (builtin_inline_predicates - (%equality_of_term $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%inequality_of_term $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($after $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($before $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%not_after $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%not_before $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%identical_or_cannot_unify $_ $_)) True) -; - +; write_index(L, Out), ; -; - - (= - (builtin_inline_predicates - (copy_term $_ $_)) True) -; - +; write(Out, ' = new '), ; -; - - (= - (builtin_inline_predicates - (is $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($abs $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($asin $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($acos $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($atan $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%bitwise_conj $_ $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%bitwise_disj $_ $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%bitwise_exclusive_or $_ $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%bitwise_neg $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($ceil $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($cos $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($degrees $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($exp $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%float_quotient $_ $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($floor $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%int_quotient $_ $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($log $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($max $_ $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($min $_ $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($minus $_ $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($mod $_ $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($multi $_ $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($plus $_ $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($pow $_ $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($radians $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($rint $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($round $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%shift_left $_ $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%shift_right $_ $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($sin $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($sqrt $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($tan $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($float $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%float_integer_part $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%float_fractional_part $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($truncate $_ $_)) True) -; - - (= - (builtin_inline_predicates - ($sign $_ $_)) True) -; - +; write_class_name(L, Out), ; -; - - (= - (builtin_inline_predicates - (%arith_equal $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%arith_not_equal $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%greater_or_equal $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%greater_than $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%less_or_equal $_ $_)) True) -; - - (= - (builtin_inline_predicates - (%less_than $_ $_)) True) -; - - - - (= - (builtin_arith_constant random) True) -; - - (= - (builtin_arith_constant pi) True) -; - - (= - (builtin_arith_constant e) True) -; - - - - (= - (eliminate-disj $Cl $NewCl $DummyCls) - ( (extract-disj $Cl $NewCl $Disjs Nil) (treat-disj $Disjs $DummyCls Nil))) -; - - - - (= - (--> - (extract_disj $Cl $Cl) - (, - { (var $Cl) } !)) True) -; - - (= - (--> - (extract_disj $Cl - (:- $H $NewB)) - (, - { (= $Cl - (:- $H $B)) } - (, ! - (extract_disj $B $NewB $Cl)))) True) -; - - (= - (--> - (extract_disj $Cl $Cl) !) True) -; - - - (= - (--> - (extract_disj $G $G $_) - (, - { (var $G) } !)) True) -; - - (= - (--> - (extract_disj - (, $G1 $G2) - (, $NewG1 $NewG2) $Cl) - (, ! - (, - (extract_disj $G1 $NewG1 $Cl) - (extract_disj $G2 $NewG2 $Cl)))) True) -; - - (= - (--> - (extract_disj $G $NewG $Cl) - (, - { (is_disj $G $DisjG) } - (, ! - (, - { (retract - (dummy_clause_counter $N)) } - (, - ( (disj $DisjG $N $NewG $Cl)) - (, - { (is $N1 - (+ $N 1)) } - { (assert - (dummy_clause_counter $N1)) })))))) True) -; - - (= - (--> - (extract_disj $G $G $_) !) True) -; - - - - (= - (is-disj - (det-if-then $C1 $C2) - (or - (, $C1 - (set-det) $C2) fail)) - (set-det)) -; - - (= - (is-disj - (det-if-then-else $C1 $C2 $C3) - (or - (, $C1 - (set-det) $C2) $C3)) - (set-det)) -; - - (= - (is-disj - (or $C1 $C2) - (or $C1 $C2)) - (set-det)) -; - - (= - (is-disj - (not $C) - (or - (, $C - (set-det) - (fail)) True)) - (set-det)) -; - - (= - (is_disj - (\+ $C) - (; - (, $C - (, ! fail)) true)) True) -; - - - - (= - (--> - (treat_disj ()) !) True) -; - - (= - (--> - (treat_disj - (Cons - (disj - (; $A $B) $N $X $C) $Disjs)) - (, - { (variables - (; $A $B) $Vars) } - (, - { (variables $C $CVars) } - (, - { (intersect_vars $Vars $CVars $Args) } - (, - { (clause - (file_name $File) $_) } - (, - { (list_to_string - ($dummy_ $N _ $File) $Name) } - (, - { (=.. $X - (Cons $Name $Args)) } - (, - { (copy_term - (:- $X $A) $DummyCla) } - (, - { (copy_term - (:- $X $B) $DummyClb) } - (, - ($DummyCla) - (, - ($DummyClb) - (treat_disj $Disjs)))))))))))) True) -; - - - - (= - (intersect-vars $V1 $V2 $Out) - ( (sort $V1 $Sorted1) - (sort $V2 $Sorted2) - (intersect-sorted-vars $Sorted1 $Sorted2 $Out))) -; - - - - (= - (intersect-sorted-vars Nil $_ Nil) - (set-det)) -; - - (= - (intersect_sorted_vars $_ () ()) True) -; - - (= - (intersect-sorted-vars - (Cons $X $Xs) - (Cons $Y $Ys) - (Cons $X $Rs)) - ( (== $X $Y) - (set-det) - (intersect-sorted-vars $Xs $Ys $Rs))) -; - - (= - (intersect-sorted-vars - (Cons $X $Xs) - (Cons $Y $Ys) $Rs) - ( (@< $X $Y) - (set-det) - (intersect-sorted-vars $Xs - (Cons $Y $Ys) $Rs))) -; - - (= - (intersect-sorted-vars - (Cons $X $Xs) - (Cons $Y $Ys) $Rs) - ( (@> $X $Y) - (set-det) - (intersect-sorted-vars - (Cons $X $Xs) $Ys $Rs))) -; - - - - (= - (pl2am-error $M) - ( (get-symbols &self +; write(Out, '();'), nl(Out). + (= (write-java0 (goto $L) $_ $Out) + (set-det) + (tab $Out 8) + (write $Out 'return ') + (write-index $L $Out) + (write $Out (engine);) + (nl $Out)) + (= (write-java0 setB0 $_ $Out) + (set-det) + (tab $Out 8) + (write $Out engine.setB0();) + (nl $Out)) + (= (write-java0 (deref $_ void) $_ $_) + (set-det)) + (= (write-java0 (deref $Ri $Rj) $_ $Out) + (set-det) + (tab $Out 8) + (write-reg $Rj $Out) + (write $Out = ) + (write-reg $Ri $Out) + (write $Out .DeRef();) + (nl $Out)) + (= (write-java0 (set $_ void) $_ $_) + (set-det)) + (= (write-java0 (set $Ri $Rj) $_ $Out) + (set-det) + (tab $Out 8) + (write-reg $Rj $Out) + (write $Out = ) + (write-reg $Ri $Out) + (write $Out or) + (nl $Out)) + (= (write-java0 (decl-term-vars Nil) $_ $_) + (set-det)) + (= (write-java0 (decl-term-vars $L) $_ $Out) + (set-det) + (tab $Out 8) + (write $Out 'Term ') + (write-reg-args $L $Out) + (write $Out or) + (nl $Out)) + (= (write-java0 (decl-pred-vars Nil) $_ $_) + (set-det)) + (= (write-java0 (decl-pred-vars $L) $_ $Out) + (set-det) + (tab $Out 8) + (write $Out 'Operation ') + (write-reg-args $L $Out) + (write $Out or) + (nl $Out)) + (= (write-java0 (put-cont $BinG $C) $_ $Out) + (set-det) + (det-if-then-else + (= $BinG + (with_self $P $G)) True + (= $BinG $G)) + (functor $G $F $A0) + (is $A + (- $A0 1)) + (=.. $G + (Cons $F $Args)) + (tab $Out 8) + (write-reg $C $Out) + (write $Out ' = new ') + (det-if-then-else + (nonvar $P) + (, + (write-package $P $Out) + (write $Out .)) True) + (write-class-name + (/ $F $A) $Out) + (write $Out () + (write-reg-args $Args $Out) + (write $Out );) + (nl $Out)) + (= (write-java0 (execute cont) $_ $Out) + (set-det) + (tab $Out 8) + (write $Out 'return cont;') + (nl $Out)) + (= (write-java0 (execute $BinG) $_ $Out) + (set-det) + (det-if-then-else + (= $BinG + (with_self $P $G)) True + (= $BinG $G)) + (functor $G $F $A0) + (is $A + (- $A0 1)) + (=.. $G + (Cons $F $Args)) + (tab $Out 8) + (write $Out 'return new ') + (det-if-then-else + (nonvar $P) + (, + (write-package $P $Out) + (write $Out .)) True) + (write-class-name + (/ $F $A) $Out) + (write $Out () + (write-reg-args $Args $Out) + (write $Out );) + (nl $Out)) + (= (write-java0 (inline $G) $In $Out) + (write-inline $G $In $Out) + (set-det)) + (= (write-java0 (new-hash $Tag $I) $_ $Out) + (set-det) + (tab $Out 4) + (write $Out 'private static final java.util.HashMap ') + (det-if-then-else + (== $Tag int) + (write $Out Int) + (write $Out $Tag)) + (write $Out ' = new java.util.HashMap(') + (write $Out $I) + (write $Out );) + (nl $Out)) + (= (write-java0 (put-hash $X $L $Tag) $_ $Out) + (set-det) + (tab $Out 8) + (det-if-then-else + (== $Tag int) + (write $Out Int) + (write $Out $Tag)) + (write $Out .put() + (det-if-then-else + (== (= - (file_line $File $Line) $_)) - (set-det) - (pl2am-message user-error - (Cons *** - (Cons PL2ASM - (Cons ERROR - (Cons in - (Cons $File - (Cons at - (Cons $Line - (Cons : $M))))))))))) -; - - - (= - (pl2am-error $M) - (pl2am-message user-error - (Cons *** - (Cons PL2ASM - (Cons ERROR $M))))) -; - - - - (= - (pl2am-message $M) - (pl2am-message user-output $M)) -; - - - (= - (pl2am-message $Stream Nil) - ( (nl $Stream) (flush-output $Stream))) -; - - (= - (pl2am-message $Stream - (Cons $M $Ms)) - ( (write $Stream $M) - (write $Stream ' ') - (pl2am-message $Stream $Ms))) -; - - -; -; - - - (= - (mode_expr ()) True) -; - - (= - (mode-expr (Cons $M $Ms)) - ( (nonvar $M) - (pl2am-member $M - (:: : or + - ?)) - (set-det) - (mode-expr $Ms))) -; - - - - (= - (predspec-expr (/ $F $A)) - ( (atom $F) (integer $A))) -; - - -; -; - - - (= - (pl2am_append () $Zs $Zs) True) -; - - (= - (pl2am-append - (Cons $X $Xs) $Ys - (Cons $X $Zs)) - (pl2am-append $Xs $Ys $Zs)) -; - - - - (= - (pl2am-rev $L $R) - (pl2am-rev $L Nil $R)) -; - - (= - (pl2am_rev () $R $R) True) -; - - (= - (pl2am-rev - (Cons $X $L) $Y $R) - (pl2am-rev $L - (Cons $X $Y) $R)) -; - - - - (= - (pl2am_member $X - (Cons $X $_)) True) -; - - (= - (pl2am-member $X - (Cons $_ $Ys)) - (pl2am-member $X $Ys)) -; - - - - (= - (pl2am-memq $X - (Cons $Y $_)) - ( (== $X $Y) (set-det))) -; - - (= - (pl2am-memq $X - (Cons $_ $Ys)) - (pl2am-memq $X $Ys)) -; - - - - (= - (--> - (flatten_list ()) !) True) -; - - (= - (--> - (flatten_list - (Cons $L1 $L2)) - (, ! - (, - (flatten_list $L1) - (flatten_list $L2)))) True) -; - - (= - (--> - (flatten_list $L) - ($L)) True) -; - - - (= - (--> - (flatten_code ()) !) True) -; - - (= - (--> - (flatten_code - (Cons - (: $L $C) $Code)) - (, ! - (, - ( (: $L ())) - (flatten_code - (Cons $C $Code))))) True) -; - - (= - (--> - (flatten_code - (Cons $Code1 $Code2)) - (, ! - (, - (flatten_code $Code1) - (flatten_code $Code2)))) True) -; - - (= - (--> - (flatten_code $Code) - ($Code)) True) -; - - - - (= - (pl2am_maplist $_ () ()) True) -; - - (= - (pl2am-maplist $Goal - (Cons $Elem1 $Tail1) - (Cons $Elem2 $Tail2)) - ( (=.. $Term - (:: $Goal $Elem1 $Elem2)) - (call $Term) - (pl2am-maplist $Goal $Tail1 $Tail2))) -; - - - - (= - (pl2am-resolve-file $BaseFile $File $File) - ( (= $File - (with_self $Package $ResourceName)) (set-det))) -; - - - (= - (pl2am-resolve-file $BaseFile $File $IncludeFile) - ( (pl2am-file-directory $BaseFile $Directory) (atom-concat $Directory $File $IncludeFile))) -; - - - - (= - (pl2am-file-directory $BaseFile $Directory) - ( (atom-chars $BaseFile $BaseFileChars) - (pl2am-rev $BaseFileChars $BaseFileCharsRev) - (pl2am-file-directory- $BaseFileCharsRev $DirectoryCharsRev) - (pl2am-add-directory-separator $DirectoryCharsRev $DirectoryCharsRev1) - (pl2am-rev $DirectoryCharsRev1 $DirectoryChars) - (atom-chars $Directory $DirectoryChars))) -; - - - - (= - (pl2am-file-directory- Nil Nil) - (set-det)) -; - - (= - (pl2am-file-directory- - (:: \) - (:: \)) - (set-det)) -; - - (= - (pl2am-file-directory- - (:: /) - (:: /)) - (set-det)) -; - - (= - (pl2am-file-directory- - (Cons \ $BaseFileCharsRev) $BaseFileCharsRev) - (set-det)) -; - - (= - (pl2am-file-directory- - (Cons / $BaseFileCharsRev) $BaseFileCharsRev) - (set-det)) -; - - (= - (pl2am-file-directory- - (Cons $_ $BaseFileCharsRev) $DirectoryCharsRev) - (pl2am-file-directory- $BaseFileCharsRev $DirectoryCharsRev)) -; - - - - (= - (pl2am-add-directory-separator $D $D) - ( (= $D - (Cons / $_)) (set-det))) -; - - (= - (pl2am-add-directory-separator $D $D) - ( (= $D - (Cons \ $_)) (set-det))) -; - - (= - (pl2am_add_directory_separator $D - (Cons / $D)) True) -; - - -; -; - - - (= - (conj-to-list $X $_) - ( (var $X) - (set-det) - (pl2am-error (:: variable $X can not be converted to [A|B] expression)) - (fail))) -; - - (= - (conj-to-list - (, $X1 $X2 $Xs) $Y) - ( (set-det) (conj-to-list (, $X1 $X2 $Xs) $Y))) -; - - (= - (conj-to-list - (, $X $Xs) - (Cons $X $Zs)) - ( (set-det) (conj-to-list $Xs $Zs))) -; - - (= - (conj_to_list $X - ($X)) True) -; - - - - (= - (list-to-string $List $String) - ( (list-to-chars $List $Chars0) - (flatten-list $Chars0 $Chars Nil) - (atom-codes $String $Chars))) -; - - - - (= - (list-to-chars Nil Nil) - (set-det)) -; - - (= - (list-to-chars - (Cons $L $Ls) - (Cons $C $Cs)) - ( (atom $L) - (set-det) - (atom-codes $L $C) - (list-to-chars $Ls $Cs))) -; - - (= - (list-to-chars - (Cons $L $Ls) - (Cons $C $Cs)) - ( (number $L) - (set-det) - (number-codes $L $C) - (list-to-chars $Ls $Cs))) -; - - - - (= - (list-to-conj $X $Y) - ( (flatten-list $X $L Nil) (list-to-conj0 $L $Y))) -; - - - - (= - (list-to-conj0 $X $_) - ( (var $X) - (set-det) - (pl2am-error (:: variable $X can not be converted to '(A,B)' expression)) - (fail))) -; - - (= - (list_to_conj0 - ($X) $X) True) -; - - (= - (list-to-conj0 - (Cons $X $Xs) - (, $X $Ys)) - ( (set-det) (list-to-conj0 $Xs $Ys))) -; - - + (inlined $X + (/ $F $A)) $_) + (get-atoms &self)) + (, + (write $Out 'Const.intern("') + (write-constant $F $Out) + (write $Out ",) + (write $Out $A) + (write $Out ))) + (write-reg $X $Out)) + (write $Out , ) + (write-method-ref $L $Out) + (write $Out );) + (nl $Out)) + (= (write-java0 (static $Instrs) $In $Out) + (set-det) + (tab $Out 4) + (write $Out 'static {') + (nl $Out) + (write-java0 $Instrs $In $Out) + (tab $Out 4) + (write $Out }) + (nl $Out)) ; -; - - - (= - (variables $X $Vs) - (variables $X Nil $Vs)) -; - - - (= - (variables $X $Vs $Vs) - ( (var $X) - (pl2am-memq $X $Vs) - (set-det))) -; - - (= - (variables $X $Vs - (Cons $X $Vs)) - ( (var $X) (set-det))) -; - - (= - (variables $X $Vs0 $Vs0) - ( (atomic $X) (set-det))) -; - - (= - (variables - (Cons $X $Xs) $Vs0 $Vs) - ( (set-det) - (variables $X $Vs0 $Vs1) - (variables $Xs $Vs1 $Vs))) -; - - (= - (variables $X $Vs0 $Vs) - ( (=.. $X $Xs) (variables $Xs $Vs0 $Vs))) -; - - - - (= - (count-variable $V $X 1) - ( (== $V $X) (set-det))) -; - - (= - (count-variable $_ $X 0) - ( (var $X) (set-det))) -; - - (= - (count-variable $_ $X 0) - ( (atomic $X) (set-det))) -; - - (= - (count-variable $V - (Cons $X $Y) $N) - ( (set-det) - (count-variable $V $X $N1) - (count-variable $V $Y $N2) - (is $N - (+ $N1 $N2)))) -; - - (= - (count-variable $V $X $N) - ( (=.. $X $Xs) (count-variable $V $Xs $N))) -; - - -; -; - - -; -; - -; -; - - - - !(op 1170 xfx :-) -; - - !(op 1170 xfx -->) -; - - !(op 1170 fx :-) -; - - !(op 1170 fx ?-) -; - - !(op 1150 fx public) -; - - !(op 1150 fx package) -; - ; -; - - - !(op 1170 xfx :-) -; - - !(op 1170 xfx -->) -; - - !(op 1170 fx :-) -; - - !(op 1170 fx ?-) -; - - !(op 500 yfx #) -; - - !(op 1150 fx dynamic) -; - - !(op 1150 fx meta-predicate) -; - - !(op 1150 fx package) -; - - !(op 1150 fx public) -; - - !(op 1150 fx import) -; - - !(op 1150 fx mode) -; - - !(op 1150 fx multifile) -; - - !(op 1150 fx block) -; - - - !(dynamic (/ dest-dir 1)) -; - - !(dynamic (/ current-arity 1)) -; - - !(dynamic (/ current-functor 1)) -; - - !(dynamic (/ current-package 1)) -; - - !(dynamic (/ domain-definition 1)) -; - - !(dynamic (/ inlined 2)) -; - - -; -; - - - (= - (package $X) - (nb-setval package $X)) -; - - - !(package TauPrologG.compiler.am2cpp) -; - - !(public (, (/ main 0) (/ am2cpp 1))) -; - - - (= - (main-am2cpp) - ( (read $X) (am2cpp $X))) -; - - - - (= - (pl2cpp (:: $File)) - ( (set-det) (pl2cpp (:: $File .)))) -; - - (= - (pl2cpp (:: $File $Dir)) - (am2cpp (:: $File $Dir))) -; - - - - (= - (am2cpp (:: $File)) - ( (set-det) (am2cpp (:: $File .)))) -; - - (= - (am2cpp (:: $File $Dir)) - ( (remove-all-symbols &self - (dest_dir $_)) - (add-symbol &self - (dest_dir $Dir)) - (open $File read $In) - (repeat) - (read $In $X) - (write-java $X $In) - (== $X end-of-file) - (set-det) - (close $In) - (write-domains))) -; - - - - (= - (write-domains) - ( (get-symbols &self - (= - (dest_dir $Dir) $_)) - (findall $D - (domain-definition $D) $LD) - (catch - (with_self - (TauPrologG.builtin *) - (call (with_self (TauPrologG.builtin *) (write-domain-definitions $Dir $LD)))) $_ - (am2cpp-message (:: domain definitions are not supported and skipped))))) -; - - - - (= - (write-java $X $_) - ( (var $X) - (set-det) - (am2cpp-error (:: unbound variable is found)) - (fail))) -; - - (= - (write-java end-of-file $_) - (set-det)) -; - - (= - (write-java - !$G $_) - ( (set-det) (call $G))) -; - - (= - (write-java - (begin-predicate $P - (/ $F $A)) $In) - ( (get-symbols &self +; ;; Put Instructions + (= (write-java0 (put-var $X) $_ $Out) + (set-det) + (tab $Out 8) + (write-reg $X $Out) + (write $Out ' = new Var(engine);') + (nl $Out)) + (= (write-java0 (put-int $I $X) $_ $Out) + (long $I) + (set-det) + (tab $Out 4) + (write $Out 'private static final LongTerm ') + (write-reg $X $Out) + (write $Out ' = new LongTerm(') + (write $Out $I) + (write $Out L);) + (nl $Out)) + (= (write-java0 (put-int $I $X) $_ $Out) + (set-det) + (tab $Out 4) + (write $Out 'private static final IntegerTerm ') + (write-reg $X $Out) + (write $Out ' = new IntegerTerm(') + (det-if-then-else + (java-integer $I) True + (write $Out 'new java.math.BigInteger("')) + (write $Out $I) + (det-if-then-else + (java-integer $I) True + (write $Out "))) + (write $Out );) + (nl $Out)) + (= (write-java0 (put-float $F $X) $_ $Out) + (set-det) + (tab $Out 4) + (write $Out 'private static final Float ') + (write-reg $X $Out) + (write $Out ' = new Float(') + (write $Out $F) + (write $Out );) + (nl $Out)) + (= (write-java0 (put-con (/ $F $A) $X) $_ $Out) + ( (set-det) (add-is-symbol &self (inlined $X (/ $F $A))))) + (= (write-java0 (put-con $C $X) $_ $Out) + (set-det) + (tab $Out 4) + (write $Out 'private static final Const ') + (write-reg $X $Out) + (write $Out ' = Const.intern("') + (det-if-then-else + (= $C + (/ $F $A)) + (, + (write-constant $F $Out) + (write $Out ", ) + (write $Out $A) + (write $Out );)) + (, + (write-constant $C $Out) + (write $Out ");))) + (nl $Out)) + (= (write-java0 (put-list $Xi $Xj $Xk) $_ $Out) + (set-det) + (det-if-then-else + (= $Xk + (s $_)) + (, + (tab $Out 4) + (write $Out 'private static final ListTerm ')) + (tab $Out 8)) + (write-reg $Xk $Out) + (write $Out ' = LIST(') + (write-reg $Xi $Out) + (write $Out , ) + (write-reg $Xj $Out) + (write $Out );) + (nl $Out)) + (= (write-java0 (put-str $Xi $Y $Xj) $_ $Out) + (set-det) + (det-if-then-else + (= $Xj + (s $_)) + (, + (tab $Out 4) + (write $Out 'private static final .Fun ')) + (tab $Out 8)) + (write-reg $Xj $Out) + (write $Out ' = F(') + (det-if-then-else + (== (= - (dest_dir $Dir) $_)) - (remove-all-symbols &self - (current_package $_)) - (remove-all-symbols &self - (current_arity $_)) - (remove-all-symbols &self - (current_functor $_)) - (remove-all-symbols &self - (inlined $_ $_)) - (add-symbol &self - (current_package $P)) - (add-symbol &self - (current_arity $A)) - (add-symbol &self - (current_functor $F)) - (predicate-encoding $F $F1) - (package-encoding $P $PDir) - (list-to-string - (:: $Dir / $PDir) $SrcDir) - (list-to-string - (:: $SrcDir / PRED- $F1 - $A .java) $SrcFile) - (mkdirs $SrcDir) - (open $SrcFile write $Out) - (write $Out 'package ') - (write-package $P $Out) - (write $Out or) - (nl $Out) - (repeat) - (read $In $X) - (write-java0 $X $In $Out) - (== $X - (end-predicate $P - (/ $F $A))) - (close $Out) - (set-det))) -; - - (= - (write-java $X $_) - ( (am2cpp-error (:: $X is an invalid argument in (/ write-java 2))) (fail))) -; - - - - (= - (write-java0 $X $_ $_) - ( (var $X) - (set-det) - (am2cpp-error (:: unbound variable is found)) - (fail))) -; - - (= - (write-java0 Nil $_ $_) - (set-det)) -; - - (= - (write-java0 - (Cons $X $Xs) $In $Out) - ( (set-det) - (write-java0 $X $In $Out) - (write-java0 $Xs $In $Out))) -; - - (= - (write-java0 - (end-predicate $_ $_) $_ $Out) - ( (set-det) - (tab $Out 4) - (write $Out }) - (nl $Out) - (write $Out }) - (nl $Out))) -; - - (= - (write-java0 - (comment $Comment) $_ $Out) - ( (set-det) - (numbervars $Comment 0 $_) - (tab $Out 4) - (write $Out // ) - (writeq $Out $Comment) - (nl $Out))) -; - - (= - (write-java0 - (debug $Comment) $_ $Out) - ( (set-det) - (numbervars $Comment 0 $_) - (write $Out // ) - (writeq $Out $Comment) - (nl $Out))) -; - - (= - (write-java0 - (info (Cons $FA (Cons $File $_))) $_ $Out) - ( (set-det) - (write $Out /*) - (nl $Out) - (write $Out ' ') - (writeq $Out $FA) - (write $Out ' defined in ') - (writeq $Out $File) - (nl $Out) - (write $Out ' This file is generated by Prolog Cafe.') - (nl $Out) - (write $Out ' PLEASE DO NOT EDIT!') - (nl $Out) - (write $Out */) - (nl $Out))) -; - - (= - (write-java0 - (import-package $P) $_ $Out) - ( (set-det) - (write $Out 'import ') - (write-package $P $Out) - (write $Out .*;) - (nl $Out))) -; - - (= - (write-java0 - (import-package $P $FA) $_ $Out) - ( (set-det) - (write $Out 'import ') - (write-package $P $Out) - (write $Out .) - (det-if-then-else - (= $FA - (/ $_ $_)) - (write-class-name $FA $Out) - (write-package $FA $Out)) - (write $Out or) - (nl $Out))) -; - - (= - (write-java0 - (with_self $Label $Instruction) $In $Out) - ( (set-det) - (write-label $Label $Out) - (write-java0 $Instruction $In $Out))) -; - - (= - (write-java0 - (label (/ fail 0)) $_ $Out) - ( (set-det) - (tab $Out 4) - (write $Out 'private static final Operation ') - (write-index - (/ fail 0) $Out) - (write $Out ' = TauPrologG.Failure.FAIL-0') - (write $Out or) - (nl $Out))) -; - - (= - (write-java0 - (label $L) $_ $Out) - (set-det)) -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - (= - (write-java0 - (goto $L) $_ $Out) - ( (set-det) - (tab $Out 8) - (write $Out 'return ') - (write-index $L $Out) - (write $Out (engine);) - (nl $Out))) -; - - (= - (write-java0 setB0 $_ $Out) - ( (set-det) - (tab $Out 8) - (write $Out engine.setB0();) - (nl $Out))) -; - - (= - (write-java0 - (deref $_ void) $_ $_) - (set-det)) -; - - (= - (write-java0 - (deref $Ri $Rj) $_ $Out) - ( (set-det) - (tab $Out 8) - (write-reg $Rj $Out) - (write $Out = ) - (write-reg $Ri $Out) - (write $Out .DeRef();) - (nl $Out))) -; - - (= - (write-java0 - (set $_ void) $_ $_) - (set-det)) -; - - (= - (write-java0 - (set $Ri $Rj) $_ $Out) - ( (set-det) - (tab $Out 8) - (write-reg $Rj $Out) - (write $Out = ) - (write-reg $Ri $Out) - (write $Out or) - (nl $Out))) -; - - (= - (write-java0 - (decl-term-vars Nil) $_ $_) - (set-det)) -; - - (= - (write-java0 - (decl-term-vars $L) $_ $Out) - ( (set-det) - (tab $Out 8) - (write $Out 'Term ') - (write-reg-args $L $Out) - (write $Out or) - (nl $Out))) -; - - (= - (write-java0 - (decl-pred-vars Nil) $_ $_) - (set-det)) -; - - (= - (write-java0 - (decl-pred-vars $L) $_ $Out) - ( (set-det) - (tab $Out 8) - (write $Out 'Operation ') - (write-reg-args $L $Out) - (write $Out or) - (nl $Out))) -; - - (= - (write-java0 - (put-cont $BinG $C) $_ $Out) - ( (set-det) - (det-if-then-else - (= $BinG - (with_self $P $G)) True - (= $BinG $G)) - (functor $G $F $A0) - (is $A - (- $A0 1)) - (=.. $G - (Cons $F $Args)) - (tab $Out 8) - (write-reg $C $Out) - (write $Out ' = new ') - (det-if-then-else - (nonvar $P) - (, - (write-package $P $Out) - (write $Out .)) True) - (write-class-name - (/ $F $A) $Out) - (write $Out () - (write-reg-args $Args $Out) - (write $Out );) - (nl $Out))) -; - - (= - (write-java0 - (execute cont) $_ $Out) - ( (set-det) - (tab $Out 8) - (write $Out 'return cont;') - (nl $Out))) -; - - (= - (write-java0 - (execute $BinG) $_ $Out) - ( (set-det) - (det-if-then-else - (= $BinG - (with_self $P $G)) True - (= $BinG $G)) - (functor $G $F $A0) - (is $A - (- $A0 1)) - (=.. $G - (Cons $F $Args)) - (tab $Out 8) - (write $Out 'return new ') - (det-if-then-else - (nonvar $P) - (, - (write-package $P $Out) - (write $Out .)) True) - (write-class-name - (/ $F $A) $Out) - (write $Out () - (write-reg-args $Args $Out) - (write $Out );) - (nl $Out))) -; - - (= - (write-java0 - (inline $G) $In $Out) - ( (write-inline $G $In $Out) (set-det))) -; - - (= - (write-java0 - (new-hash $Tag $I) $_ $Out) - ( (set-det) - (tab $Out 4) - (write $Out 'private static final java.util.HashMap ') - (det-if-then-else - (== $Tag int) - (write $Out Int) - (write $Out $Tag)) - (write $Out ' = new java.util.HashMap(') - (write $Out $I) - (write $Out );) - (nl $Out))) -; - - (= - (write-java0 - (put-hash $X $L $Tag) $_ $Out) - ( (set-det) - (tab $Out 8) - (det-if-then-else - (== $Tag int) - (write $Out Int) - (write $Out $Tag)) - (write $Out .put() - (det-if-then-else - (get-symbols &self - (= - (inlined $X - (/ $F $A)) $_)) - (, - (write $Out 'Const.intern("') - (write-constant $F $Out) - (write $Out ",) - (write $Out $A) - (write $Out ))) - (write-reg $X $Out)) - (write $Out , ) - (write-method-ref $L $Out) - (write $Out );) - (nl $Out))) -; - - (= - (write-java0 - (static $Instrs) $In $Out) - ( (set-det) - (tab $Out 4) - (write $Out 'static {') - (nl $Out) - (write-java0 $Instrs $In $Out) - (tab $Out 4) - (write $Out }) - (nl $Out))) -; - -; -; - - (= - (write-java0 - (put-var $X) $_ $Out) - ( (set-det) - (tab $Out 8) - (write-reg $X $Out) - (write $Out ' = new Var(engine);') - (nl $Out))) -; - - (= - (write-java0 - (put-int $I $X) $_ $Out) - ( (long $I) - (set-det) - (tab $Out 4) - (write $Out 'private static final LongTerm ') - (write-reg $X $Out) - (write $Out ' = new LongTerm(') - (write $Out $I) - (write $Out L);) - (nl $Out))) -; - - (= - (write-java0 - (put-int $I $X) $_ $Out) - ( (set-det) - (tab $Out 4) - (write $Out 'private static final IntegerTerm ') - (write-reg $X $Out) - (write $Out ' = new IntegerTerm(') - (det-if-then-else - (java-integer $I) True - (write $Out 'new java.math.BigInteger("')) - (write $Out $I) - (det-if-then-else - (java-integer $I) True - (write $Out "))) - (write $Out );) - (nl $Out))) -; - - (= - (write-java0 - (put-float $F $X) $_ $Out) - ( (set-det) - (tab $Out 4) - (write $Out 'private static final Float ') - (write-reg $X $Out) - (write $Out ' = new Float(') - (write $Out $F) - (write $Out );) - (nl $Out))) -; - - (= - (write-java0 - (put-con - (/ $F $A) $X) $_ $Out) - ( (set-det) (add-symbol &self (inlined $X (/ $F $A))))) -; - - (= - (write-java0 - (put-con $C $X) $_ $Out) - ( (set-det) - (tab $Out 4) - (write $Out 'private static final Const ') - (write-reg $X $Out) - (write $Out ' = Const.intern("') - (det-if-then-else - (= $C - (/ $F $A)) - (, - (write-constant $F $Out) - (write $Out ", ) - (write $Out $A) - (write $Out );)) - (, - (write-constant $C $Out) - (write $Out ");))) - (nl $Out))) -; - - (= - (write-java0 - (put-list $Xi $Xj $Xk) $_ $Out) - ( (set-det) - (det-if-then-else - (= $Xk - (s $_)) - (, - (tab $Out 4) - (write $Out 'private static final ListTerm ')) - (tab $Out 8)) - (write-reg $Xk $Out) - (write $Out ' = LIST(') - (write-reg $Xi $Out) - (write $Out , ) - (write-reg $Xj $Out) - (write $Out );) - (nl $Out))) -; - - (= - (write-java0 - (put-str $Xi $Y $Xj) $_ $Out) - ( (set-det) - (det-if-then-else - (= $Xj - (s $_)) - (, - (tab $Out 4) - (write $Out 'private static final .Fun ')) - (tab $Out 8)) - (write-reg $Xj $Out) - (write $Out ' = F(') - (det-if-then-else - (get-symbols &self - (= - (inlined $Xi - (/ $F $A)) $_)) - (, - (write $Out ") - (write-constant $F $Out) - (write $Out ")) - (write-reg $Xi $Out)) - (write $Out , ) - (write-reg $Y $Out) - (write $Out );) - (nl $Out))) -; - - (= - (write-java0 - (put-str-args $Xs - (s $Y)) $_ $Out) - ( (set-det) (add-symbol &self (inlined (s $Y) (str_args $Xs))))) -; - - (= - (write-java0 - (put-str-args $Xs $Y) $_ $Out) - ( (set-det) - (det-if-then-else - (= $Y - (s $_)) - (, - (tab $Out 4) - (write $Out 'private static final ')) - (tab $Out 8)) - (write $Out 'Term[] ') - (write-reg $Y $Out) - (write $Out = {) - (write-reg-args $Xs $Out) - (write $Out };) - (nl $Out))) -; - - (= - (write-java0 - (put-clo $G0 $X) $_ $Out) - ( (set-det) - (det-if-then-else - (= $G0 - (with_self $P $G)) True - (= $G0 $G)) - (functor $G $F $A) - (=.. $G - (Cons $F $Args0)) - (am2cpp-append $Args0 - (:: null) $Args) - (tab $Out 8) - (write-reg $X $Out) - (write $Out ' = new ClosureTerm(new ') - (det-if-then-else - (nonvar $P) - (, - (write-package $P $Out) - (write $Out .)) True) - (write-class-name - (/ $F $A) $Out) - (write $Out () - (write-reg-args $Args $Out) - (write $Out ));) - (nl $Out))) -; - -; -; - - (= - (write-java0 - (get-val $Xi $Xj) $_ $Out) - ( (set-det) - (tab $Out 8) - (write $Out 'if (! ') - (write-reg $Xi $Out) - (write $Out .unify() - (write-reg $Xj $Out) - (write $Out ', engine.trail))') - (nl $Out) - (tab $Out 12) - (write $Out 'return engine.fail();') - (nl $Out))) -; - - (= - (write-java0 - (get-int $_ $Xi $Xj) $In $Out) - ( (set-det) (write-java0 (get-val $Xi $Xj) $In $Out))) -; - - (= - (write-java0 - (get-float $_ $Xi $Xj) $In $Out) - ( (set-det) (write-java0 (get-val $Xi $Xj) $In $Out))) -; - - (= - (write-java0 - (get-con $_ $Xi $Xj) $In $Out) - ( (set-det) (write-java0 (get-val $Xi $Xj) $In $Out))) -; - - - (= - (write-java0 - (get-ground $_ $Xi $Xj) $In $Out) - ( (set-det) (write-java0 (get-val $Xi $Xj) $In $Out))) -; - - (= - (write-java0 - (get-list $X) $In $Out) - ( (set-det) - (write-java0 - (deref $X $X) $In $Out) - (read-instructions 2 $In $Us) - (tab $Out 8) - (write $Out 'if (') - (write-reg $X $Out) - (write $Out ' IsList()){') - (nl $Out) - (tab $Out 12) - (write $Out 'Term[] args = {(') - (write-reg $X $Out) - (write $Out ').Arg(1),(') - (write-reg $X $Out) - (write $Out ).Arg(2)};) - (nl $Out) - (write-unify-read $Us 0 $Out) - (tab $Out 8) - (write $Out '} else if (') - (write-reg $X $Out) - (write $Out ' instanceof Var){') - (nl $Out) - (write-unify-write $Us $Rs $Out) - (tab $Out 12) - (write $Out '((Var) ') - (write-reg $X $Out) - (write $Out ).bind(LIST() - (write-reg-args $Rs $Out) - (write $Out '), engine.trail);') - (nl $Out) - (tab $Out 8) - (write $Out '} else {') - (nl $Out) - (tab $Out 12) - (write $Out 'return engine.fail();') - (nl $Out) - (tab $Out 8) - (write $Out }) - (nl $Out))) -; - - (= - (write-java0 - (get-str - (/ $F $A) $Xi $Xj) $In $Out) - ( (set-det) - (write-java0 - (deref $Xj $Xj) $In $Out) - (read-instructions $A $In $Us) - (write-unify-write $Us $Rs $Out) - (tab $Out 12) - (write $Out 'if (!') - (write-reg $Xj $Out) - (write $Out .unify(F() - (write-reg $Xi $Out) - (write $Out , ) - (write-reg-args $Rs $Out) - (write $Out '), engine.trail)){') - (nl $Out) - (tab $Out 16) - (write $Out 'return engine.fail();') - (nl $Out) - (tab $Out 12) - (write $Out }) - (nl $Out))) -; - - - - (= - (write-java0 - (try $Li $Lj) $_ $Out) - ( (set-det) - (get-symbols &self - (= - (current_arity $A) $_)) - (tab $Out 8) - (write $Out engine.jtry) - (det-if-then-else - (=< $A 8) - (, - (write $Out $A) - (write $Out ()) - (, - (write $Out () - (write $Out $A) - (write $Out , ))) - (write $Out 'null, ') - (write-method-ref $Lj $Out) - (write $Out );) - (nl $Out) - (tab $Out 8) - (write $Out 'return ') - (write-index $Li $Out) - (write $Out (engine);) - (nl $Out))) -; - - (= - (write-java0 - (retry $Li $Lj) $_ $Out) - ( (set-det) - (tab $Out 8) - (write $Out 'engine.retry(null, ') - (write-method-ref $Lj $Out) - (write $Out );) - (nl $Out) - (tab $Out 8) - (write $Out 'return ') - (write-index $Li $Out) - (write $Out (engine);) - (nl $Out))) -; - - (= - (write-java0 - (trust $L) $_ $Out) - ( (set-det) - (tab $Out 8) - (write $Out engine.trust(null);) - (nl $Out) - (tab $Out 8) - (write $Out 'return ') - (write-index $L $Out) - (write $Out (engine);) - (nl $Out))) -; - -; -; - - (= - (write-java0 - (switch-on-term $Lv $Li $Lf $Lc $Ls $Ll) $_ $Out) - ( (set-det) - (tab $Out 8) - (write $Out {) - (write-inline-start switch-on-term $Out) - (nl $Out) - (tab $Out 12) - (write $Out 'Term x = engine.Areg[0].DeRef();') - (nl $Out) - (write-if-method-call 'x IsVar() ' $Lv $Out) - (write-if-method-call 'x .IsList() ' $Ll $Out) - (write-if-method-call 'x .IsStruct() ' $Ls $Out) - (write-if-method-call 'x .IsConst() ' $Lc $Out) - (write-if-method-call 'x .IsInt() ' $Li $Out) - (write-if-method-call 'x IsFloat() ' $Lf $Out) - (tab $Out 12) - (write $Out 'return ') - (write-index $Lv $Out) - (write $Out (engine);) - (nl $Out) - (tab $Out 8) - (write $Out }) - (write-inline-end $Out) - (nl $Out))) -; - - (= - (write-java0 - (switch-on-hash $Tag $_ $L $_) $_ $Out) - ( (set-det) - (tab $Out 8) - (write $Out 'return engine.switch-on-hash(') - (det-if-then-else - (== $Tag int) - (write $Out Int) - (write $Out $Tag)) - (write $Out , ) - (write-method-ref $L $Out) - (write $Out ).exec(engine);) - (nl $Out))) -; - - (= - (write-java0 $Instruction $_ $_) - ( (am2cpp-error (:: $Instruction is an invalid instruction)) (fail))) -; - - - - (= - (write-label - (main - (/ $F $A) $Modifier) $Out) - ( (set-det) - (get-symbols &self - (= - (current_package $P) $_)) - (nl $Out) - (nl $Out) - (det-if-then-else - (== $Modifier public) - (write $Out 'public ') True) - (write $Out 'final class ') - (write-class-name - (/ $F $A) $Out) - (write $Out ' extends ') - (write-predicate-base-class $A $Out) - (write $Out {) - (nl $Out))) -; - - (= - (write-label - (/ $F $A) $Out) - ( (set-det) - (det-if-then-else - (> $A 4) - (, - (nl $Out) - (write-enum 'private final Term ' arg 5 $A , or 4 $Out) - (nl $Out)) True) - (nl $Out) - (write-constructor - (/ $F $A) $Out) - (nl $Out) - (nl $Out) - (write-to-string - (/ $F $A) $Out) - (nl $Out) - (nl $Out) - (tab $Out 4) - (write $Out @Override) - (nl $Out) - (tab $Out 4) - (write $Out 'public Operation exec(Prolog engine) {') - (nl $Out))) -; - - (= - (write-label $L $Out) - ( (tab $Out 4) - (write $Out }) - (nl $Out) - (nl $Out) - (tab $Out 4) - (write $Out 'private final static Operation ') - (write-index $L $Out) - (write $Out '(Prolog engine) {') - (nl $Out) - (set-det))) -; - - (= - (write-label $Instruction $_ $_) - ( (am2cpp-error (:: $Instruction is an invalid instruction)) (fail))) -; - - - - (= - (write-constructor - (/ $F $A) $Out) - ( (tab $Out 4) - (write $Out 'public ') - (write-class-name - (/ $F $A) $Out) - (write $Out () - (det-if-then-else - (> $A 0) - (write-enum '' 'Term a' 1 $A , , 0 $Out) True) - (write $Out 'Operation cont) {') - (nl $Out) - (> $A 0) - (for $I 1 $A) - (tab $Out 8) - (write $Out this.) - (write $Out arg) - (write $Out $I) - (write $Out = ) - (write $Out a) - (write $Out $I) - (write $Out or) - (nl $Out) - (fail))) -; - - (= - (write-constructor $_ $Out) - ( (tab $Out 8) - (write $Out 'this.cont = cont;') - (nl $Out) - (tab $Out 4) - (write $Out }))) -; - - - - (= - (write-enum $Head $Sym $SN $EN $Delim $_ $Tab $Out) - ( (=< $SN $EN) - (tab $Out $Tab) - (write $Out $Head) - (for $I $SN $EN) - (write $Out $Sym) - (write $Out $I) - (det-if-then-else - (< $I $EN) - (write $Out $Delim) True) - (fail))) -; - - (= - (write-enum $_ $_ $SN $EN $_ $Tail $_ $Out) - ( (=< $SN $EN) (write $Out $Tail))) -; - - - - (= - (write-unify-read Nil $_ $_) - (set-det)) -; - - (= - (write-unify-read - (Cons - (unify-void $I) $Xs) $N $Out) - ( (set-det) - (is $N1 - (+ $N $I)) - (write-unify-read $Xs $N1 $Out))) -; - - (= - (write-unify-read - (Cons $X $Xs) $N $Out) - ( (write-unify-r $X $N $Out) - (is $N1 - (+ $N 1)) - (write-unify-read $Xs $N1 $Out))) -; - - - - (= - (write-unify-r $X $_ $_) - ( (var $X) - (set-det) - (am2cpp-error (:: unbound variable is found)) - (fail))) -; - - (= - (write-unify-r - (unify-var $X) $N $Out) - ( (set-det) - (tab $Out 12) - (write-reg $X $Out) - (write $Out = ) - (write-reg - (args $N) $Out) - (write $Out or) - (nl $Out))) -; - - (= - (write-unify-r - (unify-val $X) $N $Out) - ( (set-det) - (tab $Out 12) - (write $Out 'if (! ') - (write-reg $X $Out) - (write $Out .unify() - (write-reg - (args $N) $Out) - (write $Out ', engine.trail))') - (nl $Out) - (tab $Out 16) - (write $Out 'return engine.fail();') - (nl $Out))) -; - - (= - (write-unify-r - (unify-int $_ $X) $N $Out) - ( (set-det) (write-unify-r (unify-val $X) $N $Out))) -; - - (= - (write-unify-r - (unify-float $_ $X) $N $Out) - ( (set-det) (write-unify-r (unify-val $X) $N $Out))) -; - - (= - (write-unify-r - (unify-con $_ $X) $N $Out) - ( (set-det) (write-unify-r (unify-val $X) $N $Out))) -; - - (= - (write-unify-r - (unify-ground $_ $X) $N $Out) - ( (set-det) (write-unify-r (unify-val $X) $N $Out))) -; - - (= - (write-unify-r $X $_ $_) - ( (am2cpp-error (:: $X is an invalid instruction)) (fail))) -; - - -; -; - - - (= - (write-unify-write Nil Nil $_) - (set-det)) -; - - (= - (write-unify-write - (Cons - (unify-void 0) $Xs) $Rs $Out) - ( (set-det) (write-unify-write $Xs $Rs $Out))) -; - - (= - (write-unify-write - (Cons - (unify-void $I) $Xs) - (Cons void $Rs) $Out) - ( (> $I 0) - (set-det) - (is $I1 - (- $I 1)) - (write-unify-write - (Cons - (unify-void $I1) $Xs) $Rs $Out))) -; - - (= - (write-unify-write - (Cons $X $Xs) - (Cons $R $Rs) $Out) - ( (write-unify-w $X $R $Out) (write-unify-write $Xs $Rs $Out))) -; - - - - (= - (write-unify-w $X $_ $_) - ( (var $X) - (set-det) - (am2cpp-error (:: unbound variable is found)) - (fail))) -; - - (= - (write-unify-w - (unify-var $X) $X $Out) - ( (set-det) - (tab $Out 12) - (write-reg $X $Out) - (write $Out ' = new Var(engine);') - (nl $Out))) -; - - (= - (write-unify-w - (unify-val $X) $X $_) - (set-det)) -; - - (= - (write-unify-w - (unify-int $_ $X) $X $_) - (set-det)) -; - - (= - (write-unify-w - (unify-float $_ $X) $X $_) - (set-det)) -; - - (= - (write-unify-w - (unify-con $_ $X) $X $_) - (set-det)) -; - - (= - (write-unify-w - (unify-ground $_ $X) $X $_) - (set-det)) -; - - (= - (write-unify-w $X $_ $_) - ( (am2cpp-error (:: $X is an invalid instruction)) (fail))) -; - - - - (= - (write-inline $X $In $Out) - ( (write-inline-start $X $Out) - (write-inline0 $X $In $Out) - (write-inline-end $Out))) -; - - - - (= - (write-inline-start $Goal $Out) - ( (tab $Out 8) - (write $Out '//START inline expansion of ') - (write $Out $Goal) - (nl $Out))) -; - - - (= - (write-inline-end $Out) - ( (tab $Out 8) - (write $Out '//END inline expansion') - (nl $Out))) -; - - -; -; - - - (= - (write-inline0 fail $_ $Out) - ( (set-det) - (tab $Out 8) - (write $Out 'return engine.fail();') - (nl $Out))) -; - - (= - (write-inline0 - ($get-level $X) $_ $Out) - ( (set-det) (write-if-fail (op (set-det) (unify $X (# ('new IntegerTerm' engine.B0)))) Nil 8 $Out))) -; - - (= - (write-inline0 %neck-cut $_ $Out) - ( (set-det) - (tab $Out 8) - (write $Out engine.neckCut();) - (nl $Out))) -; - - (= - (write-inline0 - ($cut $X) $_ $Out) - ( (set-det) - (write-deref-args - (:: $X) $Out) - (tab $Out 8) - (write $Out 'if (') - (write-reg $X $Out) - (write $Out ' .IsInt()) {') - (nl $Out) - (tab $Out 12) - (write $Out 'engine.cut(((IntegerTerm) ') - (write-reg $X $Out) - (write $Out ).intValue());) - (nl $Out) - (tab $Out 8) - (write $Out '} else {') - (nl $Out) - (tab $Out 12) - (write $Out 'throw new IllegalTypeException("integer", ') - (write-reg $X $Out) - (write $Out );) - (nl $Out) - (tab $Out 8) - (write $Out }) - (nl $Out))) -; - -; -; - - (= - (write-inline0 - ($unify $X $Y) $_ $Out) - ( (set-det) (write-if-fail (op (set-det) (unify $X $Y)) Nil 8 $Out))) -; - - (= - (write-inline0 - ($not-unifiable $X $Y) $_ $Out) - ( (set-det) (write-if-fail (unify $X $Y) Nil 8 $Out))) -; - -; -; - - (= - (write-inline0 - (var $X) $_ $Out) - ( (set-det) (write-if-fail (op (set-det) (instanceof $X Var)) (:: $X) 8 $Out))) -; - - (= - (write-inline0 - (atom $X) $_ $Out) - ( (set-det) (write-if-fail (op (set-det) (instanceof $X Const)) (:: $X) 8 $Out))) -; - - (= - (write-inline0 - (integer $X) $_ $Out) - ( (set-det) (write-if-fail (op (set-det) (instanceof $X IntegerTerm)) (:: $X) 8 $Out))) -; - - (= - (write-inline0 - (long $X) $_ $Out) - ( (set-det) (write-if-fail (op (set-det) (instanceof $X LongTerm)) (:: $X) 8 $Out))) -; - - (= - (write-inline0 - (float $X) $_ $Out) - ( (set-det) (write-if-fail (op (set-det) (instanceof $X Float)) (:: $X) 8 $Out))) -; - - (= - (write-inline0 - (nonvar $X) $_ $Out) - ( (set-det) (write-if-fail (instanceof $X Var) (:: $X) 8 $Out))) -; - - (= - (write-inline0 - (number $X) $_ $Out) - ( (set-det) - (= $NI - (op - (set-det) - (instanceof $X IntegerTerm))) - (= $NL - (op - (set-det) - (instanceof $X LongTerm))) - (= $ND - (op - (set-det) - (instanceof $X Float))) - (write-if-fail - (op && - (op && $NI $ND) $NL) - (:: $X) 8 $Out))) -; - - (= - (write-inline0 - (java $X) $_ $Out) - ( (set-det) (write-if-fail (op (set-det) (instanceof $X JavaObjectTerm)) (:: $X) 8 $Out))) -; - - (= - (write-inline0 - (closure $X) $_ $Out) - ( (set-det) (write-if-fail (op (set-det) (instanceof $X ClosureTerm)) (:: $X) 8 $Out))) -; - - (= - (write-inline0 - (atomic $X) $_ $Out) - ( (set-det) - (= $NS - (op - (set-det) - (instanceof $X Const))) - (= $NI - (op - (set-det) - (instanceof $X IntegerTerm))) - (= $NL - (op - (set-det) - (instanceof $X LongTerm))) - (= $ND - (op - (set-det) - (instanceof $X Float))) - (write-if-fail - (op && $NL - (op && $NS - (op && $NI $ND))) - (:: $X) 8 $Out))) -; - - (= - (write-inline0 - (java $X $Y) $_ $Out) - ( (set-det) - (write-if-fail - (op - (set-det) - (instanceof $X JavaObjectTerm)) - (:: $X) 8 $Out) - (= $EXP - (# (Const.create (@ (getName (@ (getClass (@ (object (cast JavaObjectTerm $X)))))))))) - (write-if-fail - (op - (set-det) - (unify $Y $EXP)) Nil 8 $Out))) -; - - (= - (write-inline0 - (ground $X) $_ $Out) - ( (set-det) (write-if-fail (op (set-det) (@ (isGround $X))) (:: $X) 8 $Out))) -; - -; -; - - (= - (write-inline0 - ($equality-of-term $X $Y) $_ $Out) - ( (set-det) (write-if-fail (op (set-det) (@ (equals $X $Y))) (:: $X $Y) 8 $Out))) -; - - (= - (write-inline0 - ($inequality-of-term $X $Y) $_ $Out) - ( (set-det) (write-if-fail (@ (equals $X $Y)) (:: $X $Y) 8 $Out))) -; - - (= - (write-inline0 - ($after $X $Y) $_ $Out) - ( (set-det) (write-if-fail (op <= (@ (compareTo $X $Y)) 0) (:: $X $Y) 8 $Out))) -; - - (= - (write-inline0 - ($before $X $Y) $_ $Out) - ( (set-det) (write-if-fail (op >= (@ (compareTo $X $Y)) 0) (:: $X $Y) 8 $Out))) -; - - (= - (write-inline0 - ($not-after $X $Y) $_ $Out) - ( (set-det) (write-if-fail (op > (@ (compareTo $X $Y)) 0) (:: $X $Y) 8 $Out))) -; - - (= - (write-inline0 - ($not-before $X $Y) $_ $Out) - ( (set-det) (write-if-fail (op < (@ (compareTo $X $Y)) 0) (:: $X $Y) 8 $Out))) -; - - (= - (write-inline0 - ($identical-or-cannot-unify $X $Y) $_ $Out) - ( (set-det) (write-if-fail (op && (op (set-det) (@ (equals $X $Y))) (unify $X $Y)) (:: $X $Y) 8 $Out))) -; - -; -; - - (= - (write-inline0 - (copy-term $X $Y) $_ $Out) - ( (nonvar $X) - (nonvar $Y) - (set-det) - (write-if-fail - (op - (set-det) - (unify $Y - (# (engine.copy $X)))) - (:: $X) 8 $Out))) -; - -; -; - - (= - (write-inline0 - (is $X $Y) $_ $Out) - ( (set-det) (write-arith $_ $Y $X 8 $Out))) -; - - (= - (write-inline0 - ($abs $X $Y) $_ $Out) - ( (set-det) (write-arith abs $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($asin $X $Y) $_ $Out) - ( (set-det) (write-arith asin $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($acos $X $Y) $_ $Out) - ( (set-det) (write-arith acos $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($atan $X $Y) $_ $Out) - ( (set-det) (write-arith atan $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($bitwise-conj $X $Y $Z) $_ $Out) - ( (set-det) (write-arith and $X $Y $Z 8 $Out))) -; - - (= - (write-inline0 - ($bitwise-disj $X $Y $Z) $_ $Out) - ( (set-det) (write-arith or $X $Y $Z 8 $Out))) -; - - (= - (write-inline0 - ($bitwise-exclusive-or $X $Y $Z) $_ $Out) - ( (set-det) (write-arith xor $X $Y $Z 8 $Out))) -; - - (= - (write-inline0 - ($bitwise-neg $X $Y) $_ $Out) - ( (set-det) (write-arith not $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($ceil $X $Y) $_ $Out) - ( (set-det) (write-arith ceil $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($cos $X $Y) $_ $Out) - ( (set-det) (write-arith cos $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($degrees $X $Y) $_ $Out) - ( (set-det) (write-arith toDegrees $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($exp $X $Y) $_ $Out) - ( (set-det) (write-arith exp $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($float $X $Y) $_ $Out) - ( (set-det) (write-arith toFloat $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($float-integer-part $X $Y) $_ $Out) - ( (set-det) (write-arith floatIntPart $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($float-fractional-part $X $Y) $_ $Out) - ( (set-det) (write-arith floatFractPart $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($float-quotient $X $Y $Z) $_ $Out) - ( (set-det) (write-arith divide $X $Y $Z 8 $Out))) -; - - (= - (write-inline0 - ($floor $X $Y) $_ $Out) - ( (set-det) (write-arith floor $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($int-quotient $X $Y $Z) $_ $Out) - ( (set-det) (write-arith intDivide $X $Y $Z 8 $Out))) -; - - (= - (write-inline0 - ($log $X $Y) $_ $Out) - ( (set-det) (write-arith log $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($max $X $Y $Z) $_ $Out) - ( (set-det) (write-arith max $X $Y $Z 8 $Out))) -; - - (= - (write-inline0 - ($min $X $Y $Z) $_ $Out) - ( (set-det) (write-arith min $X $Y $Z 8 $Out))) -; - - (= - (write-inline0 - ($minus $X $Y $Z) $_ $Out) - ( (set-det) (write-arith subtract $X $Y $Z 8 $Out))) -; - - (= - (write-inline0 - ($mod $X $Y $Z) $_ $Out) - ( (set-det) (write-arith mod $X $Y $Z 8 $Out))) -; - - (= - (write-inline0 - ($multi $X $Y $Z) $_ $Out) - ( (set-det) (write-arith multiply $X $Y $Z 8 $Out))) -; - - (= - (write-inline0 - ($plus $X $Y $Z) $_ $Out) - ( (set-det) (write-arith add $X $Y $Z 8 $Out))) -; - - (= - (write-inline0 - ($pow $X $Y $Z) $_ $Out) - ( (set-det) (write-arith pow $X $Y $Z 8 $Out))) -; - - (= - (write-inline0 - ($radians $X $Y) $_ $Out) - ( (set-det) (write-arith toRadians $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($rint $X $Y) $_ $Out) - ( (set-det) (write-arith rint $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($round $X $Y) $_ $Out) - ( (set-det) (write-arith round $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($shift-left $X $Y $Z) $_ $Out) - ( (set-det) (write-arith shiftLeft $X $Y $Z 8 $Out))) -; - - (= - (write-inline0 - ($shift-right $X $Y $Z) $_ $Out) - ( (set-det) (write-arith shiftRight $X $Y $Z 8 $Out))) -; - - (= - (write-inline0 - ($sign $X $Y) $_ $Out) - ( (set-det) (write-arith signum $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($sin $X $Y) $_ $Out) - ( (set-det) (write-arith sin $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($sqrt $X $Y) $_ $Out) - ( (set-det) (write-arith sqrt $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($tan $X $Y) $_ $Out) - ( (set-det) (write-arith tan $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($truncate $X $Y) $_ $Out) - ( (set-det) (write-arith truncate $X $Y 8 $Out))) -; - -; -; - - (= - (write-inline0 - ($arith-equal $X $Y) $_ $Out) - ( (set-det) (write-arith-compare != $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($arith-not-equal $X $Y) $_ $Out) - ( (set-det) (write-arith-compare == $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($greater-or-equal $X $Y) $_ $Out) - ( (set-det) (write-arith-compare < $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($greater-than $X $Y) $_ $Out) - ( (set-det) (write-arith-compare <= $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($less-or-equal $X $Y) $_ $Out) - ( (set-det) (write-arith-compare > $X $Y 8 $Out))) -; - - (= - (write-inline0 - ($less-than $X $Y) $_ $Out) - ( (set-det) (write-arith-compare >= $X $Y 8 $Out))) -; - - - - (= - (write-deref-args Nil $_) - (set-det)) -; - - (= - (write-deref-args - (Cons - (s $_) $Xs) $Out) - ( (set-det) (write-deref-args $Xs $Out))) -; - - (= - (write-deref-args - (Cons - (si $_) $Xs) $Out) - ( (set-det) (write-deref-args $Xs $Out))) -; - - (= - (write-deref-args - (Cons - (sf $_) $Xs) $Out) - ( (set-det) (write-deref-args $Xs $Out))) -; - - (= - (write-deref-args - (Cons $X $Xs) $Out) - ( (write-java0 - (deref $X $X) $_ $Out) (write-deref-args $Xs $Out))) -; - - - - (= - (write-if-fail $Cond $Args $Tab $Out) - ( (nonvar $Cond) - (ground $Args) - (set-det) - (= $EXP - (if-then $Cond 'return engine.fail()')) - (write-deref-args $Args $Out) - (write-inline-java $EXP $Tab $Out))) -; - - - - (= - (make-arith-arg $E $_) - ( (var $E) - (set-det) - (fail))) -; - - (= - (make-arith-arg $E $E) - ( (= $E - (si $_)) (set-det))) -; - - (= - (make-arith-arg $E $E) - ( (= $E - (sf $_)) (set-det))) -; - -; -; - - (= - (make_arith_arg $E - (# - (Arithmetic.evaluate $E))) True) -; - - - - (= - (write-arith $M $E $V $Tab $Out) - ( (make-arith-arg $E $A1) - (nonvar $V) - (det-if-then-else - (nonvar $M) - (, - (=.. $A0 - (:: $M $A1)) - (= $A - (@ $A0))) - (= $A $A1)) - (= $EXP - (if-then - (op - (set-det) - (unify $V $A)) 'return engine.fail()')) - (write-inline-java $EXP $Tab $Out))) -; - - - (= - (write-arith $M $E1 $E2 $V $Tab $Out) - ( (nonvar $M) - (make-arith-arg $E1 $A1) - (make-arith-arg $E2 $A2) - (nonvar $V) - (=.. $A0 - (:: $M $A1 $A2)) - (= $A - (@ $A0)) - (= $EXP - (if-then - (op - (set-det) - (unify $V $A)) 'return engine.fail()')) - (write-inline-java $EXP $Tab $Out))) -; - - - - (= - (write-arith-compare $M $E1 $E2 $Tab $Out) - ( (nonvar $M) - (make-arith-arg $E1 $A1) - (make-arith-arg $E2 $A2) - (=.. $A0 - (:: arithCompareTo $A1 $A2)) - (= $A - (@ $A0)) - (= $EXP - (if-then - (op $M $A 0) 'return engine.fail()')) - (write-inline-java $EXP $Tab $Out))) -; - - - - (= - (write-inline-java $X $_ $_) - ( (var $X) - (set-det) - (fail))) -; - - (= - (write-inline-java Nil $_ $_) - (set-det)) -; - - (= - (write-inline-java - (Cons $X $Xs) $Tab $Out) - ( (set-det) - (write-inline-java $X $Tab $Out) - (write-inline-java $Xs $Tab $Out))) -; - - (= - (write-inline-java - (try-catch $TRY $EXCEPT $CATCH) $Tab $Out) - ( (set-det) - (tab $Out $Tab) - (write $Out 'try {') - (nl $Out) - (is $Tab1 - (+ $Tab 4)) - (write-inline-java $TRY $Tab1 $Out) - (tab $Out $Tab) - (write $Out '} catch (') - (write $Out $EXCEPT) - (write $Out ' e) {') - (nl $Out) - (write-inline-java $CATCH $Tab1 $Out) - (tab $Out $Tab) - (write $Out }) - (nl $Out))) -; - - (= - (write-inline-java - (if-then $IF $THEN) $Tab $Out) - ( (set-det) - (tab $Out $Tab) - (write $Out 'if (') - (write-inline-exp $IF 0 $Out) - (write $Out ) {) - (nl $Out) - (is $Tab1 - (+ $Tab 4)) - (write-inline-java $THEN $Tab1 $Out) - (tab $Out $Tab) - (write $Out }) - (nl $Out))) -; - - (= - (write-inline-java - (if-then-else $IF $THEN $ELSE) $Tab $Out) - ( (set-det) - (tab $Out $Tab) - (write $Out 'if (') - (write-inline-exp $IF 0 $Out) - (write $Out ) {) - (nl $Out) - (is $Tab1 - (+ $Tab 4)) - (write-inline-java $THEN $Tab1 $Out) - (tab $Out $Tab) - (write $Out '} else {') - (nl $Out) - (write-inline-java $ELSE $Tab1 $Out) - (tab $Out $Tab) - (write $Out }) - (nl $Out))) -; - - (= - (write-inline-java $X $Tab $Out) - ( (tab $Out $Tab) - (write $Out $X) - (write $Out or) - (nl $Out))) -; - - - - (= - (write-inline-exp $X $_ $_) - ( (var $X) - (set-det) - (fail))) -; - - (= - (write-inline-exp Nil $_ $_) - (set-det)) -; - - (= - (write-inline-exp - (:: $X) $Tab $Out) - ( (set-det) (write-inline-exp $X $Tab $Out))) -; - - (= - (write-inline-exp - (Cons $X $Xs) $Tab $Out) - ( (set-det) - (write-inline-exp $X $Tab $Out) - (write $Out ,) - (write-inline-exp $Xs 0 $Out))) -; - - (= - (write-inline-exp - (bracket $Exp) $Tab $Out) - ( (set-det) - (tab $Out $Tab) - (write $Out () - (write-inline-exp $Exp 0 $Out) - (write $Out )))) -; - - (= - (write-inline-exp - (op $Op $Exp) $Tab $Out) - ( (set-det) - (tab $Out $Tab) - (write $Out $Op) - (write $Out ' ') - (write-inline-exp $Exp 0 $Out))) -; - - (= - (write-inline-exp - (op $Op $Exp1 $Exp2) $Tab $Out) - ( (set-det) - (tab $Out $Tab) - (write-inline-exp $Exp1 0 $Out) - (write $Out ' ') - (write $Out $Op) - (write $Out ' ') - (write-inline-exp $Exp2 0 $Out))) -; - - (= - (write-inline-exp - (instanceof $Exp $Class) $Tab $Out) - ( (set-det) - (tab $Out $Tab) - (write $Out () - (write-inline-exp $Exp 0 $Out) - (write $Out ' instanceof ') - (write $Out $Class) - (write $Out )))) -; - - (= - (write-inline-exp - (cast $Class $Exp) $Tab $Out) - ( (set-det) - (tab $Out $Tab) - (write $Out (() - (write $Out $Class) - (write $Out ) ) - (write-inline-exp $Exp 0 $Out) - (write $Out )))) -; - - (= - (write-inline-exp - (unify $X $Y) $Tab $Out) - ( (set-det) - (tab $Out $Tab) - (write-inline-exp $X 0 $Out) - (write $Out .unify() - (write-inline-exp $Y 0 $Out) - (write $Out ', engine.trail)'))) -; - - (= - (write-inline-exp - (# $X) $Tab $Out) - ( (set-det) - (=.. $X - (Cons $F $As)) - (tab $Out $Tab) - (write $Out $F) - (write $Out () - (write-inline-exp $As 0 $Out) - (write $Out )))) -; - - (= - (write-inline-exp - (@ $X) $Tab $Out) - ( (set-det) - (=.. $X - (Cons $F $As)) - (write-inline-method $F $As $Tab $Out))) -; - - (= - (write-inline-exp $X $Tab $Out) - ( (= $X + (inlined $Xi + (/ $F $A)) $_) + (get-atoms &self)) + (, + (write $Out ") + (write-constant $F $Out) + (write $Out ")) + (write-reg $Xi $Out)) + (write $Out , ) + (write-reg $Y $Out) + (write $Out );) + (nl $Out)) + (= (write-java0 (put-str-args $Xs (s $Y)) $_ $Out) + ( (set-det) (add-is-symbol &self (inlined (s $Y) (str_args $Xs))))) + (= (write-java0 (put-str-args $Xs $Y) $_ $Out) + (set-det) + (det-if-then-else + (= $Y (s $_)) - (set-det) - (tab $Out $Tab) - (write-reg $X $Out))) -; - - (= - (write-inline-exp $X $Tab $Out) - ( (= $X - (si $_)) - (set-det) - (tab $Out $Tab) - (write-reg $X $Out))) -; - - (= - (write-inline-exp $X $Tab $Out) - ( (= $X - (sf $_)) - (set-det) - (tab $Out $Tab) - (write-reg $X $Out))) -; - - (= - (write-inline-exp $X $Tab $Out) - ( (= $X - (a $_)) - (set-det) - (tab $Out $Tab) - (write-reg $X $Out))) -; - - (= - (write-inline-exp $X $Tab $Out) - ( (== $X void) - (set-det) - (tab $Out $Tab) - (write-reg $X $Out))) -; - - (= - (write-inline-exp $X $Tab $Out) - ( (tab $Out $Tab) (write $Out $X))) -; - + (, + (tab $Out 4) + (write $Out 'private static final ')) + (tab $Out 8)) + (write $Out 'Term[] ') + (write-reg $Y $Out) + (write $Out = {) + (write-reg-args $Xs $Out) + (write $Out };) + (nl $Out)) + (= (write-java0 (put-clo $G0 $X) $_ $Out) + (set-det) + (det-if-then-else + (= $G0 + (with_self $P $G)) True + (= $G0 $G)) + (functor $G $F $A) + (=.. $G + (Cons $F $Args0)) + (am2cpp-append $Args0 + (:: null) $Args) + (tab $Out 8) + (write-reg $X $Out) + (write $Out ' = new ClosureTerm(new ') + (det-if-then-else + (nonvar $P) + (, + (write-package $P $Out) + (write $Out .)) True) + (write-class-name + (/ $F $A) $Out) + (write $Out () + (write-reg-args $Args $Out) + (write $Out ));) + (nl $Out)) +; +; ;; Get Instructions + (= (write-java0 (get-val $Xi $Xj) $_ $Out) + (set-det) + (tab $Out 8) + (write $Out 'if (! ') + (write-reg $Xi $Out) + (write $Out .unify() + (write-reg $Xj $Out) + (write $Out ', engine.trail))') + (nl $Out) + (tab $Out 12) + (write $Out 'return engine.fail();') + (nl $Out)) + (= (write-java0 (get-int $_ $Xi $Xj) $In $Out) + (set-det) + (write-java0 + (get-val $Xi $Xj) $In $Out)) + (= (write-java0 (get-float $_ $Xi $Xj) $In $Out) + (set-det) + (write-java0 + (get-val $Xi $Xj) $In $Out)) +; /* write_java0(get_int(N,Xi,Xj), In, Out) :- !, write_java0(deref(Xj,Xj), In, Out), ; read mode tab(Out, 8), write(Out, 'if ('), write_reg(Xj, Out), write(Out, ' .IsInt() || '), write_reg(Xj, Out), write(Out, ' instanceof LongTerm){'), nl(Out), tab(Out, 12), write(Out, 'if (((NumberTerm) '), write_reg(Xj, Out), write(Out, ').intValue() != '), write(Out, N), write(Out, ')'), nl(Out), tab(Out, 16), write(Out, 'return engine.fail();'), nl(Out), ; write mode tab(Out, 8), write(Out, '} else if ('), write_reg(Xj, Out), write(Out, ' instanceof Var){'), nl(Out), tab(Out, 12), write(Out, '((Var) '), write_reg(Xj, Out), write(Out, ').bind('), write_reg(Xi, Out), write(Out, ', engine.trail);'), nl(Out), tab(Out, 8), ; otherwise fail write(Out, '} else {'), nl(Out), tab(Out, 12), write(Out, 'return engine.fail();'), nl(Out), tab(Out, 8), write(Out, '}'), nl(Out). */ + (= (write-java0 (get-con $_ $Xi $Xj) $In $Out) + (set-det) + (write-java0 + (get-val $Xi $Xj) $In $Out)) +; /* write_java0(get_float(N,Xi,Xj), In, Out) :- !, write_java0(deref(Xj,Xj), In, Out), ; read mode tab(Out, 8), write(Out, 'if ('), write_reg(Xj, Out), write(Out, ' instanceof Float){'), nl(Out), tab(Out, 12), write(Out, 'if (((Float) '), write_reg(Xj, Out), write(Out, ').doubleValue() != '), write(Out, N), write(Out, ')'), nl(Out), tab(Out, 16), write(Out, 'return engine.fail();'), nl(Out), ; write mode tab(Out, 8), write(Out, '} else if ('), write_reg(Xj, Out), write(Out, ' instanceof Var){'), nl(Out), tab(Out, 12), write(Out, '((Var) '), write_reg(Xj, Out), write(Out, ').bind('), write_reg(Xi, Out), write(Out, ', engine.trail);'), nl(Out), tab(Out, 8), ; otherwise fail write(Out, '} else {'), nl(Out), tab(Out, 12), write(Out, 'return engine.fail();'), nl(Out), tab(Out, 8), write(Out, '}'), nl(Out). */ - - (= - (write-inline-method $F $_ $_ $_) - ( (var $F) - (set-det) - (fail))) -; + (= (write-java0 (get-ground $_ $Xi $Xj) $In $Out) + (set-det) + (write-java0 + (get-val $Xi $Xj) $In $Out)) +; /* write_java0(get_con(_,Xi,Xj), In, Out) :- !, write_java0(deref(Xj,Xj), In, Out), ; read mode tab(Out, 8), write(Out, 'if ('), write_reg(Xj, Out), write(Out, ' .IsConst()){'), nl(Out), tab(Out, 12), write(Out, 'if (! '), write_reg(Xj, Out), write(Out, '.equals('), write_reg(Xi, Out), write(Out, '))'), nl(Out), tab(Out, 16), write(Out, 'return engine.fail();'), nl(Out), ; write mode tab(Out, 8), write(Out, '} else if ('), write_reg(Xj, Out), write(Out, ' instanceof Var){'), nl(Out), tab(Out, 12), write(Out, '((Var) '), write_reg(Xj, Out), write(Out, ').bind('), write_reg(Xi, Out), write(Out, ', engine.trail);'), nl(Out), tab(Out, 8), ; otherwise fail write(Out, '} else {'), nl(Out), tab(Out, 12), write(Out, 'return engine.fail();'), nl(Out), tab(Out, 8), write(Out, '}'), nl(Out). */ + (= (write-java0 (get-list $X) $In $Out) + (set-det) + (write-java0 + (deref $X $X) $In $Out) + (read-instructions 2 $In $Us) + (tab $Out 8) + (write $Out 'if (') + (write-reg $X $Out) + (write $Out ' IsList()){') + (nl $Out) + (tab $Out 12) + (write $Out 'Term[] args = {(') + (write-reg $X $Out) + (write $Out ').Arg(1),(') + (write-reg $X $Out) + (write $Out ).Arg(2)};) + (nl $Out) + (write-unify-read $Us 0 $Out) + (tab $Out 8) + (write $Out '} else if (') + (write-reg $X $Out) + (write $Out ' instanceof Var){') + (nl $Out) + (write-unify-write $Us $Rs $Out) + (tab $Out 12) + (write $Out '((Var) ') + (write-reg $X $Out) + (write $Out ).bind(LIST() + (write-reg-args $Rs $Out) + (write $Out '), engine.trail);') + (nl $Out) + (tab $Out 8) + (write $Out '} else {') + (nl $Out) + (tab $Out 12) + (write $Out 'return engine.fail();') + (nl $Out) + (tab $Out 8) + (write $Out }) + (nl $Out)) +; ; read mode +; ; write mode +; ; otherwise fail + (= (write-java0 (get-str (/ $F $A) $Xi $Xj) $In $Out) + (set-det) + (write-java0 + (deref $Xj $Xj) $In $Out) + (read-instructions $A $In $Us) + (write-unify-write $Us $Rs $Out) + (tab $Out 12) + (write $Out 'if (!') + (write-reg $Xj $Out) + (write $Out .unify(F() + (write-reg $Xi $Out) + (write $Out , ) + (write-reg-args $Rs $Out) + (write $Out '), engine.trail)){') + (nl $Out) + (tab $Out 16) + (write $Out 'return engine.fail();') + (nl $Out) + (tab $Out 12) + (write $Out }) + (nl $Out)) +; ; simple unify - (= - (write-inline-method $_ $A $_ $_) - ( (var $A) - (set-det) - (fail))) -; - (= - (write-inline-method $F - (:: $A) $Tab $Out) + (= (write-java0 (try $Li $Lj) $_ $Out) ( (set-det) - (tab $Out $Tab) - (write-inline-exp $A 0 $Out) - (write $Out .) - (write $Out $F) - (write $Out ()))) -; - - (= - (write-inline-method $F - (:: $A $B) $Tab $Out) - ( (tab $Out $Tab) - (write-inline-exp $A 0 $Out) - (write $Out .) - (write $Out $F) - (write $Out () - (write-inline-exp $B 0 $Out) - (write $Out )))) -; - - - - - (= - (write-insert $X $_ $_) - ( (var $X) - (set-det) - (fail))) -; - - (= - (write-insert Nil $_ $_) - (set-det)) -; - - (= - (write-insert - (Cons $X $Xs) $_ $Out) - ( (atom $X) - (write $Out $X) - (nl $Out) - (write-insert $Xs $_ $Out))) -; - - - - (= - (write-to-string - (/ $F $A) $Out) - ( (tab $Out 4) - (write $Out @Override) - (nl $Out) - (tab $Out 4) - (write $Out 'public void toString(StringBuilder sb) {') - (nl $Out) - (predicate-encoding $F $F1) + (== + (= + (current_arity $A) $_) + (get-atoms &self)) (tab $Out 8) - (write $Out 'sb.append("') - (write $Out $F1) + (write $Out engine.jtry) (det-if-then-else - (> $A 0) + (=< $A 8) (, - (write $Out (");) - (nl $Out) - (write-enum '' arg 1 $A '.toString(sb); sb.append(", "); ' .toString(sb); 8 $Out) - (nl $Out) - (tab $Out 8) - (write $Out 'sb.append(")");') - (nl $Out)) + (write $Out $A) + (write $Out ()) (, - (write $Out ");) - (nl $Out))) - (tab $Out 4) - (write $Out }) + (write $Out () + (write $Out $A) + (write $Out , ))) + (write $Out 'null, ') + (write-method-ref $Lj $Out) + (write $Out );) + (nl $Out) + (tab $Out 8) + (write $Out 'return ') + (write-index $Li $Out) + (write $Out (engine);) + (nl $Out))) +; /* ; read mode tab(Out, 8), write(Out, 'if ('), write_reg(Xj, Out), write(Out, ' .IsStruct()){'), nl(Out), ;??? == F tab(Out, 12), write(Out, 'if (! '), write_reg(Xi, Out), write(Out, '.equals(((.Fun)'), write_reg(Xj, Out), write(Out, ').functor()))'), nl(Out), tab(Out, 16), write(Out, 'return engine.fail();'), nl(Out), tab(Out, 12), write(Out, 'Term[] args = ((.Fun)'), write_reg(Xj, Out), write(Out, ').args();'), nl(Out), write_unify_read(Us, 0, Out), ; write mode tab(Out, 8), write(Out, '} else if ('), write_reg(Xj, Out), write(Out, ' instanceof Var){'), nl(Out), write_unify_write(Us, Rs, Out), tab(Out, 12), write(Out, 'Term[] args = {'), write_reg_args(Rs, Out), write(Out, '};'), nl(Out), tab(Out, 12), write(Out, '((Var) '), write_reg(Xj, Out), write(Out, ').bind(F('), write_reg(Xi, Out), write(Out, ', args), engine.trail);'), nl(Out), ; otherwise fail tab(Out, 8), write(Out, '} else {'), nl(Out), tab(Out, 12), write(Out, 'return engine.fail();'), nl(Out), tab(Out, 8), write(Out, '}'), nl(Out). */ +; ;;; Choice Instructions + (= (write-java0 (retry $Li $Lj) $_ $Out) + (set-det) + (tab $Out 8) + (write $Out 'engine.retry(null, ') + (write-method-ref $Lj $Out) + (write $Out );) + (nl $Out) + (tab $Out 8) + (write $Out 'return ') + (write-index $Li $Out) + (write $Out (engine);) + (nl $Out)) + (= (write-java0 (trust $L) $_ $Out) + (set-det) + (tab $Out 8) + (write $Out engine.trust(null);) + (nl $Out) + (tab $Out 8) + (write $Out 'return ') + (write-index $L $Out) + (write $Out (engine);) + (nl $Out)) +; +; ;; Indexing Instructions + (= (write-java0 (switch-on-term $Lv $Li $Lf $Lc $Ls $Ll) $_ $Out) + (set-det) + (tab $Out 8) + (write $Out {) + (write-inline-start switch-on-term $Out) + (nl $Out) + (tab $Out 12) + (write $Out 'Term x = engine.Areg[0].DeRef();') + (nl $Out) + (write-if-method-call 'x IsVar() ' $Lv $Out) + (write-if-method-call 'x .IsList() ' $Ll $Out) + (write-if-method-call 'x .IsStruct() ' $Ls $Out) + (write-if-method-call 'x .IsConst() ' $Lc $Out) + (write-if-method-call 'x .IsInt() ' $Li $Out) + (write-if-method-call 'x IsFloat() ' $Lf $Out) + (tab $Out 12) + (write $Out 'return ') + (write-index $Lv $Out) + (write $Out (engine);) + (nl $Out) + (tab $Out 8) + (write $Out }) + (write-inline-end $Out) + (nl $Out)) + (= (write-java0 (switch-on-hash $Tag $_ $L $_) $_ $Out) + (set-det) + (tab $Out 8) + (write $Out 'return engine.switch-on-hash(') + (det-if-then-else + (== $Tag int) + (write $Out Int) + (write $Out $Tag)) + (write $Out , ) + (write-method-ref $L $Out) + (write $Out ).exec(engine);) + (nl $Out)) + (= (write-java0 $Instruction $_ $_) + (am2cpp-error (:: $Instruction is an invalid instruction)) + (fail)) + + + (= (write-label (main (/ $F $A) $Modifier) $Out) + ( (set-det) + (== + (= + (current_package $P) $_) + (get-atoms &self)) + (nl $Out) + (nl $Out) + (det-if-then-else + (== $Modifier public) + (write $Out 'public ') True) + (write $Out 'final class ') + (write-class-name + (/ $F $A) $Out) + (write $Out ' extends ') + (write-predicate-base-class $A $Out) + (write $Out {) (nl $Out))) -; +; /***************************************************************** Write Label *****************************************************************/ +; ; Import class constants within translation unit +; ; write(Out, 'import static '), write_package(P, Out), write(Out, '.'), ; write_class_name(F/A, Out), write(Out, '.*;'), ; nl(Out), +; ; Class definition + (= (write-label (/ $F $A) $Out) + (set-det) + (det-if-then-else + (> $A 4) + (, + (nl $Out) + (write-enum 'private final Term ' arg 5 $A , or 4 $Out) + (nl $Out)) True) + (nl $Out) + (write-constructor + (/ $F $A) $Out) + (nl $Out) + (nl $Out) + (write-to-string + (/ $F $A) $Out) + (nl $Out) + (nl $Out) + (tab $Out 4) + (write $Out @Override) + (nl $Out) + (tab $Out 4) + (write $Out 'public Operation exec(Prolog engine) {') + (nl $Out)) +; ; instance variable declaration +; ; constructor +; ; toString method +; ; exec method + (= (write-label $L $Out) + (tab $Out 4) + (write $Out }) + (nl $Out) + (nl $Out) + (tab $Out 4) + (write $Out 'private final static Operation ') + (write-index $L $Out) + (write $Out '(Prolog engine) {') + (nl $Out) + (set-det)) +; ; method for control instructions and clauses + (= (write-label $Instruction $_ $_) + (am2cpp-error (:: $Instruction is an invalid instruction)) + (fail)) + + + (= (write-constructor (/ $F $A) $Out) + (tab $Out 4) + (write $Out 'public ') + (write-class-name + (/ $F $A) $Out) + (write $Out () + (det-if-then-else + (> $A 0) + (write-enum '' 'Term a' 1 $A , , 0 $Out) True) + (write $Out 'Operation cont) {') + (nl $Out) + (> $A 0) + (for $I 1 $A) + (tab $Out 8) + (write $Out this.) + (write $Out arg) + (write $Out $I) + (write $Out = ) + (write $Out a) + (write $Out $I) + (write $Out or) + (nl $Out) + (fail)) +; /***************************************************************** Write Constructor *****************************************************************/ + (= (write-constructor $_ $Out) + (tab $Out 8) + (write $Out 'this.cont = cont;') + (nl $Out) + (tab $Out 4) + (write $Out })) + + + (= (write-enum $Head $Sym $SN $EN $Delim $_ $Tab $Out) + (=< $SN $EN) + (tab $Out $Tab) + (write $Out $Head) + (for $I $SN $EN) + (write $Out $Sym) + (write $Out $I) + (det-if-then-else + (< $I $EN) + (write $Out $Delim) True) + (fail)) + (= (write-enum $_ $_ $SN $EN $_ $Tail $_ $Out) + (=< $SN $EN) + (write $Out $Tail)) + + + (= (write-unify-read Nil $_ $_) + (set-det)) +; /***************************************************************** Write Unify Instructions *****************************************************************/ +; ;;; Read Mode + (= (write-unify-read (Cons (unify-void $I) $Xs) $N $Out) + (set-det) + (is $N1 + (+ $N $I)) + (write-unify-read $Xs $N1 $Out)) + (= (write-unify-read (Cons $X $Xs) $N $Out) + (write-unify-r $X $N $Out) + (is $N1 + (+ $N 1)) + (write-unify-read $Xs $N1 $Out)) + + + (= (write-unify-r $X $_ $_) + (var $X) + (set-det) + (am2cpp-error (:: unbound variable is found)) + (fail)) + (= (write-unify-r (unify-var $X) $N $Out) + (set-det) + (tab $Out 12) + (write-reg $X $Out) + (write $Out = ) + (write-reg + (args $N) $Out) + (write $Out or) + (nl $Out)) + (= (write-unify-r (unify-val $X) $N $Out) + (set-det) + (tab $Out 12) + (write $Out 'if (! ') + (write-reg $X $Out) + (write $Out .unify() + (write-reg + (args $N) $Out) + (write $Out ', engine.trail))') + (nl $Out) + (tab $Out 16) + (write $Out 'return engine.fail();') + (nl $Out)) + (= (write-unify-r (unify-int $_ $X) $N $Out) + (set-det) + (write-unify-r + (unify-val $X) $N $Out)) +; ;??? + (= (write-unify-r (unify-float $_ $X) $N $Out) + (set-det) + (write-unify-r + (unify-val $X) $N $Out)) +; ;??? + (= (write-unify-r (unify-con $_ $X) $N $Out) + (set-det) + (write-unify-r + (unify-val $X) $N $Out)) +; ;??? + (= (write-unify-r (unify-ground $_ $X) $N $Out) + (set-det) + (write-unify-r + (unify-val $X) $N $Out)) + (= (write-unify-r $X $_ $_) + (am2cpp-error (:: $X is an invalid instruction)) + (fail)) +; +; ;; Write Mode + + (= (write-unify-write Nil Nil $_) + (set-det)) + (= (write-unify-write (Cons (unify-void 0) $Xs) $Rs $Out) + (set-det) + (write-unify-write $Xs $Rs $Out)) + (= (write-unify-write (Cons (unify-void $I) $Xs) (Cons void $Rs) $Out) + (> $I 0) + (set-det) + (is $I1 + (- $I 1)) + (write-unify-write + (Cons + (unify-void $I1) $Xs) $Rs $Out)) + (= (write-unify-write (Cons $X $Xs) (Cons $R $Rs) $Out) + (write-unify-w $X $R $Out) + (write-unify-write $Xs $Rs $Out)) + + + (= (write-unify-w $X $_ $_) + (var $X) + (set-det) + (am2cpp-error (:: unbound variable is found)) + (fail)) + (= (write-unify-w (unify-var $X) $X $Out) + (set-det) + (tab $Out 12) + (write-reg $X $Out) + (write $Out ' = new Var(engine);') + (nl $Out)) + (= (write-unify-w (unify-val $X) $X $_) + (set-det)) + (= (write-unify-w (unify-int $_ $X) $X $_) + (set-det)) + (= (write-unify-w (unify-float $_ $X) $X $_) + (set-det)) + (= (write-unify-w (unify-con $_ $X) $X $_) + (set-det)) + (= (write-unify-w (unify-ground $_ $X) $X $_) + (set-det)) + (= (write-unify-w $X $_ $_) + (am2cpp-error (:: $X is an invalid instruction)) + (fail)) + + + (= (write-inline $X $In $Out) + (write-inline-start $X $Out) + (write-inline0 $X $In $Out) + (write-inline-end $Out)) +; /***************************************************************** Write Inline *****************************************************************/ + + + (= (write-inline-start $Goal $Out) + (tab $Out 8) + (write $Out '//START inline expansion of ') + (write $Out $Goal) + (nl $Out)) + + (= (write-inline-end $Out) + (tab $Out 8) + (write $Out '//END inline expansion') + (nl $Out)) - - (= - (mkdirs $Dir) - ( (exists-directory $Dir) (set-det))) -; +; +; Control constructs + + (= (write-inline0 fail $_ $Out) + (set-det) + (tab $Out 8) + (write $Out 'return engine.fail();') + (nl $Out)) + (= (write-inline0 ($get-level $X) $_ $Out) + (set-det) + (write-if-fail + (op + (set-det) + (unify $X + (# ('new IntegerTerm' engine.B0)))) Nil 8 $Out)) + (= (write-inline0 %neck-cut $_ $Out) + (set-det) + (tab $Out 8) + (write $Out engine.neckCut();) + (nl $Out)) + (= (write-inline0 ($cut $X) $_ $Out) + (set-det) + (write-deref-args + (:: $X) $Out) + (tab $Out 8) + (write $Out 'if (') + (write-reg $X $Out) + (write $Out ' .IsInt()) {') + (nl $Out) + (tab $Out 12) + (write $Out 'engine.cut(((IntegerTerm) ') + (write-reg $X $Out) + (write $Out ).intValue());) + (nl $Out) + (tab $Out 8) + (write $Out '} else {') + (nl $Out) + (tab $Out 12) + (write $Out 'throw new IllegalTypeException("integer", ') + (write-reg $X $Out) + (write $Out );) + (nl $Out) + (tab $Out 8) + (write $Out }) + (nl $Out)) +; +; Term unification + (= (write-inline0 ($unify $X $Y) $_ $Out) + (set-det) + (write-if-fail + (op + (set-det) + (unify $X $Y)) Nil 8 $Out)) + (= (write-inline0 ($not-unifiable $X $Y) $_ $Out) + (set-det) + (write-if-fail + (unify $X $Y) Nil 8 $Out)) +; +; Type testing + (= (write-inline0 (var $X) $_ $Out) + (set-det) + (write-if-fail + (op + (set-det) + (instanceof $X Var)) + (:: $X) 8 $Out)) + (= (write-inline0 (atom $X) $_ $Out) + (set-det) + (write-if-fail + (op + (set-det) + (instanceof $X Const)) + (:: $X) 8 $Out)) + (= (write-inline0 (integer $X) $_ $Out) + (set-det) + (write-if-fail + (op + (set-det) + (instanceof $X IntegerTerm)) + (:: $X) 8 $Out)) + (= (write-inline0 (long $X) $_ $Out) + (set-det) + (write-if-fail + (op + (set-det) + (instanceof $X LongTerm)) + (:: $X) 8 $Out)) + (= (write-inline0 (float $X) $_ $Out) + (set-det) + (write-if-fail + (op + (set-det) + (instanceof $X Float)) + (:: $X) 8 $Out)) + (= (write-inline0 (nonvar $X) $_ $Out) + (set-det) + (write-if-fail + (instanceof $X Var) + (:: $X) 8 $Out)) + (= (write-inline0 (number $X) $_ $Out) + (set-det) + (= $NI + (op + (set-det) + (instanceof $X IntegerTerm))) + (= $NL + (op + (set-det) + (instanceof $X LongTerm))) + (= $ND + (op + (set-det) + (instanceof $X Float))) + (write-if-fail + (op && + (op && $NI $ND) $NL) + (:: $X) 8 $Out)) + (= (write-inline0 (java $X) $_ $Out) + (set-det) + (write-if-fail + (op + (set-det) + (instanceof $X JavaObjectTerm)) + (:: $X) 8 $Out)) + (= (write-inline0 (closure $X) $_ $Out) + (set-det) + (write-if-fail + (op + (set-det) + (instanceof $X ClosureTerm)) + (:: $X) 8 $Out)) + (= (write-inline0 (atomic $X) $_ $Out) + (set-det) + (= $NS + (op + (set-det) + (instanceof $X Const))) + (= $NI + (op + (set-det) + (instanceof $X IntegerTerm))) + (= $NL + (op + (set-det) + (instanceof $X LongTerm))) + (= $ND + (op + (set-det) + (instanceof $X Float))) + (write-if-fail + (op && $NL + (op && $NS + (op && $NI $ND))) + (:: $X) 8 $Out)) + (= (write-inline0 (java $X $Y) $_ $Out) + (set-det) + (write-if-fail + (op + (set-det) + (instanceof $X JavaObjectTerm)) + (:: $X) 8 $Out) + (= $EXP + (# (Const.create (@ (getName (@ (getClass (@ (object (cast JavaObjectTerm $X)))))))))) + (write-if-fail + (op + (set-det) + (unify $Y $EXP)) Nil 8 $Out)) + (= (write-inline0 (ground $X) $_ $Out) + (set-det) + (write-if-fail + (op + (set-det) + (@ (isGround $X))) + (:: $X) 8 $Out)) +; +; Term comparison + (= (write-inline0 ($equality-of-term $X $Y) $_ $Out) + (set-det) + (write-if-fail + (op + (set-det) + (@ (equals $X $Y))) + (:: $X $Y) 8 $Out)) + (= (write-inline0 ($inequality-of-term $X $Y) $_ $Out) + (set-det) + (write-if-fail + (@ (equals $X $Y)) + (:: $X $Y) 8 $Out)) + (= (write-inline0 ($after $X $Y) $_ $Out) + (set-det) + (write-if-fail + (op <= + (@ (compareTo $X $Y)) 0) + (:: $X $Y) 8 $Out)) + (= (write-inline0 ($before $X $Y) $_ $Out) + (set-det) + (write-if-fail + (op >= + (@ (compareTo $X $Y)) 0) + (:: $X $Y) 8 $Out)) + (= (write-inline0 ($not-after $X $Y) $_ $Out) + (set-det) + (write-if-fail + (op > + (@ (compareTo $X $Y)) 0) + (:: $X $Y) 8 $Out)) + (= (write-inline0 ($not-before $X $Y) $_ $Out) + (set-det) + (write-if-fail + (op < + (@ (compareTo $X $Y)) 0) + (:: $X $Y) 8 $Out)) + (= (write-inline0 ($identical-or-cannot-unify $X $Y) $_ $Out) + (set-det) + (write-if-fail + (op && + (op + (set-det) + (@ (equals $X $Y))) + (unify $X $Y)) + (:: $X $Y) 8 $Out)) +; +; Term creation and decomposition + (= (write-inline0 (copy-term $X $Y) $_ $Out) + (nonvar $X) + (nonvar $Y) + (set-det) + (write-if-fail + (op + (set-det) + (unify $Y + (# (engine.copy $X)))) + (:: $X) 8 $Out)) +; +; Arithmetic evaluation + (= (write-inline0 (is $X $Y) $_ $Out) + (set-det) + (write-arith $_ $Y $X 8 $Out)) + (= (write-inline0 ($abs $X $Y) $_ $Out) + (set-det) + (write-arith abs $X $Y 8 $Out)) + (= (write-inline0 ($asin $X $Y) $_ $Out) + (set-det) + (write-arith asin $X $Y 8 $Out)) + (= (write-inline0 ($acos $X $Y) $_ $Out) + (set-det) + (write-arith acos $X $Y 8 $Out)) + (= (write-inline0 ($atan $X $Y) $_ $Out) + (set-det) + (write-arith atan $X $Y 8 $Out)) + (= (write-inline0 ($bitwise-conj $X $Y $Z) $_ $Out) + (set-det) + (write-arith and $X $Y $Z 8 $Out)) + (= (write-inline0 ($bitwise-disj $X $Y $Z) $_ $Out) + (set-det) + (write-arith or $X $Y $Z 8 $Out)) + (= (write-inline0 ($bitwise-exclusive-or $X $Y $Z) $_ $Out) + (set-det) + (write-arith xor $X $Y $Z 8 $Out)) + (= (write-inline0 ($bitwise-neg $X $Y) $_ $Out) + (set-det) + (write-arith not $X $Y 8 $Out)) + (= (write-inline0 ($ceil $X $Y) $_ $Out) + (set-det) + (write-arith ceil $X $Y 8 $Out)) + (= (write-inline0 ($cos $X $Y) $_ $Out) + (set-det) + (write-arith cos $X $Y 8 $Out)) + (= (write-inline0 ($degrees $X $Y) $_ $Out) + (set-det) + (write-arith toDegrees $X $Y 8 $Out)) + (= (write-inline0 ($exp $X $Y) $_ $Out) + (set-det) + (write-arith exp $X $Y 8 $Out)) + (= (write-inline0 ($float $X $Y) $_ $Out) + (set-det) + (write-arith toFloat $X $Y 8 $Out)) + (= (write-inline0 ($float-integer-part $X $Y) $_ $Out) + (set-det) + (write-arith floatIntPart $X $Y 8 $Out)) + (= (write-inline0 ($float-fractional-part $X $Y) $_ $Out) + (set-det) + (write-arith floatFractPart $X $Y 8 $Out)) + (= (write-inline0 ($float-quotient $X $Y $Z) $_ $Out) + (set-det) + (write-arith divide $X $Y $Z 8 $Out)) + (= (write-inline0 ($floor $X $Y) $_ $Out) + (set-det) + (write-arith floor $X $Y 8 $Out)) + (= (write-inline0 ($int-quotient $X $Y $Z) $_ $Out) + (set-det) + (write-arith intDivide $X $Y $Z 8 $Out)) + (= (write-inline0 ($log $X $Y) $_ $Out) + (set-det) + (write-arith log $X $Y 8 $Out)) + (= (write-inline0 ($max $X $Y $Z) $_ $Out) + (set-det) + (write-arith max $X $Y $Z 8 $Out)) + (= (write-inline0 ($min $X $Y $Z) $_ $Out) + (set-det) + (write-arith min $X $Y $Z 8 $Out)) + (= (write-inline0 ($minus $X $Y $Z) $_ $Out) + (set-det) + (write-arith subtract $X $Y $Z 8 $Out)) + (= (write-inline0 ($mod $X $Y $Z) $_ $Out) + (set-det) + (write-arith mod $X $Y $Z 8 $Out)) + (= (write-inline0 ($multi $X $Y $Z) $_ $Out) + (set-det) + (write-arith multiply $X $Y $Z 8 $Out)) + (= (write-inline0 ($plus $X $Y $Z) $_ $Out) + (set-det) + (write-arith add $X $Y $Z 8 $Out)) + (= (write-inline0 ($pow $X $Y $Z) $_ $Out) + (set-det) + (write-arith pow $X $Y $Z 8 $Out)) + (= (write-inline0 ($radians $X $Y) $_ $Out) + (set-det) + (write-arith toRadians $X $Y 8 $Out)) + (= (write-inline0 ($rint $X $Y) $_ $Out) + (set-det) + (write-arith rint $X $Y 8 $Out)) + (= (write-inline0 ($round $X $Y) $_ $Out) + (set-det) + (write-arith round $X $Y 8 $Out)) + (= (write-inline0 ($shift-left $X $Y $Z) $_ $Out) + (set-det) + (write-arith shiftLeft $X $Y $Z 8 $Out)) + (= (write-inline0 ($shift-right $X $Y $Z) $_ $Out) + (set-det) + (write-arith shiftRight $X $Y $Z 8 $Out)) + (= (write-inline0 ($sign $X $Y) $_ $Out) + (set-det) + (write-arith signum $X $Y 8 $Out)) + (= (write-inline0 ($sin $X $Y) $_ $Out) + (set-det) + (write-arith sin $X $Y 8 $Out)) + (= (write-inline0 ($sqrt $X $Y) $_ $Out) + (set-det) + (write-arith sqrt $X $Y 8 $Out)) + (= (write-inline0 ($tan $X $Y) $_ $Out) + (set-det) + (write-arith tan $X $Y 8 $Out)) + (= (write-inline0 ($truncate $X $Y) $_ $Out) + (set-det) + (write-arith truncate $X $Y 8 $Out)) +; +; Arithmetic comparison + (= (write-inline0 ($arith-equal $X $Y) $_ $Out) + (set-det) + (write-arith-compare != $X $Y 8 $Out)) + (= (write-inline0 ($arith-not-equal $X $Y) $_ $Out) + (set-det) + (write-arith-compare == $X $Y 8 $Out)) + (= (write-inline0 ($greater-or-equal $X $Y) $_ $Out) + (set-det) + (write-arith-compare < $X $Y 8 $Out)) + (= (write-inline0 ($greater-than $X $Y) $_ $Out) + (set-det) + (write-arith-compare <= $X $Y 8 $Out)) + (= (write-inline0 ($less-or-equal $X $Y) $_ $Out) + (set-det) + (write-arith-compare > $X $Y 8 $Out)) + (= (write-inline0 ($less-than $X $Y) $_ $Out) + (set-det) + (write-arith-compare >= $X $Y 8 $Out)) + + + (= (write-deref-args Nil $_) + (set-det)) + (= (write-deref-args (Cons (s $_) $Xs) $Out) + (set-det) + (write-deref-args $Xs $Out)) + (= (write-deref-args (Cons (si $_) $Xs) $Out) + (set-det) + (write-deref-args $Xs $Out)) +; ; ??? + (= (write-deref-args (Cons (sf $_) $Xs) $Out) + (set-det) + (write-deref-args $Xs $Out)) +; ; ??? + (= (write-deref-args (Cons $X $Xs) $Out) + (write-java0 + (deref $X $X) $_ $Out) + (write-deref-args $Xs $Out)) + + + (= (write-if-fail $Cond $Args $Tab $Out) + (nonvar $Cond) + (ground $Args) + (set-det) + (= $EXP + (if-then $Cond 'return engine.fail()')) + (write-deref-args $Args $Out) + (write-inline-java $EXP $Tab $Out)) + + + (= (make-arith-arg $E $_) + (var $E) + (set-det) + (fail)) + (= (make-arith-arg $E $E) + (= $E + (si $_)) + (set-det)) + (= (make-arith-arg $E $E) + (= $E + (sf $_)) + (set-det)) +; +; make_arith_arg(E, cast('NumberTerm',E)) :- E = a(_), !. ;??? + (= (make_arith_arg $E (# (Arithmetic.evaluate $E))) True) + + + (= (write-arith $M $E $V $Tab $Out) + (make-arith-arg $E $A1) + (nonvar $V) + (det-if-then-else + (nonvar $M) + (, + (=.. $A0 + (:: $M $A1)) + (= $A + (@ $A0))) + (= $A $A1)) + (= $EXP + (if-then + (op + (set-det) + (unify $V $A)) 'return engine.fail()')) + (write-inline-java $EXP $Tab $Out)) +; ;EXP = try_catch(SENT, 'BuiltinException', ['e.goal = this','throw e']), +; ;write_deref_args([E], Out), + + (= (write-arith $M $E1 $E2 $V $Tab $Out) + (nonvar $M) + (make-arith-arg $E1 $A1) + (make-arith-arg $E2 $A2) + (nonvar $V) + (=.. $A0 + (:: $M $A1 $A2)) + (= $A + (@ $A0)) + (= $EXP + (if-then + (op + (set-det) + (unify $V $A)) 'return engine.fail()')) + (write-inline-java $EXP $Tab $Out)) +; ;EXP = try_catch(SENT, 'BuiltinException', ['e.goal = this','throw e']), +; ;write_deref_args([E1,E2], Out), + + + (= (write-arith-compare $M $E1 $E2 $Tab $Out) + (nonvar $M) + (make-arith-arg $E1 $A1) + (make-arith-arg $E2 $A2) + (=.. $A0 + (:: arithCompareTo $A1 $A2)) + (= $A + (@ $A0)) + (= $EXP + (if-then + (op $M $A 0) 'return engine.fail()')) + (write-inline-java $EXP $Tab $Out)) +; ;EXP = try_catch(SENT, 'BuiltinException', ['e.goal = this','throw e']), +; ;write_deref_args([E1,E2], Out), + + + (= (write-inline-java $X $_ $_) + (var $X) + (set-det) + (fail)) + (= (write-inline-java Nil $_ $_) + (set-det)) + (= (write-inline-java (Cons $X $Xs) $Tab $Out) + (set-det) + (write-inline-java $X $Tab $Out) + (write-inline-java $Xs $Tab $Out)) + (= (write-inline-java (try-catch $TRY $EXCEPT $CATCH) $Tab $Out) + (set-det) + (tab $Out $Tab) + (write $Out 'try {') + (nl $Out) + (is $Tab1 + (+ $Tab 4)) + (write-inline-java $TRY $Tab1 $Out) + (tab $Out $Tab) + (write $Out '} catch (') + (write $Out $EXCEPT) + (write $Out ' e) {') + (nl $Out) + (write-inline-java $CATCH $Tab1 $Out) + (tab $Out $Tab) + (write $Out }) + (nl $Out)) + (= (write-inline-java (if-then $IF $THEN) $Tab $Out) + (set-det) + (tab $Out $Tab) + (write $Out 'if (') + (write-inline-exp $IF 0 $Out) + (write $Out ) {) + (nl $Out) + (is $Tab1 + (+ $Tab 4)) + (write-inline-java $THEN $Tab1 $Out) + (tab $Out $Tab) + (write $Out }) + (nl $Out)) + (= (write-inline-java (if-then-else $IF $THEN $ELSE) $Tab $Out) + (set-det) + (tab $Out $Tab) + (write $Out 'if (') + (write-inline-exp $IF 0 $Out) + (write $Out ) {) + (nl $Out) + (is $Tab1 + (+ $Tab 4)) + (write-inline-java $THEN $Tab1 $Out) + (tab $Out $Tab) + (write $Out '} else {') + (nl $Out) + (write-inline-java $ELSE $Tab1 $Out) + (tab $Out $Tab) + (write $Out }) + (nl $Out)) + (= (write-inline-java $X $Tab $Out) + (tab $Out $Tab) + (write $Out $X) + (write $Out or) + (nl $Out)) + + + (= (write-inline-exp $X $_ $_) + (var $X) + (set-det) + (fail)) + (= (write-inline-exp Nil $_ $_) + (set-det)) + (= (write-inline-exp (:: $X) $Tab $Out) + (set-det) + (write-inline-exp $X $Tab $Out)) + (= (write-inline-exp (Cons $X $Xs) $Tab $Out) + (set-det) + (write-inline-exp $X $Tab $Out) + (write $Out ,) + (write-inline-exp $Xs 0 $Out)) + (= (write-inline-exp (bracket $Exp) $Tab $Out) + (set-det) + (tab $Out $Tab) + (write $Out () + (write-inline-exp $Exp 0 $Out) + (write $Out ))) + (= (write-inline-exp (op $Op $Exp) $Tab $Out) + (set-det) + (tab $Out $Tab) + (write $Out $Op) + (write $Out ' ') + (write-inline-exp $Exp 0 $Out)) + (= (write-inline-exp (op $Op $Exp1 $Exp2) $Tab $Out) + (set-det) + (tab $Out $Tab) + (write-inline-exp $Exp1 0 $Out) + (write $Out ' ') + (write $Out $Op) + (write $Out ' ') + (write-inline-exp $Exp2 0 $Out)) + (= (write-inline-exp (instanceof $Exp $Class) $Tab $Out) + (set-det) + (tab $Out $Tab) + (write $Out () + (write-inline-exp $Exp 0 $Out) + (write $Out ' instanceof ') + (write $Out $Class) + (write $Out ))) + (= (write-inline-exp (cast $Class $Exp) $Tab $Out) + (set-det) + (tab $Out $Tab) + (write $Out (() + (write $Out $Class) + (write $Out ) ) + (write-inline-exp $Exp 0 $Out) + (write $Out ))) + (= (write-inline-exp (unify $X $Y) $Tab $Out) + (set-det) + (tab $Out $Tab) + (write-inline-exp $X 0 $Out) + (write $Out .unify() + (write-inline-exp $Y 0 $Out) + (write $Out ', engine.trail)')) + (= (write-inline-exp (# $X) $Tab $Out) + (set-det) + (=.. $X + (Cons $F $As)) + (tab $Out $Tab) + (write $Out $F) + (write $Out () + (write-inline-exp $As 0 $Out) + (write $Out ))) + (= (write-inline-exp (@ $X) $Tab $Out) + (set-det) + (=.. $X + (Cons $F $As)) + (write-inline-method $F $As $Tab $Out)) + (= (write-inline-exp $X $Tab $Out) + (= $X + (s $_)) + (set-det) + (tab $Out $Tab) + (write-reg $X $Out)) + (= (write-inline-exp $X $Tab $Out) + (= $X + (si $_)) + (set-det) + (tab $Out $Tab) + (write-reg $X $Out)) +; ; ??? + (= (write-inline-exp $X $Tab $Out) + (= $X + (sf $_)) + (set-det) + (tab $Out $Tab) + (write-reg $X $Out)) +; ; ??? + (= (write-inline-exp $X $Tab $Out) + (= $X + (a $_)) + (set-det) + (tab $Out $Tab) + (write-reg $X $Out)) + (= (write-inline-exp $X $Tab $Out) + (== $X void) + (set-det) + (tab $Out $Tab) + (write-reg $X $Out)) +; ; ??? + (= (write-inline-exp $X $Tab $Out) + (tab $Out $Tab) + (write $Out $X)) + + + (= (write-inline-method $F $_ $_ $_) + (var $F) + (set-det) + (fail)) + (= (write-inline-method $_ $A $_ $_) + (var $A) + (set-det) + (fail)) + (= (write-inline-method $F (:: $A) $Tab $Out) + (set-det) + (tab $Out $Tab) + (write-inline-exp $A 0 $Out) + (write $Out .) + (write $Out $F) + (write $Out ())) + (= (write-inline-method $F (:: $A $B) $Tab $Out) + (tab $Out $Tab) + (write-inline-exp $A 0 $Out) + (write $Out .) + (write $Out $F) + (write $Out () + (write-inline-exp $B 0 $Out) + (write $Out ))) + + + + (= (write-insert $X $_ $_) + (var $X) + (set-det) + (fail)) +; /***************************************************************** Write Insert *****************************************************************/ + (= (write-insert Nil $_ $_) + (set-det)) + (= (write-insert (Cons $X $Xs) $_ $Out) + (atom $X) + (write $Out $X) + (nl $Out) + (write-insert $Xs $_ $Out)) + + + (= (write-to-string (/ $F $A) $Out) + (tab $Out 4) + (write $Out @Override) + (nl $Out) + (tab $Out 4) + (write $Out 'public void toString(StringBuilder sb) {') + (nl $Out) + (predicate-encoding $F $F1) + (tab $Out 8) + (write $Out 'sb.append("') + (write $Out $F1) + (det-if-then-else + (> $A 0) + (, + (write $Out (");) + (nl $Out) + (write-enum '' arg 1 $A '.toString(sb); sb.append(", "); ' .toString(sb); 8 $Out) + (nl $Out) + (tab $Out 8) + (write $Out 'sb.append(")");') + (nl $Out)) + (, + (write $Out ");) + (nl $Out))) + (tab $Out 4) + (write $Out }) + (nl $Out)) +; /***************************************************************** Write toString(StringBuilder sb) *****************************************************************/ - (= - (mkdirs $Dir) - ( (file-directory-name $Dir $Parent) - (mkdirs $Parent) - (catch - (make-directory $Dir) $_ - (exists-directory $Dir)))) -; - ; -; + (= (mkdirs $Dir) + (exists-directory $Dir) + (set-det)) +; /***************************************************************** Auxiliaries *****************************************************************/ +; ; Create a directory if missing + (= (mkdirs $Dir) + (file-directory-name $Dir $Parent) + (mkdirs $Parent) + (catch + (make-directory $Dir) $_ + (exists-directory $Dir))) ; +; it is ok if we failed to create a directory, because it is already exist ; -; +; int - - (= - (java-integer $X) - ( (integer $X) - (=< -2147483648 $X) - (=< $X 2147483647))) -; - + (= (java-integer $X) + (integer $X) + (=< -2147483648 $X) + (=< $X 2147483647)) ; -; +; Read Instructions - - (= - (read-instructions 0 $_ Nil) - (set-det)) -; - - (= - (read-instructions $N $In - (Cons $X $Xs)) - ( (> $N 0) - (read $In $X) - (is $N1 - (- $N 1)) - (read-instructions $N1 $In $Xs))) -; - + (= (read-instructions 0 $_ Nil) + (set-det)) + (= (read-instructions $N $In (Cons $X $Xs)) + (> $N 0) + (read $In $X) + (is $N1 + (- $N 1)) + (read-instructions $N1 $In $Xs)) ; -; - +; Write package name - (= - (write-package $P $Out) - ( (set-det) (write $Out $P))) -; - + (= (write-package $P $Out) + (set-det) + (write $Out $P)) ; -; - +; Write class name - (= - (write-class-name $L $Out) - ( (write $Out PRED-) (write-index $L $Out))) -; - + (= (write-class-name $L $Out) + (write $Out PRED-) + (write-index $L $Out)) ; -; - - - (= - (write-predicate-base-class 0 $Out) - ( (set-det) (write $Out Predicate))) -; - - (= - (write-predicate-base-class 1 $Out) - ( (set-det) (write $Out Predicate.P1))) -; - - (= - (write-predicate-base-class 2 $Out) - ( (set-det) (write $Out Predicate.P2))) -; - - (= - (write-predicate-base-class 3 $Out) - ( (set-det) (write $Out Predicate.P3))) -; - - (= - (write-predicate-base-class 4 $Out) - ( (set-det) (write $Out Predicate.P4))) -; - - (= - (write-predicate-base-class $_ $Out) - ( (set-det) (write $Out Predicate.P4))) -; - +; Write out base class name + + (= (write-predicate-base-class 0 $Out) + (set-det) + (write $Out Predicate)) + (= (write-predicate-base-class 1 $Out) + (set-det) + (write $Out Predicate.P1)) + (= (write-predicate-base-class 2 $Out) + (set-det) + (write $Out Predicate.P2)) + (= (write-predicate-base-class 3 $Out) + (set-det) + (write $Out Predicate.P3)) + (= (write-predicate-base-class 4 $Out) + (set-det) + (write $Out Predicate.P4)) + (= (write-predicate-base-class $_ $Out) + (set-det) + (write $Out Predicate.P4)) ; -; - +; Write method reference - (= - (write-method-ref - (/ fail 0) $Out) - ( (set-det) (write-index (/ fail 0) $Out))) -; - - (= - (write-method-ref $R $Out) - ( (get-symbols &self + (= (write-method-ref (/ fail 0) $Out) + (set-det) + (write-index + (/ fail 0) $Out)) + (= (write-method-ref $R $Out) + ( (== (= - (current_arity $A) $_)) - (get-symbols &self + (current_arity $A) $_) + (get-atoms &self)) + (== (= - (current_functor $F) $_)) + (current_functor $F) $_) + (get-atoms &self)) (write-class-name (/ $F $A) $Out) (write $Out ::) - (write-index $R $Out))) -; - + (write-index $R $Out))) ; -; - - - (= - (write-if-method-call $Cond - (/ fail 0) $Out) - ( (set-det) - (tab $Out 12) - (write $Out 'if (') - (write $Out $Cond) - (write $Out ) {) - (nl $Out) - (tab $Out 16) - (write $Out 'return engine.fail();') - (nl $Out) - (tab $Out 12) - (write $Out }) - (nl $Out))) -; - - - (= - (write-if-method-call $Cond $Method $Out) - ( (tab $Out 12) - (write $Out 'if (') - (write $Out $Cond) - (write $Out ) {) - (nl $Out) - (tab $Out 16) - (write $Out 'return ') - (write-index $Method $Out) - (write $Out (engine);) - (nl $Out) - (tab $Out 12) - (write $Out }) - (nl $Out))) -; - +; Write if method call for switch_on_term + + (= (write-if-method-call $Cond (/ fail 0) $Out) + (set-det) + (tab $Out 12) + (write $Out 'if (') + (write $Out $Cond) + (write $Out ) {) + (nl $Out) + (tab $Out 16) + (write $Out 'return engine.fail();') + (nl $Out) + (tab $Out 12) + (write $Out }) + (nl $Out)) + + (= (write-if-method-call $Cond $Method $Out) + (tab $Out 12) + (write $Out 'if (') + (write $Out $Cond) + (write $Out ) {) + (nl $Out) + (tab $Out 16) + (write $Out 'return ') + (write-index $Method $Out) + (write $Out (engine);) + (nl $Out) + (tab $Out 12) + (write $Out }) + (nl $Out)) ; -; - +; Write label - (= - (write-index - (/ $F $A) $Out) - ( (set-det) (write-pred-spec (/ $F $A) $Out))) -; - - (= - (write-index - (+ $L $I) $Out) - ( (write-index $L $Out) - (write $Out -) - (write $Out $I))) -; - + (= (write-index (/ $F $A) $Out) + (set-det) + (write-pred-spec + (/ $F $A) $Out)) + (= (write-index (+ $L $I) $Out) + (write-index $L $Out) + (write $Out -) + (write $Out $I)) ; -; - +; Write constant name - (= - (write-constant $X $Out) - ( (constant-encoding $X $Y) (write $Out $Y))) -; - + (= (write-constant $X $Out) + (constant-encoding $X $Y) + (write $Out $Y)) ; -; - +; Write predicate specification - (= - (write-pred-spec - (/ $F $A) $Out) - ( (predicate-encoding $F $F1) - (write $Out $F1) - (write $Out -) - (write $Out $A))) -; - + (= (write-pred-spec (/ $F $A) $Out) + (predicate-encoding $F $F1) + (write $Out $F1) + (write $Out -) + (write $Out $A)) ; -; +; Package name as directory - - (= - (package-encoding $P $Dir) - ( (atom-codes $P $Chs0) - (package-encoding $Chs0 $Chs Nil) - (atom-codes $Dir $Chs))) -; - + (= (package-encoding $P $Dir) + (atom-codes $P $Chs0) + (package-encoding $Chs0 $Chs Nil) + (atom-codes $Dir $Chs)) - (= - (--> - (package_encoding ()) !) True) -; - - (= - (--> - (package_encoding - (Cons 46 $Xs)) - (, ! - (, - (47) - (package_encoding $Xs)))) True) -; - - (= - (--> - (package_encoding - (Cons $X $Xs)) - (, ! - (, - ($X) - (package_encoding $Xs)))) True) -; - + (= (--> (package_encoding ()) !) True) + (= (--> (package_encoding (Cons 46 $Xs)) (, ! (, (47) (package_encoding $Xs)))) True) + (= (--> (package_encoding (Cons $X $Xs)) (, ! (, ($X) (package_encoding $Xs)))) True) ; -; - - - (= - (predicate-encoding $X $Y) - ( (atom-codes $X $Chs0) - (pred-encoding $Chs0 $Chs Nil) - (atom-codes $Y $Chs))) -; - - - - (= - (--> - (pred_encoding ()) !) True) -; - - (= - (--> - (pred_encoding - (Cons $X $Xs)) - (, - (pred_encoding_char $X) - (pred_encoding $Xs))) True) -; - - - (= - (--> - (pred_encoding_char $X) - (, - { (, - (=< 97 $X) - (=< $X 122)) } - (, ! - ($X)))) True) -; - ; -; - - (= - (--> - (pred_encoding_char $X) - (, - { (, - (=< 65 $X) - (=< $X 90)) } - (, ! - ($X)))) True) -; - ; -; - - (= - (--> - (pred_encoding_char $X) - (, - { (, - (=< 48 $X) - (=< $X 57)) } - (, ! - ($X)))) True) -; - ; -; - - (= - (--> - (pred_encoding_char 95) - (, ! - (95))) True) -; - ; -; - - (= - (--> - (pred_encoding_char 36) - (, ! - (36))) True) -; - ; -; - - (= - (--> - (pred_encoding_char $X) - (, - { (, - (=< 0 $X) - (=< $X 65535)) } - (, ! - (, - (36) - (pred_encoding_hex $X))))) True) -; - - (= - (--> - (pred_encoding_char $X) - { (, - (am2cpp_error - ($X is an invalid character code)) fail) }) True) -; - - - (= - (--> - (pred_encoding_hex $X) - (, - { (int_to_hex $X () $H) } - (pred_encoding_hex_char $H))) True) -; - - - (= - (--> - (pred_encoding_hex_char ()) - (, ! - (48 48 48 48))) True) -; - ; -; - - (= - (--> - (pred_encoding_hex_char - ($X)) - (, ! - (48 48 48 $X))) True) -; - ; -; - - (= - (--> - (pred_encoding_hex_char - ($X $Y)) - (, ! - (48 48 $X $Y))) True) -; - ; -; - - (= - (--> - (pred_encoding_hex_char - ($X $Y $Z)) - (, ! - (48 $X $Y $Z))) True) -; - ; -; - - (= - (--> - (pred_encoding_hex_char - ($X $Y $Z $W)) - (, ! - ($X $Y $Z $W))) True) -; - ; -; - - - - (= - (int-to-hex 0 $H $H) - (set-det)) -; - - (= - (int-to-hex $D $H0 $H) - ( (is $R - (mod $D 16)) - (is $D1 - (// $D 16)) - (hex-map $R $R1) - (int-to-hex $D1 - (Cons $R1 $H0) $H))) -; - - - - (= - (hex-map 10 65) - (set-det)) -; - ; -; - - (= - (hex-map 11 66) - (set-det)) -; - ; -; - - (= - (hex-map 12 67) - (set-det)) -; - ; -; - - (= - (hex-map 13 68) - (set-det)) -; - ; -; - - (= - (hex-map 14 69) - (set-det)) -; - ; -; - - (= - (hex-map 15 70) - (set-det)) -; - ; -; - - (= - (hex-map $X $Y) - ( (=< 0 $X) - (=< $X 9) - (number-codes $X - (:: $Y)))) -; - +; Predicate Encoding + + (= (predicate-encoding $X $Y) + (atom-codes $X $Chs0) + (pred-encoding $Chs0 $Chs Nil) + (atom-codes $Y $Chs)) + + + (= (--> (pred_encoding ()) !) True) + (= (--> (pred_encoding (Cons $X $Xs)) (, (pred_encoding_char $X) (pred_encoding $Xs))) True) + + (= (--> (pred_encoding_char $X) (, {(, (=< 97 $X) (=< $X 122)) } (, ! ($X)))) True) ; +; a..z + (= (--> (pred_encoding_char $X) (, {(, (=< 65 $X) (=< $X 90)) } (, ! ($X)))) True) ; +; A..Z + (= (--> (pred_encoding_char $X) (, {(, (=< 48 $X) (=< $X 57)) } (, ! ($X)))) True) ; +; 0..9 + (= (--> (pred_encoding_char 95) (, ! (95))) True) ; +; '_' + (= (--> (pred_encoding_char 36) (, ! (36))) True) ; +; '$' ??? + (= (--> (pred_encoding_char $X) (, {(, (=< 0 $X) (=< $X 65535)) } (, ! (, (36) (pred_encoding_hex $X))))) True) +; ; '$' + (= (--> (pred_encoding_char $X) {(, (am2cpp_error ($X is an invalid character code)) fail) }) True) + + (= (--> (pred_encoding_hex $X) (, {(int_to_hex $X () $H) } (pred_encoding_hex_char $H))) True) + + (= (--> (pred_encoding_hex_char ()) (, ! (48 48 48 48))) True) ; +; 0000 + (= (--> (pred_encoding_hex_char ($X)) (, ! (48 48 48 $X))) True) ; +; 000X + (= (--> (pred_encoding_hex_char ($X $Y)) (, ! (48 48 $X $Y))) True) ; +; 00XY + (= (--> (pred_encoding_hex_char ($X $Y $Z)) (, ! (48 $X $Y $Z))) True) ; +; 0XYZ + (= (--> (pred_encoding_hex_char ($X $Y $Z $W)) (, ! ($X $Y $Z $W))) True) ; +; XYZW + + + (= (int-to-hex 0 $H $H) + (set-det)) + (= (int-to-hex $D $H0 $H) + (is $R + (mod $D 16)) + (is $D1 + (// $D 16)) + (hex-map $R $R1) + (int-to-hex $D1 + (Cons $R1 $H0) $H)) + + + (= (hex-map 10 65) + (set-det)) ; +; 'A' + (= (hex-map 11 66) + (set-det)) ; +; 'B' + (= (hex-map 12 67) + (set-det)) ; +; 'C' + (= (hex-map 13 68) + (set-det)) ; +; 'D' + (= (hex-map 14 69) + (set-det)) ; +; 'E' + (= (hex-map 15 70) + (set-det)) ; +; 'F' + (= (hex-map $X $Y) + (=< 0 $X) + (=< $X 9) + (number-codes $X + (:: $Y))) ; -; - - - (= - (constant-encoding $X $Y) - ( (atom-codes $X $Chs0) - (con-encoding $Chs0 $Chs) - (atom-codes $Y $Chs))) -; - - - - (= - (con-encoding Nil Nil) - (set-det)) -; - - (= - (con-encoding - (Cons 7 $Xs) - (Cons 92 - (Cons 97 $Ys))) - ( (set-det) (con-encoding $Xs $Ys))) -; - ; -; - - (= - (con-encoding - (Cons 8 $Xs) - (Cons 92 - (Cons 98 $Ys))) - ( (set-det) (con-encoding $Xs $Ys))) -; - ; -; - - (= - (con-encoding - (Cons 9 $Xs) - (Cons 92 - (Cons 116 $Ys))) - ( (set-det) (con-encoding $Xs $Ys))) -; - ; -; - - (= - (con-encoding - (Cons 10 $Xs) - (Cons 92 - (Cons 110 $Ys))) - ( (set-det) (con-encoding $Xs $Ys))) -; - ; -; - - (= - (con-encoding - (Cons 11 $Xs) - (Cons 92 - (Cons 118 $Ys))) - ( (set-det) (con-encoding $Xs $Ys))) -; - ; -; - - (= - (con-encoding - (Cons 12 $Xs) - (Cons 92 - (Cons 102 $Ys))) - ( (set-det) (con-encoding $Xs $Ys))) -; - ; -; - - (= - (con-encoding - (Cons 13 $Xs) - (Cons 92 - (Cons 114 $Ys))) - ( (set-det) (con-encoding $Xs $Ys))) -; - ; -; - - (= - (con-encoding - (Cons 34 $Xs) - (Cons 92 - (Cons 34 $Ys))) - ( (set-det) (con-encoding $Xs $Ys))) -; - ; -; - - (= - (con-encoding - (Cons 39 $Xs) - (Cons 92 - (Cons 39 $Ys))) - ( (set-det) (con-encoding $Xs $Ys))) -; - ; -; - - (= - (con-encoding - (Cons 92 $Xs) - (Cons 92 - (Cons 92 $Ys))) - ( (set-det) (con-encoding $Xs $Ys))) -; - ; -; - - (= - (con-encoding - (Cons $X $Xs) - (Cons $X $Ys)) - (con-encoding $Xs $Ys)) -; - +; Constant Encoding (especially, escape sequence) + + (= (constant-encoding $X $Y) + (atom-codes $X $Chs0) + (con-encoding $Chs0 $Chs) + (atom-codes $Y $Chs)) +; ;??? + + + (= (con-encoding Nil Nil) + (set-det)) + (= (con-encoding (Cons 7 $Xs) (Cons 92 (Cons 97 $Ys))) + (set-det) + (con-encoding $Xs $Ys)) ; +; \a + (= (con-encoding (Cons 8 $Xs) (Cons 92 (Cons 98 $Ys))) + (set-det) + (con-encoding $Xs $Ys)) ; +; \b + (= (con-encoding (Cons 9 $Xs) (Cons 92 (Cons 116 $Ys))) + (set-det) + (con-encoding $Xs $Ys)) ; +; \t + (= (con-encoding (Cons 10 $Xs) (Cons 92 (Cons 110 $Ys))) + (set-det) + (con-encoding $Xs $Ys)) ; +; \n + (= (con-encoding (Cons 11 $Xs) (Cons 92 (Cons 118 $Ys))) + (set-det) + (con-encoding $Xs $Ys)) ; +; \v + (= (con-encoding (Cons 12 $Xs) (Cons 92 (Cons 102 $Ys))) + (set-det) + (con-encoding $Xs $Ys)) ; +; \f + (= (con-encoding (Cons 13 $Xs) (Cons 92 (Cons 114 $Ys))) + (set-det) + (con-encoding $Xs $Ys)) ; +; \r + (= (con-encoding (Cons 34 $Xs) (Cons 92 (Cons 34 $Ys))) + (set-det) + (con-encoding $Xs $Ys)) ; +; \" + (= (con-encoding (Cons 39 $Xs) (Cons 92 (Cons 39 $Ys))) + (set-det) + (con-encoding $Xs $Ys)) ; +; \' + (= (con-encoding (Cons 92 $Xs) (Cons 92 (Cons 92 $Ys))) + (set-det) + (con-encoding $Xs $Ys)) ; +; \\ + (= (con-encoding (Cons $X $Xs) (Cons $X $Ys)) + (con-encoding $Xs $Ys)) ; -; - - - (= - (write-reg $X $_) - ( (var $X) - (set-det) - (am2cpp-error (:: register expression must not be unbound variable)) - (fail))) -; - - (= - (write-reg void $Out) - ( (set-det) (write $Out 'new Var(engine)'))) -; - - (= - (write-reg - (ea $X) $Out) - ( (set-det) - (write $Out engine.Areg[) - (is $Y - (- $X 1)) - (write $Out $Y) - (write $Out ]))) -; - - (= - (write-reg econt $Out) - ( (set-det) (write $Out engine.cont))) -; - - (= - (write-reg - (arg $X) $Out) - ( (set-det) - (write $Out arg) - (write $Out $X))) -; - - (= - (write-reg - (a $X) $Out) - ( (set-det) - (write $Out a) - (write $Out $X))) -; - - (= - (write-reg - (s $X) $Out) - ( (get-symbols &self +; Write Register name + + (= (write-reg $X $_) + (var $X) + (set-det) + (am2cpp-error (:: register expression must not be unbound variable)) + (fail)) + (= (write-reg void $Out) + (set-det) + (write $Out 'new Var(engine)')) + (= (write-reg (ea $X) $Out) + (set-det) + (write $Out engine.Areg[) + (is $Y + (- $X 1)) + (write $Out $Y) + (write $Out ])) +; /* write_reg(ea(1), Out) :- !, write(Out, 'engine.areg1'). write_reg(ea(2), Out) :- !, write(Out, 'engine.areg2'). write_reg(ea(3), Out) :- !, write(Out, 'engine.areg3'). write_reg(ea(4), Out) :- !, write(Out, 'engine.areg4'). write_reg(ea(5), Out) :- !, write(Out, 'engine.areg5'). write_reg(ea(6), Out) :- !, write(Out, 'engine.areg6'). write_reg(ea(7), Out) :- !, write(Out, 'engine.areg7'). write_reg(ea(8), Out) :- !, write(Out, 'engine.areg8'). */ + (= (write-reg econt $Out) + (set-det) + (write $Out engine.cont)) + (= (write-reg (arg $X) $Out) + (set-det) + (write $Out arg) + (write $Out $X)) + (= (write-reg (a $X) $Out) + (set-det) + (write $Out a) + (write $Out $X)) + (= (write-reg (s $X) $Out) + ( (== (= (inlined (s $X) - (/ $F $A)) $_)) + (/ $F $A)) $_) + (get-atoms &self)) (set-det) (write $Out ") (write-constant $F $Out) - (write $Out "))) -; - - (= - (write-reg - (s $X) $Out) - ( (get-symbols &self + (write $Out "))) + (= (write-reg (s $X) $Out) + ( (== (= (inlined (s $X) - (str_args $Xs)) $_)) + (str_args $Xs)) $_) + (get-atoms &self)) (set-det) - (write-reg-args $Xs $Out))) -; - - (= - (write-reg - (s $X) $Out) - ( (set-det) - (write $Out s) - (write $Out $X))) -; - - (= - (write-reg - (si $X) $Out) - ( (set-det) - (write $Out si) - (write $Out $X))) -; - ; -; - - (= - (write-reg - (sf $X) $Out) - ( (set-det) - (write $Out sf) - (write $Out $X))) -; - ; -; - - (= - (write-reg - (y $X) $Out) - ( (set-det) - (write $Out y) - (write $Out $X))) -; - - (= - (write-reg - (p $X) $Out) - ( (set-det) - (write $Out p) - (write $Out $X))) -; - - (= - (write-reg cont $Out) - ( (set-det) (write $Out cont))) -; - - (= - (write-reg null $Out) - ( (set-det) (write $Out null))) -; - + (write-reg-args $Xs $Out))) + (= (write-reg (s $X) $Out) + (set-det) + (write $Out s) + (write $Out $X)) + (= (write-reg (si $X) $Out) + (set-det) + (write $Out si) + (write $Out $X)) ; +; ??? + (= (write-reg (sf $X) $Out) + (set-det) + (write $Out sf) + (write $Out $X)) ; +; ??? + (= (write-reg (y $X) $Out) + (set-det) + (write $Out y) + (write $Out $X)) + (= (write-reg (p $X) $Out) + (set-det) + (write $Out p) + (write $Out $X)) + (= (write-reg cont $Out) + (set-det) + (write $Out cont)) + (= (write-reg null $Out) + (set-det) + (write $Out null)) ; -; - - (= - (write-reg - (args $X) $Out) - ( (set-det) - (write $Out args[) - (write $Out $X) - (write $Out ]))) -; - - (= - (write-reg $X $_) - ( (am2cpp-error (:: $X is an invalid register expression)) (fail))) -; - - - - (= - (write-reg-args Nil $_) - (set-det)) -; - - (= - (write-reg-args - (:: $X) $Out) - ( (set-det) (write-reg $X $Out))) -; - - (= - (write-reg-args - (Cons $X $Xs) $Out) - ( (write-reg $X $Out) - (write $Out , ) - (write-reg-args $Xs $Out))) -; - - - - (= - (for $M $M $N) +; am2cpp only + (= (write-reg (args $X) $Out) + (set-det) + (write $Out args[) + (write $Out $X) + (write $Out ])) + (= (write-reg $X $_) + (am2cpp-error (:: $X is an invalid register expression)) + (fail)) + + + (= (write-reg-args Nil $_) + (set-det)) + (= (write-reg-args (:: $X) $Out) + (set-det) + (write-reg $X $Out)) + (= (write-reg-args (Cons $X $Xs) $Out) + (write-reg $X $Out) + (write $Out , ) + (write-reg-args $Xs $Out)) + + + (= (for $M $M $N) (=< $M $N)) -; - - (= - (for $I $M $N) - ( (=< $M $N) - (is $M1 - (+ $M 1)) - (for $I $M1 $N))) -; - +; /***************************************************************** WAM-BASED INTERMEDIATE INSTRUCTIONS Put Instructions ================ + put_var(X) + put_int(i, X) + put_float(f, X) + put_con(f/n, X) + put_con(c, X), + put_list(Xi, Xj, Xk) + put_str(Xi, Y, Xj) + put_str_args([Xi,..,Xn], Y) + put_clo(p:G, X) Get Instructions ================ + get_val(Xi, Xj) + get_int(i, Xi, Xj) + get_float(f, Xi, Xj) + get_con(c, Xi, Xj) + get_ground(g, Xi, Xj) + get_list(X) + get_str(f/n, Xi, Xj) Unify Instructions ================== + unify_var(X) + unify_val(X) + unify_int(i, X) + unify_float(f, X) + unify_con(c, X) + unify_ground(g, X) + unify_void(i) Choice Instructions =================== + try(Li, Lj) + retry(Li, Lj) + trust(L) Indexing Instructions ===================== + switch_on_term(Lv, Li, Lf, Lc, Ls, Ll) + switch_on_hash(TAG, i, L, hashtable) Other Instructions ================== + comment(Message) + debug(Message) + begin_predicate(p, f/n) + end_predicate(p, f/n) + import_package(p) + import_package(p, f/n) + main(f/n, public): [Instructions] + main(f/n, non-public): [Instructions] + L: [Instructions] + label(L) + setB0 + goto(L) + deref(Ri, Rj) + set(Ri, Rj) + decl_term_vars([R1,...,Rn]) + decl_pred_vars([R1,...,Rn]) + put_cont(p:BinG, C) + put_cont(BinG, C) + execute(p:BinG) + execute(BinG) + inline(G) + new_hash(TAG, i) + put_hash(X, L, TAG) + static([Instructions]) Notation ******** X ::= a(i) | S Y ::= y(i) | S S ::= s(i) | si(i) | sf(i) L ::= f/n | f/n+i | f/n+TAG | f/n+TAG+i | f/n+TAG+i+i TAG ::= var | int | flo | con | str | lis | top | sub | nil BinG ::= C | f(A1,..,An, C) G ::= f(A1,..,An) A ::= void | X C ::= cont | p(N) R ::= cont | econt | a(i) | arg(i) | ea(i) *****************************************************************/ +; /***************************************************************** Utilities *****************************************************************/ + (= (for $I $M $N) + (=< $M $N) + (is $M1 + (+ $M 1)) + (for $I $M1 $N)) ; -; - +; ;; print - (= - (am2cpp-error $M) + (= (am2cpp-error $M) (am2cpp-message user-error (Cons *** (Cons AM2JAVA - (Cons ERROR $M))))) -; - + (Cons ERROR $M))))) - (= - (am2cpp-message $M) - (am2cpp-message user-output $M)) -; - - - (= - (am2cpp-message $Stream Nil) - ( (nl $Stream) (flush-output $Stream))) -; - - (= - (am2cpp-message (Cons $M $Ms)) - ( (write $Stream $M) - (write $Stream ' ') - (am2cpp-message $Stream $Ms))) -; + (= (am2cpp-message $M) + (am2cpp-message user-output $M)) + (= (am2cpp-message $Stream Nil) + (nl $Stream) + (flush-output $Stream)) + (= (am2cpp-message (Cons $M $Ms)) + (write $Stream $M) + (write $Stream ' ') + (am2cpp-message $Stream $Ms)) ; -; +; ;; list - - (= - (am2cpp_append () $Zs $Zs) True) -; - - (= - (am2cpp-append - (Cons $X $Xs) $Ys - (Cons $X $Zs)) - (am2cpp-append $Xs $Ys $Zs)) -; - + (= (am2cpp_append () $Zs $Zs) True) + (= (am2cpp-append (Cons $X $Xs) $Ys (Cons $X $Zs)) + (am2cpp-append $Xs $Ys $Zs)) - (= - (--> - (flatten_list ()) !) True) -; - - (= - (--> - (flatten_list - (Cons $L1 $L2)) - (, ! - (, - (flatten_list $L1) - (flatten_list $L2)))) True) -; - - (= - (--> - (flatten_list $L) - ($L)) True) -; - + (= (--> (flatten_list ()) !) True) + (= (--> (flatten_list (Cons $L1 $L2)) (, ! (, (flatten_list $L1) (flatten_list $L2)))) True) + (= (--> (flatten_list $L) ($L)) True) - (= - (list-to-string $List $String) - ( (list-to-chars $List $Chars0) - (flatten-list $Chars0 $Chars Nil) - (atom-codes $String $Chars))) -; - + (= (list-to-string $List $String) + (list-to-chars $List $Chars0) + (flatten-list $Chars0 $Chars Nil) + (atom-codes $String $Chars)) - (= - (list-to-chars Nil Nil) - (set-det)) -; - - (= - (list-to-chars - (Cons $L $Ls) - (Cons $C $Cs)) - ( (atom $L) - (set-det) - (atom-codes $L $C) - (list-to-chars $Ls $Cs))) -; - - (= - (list-to-chars - (Cons $L $Ls) - (Cons $C $Cs)) - ( (number $L) - (set-det) - (number-codes $L $C) - (list-to-chars $Ls $Cs))) -; - + (= (list-to-chars Nil Nil) + (set-det)) + (= (list-to-chars (Cons $L $Ls) (Cons $C $Cs)) + (atom $L) + (set-det) + (atom-codes $L $C) + (list-to-chars $Ls $Cs)) + (= (list-to-chars (Cons $L $Ls) (Cons $C $Cs)) + (number $L) + (set-det) + (number-codes $L $C) + (list-to-chars $Ls $Cs)) ; -; - +; END ; -; - +; written by SICStus MeTTa 3.12.8 diff --git a/sxx_machine/sxx_read.metta b/sxx_machine/sxx_read.metta index ca2884a..954d8af 100644 --- a/sxx_machine/sxx_read.metta +++ b/sxx_machine/sxx_read.metta @@ -1,434 +1,215 @@ +; (convert_to_metta_file sxx_read $_28460 sxx_machine/sxx_read.pl sxx_machine/sxx_read.metta) ; -; +; read/1: from screen - no error recovery - only simple syntax + (= (vread $Term $Vars) + (nexttoken $Tok) + (readall $Tok $Tokens) + (maketerm $Tokens $Term) + (set-det) + (collectvars $Tokens Nil $Vars)) - (= - (vread $Term $Vars) - ( (nexttoken $Tok) - (readall $Tok $Tokens) - (maketerm $Tokens $Term) - (set-det) - (collectvars $Tokens Nil $Vars))) -; - - - - (= - (read $Term) - ( (nexttoken $Tok) - (readall $Tok $Tokens) - (maketerm $Tokens $Term) - (set-det))) -; + (= (read $Term) + (nexttoken $Tok) + (readall $Tok $Tokens) + (maketerm $Tokens $Term) + (set-det)) - (= - (collectvars Nil $In $In) + (= (collectvars Nil $In $In) (set-det)) -; - - (= - (collectvars + (= (collectvars (Cons (var $Var $Name $Occ) $R) $In $Out) + (noteq $Name -) + (notvmember $Name $In) + (set-det) + (collectvars $R (Cons - (var $Var $Name $Occ) $R) $In $Out) - ( (noteq $Name -) - (notvmember $Name $In) - (set-det) - (collectvars $R - (Cons - (= $Var $Name) $In) $Out))) -; - - (= - (collectvars - (Cons $_ $R) $In $Out) + (= $Var $Name) $In) $Out)) + (= (collectvars (Cons $_ $R) $In $Out) (collectvars $R $In $Out)) -; - - (= - (notvmember $_ Nil) + (= (notvmember $_ Nil) (set-det)) -; - - (= - (notvmember $Name - (Cons - (= $_ $Name) $_)) - ( (set-det) (fail))) -; - - (= - (notvmember $Name - (Cons $_ $R)) + (= (notvmember $Name (Cons (= $_ $Name) $_)) + (set-det) + (fail)) + (= (notvmember $Name (Cons $_ $R)) (notvmember $Name $R)) -; - - - - (= - (readall end-of-file $Tail) - ( (set-det) (halt))) -; - - (= - (readall end-of-clause $Tail) - ( (set-det) (= $Tail Nil))) -; - - (= - (readall $Token - (Cons $Token $Tail)) - ( (nexttoken $NewToken) (readall $NewToken $Tail))) -; - - - - - (= - (infix 1200 xfx :-) True) -; - - (= - (infix 1000 xfy ,) True) -; - - (= - (infix 1100 xfy ;) True) -; - - (= - (infix 1050 xfy ->) True) -; - - (= - (infix 700 xfx =) True) -; - - (= - (infix 700 xfx is) True) -; - - (= - (infix 700 xfx =..) True) -; - - (= - (infix 700 xfx ==) True) -; - - (= - (infix 700 xfx @<) True) -; - - (= - (infix 700 xfx @>) True) -; - - (= - (infix 700 xfx @=<) True) -; - - (= - (infix 700 xfx @>=) True) -; - - (= - (infix 700 xfx =:=) True) -; - - (= - (infix 700 xfx <) True) -; - - (= - (infix 700 xfx =<) True) -; - - (= - (infix 700 xfx >) True) -; - - (= - (infix 700 xfx >=) True) -; - - (= - (infix 550 xfy :) True) -; - - (= - (infix 500 yfx +) True) -; - (= - (infix 500 yfx -) True) -; - - (= - (infix 500 yfx #) True) -; - - (= - (infix 400 yfx *) True) -; - - (= - (infix 400 yfx /) True) -; - - (= - (infix 400 yfx //) True) -; - - (= - (infix 400 yfx <<) True) -; - - (= - (infix 400 yfx >>) True) -; - - (= - (infix 300 xfx mod) True) -; - - (= - (infix 200 xfy ^) True) -; - - - - (= - (prefix 1200 fx :-) True) -; - - (= - (prefix 1200 fx ?-) True) -; - - (= - (prefix 500 fx +) True) -; - - (= - (prefix 500 fx -) True) -; + (= (readall end-of-file $Tail) + (set-det) + (halt)) + (= (readall end-of-clause $Tail) + (set-det) + (= $Tail Nil)) + (= (readall $Token (Cons $Token $Tail)) + (nexttoken $NewToken) + (readall $NewToken $Tail)) + + + + (= (infix 1200 xfx :-) True) + (= (infix 1000 xfy ,) True) + (= (infix 1100 xfy ;) True) + (= (infix 1050 xfy ->) True) + (= (infix 700 xfx =) True) + (= (infix 700 xfx is) True) + (= (infix 700 xfx =..) True) + (= (infix 700 xfx ==) True) + (= (infix 700 xfx @<) True) + (= (infix 700 xfx @>) True) + (= (infix 700 xfx @=<) True) + (= (infix 700 xfx @>=) True) + (= (infix 700 xfx =:=) True) + (= (infix 700 xfx <) True) + (= (infix 700 xfx =<) True) + (= (infix 700 xfx >) True) + (= (infix 700 xfx >=) True) + (= (infix 550 xfy :) True) + (= (infix 500 yfx +) True) + (= (infix 500 yfx -) True) + (= (infix 500 yfx #) True) + (= (infix 400 yfx *) True) + (= (infix 400 yfx /) True) + (= (infix 400 yfx //) True) + (= (infix 400 yfx <<) True) + (= (infix 400 yfx >>) True) + (= (infix 300 xfx mod) True) + (= (infix 200 xfy ^) True) + + + (= (prefix 1200 fx :-) True) + (= (prefix 1200 fx ?-) True) + (= (prefix 500 fx +) True) + (= (prefix 500 fx -) True) ; -; - +; maketerm(In,Term) ; -; - +; consists of tokens already - (= - (maketerm - (:: (var $Var $Name $Occ)) $Out $_) - ( (= $Out $Var) (set-det))) -; - - - (= - (maketerm - (:: (int $Term)) $Out $_) - ( (set-det) (= $Out $Term))) -; - - - (= - (maketerm - (:: (real $Term)) $Out $_) - ( (set-det) (= $Out $Term))) -; + (= (maketerm (:: (var $Var $Name $Occ)) $Out $_) + (= $Out $Var) + (set-det)) + (= (maketerm (:: (int $Term)) $Out $_) + (set-det) + (= $Out $Term)) - (= - (maketerm - (:: (const $Term)) $Out $_) - ( (set-det) (= $Out $Term))) -; + (= (maketerm (:: (real $Term)) $Out $_) + (set-det) + (= $Out $Term)) + (= (maketerm (:: (const $Term)) $Out $_) + (set-det) + (= $Out $Term)) - (= - (maketerm - (:: (string $Term)) $Out $_) - ( (set-det) (= $Out $Term))) -; + (= (maketerm (:: (string $Term)) $Out $_) + (set-det) + (= $Out $Term)) + (= (maketerm (Cons (const $Name) (Cons (const () $Argswithcomma)) $Out $_) + (getargs $Argswithcomma $Args) + (univ $Out $Name $Args)) - (= - (maketerm + (= (maketerm $In $Term $Prec) + (ap $In1 (Cons - (const $Name) - (Cons - (const () $Argswithcomma)) $Out $_) - ( (getargs $Argswithcomma $Args) (univ $Out $Name $Args))) -; - - - (= - (maketerm $In $Term $Prec) - ( (ap $In1 - (Cons - (const $Op) $In2) $In) - (infix $P $Type $Op) - (=< $P $Prec) - (newprec $Type $P $P1 $P2) - (maketerm $In1 $T1 $P1) - (maketerm $In2 $T2 $P2) - (univ $Term $Op - (:: $T1 $T2)))) -; - - (= - (maketerm - (Cons - (const $Op) $In) $Term $Prec) - ( (prefix $P $Type $Op) - (=< $P $Prec) - (newprec $Type $P $P1) - (maketerm $In $T1 $P1) - (univ $Term $Op - (:: $T1)))) -; - - (= - (maketerm + (const $Op) $In2) $In) + (infix $P $Type $Op) + (=< $P $Prec) + (newprec $Type $P $P1 $P2) + (maketerm $In1 $T1 $P1) + (maketerm $In2 $T2 $P2) + (univ $Term $Op + (:: $T1 $T2))) + (= (maketerm (Cons (const $Op) $In) $Term $Prec) + (prefix $P $Type $Op) + (=< $P $Prec) + (newprec $Type $P $P1) + (maketerm $In $T1 $P1) + (univ $Term $Op + (:: $T1))) + (= (maketerm (Cons (const [) $L) (Cons $El $Tail) $_) + (ap $ElList (Cons - (const [) $L) - (Cons $El $Tail) $_) - ( (ap $ElList - (Cons - (const ,) $Rest) $L) - (maketerm $ElList $El 900) - (maketerm - (Cons - (const [) $Rest) $Tail 900))) -; - - (= + (const ,) $Rest) $L) + (maketerm $ElList $El 900) (maketerm (Cons - (const [) $L) - (Cons $El $Tail) $_) - ( (ap $ElList - (Cons - (const |) $Rest) $L) - (ap $TailL - (:: (const ])) $Rest) - (maketerm $ElList $El 900) - (maketerm $TailL $Tail 900))) -; - - - (= - (maketerm + (const [) $Rest) $Tail 900)) + (= (maketerm (Cons (const [) $L) (Cons $El $Tail) $_) + (ap $ElList (Cons - (const () $L) $Term $_) - ( (ap $L1 - (:: (const ))) $L) - (set-det) - (maketerm $L1 $Term))) -; - - (= - (maketerm + (const |) $Rest) $L) + (ap $TailL + (:: (const ])) $Rest) + (maketerm $ElList $El 900) + (maketerm $TailL $Tail 900)) + + (= (maketerm (Cons (const () $L) $Term $_) + (ap $L1 + (:: (const ))) $L) + (set-det) + (maketerm $L1 $Term)) + (= (maketerm (Cons (const [) $R) (:: $T2) $_) + (ap $L + (:: (const ])) $R) + (maketerm $L $T2 900)) + (= (maketerm ((const [) (const ])) () $_) True) + + + (= (newprec xfx $P $P1 $P2) + (set-det) + (is $P1 + (- $P 1)) + (is $P2 + (- $P 1))) + (= (newprec xfy $P $P1 $P2) + (set-det) + (is $P1 + (- $P 1)) + (= $P2 $P)) + (= (newprec yfx $P $P1 $P2) + (set-det) + (is $P2 + (- $P 1)) + (= $P1 $P)) + + (= (newprec fx $P $P1) + (set-det) + (is $P1 + (- $P 1))) + (= (newprec fy $P $P) True) + + + (= (getargs $In $Out) + (ap $I + (:: (const ))) $In) + (maketerm $I $T 900) + (= $Out + (:: $T))) + (= (getargs $In $Out) + (ap $I (Cons - (const [) $R) - (:: $T2) $_) - ( (ap $L - (:: (const ])) $R) (maketerm $L $T2 900))) -; - - (= - (maketerm - ( (const [) (const ])) () $_) True) -; - - - - (= - (newprec xfx $P $P1 $P2) - ( (set-det) - (is $P1 - (- $P 1)) - (is $P2 - (- $P 1)))) -; - - (= - (newprec xfy $P $P1 $P2) - ( (set-det) - (is $P1 - (- $P 1)) - (= $P2 $P))) -; - - (= - (newprec yfx $P $P1 $P2) - ( (set-det) - (is $P2 - (- $P 1)) - (= $P1 $P))) -; - - - (= - (newprec fx $P $P1) - ( (set-det) (is $P1 (- $P 1)))) -; - - (= - (newprec fy $P $P) True) -; - - - - (= - (getargs $In $Out) - ( (ap $I - (:: (const ))) $In) - (maketerm $I $T 900) - (= $Out - (:: $T)))) -; - - (= - (getargs $In $Out) - ( (ap $I - (Cons - (const ,) $RI) $In) - (maketerm $I $T 900) - (= $Out - (Cons $T $RT)) - (getargs $RI $RT))) -; - - - - (= - (maketerm $X $Y) - (maketerm $X $Y 1200)) -; + (const ,) $RI) $In) + (maketerm $I $T 900) + (= $Out + (Cons $T $RT)) + (getargs $RI $RT)) + (= (maketerm $X $Y) + (maketerm $X $Y 1200)) - (= - (ap () $L $L) True) -; - (= - (ap - (Cons $X $L1) $L2 - (Cons $X $L3)) + (= (ap () $L $L) True) + (= (ap (Cons $X $L1) $L2 (Cons $X $L3)) (ap $L1 $L2 $L3)) -; - diff --git a/sxx_machine/sxx_system.metta b/sxx_machine/sxx_system.metta index 39b4899..ed15478 100644 --- a/sxx_machine/sxx_system.metta +++ b/sxx_machine/sxx_system.metta @@ -1,1280 +1,302 @@ +; (convert_to_metta_file sxx_system $_177950 sxx_machine/sxx_system.pl sxx_machine/sxx_system.metta) - !(op 1150 fx package) -; - + !(op 1150 fx package) - (= - (package $X) - (nb-setval package $X)) -; - + (= (package $X) + (nb-setval package $X)) - !(package com.googlecode.prolog-cafe.builtin) -; - - !(public (/ system-predicate 1)) -; - - !(multifile (/ system-predicate 1)) -; - - !(dynamic (/ system-predicate 1)) -; - + !(package com.googlecode.prolog-cafe.builtin) + !(public (/ system-predicate 1)) + !(multifile (/ system-predicate 1)) + !(dynamic (/ system-predicate 1)) - (= - (system_predicate - (system_predicate $_)) True) -; - + (= (system_predicate (system_predicate $_)) True) ; -; - - (= - (system_predicate true) True) -; - - (= - (system_predicate therwise) True) -; - - (= - (system_predicate fail) True) -; - - (= - (system_predicate false) True) -; - - (= - (system_predicate !) True) -; - - (= - (system_predicate - (%get_level $_)) True) -; - - (= - (system_predicate $neck_cut) True) -; - - (= - (system_predicate - ($cut $_)) True) -; - - (= - (system_predicate - (^ $_ $_)) True) -; - - (= - (system_predicate - (, $_ $_)) True) -; - - (= - (system_predicate - (; $_ $_)) True) -; - - (= - (system_predicate - (-> $_ $_)) True) -; - - (= - (system_predicate - (call $_)) True) -; - - (= - (system_predicate - (catch $_ $_ $_)) True) -; - - (= - (system_predicate - (throw $_)) True) -; - - (= - (system_predicate - (on_exception $_ $_ $_)) True) -; - - (= - (system_predicate - (raise_exception $_)) True) -; - +; Control constructs + (= (system_predicate true) True) + (= (system_predicate therwise) True) + (= (system_predicate fail) True) + (= (system_predicate false) True) + (= (system_predicate !) True) + (= (system_predicate (%get_level $_)) True) + (= (system_predicate $neck_cut) True) + (= (system_predicate (%cut $_)) True) + (= (system_predicate (^ $_ $_)) True) + (= (system_predicate (, $_ $_)) True) + (= (system_predicate (; $_ $_)) True) + (= (system_predicate (-> $_ $_)) True) + (= (system_predicate (call $_)) True) + (= (system_predicate (catch $_ $_ $_)) True) + (= (system_predicate (throw $_)) True) + (= (system_predicate (on_exception $_ $_ $_)) True) + (= (system_predicate (raise_exception $_)) True) ; -; - - (= - (system_predicate - (= $_ $_)) True) -; - - (= - (system_predicate - ($unify $_ $_)) True) -; - - (= - (system_predicate - (\= $_ $_)) True) -; - - (= - (system_predicate - (%not_unifiable $_ $_)) True) -; - +; Term unification + (= (system_predicate (= $_ $_)) True) + (= (system_predicate (%unify $_ $_)) True) + (= (system_predicate (\= $_ $_)) True) + (= (system_predicate (%not_unifiable $_ $_)) True) ; -; - - (= - (system_predicate - (var $_)) True) -; - - (= - (system_predicate - (is-symbol $_)) True) -; - - (= - (system_predicate - (integer $_)) True) -; - - (= - (system_predicate - (long $_)) True) -; - - (= - (system_predicate - (float $_)) True) -; - - (= - (system_predicate - (atomic $_)) True) -; - - (= - (system_predicate - (compound $_)) True) -; - - (= - (system_predicate - (nonvar $_)) True) -; - - (= - (system_predicate - (number $_)) True) -; - - (= - (system_predicate - (java $_)) True) -; - - (= - (system_predicate - (java $_ $_)) True) -; - - (= - (system_predicate - (closure $_)) True) -; - - (= - (system_predicate - (ground $_)) True) -; - - (= - (system_predicate - (callable $_)) True) -; - +; Type testing + (= (system_predicate (var $_)) True) + (= (system_predicate (is-symbol $_)) True) + (= (system_predicate (integer $_)) True) + (= (system_predicate (long $_)) True) + (= (system_predicate (float $_)) True) + (= (system_predicate (is-symbolic $_)) True) + (= (system_predicate (compound $_)) True) + (= (system_predicate (nonvar $_)) True) + (= (system_predicate (number $_)) True) + (= (system_predicate (java $_)) True) + (= (system_predicate (java $_ $_)) True) + (= (system_predicate (closure $_)) True) + (= (system_predicate (ground $_)) True) + (= (system_predicate (callable $_)) True) ; -; - - (= - (system_predicate - (== $_ $_)) True) -; - - (= - (system_predicate - (%equality_of_term $_ $_)) True) -; - - (= - (system_predicate - (\== $_ $_)) True) -; - - (= - (system_predicate - (%inequality_of_term $_ $_)) True) -; - - (= - (system_predicate - (@< $_ $_)) True) -; - - (= - (system_predicate - ($before $_ $_)) True) -; - - (= - (system_predicate - (@> $_ $_)) True) -; - - (= - (system_predicate - ($after $_ $_)) True) -; - - (= - (system_predicate - (@=< $_ $_)) True) -; - - (= - (system_predicate - (%not_after $_ $_)) True) -; - - (= - (system_predicate - (@>= $_ $_)) True) -; - - (= - (system_predicate - (%not_before $_ $_)) True) -; - - (= - (system_predicate - (?= $_ $_)) True) -; - - (= - (system_predicate - (%identical_or_cannot_unify $_ $_)) True) -; - - (= - (system_predicate - (compare $_ $_ $_)) True) -; - - (= - (system_predicate - (sort $_ $_)) True) -; - - (= - (system_predicate - (keysort $_ $_)) True) -; - +; Term comparison + (= (system_predicate (== $_ $_)) True) + (= (system_predicate (%equality_of_term $_ $_)) True) + (= (system_predicate (\== $_ $_)) True) + (= (system_predicate (%inequality_of_term $_ $_)) True) + (= (system_predicate (@< $_ $_)) True) + (= (system_predicate (%before $_ $_)) True) + (= (system_predicate (@> $_ $_)) True) + (= (system_predicate (%after $_ $_)) True) + (= (system_predicate (@=< $_ $_)) True) + (= (system_predicate (%not_after $_ $_)) True) + (= (system_predicate (@>= $_ $_)) True) + (= (system_predicate (%not_before $_ $_)) True) + (= (system_predicate (?= $_ $_)) True) + (= (system_predicate (%identical_or_cannot_unify $_ $_)) True) + (= (system_predicate (compare $_ $_ $_)) True) + (= (system_predicate (sort $_ $_)) True) + (= (system_predicate (keysort $_ $_)) True) ; -; - +; system_predicate(merge(_,_,_)). ; -; - - (= - (system_predicate - (arg $_ $_ $_)) True) -; - - (= - (system_predicate - (functor $_ $_ $_)) True) -; - - (= - (system_predicate - (=.. $_ $_)) True) -; - - (= - (system_predicate - ($univ $_ $_)) True) -; - - (= - (system_predicate - (copy_term $_ $_)) True) -; - +; Term creation and decomposition + (= (system_predicate (arg $_ $_ $_)) True) + (= (system_predicate (functor $_ $_ $_)) True) + (= (system_predicate (=.. $_ $_)) True) + (= (system_predicate (%univ $_ $_)) True) + (= (system_predicate (copy_term $_ $_)) True) ; -; - - (= - (system_predicate - (is $_ $_)) True) -; - - (= - (system_predicate - ($abs $_ $_)) True) -; - - (= - (system_predicate - ($asin $_ $_)) True) -; - - (= - (system_predicate - ($acos $_ $_)) True) -; - - (= - (system_predicate - ($atan $_ $_)) True) -; - - (= - (system_predicate - (%bitwise_conj $_ $_ $_)) True) -; - - (= - (system_predicate - (%bitwise_disj $_ $_ $_)) True) -; - - (= - (system_predicate - (%bitwise_exclusive_or $_ $_ $_)) True) -; - - (= - (system_predicate - (%bitwise_neg $_ $_)) True) -; - - (= - (system_predicate - ($ceil $_ $_)) True) -; - - (= - (system_predicate - ($cos $_ $_)) True) -; - - (= - (system_predicate - ($degrees $_ $_)) True) -; - - (= - (system_predicate - ($exp $_ $_)) True) -; - - (= - (system_predicate - ($float $_ $_)) True) -; - - (= - (system_predicate - (%float_integer_part $_ $_)) True) -; - - (= - (system_predicate - (%float_fractional_part $_ $_)) True) -; - - (= - (system_predicate - (%float_quotient $_ $_ $_)) True) -; - - (= - (system_predicate - ($floor $_ $_)) True) -; - - (= - (system_predicate - (%int_quotient $_ $_ $_)) True) -; - - (= - (system_predicate - ($log $_ $_)) True) -; - - (= - (system_predicate - ($max $_ $_ $_)) True) -; - - (= - (system_predicate - ($min $_ $_ $_)) True) -; - - (= - (system_predicate - ($minus $_ $_ $_)) True) -; - - (= - (system_predicate - ($mod $_ $_ $_)) True) -; - - (= - (system_predicate - ($multi $_ $_ $_)) True) -; - - (= - (system_predicate - ($plus $_ $_ $_)) True) -; - - (= - (system_predicate - ($pow $_ $_ $_)) True) -; - - (= - (system_predicate - ($radians $_ $_)) True) -; - - (= - (system_predicate - ($rint $_ $_)) True) -; - - (= - (system_predicate - ($round $_ $_)) True) -; - - (= - (system_predicate - (%shift_left $_ $_ $_)) True) -; - - (= - (system_predicate - (%shift_right $_ $_ $_)) True) -; - - (= - (system_predicate - ($sign $_ $_)) True) -; - - (= - (system_predicate - ($sin $_ $_)) True) -; - - (= - (system_predicate - ($sqrt $_ $_)) True) -; - - (= - (system_predicate - ($tan $_ $_)) True) -; - - (= - (system_predicate - ($truncate $_ $_)) True) -; - +; Arithmetic evaluation + (= (system_predicate (is $_ $_)) True) + (= (system_predicate (%abs $_ $_)) True) + (= (system_predicate (%asin $_ $_)) True) + (= (system_predicate (%acos $_ $_)) True) + (= (system_predicate (%atan $_ $_)) True) + (= (system_predicate (%bitwise_conj $_ $_ $_)) True) + (= (system_predicate (%bitwise_disj $_ $_ $_)) True) + (= (system_predicate (%bitwise_exclusive_or $_ $_ $_)) True) + (= (system_predicate (%bitwise_neg $_ $_)) True) + (= (system_predicate (%ceil $_ $_)) True) + (= (system_predicate (%cos $_ $_)) True) + (= (system_predicate (%degrees $_ $_)) True) + (= (system_predicate (%exp $_ $_)) True) + (= (system_predicate (%float $_ $_)) True) + (= (system_predicate (%float_integer_part $_ $_)) True) + (= (system_predicate (%float_fractional_part $_ $_)) True) + (= (system_predicate (%float_quotient $_ $_ $_)) True) + (= (system_predicate (%floor $_ $_)) True) + (= (system_predicate (%int_quotient $_ $_ $_)) True) + (= (system_predicate (%log $_ $_)) True) + (= (system_predicate (%max $_ $_ $_)) True) + (= (system_predicate (%min $_ $_ $_)) True) + (= (system_predicate (%minus $_ $_ $_)) True) + (= (system_predicate (%mod $_ $_ $_)) True) + (= (system_predicate (%multi $_ $_ $_)) True) + (= (system_predicate (%plus $_ $_ $_)) True) + (= (system_predicate (%pow $_ $_ $_)) True) + (= (system_predicate (%radians $_ $_)) True) + (= (system_predicate (%rint $_ $_)) True) + (= (system_predicate (%round $_ $_)) True) + (= (system_predicate (%shift_left $_ $_ $_)) True) + (= (system_predicate (%shift_right $_ $_ $_)) True) + (= (system_predicate (%sign $_ $_)) True) + (= (system_predicate (%sin $_ $_)) True) + (= (system_predicate (%sqrt $_ $_)) True) + (= (system_predicate (%tan $_ $_)) True) + (= (system_predicate (%truncate $_ $_)) True) ; -; - - (= - (system_predicate - (=:= $_ $_)) True) -; - - (= - (system_predicate - (%arith_equal $_ $_)) True) -; - - (= - (system_predicate - (=\= $_ $_)) True) -; - - (= - (system_predicate - (%arith_not_equal $_ $_)) True) -; - - (= - (system_predicate - (< $_ $_)) True) -; - - (= - (system_predicate - (%less_than $_ $_)) True) -; - - (= - (system_predicate - (=< $_ $_)) True) -; - - (= - (system_predicate - (%less_or_equal $_ $_)) True) -; - - (= - (system_predicate - (> $_ $_)) True) -; - - (= - (system_predicate - (%greater_than $_ $_)) True) -; - - (= - (system_predicate - (>= $_ $_)) True) -; - - (= - (system_predicate - (%greater_or_equal $_ $_)) True) -; - +; Arithmetic comparison + (= (system_predicate (=:= $_ $_)) True) + (= (system_predicate (%arith_equal $_ $_)) True) + (= (system_predicate (=\= $_ $_)) True) + (= (system_predicate (%arith_not_equal $_ $_)) True) + (= (system_predicate (< $_ $_)) True) + (= (system_predicate (%less_than $_ $_)) True) + (= (system_predicate (=< $_ $_)) True) + (= (system_predicate (%less_or_equal $_ $_)) True) + (= (system_predicate (> $_ $_)) True) + (= (system_predicate (%greater_than $_ $_)) True) + (= (system_predicate (>= $_ $_)) True) + (= (system_predicate (%greater_or_equal $_ $_)) True) ; -; - - (= - (system_predicate - (clause $_ $_)) True) -; - - (= - (system_predicate - (initialization $_ $_)) True) -; - - (= - (system_predicate - (%new_indexing_hash $_ $_ $_)) True) -; - +; Clause retrieval and information + (= (system_predicate (clause $_ $_)) True) + (= (system_predicate (initialization $_ $_)) True) + (= (system_predicate (%new_indexing_hash $_ $_ $_)) True) ; -; - - (= - (system_predicate - (assert $_)) True) -; - - (= - (system_predicate - (assertz $_)) True) -; - - (= - (system_predicate - (asserta $_)) True) -; - - (= - (system_predicate - (retract $_)) True) -; - - (= - (system_predicate - (abolish $_)) True) -; - - (= - (system_predicate - (retractall $_)) True) -; - +; Clause creation and destruction + (= (system_predicate (assert $_)) True) + (= (system_predicate (assertz $_)) True) + (= (system_predicate (asserta $_)) True) + (= (system_predicate (retract $_)) True) + (= (system_predicate (abolish $_)) True) + (= (system_predicate (retractall $_)) True) ; -; - - (= - (system_predicate - (findall $_ $_ $_)) True) -; - - (= - (system_predicate - (bagof $_ $_ $_)) True) -; - - (= - (system_predicate - (setof $_ $_ $_)) True) -; - +; All solutions + (= (system_predicate (findall $_ $_ $_)) True) + (= (system_predicate (bagof $_ $_ $_)) True) + (= (system_predicate (setof $_ $_ $_)) True) ; -; - - (= - (system_predicate - (current_input $_)) True) -; - - (= - (system_predicate - (current_output $_)) True) -; - - (= - (system_predicate - (set_input $_)) True) -; - - (= - (system_predicate - (set_output $_)) True) -; - - (= - (system_predicate - (open $_ $_ $_)) True) -; - - (= - (system_predicate - (open $_ $_ $_ $_)) True) -; - - (= - (system_predicate - (close $_)) True) -; - - (= - (system_predicate - (close $_ $_)) True) -; - - (= - (system_predicate - (flush_output $_)) True) -; - - (= - (system_predicate flush_output) True) -; - - (= - (system_predicate - (stream_property $_ $_)) True) -; - +; Stream selection and control + (= (system_predicate (current_input $_)) True) + (= (system_predicate (current_output $_)) True) + (= (system_predicate (set_input $_)) True) + (= (system_predicate (set_output $_)) True) + (= (system_predicate (open $_ $_ $_)) True) + (= (system_predicate (open $_ $_ $_ $_)) True) + (= (system_predicate (close $_)) True) + (= (system_predicate (close $_ $_)) True) + (= (system_predicate (flush_output $_)) True) + (= (system_predicate flush_output) True) + (= (system_predicate (stream_property $_ $_)) True) ; -; - - (= - (system_predicate - (get_char $_)) True) -; - - (= - (system_predicate - (get_char $_ $_)) True) -; - - (= - (system_predicate - (get_code $_)) True) -; - - (= - (system_predicate - (get_code $_ $_)) True) -; - - (= - (system_predicate - (peek_char $_)) True) -; - - (= - (system_predicate - (peek_char $_ $_)) True) -; - - (= - (system_predicate - (peek_code $_)) True) -; - - (= - (system_predicate - (peek_code $_ $_)) True) -; - - (= - (system_predicate - (put_char $_)) True) -; - - (= - (system_predicate - (put_char $_ $_)) True) -; - - (= - (system_predicate - (put_code $_)) True) -; - - (= - (system_predicate - (put_code $_ $_)) True) -; - - (= - (system_predicate nl) True) -; - - (= - (system_predicate - (nl $_)) True) -; - - (= - (system_predicate - (get0 $_)) True) -; - - (= - (system_predicate - (get0 $_ $_)) True) -; - - (= - (system_predicate - (get $_)) True) -; - - (= - (system_predicate - (get $_ $_)) True) -; - - (= - (system_predicate - (put $_)) True) -; - - (= - (system_predicate - (put $_ $_)) True) -; - - (= - (system_predicate - (tab $_)) True) -; - - (= - (system_predicate - (tab $_ $_)) True) -; - - (= - (system_predicate - (skip $_)) True) -; - - (= - (system_predicate - (skip $_ $_)) True) -; - +; Character input/output + (= (system_predicate (get_char $_)) True) + (= (system_predicate (get_char $_ $_)) True) + (= (system_predicate (get_code $_)) True) + (= (system_predicate (get_code $_ $_)) True) + (= (system_predicate (peek_char $_)) True) + (= (system_predicate (peek_char $_ $_)) True) + (= (system_predicate (peek_code $_)) True) + (= (system_predicate (peek_code $_ $_)) True) + (= (system_predicate (put_char $_)) True) + (= (system_predicate (put_char $_ $_)) True) + (= (system_predicate (put_code $_)) True) + (= (system_predicate (put_code $_ $_)) True) + (= (system_predicate nl) True) + (= (system_predicate (nl $_)) True) + (= (system_predicate (get0 $_)) True) + (= (system_predicate (get0 $_ $_)) True) + (= (system_predicate (get $_)) True) + (= (system_predicate (get $_ $_)) True) + (= (system_predicate (put $_)) True) + (= (system_predicate (put $_ $_)) True) + (= (system_predicate (tab $_)) True) + (= (system_predicate (tab $_ $_)) True) + (= (system_predicate (skip $_)) True) + (= (system_predicate (skip $_ $_)) True) ; -; - - (= - (system_predicate - (get_byte $_)) True) -; - - (= - (system_predicate - (get_byte $_ $_)) True) -; - - (= - (system_predicate - (peek_byte $_)) True) -; - - (= - (system_predicate - (peek_byte $_ $_)) True) -; - - (= - (system_predicate - (put_byte $_)) True) -; - - (= - (system_predicate - (put_byte $_ $_)) True) -; - +; Byte input/output + (= (system_predicate (get_byte $_)) True) + (= (system_predicate (get_byte $_ $_)) True) + (= (system_predicate (peek_byte $_)) True) + (= (system_predicate (peek_byte $_ $_)) True) + (= (system_predicate (put_byte $_)) True) + (= (system_predicate (put_byte $_ $_)) True) ; -; - - (= - (system_predicate - (read $_)) True) -; - - (= - (system_predicate - (read $_ $_)) True) -; - - (= - (system_predicate - (read_with_variables $_ $_)) True) -; - - (= - (system_predicate - (read_with_variables $_ $_ $_)) True) -; - - (= - (system_predicate - (read_line $_)) True) -; - - (= - (system_predicate - (read_line $_ $_)) True) -; - - (= - (system_predicate - (write $_)) True) -; - - (= - (system_predicate - (write $_ $_)) True) -; - - (= - (system_predicate - (writeq $_)) True) -; - - (= - (system_predicate - (writeq $_ $_)) True) -; - - (= - (system_predicate - (write_canonical $_)) True) -; - - (= - (system_predicate - (write_canonical $_ $_)) True) -; - - (= - (system_predicate - (write_term $_ $_)) True) -; - - (= - (system_predicate - (write_term $_ $_ $_)) True) -; - - (= - (system_predicate - (op $_ $_ $_)) True) -; - - (= - (system_predicate - (current_op $_ $_ $_)) True) -; - +; Term input/output + (= (system_predicate (read $_)) True) + (= (system_predicate (read $_ $_)) True) + (= (system_predicate (read_with_variables $_ $_)) True) + (= (system_predicate (read_with_variables $_ $_ $_)) True) + (= (system_predicate (read_line $_)) True) + (= (system_predicate (read_line $_ $_)) True) + (= (system_predicate (write $_)) True) + (= (system_predicate (write $_ $_)) True) + (= (system_predicate (writeq $_)) True) + (= (system_predicate (writeq $_ $_)) True) + (= (system_predicate (write_canonical $_)) True) + (= (system_predicate (write_canonical $_ $_)) True) + (= (system_predicate (write_term $_ $_)) True) + (= (system_predicate (write_term $_ $_ $_)) True) + (= (system_predicate (op $_ $_ $_)) True) + (= (system_predicate (current_op $_ $_ $_)) True) ; -; - - (= - (system_predicate - (\+ $_)) True) -; - - (= - (system_predicate - (once $_)) True) -; - - (= - (system_predicate repeat) True) -; - +; Logic and control + (= (system_predicate (\+ $_)) True) + (= (system_predicate (once $_)) True) + (= (system_predicate repeat) True) ; -; - - (= - (system_predicate - (symbol_length $_ $_)) True) -; - - (= - (system_predicate - (symbol_concat $_ $_ $_)) True) -; - - (= - (system_predicate - (sub_symbol $_ $_ $_ $_ $_)) True) -; - - (= - (system_predicate - (symbol_chars $_ $_)) True) -; - - (= - (system_predicate - (symbol_codes $_ $_)) True) -; - - (= - (system_predicate - (char_code $_ $_)) True) -; - - (= - (system_predicate - (number_chars $_ $_)) True) -; - - (= - (system_predicate - (number_codes $_ $_)) True) -; - - (= - (system_predicate - (name $_ $_)) True) -; - +; Atomic term processing + (= (system_predicate (symbol_length $_ $_)) True) + (= (system_predicate (symbol_concat $_ $_ $_)) True) + (= (system_predicate (sub_symbol $_ $_ $_ $_ $_)) True) + (= (system_predicate (symbol_chars $_ $_)) True) + (= (system_predicate (symbol_codes $_ $_)) True) + (= (system_predicate (char_code $_ $_)) True) + (= (system_predicate (number_chars $_ $_)) True) + (= (system_predicate (number_codes $_ $_)) True) + (= (system_predicate (name $_ $_)) True) ; -; - - (= - (system_predicate - (set_prolog_flag $_ $_)) True) -; - - (= - (system_predicate - (current_prolog_flag $_ $_)) True) -; - - (= - (system_predicate halt) True) -; - - (= - (system_predicate - (halt $_)) True) -; - - (= - (system_predicate abort) True) -; - +; Implementation defined hooks + (= (system_predicate (set_prolog_flag $_ $_)) True) + (= (system_predicate (current_prolog_flag $_ $_)) True) + (= (system_predicate halt) True) + (= (system_predicate (halt $_)) True) + (= (system_predicate abort) True) ; -; - - (= - (system_predicate - (C $_ $_ $_)) True) -; - - (= - (system_predicate - (expand_term $_ $_)) True) -; - +; DCG + (= (system_predicate (C $_ $_ $_)) True) + (= (system_predicate (expand_term $_ $_)) True) ; -; - - (= - (system_predicate - (new_hash $_)) True) -; - - (= - (system_predicate - (new_hash $_ $_)) True) -; - - (= - (system_predicate - (hash_clear $_)) True) -; - - (= - (system_predicate - (hash_contains_key $_ $_)) True) -; - - (= - (system_predicate - (hash_get $_ $_ $_)) True) -; - - (= - (system_predicate - (hash_is_empty $_)) True) -; - - (= - (system_predicate - (hash_keys $_ $_)) True) -; - - (= - (system_predicate - (hash_map $_ $_)) True) -; - - (= - (system_predicate - (hash_put $_ $_ $_)) True) -; - - (= - (system_predicate - (hash_remove $_ $_)) True) -; - - (= - (system_predicate - (hash_size $_ $_)) True) -; - - (= - (system_predicate - (%get_hash_manager $_)) True) -; - +; Hash creation and control + (= (system_predicate (new_hash $_)) True) + (= (system_predicate (new_hash $_ $_)) True) + (= (system_predicate (hash_clear $_)) True) + (= (system_predicate (hash_contains_key $_ $_)) True) + (= (system_predicate (hash_get $_ $_ $_)) True) + (= (system_predicate (hash_is_empty $_)) True) + (= (system_predicate (hash_keys $_ $_)) True) + (= (system_predicate (hash_map $_ $_)) True) + (= (system_predicate (hash_put $_ $_ $_)) True) + (= (system_predicate (hash_remove $_ $_)) True) + (= (system_predicate (hash_size $_ $_)) True) + (= (system_predicate (%get_hash_manager $_)) True) ; -; - - (= - (system_predicate - (java_constructor0 $_ $_)) True) -; - - (= - (system_predicate - (java_constructor $_ $_)) True) -; - - (= - (system_predicate - (java_declared_constructor0 $_ $_)) True) -; - - (= - (system_predicate - (java_declared_constructor $_ $_)) True) -; - - (= - (system_predicate - (java_method0 $_ $_ $_)) True) -; - - (= - (system_predicate - (java_method $_ $_ $_)) True) -; - - (= - (system_predicate - (java_declared_method0 $_ $_ $_)) True) -; - - (= - (system_predicate - (java_declared_method $_ $_ $_)) True) -; - - (= - (system_predicate - (java_get_field0 $_ $_ $_)) True) -; - - (= - (system_predicate - (java_get_field $_ $_ $_)) True) -; - - (= - (system_predicate - (java_get_declared_field0 $_ $_ $_)) True) -; - - (= - (system_predicate - (java_get_declared_field $_ $_ $_)) True) -; - - (= - (system_predicate - (java_set_field0 $_ $_ $_)) True) -; - - (= - (system_predicate - (java_set_field $_ $_ $_)) True) -; - - (= - (system_predicate - (java_set_declared_field0 $_ $_ $_)) True) -; - - (= - (system_predicate - (java_set_declared_field $_ $_ $_)) True) -; - - (= - (system_predicate - (synchronized $_ $_)) True) -; - - (= - (system_predicate - (java_conversion $_ $_)) True) -; - +; Java interoperation + (= (system_predicate (java_constructor0 $_ $_)) True) + (= (system_predicate (java_constructor $_ $_)) True) + (= (system_predicate (java_declared_constructor0 $_ $_)) True) + (= (system_predicate (java_declared_constructor $_ $_)) True) + (= (system_predicate (java_method0 $_ $_ $_)) True) + (= (system_predicate (java_method $_ $_ $_)) True) + (= (system_predicate (java_declared_method0 $_ $_ $_)) True) + (= (system_predicate (java_declared_method $_ $_ $_)) True) + (= (system_predicate (java_get_field0 $_ $_ $_)) True) + (= (system_predicate (java_get_field $_ $_ $_)) True) + (= (system_predicate (java_get_declared_field0 $_ $_ $_)) True) + (= (system_predicate (java_get_declared_field $_ $_ $_)) True) + (= (system_predicate (java_set_field0 $_ $_ $_)) True) + (= (system_predicate (java_set_field $_ $_ $_)) True) + (= (system_predicate (java_set_declared_field0 $_ $_ $_)) True) + (= (system_predicate (java_set_declared_field $_ $_ $_)) True) + (= (system_predicate (synchronized $_ $_)) True) + (= (system_predicate (java_conversion $_ $_)) True) ; -; - - (= - (system_predicate cafeteria) True) -; - - (= - (system_predicate - (consult $_)) True) -; - - (= - (system_predicate trace) True) -; - - (= - (system_predicate notrace) True) -; - - (= - (system_predicate debug) True) -; - - (= - (system_predicate nodebug) True) -; - - (= - (system_predicate - (leash $_)) True) -; - - (= - (system_predicate - (spy $_)) True) -; - - (= - (system_predicate - (nospy $_)) True) -; - - (= - (system_predicate nospyall) True) -; - - (= - (system_predicate listing) True) -; - - (= - (system_predicate - (listing $_)) True) -; - +; MeTTa interpreter + (= (system_predicate cafeteria) True) + (= (system_predicate (consult $_)) True) + (= (system_predicate trace) True) + (= (system_predicate notrace) True) + (= (system_predicate debug) True) + (= (system_predicate nodebug) True) + (= (system_predicate (leash $_)) True) + (= (system_predicate (spy $_)) True) + (= (system_predicate (nospy $_)) True) + (= (system_predicate nospyall) True) + (= (system_predicate listing) True) + (= (system_predicate (listing $_)) True) ; -; - - (= - (system_predicate - (length $_ $_)) True) -; - - (= - (system_predicate - (numbervars $_ $_ $_)) True) -; - - (= - (system_predicate - (statistics $_ $_)) True) -; - +; Misc + (= (system_predicate (length $_ $_)) True) + (= (system_predicate (numbervars $_ $_ $_)) True) + (= (system_predicate (statistics $_ $_)) True) ; -; - +; END diff --git a/sxx_machine/tau_builtins.metta b/sxx_machine/tau_builtins.metta index 67dca29..cf49c18 100644 --- a/sxx_machine/tau_builtins.metta +++ b/sxx_machine/tau_builtins.metta @@ -1,86 +1,59 @@ +; (convert_to_metta_file tau_builtins $_361144 sxx_machine/tau_builtins.pl sxx_machine/tau_builtins.metta) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Builtin Predicates of MeTTa Cafe ; ; - ; -; - +; Mutsunori Banbara (banbara@kobe-u.ac.jp) ; -; - +; Naoyuki Tamura (tamura@kobe-u.ac.jp) ; -; - +; Kobe University ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + !(op 1150 fx package) - !(op 1150 fx package) -; + (= (package $X) + (nb-setval package $X)) - (= - (package $X) - (nb-setval package $X)) -; - - - - !(package TauMachine.builtin-tau) -; - + !(package TauMachine.builtin-tau) ; -; - +; :- public system_predicate/1. ; -; - +; :- multifile(system_predicate/1). ; -; - +; :- dynamic(system_predicate/1). !(public (/ undo 1)) -; - +; /* system_predicate(nb_setarg(_,_,_)). system_predicate(setarg(_,_,_)). system_predicate(nb_get_attr(_,_,_)). system_predicate(nb_put_attr(_,_,_)). system_predicate(nb_get_attrs(_,_)). system_predicate(nb_put_attrs(_,_)). */ +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Control constructs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (undo $G) + (= (undo $G) (undo (call $G))) -; - +; /* '$builtin_meta_predicates'(undo, 1, [:]). '$builtin_meta_predicates'(undo1, 1, [:]). '$builtin_meta_predicates'(redo_each_call, 3, [:,:,:]). '$builtin_meta_predicates'(one_of_or_else, 3, [:,:,:]). */ - (= - (undo1 $Term) - ( ($get-current-B $Cut) ($meta-call $Term user $Cut 0 interpret))) -; - + (= (undo1 $Term) + ($get-current-B $Cut) + ($meta-call $Term user $Cut 0 interpret)) - (= - (redo-each-call $EachSetup $Call $EachCleanup) - (redo-each-call $EachSetup $Call $EachCleanup)) -; - + (= (redo-each-call $EachSetup $Call $EachCleanup) + (redo-each-call $EachSetup $Call $EachCleanup)) - (= - (one-of-or-else $If $Then $Else) - (one-of-or-else $If $Then $Else)) -; - + (= (one-of-or-else $If $Then $Else) + (one-of-or-else $If $Then $Else)) ; -; - +; END diff --git a/sxx_machine/tau_builtins_cafe.metta b/sxx_machine/tau_builtins_cafe.metta index 93f1926..ad67a65 100644 --- a/sxx_machine/tau_builtins_cafe.metta +++ b/sxx_machine/tau_builtins_cafe.metta @@ -1,7618 +1,4258 @@ +; (convert_to_metta_file tau_builtins_cafe $_440972 sxx_machine/tau_builtins_cafe.pl sxx_machine/tau_builtins_cafe.metta) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Builtin Predicates of MeTTa Cafe ; ; - ; -; - +; Mutsunori Banbara (banbara@kobe-u.ac.jp) ; -; - +; Naoyuki Tamura (tamura@kobe-u.ac.jp) ; -; - +; Kobe University ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + !(op 1150 fx package) - !(op 1150 fx package) -; - - - (= - (package $_) True) -; - + (= (package $_) True) - !(package TauMachine.builtin) -; - + !(package TauMachine.builtin) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Control constructs ; -; - - !(public (, (/ True 0) (/ otherwise 0))) -; - - !(public (, (/ fail 0) (/ False 0))) -; - - !(public (/ (set-det) 0)) -; - - !(public (/ ^ 2)) -; - - !(public (/ , 2)) -; - - !(public (/ or 2)) -; - - !(public (/ -> 2)) -; - - !(public (/ call 1)) -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + !(public (, (/ True 0) (/ otherwise 0))) + !(public (, (/ fail 0) (/ False 0))) + !(public (/ (set-det) 0)) + !(public (/ ^ 2)) + !(public (/ , 2)) + !(public (/ or 2)) + !(public (/ -> 2)) + !(public (/ call 1)) - (= true True) -; - + (= true True) - (= otherwise True) -; - + (= otherwise True) - (= fail - (empty)) -; - + (= fail + (empty)) - (= false - (empty)) -; - + (= false + (empty)) - (= ! True) -; - + (= ! True) - (= - (^ $_ $G) - (call $G)) -; - + (= (^ $_ $G) + (call $G)) - (= - (, $P $Q) - ( (call $P) (call $Q))) -; - + (= (, $P $Q) + (call $P) + (call $Q)) - (= - (or $P $Q) - ( (\= $P - (det-if-then $_ $_)) (call $P))) -; - - (= - (or $P $Q) - ( (\= $Q - (det-if-then $_ $_)) (call $Q))) -; - + (= (or $P $Q) + (\= $P + (det-if-then $_ $_)) + (call $P)) + (= (or $P $Q) + (\= $Q + (det-if-then $_ $_)) + (call $Q)) - (= - (det-if-then $IF $THEN) - ( (call $IF) - (set-det) - (call $THEN))) -; - + (= (det-if-then $IF $THEN) + (call $IF) + (set-det) + (call $THEN)) - (= - (det-if-then-else $IF $THEN $ELSE) - ( (call $IF) - (set-det) - (call $THEN))) -; - - (= - (det-if-then-else $IF $THEN $ELSE) - (call $ELSE)) -; - + (= (det-if-then-else $IF $THEN $ELSE) + (call $IF) + (set-det) + (call $THEN)) + (= (det-if-then-else $IF $THEN $ELSE) + (call $ELSE)) - (= - (call $Term) - ( ($get-current-B $Cut) ($meta-call $Term user $Cut 0 interpret))) -; - + (= (call $Term) + ($get-current-B $Cut) + ($meta-call $Term user $Cut 0 interpret)) - (= - ($meta-call $X $_ $_ $_ $_) - ( (var $X) - (set-det) - (illarg var - (call $X) 1))) -; - - (= - ($meta-call $X $_ $_ $_ $_) - ( (closure $X) - (set-det) - ($call-closure $X))) -; - - (= - ($meta-call True $_ $_ $_ $_) - (set-det)) -; - - (= - ($meta-call trace $_ $_ $_ $_) - ( (set-det) (trace))) -; - - (= - ($meta-call debug $_ $_ $_ $_) - ( (set-det) (debug))) -; - - (= - ($meta-call notrace $_ $_ $_ $_) - ( (set-det) (notrace))) -; - - (= - ($meta-call nodebug $_ $_ $_ $_) - ( (set-det) (nodebug))) -; - - (= - ($meta-call - (spy $L) $_ $_ $_ $_) - ( (set-det) (spy $L))) -; - - (= - ($meta-call - (nospy $L) $_ $_ $_ $_) - ( (set-det) (nospy $L))) -; - - (= - ($meta-call nospyall $_ $_ $_ $_) - ( (set-det) (nospyall))) -; - - (= - ($meta-call - (leash $L) $_ $_ $_ $_) - ( (set-det) (leash $L))) -; - - (= - ($meta-call - (Cons $X $Xs) $_ $_ $_ $_) - ( (set-det) (consult (Cons $X $Xs)))) -; - - (= - ($meta-call - (^ $_ $X) $P $Cut $Depth $Mode) - ( (set-det) ($meta-call $X $P $Cut $Depth $Mode))) -; - - (= - ($meta-call - (with_self $P $X) $_ $Cut $Depth $Mode) - ( (set-det) ($meta-call $X $P $Cut $Depth $Mode))) -; - - (= - ($meta-call - (set-det) $_ no $_ $_) - ( (set-det) (illarg (context if cut) (set-det) 0))) -; - - (= - ($meta-call - (set-det) $_ $Cut $_ $_) - ( (set-det) ($cut $Cut))) -; - - (= - ($meta-call - (, $X $Y) $P $Cut $Depth $Mode) - ( (set-det) + (= ($meta-call $X $_ $_ $_ $_) + (var $X) + (set-det) + (illarg var + (call $X) 1)) + (= ($meta-call $X $_ $_ $_ $_) + (closure $X) + (set-det) + ($call-closure $X)) + (= ($meta-call True $_ $_ $_ $_) + (set-det)) + (= ($meta-call trace $_ $_ $_ $_) + (set-det) + (trace)) + (= ($meta-call debug $_ $_ $_ $_) + (set-det) + (debug)) + (= ($meta-call notrace $_ $_ $_ $_) + (set-det) + (notrace)) + (= ($meta-call nodebug $_ $_ $_ $_) + (set-det) + (nodebug)) + (= ($meta-call (spy $L) $_ $_ $_ $_) + (set-det) + (spy $L)) + (= ($meta-call (nospy $L) $_ $_ $_ $_) + (set-det) + (nospy $L)) + (= ($meta-call nospyall $_ $_ $_ $_) + (set-det) + (nospyall)) + (= ($meta-call (leash $L) $_ $_ $_ $_) + (set-det) + (leash $L)) + (= ($meta-call (Cons $X $Xs) $_ $_ $_ $_) + (set-det) + (consult (Cons $X $Xs))) + (= ($meta-call (^ $_ $X) $P $Cut $Depth $Mode) + (set-det) + ($meta-call $X $P $Cut $Depth $Mode)) + (= ($meta-call (with_self $P $X) $_ $Cut $Depth $Mode) + (set-det) + ($meta-call $X $P $Cut $Depth $Mode)) + (= ($meta-call (set-det) $_ no $_ $_) + (set-det) + (illarg + (context if cut) + (set-det) 0)) + (= ($meta-call (set-det) $_ $Cut $_ $_) + (set-det) + ($cut $Cut)) + (= ($meta-call (, $X $Y) $P $Cut $Depth $Mode) + (set-det) + ($meta-call $X $P $Cut $Depth $Mode) + ($meta-call $Y $P $Cut $Depth $Mode)) + (= ($meta-call (det-if-then-else $X $Y $Z) $P $Cut $Depth $Mode) + (set-det) + (det-if-then-else + ($meta-call $X $P no $Depth $Mode) + ($meta-call $Y $P $Cut $Depth $Mode) + ($meta-call $Z $P $Cut $Depth $Mode))) + (= ($meta-call (det-if-then $X $Y) $P $Cut $Depth $Mode) + (set-det) + (det-if-then + ($meta-call $X $P no $Depth $Mode) + ($meta-call $Y $P $Cut $Depth $Mode))) + (= ($meta-call (or $X $Y) $P $Cut $Depth $Mode) + (set-det) + (or ($meta-call $X $P $Cut $Depth $Mode) - ($meta-call $Y $P $Cut $Depth $Mode))) -; - - (= - ($meta-call - (det-if-then-else $X $Y $Z) $P $Cut $Depth $Mode) - ( (set-det) (det-if-then-else ($meta-call $X $P no $Depth $Mode) ($meta-call $Y $P $Cut $Depth $Mode) ($meta-call $Z $P $Cut $Depth $Mode)))) -; - - (= - ($meta-call - (det-if-then $X $Y) $P $Cut $Depth $Mode) - ( (set-det) (det-if-then ($meta-call $X $P no $Depth $Mode) ($meta-call $Y $P $Cut $Depth $Mode)))) -; - - (= - ($meta-call - (or $X $Y) $P $Cut $Depth $Mode) - ( (set-det) (or ($meta-call $X $P $Cut $Depth $Mode) ($meta-call $Y $P $Cut $Depth $Mode)))) -; - - (= - ($meta-call - (not $X) $P $_ $Depth $Mode) - ( (set-det) (not ($meta-call $X $P no $Depth $Mode)))) -; - - (= - ($meta-call - (findall $X $Y $Z) $P $Cut $Depth $Mode) - ( (set-det) (findall $X ($meta-call $Y $P $Cut $Depth $Mode) $Z))) -; - - (= - ($meta-call - (bagof $X $Y $Z) $P $Cut $Depth $Mode) - ( (set-det) (bagof $X ($meta-call $Y $P $Cut $Depth $Mode) $Z))) -; - - (= - ($meta-call - (setof $X $Y $Z) $P $Cut $Depth $Mode) - ( (set-det) (setof $X ($meta-call $Y $P $Cut $Depth $Mode) $Z))) -; - - (= - ($meta-call - (once $X) $P $Cut $Depth $Mode) - ( (set-det) (once ($meta-call $X $P $Cut $Depth $Mode)))) -; - - (= - ($meta-call - (on-exception $X $Y $Z) $P $Cut $Depth $Mode) - ( (set-det) (on-exception $X ($meta-call $Y $P $Cut $Depth $Mode) ($meta-call $Z $P $Cut $Depth $Mode)))) -; - - (= - ($meta-call - (catch $X $Y $Z) $P $Cut $Depth $Mode) - ( (set-det) (catch ($meta-call $X $P $Cut $Depth $Mode) $Y ($meta-call $Z $P $Cut $Depth $Mode)))) -; - -; -; - -; -; - - (= - ($meta-call - (synchronized $X $Y) $P $Cut $Depth $Mode) - ( (set-det) (synchronized $X ($meta-call $Y $P $Cut $Depth $Mode)))) -; - - (= - ($meta-call - (get-symbols &self - (= $X $Y)) $P $_ $_ $_) - ( (set-det) (get-symbols &self (= (: $P $X) $Y)))) -; - - (= - ($meta-call - (add-symbol &self $X) $P $_ $_ $_) - ( (set-det) (add-symbol &self (: $P $X)))) -; - - (= - ($meta-call - (add-symbol &self $X) $P $_ $_ $_) - ( (set-det) (add-symbol &self (: $P $X)))) -; - - (= - ($meta-call - (add-symbol &self $X) $P $_ $_ $_) - ( (set-det) (add-symbol &self (: $P $X)))) -; - - (= - ($meta-call - (remove-symbol &self $X) $P $_ $_ $_) - ( (set-det) (remove-symbol &self (: $P $X)))) -; - - (= - ($meta-call - (abolish $X) $P $_ $_ $_) - ( (set-det) (abolish (with_self $P $X)))) -; - - (= - ($meta-call - (remove-all-symbols &self $X) $P $_ $_ $_) - ( (set-det) (remove-all-symbols &self (: $P $X)))) -; - - (= - ($meta-call $X $P $_ $Depth $Mode) - ( (atom $P) - (callable $X) - (set-det) - ($meta-call $Mode $Depth $P $X))) -; - - (= - ($meta-call $X $P $_ $_ $_) + ($meta-call $Y $P $Cut $Depth $Mode))) + (= ($meta-call (not $X) $P $_ $Depth $Mode) + (set-det) + (not ($meta-call $X $P no $Depth $Mode))) + (= ($meta-call (findall $X $Y $Z) $P $Cut $Depth $Mode) + (set-det) + (findall $X + ($meta-call $Y $P $Cut $Depth $Mode) $Z)) + (= ($meta-call (bagof $X $Y $Z) $P $Cut $Depth $Mode) + (set-det) + (bagof $X + ($meta-call $Y $P $Cut $Depth $Mode) $Z)) + (= ($meta-call (setof $X $Y $Z) $P $Cut $Depth $Mode) + (set-det) + (setof $X + ($meta-call $Y $P $Cut $Depth $Mode) $Z)) + (= ($meta-call (once $X) $P $Cut $Depth $Mode) + (set-det) + (once ($meta-call $X $P $Cut $Depth $Mode))) + (= ($meta-call (on-exception $X $Y $Z) $P $Cut $Depth $Mode) + (set-det) + (on-exception $X + ($meta-call $Y $P $Cut $Depth $Mode) + ($meta-call $Z $P $Cut $Depth $Mode))) + (= ($meta-call (catch $X $Y $Z) $P $Cut $Depth $Mode) + (set-det) + (catch + ($meta-call $X $P $Cut $Depth $Mode) $Y + ($meta-call $Z $P $Cut $Depth $Mode))) +; +; '$meta_call'(freeze(X,Y), P, Cut, Depth, Mode) :- !, ??? +; +; freeze(X, '$meta_call'(Y, P, Cut, Depth, Mode)). + (= ($meta-call (synchronized $X $Y) $P $Cut $Depth $Mode) + (set-det) + (synchronized $X + ($meta-call $Y $P $Cut $Depth $Mode))) + (= ($meta-call (== (= $X $Y) (get-atoms &self)) $P $_ $_ $_) + ( (set-det) (== (= (: $P $X) $Y) (get-atoms &self)))) + (= ($meta-call (add-is-symbol &self $X) $P $_ $_ $_) + ( (set-det) (add-is-symbol &self (: $P $X)))) + (= ($meta-call (add-is-symbol &self $X) $P $_ $_ $_) + ( (set-det) (add-is-symbol &self (: $P $X)))) + (= ($meta-call (add-is-symbol &self $X) $P $_ $_ $_) + ( (set-det) (add-is-symbol &self (: $P $X)))) + (= ($meta-call (remove-is-symbol &self $X) $P $_ $_ $_) + ( (set-det) (remove-is-symbol &self (: $P $X)))) + (= ($meta-call (abolish $X) $P $_ $_ $_) + (set-det) + (abolish (with_self $P $X))) + (= ($meta-call (remove-all-atoms &self $X) $P $_ $_ $_) + ( (set-det) (remove-all-atoms &self (: $P $X)))) + (= ($meta-call $X $P $_ $Depth $Mode) + (atom $P) + (callable $X) + (set-det) + ($meta-call $Mode $Depth $P $X)) + (= ($meta-call $X $P $_ $_ $_) (illarg (type callable) - (call (with_self $P $X)) 1)) -; - - - (= - ($meta-call trace $Depth $P $X) - ( (set-det) - (functor $X $F $A) - ($trace-goal $X $P - (/ $F $A) $Depth))) -; - - (= - ($meta-call interpret $Depth $P $X) - ( (functor $X $F $A) ($call-internal $X $P (/ $F $A) $Depth interpret))) -; + (call (with_self $P $X)) 1)) + (= ($meta-call trace $Depth $P $X) + (set-det) + (functor $X $F $A) + ($trace-goal $X $P + (/ $F $A) $Depth)) + (= ($meta-call interpret $Depth $P $X) + (functor $X $F $A) + ($call-internal $X $P + (/ $F $A) $Depth interpret)) - (= - ($call-internal $X $P $FA $Depth $Mode) + (= ($call-internal $X $P $FA $Depth $Mode) ( ($new-internal-database $P) (hash-contains-key $P $FA) (set-det) ($get-current-B $Cut) (is $Depth1 (+ $Depth 1)) - (get-symbols &self + (== (= - (: $P $X) $Body)) - ($meta-call $Body $P $Cut $Depth1 $Mode))) -; - - (= - ($call-internal $X $P $_ $_ $_) - ($call $P $X)) -; - + (: $P $X) $Body) + (get-atoms &self)) + ($meta-call $Body $P $Cut $Depth1 $Mode))) + (= ($call-internal $X $P $_ $_ $_) + ($call $P $X)) - !(public (, (/ catch 3) (/ throw 1))) -; - - !(public (/ on-exception 3)) -; - + !(public (, (/ catch 3) (/ throw 1))) + !(public (/ on-exception 3)) - (= - (catch $Goal $Catch $Recovery) - (on-exception $Catch $Goal $Recovery)) -; - + (= (catch $Goal $Catch $Recovery) + (on-exception $Catch $Goal $Recovery)) - (= - (throw $Msg) - (raise-exception $Msg)) -; - + (= (throw $Msg) + (raise-exception $Msg)) - (= - (on-exception $Catch $Goal $Recovery) - ( (callable $Goal) - (set-det) - ($on-exception $Catch $Goal $Recovery))) -; - - (= - (on-exception $Catch $Goal $Recovery) + (= (on-exception $Catch $Goal $Recovery) + (callable $Goal) + (set-det) + ($on-exception $Catch $Goal $Recovery)) + (= (on-exception $Catch $Goal $Recovery) (illarg (type callable) - (on-exception $Catch $Goal $Recovery) 2)) -; - + (on-exception $Catch $Goal $Recovery) 2)) - (= - ($on-exception $Catch $Goal $Recovery) - ( ($set-exception %none) - ($begin-exception $L) - (call $Goal) - ($end-exception $L))) -; - - (= - ($on-exception $Catch $Goal $Recovery) - ( ($get-exception $Msg) - (\== $Msg %none) - ($catch-and-throw $Msg $Catch $Recovery))) -; - + (= ($on-exception $Catch $Goal $Recovery) + ($set-exception %none) + ($begin-exception $L) + (call $Goal) + ($end-exception $L)) + (= ($on-exception $Catch $Goal $Recovery) + ($get-exception $Msg) + (\== $Msg %none) + ($catch-and-throw $Msg $Catch $Recovery)) - (= - ($catch-and-throw $Msg $Msg $Recovery) - ( (set-det) - ($set-exception %none) - (call $Recovery))) -; - - (= - ($catch-and-throw $Msg $_ $_) - (raise-exception $Msg)) -; - + (= ($catch-and-throw $Msg $Msg $Recovery) + (set-det) + ($set-exception %none) + (call $Recovery)) + (= ($catch-and-throw $Msg $_ $_) + (raise-exception $Msg)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Term unification ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - !(public (, (/ = 2) (/ %unify 2))) -; - - !(public (, (/ \= 2) (/ %not-unifiable 2))) -; - + !(public (, (/ = 2) (/ %unify 2))) + !(public (, (/ \= 2) (/ %not-unifiable 2))) - (= - (= $X $Y) - (= $X $Y)) -; - + (= (= $X $Y) + (= $X $Y)) - (= - ($unify $X $Y) - ($unify $X $Y)) -; - + (= ($unify $X $Y) + ($unify $X $Y)) - (= - (\= $X $Y) - (\= $X $Y)) -; - + (= (\= $X $Y) + (\= $X $Y)) - (= - ($not-unifiable $X $Y) - ($not-unifiable $X $Y)) -; - + (= ($not-unifiable $X $Y) + ($not-unifiable $X $Y)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Type testing ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - !(public (, (/ var 1) (/ is-symbol 1) (/ integer 1) (/ long 1) (/ float 1) (/ symbolic 1) (/ compound 1) (/ nonvar 1) (/ number 1))) -; - - !(public (, (/ java 1) (/ java 2) (/ closure 1))) -; - - !(public (, (/ ground 1) (/ callable 1))) -; - + !(public (, (/ var 1) (/ is-symbol 1) (/ integer 1) (/ long 1) (/ float 1) (/ symbolic 1) (/ compound 1) (/ nonvar 1) (/ number 1))) + !(public (, (/ java 1) (/ java 2) (/ closure 1))) + !(public (, (/ ground 1) (/ callable 1))) - (= - (var $X) - (var $X)) -; - + (= (var $X) + (var $X)) - (= - (atom $X) - (atom $X)) -; - + (= (atom $X) + (atom $X)) - (= - (integer $X) - (integer $X)) -; - + (= (integer $X) + (integer $X)) - (= - (long $X) - (long $X)) -; + (= (long $X) + (long $X)) + + (= (float $X) + (float $X)) - (= - (float $X) - (float $X)) -; + (= (atomic $X) + (atomic $X)) + + (= (nonvar $X) + (nonvar $X)) - (= - (atomic $X) - (atomic $X)) -; + (= (number $X) + (number $X)) + + (= (java $X) + (java $X)) + (= (java $X $Y) + (java $X $Y)) - (= - (nonvar $X) - (nonvar $X)) -; + (= (closure $X) + (closure $X)) + + (= (ground $X) + (ground $X)) - (= - (number $X) - (number $X)) -; + (= (compound $X) + (nonvar $X) + (functor $X $_ $A) + (> $A 0)) + + (= (callable $X) + (atom $X) + (set-det)) + (= (callable $X) + (compound $X) + (set-det)) + (= (callable $X) + (closure $X)) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Term comparison +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - (java $X) - (java $X)) -; + !(public (, (/ == 2) (/ %equality-of-term 2))) + !(public (, (/ \== 2) (/ %inequality-of-term 2))) + !(public (, (/ @< 2) (/ %before 2))) + !(public (, (/ @> 2) (/ %after 2))) + !(public (, (/ @=< 2) (/ %not-after 2))) + !(public (, (/ @>= 2) (/ %not-before 2))) + !(public (, (/ ?= 2) (/ %identical-or-cannot-unify 2))) + !(public (/ compare 3)) +; +; :- public sort/2. witten in Java +; +; :- public keysort/2. witten in Java +; +; :- public merge/3. - (= - (java $X $Y) - (java $X $Y)) -; + + (= (== $X $Y) + (== $X $Y)) + + (= ($equality-of-term $X $Y) + ($equality-of-term $X $Y)) + + (= (\== $X $Y) + (\== $X $Y)) + + (= ($inequality-of-term $X $Y) + ($inequality-of-term $X $Y)) - (= - (closure $X) - (closure $X)) -; + (= (@< $X $Y) + (@< $X $Y)) + + (= ($before $X $Y) + ($before $X $Y)) + + (= (@> $X $Y) + (@> $X $Y)) + + (= ($after $X $Y) + ($after $X $Y)) - (= - (ground $X) - (ground $X)) -; + (= (@=< $X $Y) + (@=< $X $Y)) + + (= ($not-after $X $Y) + ($not-after $X $Y)) + + (= (@>= $X $Y) + (@>= $X $Y)) + + (= ($not-before $X $Y) + ($not-before $X $Y)) - (= - (compound $X) - ( (nonvar $X) - (functor $X $_ $A) - (> $A 0))) -; + (= (?= $X $Y) + (?= $X $Y)) + + (= ($identical-or-cannot-unify $X $Y) + ($identical-or-cannot-unify $X $Y)) + + (= (compare $Op $X $Y) + ($compare0 $Op0 $X $Y) + ($map-compare-op $Op0 $Op)) - (= - (callable $X) - ( (atom $X) (set-det))) -; - - (= - (callable $X) - ( (compound $X) (set-det))) -; - - (= - (callable $X) - (closure $X)) -; - + (= ($map-compare-op $Op0 $Op) + (=:= $Op0 0) + (set-det) + (= $Op =)) + (= ($map-compare-op $Op0 $Op) + (< $Op0 0) + (set-det) + (= $Op <)) + (= ($map-compare-op $Op0 $Op) + (> $Op0 0) + (set-det) + (= $Op >)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Term creation and decomposition ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; :- public arg/3. --> written in Java +; +; :- public functor/3. --> written in Java - !(public (, (/ == 2) (/ %equality-of-term 2))) -; - - !(public (, (/ \== 2) (/ %inequality-of-term 2))) -; + !(public (/ =.. 2)) + !(public (/ copy-term 2)) - !(public (, (/ @< 2) (/ %before 2))) -; - - !(public (, (/ @> 2) (/ %after 2))) -; - - !(public (, (/ @=< 2) (/ %not-after 2))) -; - - !(public (, (/ @>= 2) (/ %not-before 2))) -; - - !(public (, (/ ?= 2) (/ %identical-or-cannot-unify 2))) -; + + (= (=.. $Term $List) + (=.. $Term $List)) - !(public (/ compare 3)) -; + + (= (copy-term $X $Y) + (copy-term $X $Y)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Arithmetic evaluation ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + !(public (/ is 2)) + !(public (, (/ %abs 2) (/ %asin 2) (/ %acos 2) (/ %atan 2))) + !(public (, (/ %bitwise-conj 3) (/ %bitwise-disj 3) (/ %bitwise-exclusive-or 3) (/ %bitwise-neg 2))) + !(public (, (/ %ceil 2) (/ %cos 2))) + !(public (/ %degrees 2)) + !(public (/ %exp 2)) + !(public (, (/ %float 2) (/ %float-integer-part 2) (/ %float-fractional-part 2) (/ %float-quotient 3) (/ %floor 2))) + !(public (/ %int-quotient 3)) + !(public (/ %log 2)) + !(public (, (/ %max 3) (/ %min 3) (/ %minus 3) (/ %mod 3) (/ %multi 3))) + !(public (, (/ %plus 3) (/ %pow 3))) + !(public (, (/ %radians 2) (/ %rint 2) (/ %round 2))) + !(public (, (/ %shift-left 3) (/ %shift-right 3) (/ %sign 2) (/ %sin 2) (/ %sqrt 2))) + !(public (, (/ %tan 2) (/ %truncate 2))) - (= - (== $X $Y) - (== $X $Y)) -; + (= (is $Z $Y) + (is $Z $Y)) - (= - ($equality-of-term $X $Y) - ($equality-of-term $X $Y)) -; - - + (= ($abs $X $Y) + ($abs $X $Y)) - (= - (\== $X $Y) - (\== $X $Y)) -; - + (= ($asin $X $Y) + ($asin $X $Y)) - (= - ($inequality-of-term $X $Y) - ($inequality-of-term $X $Y)) -; - - + (= ($acos $X $Y) + ($acos $X $Y)) - (= - (@< $X $Y) - (@< $X $Y)) -; - + (= ($atan $X $Y) + ($atan $X $Y)) - (= - ($before $X $Y) - ($before $X $Y)) -; - - + (= ($bitwise-conj $X $Y $Z) + ($bitwise-conj $X $Y $Z)) - (= - (@> $X $Y) - (@> $X $Y)) -; - + (= ($bitwise-disj $X $Y $Z) + ($bitwise-disj $X $Y $Z)) - (= - ($after $X $Y) - ($after $X $Y)) -; - - + (= ($bitwise-exclusive-or $X $Y $Z) + ($bitwise-exclusive-or $X $Y $Z)) - (= - (@=< $X $Y) - (@=< $X $Y)) -; - + (= ($bitwise-neg $X $Y) + ($bitwise-neg $X $Y)) - (= - ($not-after $X $Y) - ($not-after $X $Y)) -; - - + (= ($ceil $X $Y) + ($ceil $X $Y)) - (= - (@>= $X $Y) - (@>= $X $Y)) -; - + (= ($cos $X $Y) + ($cos $X $Y)) - (= - ($not-before $X $Y) - ($not-before $X $Y)) -; - - + (= ($degrees $X $Y) + ($degrees $X $Y)) - (= - (?= $X $Y) - (?= $X $Y)) -; - + (= ($exp $X $Y) + ($exp $X $Y)) - (= - ($identical-or-cannot-unify $X $Y) - ($identical-or-cannot-unify $X $Y)) -; - - + (= ($float $X $Y) + ($float $X $Y)) - (= - (compare $Op $X $Y) - ( ($compare0 $Op0 $X $Y) ($map-compare-op $Op0 $Op))) -; - - + (= ($float-integer-part $X $Y) + ($float-integer-part $X $Y)) - (= - ($map-compare-op $Op0 $Op) - ( (=:= $Op0 0) - (set-det) - (= $Op =))) -; - - (= - ($map-compare-op $Op0 $Op) - ( (< $Op0 0) - (set-det) - (= $Op <))) -; - - (= - ($map-compare-op $Op0 $Op) - ( (> $Op0 0) - (set-det) - (= $Op >))) -; - - -; -; + (= ($float-fractional-part $X $Y) + ($float-fractional-part $X $Y)) -; -; + (= ($float-quotient $X $Y $Z) + ($float-quotient $X $Y $Z)) -; -; + (= ($floor $X $Y) + ($floor $X $Y)) -; -; + (= ($int-quotient $X $Y $Z) + ($int-quotient $X $Y $Z)) -; -; + (= ($log $X $Y) + ($log $X $Y)) + (= ($max $X $Y $Z) + ($max $X $Y $Z)) - !(public (/ =.. 2)) -; - - !(public (/ copy-term 2)) -; - - + (= ($min $X $Y $Z) + ($min $X $Y $Z)) - (= - (=.. $Term $List) - (=.. $Term $List)) -; - - + (= ($minus $X $Y $Z) + ($minus $X $Y $Z)) - (= - (copy-term $X $Y) - (copy-term $X $Y)) -; - - -; -; + (= ($mod $X $Y $Z) + ($mod $X $Y $Z)) -; -; + (= ($multi $X $Y $Z) + ($multi $X $Y $Z)) -; -; + (= ($plus $X $Y $Z) + ($plus $X $Y $Z)) + (= ($pow $X $Y $Z) + ($pow $X $Y $Z)) - !(public (/ is 2)) -; - - !(public (, (/ %abs 2) (/ %asin 2) (/ %acos 2) (/ %atan 2))) -; - - !(public (, (/ %bitwise-conj 3) (/ %bitwise-disj 3) (/ %bitwise-exclusive-or 3) (/ %bitwise-neg 2))) -; - - !(public (, (/ %ceil 2) (/ %cos 2))) -; - - !(public (/ %degrees 2)) -; - - !(public (/ %exp 2)) -; - - !(public (, (/ %float 2) (/ %float-integer-part 2) (/ %float-fractional-part 2) (/ %float-quotient 3) (/ %floor 2))) -; - - !(public (/ %int-quotient 3)) -; - - !(public (/ %log 2)) -; - - !(public (, (/ %max 3) (/ %min 3) (/ %minus 3) (/ %mod 3) (/ %multi 3))) -; - - !(public (, (/ %plus 3) (/ %pow 3))) -; - - !(public (, (/ %radians 2) (/ %rint 2) (/ %round 2))) -; - - !(public (, (/ %shift-left 3) (/ %shift-right 3) (/ %sign 2) (/ %sin 2) (/ %sqrt 2))) -; - - !(public (, (/ %tan 2) (/ %truncate 2))) -; - - + (= ($radians $X $Y) + ($radians $X $Y)) - (= - (is $Z $Y) - (is $Z $Y)) -; - - + (= ($rint $X $Y) + ($rint $X $Y)) - (= - ($abs $X $Y) - ($abs $X $Y)) -; - + (= ($round $X $Y) + ($round $X $Y)) - (= - ($asin $X $Y) - ($asin $X $Y)) -; - + (= ($shift-left $X $Y $Z) + ($shift-left $X $Y $Z)) - (= - ($acos $X $Y) - ($acos $X $Y)) -; - + (= ($shift-right $X $Y $Z) + ($shift-right $X $Y $Z)) - (= - ($atan $X $Y) - ($atan $X $Y)) -; - + (= ($sign $X $Y) + ($sign $X $Y)) - (= - ($bitwise-conj $X $Y $Z) - ($bitwise-conj $X $Y $Z)) -; - + (= ($sin $X $Y) + ($sin $X $Y)) - (= - ($bitwise-disj $X $Y $Z) - ($bitwise-disj $X $Y $Z)) -; - + (= ($sqrt $X $Y) + ($sqrt $X $Y)) - (= - ($bitwise-exclusive-or $X $Y $Z) - ($bitwise-exclusive-or $X $Y $Z)) -; - + (= ($tan $X $Y) + ($tan $X $Y)) - (= - ($bitwise-neg $X $Y) - ($bitwise-neg $X $Y)) -; + (= ($truncate $X $Y) + ($truncate $X $Y)) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Arithmetic comparison +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - ($ceil $X $Y) - ($ceil $X $Y)) -; + !(public (, (/ =:= 2) (/ %arith-equal 2))) + !(public (, (/ =\= 2) (/ %arith-not-equal 2))) + !(public (, (/ < 2) (/ %less-than 2))) + !(public (, (/ =< 2) (/ %less-or-equal 2))) + !(public (, (/ > 2) (/ %greater-than 2))) + !(public (, (/ >= 2) (/ %greater-or-equal 2))) - (= - ($cos $X $Y) - ($cos $X $Y)) -; - + (= (=:= $X $Y) + (=:= $X $Y)) - (= - ($degrees $X $Y) - ($degrees $X $Y)) -; + (= ($arith-equal $X $Y) + ($arith-equal $X $Y)) - (= - ($exp $X $Y) - ($exp $X $Y)) -; + (= (=\= $X $Y) + (=\= $X $Y)) + + (= ($arith-not-equal $X $Y) + ($arith-not-equal $X $Y)) - (= - ($float $X $Y) - ($float $X $Y)) -; + (= (< $X $Y) + (< $X $Y)) + + (= ($less-than $X $Y) + ($less-than $X $Y)) - (= - ($float-integer-part $X $Y) - ($float-integer-part $X $Y)) -; + (= (=< $X $Y) + (=< $X $Y)) + + (= ($less-or-equal $X $Y) + ($less-or-equal $X $Y)) - (= - ($float-fractional-part $X $Y) - ($float-fractional-part $X $Y)) -; + (= (> $X $Y) + (> $X $Y)) + + (= ($greater-than $X $Y) + ($greater-than $X $Y)) - (= - ($float-quotient $X $Y $Z) - ($float-quotient $X $Y $Z)) -; + (= (>= $X $Y) + (>= $X $Y)) + + (= ($greater-or-equal $X $Y) + ($greater-or-equal $X $Y)) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Clause retrieval and information +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - ($floor $X $Y) - ($floor $X $Y)) -; + !(public (/ clause 2)) + !(public (/ initialization 2)) + !(public (/ %new-indexing-hash 3)) - (= - ($int-quotient $X $Y $Z) - ($int-quotient $X $Y $Z)) -; + (= (== (= $Head $B) (get-atoms &self)) + ($head-to-term $Head $H + (with_self $P $PI) + (== + (= $Head $B) + (get-atoms &self))) + ($new-internal-database $P) + ($check-procedure-permission + (with_self $P $PI) access private-procedure + (== + (= $Head $B) + (get-atoms &self))) + ($clause-internal $P $PI $H $Cl $_) + (copy-term $Cl + (= $H $B))) +; ;(ground(Cl) -> Cl = (H :- B) ; copy_term(Cl, (H :- B))). ??? + +; +; head --> term + + (= ($head-to-term $H $T (with_self $Pkg (/ $F $A)) $Goal) + ($head-to-term $H $T user $Pkg $Goal) + (functor $T $F $A)) + + (= ($head-to-term $H $_ $_ $_ $Goal) + (var $H) + (set-det) + (illarg var $Goal 1)) + (= ($head-to-term (with_self $P $H) $T $_ $Pkg $Goal) + (set-det) + ($head-to-term $H $T $P $Pkg $Goal)) + (= ($head-to-term $H $H $Pkg $Pkg $_) + (callable $H) + (atom $Pkg) + (set-det)) + (= ($head-to-term $_ $_ $_ $_ $Goal) + (illarg + (type callable) $Goal 1)) +; +; creates an internal database for A if no exists. - (= - ($log $X $Y) - ($log $X $Y)) -; + (= ($new-internal-database $A) + (atom $A) + ($get-hash-manager $HM) + ($new-internal-database $HM $A)) + + (= ($new-internal-database $HM $A) + (hash-contains-key $HM $A) + (set-det)) + (= ($new-internal-database $_ $A) + (new-hash $_ + (:: (alias $A))) + ($init-internal-database $A)) - (= - ($max $X $Y $Z) - ($max $X $Y $Z)) -; + (= ($init-internal-database $A) + ($compiled-predicate $A %init 0) + (findall $_ + (with_self $A + (%init)) $_) + (set-det)) + (= (%init_internal_database $_) True) +; +; checks if the internal database of A exists. - (= - ($min $X $Y $Z) - ($min $X $Y $Z)) -; + (= ($defined-internal-database $A) + (atom $A) + ($get-hash-manager $HM) + (hash-contains-key $HM $A)) +; +; repeatedly finds dynamic clauses. - (= - ($minus $X $Y $Z) - ($minus $X $Y $Z)) -; + (= ($clause-internal $P $PI $H $Cl $Ref) + (hash-contains-key $P $PI) + ($get-indices $P $PI $H $RevRefs) + ($get-instances $RevRefs $Cls_Refs) + ($clause-internal0 $Cls_Refs $Cl $Ref)) +; ; ??? +; ;length(Cls_Refs,N), +; ;'$fast_write'([clause_internal,N,for,P,PI]),nl, +; ; - (= - ($mod $X $Y $Z) - ($mod $X $Y $Z)) -; + (= (%clause_internal0 () $_ $_) + (empty)) + (= ($clause-internal0 (:: (, $Cl $Ref)) $Cl $Ref) + (set-det)) + (= ($clause-internal0 $L $Cl $Ref) + ($builtin-member + (, $Cl $Ref) $L)) + + + (= ($get-indices $P $PI $H $Refs) + ($new-indexing-hash $P $PI $IH) + ($calc-indexing-key $H $Key) + (det-if-then-else + (hash-contains-key $IH $Key) + (hash-get $IH $Key $Refs) + (hash-get $IH var $Refs))) + +; +; finds the indexing hashtable for P:PI. creates it if no exist. + + (= ($new-indexing-hash $P $PI $IH) + (hash-contains-key $P $PI) + (set-det) + (hash-get $P $PI $IH)) + (= ($new-indexing-hash $P $PI $IH) + (new-hash $IH) + (hash-put $IH all Nil) + (hash-put $IH var Nil) + (hash-put $IH lis Nil) + (hash-put $IH str Nil) + (hash-put $P $PI $IH)) + + + (= ($calc-indexing-key $H all) + (atom $H) + (set-det)) + (= ($calc-indexing-key $H $Key) + (arg 1 $H $A1) + ($calc-indexing-key0 $A1 $Key)) + + + (= ($calc-indexing-key0 $A1 all) + (var $A1) + (set-det)) + (= ($calc-indexing-key0 $A1 lis) + (= $A1 + (Cons $_ $_)) + (set-det)) + (= ($calc-indexing-key0 $A1 str) + (compound $A1) + (set-det)) + (= ($calc-indexing-key0 $A1 $Key) + (ground $A1) + (set-det) + ($term-hash $A1 $Key)) + (= ($calc-indexing-key0 $A1 $Key) + (illarg + (type term) + ($calc-indexing-key0 $A1 $Key) 1)) +; +; checks the permission of predicate P:F/A. - (= - ($multi $X $Y $Z) - ($multi $X $Y $Z)) -; + (= ($check-procedure-permission (with_self $P (/ $F $A)) $Operation $ObjType $Goal) + (hash-contains-key $P + (/ $F $A)) + (set-det)) + (= ($check-procedure-permission (with_self $P (/ $F $A)) $Operation $ObjType $Goal) + ($compiled-predicate-or-builtin $P $F $A) + (set-det) + (illarg + (permission $Operation $ObjType + (with_self $P + (/ $F $A)) $_) $Goal $_)) + (= (%check_procedure_permission $_ $_ $_ $_) True) +; +; initialize internal databases of given packages. - (= - ($plus $X $Y $Z) - ($plus $X $Y $Z)) -; + (= (initialization Nil $Goal) + (set-det) + (once $Goal)) + (= (initialization (Cons $P $Ps) $Goal) + ($new-internal-database $P) + (initialization $Ps $Goal)) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Clause creation and destruction +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - ($pow $X $Y $Z) - ($pow $X $Y $Z)) -; + !(public (/ assert 1)) + !(public (/ assertz 1)) + !(public (/ asserta 1)) + !(public (/ retract 1)) + !(public (/ abolish 1)) + !(public (/ retractall 1)) - (= - ($radians $X $Y) - ($radians $X $Y)) -; + (= (add-is-symbol &self $T) + (add-is-symbol &self $T)) - (= - ($rint $X $Y) - ($rint $X $Y)) -; + (= (add-is-symbol &self $T) + ($term-to-clause $T $Cl + (with_self $P $PI) + (add-is-symbol &self $T)) + ($new-internal-database $P) + ($check-procedure-permission + (with_self $P $PI) modify static-procedure + (add-is-symbol &self $T)) + (copy-term $Cl $NewCl) + ($insert $NewCl $Ref) + ($update-indexing $P $PI $Cl $Ref z) + (fail)) +; ;'$fast_write'([intert,NewCl,Ref]), nl, ;??? + (= (assertz $_) True) + + + (= (add-is-symbol &self $T) + ($term-to-clause $T $Cl + (with_self $P $PI) + (add-is-symbol &self $T)) + ($new-internal-database $P) + ($check-procedure-permission + (with_self $P $PI) modify static-procedure + (add-is-symbol &self $T)) + (copy-term $Cl $NewCl) + ($insert $NewCl $Ref) + ($update-indexing $P $PI $Cl $Ref a) + (fail)) +; ;'$fast_write'([insert,NewCl,Ref]), nl, ;??? + (= (asserta $_) True) - (= - ($round $X $Y) - ($round $X $Y)) -; + (= (abolish $T) + ($term-to-predicateindicator $T + (with_self $P $PI) + (abolish $T)) + ($new-internal-database $P) + ($check-procedure-permission + (with_self $P $PI) modify static-procedure + (abolish $T)) + ($new-indexing-hash $P $PI $IH) + (hash-get $IH all $Refs) + ($erase-all $Refs) + (hash-remove $P $PI) + (fail)) +; ;'$fast_write'([erase_all,Refs]), nl, ;??? + (= (abolish $_) True) + + + (= (remove-is-symbol &self $Cl) + ($clause-to-term $Cl $T + (with_self $P $PI) + (remove-is-symbol &self $Cl)) + ($new-internal-database $P) + ($check-procedure-permission + (with_self $P $PI) access static-procedure + (remove-is-symbol &self $Cl)) + (= $T + (= $H $_)) + ($clause-internal $P $PI $H $Cl0 $Ref) + (copy-term $Cl0 $T) + ($erase $Ref) + ($rehash-indexing $P $PI $Ref)) +; ;'$fast_write'([erase,Cl0,Ref]), nl, ;??? + + + (= (remove-all-atoms &self $Head) + ($head-to-term $Head $H + (with_self $P $PI) + (remove-all-atoms &self $Head)) + ($new-internal-database $P) + ($check-procedure-permission + (with_self $P $PI) access static-procedure + (remove-all-atoms &self $Head)) + ($clause-internal $P $PI $H $Cl $Ref) + (copy-term $Cl + (= $H $_)) + ($erase $Ref) + ($rehash-indexing $P $PI $Ref) + (fail)) +; ;'$fast_write'([erase,Cl,Ref]), nl, ;??? + (= (retractall $_) True) + +; +; term --> clause (for assert) + + (= ($term-to-clause $Cl0 $Cl (with_self $Pkg (/ $F $A)) $Goal) + ($term-to-clause $Cl0 $Cl user $Pkg $Goal) + (= $Cl + (= $H $_)) + (functor $H $F $A)) + + (= ($term-to-clause $Cl0 $_ $_ $_ $Goal) + (var $Cl0) + (set-det) + (illarg var $Goal 1)) + (= ($term-to-clause $_ $_ $Pkg0 $_ $Goal) + (var $Pkg0) + (set-det) + (illarg var $Goal 1)) + (= ($term-to-clause (with_self $P $Cl0) $Cl $_ $Pkg $Goal) + (set-det) + ($term-to-clause $Cl0 $Cl $P $Pkg $Goal)) + (= ($term-to-clause $_ $_ $Pkg0 $_ $Goal) + (not (atom $Pkg0)) + (set-det) + (illarg + (type is-symbol) $Goal 1)) + (= ($term-to-clause (= $H0 $B0) (= $H $B) $Pkg $Pkg $Goal) + (set-det) + ($term-to-head $H0 $H $Pkg $Goal) + ($term-to-body $B0 $B $Pkg $Goal)) + (= ($term-to-clause $H0 (= $H True) $Pkg $Pkg $Goal) + ($term-to-head $H0 $H $Pkg $Goal)) + + + (= ($term-to-head $H $H $_ $_) + (atom $H) + (set-det)) + (= ($term-to-head $H $H $_ $_) + (compound $H) + (set-det)) + (= ($term-to-head $_ $_ $_ $Goal) + (illarg + (type callable) $Goal 1)) - (= - ($shift-left $X $Y $Z) - ($shift-left $X $Y $Z)) -; + (= ($term-to-body $B0 $B $Pkg $_) + ($localize-body $B0 $Pkg $B)) - (= - ($shift-right $X $Y $Z) - ($shift-right $X $Y $Z)) -; + (= ($localize-body $G $P $G1) + (var $G) + (set-det) + ($localize-body + (call $G) $P $G1)) + (= ($localize-body (with_self $P $G) $_ $G1) + (set-det) + ($localize-body $G $P $G1)) + (= ($localize-body (, $X $Y) $P (, $X1 $Y1)) + (set-det) + ($localize-body $X $P $X1) + ($localize-body $Y $P $Y1)) + (= ($localize-body (det-if-then $X $Y) $P (det-if-then $X1 $Y1)) + (set-det) + ($localize-body $X $P $X1) + ($localize-body $Y $P $Y1)) + (= ($localize-body (or $X $Y) $P (or $X1 $Y1)) + (set-det) + ($localize-body $X $P $X1) + ($localize-body $Y $P $Y1)) + (= ($localize-body $G $P $G1) + (functor $G $F $A) + ($builtin-meta-predicates $F $A $M) + (set-det) + (=.. $G + (Cons $F $As)) + ($localize-args $M $As $P $As1) + (=.. $G1 + (Cons $F $As1))) +; ;??? + (= ($localize-body $G $P (call (with_self $P $G))) + (var $P) + (set-det)) + (= ($localize-body $G user $G) + (set-det)) + (= ($localize-body $G $_ $G) + (system-predicate $G) + (set-det)) + (= (%localize_body $G $P (: $P $G)) True) + + + (= ($localize-args Nil Nil $_ Nil) + (set-det)) + (= ($localize-args (Cons : $Ms) (Cons $A $As) $P (Cons (with_self $P $A) $As1)) + (or + (var $A) + (\= $A + (with_self $_ $_))) + (set-det) + ($localize-args $Ms $As $P $As1)) + (= ($localize-args (Cons $_ $Ms) (Cons $A $As) $P (Cons $A $As1)) + ($localize-args $Ms $As $P $As1)) + + + (= (%builtin_meta_predicates ^ 2 (? :)) True) + (= (%builtin_meta_predicates call 1 (:)) True) + (= (%builtin_meta_predicates once 1 (:)) True) + (= (%builtin_meta_predicates \+ 1 (:)) True) + (= (%builtin_meta_predicates findall 3 (? : ?)) True) + (= (%builtin_meta_predicates setof 3 (? : ?)) True) + (= (%builtin_meta_predicates bagof 3 (? : ?)) True) + (= (%builtin_meta_predicates on_exception 3 (? : :)) True) + (= (%builtin_meta_predicates catch 3 (: ? :)) True) + (= (%builtin_meta_predicates synchronized 2 (? :)) True) + (= (%builtin_meta_predicates freeze 2 (? :)) True) + +; +; clause --> term (for retract) + + (= ($clause-to-term $Cl $T (with_self $Pkg (/ $F $A)) $Goal) + ($clause-to-term $Cl $T user $Pkg $Goal) + (= $T + (= $H $_)) + (functor $H $F $A)) + + (= ($clause-to-term $Cl $_ $_ $_ $Goal) + (var $Cl) + (set-det) + (illarg var $Goal 1)) + (= ($clause-to-term $_ $_ $Pkg $_ $Goal) + (var $Pkg) + (set-det) + (illarg var $Goal 1)) + (= ($clause-to-term (with_self $P $Cl) $T $_ $Pkg $Goal) + (set-det) + ($clause-to-term $Cl $T $P $Pkg $Goal)) + (= ($clause-to-term $_ $_ $Pkg $_ $Goal) + (not (atom $Pkg)) + (set-det) + (illarg + (type is-symbol) $Goal 1)) + (= ($clause-to-term (= $H0 $B) (= $H $B) $Pkg $Pkg $Goal) + (set-det) + ($head-to-term $H0 $H $_ $Goal)) + ; +; '$body_to_term'(B0, B, Goal). + (= ($clause-to-term $H0 (= $H True) $Pkg $Pkg $Goal) + ($head-to-term $H0 $H $_ $Goal)) + +; +; term --> predicate indicator (for abolish) + + (= ($term-to-predicateindicator $T (with_self $Pkg $PI) $Goal) + ($term-to-predicateindicator $T $PI user $Pkg $Goal)) + + (= ($term-to-predicateindicator $T $_ $_ $_ $Goal) + (var $T) + (set-det) + (illarg var $Goal 1)) + (= ($term-to-predicateindicator $_ $_ $Pkg $_ $Goal) + (var $Pkg) + (set-det) + (illarg var $Goal 1)) + (= ($term-to-predicateindicator (with_self $P $T) $PI $_ $Pkg $Goal) + (set-det) + ($term-to-predicateindicator $T $PI $P $Pkg $Goal)) + (= ($term-to-predicateindicator $T $_ $_ $_ $Goal) + (\= $T + (/ $_ $_)) + (set-det) + (illarg + (type predicate-indicator) $Goal 1)) + (= ($term-to-predicateindicator (/ $F $_) $_ $_ $_ $Goal) + (not (atom $F)) + (set-det) + (illarg + (type is-symbol) $Goal 1)) + (= ($term-to-predicateindicator (/ $_ $A) $_ $_ $_ $Goal) + (not (integer $A)) + (set-det) + (illarg + (type integer) $Goal 1)) + (= (%term_to_predicateindicator $T $T $Pkg $Pkg $_) True) + + + (= ($update-indexing $P $PI $Cl $Ref $A_or_Z) + ($new-indexing-hash $P $PI $IH) + ($gen-indexing-keys $Cl $IH $Keys) + ($update-indexing-hash $A_or_Z $Keys $IH $Ref)) +; ;'$fast_write'([update_indexing,P,PI,Cl,Ref,Keys]), nl, ;??? + + + (= ($gen-indexing-keys (= $H $_) $_ (:: all)) + (atom $H) + (set-det)) + (= ($gen-indexing-keys (= $H $_) $IT $Keys) + (arg 1 $H $A1) + ($gen-indexing-keys0 $A1 $IT $Keys)) + + + (= ($gen-indexing-keys0 $A1 $IT $Keys) + (var $A1) + (set-det) + (hash-keys $IT $Keys)) + (= ($gen-indexing-keys0 $A1 $_ (:: all lis)) + (= $A1 + (Cons $_ $_)) + (set-det)) + (= ($gen-indexing-keys0 $A1 $_ (:: all str)) + (compound $A1) + (set-det)) + (= ($gen-indexing-keys0 $A1 $IT (:: all $Key)) + (ground $A1) + (set-det) + ($term-hash $A1 $Key) + (det-if-then-else + (hash-contains-key $IT $Key) True + (, + (hash-get $IT var $L) + (hash-put $IT $Key $L)))) +; ; get the hash code of A1 + (= ($gen-indexing-keys0 $A1 $IT $Keys) + (illarg + (type term) + ($gen-indexing-keys0 $A1 $IT $Keys) 1)) - (= - ($sign $X $Y) - ($sign $X $Y)) -; + (= ($update-indexing-hash a $Keys $IH $Ref) + (set-det) + ($hash-addz-all $Keys $IH $Ref)) + (= ($update-indexing-hash z $Keys $IH $Ref) + (set-det) + ($hash-adda-all $Keys $IH $Ref)) - (= - ($sin $X $Y) - ($sin $X $Y)) -; + (= ($hash-adda-all Nil $_ $_) + (set-det)) + (= ($hash-adda-all (Cons $K $Ks) $H $X) + ($hash-adda $H $K $X) + ($hash-adda-all $Ks $H $X)) - (= - ($sqrt $X $Y) - ($sqrt $X $Y)) -; + (= ($hash-addz-all Nil $_ $_) + (set-det)) + (= ($hash-addz-all (Cons $K $Ks) $H $X) + ($hash-addz $H $K $X) + ($hash-addz-all $Ks $H $X)) - (= - ($tan $X $Y) - ($tan $X $Y)) -; + (= ($erase-all Nil) + (set-det)) + (= ($erase-all (Cons $R $Rs)) + ($erase $R) + ($erase-all $Rs)) - (= - ($truncate $X $Y) - ($truncate $X $Y)) -; + (= ($rehash-indexing $P $PI $Ref) + ($new-indexing-hash $P $PI $IH) + (hash-keys $IH $Keys) + ($remove-index-all $Keys $IH $Ref)) +; ;'$fast_write'([rehash_indexing,P,PI,Keys]), nl, ;??? + + (= ($remove-index-all Nil $_ $_) + (set-det)) + (= ($remove-index-all (Cons $K $Ks) $IH $Ref) + ($hash-remove-first $IH $K $Ref) + ($remove-index-all $Ks $IH $Ref)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; All solutions ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - !(public (, (/ =:= 2) (/ %arith-equal 2))) -; - - !(public (, (/ =\= 2) (/ %arith-not-equal 2))) -; - - !(public (, (/ < 2) (/ %less-than 2))) -; - - !(public (, (/ =< 2) (/ %less-or-equal 2))) -; - - !(public (, (/ > 2) (/ %greater-than 2))) -; - - !(public (, (/ >= 2) (/ %greater-or-equal 2))) -; - + !(public (/ findall 3)) + !(public (/ bagof 3)) + !(public (/ setof 3)) +; +; findall/3 - (= - (=:= $X $Y) - (=:= $X $Y)) -; + (= (findall $Template $Goal $Instances) + (callable $Goal) + (set-det) + (new-hash $H) + ($findall $H $Template $Goal $Instances)) + (= (findall $Template $Goal $Instances) + (illarg + (type callable) + (findall $Template $Goal $Instances) 2)) - (= - ($arith-equal $X $Y) - ($arith-equal $X $Y)) -; + (= ($findall $H $Template $Goal $_) + (call $Goal) + (copy-term $Template $CT) + ($hash-addz $H %FINDALL $CT) + (fail)) + (= ($findall $H $_ $_ $Instances) + (hash-get $H %FINDALL $Instances)) +; +; bagof/3 & setof/3 + + (= (bagof $Template $Goal $Instances) + (callable $Goal) + (set-det) + ($bagof $Template $Goal $Instances)) + (= (bagof $Template $Goal $Instances) + (illarg + (type callable) + (bagof $Template $Goal $Instances) 2)) - (= - (=\= $X $Y) - (=\= $X $Y)) -; - - - (= - ($arith-not-equal $X $Y) - ($arith-not-equal $X $Y)) -; - - + (= (setof $Template $Goal $Instances) + (callable $Goal) + (set-det) + ($bagof $Template $Goal $Instances0) + (sort $Instances0 $Instances)) + (= (setof $Template $Goal $Instances) + (illarg + (type callable) + (setof $Template $Goal $Instances) 2)) + + + (= ($bagof $Template $Goal $Instances) + ($free-variables-set $Goal $Template $FV) + (\== $FV Nil) + (set-det) + (=.. $Witness + (Cons %witness $FV)) + (findall + (+ $Witness $Template) $Goal $S) + ($bagof-instances $S $Witness $Instances0) + (= $Instances $Instances0)) +; ;write('Goal = '), write(Goal), nl, +; ;write('Free variables set = '), write(FV), nl, + (= ($bagof $Template $Goal $Instances) + (findall $Template $Goal $Instances) + (\== $Instances Nil)) + + + (= (%bagof_instances () $Witness $Instances) + (empty)) + (= ($bagof-instances $S0 $Witness $Instances) + (= $S0 + (Cons + (+ $W $T) $S)) + ($variants-subset $S $W $WT_list $T_list $S_next) + ($bagof-instances0 $S_next $Witness $Instances + (Cons + (+ $W $T) $WT_list) + (Cons $T $T_list))) + + + (= ($bagof-instances0 $_ $Witness $Instances $WT_list $T_list) + ($unify-witness $WT_list $Witness) + (= $Instances $T_list)) + (= ($bagof-instances0 $S_next $Witness $Instances $_ $_) + ($bagof-instances $S_next $Witness $Instances)) + + + (= ($variants-subset Nil $W Nil Nil Nil) + (set-det)) + (= ($variants-subset (Cons (+ $W0 $T0) $S) $W (Cons (+ $W0 $T0) $WT_list) (Cons $T0 $T_list) $S_next) + ($term-variant $W $W0) + (set-det) + ($variants-subset $S $W $WT_list $T_list $S_next)) + (= ($variants-subset (Cons $WT $S) $W $WT_list $T_list (Cons $WT $S_next)) + ($variants-subset $S $W $WT_list $T_list $S_next)) + + + (= ($term-variant $X $Y) + (new-hash $Hash) + ($term-variant $X $Y $Hash)) + + (= ($term-variant $X $Y $Hash) + (var $X) + (set-det) + (det-if-then-else + (hash-contains-key $Hash $X) + (, + (hash-get $Hash $X $V) + (== $Y $V)) + (, + (var $Y) + (hash-put $Hash $X $Y)))) + (= ($term-variant $X $Y $_) + (ground $X) + (set-det) + (== $X $Y)) + (= ($term-variant $_ $Y $_) + (var $Y) + (set-det) + (fail)) + (= ($term-variant (Cons $X $Xs) (Cons $Y $Ys) $Hash) + (set-det) + ($term-variant $X $Y $Hash) + ($term-variant $Xs $Ys $Hash)) + (= ($term-variant $X $Y $Hash) + (=.. $X $Xs) + (=.. $Y $Ys) + ($term-variant $Xs $Ys $Hash)) + + + (= ($unify-witness Nil $_) + (set-det)) + (= ($unify-witness (Cons (+ $W $_) $WT_list) $W) + ($unify-witness $WT_list $W)) + +; +; Variable set of a term + + (= ($variables-set $X $Vs) + ($variables-set $X Nil $Vs)) + + (= ($variables-set $X $Vs $Vs) + (var $X) + ($builtin-memq $X $Vs) + (set-det)) + (= ($variables-set $X $Vs (Cons $X $Vs)) + (var $X) + (set-det)) + (= ($variables-set $X $Vs0 $Vs0) + (atomic $X) + (set-det)) + (= ($variables-set (Cons $X $Xs) $Vs0 $Vs) + (set-det) + ($variables-set $X $Vs0 $Vs1) + ($variables-set $Xs $Vs1 $Vs)) + (= ($variables-set $X $Vs0 $Vs) + (=.. $X $Xs) + ($variables-set $Xs $Vs0 $Vs)) + + + (= ($builtin-memq $X (Cons $Y $_)) + (== $X $Y) + (set-det)) + (= ($builtin-memq $X (Cons $_ $Ys)) + ($builtin-memq $X $Ys)) + +; +; Existential variables set of a term + + (= ($existential-variables-set $X $Vs) + ($existential-variables-set $X Nil $Vs)) + + (= ($existential-variables-set $X $Vs $Vs) + (var $X) + (set-det)) + (= ($existential-variables-set $X $Vs $Vs) + (atomic $X) + (set-det)) + (= ($existential-variables-set (with_self $_ $X) $Vs0 $Vs) + (set-det) + ($existential-variables-set $X $Vs0 $Vs)) +; +; '$existential_variables_set'((X;Y), Vs0, Vs) :- !, +; +; '$existential_variables_set'(X, Vs0, Vs1), +; +; '$existential_variables_set'(Y, Vs1, Vs). +; +; '$existential_variables_set'((X->Y), Vs0, Vs) :- !, +; +; '$existential_variables_set'(X, Vs0, Vs1), +; +; '$existential_variables_set'(Y, Vs1, Vs). +; +; '$existential_variables_set'((X,Y), Vs0, Vs) :- !, +; +; '$existential_variables_set'(X, Vs0, Vs1), +; +; '$existential_variables_set'(Y, Vs1, Vs). + (= ($existential-variables-set (^ $V $G) $Vs0 $Vs) + (set-det) + ($variables-set $V $Vs0 $Vs1) + ($existential-variables-set $G $Vs1 $Vs)) + (= ($existential-variables-set ($meta-call $G $_ $_ $_ $_) $Vs0 $Vs) + (set-det) + ($existential-variables-set $G $Vs0 $Vs)) +; ;??? + (= (%existential_variables_set $_ $Vs $Vs) True) + +; +; Free variables set of a term + + (= ($free-variables-set $T $V $FV) + ($variables-set $T $TV) + ($variables-set $V $VV) + ($existential-variables-set $T $VV $BV) + ($builtin-set-diff $TV $BV $FV) + (set-det)) + + + (= ($builtin-set-diff $L1 $L2 $L) + (sort $L1 $SL1) + (sort $L2 $SL2) + ($builtin-set-diff0 $SL1 $SL2 $L)) + - (= - (< $X $Y) - (< $X $Y)) -; + (= ($builtin-set-diff0 Nil $_ Nil) + (set-det)) + (= ($builtin-set-diff0 $L1 Nil $L1) + (set-det)) + (= ($builtin-set-diff0 (Cons $X $Xs) (Cons $Y $Ys) $L) + (== $X $Y) + (set-det) + ($builtin-set-diff0 $Xs $Ys $L)) + (= ($builtin-set-diff0 (Cons $X $Xs) (Cons $Y $Ys) (Cons $X $L)) + (@< $X $Y) + (set-det) + ($builtin-set-diff0 $Xs + (Cons $Y $Ys) $L)) + (= ($builtin-set-diff0 (Cons $X $Xs) (Cons $Y $Ys) (Cons $Y $L)) + ($builtin-set-diff0 + (Cons $X $Xs) $Ys + (Cons $Y $L))) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Stream selection and control +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; :- public current_input/1 (written in Java) +; +; :- public current_output/1 (written in Java) +; +; :- public set_input/1, set_output/1. (written in Java) +; +; :- public open/4 (written in Java) - (= - ($less-than $X $Y) - ($less-than $X $Y)) -; - + !(public (/ open 3)) +; +; :- public close/2 (written in Java) + !(public (/ close 1)) +; +; :- public flush_output/1.(written in Java) + !(public (/ flush-output 0)) + !(public (/ stream-property 2)) - (= - (=< $X $Y) - (=< $X $Y)) -; + (= (open $Source_sink $Mode $Stream) + (open $Source_sink $Mode $Stream Nil)) - (= - ($less-or-equal $X $Y) - ($less-or-equal $X $Y)) -; - + (= (close $S_or_a) + (close $S_or_a Nil)) - (= - (> $X $Y) - (> $X $Y)) -; + (= (flush-output) + (current-output $S) + (flush-output $S)) - (= - ($greater-than $X $Y) - ($greater-than $X $Y)) -; - + (= (stream-property $Stream $Stream_property) + (var $Stream_property) + (set-det) + ($stream-property $Stream $Stream_property)) + (= (stream-property $Stream $Stream_property) + ($stream-property-specifier $Stream_property) + (set-det) + ($stream-property $Stream $Stream_property)) + (= (stream-property $Stream $Stream_property) + (illarg + (domain term stream-property) + (stream-property $Stream $Stream_property) 2)) - (= - (>= $X $Y) - (>= $X $Y)) -; + (= ($stream-property $Stream $Stream_property) + (var $Stream) + (set-det) + ($get-stream-manager $SM) + (hash-map $SM $Map) + ($builtin-member + (, $Stream $Vs) $Map) + (java $Stream) + ($builtin-member $Stream_property $Vs)) + (= ($stream-property $Stream $Stream_property) + (java $Stream) + (set-det) + ($get-stream-manager $SM) + (hash-get $SM $Stream $Vs) + ($builtin-member $Stream_property $Vs)) + (= ($stream-property $Stream $Stream_property) + (illarg + (domain stream stream) + (stream-property $Stream $Stream_property) 1)) - (= - ($greater-or-equal $X $Y) - ($greater-or-equal $X $Y)) -; - + (= (%stream_property_specifier input) True) + (= (%stream_property_specifier output) True) + (= (%stream_property_specifier (alias $_)) True) + (= (%stream_property_specifier (mode $_)) True) + (= (%stream_property_specifier (type $_)) True) + (= (%stream_property_specifier (file_name $_)) True) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Character input/output ; -; - - - !(public (/ clause 2)) -; - - !(public (/ initialization 2)) -; - - !(public (/ %new-indexing-hash 3)) -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; :- public get_char/2, get_code/2. (written in Java) +; +; :- public peek_char/2, peek_code/2. (written in Java) +; +; :- public put_char/2, put_code/2. (written in Java) +; +; :- public nl/0. (written in Java) - (= - (get-symbols &self - (= $Head $B)) - ( ($head-to-term $Head $H - (with_self $P $PI) - (get-symbols &self - (= $Head $B))) - ($new-internal-database $P) - ($check-procedure-permission - (with_self $P $PI) access private-procedure - (get-symbols &self - (= $Head $B))) - ($clause-internal $P $PI $H $Cl $_) - (copy-term $Cl - (= $H $B)))) -; + !(public (, (/ get-char 1) (/ get-code 1))) + !(public (, (/ peek-char 1) (/ peek-code 1))) + !(public (, (/ put-char 1) (/ put-code 1))) + !(public (/ nl 1)) - -; -; + (= (get-char $Char) + (current-input $S) + (get-char $S $Char)) - (= - ($head-to-term $H $T - (with_self $Pkg - (/ $F $A)) $Goal) - ( ($head-to-term $H $T user $Pkg $Goal) (functor $T $F $A))) -; - - - (= - ($head-to-term $H $_ $_ $_ $Goal) - ( (var $H) - (set-det) - (illarg var $Goal 1))) -; + (= (get-code $Code) + (current-input $S) + (get-code $S $Code)) - (= - ($head-to-term - (with_self $P $H) $T $_ $Pkg $Goal) - ( (set-det) ($head-to-term $H $T $P $Pkg $Goal))) -; - - (= - ($head-to-term $H $H $Pkg $Pkg $_) - ( (callable $H) - (atom $Pkg) - (set-det))) -; - - (= - ($head-to-term $_ $_ $_ $_ $Goal) - (illarg - (type callable) $Goal 1)) -; - - -; -; + (= (peek-char $Char) + (current-input $S) + (peek-char $S $Char)) - (= - ($new-internal-database $A) - ( (atom $A) - ($get-hash-manager $HM) - ($new-internal-database $HM $A))) -; - + (= (peek-code $Code) + (current-input $S) + (peek-code $S $Code)) - (= - ($new-internal-database $HM $A) - ( (hash-contains-key $HM $A) (set-det))) -; - - (= - ($new-internal-database $_ $A) - ( (new-hash $_ - (:: (alias $A))) ($init-internal-database $A))) -; + + (= (put-char $Char) + (current-output $S) + (put-char $S $Char)) + + (= (put-code $Code) + (current-output $S) + (put-code $S $Code)) + + (= (nl $S) + (put-char $S +)) - (= - ($init-internal-database $A) - ( ($compiled-predicate $A %init 0) - (findall $_ - (with_self $A - (%init)) $_) - (set-det))) -; + !(public (, (/ get0 1) (/ get0 2))) + !(public (/ get 1)) +; +; :- public get/2. (written in Java) + !(public (, (/ put 1) (/ put 2))) + !(public (/ tab 1)) +; +; :- public tab/2. (written in Java) + !(public (/ skip 1)) +; +; :- public skip/2. (written in Java) - (= - (%init_internal_database $_) True) -; + + (= (get0 $Code) + (current-input $S) + (get-code $S $Code)) + (= (get0 $S_or_a $Code) + (get-code $S_or_a $Code)) + + (= (get $Code) + (current-input $S) + (get $S $Code)) -; -; + (= (put $Exp) + (current-output $S) + (put $S $Exp)) + (= (put $S_or_a $Exp) + (is $Code $Exp) + (put-code $S_or_a $Code)) + - (= - ($defined-internal-database $A) - ( (atom $A) - ($get-hash-manager $HM) - (hash-contains-key $HM $A))) -; + (= (tab $N) + (current-output $S) + (tab $S $N)) + + (= (skip $N) + (current-input $S) + (skip $S $N)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Byte input/output +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (= - ($clause-internal $P $PI $H $Cl $Ref) - ( (hash-contains-key $P $PI) - ($get-indices $P $PI $H $RevRefs) - ($get-instances $RevRefs $Cls_Refs) - ($clause-internal0 $Cls_Refs $Cl $Ref))) -; - + !(public (, (/ get-byte 1) (/ peek-byte 1) (/ put-byte 1))) +; +; :- public get_byte/2. ; written in java +; +; :- public peek_byte/2. ; written in java +; +; :- public put_byte/2. ; written in java - (= - (%clause_internal0 () $_ $_) - (empty)) -; - - (= - ($clause-internal0 - (:: (, $Cl $Ref)) $Cl $Ref) - (set-det)) -; - - (= - ($clause-internal0 $L $Cl $Ref) - ($builtin-member - (, $Cl $Ref) $L)) -; - + (= (get-byte $Byte) + (current-input $S) + (get-byte $S $Byte)) - (= - ($get-indices $P $PI $H $Refs) - ( ($new-indexing-hash $P $PI $IH) - ($calc-indexing-key $H $Key) - (det-if-then-else - (hash-contains-key $IH $Key) - (hash-get $IH $Key $Refs) - (hash-get $IH var $Refs)))) -; + (= (peek-byte $Byte) + (current-input $S) + (peek-byte $S $Byte)) + + (= (put-byte $Byte) + (current-output $S) + (put-byte $S $Byte)) ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Term input/output (read) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + !(public (, (/ read 1) (/ read 2))) + !(public (, (/ read-with-variables 2) (/ read-with-variables 3))) + !(public (/ read-line 1)) +; +; :- public read_line/2. (written in Java) + !(dynamic (/ %tokens 1)) + - (= - ($new-indexing-hash $P $PI $IH) - ( (hash-contains-key $P $PI) - (set-det) - (hash-get $P $PI $IH))) -; + (= (read $X) + (current-input $S) + (read $S $X)) - (= - ($new-indexing-hash $P $PI $IH) - ( (new-hash $IH) - (hash-put $IH all Nil) - (hash-put $IH var Nil) - (hash-put $IH lis Nil) - (hash-put $IH str Nil) - (hash-put $P $PI $IH))) -; + (= (read $S_or_a $X) + (read-tokens $S_or_a $Tokens $_) + (parse-tokens $X $Tokens) + (set-det)) + + + (= (read-with-variables $X $Vs) + (current-input $S) + (read-with-variables $S $X $Vs)) + (= (read-with-variables $S_or_a $X $Vs) + (read-tokens $S_or_a $Tokens $Vs) + (parse-tokens $X $Tokens) + (set-det)) - (= - ($calc-indexing-key $H all) - ( (atom $H) (set-det))) -; + (= (read-line $X) + (current-input $S) + (read-line $S $X)) - (= - ($calc-indexing-key $H $Key) - ( (arg 1 $H $A1) ($calc-indexing-key0 $A1 $Key))) -; +; +; read_token(S_or_a, Token) reads one token from the input, +; +; and unifies Token with: +; +; error(Atom), +; +; end_of_file, +; +; '.', ' ', '(', ')', '[', ']', '{', '}', ',', '|', +; +; number(Integer_or_Float), +; +; atom(Atom), +; +; var(Atom), +; +; string(CharCodeList) +; +; read_token(Token) :- current_input(S), read_token(S, Token). - (= - ($calc-indexing-key0 $A1 all) - ( (var $A1) (set-det))) -; + (= (read-token $S_or_a $Token) + ($read-token0 $S_or_a $Type $Token0) + ($read-token1 + (:: $Type) $Token0 $Token)) - (= - ($calc-indexing-key0 $A1 lis) - ( (= $A1 - (Cons $_ $_)) (set-det))) -; + + (= ($read-token1 (:: -2) $T (error $T)) + (set-det)) ; +; error('message') + (= ($read-token1 "I" $T (number $T)) + (set-det)) ; +; number(intvalue) + (= ($read-token1 "L" $T (number $T)) + (set-det)) ; +; number(longvalue) + (= ($read-token1 "D" $T (number $T)) + (set-det)) ; +; number(floatvalue) + (= ($read-token1 "A" $T (atom $T)) + (set-det)) ; +; atom('name') + (= ($read-token1 "V" $T (var $T)) + (set-det)) ; +; var('name') + (= ($read-token1 "S" $T (string $T)) + (set-det)) ; +; string("chars") + (= ($read-token1 $_ $T $T) + (set-det)) ; +; others - (= - ($calc-indexing-key0 $A1 str) - ( (compound $A1) (set-det))) -; +; +; read_tokens(Tokens, Vs) reads tokens from the input +; +; until full-stop-mark ('.') or end_of_file, +; +; unifies Tokens with a list of tokens. +; +; Token for a variable has a form of var(Name,Variable). +; +; Vs is a list of Name=Variable pairs. - (= - ($calc-indexing-key0 $A1 $Key) - ( (ground $A1) - (set-det) - ($term-hash $A1 $Key))) -; +; +; read_tokens(Tokens, Vs) :- +; +; current_input(Stream), +; +; '$read_tokens'(Stream, Tokens, Vs, []), +; +; !. - (= - ($calc-indexing-key0 $A1 $Key) - (illarg - (type term) - ($calc-indexing-key0 $A1 $Key) 1)) -; + + (= (read-tokens $Stream $Tokens $Vs) + ($read-tokens $Stream $Tokens $Vs Nil) + (set-det)) + + (= ($read-tokens $Stream $Tokens $Vs $VI) + (read-token $Stream $Token) + ($read-tokens1 $Stream $Token $Tokens $Vs $VI)) -; -; + (= ($read-tokens1 $Stream (error $Message) Nil $_ $_) + (set-det) + (write user-error '{SYNTAX ERROR}') + (nl user-error) + (write user-error ** ) + (write user-error $Message) + (write user-error **) + (nl user-error) + (flush-output user-error) + ($read-tokens-until-fullstop $Stream) + (fail)) + (= ($read-tokens1 $Stream end-of-file (:: end-of-file .) Nil $_) + (set-det)) + (= ($read-tokens1 $Stream . (:: .) Nil $_) + (set-det)) + (= ($read-tokens1 $Stream (var -) (Cons (var - $V) $Tokens) (Cons (= - $V) $Vs) $VI0) + (set-det) + ($read-tokens $Stream $Tokens $Vs + (Cons + (= - $V) $VI0))) + (= ($read-tokens1 $Stream (var $Name) (Cons (var $Name $V) $Tokens) $Vs $VI) + ($mem-pair + (= $Name $V) $VI) + (set-det) + ($read-tokens $Stream $Tokens $Vs $VI)) + (= ($read-tokens1 $Stream (var $Name) (Cons (var $Name $V) $Tokens) (Cons (= $Name $V) $Vs) $VI0) + (set-det) + ($read-tokens $Stream $Tokens $Vs + (Cons + (= $Name $V) $VI0))) + (= ($read-tokens1 $Stream $Token (Cons $Token $Tokens) $Vs $VI) + ($read-tokens $Stream $Tokens $Vs $VI)) + - (= - ($check-procedure-permission - (with_self $P - (/ $F $A)) $Operation $ObjType $Goal) - ( (hash-contains-key $P - (/ $F $A)) (set-det))) -; + (= ($mem-pair (= $X1 $V1) (Cons (= $X2 $V2) $_)) + (== $X1 $X2) + (set-det) + (= $V1 $V2)) + (= ($mem-pair $X (Cons $_ $L)) + ($mem-pair $X $L)) +; +; '$mem_pair'(X, [_|L]) :- member(X, L). - (= - ($check-procedure-permission - (with_self $P - (/ $F $A)) $Operation $ObjType $Goal) - ( ($compiled-predicate-or-builtin $P $F $A) - (set-det) - (illarg - (permission $Operation $ObjType - (with_self $P - (/ $F $A)) $_) $Goal $_))) -; + + (= ($read-tokens-until-fullstop $Stream) + (read-token $Stream $Token) + ($read-tokens-until-fullstop $Stream $Token)) - (= - (%check_procedure_permission $_ $_ $_ $_) True) -; + (= ($read-tokens-until-fullstop $Stream end-of-file) + (set-det)) + (= ($read-tokens-until-fullstop $Stream .) + (set-det)) + (= ($read-tokens-until-fullstop $Stream $_) + (read-token $Stream $Token) + ($read-tokens-until-fullstop $Stream $Token)) + + (= (parse-tokens $X $Tokens) + ( (remove-all-atoms &self + (%tokens $_)) + (add-is-symbol &self + (%tokens $Tokens)) + ($parse-tokens $X 1201 $Tokens + (:: .)) + (remove-is-symbol &self + (%tokens $Tokens)) + (set-det))) ; -; - +; '$parse_tokens'(X, Prec) parses the input whose precedecence =< Prec. - (= - (initialization Nil $Goal) - ( (set-det) (once $Goal))) -; + (= (--> (%parse_tokens $X $Prec0) (, $parse_tokens_skip_spaces (, (%parse_tokens1 $Prec0 $X1 $Prec1) (, ! (, $parse_tokens_skip_spaces (, (%parse_tokens2 $Prec0 $X1 $Prec1 $X $Prec) !)))))) True) - (= - (initialization - (Cons $P $Ps) $Goal) - ( ($new-internal-database $P) (initialization $Ps $Goal))) -; + (= (--> (%parse_tokens1 $Prec0 $X1 $Prec1) (, (%parse_tokens_peep_next $Next) (, {(%parse_tokens_is_starter $Next) } (, ! (%parse_tokens_before_op $Prec0 $X1 $Prec1))))) True) + (= (--> (%parse_tokens1 $_ $_ $_) (, (%parse_tokens_peep_next $Next) (%parse_tokens_error ($Next cannot start an expression)))) True) + (= (--> (%parse_tokens2 $Prec0 $X $Prec $X $Prec) (, (%parse_tokens_peep_next $Next) (, {(%parse_tokens_is_terminator $Next) } (, {(=< $Prec $Prec0) } !)))) True) + (= (--> (%parse_tokens2 $Prec0 $X1 $Prec1 $X $Prec) (, (%parse_tokens_peep_next $Next) (, {(%parse_tokens_is_post_in_op $Next) } (, ! (%parse_tokens_post_in_ops $Prec0 $X1 $Prec1 $X $Prec))))) True) + (= (--> (%parse_tokens2 $_ $_ $_ $_ $_) (%parse_tokens_error (operator expected after expression))) True) ; -; - +; '$parse_tokens_before_op'(Prec0, X, Prec) ; -; - +; parses the input until infix or postfix operator, ; -; - - - !(public (/ assert 1)) -; - - !(public (/ assertz 1)) -; +; and returns X and Prec + (= (--> (%parse_tokens_before_op $Prec0 $X $Prec) (, (' ') (, ! (%parse_tokens_before_op $Prec0 $X $Prec)))) True) + (= (--> (%parse_tokens_before_op $_ end_of_file 0) (, (end_of_file) !)) True) + (= (--> (%parse_tokens_before_op $_ $N 0) (, ((number $N)) !)) True) + (= (--> (%parse_tokens_before_op $_ $N 0) (, ((is-symbol -)) (, ((number $N0)) (, ! {(is $N (- $N0)) })))) True) + (= (--> (%parse_tokens_before_op $_ $V 0) (, ((var $_ $V)) !)) True) + (= (--> (%parse_tokens_before_op $_ $S 0) (, ((string $S)) !)) True) + (= (--> (%parse_tokens_before_op $_ $X 0) (, (() (, ! (, (%parse_tokens $X 1201) (%parse_tokens_expect )))))) True) + (= (--> (%parse_tokens_before_op $_ $X 0) (, ({) (, ! (, $parse_tokens_skip_spaces (%parse_tokens_brace $X))))) True) + (= (--> (%parse_tokens_before_op $_ $X 0) (, ([) (, ! (, $parse_tokens_skip_spaces (%parse_tokens_list $X))))) True) + (= (--> (%parse_tokens_before_op $_ $X 0) (, ((is-symbol $F)) (, (() (, ! (, $parse_tokens_skip_spaces (, (%parse_tokens_args $Args) {(=.. $X (Cons $F $Args)) })))))) True) + (= (--> (%parse_tokens_before_op $Prec0 $X $PrecOp) (, ((is-symbol $F)) (, {(current_op $PrecOp fx $F) } (, {(=< $PrecOp $Prec0) } (, $parse_tokens_skip_spaces (, (%parse_tokens_peep_next $Next) (, {(%parse_tokens_is_starter $Next) } (, {(\+ (%parse_tokens_is_post_in_op $Next)) } (, ! (, {(is $Prec1 (- $PrecOp 1)) } (, (%parse_tokens $Arg $Prec1) (, {(functor $X $F 1) } {(arg 1 $X $Arg) })))))))))))) True) + (= (--> (%parse_tokens_before_op $Prec0 $X $PrecOp) (, ((is-symbol $F)) (, {(current_op $PrecOp fy $F) } (, {(=< $PrecOp $Prec0) } (, $parse_tokens_skip_spaces (, (%parse_tokens_peep_next $Next) (, {(%parse_tokens_is_starter $Next) } (, {(\+ (%parse_tokens_is_post_in_op $Next)) } (, ! (, (%parse_tokens $Arg $PrecOp) (, {(functor $X $F 1) } {(arg 1 $X $Arg) }))))))))))) True) + (= (--> (%parse_tokens_before_op $_ $A 0) ((is-symbol $A))) True) - !(public (/ asserta 1)) -; + (= (--> (%parse_tokens_brace {}) (, (}) !)) True) + (= (--> (%parse_tokens_brace $X) (, (%parse_tokens $X1 1201) (, (%parse_tokens_expect }) {(= $X + {$X1 }) }))) True) - !(public (/ retract 1)) -; + (= (--> (%parse_tokens_list []) (, (]) !)) True) + (= (--> (%parse_tokens_list (Cons $X $Xs)) (, (%parse_tokens $X 999) (, $parse_tokens_skip_spaces (%parse_tokens_list_rest $Xs)))) True) - !(public (/ abolish 1)) -; + (= (--> (%parse_tokens_list_rest $Xs) (, (|) (, ! (, (%parse_tokens $Xs 999) (%parse_tokens_expect ]))))) True) + (= (--> (%parse_tokens_list_rest (Cons $X $Xs)) (, (,) (, ! (, (%parse_tokens $X 999) (, $parse_tokens_skip_spaces (%parse_tokens_list_rest $Xs)))))) True) + (= (--> (%parse_tokens_list_rest []) (%parse_tokens_expect ])) True) - !(public (/ retractall 1)) -; + (= (--> (%parse_tokens_args []) (, ()) !)) True) + (= (--> (%parse_tokens_args (Cons $X $Xs)) (, (%parse_tokens $X 999) (, $parse_tokens_skip_spaces (%parse_tokens_args_rest $Xs)))) True) + (= (--> (%parse_tokens_args_rest (Cons $X $Xs)) (, (,) (, ! (, (%parse_tokens $X 999) (, $parse_tokens_skip_spaces (%parse_tokens_args_rest $Xs)))))) True) + (= (--> (%parse_tokens_args_rest []) (%parse_tokens_expect ))) True) - - (= - (add-symbol &self $T) - (add-symbol &self $T)) -; +; +; '$parse_tokens_post_in_op'(Prec0, X1, Prec1, X, Prec) +; +; parses the input beginning from infix or postfix operator, +; +; and returns X and Prec + (= (--> (%parse_tokens_post_in_ops $Prec0 $X1 $Prec1 $X $Prec) (, $parse_tokens_skip_spaces (, ($Op) (, (%parse_tokens_op $Op $Prec0 $X1 $Prec1 $X2 $Prec2) (%parse_tokens_post_in_ops $Prec0 $X2 $Prec2 $X $Prec))))) True) + (= (--> (%parse_tokens_post_in_ops $Prec0 $X $Prec $X $Prec) {(=< $Prec $Prec0) }) True) + (= (--> (%parse_tokens_op , $Prec0 $X1 $Prec1 $X $PrecOp) (, ! (%parse_tokens_op (is-symbol ,) $Prec0 $X1 $Prec1 $X $PrecOp))) True) + (= (--> (%parse_tokens_op | $Prec0 $X1 $Prec1 $X $PrecOp) (, ! (%parse_tokens_op (is-symbol ;) $Prec0 $X1 $Prec1 $X $PrecOp))) True) + (= (--> (%parse_tokens_op (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) (, {(current_op $PrecOp xf $Op) } (, {(=< $PrecOp $Prec0) } (, {(< $Prec1 $PrecOp) } (, {(functor $X $Op 1) } {(arg 1 $X $X1) }))))) True) + (= (--> (%parse_tokens_op (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) (, {(current_op $PrecOp yf $Op) } (, {(=< $PrecOp $Prec0) } (, {(=< $Prec1 $PrecOp) } (, {(functor $X $Op 1) } {(arg 1 $X $X1) }))))) True) + (= (--> (%parse_tokens_op (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) (, {(current_op $PrecOp xfx $Op) } (, {(=< $PrecOp $Prec0) } (, {(< $Prec1 $PrecOp) } (, {(is $Prec2 (- $PrecOp 1)) } (, (%parse_tokens $X2 $Prec2) (, ! (, {(functor $X $Op 2) } (, {(arg 1 $X $X1) } {(arg 2 $X $X2) }))))))))) True) + (= (--> (%parse_tokens_op (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) (, {(current_op $PrecOp xfy $Op) } (, {(=< $PrecOp $Prec0) } (, {(< $Prec1 $PrecOp) } (, {(is $Prec2 $PrecOp) } (, (%parse_tokens $X2 $Prec2) (, ! (, {(functor $X $Op 2) } (, {(arg 1 $X $X1) } {(arg 2 $X $X2) }))))))))) True) + (= (--> (%parse_tokens_op (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) (, {(current_op $PrecOp yfx $Op) } (, {(=< $PrecOp $Prec0) } (, {(=< $Prec1 $PrecOp) } (, {(is $Prec2 (- $PrecOp 1)) } (, (%parse_tokens $X2 $Prec2) (, ! (, {(functor $X $Op 2) } (, {(arg 1 $X $X1) } {(arg 2 $X $X2) }))))))))) True) - (= - (add-symbol &self $T) - ( ($term-to-clause $T $Cl - (with_self $P $PI) - (add-symbol &self $T)) - ($new-internal-database $P) - ($check-procedure-permission - (with_self $P $PI) modify static-procedure - (add-symbol &self $T)) - (copy-term $Cl $NewCl) - ($insert $NewCl $Ref) - ($update-indexing $P $PI $Cl $Ref z) - (fail))) -; + (= (%parse_tokens_is_starter end_of_file) True) + (= (%parse_tokens_is_starter () True) + (= (%parse_tokens_is_starter [) True) + (= (%parse_tokens_is_starter {) True) + (= (%parse_tokens_is_starter (number $_)) True) + (= (%parse_tokens_is_starter (is-symbol $_)) True) + (= (%parse_tokens_is_starter (var $_ $_)) True) + (= (%parse_tokens_is_starter (string $_)) True) - (= - (assertz $_) True) -; + + (= (%parse_tokens_is_terminator )) True) + (= (%parse_tokens_is_terminator ]) True) + (= (%parse_tokens_is_terminator }) True) + (= (%parse_tokens_is_terminator .) True) + + (= ($parse-tokens-is-post-in-op ,) + (set-det)) + (= ($parse-tokens-is-post-in-op |) + (set-det)) + (= ($parse-tokens-is-post-in-op (atom $Op)) + (current-op $_ $Type $Op) + ($parse-tokens-post-in-type $Type) + (set-det)) - (= - (add-symbol &self $T) - ( ($term-to-clause $T $Cl - (with_self $P $PI) - (add-symbol &self $T)) - ($new-internal-database $P) - ($check-procedure-permission - (with_self $P $PI) modify static-procedure - (add-symbol &self $T)) - (copy-term $Cl $NewCl) - ($insert $NewCl $Ref) - ($update-indexing $P $PI $Cl $Ref a) - (fail))) -; + (= (%parse_tokens_post_in_type xfx) True) + (= (%parse_tokens_post_in_type xfy) True) + (= (%parse_tokens_post_in_type yfx) True) + (= (%parse_tokens_post_in_type xf) True) + (= (%parse_tokens_post_in_type yf) True) - (= - (asserta $_) True) -; + + (= (--> (%parse_tokens_expect $Token) (, $parse_tokens_skip_spaces (, ($Token) !))) True) + (= (--> (%parse_tokens_expect $Token) (%parse_tokens_error ($Token expected))) True) + (= (--> $parse_tokens_skip_spaces (, (' ') (, ! $parse_tokens_skip_spaces))) True) + (= (--> $parse_tokens_skip_spaces ()) True) - (= - (abolish $T) - ( ($term-to-predicateindicator $T - (with_self $P $PI) - (abolish $T)) - ($new-internal-database $P) - ($check-procedure-permission - (with_self $P $PI) modify static-procedure - (abolish $T)) - ($new-indexing-hash $P $PI $IH) - (hash-get $IH all $Refs) - ($erase-all $Refs) - (hash-remove $P $PI) - (fail))) -; - - (= - (abolish $_) True) -; + (= ($parse-tokens-peep-next $Next $S $S) + (= $S + (Cons $Next $_))) + + (= ($parse-tokens-error $Message $S0 $S) + ( (write user-error '{SYNTAX ERROR}') + (nl user-error) + (write user-error ** ) + ($parse-tokens-write-message user-error $Message) + (write user-error **) + (nl user-error) + ($parse-tokens-error1 Nil $S0) + (== + (= + (%tokens $Tokens) $_) + (get-atoms &self)) + ($parse-tokens-error1 $Tokens $S0) + (flush-output user-error) + (fail))) + + + (= ($parse-tokens-error1 Nil $_) + (set-det)) + (= ($parse-tokens-error1 $Tokens $S0) + (== $Tokens $S0) + (set-det) + (nl user-error) + (write user-error '** here **') + (nl user-error) + ($parse-tokens-error1 $Tokens Nil) + (nl user-error)) + (= ($parse-tokens-error1 (Cons $Token $Tokens) $S0) + ($parse-tokens-error2 $Token) + ($parse-tokens-error1 $Tokens $S0)) + + + (= ($parse-tokens-error2 (number $X)) + (set-det) + (write $X)) + (= ($parse-tokens-error2 (atom $X)) + (set-det) + (writeq $X)) + (= ($parse-tokens-error2 (var $X $_)) + (set-det) + (write $X)) + (= ($parse-tokens-error2 (string $X)) + (set-det) + (write user-error ") + ($parse-tokens-write-string user-error $X) + (write user-error ")) + (= ($parse-tokens-error2 $X) + (write user-error $X)) + + + (= (%parse_tokens_write_string $_ ()) True) + (= ($parse-tokens-write-string $S (Cons $C $Cs)) + (= + (:: $C) "\"") + (set-det) + (put-code $S $C) + (put-code $S $C) + ($parse-tokens-write-string $S $Cs)) + (= ($parse-tokens-write-string $S (Cons $C $Cs)) + (put-code $S $C) + ($parse-tokens-write-string $S $Cs)) + + + (= (%parse_tokens_write_message $_ ()) True) + (= ($parse-tokens-write-message $S (Cons $X $Xs)) + (write $S $X) + (write $S ' ') + ($parse-tokens-write-message $S $Xs)) + +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Term input/output (write) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + !(public (, (/ write 1) (/ write 2))) + !(public (, (/ writeq 1) (/ writeq 2))) + !(public (, (/ write-canonical 1) (/ write-canonical 2))) + !(public (, (/ write-term 2) (/ write-term 3))) + + + (= (write $Term) + (current-output $S) + (write-term $S $Term + (:: (numbervars True)))) + + (= (write $S_or_a $Term) + (write-term $S_or_a $Term + (:: (numbervars True)))) - (= - (remove-symbol &self $Cl) - ( ($clause-to-term $Cl $T - (with_self $P $PI) - (remove-symbol &self $Cl)) - ($new-internal-database $P) - ($check-procedure-permission - (with_self $P $PI) access static-procedure - (remove-symbol &self $Cl)) - (= $T - (= $H $_)) - ($clause-internal $P $PI $H $Cl0 $Ref) - (copy-term $Cl0 $T) - ($erase $Ref) - ($rehash-indexing $P $PI $Ref))) -; + (= (writeq $Term) + (current-output $S) + (write-term $S $Term + (:: + (quoted True) + (numbervars True)))) + (= (writeq $S_or_a $Term) + (write-term $S_or_a $Term + (:: + (quoted True) + (numbervars True)))) - (= - (remove-all-symbols &self $Head) - ( ($head-to-term $Head $H - (with_self $P $PI) - (remove-all-symbols &self $Head)) - ($new-internal-database $P) - ($check-procedure-permission - (with_self $P $PI) access static-procedure - (remove-all-symbols &self $Head)) - ($clause-internal $P $PI $H $Cl $Ref) - (copy-term $Cl - (= $H $_)) - ($erase $Ref) - ($rehash-indexing $P $PI $Ref) - (fail))) -; - - (= - (retractall $_) True) -; + (= (write-canonical $Term) + (current-output $S) + (write-term $S $Term + (:: + (quoted True) + (ignore-ops True)))) + (= (write-canonical $S_or_a $Term) + (write-term $S_or_a $Term + (:: + (quoted True) + (ignore-ops True)))) + + + (= (write-term $Term $Options) + (current-output $S) + (write-term $S $Term $Options)) + + (= (write-term $S_or_a $Term $Options) + ($write-term $S_or_a $Term $Options) + (fail)) + (= (write_term $_ $_ $_) True) + + + (= ($write-term $S_or_a $Term $Options) + ($write-term0 $Term 1200 punct $_ $Options $S_or_a) + (set-det)) + + + (= ($write-term0 $Term $Prec $Type0 alpha $_ $S_or_a) + (var $Term) + (set-det) + ($write-space-if-needed $Type0 alpha $S_or_a) + ($fast-write $S_or_a $Term)) + (= ($write-term0 $Term $Prec $Type0 alpha $_ $S_or_a) + (java $Term) + (set-det) + ($write-space-if-needed $Type0 alpha $S_or_a) + ($fast-write $S_or_a $Term)) + (= ($write-term0 $Term $Prec $Type0 alpha $Style $S_or_a) + (= $Term $VN) + (integer $VN) + (>= $VN 0) + ($builtin-member + (numbervars True) $Style) + (set-det) + ($write-space-if-needed $Type0 alpha $S_or_a) + ($write-VAR $VN $S_or_a)) + (= ($write-term0 $Term $Prec $Type0 alpha $_ $S_or_a) + (number $Term) + (< $Term 0) + (set-det) + ($write-space-if-needed $Type0 symbol $S_or_a) + ($fast-write $S_or_a $Term)) + (= ($write-term0 $Term $Prec $Type0 alpha $_ $S_or_a) + (number $Term) + (set-det) + ($write-space-if-needed $Type0 alpha $S_or_a) + ($fast-write $S_or_a $Term)) +; +; '$write_term0'(Term, Prec, Type0, punct, _, S_or_a) :- +; +; atom(Term), +; +; current_op(PrecOp, OpType, Term), +; +; (OpType = fx ; OpType = fy), +; +; PrecOp =< Prec, +; +; !, +; +; '$write_space_if_needed'(Type0, punct, S_or_a), +; +; put_char(S_or_a, '('), +; +; '$write_atom'(Term, punct, _, _, S_or_a), +; +; put_char(S_or_a, ')'). + (= ($write-term0 $Term $Prec $Type0 $Type $Style $S_or_a) + (atom $Term) + (set-det) + ($write-atom $Term $Type0 $Type $Style $S_or_a)) + (= ($write-term0 $Term $Prec $Type0 $Type $Style $S_or_a) + (not ($builtin-member (ignore-ops True) $Style)) + ($write-is-operator $Term $Op $Args $OpType) + (set-det) + ($write-term-op $Op $OpType $Args $Prec $Type0 $Type $Style $S_or_a)) + (= ($write-term0 $Term $Prec $Type0 punct $Style $S_or_a) + (= $Term + (Cons $_ $_)) + (not ($builtin-member (ignore-ops True) $Style)) + (set-det) + ($write-space-if-needed $Type0 punct $S_or_a) + (put-char $S_or_a [) + ($write-term-list-args $Term punct $_ $Style $S_or_a) + (put-char $S_or_a ])) + (= ($write-term0 $Term $Prec $Type0 $Type $Style $S_or_a) + (= $Term + {$Term1 }) + (not ($builtin-member (ignore-ops True) $Style)) + (set-det) + ($write-space-if-needed $Type0 punct $S_or_a) + (put-char $S_or_a {) + ($write-term0 $Term1 1200 punct $_ $Style $S_or_a) + (put-char $S_or_a })) + (= ($write-term0 $Term $Prec $Type0 punct $Style $S_or_a) + (=.. $Term + (Cons $F $Args)) + ($write-atom $F $Type0 $_ $Style $S_or_a) + (put-char $S_or_a () + ($write-term-args $Args punct $_ $Style $S_or_a) + (put-char $S_or_a ))) + + + (= ($write-space-if-needed punct $_ $_) + (set-det)) + (= ($write-space-if-needed $X $X $S_or_a) + (set-det) + (put-char $S_or_a ' ')) + (= ($write-space-if-needed other alpha $S_or_a) + (set-det) + (put-char $S_or_a ' ')) + (= (%write_space_if_needed $_ $_ $_) True) + + + (= ($write-VAR $VN $S_or_a) + (< $VN 26) + (set-det) + (is $Letter + (+ + (mod $VN 26) "A")) + (put-code $S_or_a $Letter)) + (= ($write-VAR $VN $S_or_a) + (is $Letter + (+ + (mod $VN 26) "A")) + (put-code $S_or_a $Letter) + (is $Rest + (// $VN 26)) + ($fast-write $S_or_a $Rest)) + + + (= ($write-atom $Atom $Type0 $Type $Style $S_or_a) + ($builtin-member + (quoted True) $Style) + (set-det) + ($atom-type $Atom $Type) + ($write-space-if-needed $Type0 $Type $S_or_a) + ($fast-writeq $S_or_a $Atom)) + (= ($write-atom $Atom $Type0 $Type $_ $S_or_a) + ($atom-type $Atom $Type) + ($write-space-if-needed $Type0 $Type $S_or_a) + ($fast-write $S_or_a $Atom)) + + + (= ($atom-type $X alpha) + ($atom-type0 $X 0) + (set-det)) + (= ($atom-type $X symbol) + ($atom-type0 $X 1) + (set-det)) + (= ($atom-type $X punct) + ($atom-type0 $X 2) + (set-det)) + (= ($atom-type $X other) + ($atom-type0 $X 3) + (set-det)) + + + (= ($write-is-operator $Term $Op $Args $OpType) + (functor $Term $Op $Arity) + ($write-op-type $Arity $OpType) + (current-op $_ $OpType $Op) + (=.. $Term + (Cons $_ $Args)) + (set-det)) + + + (= (%write_op_type 1 fx) True) + (= (%write_op_type 1 fy) True) + (= (%write_op_type 1 xf) True) + (= (%write_op_type 1 yf) True) + (= (%write_op_type 2 xfx) True) + (= (%write_op_type 2 xfy) True) + (= (%write_op_type 2 yfx) True) + + + (= ($write-term-op $Op $OpType $Args $Prec $Type0 punct $Style $S_or_a) + (current-op $PrecOp $OpType $Op) + (> $PrecOp $Prec) + (set-det) + ($write-space-if-needed $Type0 punct $S_or_a) + (put-char $S_or_a () + ($write-term-op1 $Op $OpType $Args $PrecOp punct $_ $Style $S_or_a) + (put-char $S_or_a ))) + (= ($write-term-op $Op $OpType $Args $Prec $Type0 $Type $Style $S_or_a) + (current-op $PrecOp $OpType $Op) + ($write-term-op1 $Op $OpType $Args $PrecOp $Type0 $Type $Style $S_or_a)) + + + (= ($write-term-op1 $Op fx (:: $A1) $PrecOp $Type0 $Type $Style $S_or_a) + (set-det) + ($write-atom $Op $Type0 $Type1 $Style $S_or_a) + (is $Prec1 + (- $PrecOp 1)) + ($write-term0 $A1 $Prec1 $Type1 $Type $Style $S_or_a)) + (= ($write-term-op1 $Op fy (:: $A1) $PrecOp $Type0 $Type $Style $S_or_a) + (set-det) + ($write-atom $Op $Type0 $Type1 $Style $S_or_a) + (is $Prec1 $PrecOp) + ($write-term0 $A1 $Prec1 $Type1 $Type $Style $S_or_a)) + (= ($write-term-op1 $Op xf (:: $A1) $PrecOp $Type0 $Type $Style $S_or_a) + (set-det) + (is $Prec1 + (- $PrecOp 1)) + ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) + ($write-atom $Op $Type1 $Type $Style $S_or_a)) + (= ($write-term-op1 $Op yf (:: $A1) $PrecOp $Type0 $Type $Style $S_or_a) + (set-det) + (is $Prec1 $PrecOp) + ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) + ($write-atom $Op $Type1 $Type $Style $S_or_a)) + (= ($write-term-op1 $Op xfx (:: $A1 $A2) $PrecOp $Type0 $Type $Style $S_or_a) + (set-det) + (is $Prec1 + (- $PrecOp 1)) + (is $Prec2 + (- $PrecOp 1)) + ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) + ($write-term-infix-op $Op $Type1 $Type2 $Style $S_or_a) + ($write-term0 $A2 $Prec2 $Type2 $Type $Style $S_or_a)) + (= ($write-term-op1 $Op xfy (:: $A1 $A2) $PrecOp $Type0 $Type $Style $S_or_a) + (set-det) + (is $Prec1 + (- $PrecOp 1)) + (is $Prec2 $PrecOp) + ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) + ($write-term-infix-op $Op $Type1 $Type2 $Style $S_or_a) + ($write-term0 $A2 $Prec2 $Type2 $Type $Style $S_or_a)) + (= ($write-term-op1 $Op yfx (:: $A1 $A2) $PrecOp $Type0 $Type $Style $S_or_a) + (set-det) + (is $Prec1 $PrecOp) + (is $Prec2 + (- $PrecOp 1)) + ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) + ($write-term-infix-op $Op $Type1 $Type2 $Style $S_or_a) + ($write-term0 $A2 $Prec2 $Type2 $Type $Style $S_or_a)) + + + (= ($write-term-infix-op , $Type0 punct $_ $S_or_a) + (set-det) + ($write-space-if-needed $Type0 punct $S_or_a) + (put-char $S_or_a ,)) + (= ($write-term-infix-op $Op $Type0 $Type $Style $S_or_a) + ($write-atom $Op $Type0 $Type $Style $S_or_a)) + + + (= ($write-term-list-args (Cons $A $As) $Type0 $Type $Style $S_or_a) + (nonvar $As) + (= $As + (Cons $_ $_)) + (set-det) + ($write-term0 $A 999 $Type0 $Type1 $Style $S_or_a) + ($write-space-if-needed $Type1 punct $S_or_a) + (put-char $S_or_a ,) + ($write-term-list-args $As punct $Type $Style $S_or_a)) + + (= ($write-term-list-args (Cons $A $As) $Type0 $Type $Style $S_or_a) + (nonvar $As) + (= $As Nil) + (set-det) + ($write-term0 $A 999 $Type0 $Type $Style $S_or_a)) + + (= ($write-term-list-args (Cons $A $As) $Type0 $Type $Style $S_or_a) + ($write-term0 $A 999 $Type0 $Type1 $Style $S_or_a) + ($write-space-if-needed $Type1 punct $S_or_a) + (put-char $S_or_a |) + ($write-term0 $As 999 punct $Type $Style $S_or_a)) + + + (= ($write-term-args Nil $Type $Type $_ $_) + (set-det)) + (= ($write-term-args (:: $A) $Type0 $Type $Style $S_or_a) + (set-det) + ($write-term0 $A 999 $Type0 $Type $Style $S_or_a)) + (= ($write-term-args (Cons $A $As) $Type0 $Type $Style $S_or_a) + (set-det) + ($write-term0 $A 999 $Type0 $Type1 $Style $S_or_a) + ($write-space-if-needed $Type1 punct $S_or_a) + (put-char $S_or_a ,) + ($write-term-args $As punct $Type $Style $S_or_a)) + +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Term input/output (others) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + !(public (/ op 3)) + !(public (/ current-op 3)) + !(dynamic (/ %current-operator 3)) + + + (= (op $Priority $Op_specifier $Operator) + (integer $Priority) + (=< 0 $Priority) + (=< $Priority 1200) + (set-det) + ($op1 $Priority $Op_specifier $Operator)) + (= (op $Priority $Op_specifier $Operator) + (illarg + (domain integer + (- 0 1200)) + (op $Priority $Op_specifier $Operator) 1)) -; -; - - (= - ($term-to-clause $Cl0 $Cl - (with_self $Pkg - (/ $F $A)) $Goal) - ( ($term-to-clause $Cl0 $Cl user $Pkg $Goal) - (= $Cl - (= $H $_)) - (functor $H $F $A))) -; + (= ($op1 $Priority $Op_specifier $Operator) + (nonvar $Op_specifier) + ($op-specifier $Op_specifier $_) + (set-det) + ($op2 $Priority $Op_specifier $Operator)) + (= ($op1 $Priority $Op_specifier $Operator) + (findall $X + ($op-specifier $X $_) $Domain) + (illarg + (domain term $Domain) + (op $Priority $Op_specifier $Operator) 2)) + + (= ($op2 $Priority $Op_specifier $Operator) + (atom $Operator) + (set-det) + ($add-operators + (:: $Operator) $Priority $Op_specifier)) + (= ($op2 $Priority $Op_specifier $Operator) + ($op-atom-list $Operator $Atoms) + (set-det) + ($add-operators $Atoms $Priority $Op_specifier)) + (= ($op2 $Priority $Op_specifier $Operator) + (illarg + (type (list is-symbol)) + (op $Priority $Op_specifier $Operator) 3)) - (= - ($term-to-clause $Cl0 $_ $_ $_ $Goal) - ( (var $Cl0) - (set-det) - (illarg var $Goal 1))) -; - - (= - ($term-to-clause $_ $_ $Pkg0 $_ $Goal) - ( (var $Pkg0) - (set-det) - (illarg var $Goal 1))) -; - - (= - ($term-to-clause - (with_self $P $Cl0) $Cl $_ $Pkg $Goal) - ( (set-det) ($term-to-clause $Cl0 $Cl $P $Pkg $Goal))) -; - - (= - ($term-to-clause $_ $_ $Pkg0 $_ $Goal) - ( (not (atom $Pkg0)) - (set-det) - (illarg - (type is-symbol) $Goal 1))) -; - - (= - ($term-to-clause - (= $H0 $B0) - (= $H $B) $Pkg $Pkg $Goal) - ( (set-det) - ($term-to-head $H0 $H $Pkg $Goal) - ($term-to-body $B0 $B $Pkg $Goal))) -; - - (= - ($term-to-clause $H0 - (= $H True) $Pkg $Pkg $Goal) - ($term-to-head $H0 $H $Pkg $Goal)) -; - + + (= ($add-operators Nil $_ $_) + (set-det)) + (= ($add-operators (Cons $A $As) $Priority $Op_specifier) + ($add-op $A $Priority $Op_specifier) + ($add-operators $As $Priority $Op_specifier)) - (= - ($term-to-head $H $H $_ $_) - ( (atom $H) (set-det))) -; - - (= - ($term-to-head $H $H $_ $_) - ( (compound $H) (set-det))) -; - - (= - ($term-to-head $_ $_ $_ $Goal) + (= ($add-op , $Priority $Op_specifier) + (set-det) (illarg - (type callable) $Goal 1)) -; - + (permission modify operator , $_) + (op $Priority $Op_specifier ,) 3)) + (= ($add-op $A $_ $Op_specifier) + ( (== + (= + (%current_operator $_ $Op_specifier0 $A) $_) + (get-atoms &self)) + ($op-specifier $Op_specifier $Class) + ($op-specifier $Op_specifier0 $Class0) + (= $Class $Class0) + (remove-is-symbol &self + (%current_operator $_ $Op_specifier0 $A)) + (fail))) + (= ($add-op $_ 0 $_) + (set-det)) + (= ($add-op $A $Priority $Op_specifier) + (add-is-symbol &self + (%current_operator $Priority $Op_specifier $A))) + + + (= (%op_specifier fx prefix) True) + (= (%op_specifier fy prefix) True) + (= (%op_specifier xfx infix) True) + (= (%op_specifier xfy infix) True) + (= (%op_specifier yfx infix) True) + (= (%op_specifier xf postfix) True) + (= (%op_specifier yf postfix) True) + + + (= ($op-atom-list $X $_) + (var $X) + (set-det) + (fail)) + (= ($op-atom-list Nil Nil) + (set-det)) + (= ($op-atom-list (Cons $X $Xs) (Cons $X $As)) + (atom $X) + (set-det) + ($op-atom-list $Xs $As)) + + + (= (current-op $Priority $Op_specifier $Operator) + (== + (= + (%current_operator $Priority $Op_specifier $Operator) $_) + (get-atoms &self))) + + + (= (%current_operator 1200 xfx :-) True) + (= (%current_operator 1200 xfx -->) True) + (= (%current_operator 1200 fx :-) True) + (= (%current_operator 1200 fx ?-) True) + (= (%current_operator 1150 fx package) True) + (= (%current_operator 1150 fx import) True) + (= (%current_operator 1150 fx include) True) + (= (%current_operator 1150 fx include_resource) True) + (= (%current_operator 1150 fx constant) True) + (= (%current_operator 1150 fx public) True) + (= (%current_operator 1150 fx dynamic) True) + (= (%current_operator 1150 fx meta_predicate) True) + (= (%current_operator 1150 fx mode) True) + (= (%current_operator 1150 fx multifile) True) + (= (%current_operator 1150 fx block) True) + (= (%current_operator 1150 fx ifdef) True) + (= (%current_operator 1150 fx ifndef) True) + (= (%current_operator 1150 fx domain) True) + (= (%current_operator 1150 fx database) True) + (= (%current_operator 1100 xfy ;) True) + (= (%current_operator 1050 xfy ->) True) + (= (%current_operator 1000 xfy ,) True) + (= (%current_operator 900 fy \+) True) + (= (%current_operator 700 xfx =) True) + (= (%current_operator 700 xfx \=) True) + (= (%current_operator 700 xfx ==) True) + (= (%current_operator 700 xfx \==) True) + (= (%current_operator 700 xfx @<) True) + (= (%current_operator 700 xfx @>) True) + (= (%current_operator 700 xfx @=<) True) + (= (%current_operator 700 xfx @>=) True) + (= (%current_operator 700 xfx =..) True) + (= (%current_operator 700 xfx is) True) + (= (%current_operator 700 xfx =:=) True) + (= (%current_operator 700 xfx =\=) True) + (= (%current_operator 700 xfx <) True) + (= (%current_operator 700 xfx >) True) + (= (%current_operator 700 xfx =<) True) + (= (%current_operator 700 xfx >=) True) + (= (%current_operator 550 xfy :) True) + (= (%current_operator 500 yfx +) True) + (= (%current_operator 500 yfx -) True) + (= (%current_operator 500 yfx #) True) + (= (%current_operator 500 yfx /\) True) + (= (%current_operator 500 yfx \/) True) + (= (%current_operator 500 fx +) True) + (= (%current_operator 400 yfx *) True) + (= (%current_operator 400 yfx /) True) + (= (%current_operator 400 yfx //) True) + (= (%current_operator 400 yfx mod) True) + (= (%current_operator 400 yfx rem) True) + (= (%current_operator 400 yfx <<) True) + (= (%current_operator 400 yfx >>) True) + (= (%current_operator 300 xfx ~) True) + (= (%current_operator 200 xfx **) True) + (= (%current_operator 200 xfy ^) True) + (= (%current_operator 200 fy \) True) + (= (%current_operator 200 fy -) True) + +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Logic and control +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + !(public (/ \+ 1)) + !(public (/ once 1)) + !(public (/ repeat 0)) + + + (= (not $G) + (call $G) + (set-det) + (fail)) + (= (\+ $_) True) + + + (= repeat True) + (= (repeat) + (repeat)) + + + (= (once $G) + (call $G) + (set-det)) + +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Atomic term processing +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; :- public atom_length/2. written in Java +; +; :- public atom_concat/3. written in Java + + !(public (/ sub-symbol 5)) +; +; :- public atom_chars/2, atom_codes/2. written in Java +; +; :- public char_code/2. written in Java +; +; :- public number_chars/2, number_codes/2. written in Java + !(public (/ name 2)) +; +; :- public regex_compile/2. written in Java +; +; :- public regex_match/3. written in Java + !(public (/ regex-matches 3)) + !(public (/ regex-matches 2)) + + + (= (sub-atom $Atom $Before $Length $After $Sub_atom) + (atom-concat $AtomL $X $Atom) + (atom-length $AtomL $Before) + (atom-concat $Sub_atom $AtomR $X) + (atom-length $Sub_atom $Length) + (atom-length $AtomR $After)) - (= - ($term-to-body $B0 $B $Pkg $_) - ($localize-body $B0 $Pkg $B)) -; - + (= (name $Constant $Chars) + (nonvar $Constant) + (det-if-then-else + (number $Constant) + (number-codes $Constant $Chars) + (det-if-then-else + (atomic $Constant) + (atom-codes $Constant $Chars) + (illarg + (type symbolic) + (name $Constant $Chars) 1)))) + (= (name $Constant $Chars) + (var $Constant) + (det-if-then-else + (number-codes $Constant0 $Chars) + (= $Constant $Constant0) + (det-if-then-else + (atom-codes $Constant0 $Chars) + (= $Constant $Constant0) + (illarg + (type (list char)) + (name $Constant $Chars) 2)))) + + + (= (regex-matches $_ Nil $_) + (set-det) + (fail)) + (= (regex-matches $Pattern $List $Result) + (= $List + (Cons $_ $_)) + (set-det) + (regex-list $Pattern $List $Result)) + (= (regex-matches $Pattern $String $Result) + (atom $String) + (regex-compile $Pattern $Matcher) + (regex-match $Matcher $String $Result)) + + (= (regex-matches $Pattern $String) + (once (regex-matches $Pattern $String $_))) + + + (= (regex-list $Pattern (Cons $H $_) $Result) + (regex-matches $Pattern $H $Result)) + (= (regex-list $Pattern (Cons $_ $Ls) $Result) + (regex-list $Pattern $Ls $Result)) + +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Implementation defined hooks +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + !(public (/ set-prolog-flag 2)) + !(public (/ current-prolog-flag 2)) + + + (= (set-prolog-flag $Flag $Value) + (var $Flag) + (set-det) + (illarg var + (set-prolog-flag $Flag $Value) 1)) + (= (set-prolog-flag $Flag $Value) + (var $Value) + (set-det) + (illarg var + (set-prolog-flag $Flag $Value) 2)) + (= (set-prolog-flag $Flag $Value) + (atom $Flag) + (set-det) + ($set-prolog-flag0 $Flag $Value)) + (= (set-prolog-flag $Flag $Value) + (illarg + (type is-symbol) + (set-prolog-flag $Flag $Value) 1)) - (= - ($localize-body $G $P $G1) - ( (var $G) - (set-det) - ($localize-body - (call $G) $P $G1))) -; + (= ($set-prolog-flag0 $Flag $Value) + ($prolog-impl-flag $Flag $Mode + (changeable $YN)) + (set-det) + ($set-prolog-flag0 $YN $Flag $Value $Mode)) + (= ($set-prolog-flag0 $Flag $Value) + (illarg + (domain is-symbol prolog-flag) + (set-prolog-flag $Flag $Value) 1)) - (= - ($localize-body - (with_self $P $G) $_ $G1) - ( (set-det) ($localize-body $G $P $G1))) -; + (= ($set-prolog-flag0 no $Flag $Value $_) + (set-det) + (illarg + (permission modify flag $Flag $_) + (set-prolog-flag $Flag $Value) $_)) + (= ($set-prolog-flag0 $_ $Flag $Value $Mode) + ($builtin-member $Value $Mode) + (set-det) + ($set-prolog-impl-flag $Flag $Value)) + (= ($set-prolog-flag0 $_ $Flag $Value $_) + (illarg + (domain is-symbol flag-value) + (set-prolog-flag $Flag $Value) 2)) + + + (= (current-prolog-flag $Flag $Term) + (var $Flag) + (set-det) + ($prolog-impl-flag $Flag $_ $_) + ($get-prolog-impl-flag $Flag $Term)) + (= (current-prolog-flag $Flag $Term) + (atom $Flag) + (set-det) + (det-if-then-else + ($prolog-impl-flag $Flag $_ $_) + ($get-prolog-impl-flag $Flag $Term) + (illarg + (domain is-symbol prolog-flag) + (current-prolog-flag $Flag $Term) 1))) + (= (current-prolog-flag $Flag $Term) + (illarg + (type is-symbol) + (current-prolog-flag $Flag $Term) 1)) - (= - ($localize-body - (, $X $Y) $P - (, $X1 $Y1)) - ( (set-det) - ($localize-body $X $P $X1) - ($localize-body $Y $P $Y1))) -; +; +; '$MeTTa_impl_flag'(bounded, _, changeable(no)). + + (= (%prolog_impl_flag max_integer $_ (changeable no)) True) + (= (%prolog_impl_flag min_integer $_ (changeable no)) True) +; +; '$MeTTa_impl_flag'(integer_rounding_function, [down,toward_zero], changeable(no)). +; +; '$MeTTa_impl_flag'(char_conversion, [on,off], changeable(no)). + (= (%prolog_impl_flag debug (on off) (changeable yes)) True) + (= (%prolog_impl_flag max_arity $_ (changeable no)) True) + (= (%prolog_impl_flag unknown (error fail warning) (changeable yes)) True) + (= (%prolog_impl_flag double_quotes (chars codes atom) (changeable no)) True) + (= (%prolog_impl_flag print_stack_trace (on off) (changeable yes)) True) - (= - ($localize-body - (det-if-then $X $Y) $P - (det-if-then $X1 $Y1)) - ( (set-det) - ($localize-body $X $P $X1) - ($localize-body $Y $P $Y1))) -; + + !(public (/ halt 0)) + !(public (/ abort 0)) - (= - ($localize-body - (or $X $Y) $P - (or $X1 $Y1)) - ( (set-det) - ($localize-body $X $P $X1) - ($localize-body $Y $P $Y1))) -; + + (= (halt) + (halt 0)) + + (= (abort) + (raise-exception 'Execution aborted')) - (= - ($localize-body $G $P $G1) - ( (functor $G $F $A) - ($builtin-meta-predicates $F $A $M) - (set-det) - (=.. $G - (Cons $F $As)) - ($localize-args $M $As $P $As1) - (=.. $G1 - (Cons $F $As1)))) -; +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; DCG +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + !(public (, (/ C 3) (/ expand-term 2))) - (= - ($localize-body $G $P - (call (with_self $P $G))) - ( (var $P) (set-det))) -; + + (= (C (Cons $X $S) $X $S) True) - (= - ($localize-body $G user $G) - (set-det)) -; + + (= (expand-term $Dcg $Cl) + (var $Dcg) + (set-det) + (= $Dcg $Cl)) + (= (expand-term $Dcg $Cl) + ($dcg-expansion $Dcg $Cl0) + (set-det) + (= $Cl0 $Cl)) + (= (expand_term $Dcg $Dcg) True) - (= - ($localize-body $G $_ $G) - ( (system-predicate $G) (set-det))) -; + + (= ($dcg-expansion $Dcg $Cl) + (var $Dcg) + (set-det) + (= $Dcg $Cl)) + (= ($dcg-expansion (--> $Head $B) (= $H1 + ($G1 $G2))) + (nonvar $Head) + (= $Head + (, $H $List)) + (= $List + (Cons $_ $_)) + (set-det) + ($dcg-translation-atom $H $H1 $S0 $S1) + ($dcg-translation $B $G1 $S0 $S) + ($dcg-translation $List $G2 $S1 $S)) + (= ($dcg-expansion (--> $H $B) (= $H1 $B1)) + ($dcg-translation-atom $H $H1 $S0 $S) + ($dcg-translation $B $B1 $S0 $S)) - (= - (%localize_body $G $P - (: $P $G)) True) -; + + (= ($dcg-translation-atom $X (phrase $X $S0 $S) $S0 $S) + (var $X) + (set-det)) + (= ($dcg-translation-atom (with_self $M $X) (with_self $M $X1) $S0 $S) + (set-det) + ($dcg-translation-atom $X $X1 $S0 $S)) + (= ($dcg-translation-atom $X $X1 $S0 $S) + (=.. $X + (Cons $F $As)) + ($builtin-append $As + (:: $S0 $S) $As1) + (=.. $X1 + (Cons $F $As1))) + + (= ($dcg-translation $X $Y $S0 $S) + ($dcg-trans $X $Y0 $T $S0 $S) + ($dcg-trans0 $Y0 $Y $T $S0 $S)) - (= - ($localize-args Nil Nil $_ Nil) - (set-det)) -; + (= ($dcg-trans0 $Y $Y $T $S0 $T) + (\== $T $S0) + (set-det)) + (= ($dcg-trans0 $Y0 $Y $T $_ $S) + ($dcg-concat $Y0 + (= $S $T) $Y)) - (= - ($localize-args - (Cons : $Ms) - (Cons $A $As) $P - (Cons - (with_self $P $A) $As1)) - ( (or - (var $A) - (\= $A - (with_self $_ $_))) - (set-det) - ($localize-args $Ms $As $P $As1))) -; + + (= ($dcg-concat $X $Y $Z) + (== $X True) + (set-det) + (= $Z $Y)) + (= ($dcg-concat $X $Y $Z) + (== $Y True) + (set-det) + (= $Z $X)) + (= (%dcg_concat $X $Y (, $X $Y)) True) - (= - ($localize-args - (Cons $_ $Ms) - (Cons $A $As) $P - (Cons $A $As1)) - ($localize-args $Ms $As $P $As1)) -; + + (= ($dcg-trans $X $X1 $S $S0 $S) + (var $X) + (set-det) + ($dcg-translation-atom $X $X1 $S0 $S)) + (= ($dcg-trans (with_self $M $X) (with_self $M $Y) $T $S0 $S) + (set-det) + ($dcg-trans $X $Y $T $S0 $S)) + (= ($dcg-trans Nil True $S0 $S0 $_) + (set-det)) + (= ($dcg-trans (Cons $X $Y) $Z $T $S0 $S) + (set-det) + ($dcg-trans $Y $Y1 $T $S1 $S) + ($dcg-concat + (C $S0 $X $S1) $Y1 $Z)) + (= ($dcg-trans (not $X) (det-if-then-else $X1 fail (= $S $S0)) $S $S0 $S) + (set-det) + ($dcg-trans $X $X1 $S1 $S0 $S1)) + (= ($dcg-trans (, $X $Y) $Z $T $S0 $S) + (set-det) + ($dcg-trans $X $X1 $S1 $S0 $S1) + ($dcg-trans $Y $Y1 $T $S1 $S) + ($dcg-concat $X1 $Y1 $Z)) + (= ($dcg-trans (det-if-then $X $Y) (det-if-then $X1 $Y1) $T $S0 $S) + (set-det) + ($dcg-trans $X $X1 $S1 $S0 $S1) + ($dcg-trans $Y $Y1 $T $S1 $S)) + (= ($dcg-trans (or $X $Y) (or $X1 $Y1) $S $S0 $S) + (set-det) + ($dcg-translation $X $X1 $S0 $S) + ($dcg-translation $Y $Y1 $S0 $S)) + (= ($dcg-trans (set-det) (set-det) $S0 $S0 $_) + (set-det)) + (= ($dcg-trans {$G } (call $G) $S0 $S0 $_) + (var $G) + (set-det)) + (= ($dcg-trans {$G } $G $S0 $S0 $_) + (set-det)) + (= ($dcg-trans $X $X1 $S $S0 $S) + ($dcg-translation-atom $X $X1 $S0 $S)) +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Hash creation and control +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + !(public (/ new-hash 1)) + !(public (/ hash-map 2)) + !(public (/ hash-exists 1)) + + + (= (new-hash $Hash) + (new-hash $Hash Nil)) + + + (= (hash-map $H_or_a $List) + (hash-keys $H_or_a $Ks0) + (sort $Ks0 $Ks) + (hash-map $Ks $List $H_or_a)) + + (= (hash-map Nil Nil $_) + (set-det)) + (= (hash-map (Cons $K $Ks) (Cons (, $K $V) $Ls) $H_or_a) + (hash-get $H_or_a $K $V) + (hash-map $Ks $Ls $H_or_a)) - (= - (%builtin_meta_predicates ^ 2 - (? :)) True) -; + (= (hash-exists $Alias) + (atom $Alias) + ($get-hash-manager $HM) + (hash-contains-key $HM $Alias)) - (= - (%builtin_meta_predicates call 1 - (:)) True) -; +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Java interoperation +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; :- public java_constructor0/2. (written in Java) +; +; :- public java_declared_constructor0/2. (written in Java) +; +; :- public java_method0/3. (written in Java) +; +; :- public java_declared_method0/3. (written in Java) +; +; :- public java_get_field0/3. (written in Java) +; +; :- public java_get_declared_field0/3. (written in Java) +; +; :- public java_set_field0/3. (written in Java) +; +; :- public java_set_declared_field0/3. (written in Java) +; +; :- public java_conversion/2. (written in Java) + + !(public (/ java-constructor 2)) + !(public (/ java-declared-constructor 2)) + !(public (/ java-method 3)) + !(public (/ java-declared-method 3)) + !(public (/ java-get-field 3)) + !(public (/ java-get-declared-field 3)) + !(public (/ java-set-field 3)) + !(public (/ java-set-declared-field 3)) + !(public (/ synchronized 2)) - (= - (%builtin_meta_predicates once 1 - (:)) True) -; + + (= (java-constructor $Constr $Instance) + (=.. $Constr + (Cons $F $As)) + (builtin-java-convert-args $As $As1) + (=.. $Constr1 + (Cons $F $As1)) + (java-constructor0 $Constr1 $Instance1) + (= $Instance $Instance1)) - (= - (%builtin_meta_predicates \+ 1 - (:)) True) -; + + (= (java-declared-constructor $Constr $Instance) + (=.. $Constr + (Cons $F $As)) + (builtin-java-convert-args $As $As1) + (=.. $Constr1 + (Cons $F $As1)) + (java-declared-constructor0 $Constr1 $Instance1) + (= $Instance $Instance1)) - (= - (%builtin_meta_predicates findall 3 - (? : ?)) True) -; + + (= (java-method $Class_or_Instance $Method $Value) + (=.. $Method + (Cons $F $As)) + (builtin-java-convert-args $As $As1) + (=.. $Method1 + (Cons $F $As1)) + (java-method0 $Class_or_Instance $Method1 $Value1) + (java-conversion $Value2 $Value1) + (= $Value $Value2)) - (= - (%builtin_meta_predicates setof 3 - (? : ?)) True) -; + + (= (java-declared-method $Class_or_Instance $Method $Value) + (=.. $Method + (Cons $F $As)) + (builtin-java-convert-args $As $As1) + (=.. $Method1 + (Cons $F $As1)) + (java-declared-method0 $Class_or_Instance $Method1 $Value1) + (java-conversion $Value2 $Value1) + (= $Value $Value2)) - (= - (%builtin_meta_predicates bagof 3 - (? : ?)) True) -; + + (= (java-get-field $Class_or_Instance $Field $Value) + (java-get-field0 $Class_or_Instance $Field $Value1) + (java-conversion $Value2 $Value1) + (= $Value $Value2)) - (= - (%builtin_meta_predicates on_exception 3 - (? : :)) True) -; + + (= (java-get-declared-field $Class_or_Instance $Field $Value) + (java-get-declared-field0 $Class_or_Instance $Field $Value1) + (java-conversion $Value2 $Value1) + (= $Value $Value2)) - (= - (%builtin_meta_predicates catch 3 - (: ? :)) True) -; + + (= (java-set-field $Class_or_Instance $Field $Value) + (java-conversion $Value $Value1) + (java-set-field0 $Class_or_Instance $Field $Value1)) - (= - (%builtin_meta_predicates synchronized 2 - (? :)) True) -; + + (= (java-set-declared-field $Class_or_Instance $Field $Value) + (java-conversion $Value $Value1) + (java-set-declared-field0 $Class_or_Instance $Field $Value1)) - (= - (%builtin_meta_predicates freeze 2 - (? :)) True) -; + + (= (builtin-java-convert-args Nil Nil) + (set-det)) + (= (builtin-java-convert-args (Cons $X $Xs) (Cons $Y $Ys)) + (java-conversion $X $Y) + (builtin-java-convert-args $Xs $Ys)) + + (= (synchronized $Object $Goal) + ($begin-sync $Object $Ref) + (call $Goal) + ($end-sync $Ref)) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; MeTTa interpreter +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + !(op 1170 xfx :-) + !(op 1170 xfx -->) + !(op 1170 fx :-) + !(op 1170 fx ?-) + + !(op 1150 fx package) + !(op 1150 fx import) + !(op 1150 fx public) + !(op 1150 fx dynamic) + !(op 1150 fx meta-predicate) + !(op 1150 fx mode) + !(op 1150 fx multifile) + !(op 1150 fx block) + + !(public (/ cafeteria 0)) + !(public (/ consult 1)) + !(public (/ consult-stream 1)) + !(public (, (/ trace 0) (/ notrace 0))) + !(public (, (/ debug 0) (/ nodebug 0))) + !(public (/ leash 1)) + !(public (, (/ spy 1) (/ nospy 1) (/ nospyall 0))) + !(public (/ listing 0)) + !(public (/ listing 1)) + + !(dynamic (/ %current-leash 1)) + !(dynamic (/ %current-spypoint 3)) + !(dynamic (/ %leap-flag 1)) + !(dynamic (/ %consulted-file 1)) + !(dynamic (/ %consulted-import 2)) + !(dynamic (/ %consulted-package 1)) + !(dynamic (/ %consulted-predicate 3)) + +; +; ;; Main - (= - ($clause-to-term $Cl $T - (with_self $Pkg - (/ $F $A)) $Goal) - ( ($clause-to-term $Cl $T user $Pkg $Goal) - (= $T - (= $H $_)) - (functor $H $F $A))) -; + (= (cafeteria) + (%cafeteria-init) + (repeat) + (%toplvel-loop) + (on-exception $Msg + ($cafeteria $Goal) + (print-message error $Msg)) + (== $Goal end-of-file) + (set-det) + (nl) + ($fast-write bye) + (nl)) + + (= (%cafeteria-init) + ( (remove-all-atoms &self + (%leap_flag $_)) + (remove-all-atoms &self + (%current_leash $_)) + (remove-all-atoms &self + (%current_spypoint $_ $_ $_)) + (remove-all-atoms &self + (%consulted_file $_)) + (remove-all-atoms &self + (%consulted_package $_)) + (remove-all-atoms &self + (%consulted_predicate $_ $_ $_)) + (add-is-symbol &self + (%leap_flag no)) + (add-is-symbol &self + (%current_leash call)) + (add-is-symbol &self + (%current_leash exit)) + (add-is-symbol &self + (%current_leash redo)) + (add-is-symbol &self + (%current_leash fail)) + (set-det))) - (= - ($clause-to-term $Cl $_ $_ $_ $Goal) - ( (var $Cl) - (set-det) - (illarg var $Goal 1))) -; - - (= - ($clause-to-term $_ $_ $Pkg $_ $Goal) - ( (var $Pkg) - (set-det) - (illarg var $Goal 1))) -; + + (= (%toplvel-loop) + (current-prolog-flag debug $Mode) + (det-if-then-else + (== $Mode off) True + (print-message info + (:: debug))) + ($fast-write | ?- ) + (flush-output)) + + + (= ($cafeteria $Goal) + (read-with-variables $Goal $Vars) + ($process-order $Goal $Vars)) + + + (= ($process-order $G $_) + (var $G) + (set-det) + (illarg var + ! (?- $G) 1)) + (= ($process-order end-of-file $_) + (set-det)) + (= ($process-order (Cons $File $Files) $_) + (set-det) + (consult (Cons $File $Files))) + (= ($process-order $G $Vars) + (current-prolog-flag debug $Mode) + (det-if-then-else + (== $Mode off) + (call $G) + ($trace-goal $G)) + (nl) + ($rm-redundant-vars $Vars $Vars1) + ($give-answers-with-prompt $Vars1) + (set-det) + ($fast-write yes) + (nl)) + (= ($process-order $_ $_) + (nl) + ($fast-write no) + (nl)) + + + (= ($rm-redundant-vars Nil Nil) + (set-det)) + (= ($rm-redundant-vars (Cons (= - $_) $Xs) $Vs) + (set-det) + ($rm-redundant-vars $Xs $Vs)) + (= ($rm-redundant-vars (Cons $X $Xs) (Cons $X $Vs)) + ($rm-redundant-vars $Xs $Vs)) + + + (= ($give-answers-with-prompt Nil) + (set-det)) + (= ($give-answers-with-prompt $Vs) + ($give-an-answer $Vs) + ($fast-write ? ) + (flush-output) + (read-line $Str) + (\== $Str ";") + (nl)) + + + (= ($give-an-answer Nil) + (set-det) + ($fast-write True)) + (= ($give-an-answer (:: $X)) + (set-det) + ('$print-an answer' $X)) + (= ($give-an-answer (Cons $X $Xs)) + ('$print-an answer' $X) + ($fast-write ,) + (nl) + ($give-an-answer $Xs)) + + + (= ('$print-an answer' (= $N $V)) + (write $N) + ($fast-write = ) + (writeq $V)) + +; +; ;; Read Program + + (= (consult $Files) + (var $Files) + (set-det) + (illarg var + (consult $Files) 1)) + (= (consult Nil) + (set-det)) + (= (consult (Cons $File $Files)) + (set-det) + (consult $File) + (consult $Files)) + (= (consult $File) + (atom $File) + (set-det) + ($consult $File)) + + + (= ($consult $F) + ($prolog-file-name $F $PF) + (open $PF read $In) + (stream-property $In + (file-name $File)) + (print-message info + (:: consulting $File ...)) + (statistics runtime $_) + (consult-stream $File $In) + (statistics runtime + (:: $_ $T)) + (print-message info + (:: $File consulted $T msec)) + (close $In)) + + + (= (consult-stream $File $In) + ($consult-init $File) + (repeat) + (read $In $Cl) + ($consult-clause $Cl) + (== $Cl end-of-file) + (set-det)) + + + (= ($prolog-file-name $File $File) + (sub-atom $File $_ $_ $After .) + (> $After 0) + (set-det)) + (= ($prolog-file-name $File0 $File) + (atom-concat $File0 .pl $File)) + + + (= ($consult-init $File) + ( (remove-all-atoms &self + (%consulted_file $_)) + (remove-all-atoms &self + (%consulted_package $_)) + (remove-all-atoms &self + (%consulted_import $File $_)) + (remove-is-symbol &self + (%consulted_predicate $P $PI $File)) + (abolish (with_self $P $PI)) + (fail))) + (= ($consult-init $File) + ( (add-is-symbol &self + (%consulted_file $File)) (add-is-symbol &self (%consulted_package user)))) + + + (= ($consult-clause end-of-file) + (set-det)) + (= ($consult-clause !(module $P $_)) + (set-det) + ($assert-consulted-package $P)) + (= ($consult-clause !(package $P)) + (set-det) + ($assert-consulted-package $P)) + (= ($consult-clause !(import $P)) + (set-det) + ($assert-consulted-import $P)) + (= ($consult-clause !(dynamic $_)) + (set-det)) + (= ($consult-clause !(public $_)) + (set-det)) + (= ($consult-clause !(meta-predicate $_)) + (set-det)) + (= ($consult-clause !(mode $_)) + (set-det)) + (= ($consult-clause !(multifile $_)) + (set-det)) + (= ($consult-clause !(block $_)) + (set-det)) + (= ($consult-clause !$G) + ( (set-det) + (== + (= + (%consulted_package $P) $_) + (get-atoms &self)) + (once (with_self $P $G)))) + (= ($consult-clause $Clause0) + ($consult-preprocess $Clause0 $Clause) + ($consult-cls $Clause)) - (= - ($clause-to-term - (with_self $P $Cl) $T $_ $Pkg $Goal) - ( (set-det) ($clause-to-term $Cl $T $P $Pkg $Goal))) -; + + (= ($assert-consulted-package $P) + ( (== + (= + (%consulted_package $P) $_) + (get-atoms &self)) (set-det))) + (= ($assert-consulted-package $P) + ( (remove-all-atoms &self + (%consulted_package $_)) (add-is-symbol &self (%consulted_package $P)))) - (= - ($clause-to-term $_ $_ $Pkg $_ $Goal) - ( (not (atom $Pkg)) - (set-det) - (illarg - (type is-symbol) $Goal 1))) -; + + (= ($assert-consulted-import $P) + ( (== + (= + (%consulted_file $File) $_) + (get-atoms &self)) (add-is-symbol &self (%consulted_import $File $P)))) - (= - ($clause-to-term - (= $H0 $B) - (= $H $B) $Pkg $Pkg $Goal) - ( (set-det) ($head-to-term $H0 $H $_ $Goal))) -; + + (= ($consult-preprocess $Clause0 $Clause) + (expand-term $Clause0 $Clause)) - ; -; - (= - ($clause-to-term $H0 - (= $H True) $Pkg $Pkg $Goal) - ($head-to-term $H0 $H $_ $Goal)) -; + (= ($consult-cls (= $H $G)) + (set-det) + ($assert-consulted-clause (= $H $G))) + (= ($consult-cls $H) + ($assert-consulted-clause (= $H True))) + + (= ($assert-consulted-clause $Clause) + ( (= $Clause + (= $H $_)) + (functor $H $F $A) + (== + (= + (%consulted_file $File) $_) + (get-atoms &self)) + (== + (= + (%consulted_package $P) $_) + (get-atoms &self)) + (add-is-symbol &self + (: $P $Clause)) + (add-is-symbol &self + (%consulted_predicate $P + (/ $F $A) $File)) + (set-det))) ; -; - +; ;; Trace - (= - ($term-to-predicateindicator $T - (with_self $Pkg $PI) $Goal) - ($term-to-predicateindicator $T $PI user $Pkg $Goal)) -; + (= (trace) + (current-prolog-flag debug on) + (set-det)) + (= (trace) + (set-prolog-flag debug on) + (%trace-init) + ($fast-write '{Small debugger is switch on}') + (nl) + (set-det)) + + (= (%trace-init) + ( (remove-all-atoms &self + (%leap_flag $_)) + (remove-all-atoms &self + (%current_leash $_)) + (remove-all-atoms &self + (%current_spypoint $_ $_ $_)) + (add-is-symbol &self + (%leap_flag no)) + (add-is-symbol &self + (%current_leash call)) + (add-is-symbol &self + (%current_leash exit)) + (add-is-symbol &self + (%current_leash redo)) + (add-is-symbol &self + (%current_leash fail)) + (set-det))) - (= - ($term-to-predicateindicator $T $_ $_ $_ $Goal) - ( (var $T) - (set-det) - (illarg var $Goal 1))) -; + + (= (notrace) + (current-prolog-flag debug off) + (set-det)) + (= (notrace) + (set-prolog-flag debug off) + ($fast-write '{Small debugger is switch off}') + (nl) + (set-det)) - (= - ($term-to-predicateindicator $_ $_ $Pkg $_ $Goal) - ( (var $Pkg) - (set-det) - (illarg var $Goal 1))) -; + + (= (debug) + (trace)) + + (= (nodebug) + (notrace)) - (= - ($term-to-predicateindicator - (with_self $P $T) $PI $_ $Pkg $Goal) - ( (set-det) ($term-to-predicateindicator $T $PI $P $Pkg $Goal))) -; +; +; ;; Spy-Points + + (= (spy $T) + ($term-to-predicateindicator $T $PI + (spy $T)) + (trace) + ($assert-spypoint $PI) + ($set-debug-flag leap yes) + (set-det)) - (= - ($term-to-predicateindicator $T $_ $_ $_ $Goal) - ( (\= $T - (/ $_ $_)) - (set-det) - (illarg - (type predicate-indicator) $Goal 1))) -; + + (= ($assert-spypoint (with_self $P (/ $F $A))) + ( (== + (= + (%current_spypoint $P $F $A) $_) + (get-atoms &self)) + (print-message info + (:: spypoint + (with_self $P + (/ $F $A)) is already added)) + (set-det))) + (= ($assert-spypoint (with_self $P (/ $F $A))) + ( (== + (= + (%consulted_predicate $P + (/ $F $A) $_) $_) + (get-atoms &self)) + (add-is-symbol &self + (%current_spypoint $P $F $A)) + (print-message info + (:: spypoint + (with_self $P + (/ $F $A)) is added)) + (set-det))) + (= ($assert-spypoint (with_self $P (/ $F $A))) + (print-message warning + (:: no matching predicate for spy + (with_self $P + (/ $F $A))))) - (= - ($term-to-predicateindicator - (/ $F $_) $_ $_ $_ $Goal) - ( (not (atom $F)) - (set-det) - (illarg - (type is-symbol) $Goal 1))) -; + + (= (nospy $T) + ($term-to-predicateindicator $T $PI + (nospy $T)) + ($retract-spypoint $PI) + ($set-debug-flag leap no) + (set-det)) - (= - ($term-to-predicateindicator - (/ $_ $A) $_ $_ $_ $Goal) - ( (not (integer $A)) - (set-det) - (illarg - (type integer) $Goal 1))) -; + + (= ($retract-spypoint (with_self $P (/ $F $A))) + ( (remove-is-symbol &self + (%current_spypoint $P $F $A)) + (print-message info + (:: spypoint + (with_self $P + (/ $F $A)) is removed)) + (set-det))) + (= (%retract_spypoint $_) True) - (= - (%term_to_predicateindicator $T $T $Pkg $Pkg $_) True) -; + + (= (nospyall) + ( (remove-all-atoms &self + (%current_spypoint $_ $_ $_)) ($set-debug-flag leap no))) +; +; ;; Leash + + (= (leash $L) + (nonvar $L) + ($leash $L) + (set-det)) + (= (leash $L) + (illarg + (type leash-specifier) + (leash $L) 1)) - (= - ($update-indexing $P $PI $Cl $Ref $A_or_Z) - ( ($new-indexing-hash $P $PI $IH) - ($gen-indexing-keys $Cl $IH $Keys) - ($update-indexing-hash $A_or_Z $Keys $IH $Ref))) -; + (= ($leash Nil) + ( (set-det) + (remove-all-atoms &self + (%current_leash $_)) + (print-message info + (:: no leashing)))) + (= ($leash $Ms) + ( (remove-all-atoms &self + (%current_leash $_)) + ($assert-leash $Ms) + (print-message info + (:: leashing stopping on $Ms)))) + + (= ($assert-leash Nil) + (set-det)) + (= ($assert-leash (Cons $X $Xs)) + ( ($leash-specifier $X) + (add-is-symbol &self + (%current_leash $X)) + ($assert-leash $Xs))) - (= - ($gen-indexing-keys - (= $H $_) $_ - (:: all)) - ( (atom $H) (set-det))) -; + (= (%leash_specifier call) True) + (= (%leash_specifier exit) True) + (= (%leash_specifier redo) True) + (= (%leash_specifier fail) True) +; +; '$leash_specifier'(exception). - (= - ($gen-indexing-keys - (= $H $_) $IT $Keys) - ( (arg 1 $H $A1) ($gen-indexing-keys0 $A1 $IT $Keys))) -; +; +; ;; Trace a Goal + + (= ($trace-goal $Term) + ($set-debug-flag leap no) + ($get-current-B $Cut) + ($meta-call $Term user $Cut 0 trace)) + (= ($trace-goal $X $P $FA $Depth) + (print-procedure-box call $X $P $FA $Depth) + ($call-internal $X $P $FA $Depth trace) + (print-procedure-box exit $X $P $FA $Depth) + (redo-procedure-box $X $P $FA $Depth)) + (= ($trace-goal $X $P $FA $Depth) + (print-procedure-box fail $X $P $FA $Depth) + (fail)) - (= - ($gen-indexing-keys0 $A1 $IT $Keys) - ( (var $A1) + (= (print-procedure-box $Mode $G $P (/ $F $A) $Depth) + ( (== + (= + (%current_spypoint $P $F $A) $_) + (get-atoms &self)) (set-det) - (hash-keys $IT $Keys))) -; - - (= - ($gen-indexing-keys0 $A1 $_ - (:: all lis)) - ( (= $A1 - (Cons $_ $_)) (set-det))) -; - - (= - ($gen-indexing-keys0 $A1 $_ - (:: all str)) - ( (compound $A1) (set-det))) -; - - (= - ($gen-indexing-keys0 $A1 $IT - (:: all $Key)) - ( (ground $A1) - (set-det) - ($term-hash $A1 $Key) - (det-if-then-else - (hash-contains-key $IT $Key) True - (, - (hash-get $IT var $L) - (hash-put $IT $Key $L))))) -; - - (= - ($gen-indexing-keys0 $A1 $IT $Keys) - (illarg - (type term) - ($gen-indexing-keys0 $A1 $IT $Keys) 1)) -; - - - - (= - ($update-indexing-hash a $Keys $IH $Ref) - ( (set-det) ($hash-addz-all $Keys $IH $Ref))) -; - - (= - ($update-indexing-hash z $Keys $IH $Ref) - ( (set-det) ($hash-adda-all $Keys $IH $Ref))) -; - - - - (= - ($hash-adda-all Nil $_ $_) - (set-det)) -; - - (= - ($hash-adda-all - (Cons $K $Ks) $H $X) - ( ($hash-adda $H $K $X) ($hash-adda-all $Ks $H $X))) -; - - - - (= - ($hash-addz-all Nil $_ $_) - (set-det)) -; - - (= - ($hash-addz-all - (Cons $K $Ks) $H $X) - ( ($hash-addz $H $K $X) ($hash-addz-all $Ks $H $X))) -; - - - - (= - ($erase-all Nil) - (set-det)) -; - - (= - ($erase-all (Cons $R $Rs)) - ( ($erase $R) ($erase-all $Rs))) -; - - - - (= - ($rehash-indexing $P $PI $Ref) - ( ($new-indexing-hash $P $PI $IH) - (hash-keys $IH $Keys) - ($remove-index-all $Keys $IH $Ref))) -; - - - - (= - ($remove-index-all Nil $_ $_) - (set-det)) -; - - (= - ($remove-index-all - (Cons $K $Ks) $IH $Ref) - ( ($hash-remove-first $IH $K $Ref) ($remove-index-all $Ks $IH $Ref))) -; - - -; -; - -; -; - -; -; - - - !(public (/ findall 3)) -; - - !(public (/ bagof 3)) -; - - !(public (/ setof 3)) -; - - -; -; - - - (= - (findall $Template $Goal $Instances) - ( (callable $Goal) - (set-det) - (new-hash $H) - ($findall $H $Template $Goal $Instances))) -; - - (= - (findall $Template $Goal $Instances) - (illarg - (type callable) - (findall $Template $Goal $Instances) 2)) -; - - - - (= - ($findall $H $Template $Goal $_) - ( (call $Goal) - (copy-term $Template $CT) - ($hash-addz $H %FINDALL $CT) - (fail))) -; - - (= - ($findall $H $_ $_ $Instances) - (hash-get $H %FINDALL $Instances)) -; - - -; -; - - - (= - (bagof $Template $Goal $Instances) - ( (callable $Goal) - (set-det) - ($bagof $Template $Goal $Instances))) -; - - (= - (bagof $Template $Goal $Instances) - (illarg - (type callable) - (bagof $Template $Goal $Instances) 2)) -; - - - - (= - (setof $Template $Goal $Instances) - ( (callable $Goal) - (set-det) - ($bagof $Template $Goal $Instances0) - (sort $Instances0 $Instances))) -; - - (= - (setof $Template $Goal $Instances) - (illarg - (type callable) - (setof $Template $Goal $Instances) 2)) -; - - - - (= - ($bagof $Template $Goal $Instances) - ( ($free-variables-set $Goal $Template $FV) - (\== $FV Nil) - (set-det) - (=.. $Witness - (Cons %witness $FV)) - (findall - (+ $Witness $Template) $Goal $S) - ($bagof-instances $S $Witness $Instances0) - (= $Instances $Instances0))) -; - - (= - ($bagof $Template $Goal $Instances) - ( (findall $Template $Goal $Instances) (\== $Instances Nil))) -; - - - - (= - (%bagof_instances () $Witness $Instances) - (empty)) -; - - (= - ($bagof-instances $S0 $Witness $Instances) - ( (= $S0 - (Cons - (+ $W $T) $S)) - ($variants-subset $S $W $WT_list $T_list $S_next) - ($bagof-instances0 $S_next $Witness $Instances - (Cons - (+ $W $T) $WT_list) - (Cons $T $T_list)))) -; - - - - (= - ($bagof-instances0 $_ $Witness $Instances $WT_list $T_list) - ( ($unify-witness $WT_list $Witness) (= $Instances $T_list))) -; - - (= - ($bagof-instances0 $S_next $Witness $Instances $_ $_) - ($bagof-instances $S_next $Witness $Instances)) -; - - - - (= - ($variants-subset Nil $W Nil Nil Nil) - (set-det)) -; - - (= - ($variants-subset - (Cons - (+ $W0 $T0) $S) $W - (Cons - (+ $W0 $T0) $WT_list) - (Cons $T0 $T_list) $S_next) - ( ($term-variant $W $W0) - (set-det) - ($variants-subset $S $W $WT_list $T_list $S_next))) -; - - (= - ($variants-subset - (Cons $WT $S) $W $WT_list $T_list - (Cons $WT $S_next)) - ($variants-subset $S $W $WT_list $T_list $S_next)) -; - - - - (= - ($term-variant $X $Y) - ( (new-hash $Hash) ($term-variant $X $Y $Hash))) -; - - - (= - ($term-variant $X $Y $Hash) - ( (var $X) - (set-det) - (det-if-then-else - (hash-contains-key $Hash $X) - (, - (hash-get $Hash $X $V) - (== $Y $V)) - (, - (var $Y) - (hash-put $Hash $X $Y))))) -; - - (= - ($term-variant $X $Y $_) - ( (ground $X) - (set-det) - (== $X $Y))) -; - - (= - ($term-variant $_ $Y $_) - ( (var $Y) - (set-det) - (fail))) -; - - (= - ($term-variant - (Cons $X $Xs) - (Cons $Y $Ys) $Hash) - ( (set-det) - ($term-variant $X $Y $Hash) - ($term-variant $Xs $Ys $Hash))) -; - - (= - ($term-variant $X $Y $Hash) - ( (=.. $X $Xs) - (=.. $Y $Ys) - ($term-variant $Xs $Ys $Hash))) -; - - - - (= - ($unify-witness Nil $_) - (set-det)) -; - - (= - ($unify-witness - (Cons - (+ $W $_) $WT_list) $W) - ($unify-witness $WT_list $W)) -; - - -; -; - - - (= - ($variables-set $X $Vs) - ($variables-set $X Nil $Vs)) -; - - - (= - ($variables-set $X $Vs $Vs) - ( (var $X) - ($builtin-memq $X $Vs) - (set-det))) -; - - (= - ($variables-set $X $Vs - (Cons $X $Vs)) - ( (var $X) (set-det))) -; - - (= - ($variables-set $X $Vs0 $Vs0) - ( (atomic $X) (set-det))) -; - - (= - ($variables-set - (Cons $X $Xs) $Vs0 $Vs) - ( (set-det) - ($variables-set $X $Vs0 $Vs1) - ($variables-set $Xs $Vs1 $Vs))) -; - - (= - ($variables-set $X $Vs0 $Vs) - ( (=.. $X $Xs) ($variables-set $Xs $Vs0 $Vs))) -; - - - - (= - ($builtin-memq $X - (Cons $Y $_)) - ( (== $X $Y) (set-det))) -; - - (= - ($builtin-memq $X - (Cons $_ $Ys)) - ($builtin-memq $X $Ys)) -; - - -; -; - - - (= - ($existential-variables-set $X $Vs) - ($existential-variables-set $X Nil $Vs)) -; - - - (= - ($existential-variables-set $X $Vs $Vs) - ( (var $X) (set-det))) -; - - (= - ($existential-variables-set $X $Vs $Vs) - ( (atomic $X) (set-det))) -; - - (= - ($existential-variables-set - (with_self $_ $X) $Vs0 $Vs) - ( (set-det) ($existential-variables-set $X $Vs0 $Vs))) -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - (= - ($existential-variables-set - (^ $V $G) $Vs0 $Vs) - ( (set-det) - ($variables-set $V $Vs0 $Vs1) - ($existential-variables-set $G $Vs1 $Vs))) -; - - (= - ($existential-variables-set - ($meta-call $G $_ $_ $_ $_) $Vs0 $Vs) - ( (set-det) ($existential-variables-set $G $Vs0 $Vs))) -; - - (= - (%existential_variables_set $_ $Vs $Vs) True) -; - - -; -; - - - (= - ($free-variables-set $T $V $FV) - ( ($variables-set $T $TV) - ($variables-set $V $VV) - ($existential-variables-set $T $VV $BV) - ($builtin-set-diff $TV $BV $FV) - (set-det))) -; - - - - (= - ($builtin-set-diff $L1 $L2 $L) - ( (sort $L1 $SL1) - (sort $L2 $SL2) - ($builtin-set-diff0 $SL1 $SL2 $L))) -; - - - - (= - ($builtin-set-diff0 Nil $_ Nil) - (set-det)) -; - - (= - ($builtin-set-diff0 $L1 Nil $L1) - (set-det)) -; - - (= - ($builtin-set-diff0 - (Cons $X $Xs) - (Cons $Y $Ys) $L) - ( (== $X $Y) - (set-det) - ($builtin-set-diff0 $Xs $Ys $L))) -; - - (= - ($builtin-set-diff0 - (Cons $X $Xs) - (Cons $Y $Ys) - (Cons $X $L)) - ( (@< $X $Y) - (set-det) - ($builtin-set-diff0 $Xs - (Cons $Y $Ys) $L))) -; - - (= - ($builtin-set-diff0 - (Cons $X $Xs) - (Cons $Y $Ys) - (Cons $Y $L)) - ($builtin-set-diff0 - (Cons $X $Xs) $Ys - (Cons $Y $L))) -; - - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - - !(public (/ open 3)) -; - -; -; - - !(public (/ close 1)) -; - -; -; - - !(public (/ flush-output 0)) -; - - !(public (/ stream-property 2)) -; - - - - (= - (open $Source_sink $Mode $Stream) - (open $Source_sink $Mode $Stream Nil)) -; - - - - (= - (close $S_or_a) - (close $S_or_a Nil)) -; - - - - (= - (flush-output) - ( (current-output $S) (flush-output $S))) -; - - - - (= - (stream-property $Stream $Stream_property) - ( (var $Stream_property) - (set-det) - ($stream-property $Stream $Stream_property))) -; - - (= - (stream-property $Stream $Stream_property) - ( ($stream-property-specifier $Stream_property) - (set-det) - ($stream-property $Stream $Stream_property))) -; - - (= - (stream-property $Stream $Stream_property) - (illarg - (domain term stream-property) - (stream-property $Stream $Stream_property) 2)) -; - - - - (= - ($stream-property $Stream $Stream_property) - ( (var $Stream) - (set-det) - ($get-stream-manager $SM) - (hash-map $SM $Map) - ($builtin-member - (, $Stream $Vs) $Map) - (java $Stream) - ($builtin-member $Stream_property $Vs))) -; - - (= - ($stream-property $Stream $Stream_property) - ( (java $Stream) - (set-det) - ($get-stream-manager $SM) - (hash-get $SM $Stream $Vs) - ($builtin-member $Stream_property $Vs))) -; - - (= - ($stream-property $Stream $Stream_property) - (illarg - (domain stream stream) - (stream-property $Stream $Stream_property) 1)) -; - - - - (= - (%stream_property_specifier input) True) -; - - (= - (%stream_property_specifier output) True) -; - - (= - (%stream_property_specifier - (alias $_)) True) -; - - (= - (%stream_property_specifier - (mode $_)) True) -; - - (= - (%stream_property_specifier - (type $_)) True) -; - - (= - (%stream_property_specifier - (file_name $_)) True) -; - - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - - - !(public (, (/ get-char 1) (/ get-code 1))) -; - - !(public (, (/ peek-char 1) (/ peek-code 1))) -; - - !(public (, (/ put-char 1) (/ put-code 1))) -; - - !(public (/ nl 1)) -; - - - - (= - (get-char $Char) - ( (current-input $S) (get-char $S $Char))) -; - - - (= - (get-code $Code) - ( (current-input $S) (get-code $S $Code))) -; - - - - (= - (peek-char $Char) - ( (current-input $S) (peek-char $S $Char))) -; - - - (= - (peek-code $Code) - ( (current-input $S) (peek-code $S $Code))) -; - - - - (= - (put-char $Char) - ( (current-output $S) (put-char $S $Char))) -; - - - (= - (put-code $Code) - ( (current-output $S) (put-code $S $Code))) -; - - - - (= - (nl $S) - (put-char $S -)) -; - - - - !(public (, (/ get0 1) (/ get0 2))) -; - - !(public (/ get 1)) -; - -; -; - - !(public (, (/ put 1) (/ put 2))) -; - - !(public (/ tab 1)) -; - -; -; - - !(public (/ skip 1)) -; - -; -; - - - - (= - (get0 $Code) - ( (current-input $S) (get-code $S $Code))) -; - - (= - (get0 $S_or_a $Code) - (get-code $S_or_a $Code)) -; - - - - (= - (get $Code) - ( (current-input $S) (get $S $Code))) -; - - - - (= - (put $Exp) - ( (current-output $S) (put $S $Exp))) -; - - (= - (put $S_or_a $Exp) - ( (is $Code $Exp) (put-code $S_or_a $Code))) -; - - - - (= - (tab $N) - ( (current-output $S) (tab $S $N))) -; - - - - (= - (skip $N) - ( (current-input $S) (skip $S $N))) -; - - -; -; - -; -; - -; -; - - - !(public (, (/ get-byte 1) (/ peek-byte 1) (/ put-byte 1))) -; - -; -; - -; -; - -; -; - - - - (= - (get-byte $Byte) - ( (current-input $S) (get-byte $S $Byte))) -; - - - - (= - (peek-byte $Byte) - ( (current-input $S) (peek-byte $S $Byte))) -; - - - - (= - (put-byte $Byte) - ( (current-output $S) (put-byte $S $Byte))) -; - - -; -; - -; -; - -; -; - - - !(public (, (/ read 1) (/ read 2))) -; - - !(public (, (/ read-with-variables 2) (/ read-with-variables 3))) -; - - !(public (/ read-line 1)) -; - -; -; - - !(dynamic (/ %tokens 1)) -; - - - - (= - (read $X) - ( (current-input $S) (read $S $X))) -; - - - (= - (read $S_or_a $X) - ( (read-tokens $S_or_a $Tokens $_) - (parse-tokens $X $Tokens) - (set-det))) -; - - - - (= - (read-with-variables $X $Vs) - ( (current-input $S) (read-with-variables $S $X $Vs))) -; - - - (= - (read-with-variables $S_or_a $X $Vs) - ( (read-tokens $S_or_a $Tokens $Vs) - (parse-tokens $X $Tokens) - (set-det))) -; - - - - (= - (read-line $X) - ( (current-input $S) (read-line $S $X))) -; - - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - -; -; - - - - (= - (read-token $S_or_a $Token) - ( ($read-token0 $S_or_a $Type $Token0) ($read-token1 (:: $Type) $Token0 $Token))) -; - - - - (= - ($read-token1 - (:: -2) $T - (error $T)) - (set-det)) -; - ; -; - - (= - ($read-token1 "I" $T - (number $T)) - (set-det)) -; - ; -; - - (= - ($read-token1 "L" $T - (number $T)) - (set-det)) -; - ; -; - - (= - ($read-token1 "D" $T - (number $T)) - (set-det)) -; - ; -; - - (= - ($read-token1 "A" $T - (atom $T)) - (set-det)) -; - ; -; - - (= - ($read-token1 "V" $T - (var $T)) - (set-det)) -; - ; -; - - (= - ($read-token1 "S" $T - (string $T)) - (set-det)) -; - ; -; - - (= - ($read-token1 $_ $T $T) - (set-det)) -; - ; -; - - -; -; - -; -; - -; -; - -; -; - -; -; - - -; -; - -; -; - -; -; - -; -; - - - - (= - (read-tokens $Stream $Tokens $Vs) - ( ($read-tokens $Stream $Tokens $Vs Nil) (set-det))) -; - - - - (= - ($read-tokens $Stream $Tokens $Vs $VI) - ( (read-token $Stream $Token) ($read-tokens1 $Stream $Token $Tokens $Vs $VI))) -; - - - - (= - ($read-tokens1 $Stream - (error $Message) Nil $_ $_) - ( (set-det) - (write user-error '{SYNTAX ERROR}') - (nl user-error) - (write user-error ** ) - (write user-error $Message) - (write user-error **) - (nl user-error) - (flush-output user-error) - ($read-tokens-until-fullstop $Stream) - (fail))) -; - - (= - ($read-tokens1 $Stream end-of-file - (:: end-of-file .) Nil $_) - (set-det)) -; - - (= - ($read-tokens1 $Stream . - (:: .) Nil $_) - (set-det)) -; - - (= - ($read-tokens1 $Stream - (var -) - (Cons - (var - $V) $Tokens) - (Cons - (= - $V) $Vs) $VI0) - ( (set-det) ($read-tokens $Stream $Tokens $Vs (Cons (= - $V) $VI0)))) -; - - (= - ($read-tokens1 $Stream - (var $Name) - (Cons - (var $Name $V) $Tokens) $Vs $VI) - ( ($mem-pair - (= $Name $V) $VI) - (set-det) - ($read-tokens $Stream $Tokens $Vs $VI))) -; - - (= - ($read-tokens1 $Stream - (var $Name) - (Cons - (var $Name $V) $Tokens) - (Cons - (= $Name $V) $Vs) $VI0) - ( (set-det) ($read-tokens $Stream $Tokens $Vs (Cons (= $Name $V) $VI0)))) -; - - (= - ($read-tokens1 $Stream $Token - (Cons $Token $Tokens) $Vs $VI) - ($read-tokens $Stream $Tokens $Vs $VI)) -; - - - - (= - ($mem-pair - (= $X1 $V1) - (Cons - (= $X2 $V2) $_)) - ( (== $X1 $X2) - (set-det) - (= $V1 $V2))) -; - - (= - ($mem-pair $X - (Cons $_ $L)) - ($mem-pair $X $L)) -; - -; -; - - - - (= - ($read-tokens-until-fullstop $Stream) - ( (read-token $Stream $Token) ($read-tokens-until-fullstop $Stream $Token))) -; - - - (= - ($read-tokens-until-fullstop $Stream end-of-file) - (set-det)) -; - - (= - ($read-tokens-until-fullstop $Stream .) - (set-det)) -; - - (= - ($read-tokens-until-fullstop $Stream $_) - ( (read-token $Stream $Token) ($read-tokens-until-fullstop $Stream $Token))) -; - - - - (= - (parse-tokens $X $Tokens) - ( (remove-all-symbols &self - ($tokens $_)) - (add-symbol &self - ($tokens $Tokens)) - ($parse-tokens $X 1201 $Tokens - (:: .)) - (remove-symbol &self - ($tokens $Tokens)) - (set-det))) -; - - -; -; - - - (= - (--> - (%parse_tokens $X $Prec0) - (, $parse_tokens_skip_spaces - (, - (%parse_tokens1 $Prec0 $X1 $Prec1) - (, ! - (, $parse_tokens_skip_spaces - (, - (%parse_tokens2 $Prec0 $X1 $Prec1 $X $Prec) !)))))) True) -; - - - (= - (--> - (%parse_tokens1 $Prec0 $X1 $Prec1) - (, - (%parse_tokens_peep_next $Next) - (, - { (%parse_tokens_is_starter $Next) } - (, ! - (%parse_tokens_before_op $Prec0 $X1 $Prec1))))) True) -; - - (= - (--> - (%parse_tokens1 $_ $_ $_) - (, - (%parse_tokens_peep_next $Next) - (%parse_tokens_error - ($Next cannot start an expression)))) True) -; - - - (= - (--> - (%parse_tokens2 $Prec0 $X $Prec $X $Prec) - (, - (%parse_tokens_peep_next $Next) - (, - { (%parse_tokens_is_terminator $Next) } - (, - { (=< $Prec $Prec0) } !)))) True) -; - - (= - (--> - (%parse_tokens2 $Prec0 $X1 $Prec1 $X $Prec) - (, - (%parse_tokens_peep_next $Next) - (, - { (%parse_tokens_is_post_in_op $Next) } - (, ! - (%parse_tokens_post_in_ops $Prec0 $X1 $Prec1 $X $Prec))))) True) -; - - (= - (--> - (%parse_tokens2 $_ $_ $_ $_ $_) - (%parse_tokens_error - (operator expected after expression))) True) -; - - -; -; - -; -; - -; -; - - (= - (--> - (%parse_tokens_before_op $Prec0 $X $Prec) - (, - (' ') - (, ! - (%parse_tokens_before_op $Prec0 $X $Prec)))) True) -; - - (= - (--> - (%parse_tokens_before_op $_ end_of_file 0) - (, - (end_of_file) !)) True) -; - - (= - (--> - (%parse_tokens_before_op $_ $N 0) - (, - ( (number $N)) !)) True) -; - - (= - (--> - (%parse_tokens_before_op $_ $N 0) - (, - ( (is-symbol -)) - (, - ( (number $N0)) - (, ! - { (is $N - (- $N0)) })))) True) -; - - (= - (--> - (%parse_tokens_before_op $_ $V 0) - (, - ( (var $_ $V)) !)) True) -; - - (= - (--> - (%parse_tokens_before_op $_ $S 0) - (, - ( (string $S)) !)) True) -; - - (= - (--> - (%parse_tokens_before_op $_ $X 0) - (, - (() - (, ! - (, - (%parse_tokens $X 1201) - (%parse_tokens_expect )))))) True) -; - - (= - (--> - (%parse_tokens_before_op $_ $X 0) - (, - ({) - (, ! - (, $parse_tokens_skip_spaces - (%parse_tokens_brace $X))))) True) -; - - (= - (--> - (%parse_tokens_before_op $_ $X 0) - (, - ([) - (, ! - (, $parse_tokens_skip_spaces - (%parse_tokens_list $X))))) True) -; - - (= - (--> - (%parse_tokens_before_op $_ $X 0) - (, - ( (is-symbol $F)) - (, - (() - (, ! - (, $parse_tokens_skip_spaces - (, - (%parse_tokens_args $Args) - { (=.. $X - (Cons $F $Args)) })))))) True) -; - - (= - (--> - (%parse_tokens_before_op $Prec0 $X $PrecOp) - (, - ( (is-symbol $F)) - (, - { (current_op $PrecOp fx $F) } - (, - { (=< $PrecOp $Prec0) } - (, $parse_tokens_skip_spaces - (, - (%parse_tokens_peep_next $Next) - (, - { (%parse_tokens_is_starter $Next) } - (, - { (\+ - (%parse_tokens_is_post_in_op $Next)) } - (, ! - (, - { (is $Prec1 - (- $PrecOp 1)) } - (, - (%parse_tokens $Arg $Prec1) - (, - { (functor $X $F 1) } - { (arg 1 $X $Arg) })))))))))))) True) -; - - (= - (--> - (%parse_tokens_before_op $Prec0 $X $PrecOp) - (, - ( (is-symbol $F)) - (, - { (current_op $PrecOp fy $F) } - (, - { (=< $PrecOp $Prec0) } - (, $parse_tokens_skip_spaces - (, - (%parse_tokens_peep_next $Next) - (, - { (%parse_tokens_is_starter $Next) } - (, - { (\+ - (%parse_tokens_is_post_in_op $Next)) } - (, ! - (, - (%parse_tokens $Arg $PrecOp) - (, - { (functor $X $F 1) } - { (arg 1 $X $Arg) }))))))))))) True) -; - - (= - (--> - (%parse_tokens_before_op $_ $A 0) - ( (is-symbol $A))) True) -; - - - (= - (--> - (%parse_tokens_brace {}) - (, - (}) !)) True) -; - - (= - (--> - (%parse_tokens_brace $X) - (, - (%parse_tokens $X1 1201) - (, - (%parse_tokens_expect }) - { (= $X - {$X1 }) }))) True) -; - - - (= - (--> - (%parse_tokens_list []) - (, - (]) !)) True) -; - - (= - (--> - (%parse_tokens_list - (Cons $X $Xs)) - (, - (%parse_tokens $X 999) - (, $parse_tokens_skip_spaces - (%parse_tokens_list_rest $Xs)))) True) -; - - - (= - (--> - (%parse_tokens_list_rest $Xs) - (, - (|) - (, ! - (, - (%parse_tokens $Xs 999) - (%parse_tokens_expect ]))))) True) -; - - (= - (--> - (%parse_tokens_list_rest - (Cons $X $Xs)) - (, - (,) - (, ! - (, - (%parse_tokens $X 999) - (, $parse_tokens_skip_spaces - (%parse_tokens_list_rest $Xs)))))) True) -; - - (= - (--> - (%parse_tokens_list_rest []) - (%parse_tokens_expect ])) True) -; - - - (= - (--> - (%parse_tokens_args []) - (, - ()) !)) True) -; - - (= - (--> - (%parse_tokens_args - (Cons $X $Xs)) - (, - (%parse_tokens $X 999) - (, $parse_tokens_skip_spaces - (%parse_tokens_args_rest $Xs)))) True) -; - - - (= - (--> - (%parse_tokens_args_rest - (Cons $X $Xs)) - (, - (,) - (, ! - (, - (%parse_tokens $X 999) - (, $parse_tokens_skip_spaces - (%parse_tokens_args_rest $Xs)))))) True) -; - - (= - (--> - (%parse_tokens_args_rest []) - (%parse_tokens_expect ))) True) -; - - -; -; - -; -; - -; -; - - (= - (--> - (%parse_tokens_post_in_ops $Prec0 $X1 $Prec1 $X $Prec) - (, $parse_tokens_skip_spaces - (, - ($Op) - (, - (%parse_tokens_op $Op $Prec0 $X1 $Prec1 $X2 $Prec2) - (%parse_tokens_post_in_ops $Prec0 $X2 $Prec2 $X $Prec))))) True) -; - - (= - (--> - (%parse_tokens_post_in_ops $Prec0 $X $Prec $X $Prec) - { (=< $Prec $Prec0) }) True) -; - - - (= - (--> - (%parse_tokens_op , $Prec0 $X1 $Prec1 $X $PrecOp) - (, ! - (%parse_tokens_op - (is-symbol ,) $Prec0 $X1 $Prec1 $X $PrecOp))) True) -; - - (= - (--> - (%parse_tokens_op | $Prec0 $X1 $Prec1 $X $PrecOp) - (, ! - (%parse_tokens_op - (is-symbol ;) $Prec0 $X1 $Prec1 $X $PrecOp))) True) -; - - (= - (--> - (%parse_tokens_op - (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) - (, - { (current_op $PrecOp xf $Op) } - (, - { (=< $PrecOp $Prec0) } - (, - { (< $Prec1 $PrecOp) } - (, - { (functor $X $Op 1) } - { (arg 1 $X $X1) }))))) True) -; - - (= - (--> - (%parse_tokens_op - (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) - (, - { (current_op $PrecOp yf $Op) } - (, - { (=< $PrecOp $Prec0) } - (, - { (=< $Prec1 $PrecOp) } - (, - { (functor $X $Op 1) } - { (arg 1 $X $X1) }))))) True) -; - - (= - (--> - (%parse_tokens_op - (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) - (, - { (current_op $PrecOp xfx $Op) } - (, - { (=< $PrecOp $Prec0) } - (, - { (< $Prec1 $PrecOp) } - (, - { (is $Prec2 - (- $PrecOp 1)) } - (, - (%parse_tokens $X2 $Prec2) - (, ! - (, - { (functor $X $Op 2) } - (, - { (arg 1 $X $X1) } - { (arg 2 $X $X2) }))))))))) True) -; - - (= - (--> - (%parse_tokens_op - (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) - (, - { (current_op $PrecOp xfy $Op) } - (, - { (=< $PrecOp $Prec0) } - (, - { (< $Prec1 $PrecOp) } - (, - { (is $Prec2 $PrecOp) } - (, - (%parse_tokens $X2 $Prec2) - (, ! - (, - { (functor $X $Op 2) } - (, - { (arg 1 $X $X1) } - { (arg 2 $X $X2) }))))))))) True) -; - - (= - (--> - (%parse_tokens_op - (is-symbol $Op) $Prec0 $X1 $Prec1 $X $PrecOp) - (, - { (current_op $PrecOp yfx $Op) } - (, - { (=< $PrecOp $Prec0) } - (, - { (=< $Prec1 $PrecOp) } - (, - { (is $Prec2 - (- $PrecOp 1)) } - (, - (%parse_tokens $X2 $Prec2) - (, ! - (, - { (functor $X $Op 2) } - (, - { (arg 1 $X $X1) } - { (arg 2 $X $X2) }))))))))) True) -; - - - - (= - (%parse_tokens_is_starter end_of_file) True) -; - - (= - (%parse_tokens_is_starter () True) -; - - (= - (%parse_tokens_is_starter [) True) -; - - (= - (%parse_tokens_is_starter {) True) -; - - (= - (%parse_tokens_is_starter - (number $_)) True) -; - - (= - (%parse_tokens_is_starter - (is-symbol $_)) True) -; - - (= - (%parse_tokens_is_starter - (var $_ $_)) True) -; - - (= - (%parse_tokens_is_starter - (string $_)) True) -; - - - - (= - (%parse_tokens_is_terminator )) True) -; - - (= - (%parse_tokens_is_terminator ]) True) -; - - (= - (%parse_tokens_is_terminator }) True) -; - - (= - (%parse_tokens_is_terminator .) True) -; - - - - (= - ($parse-tokens-is-post-in-op ,) - (set-det)) -; - - (= - ($parse-tokens-is-post-in-op |) - (set-det)) -; - - (= - ($parse-tokens-is-post-in-op (atom $Op)) - ( (current-op $_ $Type $Op) - ($parse-tokens-post-in-type $Type) - (set-det))) -; - - - - (= - (%parse_tokens_post_in_type xfx) True) -; - - (= - (%parse_tokens_post_in_type xfy) True) -; - - (= - (%parse_tokens_post_in_type yfx) True) -; - - (= - (%parse_tokens_post_in_type xf) True) -; - - (= - (%parse_tokens_post_in_type yf) True) -; - - - - (= - (--> - (%parse_tokens_expect $Token) - (, $parse_tokens_skip_spaces - (, - ($Token) !))) True) -; - - (= - (--> - (%parse_tokens_expect $Token) - (%parse_tokens_error - ($Token expected))) True) -; - - - (= - (--> $parse_tokens_skip_spaces - (, - (' ') - (, ! $parse_tokens_skip_spaces))) True) -; - - (= - (--> $parse_tokens_skip_spaces ()) True) -; - - - - (= - ($parse-tokens-peep-next $Next $S $S) - (= $S - (Cons $Next $_))) -; - - - - (= - ($parse-tokens-error $Message $S0 $S) - ( (write user-error '{SYNTAX ERROR}') - (nl user-error) - (write user-error ** ) - ($parse-tokens-write-message user-error $Message) - (write user-error **) - (nl user-error) - ($parse-tokens-error1 Nil $S0) - (get-symbols &self - (= - ($tokens $Tokens) $_)) - ($parse-tokens-error1 $Tokens $S0) - (flush-output user-error) - (fail))) -; - - - - (= - ($parse-tokens-error1 Nil $_) - (set-det)) -; - - (= - ($parse-tokens-error1 $Tokens $S0) - ( (== $Tokens $S0) - (set-det) - (nl user-error) - (write user-error '** here **') - (nl user-error) - ($parse-tokens-error1 $Tokens Nil) - (nl user-error))) -; - - (= - ($parse-tokens-error1 - (Cons $Token $Tokens) $S0) - ( ($parse-tokens-error2 $Token) ($parse-tokens-error1 $Tokens $S0))) -; - - - - (= - ($parse-tokens-error2 (number $X)) - ( (set-det) (write $X))) -; - - (= - ($parse-tokens-error2 (atom $X)) - ( (set-det) (writeq $X))) -; - - (= - ($parse-tokens-error2 (var $X $_)) - ( (set-det) (write $X))) -; - - (= - ($parse-tokens-error2 (string $X)) - ( (set-det) - (write user-error ") - ($parse-tokens-write-string user-error $X) - (write user-error "))) -; - - (= - ($parse-tokens-error2 $X) - (write user-error $X)) -; - - - - (= - (%parse_tokens_write_string $_ ()) True) -; - - (= - ($parse-tokens-write-string $S - (Cons $C $Cs)) - ( (= - (:: $C) "\"") - (set-det) - (put-code $S $C) - (put-code $S $C) - ($parse-tokens-write-string $S $Cs))) -; - - (= - ($parse-tokens-write-string $S - (Cons $C $Cs)) - ( (put-code $S $C) ($parse-tokens-write-string $S $Cs))) -; - - - - (= - (%parse_tokens_write_message $_ ()) True) -; - - (= - ($parse-tokens-write-message $S - (Cons $X $Xs)) - ( (write $S $X) - (write $S ' ') - ($parse-tokens-write-message $S $Xs))) -; - - -; -; - -; -; - -; -; - - - !(public (, (/ write 1) (/ write 2))) -; - - !(public (, (/ writeq 1) (/ writeq 2))) -; - - !(public (, (/ write-canonical 1) (/ write-canonical 2))) -; - - !(public (, (/ write-term 2) (/ write-term 3))) -; - - - - (= - (write $Term) - ( (current-output $S) (write-term $S $Term (:: (numbervars True))))) -; - - - (= - (write $S_or_a $Term) - (write-term $S_or_a $Term - (:: (numbervars True)))) -; - - - - (= - (writeq $Term) - ( (current-output $S) (write-term $S $Term (:: (quoted True) (numbervars True))))) -; - - - (= - (writeq $S_or_a $Term) - (write-term $S_or_a $Term - (:: - (quoted True) - (numbervars True)))) -; - - - - (= - (write-canonical $Term) - ( (current-output $S) (write-term $S $Term (:: (quoted True) (ignore-ops True))))) -; - - - (= - (write-canonical $S_or_a $Term) - (write-term $S_or_a $Term - (:: - (quoted True) - (ignore-ops True)))) -; - - - - (= - (write-term $Term $Options) - ( (current-output $S) (write-term $S $Term $Options))) -; - - - (= - (write-term $S_or_a $Term $Options) - ( ($write-term $S_or_a $Term $Options) (fail))) -; - - (= - (write_term $_ $_ $_) True) -; - - - - (= - ($write-term $S_or_a $Term $Options) - ( ($write-term0 $Term 1200 punct $_ $Options $S_or_a) (set-det))) -; - - - - (= - ($write-term0 $Term $Prec $Type0 alpha $_ $S_or_a) - ( (var $Term) - (set-det) - ($write-space-if-needed $Type0 alpha $S_or_a) - ($fast-write $S_or_a $Term))) -; - - (= - ($write-term0 $Term $Prec $Type0 alpha $_ $S_or_a) - ( (java $Term) - (set-det) - ($write-space-if-needed $Type0 alpha $S_or_a) - ($fast-write $S_or_a $Term))) -; - - (= - ($write-term0 $Term $Prec $Type0 alpha $Style $S_or_a) - ( (= $Term $VN) - (integer $VN) - (>= $VN 0) - ($builtin-member - (numbervars True) $Style) - (set-det) - ($write-space-if-needed $Type0 alpha $S_or_a) - ($write-VAR $VN $S_or_a))) -; - - (= - ($write-term0 $Term $Prec $Type0 alpha $_ $S_or_a) - ( (number $Term) - (< $Term 0) - (set-det) - ($write-space-if-needed $Type0 symbol $S_or_a) - ($fast-write $S_or_a $Term))) -; - - (= - ($write-term0 $Term $Prec $Type0 alpha $_ $S_or_a) - ( (number $Term) - (set-det) - ($write-space-if-needed $Type0 alpha $S_or_a) - ($fast-write $S_or_a $Term))) -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - (= - ($write-term0 $Term $Prec $Type0 $Type $Style $S_or_a) - ( (atom $Term) - (set-det) - ($write-atom $Term $Type0 $Type $Style $S_or_a))) -; - - (= - ($write-term0 $Term $Prec $Type0 $Type $Style $S_or_a) - ( (not ($builtin-member (ignore-ops True) $Style)) - ($write-is-operator $Term $Op $Args $OpType) - (set-det) - ($write-term-op $Op $OpType $Args $Prec $Type0 $Type $Style $S_or_a))) -; - - (= - ($write-term0 $Term $Prec $Type0 punct $Style $S_or_a) - ( (= $Term - (Cons $_ $_)) - (not ($builtin-member (ignore-ops True) $Style)) - (set-det) - ($write-space-if-needed $Type0 punct $S_or_a) - (put-char $S_or_a [) - ($write-term-list-args $Term punct $_ $Style $S_or_a) - (put-char $S_or_a ]))) -; - - (= - ($write-term0 $Term $Prec $Type0 $Type $Style $S_or_a) - ( (= $Term - {$Term1 }) - (not ($builtin-member (ignore-ops True) $Style)) - (set-det) - ($write-space-if-needed $Type0 punct $S_or_a) - (put-char $S_or_a {) - ($write-term0 $Term1 1200 punct $_ $Style $S_or_a) - (put-char $S_or_a }))) -; - - (= - ($write-term0 $Term $Prec $Type0 punct $Style $S_or_a) - ( (=.. $Term - (Cons $F $Args)) - ($write-atom $F $Type0 $_ $Style $S_or_a) - (put-char $S_or_a () - ($write-term-args $Args punct $_ $Style $S_or_a) - (put-char $S_or_a )))) -; - - - - (= - ($write-space-if-needed punct $_ $_) - (set-det)) -; - - (= - ($write-space-if-needed $X $X $S_or_a) - ( (set-det) (put-char $S_or_a ' '))) -; - - (= - ($write-space-if-needed other alpha $S_or_a) - ( (set-det) (put-char $S_or_a ' '))) -; - - (= - (%write_space_if_needed $_ $_ $_) True) -; - - - - (= - ($write-VAR $VN $S_or_a) - ( (< $VN 26) - (set-det) - (is $Letter - (+ - (mod $VN 26) "A")) - (put-code $S_or_a $Letter))) -; - - (= - ($write-VAR $VN $S_or_a) - ( (is $Letter - (+ - (mod $VN 26) "A")) - (put-code $S_or_a $Letter) - (is $Rest - (// $VN 26)) - ($fast-write $S_or_a $Rest))) -; - - - - (= - ($write-atom $Atom $Type0 $Type $Style $S_or_a) - ( ($builtin-member - (quoted True) $Style) - (set-det) - ($atom-type $Atom $Type) - ($write-space-if-needed $Type0 $Type $S_or_a) - ($fast-writeq $S_or_a $Atom))) -; - - (= - ($write-atom $Atom $Type0 $Type $_ $S_or_a) - ( ($atom-type $Atom $Type) - ($write-space-if-needed $Type0 $Type $S_or_a) - ($fast-write $S_or_a $Atom))) -; - - - - (= - ($atom-type $X alpha) - ( ($atom-type0 $X 0) (set-det))) -; - - (= - ($atom-type $X symbol) - ( ($atom-type0 $X 1) (set-det))) -; - - (= - ($atom-type $X punct) - ( ($atom-type0 $X 2) (set-det))) -; - - (= - ($atom-type $X other) - ( ($atom-type0 $X 3) (set-det))) -; - - - - (= - ($write-is-operator $Term $Op $Args $OpType) - ( (functor $Term $Op $Arity) - ($write-op-type $Arity $OpType) - (current-op $_ $OpType $Op) - (=.. $Term - (Cons $_ $Args)) - (set-det))) -; - - - - (= - (%write_op_type 1 fx) True) -; - - (= - (%write_op_type 1 fy) True) -; - - (= - (%write_op_type 1 xf) True) -; - - (= - (%write_op_type 1 yf) True) -; - - (= - (%write_op_type 2 xfx) True) -; - - (= - (%write_op_type 2 xfy) True) -; - - (= - (%write_op_type 2 yfx) True) -; - - - - (= - ($write-term-op $Op $OpType $Args $Prec $Type0 punct $Style $S_or_a) - ( (current-op $PrecOp $OpType $Op) - (> $PrecOp $Prec) - (set-det) - ($write-space-if-needed $Type0 punct $S_or_a) - (put-char $S_or_a () - ($write-term-op1 $Op $OpType $Args $PrecOp punct $_ $Style $S_or_a) - (put-char $S_or_a )))) -; - - (= - ($write-term-op $Op $OpType $Args $Prec $Type0 $Type $Style $S_or_a) - ( (current-op $PrecOp $OpType $Op) ($write-term-op1 $Op $OpType $Args $PrecOp $Type0 $Type $Style $S_or_a))) -; - - - - (= - ($write-term-op1 $Op fx - (:: $A1) $PrecOp $Type0 $Type $Style $S_or_a) - ( (set-det) - ($write-atom $Op $Type0 $Type1 $Style $S_or_a) - (is $Prec1 - (- $PrecOp 1)) - ($write-term0 $A1 $Prec1 $Type1 $Type $Style $S_or_a))) -; - - (= - ($write-term-op1 $Op fy - (:: $A1) $PrecOp $Type0 $Type $Style $S_or_a) - ( (set-det) - ($write-atom $Op $Type0 $Type1 $Style $S_or_a) - (is $Prec1 $PrecOp) - ($write-term0 $A1 $Prec1 $Type1 $Type $Style $S_or_a))) -; - - (= - ($write-term-op1 $Op xf - (:: $A1) $PrecOp $Type0 $Type $Style $S_or_a) - ( (set-det) - (is $Prec1 - (- $PrecOp 1)) - ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) - ($write-atom $Op $Type1 $Type $Style $S_or_a))) -; - - (= - ($write-term-op1 $Op yf - (:: $A1) $PrecOp $Type0 $Type $Style $S_or_a) - ( (set-det) - (is $Prec1 $PrecOp) - ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) - ($write-atom $Op $Type1 $Type $Style $S_or_a))) -; - - (= - ($write-term-op1 $Op xfx - (:: $A1 $A2) $PrecOp $Type0 $Type $Style $S_or_a) - ( (set-det) - (is $Prec1 - (- $PrecOp 1)) - (is $Prec2 - (- $PrecOp 1)) - ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) - ($write-term-infix-op $Op $Type1 $Type2 $Style $S_or_a) - ($write-term0 $A2 $Prec2 $Type2 $Type $Style $S_or_a))) -; - - (= - ($write-term-op1 $Op xfy - (:: $A1 $A2) $PrecOp $Type0 $Type $Style $S_or_a) - ( (set-det) - (is $Prec1 - (- $PrecOp 1)) - (is $Prec2 $PrecOp) - ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) - ($write-term-infix-op $Op $Type1 $Type2 $Style $S_or_a) - ($write-term0 $A2 $Prec2 $Type2 $Type $Style $S_or_a))) -; - - (= - ($write-term-op1 $Op yfx - (:: $A1 $A2) $PrecOp $Type0 $Type $Style $S_or_a) - ( (set-det) - (is $Prec1 $PrecOp) - (is $Prec2 - (- $PrecOp 1)) - ($write-term0 $A1 $Prec1 $Type0 $Type1 $Style $S_or_a) - ($write-term-infix-op $Op $Type1 $Type2 $Style $S_or_a) - ($write-term0 $A2 $Prec2 $Type2 $Type $Style $S_or_a))) -; - - - - (= - ($write-term-infix-op , $Type0 punct $_ $S_or_a) - ( (set-det) - ($write-space-if-needed $Type0 punct $S_or_a) - (put-char $S_or_a ,))) -; - - (= - ($write-term-infix-op $Op $Type0 $Type $Style $S_or_a) - ($write-atom $Op $Type0 $Type $Style $S_or_a)) -; - - - - (= - ($write-term-list-args - (Cons $A $As) $Type0 $Type $Style $S_or_a) - ( (nonvar $As) - (= $As - (Cons $_ $_)) - (set-det) - ($write-term0 $A 999 $Type0 $Type1 $Style $S_or_a) - ($write-space-if-needed $Type1 punct $S_or_a) - (put-char $S_or_a ,) - ($write-term-list-args $As punct $Type $Style $S_or_a))) -; - - - (= - ($write-term-list-args - (Cons $A $As) $Type0 $Type $Style $S_or_a) - ( (nonvar $As) - (= $As Nil) - (set-det) - ($write-term0 $A 999 $Type0 $Type $Style $S_or_a))) -; - - - (= - ($write-term-list-args - (Cons $A $As) $Type0 $Type $Style $S_or_a) - ( ($write-term0 $A 999 $Type0 $Type1 $Style $S_or_a) - ($write-space-if-needed $Type1 punct $S_or_a) - (put-char $S_or_a |) - ($write-term0 $As 999 punct $Type $Style $S_or_a))) -; - - - - (= - ($write-term-args Nil $Type $Type $_ $_) - (set-det)) -; - - (= - ($write-term-args - (:: $A) $Type0 $Type $Style $S_or_a) - ( (set-det) ($write-term0 $A 999 $Type0 $Type $Style $S_or_a))) -; - - (= - ($write-term-args - (Cons $A $As) $Type0 $Type $Style $S_or_a) - ( (set-det) - ($write-term0 $A 999 $Type0 $Type1 $Style $S_or_a) - ($write-space-if-needed $Type1 punct $S_or_a) - (put-char $S_or_a ,) - ($write-term-args $As punct $Type $Style $S_or_a))) -; - - -; -; - -; -; - -; -; - - - !(public (/ op 3)) -; - - !(public (/ current-op 3)) -; - - !(dynamic (/ %current-operator 3)) -; - - - - (= - (op $Priority $Op_specifier $Operator) - ( (integer $Priority) - (=< 0 $Priority) - (=< $Priority 1200) - (set-det) - ($op1 $Priority $Op_specifier $Operator))) -; - - (= - (op $Priority $Op_specifier $Operator) - (illarg - (domain integer - (- 0 1200)) - (op $Priority $Op_specifier $Operator) 1)) -; - - - - (= - ($op1 $Priority $Op_specifier $Operator) - ( (nonvar $Op_specifier) - ($op-specifier $Op_specifier $_) - (set-det) - ($op2 $Priority $Op_specifier $Operator))) -; - - (= - ($op1 $Priority $Op_specifier $Operator) - ( (findall $X - ($op-specifier $X $_) $Domain) (illarg (domain term $Domain) (op $Priority $Op_specifier $Operator) 2))) -; - - - - (= - ($op2 $Priority $Op_specifier $Operator) - ( (atom $Operator) - (set-det) - ($add-operators - (:: $Operator) $Priority $Op_specifier))) -; - - (= - ($op2 $Priority $Op_specifier $Operator) - ( ($op-atom-list $Operator $Atoms) - (set-det) - ($add-operators $Atoms $Priority $Op_specifier))) -; - - (= - ($op2 $Priority $Op_specifier $Operator) - (illarg - (type (list is-symbol)) - (op $Priority $Op_specifier $Operator) 3)) -; - - - - (= - ($add-operators Nil $_ $_) - (set-det)) -; - - (= - ($add-operators - (Cons $A $As) $Priority $Op_specifier) - ( ($add-op $A $Priority $Op_specifier) ($add-operators $As $Priority $Op_specifier))) -; - - - - (= - ($add-op , $Priority $Op_specifier) - ( (set-det) (illarg (permission modify operator , $_) (op $Priority $Op_specifier ,) 3))) -; - - (= - ($add-op $A $_ $Op_specifier) - ( (get-symbols &self - (= - (%current_operator $_ $Op_specifier0 $A) $_)) - ($op-specifier $Op_specifier $Class) - ($op-specifier $Op_specifier0 $Class0) - (= $Class $Class0) - (remove-symbol &self - (%current_operator $_ $Op_specifier0 $A)) - (fail))) -; - - (= - ($add-op $_ 0 $_) - (set-det)) -; - - (= - ($add-op $A $Priority $Op_specifier) - (add-symbol &self - (%current_operator $Priority $Op_specifier $A))) -; - - - - (= - (%op_specifier fx prefix) True) -; - - (= - (%op_specifier fy prefix) True) -; - - (= - (%op_specifier xfx infix) True) -; - - (= - (%op_specifier xfy infix) True) -; - - (= - (%op_specifier yfx infix) True) -; - - (= - (%op_specifier xf postfix) True) -; - - (= - (%op_specifier yf postfix) True) -; - - - - (= - ($op-atom-list $X $_) - ( (var $X) - (set-det) - (fail))) -; - - (= - ($op-atom-list Nil Nil) - (set-det)) -; - - (= - ($op-atom-list - (Cons $X $Xs) - (Cons $X $As)) - ( (atom $X) - (set-det) - ($op-atom-list $Xs $As))) -; - - - - (= - (current-op $Priority $Op_specifier $Operator) - (get-symbols &self - (= - (%current_operator $Priority $Op_specifier $Operator) $_))) -; - - - - (= - (%current_operator 1200 xfx :-) True) -; - - (= - (%current_operator 1200 xfx -->) True) -; - - (= - (%current_operator 1200 fx :-) True) -; - - (= - (%current_operator 1200 fx ?-) True) -; - - (= - (%current_operator 1150 fx package) True) -; - - (= - (%current_operator 1150 fx import) True) -; - - (= - (%current_operator 1150 fx include) True) -; - - (= - (%current_operator 1150 fx include_resource) True) -; - - (= - (%current_operator 1150 fx constant) True) -; - - (= - (%current_operator 1150 fx public) True) -; - - (= - (%current_operator 1150 fx dynamic) True) -; - - (= - (%current_operator 1150 fx meta_predicate) True) -; - - (= - (%current_operator 1150 fx mode) True) -; - - (= - (%current_operator 1150 fx multifile) True) -; - - (= - (%current_operator 1150 fx block) True) -; - - (= - (%current_operator 1150 fx ifdef) True) -; - - (= - (%current_operator 1150 fx ifndef) True) -; - - (= - (%current_operator 1150 fx domain) True) -; - - (= - (%current_operator 1150 fx database) True) -; - - (= - (%current_operator 1100 xfy ;) True) -; - - (= - (%current_operator 1050 xfy ->) True) -; - - (= - (%current_operator 1000 xfy ,) True) -; - - (= - (%current_operator 900 fy \+) True) -; - - (= - (%current_operator 700 xfx =) True) -; - - (= - (%current_operator 700 xfx \=) True) -; - - (= - (%current_operator 700 xfx ==) True) -; - - (= - (%current_operator 700 xfx \==) True) -; - - (= - (%current_operator 700 xfx @<) True) -; - - (= - (%current_operator 700 xfx @>) True) -; - - (= - (%current_operator 700 xfx @=<) True) -; - - (= - (%current_operator 700 xfx @>=) True) -; - - (= - (%current_operator 700 xfx =..) True) -; - - (= - (%current_operator 700 xfx is) True) -; - - (= - (%current_operator 700 xfx =:=) True) -; - - (= - (%current_operator 700 xfx =\=) True) -; - - (= - (%current_operator 700 xfx <) True) -; - - (= - (%current_operator 700 xfx >) True) -; - - (= - (%current_operator 700 xfx =<) True) -; - - (= - (%current_operator 700 xfx >=) True) -; - - (= - (%current_operator 550 xfy :) True) -; - - (= - (%current_operator 500 yfx +) True) -; - - (= - (%current_operator 500 yfx -) True) -; - - (= - (%current_operator 500 yfx #) True) -; - - (= - (%current_operator 500 yfx /\) True) -; - - (= - (%current_operator 500 yfx \/) True) -; - - (= - (%current_operator 500 fx +) True) -; - - (= - (%current_operator 400 yfx *) True) -; - - (= - (%current_operator 400 yfx /) True) -; - - (= - (%current_operator 400 yfx //) True) -; - - (= - (%current_operator 400 yfx mod) True) -; - - (= - (%current_operator 400 yfx rem) True) -; - - (= - (%current_operator 400 yfx <<) True) -; - - (= - (%current_operator 400 yfx >>) True) -; - - (= - (%current_operator 300 xfx ~) True) -; - - (= - (%current_operator 200 xfx **) True) -; - - (= - (%current_operator 200 xfy ^) True) -; - - (= - (%current_operator 200 fy \) True) -; - - (= - (%current_operator 200 fy -) True) -; - - -; -; - -; -; - -; -; - - - !(public (/ \+ 1)) -; - - !(public (/ once 1)) -; - - !(public (/ repeat 0)) -; - - - - (= - (not $G) - ( (call $G) - (set-det) - (fail))) -; - - (= - (\+ $_) True) -; - - - - (= repeat True) -; - - (= - (repeat) - (repeat)) -; - - - - (= - (once $G) - ( (call $G) (set-det))) -; - - -; -; - -; -; - -; -; - -; -; - -; -; - - - !(public (/ sub-symbol 5)) -; - -; -; - -; -; - -; -; - - !(public (/ name 2)) -; - -; -; - -; -; - - !(public (/ regex-matches 3)) -; - - !(public (/ regex-matches 2)) -; - - - - (= - (sub-atom $Atom $Before $Length $After $Sub_atom) - ( (atom-concat $AtomL $X $Atom) - (atom-length $AtomL $Before) - (atom-concat $Sub_atom $AtomR $X) - (atom-length $Sub_atom $Length) - (atom-length $AtomR $After))) -; - - - - (= - (name $Constant $Chars) - ( (nonvar $Constant) (det-if-then-else (number $Constant) (number-codes $Constant $Chars) (det-if-then-else (atomic $Constant) (atom-codes $Constant $Chars) (illarg (type symbolic) (name $Constant $Chars) 1))))) -; - - (= - (name $Constant $Chars) - ( (var $Constant) (det-if-then-else (number-codes $Constant0 $Chars) (= $Constant $Constant0) (det-if-then-else (atom-codes $Constant0 $Chars) (= $Constant $Constant0) (illarg (type (list char)) (name $Constant $Chars) 2))))) -; - - - - (= - (regex-matches $_ Nil $_) - ( (set-det) (fail))) -; - - (= - (regex-matches $Pattern $List $Result) - ( (= $List - (Cons $_ $_)) - (set-det) - (regex-list $Pattern $List $Result))) -; - - (= - (regex-matches $Pattern $String $Result) - ( (atom $String) - (regex-compile $Pattern $Matcher) - (regex-match $Matcher $String $Result))) -; - - - (= - (regex-matches $Pattern $String) - (once (regex-matches $Pattern $String $_))) -; - - - - (= - (regex-list $Pattern - (Cons $H $_) $Result) - (regex-matches $Pattern $H $Result)) -; - - (= - (regex-list $Pattern - (Cons $_ $Ls) $Result) - (regex-list $Pattern $Ls $Result)) -; - - -; -; - -; -; - -; -; - - - !(public (/ set-prolog-flag 2)) -; - - !(public (/ current-prolog-flag 2)) -; - - - - (= - (set-prolog-flag $Flag $Value) - ( (var $Flag) - (set-det) - (illarg var - (set-prolog-flag $Flag $Value) 1))) -; - - (= - (set-prolog-flag $Flag $Value) - ( (var $Value) - (set-det) - (illarg var - (set-prolog-flag $Flag $Value) 2))) -; - - (= - (set-prolog-flag $Flag $Value) - ( (atom $Flag) - (set-det) - ($set-prolog-flag0 $Flag $Value))) -; - - (= - (set-prolog-flag $Flag $Value) - (illarg - (type is-symbol) - (set-prolog-flag $Flag $Value) 1)) -; - - - - (= - ($set-prolog-flag0 $Flag $Value) - ( ($prolog-impl-flag $Flag $Mode - (changeable $YN)) - (set-det) - ($set-prolog-flag0 $YN $Flag $Value $Mode))) -; - - (= - ($set-prolog-flag0 $Flag $Value) - (illarg - (domain is-symbol prolog-flag) - (set-prolog-flag $Flag $Value) 1)) -; - - - (= - ($set-prolog-flag0 no $Flag $Value $_) - ( (set-det) (illarg (permission modify flag $Flag $_) (set-prolog-flag $Flag $Value) $_))) -; - - (= - ($set-prolog-flag0 $_ $Flag $Value $Mode) - ( ($builtin-member $Value $Mode) - (set-det) - ($set-prolog-impl-flag $Flag $Value))) -; - - (= - ($set-prolog-flag0 $_ $Flag $Value $_) - (illarg - (domain is-symbol flag-value) - (set-prolog-flag $Flag $Value) 2)) -; - - - - (= - (current-prolog-flag $Flag $Term) - ( (var $Flag) - (set-det) - ($prolog-impl-flag $Flag $_ $_) - ($get-prolog-impl-flag $Flag $Term))) -; - - (= - (current-prolog-flag $Flag $Term) - ( (atom $Flag) - (set-det) - (det-if-then-else - ($prolog-impl-flag $Flag $_ $_) - ($get-prolog-impl-flag $Flag $Term) - (illarg - (domain is-symbol prolog-flag) - (current-prolog-flag $Flag $Term) 1)))) -; - - (= - (current-prolog-flag $Flag $Term) - (illarg - (type is-symbol) - (current-prolog-flag $Flag $Term) 1)) -; - - -; -; - - - (= - (%prolog_impl_flag max_integer $_ - (changeable no)) True) -; - - (= - (%prolog_impl_flag min_integer $_ - (changeable no)) True) -; - -; -; - -; -; - - (= - (%prolog_impl_flag debug - (on off) - (changeable yes)) True) -; - - (= - (%prolog_impl_flag max_arity $_ - (changeable no)) True) -; - - (= - (%prolog_impl_flag unknown - (error fail warning) - (changeable yes)) True) -; - - (= - (%prolog_impl_flag double_quotes - (chars codes atom) - (changeable no)) True) -; - - (= - (%prolog_impl_flag print_stack_trace - (on off) - (changeable yes)) True) -; - - - - !(public (/ halt 0)) -; - - !(public (/ abort 0)) -; - - - - (= - (halt) - (halt 0)) -; - - - (= - (abort) - (raise-exception 'Execution aborted')) -; - - -; -; - -; -; - -; -; - - - !(public (, (/ C 3) (/ expand-term 2))) -; - - - - (= - (C - (Cons $X $S) $X $S) True) -; - - - - (= - (expand-term $Dcg $Cl) - ( (var $Dcg) - (set-det) - (= $Dcg $Cl))) -; - - (= - (expand-term $Dcg $Cl) - ( ($dcg-expansion $Dcg $Cl0) - (set-det) - (= $Cl0 $Cl))) -; - - (= - (expand_term $Dcg $Dcg) True) -; - - - - (= - ($dcg-expansion $Dcg $Cl) - ( (var $Dcg) - (set-det) - (= $Dcg $Cl))) -; - - (= - ($dcg-expansion - (--> $Head $B) - (= $H1 - ($G1 $G2))) - ( (nonvar $Head) - (= $Head - (, $H $List)) - (= $List - (Cons $_ $_)) - (set-det) - ($dcg-translation-atom $H $H1 $S0 $S1) - ($dcg-translation $B $G1 $S0 $S) - ($dcg-translation $List $G2 $S1 $S))) -; - - (= - ($dcg-expansion - (--> $H $B) - (= $H1 $B1)) - ( ($dcg-translation-atom $H $H1 $S0 $S) ($dcg-translation $B $B1 $S0 $S))) -; - - - - (= - ($dcg-translation-atom $X - (phrase $X $S0 $S) $S0 $S) - ( (var $X) (set-det))) -; - - (= - ($dcg-translation-atom - (with_self $M $X) - (with_self $M $X1) $S0 $S) - ( (set-det) ($dcg-translation-atom $X $X1 $S0 $S))) -; - - (= - ($dcg-translation-atom $X $X1 $S0 $S) - ( (=.. $X - (Cons $F $As)) - ($builtin-append $As - (:: $S0 $S) $As1) - (=.. $X1 - (Cons $F $As1)))) -; - - - - (= - ($dcg-translation $X $Y $S0 $S) - ( ($dcg-trans $X $Y0 $T $S0 $S) ($dcg-trans0 $Y0 $Y $T $S0 $S))) -; - - - - (= - ($dcg-trans0 $Y $Y $T $S0 $T) - ( (\== $T $S0) (set-det))) -; - - (= - ($dcg-trans0 $Y0 $Y $T $_ $S) - ($dcg-concat $Y0 - (= $S $T) $Y)) -; - - - - (= - ($dcg-concat $X $Y $Z) - ( (== $X True) - (set-det) - (= $Z $Y))) -; - - (= - ($dcg-concat $X $Y $Z) - ( (== $Y True) - (set-det) - (= $Z $X))) -; - - (= - (%dcg_concat $X $Y - (, $X $Y)) True) -; - - - - (= - ($dcg-trans $X $X1 $S $S0 $S) - ( (var $X) - (set-det) - ($dcg-translation-atom $X $X1 $S0 $S))) -; - - (= - ($dcg-trans - (with_self $M $X) - (with_self $M $Y) $T $S0 $S) - ( (set-det) ($dcg-trans $X $Y $T $S0 $S))) -; - - (= - ($dcg-trans Nil True $S0 $S0 $_) - (set-det)) -; - - (= - ($dcg-trans - (Cons $X $Y) $Z $T $S0 $S) - ( (set-det) - ($dcg-trans $Y $Y1 $T $S1 $S) - ($dcg-concat - (C $S0 $X $S1) $Y1 $Z))) -; - - (= - ($dcg-trans - (not $X) - (det-if-then-else $X1 fail - (= $S $S0)) $S $S0 $S) - ( (set-det) ($dcg-trans $X $X1 $S1 $S0 $S1))) -; - - (= - ($dcg-trans - (, $X $Y) $Z $T $S0 $S) - ( (set-det) - ($dcg-trans $X $X1 $S1 $S0 $S1) - ($dcg-trans $Y $Y1 $T $S1 $S) - ($dcg-concat $X1 $Y1 $Z))) -; - - (= - ($dcg-trans - (det-if-then $X $Y) - (det-if-then $X1 $Y1) $T $S0 $S) - ( (set-det) - ($dcg-trans $X $X1 $S1 $S0 $S1) - ($dcg-trans $Y $Y1 $T $S1 $S))) -; - - (= - ($dcg-trans - (or $X $Y) - (or $X1 $Y1) $S $S0 $S) - ( (set-det) - ($dcg-translation $X $X1 $S0 $S) - ($dcg-translation $Y $Y1 $S0 $S))) -; - - (= - ($dcg-trans - (set-det) - (set-det) $S0 $S0 $_) - (set-det)) -; - - (= - ($dcg-trans - {$G } - (call $G) $S0 $S0 $_) - ( (var $G) (set-det))) -; - - (= - ($dcg-trans - {$G } $G $S0 $S0 $_) - (set-det)) -; - - (= - ($dcg-trans $X $X1 $S $S0 $S) - ($dcg-translation-atom $X $X1 $S0 $S)) -; - - -; -; - -; -; - -; -; - - - !(public (/ new-hash 1)) -; - - !(public (/ hash-map 2)) -; - - !(public (/ hash-exists 1)) -; - - - - (= - (new-hash $Hash) - (new-hash $Hash Nil)) -; - - - - (= - (hash-map $H_or_a $List) - ( (hash-keys $H_or_a $Ks0) - (sort $Ks0 $Ks) - (hash-map $Ks $List $H_or_a))) -; - - - (= - (hash-map Nil Nil $_) - (set-det)) -; - - (= - (hash-map - (Cons $K $Ks) - (Cons - (, $K $V) $Ls) $H_or_a) - ( (hash-get $H_or_a $K $V) (hash-map $Ks $Ls $H_or_a))) -; - - - - (= - (hash-exists $Alias) - ( (atom $Alias) - ($get-hash-manager $HM) - (hash-contains-key $HM $Alias))) -; - - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - -; -; - - - !(public (/ java-constructor 2)) -; - - !(public (/ java-declared-constructor 2)) -; - - !(public (/ java-method 3)) -; - - !(public (/ java-declared-method 3)) -; - - !(public (/ java-get-field 3)) -; - - !(public (/ java-get-declared-field 3)) -; - - !(public (/ java-set-field 3)) -; - - !(public (/ java-set-declared-field 3)) -; - - !(public (/ synchronized 2)) -; - - - - (= - (java-constructor $Constr $Instance) - ( (=.. $Constr - (Cons $F $As)) - (builtin-java-convert-args $As $As1) - (=.. $Constr1 - (Cons $F $As1)) - (java-constructor0 $Constr1 $Instance1) - (= $Instance $Instance1))) -; - - - - (= - (java-declared-constructor $Constr $Instance) - ( (=.. $Constr - (Cons $F $As)) - (builtin-java-convert-args $As $As1) - (=.. $Constr1 - (Cons $F $As1)) - (java-declared-constructor0 $Constr1 $Instance1) - (= $Instance $Instance1))) -; - - - - (= - (java-method $Class_or_Instance $Method $Value) - ( (=.. $Method - (Cons $F $As)) - (builtin-java-convert-args $As $As1) - (=.. $Method1 - (Cons $F $As1)) - (java-method0 $Class_or_Instance $Method1 $Value1) - (java-conversion $Value2 $Value1) - (= $Value $Value2))) -; - - - - (= - (java-declared-method $Class_or_Instance $Method $Value) - ( (=.. $Method - (Cons $F $As)) - (builtin-java-convert-args $As $As1) - (=.. $Method1 - (Cons $F $As1)) - (java-declared-method0 $Class_or_Instance $Method1 $Value1) - (java-conversion $Value2 $Value1) - (= $Value $Value2))) -; - - - - (= - (java-get-field $Class_or_Instance $Field $Value) - ( (java-get-field0 $Class_or_Instance $Field $Value1) - (java-conversion $Value2 $Value1) - (= $Value $Value2))) -; - - - - (= - (java-get-declared-field $Class_or_Instance $Field $Value) - ( (java-get-declared-field0 $Class_or_Instance $Field $Value1) - (java-conversion $Value2 $Value1) - (= $Value $Value2))) -; - - - - (= - (java-set-field $Class_or_Instance $Field $Value) - ( (java-conversion $Value $Value1) (java-set-field0 $Class_or_Instance $Field $Value1))) -; - - - - (= - (java-set-declared-field $Class_or_Instance $Field $Value) - ( (java-conversion $Value $Value1) (java-set-declared-field0 $Class_or_Instance $Field $Value1))) -; - - - - (= - (builtin-java-convert-args Nil Nil) - (set-det)) -; - - (= - (builtin-java-convert-args - (Cons $X $Xs) - (Cons $Y $Ys)) - ( (java-conversion $X $Y) (builtin-java-convert-args $Xs $Ys))) -; - - - - (= - (synchronized $Object $Goal) - ( ($begin-sync $Object $Ref) - (call $Goal) - ($end-sync $Ref))) -; - - -; -; - -; -; - -; -; - - - !(op 1170 xfx :-) -; - - !(op 1170 xfx -->) -; - - !(op 1170 fx :-) -; - - !(op 1170 fx ?-) -; - - - !(op 1150 fx package) -; - - !(op 1150 fx import) -; - - !(op 1150 fx public) -; - - !(op 1150 fx dynamic) -; - - !(op 1150 fx meta-predicate) -; - - !(op 1150 fx mode) -; - - !(op 1150 fx multifile) -; - - !(op 1150 fx block) -; - - - !(public (/ cafeteria 0)) -; - - !(public (/ consult 1)) -; - - !(public (/ consult-stream 1)) -; - - !(public (, (/ trace 0) (/ notrace 0))) -; - - !(public (, (/ debug 0) (/ nodebug 0))) -; - - !(public (/ leash 1)) -; - - !(public (, (/ spy 1) (/ nospy 1) (/ nospyall 0))) -; - - !(public (/ listing 0)) -; - - !(public (/ listing 1)) -; - - - !(dynamic (/ %current-leash 1)) -; - - !(dynamic (/ %current-spypoint 3)) -; - - !(dynamic (/ %leap-flag 1)) -; - - !(dynamic (/ %consulted-file 1)) -; - - !(dynamic (/ %consulted-import 2)) -; - - !(dynamic (/ %consulted-package 1)) -; - - !(dynamic (/ %consulted-predicate 3)) -; - - -; -; - - - (= - (cafeteria) - ( (%cafeteria-init) - (repeat) - (%toplvel-loop) - (on-exception $Msg - ($cafeteria $Goal) - (print-message error $Msg)) - (== $Goal end-of-file) - (set-det) - (nl) - ($fast-write bye) - (nl))) -; - - - - (= - (%cafeteria-init) - ( (remove-all-symbols &self - (%leap_flag $_)) - (remove-all-symbols &self - (%current_leash $_)) - (remove-all-symbols &self - (%current_spypoint $_ $_ $_)) - (remove-all-symbols &self - (%consulted_file $_)) - (remove-all-symbols &self - (%consulted_package $_)) - (remove-all-symbols &self - (%consulted_predicate $_ $_ $_)) - (add-symbol &self - (%leap_flag no)) - (add-symbol &self - (%current_leash call)) - (add-symbol &self - (%current_leash exit)) - (add-symbol &self - (%current_leash redo)) - (add-symbol &self - (%current_leash fail)) - (set-det))) -; - - - - (= - (%toplvel-loop) - ( (current-prolog-flag debug $Mode) - (det-if-then-else - (== $Mode off) True - (print-message info - (:: debug))) - ($fast-write | ?- ) - (flush-output))) -; - - - - (= - ($cafeteria $Goal) - ( (read-with-variables $Goal $Vars) ($process-order $Goal $Vars))) -; - - - - (= - ($process-order $G $_) - ( (var $G) - (set-det) - (illarg var - (?- $G) 1))) -; - - (= - ($process-order end-of-file $_) - (set-det)) -; - - (= - ($process-order - (Cons $File $Files) $_) - ( (set-det) (consult (Cons $File $Files)))) -; - - (= - ($process-order $G $Vars) - ( (current-prolog-flag debug $Mode) - (det-if-then-else - (== $Mode off) - (call $G) - ($trace-goal $G)) - (nl) - ($rm-redundant-vars $Vars $Vars1) - ($give-answers-with-prompt $Vars1) - (set-det) - ($fast-write yes) - (nl))) -; - - (= - ($process-order $_ $_) - ( (nl) - ($fast-write no) - (nl))) -; - - - - (= - ($rm-redundant-vars Nil Nil) - (set-det)) -; - - (= - ($rm-redundant-vars - (Cons - (= - $_) $Xs) $Vs) - ( (set-det) ($rm-redundant-vars $Xs $Vs))) -; - - (= - ($rm-redundant-vars - (Cons $X $Xs) - (Cons $X $Vs)) - ($rm-redundant-vars $Xs $Vs)) -; - - - - (= - ($give-answers-with-prompt Nil) - (set-det)) -; - - (= - ($give-answers-with-prompt $Vs) - ( ($give-an-answer $Vs) - ($fast-write ? ) - (flush-output) - (read-line $Str) - (\== $Str ";") - (nl))) -; - - - - (= - ($give-an-answer Nil) - ( (set-det) ($fast-write True))) -; - - (= - ($give-an-answer (:: $X)) - ( (set-det) ('$print-an answer' $X))) -; - - (= - ($give-an-answer (Cons $X $Xs)) - ( ('$print-an answer' $X) - ($fast-write ,) - (nl) - ($give-an-answer $Xs))) -; - - - - (= - ('$print-an answer' (= $N $V)) - ( (write $N) - ($fast-write = ) - (writeq $V))) -; - - -; -; - - - (= - (consult $Files) - ( (var $Files) - (set-det) - (illarg var - (consult $Files) 1))) -; - - (= - (consult Nil) - (set-det)) -; - - (= - (consult (Cons $File $Files)) - ( (set-det) - (consult $File) - (consult $Files))) -; - - (= - (consult $File) - ( (atom $File) - (set-det) - ($consult $File))) -; - - - - (= - ($consult $F) - ( ($prolog-file-name $F $PF) - (open $PF read $In) - (stream-property $In - (file-name $File)) - (print-message info - (:: consulting $File ...)) - (statistics runtime $_) - (consult-stream $File $In) - (statistics runtime - (:: $_ $T)) - (print-message info - (:: $File consulted $T msec)) - (close $In))) -; - - - - (= - (consult-stream $File $In) - ( ($consult-init $File) - (repeat) - (read $In $Cl) - ($consult-clause $Cl) - (== $Cl end-of-file) - (set-det))) -; - - - - (= - ($prolog-file-name $File $File) - ( (sub-atom $File $_ $_ $After .) - (> $After 0) - (set-det))) -; - - (= - ($prolog-file-name $File0 $File) - (atom-concat $File0 .pl $File)) -; - - - - (= - ($consult-init $File) - ( (remove-all-symbols &self - (%consulted_file $_)) - (remove-all-symbols &self - (%consulted_package $_)) - (remove-all-symbols &self - (%consulted_import $File $_)) - (remove-symbol &self - (%consulted_predicate $P $PI $File)) - (abolish (with_self $P $PI)) - (fail))) -; - - (= - ($consult-init $File) - ( (add-symbol &self - (%consulted_file $File)) (add-symbol &self (%consulted_package user)))) -; - - - - (= - ($consult-clause end-of-file) - (set-det)) -; - - (= - ($consult-clause !(module $P $_)) - ( (set-det) ($assert-consulted-package $P))) -; - - (= - ($consult-clause !(package $P)) - ( (set-det) ($assert-consulted-package $P))) -; - - (= - ($consult-clause !(import $P)) - ( (set-det) ($assert-consulted-import $P))) -; - - (= - ($consult-clause !(dynamic $_)) - (set-det)) -; - - (= - ($consult-clause !(public $_)) - (set-det)) -; - - (= - ($consult-clause !(meta-predicate $_)) - (set-det)) -; - - (= - ($consult-clause !(mode $_)) - (set-det)) -; - - (= - ($consult-clause !(multifile $_)) - (set-det)) -; - - (= - ($consult-clause !(block $_)) - (set-det)) -; - - (= - ($consult-clause !$G) - ( (set-det) - (get-symbols &self - (= - (%consulted_package $P) $_)) - (once (with_self $P $G)))) -; - - (= - ($consult-clause $Clause0) - ( ($consult-preprocess $Clause0 $Clause) ($consult-cls $Clause))) -; - - - - (= - ($assert-consulted-package $P) - ( (get-symbols &self - (= - (%consulted_package $P) $_)) (set-det))) -; - - (= - ($assert-consulted-package $P) - ( (remove-all-symbols &self - (%consulted_package $_)) (add-symbol &self (%consulted_package $P)))) -; - - - - (= - ($assert-consulted-import $P) - ( (get-symbols &self - (= - (%consulted_file $File) $_)) (add-symbol &self (%consulted_import $File $P)))) -; - - - - (= - ($consult-preprocess $Clause0 $Clause) - (expand-term $Clause0 $Clause)) -; - - - - (= - ($consult-cls (= $H $G)) - ( (set-det) ($assert-consulted-clause (= $H $G)))) -; - - (= - ($consult-cls $H) - ($assert-consulted-clause (= $H True))) -; - - - - (= - ($assert-consulted-clause $Clause) - ( (= $Clause - (= $H $_)) - (functor $H $F $A) - (get-symbols &self - (= - (%consulted_file $File) $_)) - (get-symbols &self - (= - (%consulted_package $P) $_)) - (add-symbol &self - (: $P $Clause)) - (add-symbol &self - (%consulted_predicate $P - (/ $F $A) $File)) - (set-det))) -; - - -; -; - - - (= - (trace) - ( (current-prolog-flag debug on) (set-det))) -; - - (= - (trace) - ( (set-prolog-flag debug on) - (%trace-init) - ($fast-write '{Small debugger is switch on}') - (nl) - (set-det))) -; - - - - (= - (%trace-init) - ( (remove-all-symbols &self - (%leap_flag $_)) - (remove-all-symbols &self - (%current_leash $_)) - (remove-all-symbols &self - (%current_spypoint $_ $_ $_)) - (add-symbol &self - (%leap_flag no)) - (add-symbol &self - (%current_leash call)) - (add-symbol &self - (%current_leash exit)) - (add-symbol &self - (%current_leash redo)) - (add-symbol &self - (%current_leash fail)) - (set-det))) -; - - - - (= - (notrace) - ( (current-prolog-flag debug off) (set-det))) -; - - (= - (notrace) - ( (set-prolog-flag debug off) - ($fast-write '{Small debugger is switch off}') - (nl) - (set-det))) -; - - - - (= - (debug) - (trace)) -; - - - (= - (nodebug) - (notrace)) -; - - -; -; - - - (= - (spy $T) - ( ($term-to-predicateindicator $T $PI - (spy $T)) - (trace) - ($assert-spypoint $PI) - ($set-debug-flag leap yes) - (set-det))) -; - - - - (= - ($assert-spypoint (with_self $P (/ $F $A))) - ( (get-symbols &self - (= - (%current_spypoint $P $F $A) $_)) - (print-message info - (:: spypoint - (with_self $P - (/ $F $A)) is already added)) - (set-det))) -; - - (= - ($assert-spypoint (with_self $P (/ $F $A))) - ( (get-symbols &self - (= - (%consulted_predicate $P - (/ $F $A) $_) $_)) - (add-symbol &self - (%current_spypoint $P $F $A)) - (print-message info - (:: spypoint - (with_self $P - (/ $F $A)) is added)) - (set-det))) -; - - (= - ($assert-spypoint (with_self $P (/ $F $A))) - (print-message warning - (:: no matching predicate for spy - (with_self $P - (/ $F $A))))) -; - - - - (= - (nospy $T) - ( ($term-to-predicateindicator $T $PI - (nospy $T)) - ($retract-spypoint $PI) - ($set-debug-flag leap no) - (set-det))) -; - - - - (= - ($retract-spypoint (with_self $P (/ $F $A))) - ( (remove-symbol &self - (%current_spypoint $P $F $A)) - (print-message info - (:: spypoint - (with_self $P - (/ $F $A)) is removed)) - (set-det))) -; - - (= - (%retract_spypoint $_) True) -; - - - - (= - (nospyall) - ( (remove-all-symbols &self - (%current_spypoint $_ $_ $_)) ($set-debug-flag leap no))) -; - - -; -; - - - (= - (leash $L) - ( (nonvar $L) - ($leash $L) - (set-det))) -; - - (= - (leash $L) - (illarg - (type leash-specifier) - (leash $L) 1)) -; - - - - (= - ($leash Nil) - ( (set-det) - (remove-all-symbols &self - (%current_leash $_)) - (print-message info - (:: no leashing)))) -; - - (= - ($leash $Ms) - ( (remove-all-symbols &self - (%current_leash $_)) - ($assert-leash $Ms) - (print-message info - (:: leashing stopping on $Ms)))) -; - - - - (= - ($assert-leash Nil) - (set-det)) -; - - (= - ($assert-leash (Cons $X $Xs)) - ( ($leash-specifier $X) - (add-symbol &self - (%current_leash $X)) - ($assert-leash $Xs))) -; - - - - (= - (%leash_specifier call) True) -; - - (= - (%leash_specifier exit) True) -; - - (= - (%leash_specifier redo) True) -; - - (= - (%leash_specifier fail) True) -; - -; -; - - -; -; - - - (= - ($trace-goal $Term) - ( ($set-debug-flag leap no) - ($get-current-B $Cut) - ($meta-call $Term user $Cut 0 trace))) -; - - - (= - ($trace-goal $X $P $FA $Depth) - ( (print-procedure-box call $X $P $FA $Depth) - ($call-internal $X $P $FA $Depth trace) - (print-procedure-box exit $X $P $FA $Depth) - (redo-procedure-box $X $P $FA $Depth))) -; - - (= - ($trace-goal $X $P $FA $Depth) - ( (print-procedure-box fail $X $P $FA $Depth) (fail))) -; - - - - (= - (print-procedure-box $Mode $G $P - (/ $F $A) $Depth) - ( (get-symbols &self - (= - (%current_spypoint $P $F $A) $_)) - (set-det) - ($builtin-message (:: + $Depth $Mode : (with_self $P $G))) - ($read-blocked (print-procedure-box $Mode $G $P (/ $F $A) $Depth)))) -; - - (= - (print-procedure-box $Mode $G $P $FA $Depth) - ( (get-symbols &self - (= - (%leap_flag no) $_)) - (set-det) - ($builtin-message (:: ' ' $Depth $Mode : (with_self $P $G))) - (det-if-then-else - (get-symbols &self - (= - (%current_leash $Mode) $_)) - ($read-blocked (print-procedure-box $Mode $G $P $FA $Depth)) nl))) -; - - (= - (print_procedure_box $_ $_ $_ $_ $_) True) -; - - - - (= - (redo_procedure_box $_ $_ $_ $_) True) -; - - (= - (redo-procedure-box $X $P $FA $Depth) - ( (print-procedure-box redo $X $P $FA $Depth) (fail))) -; - - - - (= - ($read-blocked $G) - ( ($fast-write ? ) - (flush-output) - (read-line $C) - (det-if-then-else - (== $C Nil) - (= $DOP 99) - (= $C - (Cons $DOP $_))) - ($debug-option $DOP $G))) -; - - - - (= - ($debug-option 97 $_) - ( (set-det) - (notrace) - (abort))) -; - ; -; - - (= - ($debug-option 99 $_) - ( (set-det) ($set-debug-flag leap no))) -; - ; -; - - (= - ($debug-option 108 $_) - ( (set-det) ($set-debug-flag leap yes))) -; - ; -; - - (= - ($debug-option 43 - (print-procedure-box $Mode $G $P $FA $Depth)) - ( (set-det) - (spy (with_self $P $FA)) - (call (print-procedure-box $Mode $G $P $FA $Depth)))) -; - - (= - ($debug-option 45 - (print-procedure-box $Mode $G $P $FA $Depth)) - ( (set-det) - (nospy (with_self $P $FA)) - (call (print-procedure-box $Mode $G $P $FA $Depth)))) -; - - (= - ($debug-option 63 $G) - ( (set-det) - (%show-debug-option) - (call $G))) -; - - (= - ($debug-option 104 $G) - ( (set-det) - (%show-debug-option) - (call $G))) -; - - (= - (%debug_option $_ $_) True) -; - - - - (= - (%show-debug-option) - ( (tab 4) - ($fast-write 'Debuggin options:') - (nl) - (tab 4) - ($fast-write 'a abort') - (nl) - (tab 4) - ($fast-write 'RET creep') - (nl) - (tab 4) - ($fast-write 'c creep') - (nl) - (tab 4) - ($fast-write 'l leap') - (nl) - (tab 4) - ($fast-write '+ spy this') - (nl) - (tab 4) - ($fast-write '- nospy this') - (nl) - (tab 4) - ($fast-write '? help') - (nl) - (tab 4) - ($fast-write 'h help') - (nl))) -; - - - - (= - ($set-debug-flag leap $Flag) - ( (get-symbols &self - (= - (%leap_flag $Flag) $_)) (set-det))) -; - - (= - ($set-debug-flag leap $Flag) - ( (remove-all-symbols &self - (%leap_flag $_)) (add-symbol &self (%leap_flag $Flag)))) -; - - -; -; - - - (= - (listing) - ($listing $_ user)) -; - - - (= - (listing $T) - ( (var $T) - (set-det) - (illarg var - (listing $T) 1))) -; - - (= - (listing $P) - ( (atom $P) - (set-det) - ($listing $_ $P))) -; - - (= - (listing (/ $F $A)) - ( (set-det) ($listing (/ $F $A) user))) -; - - (= - (listing (with_self $P $PI)) - ( (atom $P) - (set-det) - ($listing $PI $P))) -; - - (= - (listing $T) - (illarg - (type predicate-indicator) - (listing $T) 1)) -; - - - - (= - ($listing $PI $P) - ( (var $PI) - (set-det) - ($listing-dynamic-clause $P $_))) -; - - (= - ($listing - (/ $F $A) $P) - ( (atom $F) - (integer $A) - (set-det) - ($listing-dynamic-clause $P - (/ $F $A)))) -; - - (= - ($listing $PI $P) - (illarg - (type predicate-indicator) - (listing (with_self $P $PI)) 1)) -; - - - - (= - ($listing-dynamic-clause $P $PI) - ( ($new-internal-database $P) - (hash-keys $P $Keys) - ($builtin-member $PI $Keys) - (= $PI - (/ $F $A)) - (functor $H $F $A) - ($clause-internal $P $PI $H $Cl $_) - ($write-dynamic-clause $P $Cl) - (fail))) -; - - (= - (%listing_dynamic_clause $_ $_) True) -; - - - - (= - ($write-dynamic-clause $_ $Cl) - ( (var $Cl) - (set-det) - (fail))) -; - - (= - ($write-dynamic-clause $P - (= $H True)) - ( (set-det) - (numbervars $H 0 $_) - ($write-dynamic-head $P $H) - (write .) - (nl))) -; - - (= - ($write-dynamic-clause $P - (= $H $B)) - ( (set-det) - (numbervars - (= $H $B) 0 $_) - ($write-dynamic-head $P $H) - (write :-) - (nl) - ($write-dynamic-body $B 8) - (write .) - (nl))) -; - - - - (= - ($write-dynamic-head user $H) - ( (set-det) (writeq $H))) -; - - (= - ($write-dynamic-head $P $H) - ( (write $P) - (write :) - (writeq $H))) -; - - - - (= - ($write-dynamic-body - (, $G1 $G2) $N) - ( (set-det) - ($write-dynamic-body $G1 $N) - (write ,) - (nl) - ($write-dynamic-body $G2 $N))) -; - - (= - ($write-dynamic-body - (or $G1 $G2) $N) - ( (set-det) - (is $N1 - (+ $N 4)) - (tab $N) - (write () - (nl) - ($write-dynamic-body $G1 $N1) - (nl) - (tab $N) - (write or) - (nl) - ($write-dynamic-body $G2 $N1) - (nl) - (tab $N) - (write )))) -; - - (= - ($write-dynamic-body - (det-if-then $G1 $G2) $N) - ( (set-det) - (is $N1 - (+ $N 4)) - (tab $N) - (write () - (nl) - ($write-dynamic-body $G1 $N1) - (nl) - (tab $N) - (write ->) - (nl) - ($write-dynamic-body $G2 $N1) - (nl) - (tab $N) - (write )))) -; - - (= - ($write-dynamic-body $B $N) - ( (tab $N) (writeq $B))) -; - - -; -; - -; -; - -; -; - - - !(public (/ reverse 2)) -; - - !(public (/ length 2)) -; - - !(public (/ numbervars 3)) -; - - !(public (/ statistics 2)) -; - - -; -; - -; -; - -; -; - - - - (= - (length $L $N) - ( (var $N) - (set-det) - ($length $L 0 $N))) -; - - (= - (length $L $N) - ($length0 $L 0 $N)) -; - - - - (= - ($length () $I $I) True) -; - - (= - ($length - (Cons $_ $L) $I0 $I) - ( (is $I1 - (+ $I0 1)) ($length $L $I1 $I))) -; - - - - (= - ($length0 Nil $I $I) - (set-det)) -; - - (= - ($length0 - (Cons $_ $L) $I0 $I) - ( (< $I0 $I) - (is $I1 - (+ $I0 1)) - ($length0 $L $I1 $I))) -; - - - - (= - (numbervars $X $VI $VN) - ( (integer $VI) - (>= $VI 0) - (set-det) - ($numbervars $X $VI $VN))) -; - - - - (= - ($numbervars $X $VI $VN) - ( (var $X) - (set-det) - (= $X $VI) - (is $VN - (+ $VI 1)))) -; - - (= - ($numbervars $X $VI $VI) - ( (atomic $X) (set-det))) -; - - (= - ($numbervars $X $VI $VI) - ( (java $X) (set-det))) -; - - (= - ($numbervars $X $VI $VN) - ( (functor $X $_ $N) ($numbervars-str 1 $N $X $VI $VN))) -; - - - - (= - ($numbervars-str $I $I $X $VI $VN) - ( (set-det) - (arg $I $X $A) - ($numbervars $A $VI $VN))) -; - - (= - ($numbervars-str $I $N $X $VI $VN) - ( (arg $I $X $A) - ($numbervars $A $VI $VN1) - (is $I1 - (+ $I 1)) - ($numbervars-str $I1 $N $X $VN1 $VN))) -; - - - - (= - (statistics $Key $Value) - ( (nonvar $Key) - ($statistics-mode $Key) - (set-det) - ($statistics $Key $Value))) -; - - (= - (statistics $Key $Value) - ( (findall $M - ($statistics-mode $M) $Domain) (illarg (domain is-symbol $Domain) (statistics $Key $Value) 1))) -; - - - - (= - (%statistics_mode runtime) True) -; - - (= - (%statistics_mode trail) True) -; - - (= - (%statistics_mode choice) True) -; - - - - (= - (print-message $Type $Message) - ( (var $Type) - (set-det) - (illarg var - (print-message $Type $Message) 1))) -; - - (= - (print-message error $Message) - ( (set-det) ($error-message $Message))) -; - - (= - (print-message info $Message) - ( (set-det) - ($fast-write {) - ($builtin-message $Message) - ($fast-write }) - (nl))) -; - - (= - (print-message warning $Message) - ( (set-det) - ($fast-write '{WARNING: ') - ($builtin-message $Message) - ($fast-write }) - (nl))) -; - - - - (= - ($error-message (instantiation-error $Goal 0)) - ( (set-det) - ($fast-write user-error '{INSTANTIATION ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (instantiation-error $Goal $ArgNo)) - ( (set-det) - ($fast-write user-error '{INSTANTIATION ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error ' - arg ') - ($fast-write user-error $ArgNo) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (type-error $Goal $ArgNo $Type $Culprit)) - ( (set-det) - ($fast-write user-error '{TYPE ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error ' - arg ') - ($fast-write user-error $ArgNo) - ($fast-write user-error ': expected ') - ($fast-write user-error $Type) - ($fast-write user-error ', found ') - (write user-error $Culprit) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (domain-error $Goal $ArgNo $Domain $Culprit)) - ( (set-det) - ($fast-write user-error '{DOMAIN ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error ' - arg ') - ($fast-write user-error $ArgNo) - ($fast-write user-error ': expected ') - ($fast-write user-error $Domain) - ($fast-write user-error ', found ') - (write user-error $Culprit) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (existence-error $Goal 0 $ObjType $Culprit $Message)) - ( (set-det) - ($fast-write user-error '{EXISTENCE ERROR: ') - ($fast-write user-error $ObjType) - ($fast-write user-error ' ') - (write user-error $Culprit) - ($fast-write user-error ' does not exist') - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (existence-error $Goal $ArgNo $ObjType $Culprit $Message)) - ( (set-det) - ($fast-write user-error '{EXISTENCE ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error ' - arg ') - ($fast-write user-error $ArgNo) - ($fast-write user-error : ) - ($fast-write user-error $ObjType) - ($fast-write user-error ' ') - (write user-error $Culprit) - ($fast-write user-error ' does not exist') - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (permission-error $Goal $Operation $ObjType $Culprit $Message)) - ( (set-det) - ($fast-write user-error '{PERMISSION ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error ' - can not ') - ($fast-write user-error $Operation) - ($fast-write user-error ' ') - ($fast-write user-error $ObjType) - ($fast-write user-error ' ') - (write user-error $Culprit) - ($fast-write user-error : ) - ($fast-write user-error $Message) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (representation-error $Goal $ArgNo $Flag)) - ( (set-det) - ($fast-write user-error '{REPRESENTATION ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error ' - arg ') - ($fast-write user-error $ArgNo) - ($fast-write user-error ': limit of ') - ($fast-write user-error $Flag) - ($fast-write user-error ' is breached') - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (evaluation-error $Goal $ArgNo $Type)) - ( (set-det) - ($fast-write user-error '{EVALUATION ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error ' - arg ') - ($fast-write user-error $ArgNo) - ($fast-write user-error ', found ') - ($fast-write user-error $Type) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (syntax-error $Goal $ArgNo $Type $Culprit $Message)) - ( (set-det) - ($fast-write user-error '{SYNTAX ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error ' - arg ') - ($fast-write user-error $ArgNo) - ($fast-write user-error ': expected ') - ($fast-write user-error $Type) - ($fast-write user-error ', found ') - (write user-error $Culprit) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (system-error $Message)) - ( (set-det) - ($fast-write user-error '{SYSTEM ERROR: ') - (write user-error $Message) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (internal-error $Message)) - ( (set-det) - ($fast-write user-error '{INTERNAL ERROR: ') - (write user-error $Message) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - (= - ($error-message (java-error $Goal $ArgNo $Exception)) - ( (set-det) - ($fast-write user-error '{JAVA ERROR: ') - ($write-goal user-error $Goal) - ($fast-write user-error ' - arg ') - ($fast-write user-error $ArgNo) - ($fast-write user-error ', found ') - ($write-goal user-error $Exception) - ($fast-write user-error }) - (nl user-error) - ($print-stack-trace $Exception) - (flush-output user-error))) -; - - (= - ($error-message $Message) - ( ($fast-write user-error {) - (write user-error $Message) - ($fast-write user-error }) - (nl user-error) - (flush-output user-error))) -; - - - - (= - ($write-goal $S $Goal) - ( (java $Goal) - (set-det) - ($write-toString $S $Goal))) -; - - (= - ($write-goal $S $Goal) - (write $S $Goal)) -; - - - - (= - (illarg $Msg $Goal $ArgNo) - ( (var $Msg) + ($builtin-message (:: + $Depth $Mode : (with_self $P $G))) + ($read-blocked (print-procedure-box $Mode $G $P (/ $F $A) $Depth)))) + (= (print-procedure-box $Mode $G $P $FA $Depth) + ( (== + (= + (%leap_flag no) $_) + (get-atoms &self)) (set-det) - (illarg var $Goal $ArgNo))) -; - - (= - (illarg var $Goal $ArgNo) - (raise-exception (instantiation-error $Goal $ArgNo))) -; - - (= + ($builtin-message (:: ' ' $Depth $Mode : (with_self $P $G))) + (det-if-then-else + (== + (= + (%current_leash $Mode) $_) + (get-atoms &self)) + ($read-blocked (print-procedure-box $Mode $G $P $FA $Depth)) nl))) + (= (print_procedure_box $_ $_ $_ $_ $_) True) + + + (= (redo_procedure_box $_ $_ $_ $_) True) + (= (redo-procedure-box $X $P $FA $Depth) + (print-procedure-box redo $X $P $FA $Depth) + (fail)) + + + (= ($read-blocked $G) + ($fast-write ? ) + (flush-output) + (read-line $C) + (det-if-then-else + (== $C Nil) + (= $DOP 99) + (= $C + (Cons $DOP $_))) + ($debug-option $DOP $G)) + + + (= ($debug-option 97 $_) + (set-det) + (notrace) + (abort)) ; +; a for abort + (= ($debug-option 99 $_) + (set-det) + ($set-debug-flag leap no)) ; +; c for creep + (= ($debug-option 108 $_) + (set-det) + ($set-debug-flag leap yes)) ; +; l for leap + (= ($debug-option 43 (print-procedure-box $Mode $G $P $FA $Depth)) + (set-det) + (spy (with_self $P $FA)) + (call (print-procedure-box $Mode $G $P $FA $Depth))) +; ; + for spy this + (= ($debug-option 45 (print-procedure-box $Mode $G $P $FA $Depth)) + (set-det) + (nospy (with_self $P $FA)) + (call (print-procedure-box $Mode $G $P $FA $Depth))) +; ; - for nospy this + (= ($debug-option 63 $G) + (set-det) + (%show-debug-option) + (call $G)) + (= ($debug-option 104 $G) + (set-det) + (%show-debug-option) + (call $G)) + (= (%debug_option $_ $_) True) + + + (= (%show-debug-option) + (tab 4) + ($fast-write 'Debuggin options:') + (nl) + (tab 4) + ($fast-write 'a abort') + (nl) + (tab 4) + ($fast-write 'RET creep') + (nl) + (tab 4) + ($fast-write 'c creep') + (nl) + (tab 4) + ($fast-write 'l leap') + (nl) + (tab 4) + ($fast-write '+ spy this') + (nl) + (tab 4) + ($fast-write '- nospy this') + (nl) + (tab 4) + ($fast-write '? help') + (nl) + (tab 4) + ($fast-write 'h help') + (nl)) + + + (= ($set-debug-flag leap $Flag) + ( (== + (= + (%leap_flag $Flag) $_) + (get-atoms &self)) (set-det))) + (= ($set-debug-flag leap $Flag) + ( (remove-all-atoms &self + (%leap_flag $_)) (add-is-symbol &self (%leap_flag $Flag)))) + +; +; ;; Listing + + (= (listing) + ($listing $_ user)) + + (= (listing $T) + (var $T) + (set-det) + (illarg var + (listing $T) 1)) + (= (listing $P) + (atom $P) + (set-det) + ($listing $_ $P)) + (= (listing (/ $F $A)) + (set-det) + ($listing + (/ $F $A) user)) + (= (listing (with_self $P $PI)) + (atom $P) + (set-det) + ($listing $PI $P)) + (= (listing $T) + (illarg + (type predicate-indicator) + (listing $T) 1)) + + + (= ($listing $PI $P) + (var $PI) + (set-det) + ($listing-dynamic-clause $P $_)) + (= ($listing (/ $F $A) $P) + (atom $F) + (integer $A) + (set-det) + ($listing-dynamic-clause $P + (/ $F $A))) + (= ($listing $PI $P) (illarg - (type $Type) $Goal $ArgNo) - ( (arg $ArgNo $Goal $Arg) + (type predicate-indicator) + (listing (with_self $P $PI)) 1)) + + + (= ($listing-dynamic-clause $P $PI) + ($new-internal-database $P) + (hash-keys $P $Keys) + ($builtin-member $PI $Keys) + (= $PI + (/ $F $A)) + (functor $H $F $A) + ($clause-internal $P $PI $H $Cl $_) + ($write-dynamic-clause $P $Cl) + (fail)) + (= (%listing_dynamic_clause $_ $_) True) + + + (= ($write-dynamic-clause $_ $Cl) + (var $Cl) + (set-det) + (fail)) + (= ($write-dynamic-clause $P (= $H True)) + (set-det) + (numbervars $H 0 $_) + ($write-dynamic-head $P $H) + (write .) + (nl)) + (= ($write-dynamic-clause $P (= $H $B)) + (set-det) + (numbervars + (= $H $B) 0 $_) + ($write-dynamic-head $P $H) + (write :-) + (nl) + ($write-dynamic-body $B 8) + (write .) + (nl)) + + + (= ($write-dynamic-head user $H) + (set-det) + (writeq $H)) + (= ($write-dynamic-head $P $H) + (write $P) + (write :) + (writeq $H)) + + + (= ($write-dynamic-body (, $G1 $G2) $N) + (set-det) + ($write-dynamic-body $G1 $N) + (write ,) + (nl) + ($write-dynamic-body $G2 $N)) + (= ($write-dynamic-body (or $G1 $G2) $N) + (set-det) + (is $N1 + (+ $N 4)) + (tab $N) + (write () + (nl) + ($write-dynamic-body $G1 $N1) + (nl) + (tab $N) + (write or) + (nl) + ($write-dynamic-body $G2 $N1) + (nl) + (tab $N) + (write ))) + (= ($write-dynamic-body (det-if-then $G1 $G2) $N) + (set-det) + (is $N1 + (+ $N 4)) + (tab $N) + (write () + (nl) + ($write-dynamic-body $G1 $N1) + (nl) + (tab $N) + (write ->) + (nl) + ($write-dynamic-body $G2 $N1) + (nl) + (tab $N) + (write ))) + (= ($write-dynamic-body $B $N) + (tab $N) + (writeq $B)) + +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Misc +; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + !(public (/ reverse 2)) + !(public (/ length 2)) + !(public (/ numbervars 3)) + !(public (/ statistics 2)) + +; +; reverse(Xs, Zs) :- reverse(Xs, [], Zs). +; +; reverse([], Zs, Zs). +; +; reverse([X|Xs], Tmp, Zs) :- reverse(Xs, [X|Tmp], Zs). + + + (= (length $L $N) + (var $N) + (set-det) + ($length $L 0 $N)) + (= (length $L $N) + ($length0 $L 0 $N)) + + + (= (%length () $I $I) True) + (= ($length (Cons $_ $L) $I0 $I) + (is $I1 + (+ $I0 1)) + ($length $L $I1 $I)) + + + (= ($length0 Nil $I $I) + (set-det)) + (= ($length0 (Cons $_ $L) $I0 $I) + (< $I0 $I) + (is $I1 + (+ $I0 1)) + ($length0 $L $I1 $I)) + + + (= (numbervars $X $VI $VN) + (integer $VI) + (>= $VI 0) + (set-det) + ($numbervars $X $VI $VN)) + + + (= ($numbervars $X $VI $VN) + (var $X) + (set-det) + (= $X $VI) + (is $VN + (+ $VI 1))) +; ; This structure is checked in write + (= ($numbervars $X $VI $VI) + (atomic $X) + (set-det)) + (= ($numbervars $X $VI $VI) + (java $X) + (set-det)) + (= ($numbervars $X $VI $VN) + (functor $X $_ $N) + ($numbervars-str 1 $N $X $VI $VN)) + + + (= ($numbervars-str $I $I $X $VI $VN) + (set-det) + (arg $I $X $A) + ($numbervars $A $VI $VN)) + (= ($numbervars-str $I $N $X $VI $VN) + (arg $I $X $A) + ($numbervars $A $VI $VN1) + (is $I1 + (+ $I 1)) + ($numbervars-str $I1 $N $X $VN1 $VN)) + + + (= (statistics $Key $Value) + (nonvar $Key) + ($statistics-mode $Key) + (set-det) + ($statistics $Key $Value)) + (= (statistics $Key $Value) + (findall $M + ($statistics-mode $M) $Domain) + (illarg + (domain is-symbol $Domain) + (statistics $Key $Value) 1)) + + + (= (%statistics_mode runtime) True) + (= (%statistics_mode trail) True) + (= (%statistics_mode choice) True) + + + (= (print-message $Type $Message) + (var $Type) + (set-det) + (illarg var + (print-message $Type $Message) 1)) + (= (print-message error $Message) + (set-det) + ($error-message $Message)) + (= (print-message info $Message) + (set-det) + ($fast-write {) + ($builtin-message $Message) + ($fast-write }) + (nl)) + (= (print-message warning $Message) + (set-det) + ($fast-write '{WARNING: ') + ($builtin-message $Message) + ($fast-write }) + (nl)) + + + (= ($error-message (instantiation-error $Goal 0)) + (set-det) + ($fast-write user-error '{INSTANTIATION ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (instantiation-error $Goal $ArgNo)) + (set-det) + ($fast-write user-error '{INSTANTIATION ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error ' - arg ') + ($fast-write user-error $ArgNo) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (type-error $Goal $ArgNo $Type $Culprit)) + (set-det) + ($fast-write user-error '{TYPE ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error ' - arg ') + ($fast-write user-error $ArgNo) + ($fast-write user-error ': expected ') + ($fast-write user-error $Type) + ($fast-write user-error ', found ') + (write user-error $Culprit) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (domain-error $Goal $ArgNo $Domain $Culprit)) + (set-det) + ($fast-write user-error '{DOMAIN ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error ' - arg ') + ($fast-write user-error $ArgNo) + ($fast-write user-error ': expected ') + ($fast-write user-error $Domain) + ($fast-write user-error ', found ') + (write user-error $Culprit) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (existence-error $Goal 0 $ObjType $Culprit $Message)) + (set-det) + ($fast-write user-error '{EXISTENCE ERROR: ') + ($fast-write user-error $ObjType) + ($fast-write user-error ' ') + (write user-error $Culprit) + ($fast-write user-error ' does not exist') + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (existence-error $Goal $ArgNo $ObjType $Culprit $Message)) + (set-det) + ($fast-write user-error '{EXISTENCE ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error ' - arg ') + ($fast-write user-error $ArgNo) + ($fast-write user-error : ) + ($fast-write user-error $ObjType) + ($fast-write user-error ' ') + (write user-error $Culprit) + ($fast-write user-error ' does not exist') + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (permission-error $Goal $Operation $ObjType $Culprit $Message)) + (set-det) + ($fast-write user-error '{PERMISSION ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error ' - can not ') + ($fast-write user-error $Operation) + ($fast-write user-error ' ') + ($fast-write user-error $ObjType) + ($fast-write user-error ' ') + (write user-error $Culprit) + ($fast-write user-error : ) + ($fast-write user-error $Message) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (representation-error $Goal $ArgNo $Flag)) + (set-det) + ($fast-write user-error '{REPRESENTATION ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error ' - arg ') + ($fast-write user-error $ArgNo) + ($fast-write user-error ': limit of ') + ($fast-write user-error $Flag) + ($fast-write user-error ' is breached') + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (evaluation-error $Goal $ArgNo $Type)) + (set-det) + ($fast-write user-error '{EVALUATION ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error ' - arg ') + ($fast-write user-error $ArgNo) + ($fast-write user-error ', found ') + ($fast-write user-error $Type) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (syntax-error $Goal $ArgNo $Type $Culprit $Message)) + (set-det) + ($fast-write user-error '{SYNTAX ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error ' - arg ') + ($fast-write user-error $ArgNo) + ($fast-write user-error ': expected ') + ($fast-write user-error $Type) + ($fast-write user-error ', found ') + (write user-error $Culprit) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (system-error $Message)) + (set-det) + ($fast-write user-error '{SYSTEM ERROR: ') + (write user-error $Message) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (internal-error $Message)) + (set-det) + ($fast-write user-error '{INTERNAL ERROR: ') + (write user-error $Message) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + (= ($error-message (java-error $Goal $ArgNo $Exception)) + (set-det) + ($fast-write user-error '{JAVA ERROR: ') + ($write-goal user-error $Goal) + ($fast-write user-error ' - arg ') + ($fast-write user-error $ArgNo) + ($fast-write user-error ', found ') + ($write-goal user-error $Exception) + ($fast-write user-error }) + (nl user-error) + ($print-stack-trace $Exception) + (flush-output user-error)) + (= ($error-message $Message) + ($fast-write user-error {) + (write user-error $Message) + ($fast-write user-error }) + (nl user-error) + (flush-output user-error)) + + + (= ($write-goal $S $Goal) + (java $Goal) + (set-det) + ($write-toString $S $Goal)) + (= ($write-goal $S $Goal) + (write $S $Goal)) + + + (= (illarg $Msg $Goal $ArgNo) + (var $Msg) + (set-det) + (illarg var $Goal $ArgNo)) + (= (illarg var $Goal $ArgNo) + (raise-exception (instantiation-error $Goal $ArgNo))) + (= (illarg (type $Type) $Goal $ArgNo) + (arg $ArgNo $Goal $Arg) + (det-if-then-else + (nonvar $Arg) + (= $Error + (type-error $Goal $ArgNo $Type $Arg)) + (= $Error + (instantiation-error $Goal $ArgNo))) + (raise-exception $Error)) + (= (illarg (domain $Type $ExpDomain) $Goal $ArgNo) + (arg $ArgNo $Goal $Arg) + (det-if-then-else + ($match-type $Type $Arg) + (= $Error + (domain-error $Goal $ArgNo $ExpDomain $Arg)) (det-if-then-else (nonvar $Arg) (= $Error (type-error $Goal $ArgNo $Type $Arg)) (= $Error - (instantiation-error $Goal $ArgNo))) - (raise-exception $Error))) -; - - (= - (illarg - (domain $Type $ExpDomain) $Goal $ArgNo) - ( (arg $ArgNo $Goal $Arg) - (det-if-then-else - ($match-type $Type $Arg) - (= $Error - (domain-error $Goal $ArgNo $ExpDomain $Arg)) - (det-if-then-else - (nonvar $Arg) - (= $Error - (type-error $Goal $ArgNo $Type $Arg)) - (= $Error - (instantiation-error $Goal $ArgNo)))) - (raise-exception $Error))) -; - - (= - (illarg - (existence $ObjType $Culprit $Message) $Goal $ArgNo) - (raise-exception (existence-error $Goal $ArgNo $ObjType $Culprit $Message))) -; - - (= - (illarg - (permission $Operation $ObjType $Culprit $Message) $Goal $_) - (raise-exception (permission-error $Goal $Operation $ObjType $Culprit $Message))) -; - - (= - (illarg - (representation $Flag) $Goal $ArgNo) - (raise-exception (representation-error $Goal $ArgNo $Flag))) -; - - (= - (illarg - (evaluation $Type) $Goal $ArgNo) - (raise-exception (evaluation-error $Goal $ArgNo $Type))) -; - - (= - (illarg - (syntax $Type $Culprit $Message) $Goal $ArgNo) - (raise-exception (syntax-error $Goal $ArgNo $Type $Culprit $Message))) -; - - (= - (illarg - (system $Message) $_ $_) - (raise-exception (system-error $Message))) -; - - (= - (illarg - (internal $Message) $_ $_) - (raise-exception (internal-error $Message))) -; - - (= - (illarg - (java $Exception) $Goal $ArgNo) - (raise-exception (java-error $Goal $ArgNo $Exception))) -; - - (= - (illarg $Msg $_ $_) - (raise-exception $Msg)) -; - - - - (= - (%match_type term $_) True) -; - - (= - ($match-type variable $X) - (var $X)) -; - - (= - ($match-type is-symbol $X) - (atom $X)) -; - - (= - ($match-type symbolic $X) - (atomic $X)) -; - - (= - ($match-type byte $X) - ( (integer $X) - (=< 0 $X) - (=< $X 255))) -; - - (= - ($match-type in-byte $X) - ( (integer $X) - (=< -1 $X) - (=< $X 255))) -; - - (= - ($match-type character $X) - ( (atom $X) (atom-length $X 1))) -; - - (= - ($match-type in-character $X) + (instantiation-error $Goal $ArgNo)))) + (raise-exception $Error)) + (= (illarg (existence $ObjType $Culprit $Message) $Goal $ArgNo) + (raise-exception (existence-error $Goal $ArgNo $ObjType $Culprit $Message))) + (= (illarg (permission $Operation $ObjType $Culprit $Message) $Goal $_) + (raise-exception (permission-error $Goal $Operation $ObjType $Culprit $Message))) + (= (illarg (representation $Flag) $Goal $ArgNo) + (raise-exception (representation-error $Goal $ArgNo $Flag))) + (= (illarg (evaluation $Type) $Goal $ArgNo) + (raise-exception (evaluation-error $Goal $ArgNo $Type))) + (= (illarg (syntax $Type $Culprit $Message) $Goal $ArgNo) + (raise-exception (syntax-error $Goal $ArgNo $Type $Culprit $Message))) + (= (illarg (system $Message) $_ $_) + (raise-exception (system-error $Message))) + (= (illarg (internal $Message) $_ $_) + (raise-exception (internal-error $Message))) + (= (illarg (java $Exception) $Goal $ArgNo) + (raise-exception (java-error $Goal $ArgNo $Exception))) + (= (illarg $Msg $_ $_) + (raise-exception $Msg)) + + + (= (%match_type term $_) True) + (= ($match-type variable $X) + (var $X)) + (= ($match-type is-symbol $X) + (atom $X)) + (= ($match-type symbolic $X) + (atomic $X)) + (= ($match-type byte $X) + (integer $X) + (=< 0 $X) + (=< $X 255)) + (= ($match-type in-byte $X) + (integer $X) + (=< -1 $X) + (=< $X 255)) + (= ($match-type character $X) + (atom $X) + (atom-length $X 1)) + (= ($match-type in-character $X) (or (== $X end-of-file) - ($match-type character $X))) -; - - (= - ($match-type number $X) - (number $X)) -; - - (= - ($match-type integer $X) - (integer $X)) -; - - (= - ($match-type long $X) - (long $X)) -; - - (= - ($match-type float $X) - (float $X)) -; - - (= - ($match-type callable $X) - (callable $X)) -; - - (= - ($match-type compound $X) - (compound $X)) -; - - (= - ($match-type list $X) - ( (nonvar $X) (or (= $X Nil) (= $X (Cons $_ $_))))) -; - - (= - ($match-type java $X) - (java $X)) -; - - (= - ($match-type stream $X) + ($match-type character $X))) + (= ($match-type number $X) + (number $X)) + (= ($match-type integer $X) + (integer $X)) + (= ($match-type long $X) + (long $X)) + (= ($match-type float $X) + (float $X)) + (= ($match-type callable $X) + (callable $X)) + (= ($match-type compound $X) + (compound $X)) + (= ($match-type list $X) + (nonvar $X) + (or + (= $X Nil) + (= $X + (Cons $_ $_)))) + (= ($match-type java $X) + (java $X)) + (= ($match-type stream $X) (or (java $X java.io.PushbackReader) - (java $X java.io.PrintWriter))) -; - - (= - ($match-type stream-or-alias $X) + (java $X java.io.PrintWriter))) + (= ($match-type stream-or-alias $X) (or (atom $X) - ($match-type stream $X))) -; - - (= - ($match-type hash $X) - (java $X com.googlecode.prolog-cafe.lang.HashtableOfTerm)) -; - - (= - ($match-type hash-or-alias $X) + ($match-type stream $X))) + (= ($match-type hash $X) + (java $X com.googlecode.prolog-cafe.lang.HashtableOfTerm)) + (= ($match-type hash-or-alias $X) (or (atom $X) - ($match-type hash $X))) -; - - (= - ($match-type predicate-indicator $X) - ( (nonvar $X) - (= $X - (with_self $P - (/ $F $A))) - (atom $P) - (atom $F) - (integer $A))) -; - + ($match-type hash $X))) + (= ($match-type predicate-indicator $X) + (nonvar $X) + (= $X + (with_self $P + (/ $F $A))) + (atom $P) + (atom $F) + (integer $A)) ; -; - +; '$match_type'(evaluable, X). ; -; - +; '$match_type'('convertible to java', X). ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; ISO thread synchronization ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - !(public (/ with-mutex 2)) -; - + !(public (/ with-mutex 2)) - (= - (with-mutex $M $G) - ( (not (atom $M)) - (not (java $M)) - (set-det) - (illarg - (type is-symbol) - (with-mutex $M $G) 1))) -; - - (= - (with-mutex $M $G) - ( (var $G) - (set-det) - (illarg var - (with-mutex $M $G) 2))) -; - - (= - (with-mutex $M $G) - ( (not (callable $G)) - (set-det) - (illarg - (type callable) - (with-mutex $M $G) 2))) -; - - (= - (with-mutex $M $G) - ( (mutex-lock-bt $M) - (call $G) - (set-det) - (mutex-unlock $M))) -; - + (= (with-mutex $M $G) + (not (atom $M)) + (not (java $M)) + (set-det) + (illarg + (type is-symbol) + (with-mutex $M $G) 1)) + (= (with-mutex $M $G) + (var $G) + (set-det) + (illarg var + (with-mutex $M $G) 2)) + (= (with-mutex $M $G) + (not (callable $G)) + (set-det) + (illarg + (type callable) + (with-mutex $M $G) 2)) + (= (with-mutex $M $G) + (mutex-lock-bt $M) + (call $G) + (set-det) + (mutex-unlock $M)) +; ; if it fails or throws exception, mutex is unlocked automatically due to mutex_lock_bt ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; Utilities ; -; +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (= - (%builtin_append () $Zs $Zs) True) -; - - (= - ($builtin-append - (Cons $X $Xs) $Ys - (Cons $X $Zs)) - ($builtin-append $Xs $Ys $Zs)) -; - + (= (%builtin_append () $Zs $Zs) True) + (= ($builtin-append (Cons $X $Xs) $Ys (Cons $X $Zs)) + ($builtin-append $Xs $Ys $Zs)) ; -; - +; '$builtin_member'(X, [X|_]). ; -; - +; '$builtin_member'(X, [_|L]) :- '$builtin_member'(X, L). - (= - ($builtin-message Nil) - (set-det)) -; - - (= - ($builtin-message (:: $M)) - ( (set-det) (write $M))) -; - - (= - ($builtin-message (Cons $M $Ms)) - ( (write $M) - ($fast-write ' ') - ($builtin-message $Ms))) -; - + (= ($builtin-message Nil) + (set-det)) + (= ($builtin-message (:: $M)) + (set-det) + (write $M)) + (= ($builtin-message (Cons $M $Ms)) + (write $M) + ($fast-write ' ') + ($builtin-message $Ms)) - (= - ($member-in-reverse $X - (Cons $_ $L)) - ($member-in-reverse $X $L)) -; - - (= - (%member_in_reverse $X - (Cons $X $_)) True) -; - + (= ($member-in-reverse $X (Cons $_ $L)) + ($member-in-reverse $X $L)) + (= (%member_in_reverse $X (Cons $X $_)) True) ; -; - +; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; -; - +; END diff --git a/sxx_machine/tau_operators.metta b/sxx_machine/tau_operators.metta index 72a8c85..2766563 100644 --- a/sxx_machine/tau_operators.metta +++ b/sxx_machine/tau_operators.metta @@ -1,43 +1,18 @@ +; (convert_to_metta_file tau_operators $_34720 sxx_machine/tau_operators.pl sxx_machine/tau_operators.metta) - !(op 1170 xfx :-) -; - - !(op 1170 xfx -->) -; - - !(op 1170 fx :-) -; - - !(op 1170 fx ?-) -; - - !(op 500 yfx #) -; - - !(op 1150 fx dynamic) -; - - !(op 1150 fx meta-predicate) -; - - !(op 1150 fx package) -; - - !(op 1150 fx public) -; - - !(op 1150 fx import) -; - - !(op 1150 fx mode) -; - - !(op 1150 fx multifile) -; - - !(op 1150 fx block) -; - + !(op 1170 xfx :-) + !(op 1170 xfx -->) + !(op 1170 fx :-) + !(op 1170 fx ?-) + !(op 500 yfx #) + !(op 1150 fx dynamic) + !(op 1150 fx meta-predicate) + !(op 1150 fx package) + !(op 1150 fx public) + !(op 1150 fx import) + !(op 1150 fx mode) + !(op 1150 fx multifile) + !(op 1150 fx block) diff --git a/sxx_machine/tau_system.metta b/sxx_machine/tau_system.metta index 28e9150..eb267e8 100644 --- a/sxx_machine/tau_system.metta +++ b/sxx_machine/tau_system.metta @@ -1,1279 +1,301 @@ - !(op 1150 fx package) -; - +; (convert_to_metta_file tau_system $_104114 sxx_machine/tau_system.pl sxx_machine/tau_system.metta) + !(op 1150 fx package) - (= - (package $X) - (nb-setval package $X)) -; - + (= (package $X) + (nb-setval package $X)) - !(package com.googlecode.prolog-cafe.builtin) -; - - !(public (/ system-predicate 1)) -; - - !(multifile (/ system-predicate 1)) -; - - !(dynamic (/ system-predicate 1)) -; - + !(package com.googlecode.prolog-cafe.builtin) + !(public (/ system-predicate 1)) + !(multifile (/ system-predicate 1)) + !(dynamic (/ system-predicate 1)) - (= - (system_predicate - (system_predicate $_)) True) -; - + (= (system_predicate (system_predicate $_)) True) ; -; - - (= - (system_predicate true) True) -; - - (= - (system_predicate therwise) True) -; - - (= - (system_predicate fail) True) -; - - (= - (system_predicate false) True) -; - - (= - (system_predicate !) True) -; - - (= - (system_predicate - (%get_level $_)) True) -; - - (= - (system_predicate $neck_cut) True) -; - - (= - (system_predicate - ($cut $_)) True) -; - - (= - (system_predicate - (^ $_ $_)) True) -; - - (= - (system_predicate - (, $_ $_)) True) -; - - (= - (system_predicate - (; $_ $_)) True) -; - - (= - (system_predicate - (-> $_ $_)) True) -; - - (= - (system_predicate - (call $_)) True) -; - - (= - (system_predicate - (catch $_ $_ $_)) True) -; - - (= - (system_predicate - (throw $_)) True) -; - - (= - (system_predicate - (on_exception $_ $_ $_)) True) -; - - (= - (system_predicate - (raise_exception $_)) True) -; - +; Control constructs + (= (system_predicate true) True) + (= (system_predicate therwise) True) + (= (system_predicate fail) True) + (= (system_predicate false) True) + (= (system_predicate !) True) + (= (system_predicate (%get_level $_)) True) + (= (system_predicate $neck_cut) True) + (= (system_predicate (%cut $_)) True) + (= (system_predicate (^ $_ $_)) True) + (= (system_predicate (, $_ $_)) True) + (= (system_predicate (; $_ $_)) True) + (= (system_predicate (-> $_ $_)) True) + (= (system_predicate (call $_)) True) + (= (system_predicate (catch $_ $_ $_)) True) + (= (system_predicate (throw $_)) True) + (= (system_predicate (on_exception $_ $_ $_)) True) + (= (system_predicate (raise_exception $_)) True) ; -; - - (= - (system_predicate - (= $_ $_)) True) -; - - (= - (system_predicate - ($unify $_ $_)) True) -; - - (= - (system_predicate - (\= $_ $_)) True) -; - - (= - (system_predicate - (%not_unifiable $_ $_)) True) -; - +; Term unification + (= (system_predicate (= $_ $_)) True) + (= (system_predicate (%unify $_ $_)) True) + (= (system_predicate (\= $_ $_)) True) + (= (system_predicate (%not_unifiable $_ $_)) True) ; -; - - (= - (system_predicate - (var $_)) True) -; - - (= - (system_predicate - (is-symbol $_)) True) -; - - (= - (system_predicate - (integer $_)) True) -; - - (= - (system_predicate - (long $_)) True) -; - - (= - (system_predicate - (float $_)) True) -; - - (= - (system_predicate - (atomic $_)) True) -; - - (= - (system_predicate - (compound $_)) True) -; - - (= - (system_predicate - (nonvar $_)) True) -; - - (= - (system_predicate - (number $_)) True) -; - - (= - (system_predicate - (java $_)) True) -; - - (= - (system_predicate - (java $_ $_)) True) -; - - (= - (system_predicate - (closure $_)) True) -; - - (= - (system_predicate - (ground $_)) True) -; - - (= - (system_predicate - (callable $_)) True) -; - +; Type testing + (= (system_predicate (var $_)) True) + (= (system_predicate (is-symbol $_)) True) + (= (system_predicate (integer $_)) True) + (= (system_predicate (long $_)) True) + (= (system_predicate (float $_)) True) + (= (system_predicate (is-symbolic $_)) True) + (= (system_predicate (compound $_)) True) + (= (system_predicate (nonvar $_)) True) + (= (system_predicate (number $_)) True) + (= (system_predicate (java $_)) True) + (= (system_predicate (java $_ $_)) True) + (= (system_predicate (closure $_)) True) + (= (system_predicate (ground $_)) True) + (= (system_predicate (callable $_)) True) ; -; - - (= - (system_predicate - (== $_ $_)) True) -; - - (= - (system_predicate - (%equality_of_term $_ $_)) True) -; - - (= - (system_predicate - (\== $_ $_)) True) -; - - (= - (system_predicate - (%inequality_of_term $_ $_)) True) -; - - (= - (system_predicate - (@< $_ $_)) True) -; - - (= - (system_predicate - ($before $_ $_)) True) -; - - (= - (system_predicate - (@> $_ $_)) True) -; - - (= - (system_predicate - ($after $_ $_)) True) -; - - (= - (system_predicate - (@=< $_ $_)) True) -; - - (= - (system_predicate - (%not_after $_ $_)) True) -; - - (= - (system_predicate - (@>= $_ $_)) True) -; - - (= - (system_predicate - (%not_before $_ $_)) True) -; - - (= - (system_predicate - (?= $_ $_)) True) -; - - (= - (system_predicate - (%identical_or_cannot_unify $_ $_)) True) -; - - (= - (system_predicate - (compare $_ $_ $_)) True) -; - - (= - (system_predicate - (sort $_ $_)) True) -; - - (= - (system_predicate - (keysort $_ $_)) True) -; - +; Term comparison + (= (system_predicate (== $_ $_)) True) + (= (system_predicate (%equality_of_term $_ $_)) True) + (= (system_predicate (\== $_ $_)) True) + (= (system_predicate (%inequality_of_term $_ $_)) True) + (= (system_predicate (@< $_ $_)) True) + (= (system_predicate (%before $_ $_)) True) + (= (system_predicate (@> $_ $_)) True) + (= (system_predicate (%after $_ $_)) True) + (= (system_predicate (@=< $_ $_)) True) + (= (system_predicate (%not_after $_ $_)) True) + (= (system_predicate (@>= $_ $_)) True) + (= (system_predicate (%not_before $_ $_)) True) + (= (system_predicate (?= $_ $_)) True) + (= (system_predicate (%identical_or_cannot_unify $_ $_)) True) + (= (system_predicate (compare $_ $_ $_)) True) + (= (system_predicate (sort $_ $_)) True) + (= (system_predicate (keysort $_ $_)) True) ; -; - +; system_predicate(merge(_,_,_)). ; -; - - (= - (system_predicate - (arg $_ $_ $_)) True) -; - - (= - (system_predicate - (functor $_ $_ $_)) True) -; - - (= - (system_predicate - (=.. $_ $_)) True) -; - - (= - (system_predicate - ($univ $_ $_)) True) -; - - (= - (system_predicate - (copy_term $_ $_)) True) -; - +; Term creation and decomposition + (= (system_predicate (arg $_ $_ $_)) True) + (= (system_predicate (functor $_ $_ $_)) True) + (= (system_predicate (=.. $_ $_)) True) + (= (system_predicate (%univ $_ $_)) True) + (= (system_predicate (copy_term $_ $_)) True) ; -; - - (= - (system_predicate - (is $_ $_)) True) -; - - (= - (system_predicate - ($abs $_ $_)) True) -; - - (= - (system_predicate - ($asin $_ $_)) True) -; - - (= - (system_predicate - ($acos $_ $_)) True) -; - - (= - (system_predicate - ($atan $_ $_)) True) -; - - (= - (system_predicate - (%bitwise_conj $_ $_ $_)) True) -; - - (= - (system_predicate - (%bitwise_disj $_ $_ $_)) True) -; - - (= - (system_predicate - (%bitwise_exclusive_or $_ $_ $_)) True) -; - - (= - (system_predicate - (%bitwise_neg $_ $_)) True) -; - - (= - (system_predicate - ($ceil $_ $_)) True) -; - - (= - (system_predicate - ($cos $_ $_)) True) -; - - (= - (system_predicate - ($degrees $_ $_)) True) -; - - (= - (system_predicate - ($exp $_ $_)) True) -; - - (= - (system_predicate - ($float $_ $_)) True) -; - - (= - (system_predicate - (%float_integer_part $_ $_)) True) -; - - (= - (system_predicate - (%float_fractional_part $_ $_)) True) -; - - (= - (system_predicate - (%float_quotient $_ $_ $_)) True) -; - - (= - (system_predicate - ($floor $_ $_)) True) -; - - (= - (system_predicate - (%int_quotient $_ $_ $_)) True) -; - - (= - (system_predicate - ($log $_ $_)) True) -; - - (= - (system_predicate - ($max $_ $_ $_)) True) -; - - (= - (system_predicate - ($min $_ $_ $_)) True) -; - - (= - (system_predicate - ($minus $_ $_ $_)) True) -; - - (= - (system_predicate - ($mod $_ $_ $_)) True) -; - - (= - (system_predicate - ($multi $_ $_ $_)) True) -; - - (= - (system_predicate - ($plus $_ $_ $_)) True) -; - - (= - (system_predicate - ($pow $_ $_ $_)) True) -; - - (= - (system_predicate - ($radians $_ $_)) True) -; - - (= - (system_predicate - ($rint $_ $_)) True) -; - - (= - (system_predicate - ($round $_ $_)) True) -; - - (= - (system_predicate - (%shift_left $_ $_ $_)) True) -; - - (= - (system_predicate - (%shift_right $_ $_ $_)) True) -; - - (= - (system_predicate - ($sign $_ $_)) True) -; - - (= - (system_predicate - ($sin $_ $_)) True) -; - - (= - (system_predicate - ($sqrt $_ $_)) True) -; - - (= - (system_predicate - ($tan $_ $_)) True) -; - - (= - (system_predicate - ($truncate $_ $_)) True) -; - +; Arithmetic evaluation + (= (system_predicate (is $_ $_)) True) + (= (system_predicate (%abs $_ $_)) True) + (= (system_predicate (%asin $_ $_)) True) + (= (system_predicate (%acos $_ $_)) True) + (= (system_predicate (%atan $_ $_)) True) + (= (system_predicate (%bitwise_conj $_ $_ $_)) True) + (= (system_predicate (%bitwise_disj $_ $_ $_)) True) + (= (system_predicate (%bitwise_exclusive_or $_ $_ $_)) True) + (= (system_predicate (%bitwise_neg $_ $_)) True) + (= (system_predicate (%ceil $_ $_)) True) + (= (system_predicate (%cos $_ $_)) True) + (= (system_predicate (%degrees $_ $_)) True) + (= (system_predicate (%exp $_ $_)) True) + (= (system_predicate (%float $_ $_)) True) + (= (system_predicate (%float_integer_part $_ $_)) True) + (= (system_predicate (%float_fractional_part $_ $_)) True) + (= (system_predicate (%float_quotient $_ $_ $_)) True) + (= (system_predicate (%floor $_ $_)) True) + (= (system_predicate (%int_quotient $_ $_ $_)) True) + (= (system_predicate (%log $_ $_)) True) + (= (system_predicate (%max $_ $_ $_)) True) + (= (system_predicate (%min $_ $_ $_)) True) + (= (system_predicate (%minus $_ $_ $_)) True) + (= (system_predicate (%mod $_ $_ $_)) True) + (= (system_predicate (%multi $_ $_ $_)) True) + (= (system_predicate (%plus $_ $_ $_)) True) + (= (system_predicate (%pow $_ $_ $_)) True) + (= (system_predicate (%radians $_ $_)) True) + (= (system_predicate (%rint $_ $_)) True) + (= (system_predicate (%round $_ $_)) True) + (= (system_predicate (%shift_left $_ $_ $_)) True) + (= (system_predicate (%shift_right $_ $_ $_)) True) + (= (system_predicate (%sign $_ $_)) True) + (= (system_predicate (%sin $_ $_)) True) + (= (system_predicate (%sqrt $_ $_)) True) + (= (system_predicate (%tan $_ $_)) True) + (= (system_predicate (%truncate $_ $_)) True) ; -; - - (= - (system_predicate - (=:= $_ $_)) True) -; - - (= - (system_predicate - (%arith_equal $_ $_)) True) -; - - (= - (system_predicate - (=\= $_ $_)) True) -; - - (= - (system_predicate - (%arith_not_equal $_ $_)) True) -; - - (= - (system_predicate - (< $_ $_)) True) -; - - (= - (system_predicate - (%less_than $_ $_)) True) -; - - (= - (system_predicate - (=< $_ $_)) True) -; - - (= - (system_predicate - (%less_or_equal $_ $_)) True) -; - - (= - (system_predicate - (> $_ $_)) True) -; - - (= - (system_predicate - (%greater_than $_ $_)) True) -; - - (= - (system_predicate - (>= $_ $_)) True) -; - - (= - (system_predicate - (%greater_or_equal $_ $_)) True) -; - +; Arithmetic comparison + (= (system_predicate (=:= $_ $_)) True) + (= (system_predicate (%arith_equal $_ $_)) True) + (= (system_predicate (=\= $_ $_)) True) + (= (system_predicate (%arith_not_equal $_ $_)) True) + (= (system_predicate (< $_ $_)) True) + (= (system_predicate (%less_than $_ $_)) True) + (= (system_predicate (=< $_ $_)) True) + (= (system_predicate (%less_or_equal $_ $_)) True) + (= (system_predicate (> $_ $_)) True) + (= (system_predicate (%greater_than $_ $_)) True) + (= (system_predicate (>= $_ $_)) True) + (= (system_predicate (%greater_or_equal $_ $_)) True) ; -; - - (= - (system_predicate - (clause $_ $_)) True) -; - - (= - (system_predicate - (initialization $_ $_)) True) -; - - (= - (system_predicate - (%new_indexing_hash $_ $_ $_)) True) -; - +; Clause retrieval and information + (= (system_predicate (clause $_ $_)) True) + (= (system_predicate (initialization $_ $_)) True) + (= (system_predicate (%new_indexing_hash $_ $_ $_)) True) ; -; - - (= - (system_predicate - (assert $_)) True) -; - - (= - (system_predicate - (assertz $_)) True) -; - - (= - (system_predicate - (asserta $_)) True) -; - - (= - (system_predicate - (retract $_)) True) -; - - (= - (system_predicate - (abolish $_)) True) -; - - (= - (system_predicate - (retractall $_)) True) -; - +; Clause creation and destruction + (= (system_predicate (assert $_)) True) + (= (system_predicate (assertz $_)) True) + (= (system_predicate (asserta $_)) True) + (= (system_predicate (retract $_)) True) + (= (system_predicate (abolish $_)) True) + (= (system_predicate (retractall $_)) True) ; -; - - (= - (system_predicate - (findall $_ $_ $_)) True) -; - - (= - (system_predicate - (bagof $_ $_ $_)) True) -; - - (= - (system_predicate - (setof $_ $_ $_)) True) -; - +; All solutions + (= (system_predicate (findall $_ $_ $_)) True) + (= (system_predicate (bagof $_ $_ $_)) True) + (= (system_predicate (setof $_ $_ $_)) True) ; -; - - (= - (system_predicate - (current_input $_)) True) -; - - (= - (system_predicate - (current_output $_)) True) -; - - (= - (system_predicate - (set_input $_)) True) -; - - (= - (system_predicate - (set_output $_)) True) -; - - (= - (system_predicate - (open $_ $_ $_)) True) -; - - (= - (system_predicate - (open $_ $_ $_ $_)) True) -; - - (= - (system_predicate - (close $_)) True) -; - - (= - (system_predicate - (close $_ $_)) True) -; - - (= - (system_predicate - (flush_output $_)) True) -; - - (= - (system_predicate flush_output) True) -; - - (= - (system_predicate - (stream_property $_ $_)) True) -; - +; Stream selection and control + (= (system_predicate (current_input $_)) True) + (= (system_predicate (current_output $_)) True) + (= (system_predicate (set_input $_)) True) + (= (system_predicate (set_output $_)) True) + (= (system_predicate (open $_ $_ $_)) True) + (= (system_predicate (open $_ $_ $_ $_)) True) + (= (system_predicate (close $_)) True) + (= (system_predicate (close $_ $_)) True) + (= (system_predicate (flush_output $_)) True) + (= (system_predicate flush_output) True) + (= (system_predicate (stream_property $_ $_)) True) ; -; - - (= - (system_predicate - (get_char $_)) True) -; - - (= - (system_predicate - (get_char $_ $_)) True) -; - - (= - (system_predicate - (get_code $_)) True) -; - - (= - (system_predicate - (get_code $_ $_)) True) -; - - (= - (system_predicate - (peek_char $_)) True) -; - - (= - (system_predicate - (peek_char $_ $_)) True) -; - - (= - (system_predicate - (peek_code $_)) True) -; - - (= - (system_predicate - (peek_code $_ $_)) True) -; - - (= - (system_predicate - (put_char $_)) True) -; - - (= - (system_predicate - (put_char $_ $_)) True) -; - - (= - (system_predicate - (put_code $_)) True) -; - - (= - (system_predicate - (put_code $_ $_)) True) -; - - (= - (system_predicate nl) True) -; - - (= - (system_predicate - (nl $_)) True) -; - - (= - (system_predicate - (get0 $_)) True) -; - - (= - (system_predicate - (get0 $_ $_)) True) -; - - (= - (system_predicate - (get $_)) True) -; - - (= - (system_predicate - (get $_ $_)) True) -; - - (= - (system_predicate - (put $_)) True) -; - - (= - (system_predicate - (put $_ $_)) True) -; - - (= - (system_predicate - (tab $_)) True) -; - - (= - (system_predicate - (tab $_ $_)) True) -; - - (= - (system_predicate - (skip $_)) True) -; - - (= - (system_predicate - (skip $_ $_)) True) -; - +; Character input/output + (= (system_predicate (get_char $_)) True) + (= (system_predicate (get_char $_ $_)) True) + (= (system_predicate (get_code $_)) True) + (= (system_predicate (get_code $_ $_)) True) + (= (system_predicate (peek_char $_)) True) + (= (system_predicate (peek_char $_ $_)) True) + (= (system_predicate (peek_code $_)) True) + (= (system_predicate (peek_code $_ $_)) True) + (= (system_predicate (put_char $_)) True) + (= (system_predicate (put_char $_ $_)) True) + (= (system_predicate (put_code $_)) True) + (= (system_predicate (put_code $_ $_)) True) + (= (system_predicate nl) True) + (= (system_predicate (nl $_)) True) + (= (system_predicate (get0 $_)) True) + (= (system_predicate (get0 $_ $_)) True) + (= (system_predicate (get $_)) True) + (= (system_predicate (get $_ $_)) True) + (= (system_predicate (put $_)) True) + (= (system_predicate (put $_ $_)) True) + (= (system_predicate (tab $_)) True) + (= (system_predicate (tab $_ $_)) True) + (= (system_predicate (skip $_)) True) + (= (system_predicate (skip $_ $_)) True) ; -; - - (= - (system_predicate - (get_byte $_)) True) -; - - (= - (system_predicate - (get_byte $_ $_)) True) -; - - (= - (system_predicate - (peek_byte $_)) True) -; - - (= - (system_predicate - (peek_byte $_ $_)) True) -; - - (= - (system_predicate - (put_byte $_)) True) -; - - (= - (system_predicate - (put_byte $_ $_)) True) -; - +; Byte input/output + (= (system_predicate (get_byte $_)) True) + (= (system_predicate (get_byte $_ $_)) True) + (= (system_predicate (peek_byte $_)) True) + (= (system_predicate (peek_byte $_ $_)) True) + (= (system_predicate (put_byte $_)) True) + (= (system_predicate (put_byte $_ $_)) True) ; -; - - (= - (system_predicate - (read $_)) True) -; - - (= - (system_predicate - (read $_ $_)) True) -; - - (= - (system_predicate - (read_with_variables $_ $_)) True) -; - - (= - (system_predicate - (read_with_variables $_ $_ $_)) True) -; - - (= - (system_predicate - (read_line $_)) True) -; - - (= - (system_predicate - (read_line $_ $_)) True) -; - - (= - (system_predicate - (write $_)) True) -; - - (= - (system_predicate - (write $_ $_)) True) -; - - (= - (system_predicate - (writeq $_)) True) -; - - (= - (system_predicate - (writeq $_ $_)) True) -; - - (= - (system_predicate - (write_canonical $_)) True) -; - - (= - (system_predicate - (write_canonical $_ $_)) True) -; - - (= - (system_predicate - (write_term $_ $_)) True) -; - - (= - (system_predicate - (write_term $_ $_ $_)) True) -; - - (= - (system_predicate - (op $_ $_ $_)) True) -; - - (= - (system_predicate - (current_op $_ $_ $_)) True) -; - +; Term input/output + (= (system_predicate (read $_)) True) + (= (system_predicate (read $_ $_)) True) + (= (system_predicate (read_with_variables $_ $_)) True) + (= (system_predicate (read_with_variables $_ $_ $_)) True) + (= (system_predicate (read_line $_)) True) + (= (system_predicate (read_line $_ $_)) True) + (= (system_predicate (write $_)) True) + (= (system_predicate (write $_ $_)) True) + (= (system_predicate (writeq $_)) True) + (= (system_predicate (writeq $_ $_)) True) + (= (system_predicate (write_canonical $_)) True) + (= (system_predicate (write_canonical $_ $_)) True) + (= (system_predicate (write_term $_ $_)) True) + (= (system_predicate (write_term $_ $_ $_)) True) + (= (system_predicate (op $_ $_ $_)) True) + (= (system_predicate (current_op $_ $_ $_)) True) ; -; - - (= - (system_predicate - (\+ $_)) True) -; - - (= - (system_predicate - (once $_)) True) -; - - (= - (system_predicate repeat) True) -; - +; Logic and control + (= (system_predicate (\+ $_)) True) + (= (system_predicate (once $_)) True) + (= (system_predicate repeat) True) ; -; - - (= - (system_predicate - (symbol_length $_ $_)) True) -; - - (= - (system_predicate - (symbol_concat $_ $_ $_)) True) -; - - (= - (system_predicate - (sub_symbol $_ $_ $_ $_ $_)) True) -; - - (= - (system_predicate - (symbol_chars $_ $_)) True) -; - - (= - (system_predicate - (symbol_codes $_ $_)) True) -; - - (= - (system_predicate - (char_code $_ $_)) True) -; - - (= - (system_predicate - (number_chars $_ $_)) True) -; - - (= - (system_predicate - (number_codes $_ $_)) True) -; - - (= - (system_predicate - (name $_ $_)) True) -; - +; Atomic term processing + (= (system_predicate (symbol_length $_ $_)) True) + (= (system_predicate (symbol_concat $_ $_ $_)) True) + (= (system_predicate (sub_symbol $_ $_ $_ $_ $_)) True) + (= (system_predicate (symbol_chars $_ $_)) True) + (= (system_predicate (symbol_codes $_ $_)) True) + (= (system_predicate (char_code $_ $_)) True) + (= (system_predicate (number_chars $_ $_)) True) + (= (system_predicate (number_codes $_ $_)) True) + (= (system_predicate (name $_ $_)) True) ; -; - - (= - (system_predicate - (set_prolog_flag $_ $_)) True) -; - - (= - (system_predicate - (current_prolog_flag $_ $_)) True) -; - - (= - (system_predicate halt) True) -; - - (= - (system_predicate - (halt $_)) True) -; - - (= - (system_predicate abort) True) -; - +; Implementation defined hooks + (= (system_predicate (set_prolog_flag $_ $_)) True) + (= (system_predicate (current_prolog_flag $_ $_)) True) + (= (system_predicate halt) True) + (= (system_predicate (halt $_)) True) + (= (system_predicate abort) True) ; -; - - (= - (system_predicate - (C $_ $_ $_)) True) -; - - (= - (system_predicate - (expand_term $_ $_)) True) -; - +; DCG + (= (system_predicate (C $_ $_ $_)) True) + (= (system_predicate (expand_term $_ $_)) True) ; -; - - (= - (system_predicate - (new_hash $_)) True) -; - - (= - (system_predicate - (new_hash $_ $_)) True) -; - - (= - (system_predicate - (hash_clear $_)) True) -; - - (= - (system_predicate - (hash_contains_key $_ $_)) True) -; - - (= - (system_predicate - (hash_get $_ $_ $_)) True) -; - - (= - (system_predicate - (hash_is_empty $_)) True) -; - - (= - (system_predicate - (hash_keys $_ $_)) True) -; - - (= - (system_predicate - (hash_map $_ $_)) True) -; - - (= - (system_predicate - (hash_put $_ $_ $_)) True) -; - - (= - (system_predicate - (hash_remove $_ $_)) True) -; - - (= - (system_predicate - (hash_size $_ $_)) True) -; - - (= - (system_predicate - (%get_hash_manager $_)) True) -; - +; Hash creation and control + (= (system_predicate (new_hash $_)) True) + (= (system_predicate (new_hash $_ $_)) True) + (= (system_predicate (hash_clear $_)) True) + (= (system_predicate (hash_contains_key $_ $_)) True) + (= (system_predicate (hash_get $_ $_ $_)) True) + (= (system_predicate (hash_is_empty $_)) True) + (= (system_predicate (hash_keys $_ $_)) True) + (= (system_predicate (hash_map $_ $_)) True) + (= (system_predicate (hash_put $_ $_ $_)) True) + (= (system_predicate (hash_remove $_ $_)) True) + (= (system_predicate (hash_size $_ $_)) True) + (= (system_predicate (%get_hash_manager $_)) True) ; -; - - (= - (system_predicate - (java_constructor0 $_ $_)) True) -; - - (= - (system_predicate - (java_constructor $_ $_)) True) -; - - (= - (system_predicate - (java_declared_constructor0 $_ $_)) True) -; - - (= - (system_predicate - (java_declared_constructor $_ $_)) True) -; - - (= - (system_predicate - (java_method0 $_ $_ $_)) True) -; - - (= - (system_predicate - (java_method $_ $_ $_)) True) -; - - (= - (system_predicate - (java_declared_method0 $_ $_ $_)) True) -; - - (= - (system_predicate - (java_declared_method $_ $_ $_)) True) -; - - (= - (system_predicate - (java_get_field0 $_ $_ $_)) True) -; - - (= - (system_predicate - (java_get_field $_ $_ $_)) True) -; - - (= - (system_predicate - (java_get_declared_field0 $_ $_ $_)) True) -; - - (= - (system_predicate - (java_get_declared_field $_ $_ $_)) True) -; - - (= - (system_predicate - (java_set_field0 $_ $_ $_)) True) -; - - (= - (system_predicate - (java_set_field $_ $_ $_)) True) -; - - (= - (system_predicate - (java_set_declared_field0 $_ $_ $_)) True) -; - - (= - (system_predicate - (java_set_declared_field $_ $_ $_)) True) -; - - (= - (system_predicate - (synchronized $_ $_)) True) -; - - (= - (system_predicate - (java_conversion $_ $_)) True) -; - +; Java interoperation + (= (system_predicate (java_constructor0 $_ $_)) True) + (= (system_predicate (java_constructor $_ $_)) True) + (= (system_predicate (java_declared_constructor0 $_ $_)) True) + (= (system_predicate (java_declared_constructor $_ $_)) True) + (= (system_predicate (java_method0 $_ $_ $_)) True) + (= (system_predicate (java_method $_ $_ $_)) True) + (= (system_predicate (java_declared_method0 $_ $_ $_)) True) + (= (system_predicate (java_declared_method $_ $_ $_)) True) + (= (system_predicate (java_get_field0 $_ $_ $_)) True) + (= (system_predicate (java_get_field $_ $_ $_)) True) + (= (system_predicate (java_get_declared_field0 $_ $_ $_)) True) + (= (system_predicate (java_get_declared_field $_ $_ $_)) True) + (= (system_predicate (java_set_field0 $_ $_ $_)) True) + (= (system_predicate (java_set_field $_ $_ $_)) True) + (= (system_predicate (java_set_declared_field0 $_ $_ $_)) True) + (= (system_predicate (java_set_declared_field $_ $_ $_)) True) + (= (system_predicate (synchronized $_ $_)) True) + (= (system_predicate (java_conversion $_ $_)) True) ; -; - - (= - (system_predicate cafeteria) True) -; - - (= - (system_predicate - (consult $_)) True) -; - - (= - (system_predicate trace) True) -; - - (= - (system_predicate notrace) True) -; - - (= - (system_predicate debug) True) -; - - (= - (system_predicate nodebug) True) -; - - (= - (system_predicate - (leash $_)) True) -; - - (= - (system_predicate - (spy $_)) True) -; - - (= - (system_predicate - (nospy $_)) True) -; - - (= - (system_predicate nospyall) True) -; - - (= - (system_predicate listing) True) -; - - (= - (system_predicate - (listing $_)) True) -; - +; MeTTa interpreter + (= (system_predicate cafeteria) True) + (= (system_predicate (consult $_)) True) + (= (system_predicate trace) True) + (= (system_predicate notrace) True) + (= (system_predicate debug) True) + (= (system_predicate nodebug) True) + (= (system_predicate (leash $_)) True) + (= (system_predicate (spy $_)) True) + (= (system_predicate (nospy $_)) True) + (= (system_predicate nospyall) True) + (= (system_predicate listing) True) + (= (system_predicate (listing $_)) True) ; -; - - (= - (system_predicate - (length $_ $_)) True) -; - - (= - (system_predicate - (numbervars $_ $_ $_)) True) -; - - (= - (system_predicate - (statistics $_ $_)) True) -; - +; Misc + (= (system_predicate (length $_ $_)) True) + (= (system_predicate (numbervars $_ $_ $_)) True) + (= (system_predicate (statistics $_ $_)) True) ; -; - +; END diff --git a/sxx_machine/tests/animal.metta b/sxx_machine/tests/animal.metta index 658fe91..e6c1fe3 100644 --- a/sxx_machine/tests/animal.metta +++ b/sxx_machine/tests/animal.metta @@ -1,15 +1,8 @@ +; (convert_to_metta_file animal $_266014 sxx_machine/tests/animal.pl sxx_machine/tests/animal.metta) - (= - (animal goat) True) -; - - (= - (animal elephant) True) -; - - (= - (animal $X) - ( (write 'please type one more animal name: ') (read $X))) -; - + (= (animal goat) True) + (= (animal elephant) True) + (= (animal $X) + (write 'please type one more animal name: ') + (read $X)) diff --git a/vs/vs.metta b/vs/vs.metta index 492ca52..f027e30 100644 --- a/vs/vs.metta +++ b/vs/vs.metta @@ -1,328 +1,464 @@ - - (= - (learn) - ( (writeln 'First positive example ?') - (read $POS_EX) - (nl) - (initialize $POS_EX $G $S) - (versionspace $G $S))) -; - +; (convert_to_metta_file vs $_344246 vs/vs.pl vs/vs.metta) + + (= (learn) + (writeln 'First positive example ?') + (read $POS_EX) + (nl) + (initialize $POS_EX $G $S) + (versionspace $G $S)) +; /******************************************************************/ +; /* VS.PRO Last Modification: Fri Jan 14 19:28:27 1994 */ +; /* Mitchell's bi-directional search strategy in the version space */ +; /******************************************************************/ +; ; ; Copyright (c) 1988 Luc De Raedt ; ; This program is free software; you can redistribute it and/or ; modify it under the terms of the GNU General Public License ; Version 1 as published by the Free Software Foundation. ; ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; ; You should have received a copy of the GNU General Public ; Licensealong with this program; if not, write to the Free ; SoftwareFoundation, Inc., 675 Mass Ave, Cambridge, MA 02139, ; USA. ; +; /******************************************************************/ +; /* impl. by : Luc De Raedt, Katholieke Universiteit Leuven, */ +; /* Department of Computer Science, */ +; /* Celestijnenlaan 200A, */ +; /* B-3030 Heverlee, */ +; /* Belgium */ +; /* E-Mail: lucdr@kulcs.uucp or lucdr@kulcs.bitnet */ +; /* 1988 */ +; /* */ +; /* reference : ES2ML Tutorial Exercise */ +; /* Version Space Algorithm */ +; /* Luc De Raedt */ +; /* */ +; /* Generalization as Search, */ +; /* Tom M. Mitchell, */ +; /* Artificial Intelligence 18, 1982. */ +; /* */ +; /* call : learn */ +; /* */ +; /******************************************************************/ +; /* THIS VERSION LEARNS CONJUNCTIONS AND CONSTRUCTS EXAMPLES */ +; /* FOR A SIMPLE ATTRIBUTE-VALUED GENERALISATION LANGUAGE */ +; /* */ +; /* LEARN will learn a concept, it needs only one example it will */ +; /* ask for the classification of further examples, which it will */ +; /* construct itself. The first example must be a list of */ +; /* attributes. */ +; /******************************************************************/ - (= - (versionspace Nil $_) - ( (writeln 'There is no consistent concept description in this language !') (set-det))) -; - - (= - (versionspace $_ Nil) - ( (writeln 'There is no consistent concept description in this language !') (set-det))) -; - - (= - (versionspace - (:: $CONCEPT) - (:: $CONCEPT)) - ( (set-det) - (writeln 'The consistent generalization is : ') - (writeln $CONCEPT))) -; - - (= - (versionspace $G $S) - ( (writeln 'The G-set is : ') - (writeln $G) - (writeln 'The S-set is : ') - (writeln $S) - (nl) - (writeln 'Next example :') - (generate-ex $G $S $NEXT_EX) - (set-det) - (writeln $NEXT_EX) - (writeln 'Classification of the example ? [p/n]') - (read $CLASS) - (nl) - (adjust-versionspace $CLASS $NEXT_EX $G $S $NG $NS) - (versionspace $NG $NS))) -; - - (= - (versionspace $G $S) + (= (versionspace Nil $_) + (writeln 'There is no consistent concept description in this language !') + (set-det)) +; /******************************************************************/ +; /* */ +; /* call : versionspace (+G_SET,+S_SET) */ +; /* */ +; /* arguments : G_SET = Set of most general concepts */ +; /* S_SET = Set of most special concepts */ +; /* */ +; /* side effects: terminal-I/O */ +; /* */ +; /******************************************************************/ +; /* VERSIONSPACE succeeds if there is a consistent concept, which */ +; /* is in the versionspace between g and s it will ask for the */ +; /* classification of examples, which it generates. */ +; /******************************************************************/ + (= (versionspace $_ Nil) + (writeln 'There is no consistent concept description in this language !') + (set-det)) + (= (versionspace (:: $CONCEPT) (:: $CONCEPT)) + (set-det) + (writeln 'The consistent generalization is : ') + (writeln $CONCEPT)) + (= (versionspace $G $S) + (writeln 'The G-set is : ') + (writeln $G) + (writeln 'The S-set is : ') + (writeln $S) + (nl) + (writeln 'Next example :') + (generate-ex $G $S $NEXT_EX) + (set-det) + (writeln $NEXT_EX) + (writeln 'Classification of the example ? [p/n]') + (read $CLASS) + (nl) + (adjust-versionspace $CLASS $NEXT_EX $G $S $NG $NS) + (versionspace $NG $NS)) + (= (versionspace $G $S) (writeln 'Impossible to generate relevant examples')) -; - - (= - (adjust-versionspace p $EX $G $S $NG $NS) - ( (retain-g $G $NG $EX) - (generalize-s $S $S1 $NG $EX) - (prune-s $S1 $NS))) -; - - (= - (adjust-versionspace n $EX $G $S $NG $NS) - ( (retain-s $S $NS $EX) - (specialize-g $G $G1 $NS $EX) - (prune-g $G1 $NG))) -; - + (= (adjust-versionspace p $EX $G $S $NG $NS) + (retain-g $G $NG $EX) + (generalize-s $S $S1 $NG $EX) + (prune-s $S1 $NS)) +; /******************************************************************/ +; /* */ +; /* call : adjust_versionspace(+CLASSIFICATION, */ +; /* +EXAMPLE, */ +; /* +G_SET, */ +; /* +S_SET, */ +; /* -UPDATED_S_SET, */ +; /* -UPDATED_G_SET) */ +; /* */ +; /* arguments : CLASSIFICATION = of the example p for positive */ +; /* or n for negative */ +; /* EXAMPLE = the example itself */ +; /* G_SET = the actual G-set */ +; /* S_SET = the actual S-set */ +; /* UPDATED_G_SET = the updated G-set */ +; /* UPDATED_S_SET = the updated S-set */ +; /* */ +; /******************************************************************/ +; /* ADJUST_VERSIONSPACE succeeds if UPDATED_G_SET and UPDATED_S_SET*/ +; /* specify the updated versionspace of G_SET and S_SET wrt EXAMPLE*/ +; /* and CLASSIFICATION. */ +; /******************************************************************/ + (= (adjust-versionspace n $EX $G $S $NG $NS) + (retain-s $S $NS $EX) + (specialize-g $G $G1 $NS $EX) + (prune-g $G1 $NG)) - (= - (retain-g Nil Nil $_) + (= (retain-g Nil Nil $_) (set-det)) -; - - (= - (retain-g - (Cons $CONCEPT $G) - (Cons $CONCEPT $NG) $EX) - ( (covers $CONCEPT $EX) - (set-det) - (retain-g $G $NG $EX))) -; - - (= - (retain-g - (Cons $CONCEPT $G) $NG $EX) +; /******************************************************************/ +; /* */ +; /* call : retain_g(+G_SET,-UPDATED_G_SET,+EXAMPLE) */ +; /* */ +; /* arguments : G_SET = the actual G-set */ +; /* UPDATED_G_SET = the updated G-set */ +; /* EXAMPLE = the example itself */ +; /* */ +; /******************************************************************/ +; /* RETAIN_G succeeds if UPDATED_G_SET lists the elements of G_SET */ +; /* which cover the EXAMPLE */ +; /******************************************************************/ + (= (retain-g (Cons $CONCEPT $G) (Cons $CONCEPT $NG) $EX) + (covers $CONCEPT $EX) + (set-det) + (retain-g $G $NG $EX)) + (= (retain-g (Cons $CONCEPT $G) $NG $EX) (retain-g $G $NG $EX)) -; - - (= - (retain-s Nil Nil $_) + (= (retain-s Nil Nil $_) (set-det)) -; - +; /******************************************************************/ +; /* */ +; /* call : retain_s(+S_SET,-UPDATED_S_SET,+EXAMPLE) */ +; /* */ +; /* arguments : S_SET = the actual S-set */ +; /* UPDATED_S_SET = the updated S-set */ +; /* EXAMPLE = the example itself */ +; /* */ +; /******************************************************************/ +; /* RETAIN_S succeeds if UPDATED_S_SET lists the elements of S_SET */ +; /* which do not cover the EXAMPLE */ +; /******************************************************************/ ; (error ; (syntax_error operator_expected) ; (file vs/vs.pl 164 11 8582)) - (= - (retain-s - (Cons $CONCEPT $S) $NS $EX) + (= (retain-s (Cons $CONCEPT $S) $NS $EX) (retain-s $S $NS $EX)) -; - - (= - (generalize-s $S $NS $NG $EX) + (= (generalize-s $S $NS $NG $EX) (setofnil $NCON (^ $CON (, (member $CON $S) (valid-least-generalization $CON $EX $NCON $NG))) $NS)) -; - +; /******************************************************************/ +; /* */ +; /* call : generalize_s(+S_SET,-UPDATED_S_SET, */ +; /* +G_SET,+EXAMPLE) */ +; /* */ +; /* arguments : S_SET = the actual S-set */ +; /* UPDATED_S_SET = the updated S-set */ +; /* G_SET = the actual G-set */ +; /* EXAMPLE = the example itself */ +; /* */ +; /******************************************************************/ +; /* GENERALIZE_S succeeds if UPDATED_S_SET lists the minimal */ +; /* generalizations of the elements in S_SET wrt EXAMPLE such that */ +; /* there is an element in G_SET which is more general. */ +; /******************************************************************/ - (= - (specialize-g $G $NG $NS $EX) + (= (specialize-g $G $NG $NS $EX) (setofnil $NCONCEPT (^ $CONCEPT (, (member $CONCEPT $G) (valid-greatest-specialization $CONCEPT $EX $NCONCEPT $NS))) $NG)) -; - +; /******************************************************************/ +; /* */ +; /* call : generalize_g(+G_SET,-UPDATED_G_SET, */ +; /* +S_SET,+EXAMPLE) */ +; /* */ +; /* arguments : G_SET = the actual G-set */ +; /* UPDATED_G_SET = the updated G-set */ +; /* S_SET = the actual S-set */ +; /* EXAMPLE = the example itself */ +; /* */ +; /******************************************************************/ +; /* GENERALIZE_G succeeds if UPDATED_G_SET lists the greatest */ +; /* specializations of the elements in G_SET wrt EXAMPLE such that */ +; /* there is an element in S_SET which is more specific. */ +; /******************************************************************/ - (= - (valid-least-generalization $CONCEPT $EX $NCONCEPT $NG) - ( (least-generalization $CONCEPT $EX $NCONCEPT) - (member $GENERAL $NG) - (more-general $GENERAL $NCONCEPT))) -; - + (= (valid-least-generalization $CONCEPT $EX $NCONCEPT $NG) + (least-generalization $CONCEPT $EX $NCONCEPT) + (member $GENERAL $NG) + (more-general $GENERAL $NCONCEPT)) +; /******************************************************************/ +; /* */ +; /* call : valid_least_generalization(+CONCEPT,+EXAMPLE, */ +; /* -GENERALIZATION, */ +; /* +G_SET) */ +; /* */ +; /* arguments : CONCEPT = concept description */ +; /* EXAMPLE = the example itself */ +; /* GENERALIZATION = a new generalization */ +; /* G_SET = the actual G-set */ +; /* */ +; /******************************************************************/ +; /* VALID_LEAST_GENERALIZATION succeeds if GENERALIZATION is a */ +; /* least generalization of EXAMPLE and CONCEPT such that there is */ +; /* an element in G_SET which is more general than GENERALIZATION */ +; /******************************************************************/ - (= - (valid-greatest-specialization $CONCEPT $EX $NCONCEPT $NS) - ( (greatest-specialization $CONCEPT $EX $NCONCEPT) - (member $SPECIFIC $NS) - (more-general $NCONCEPT $SPECIFIC))) -; - - - - (= - (prune-s $S $NS) + (= (valid-greatest-specialization $CONCEPT $EX $NCONCEPT $NS) + (greatest-specialization $CONCEPT $EX $NCONCEPT) + (member $SPECIFIC $NS) + (more-general $NCONCEPT $SPECIFIC)) +; /******************************************************************/ +; /* */ +; /* call : valid_greatest_specialization(+CONCEPT,+EXAMPLE,*/ +; /* -SPECIALIZATION, */ +; /* +S_SET) */ +; /* */ +; /* arguments : CONCEPT = concept description */ +; /* EXAMPLE = the example itself */ +; /* SPECIALIZATION = a new specialization */ +; /* S_SET = the actual S-set */ +; /* */ +; /******************************************************************/ +; /* VALID_GREATEST_SPECIALIZATION succeeds if SPECIALIZATION is a */ +; /* greatest specialization of CONCEPT wrt EXAMPLE such that there */ +; /* is an element in S_SET which is more specific than */ +; /* SPECIALIZATION */ +; /******************************************************************/ + + + (= (prune-s $S $NS) (prune-s-acc $S $S $NS)) -; - - - (= - (prune-s-acc Nil $_ Nil) +; /******************************************************************/ +; /* */ +; /* call : prune_s(+S_SET,-PRUNED_S_SET) */ +; /* */ +; /* arguments : S_SET = the actual S-set */ +; /* PRUNED_S_SET = the pruned S-set */ +; /* */ +; /******************************************************************/ +; /* PRUNE_S succeeds if PRUNED_S_SET is the set of non-redundant */ +; /* elements in S_SET. An element is non-redundant if there is no */ +; /* element in S_SET which is more specific. PRUNE_S using an */ +; /* accumulating parameter to store intermediate results. */ +; /******************************************************************/ + + (= (prune-s-acc Nil $_ Nil) (set-det)) -; - - (= - (prune-s-acc - (Cons $SPECIFIC $S) $ACC $NS) - ( (member $SPECIFIC1 $ACC) - (not (== $SPECIFIC1 $SPECIFIC)) - (more-general $SPECIFIC $SPECIFIC1) - (set-det) - (prune-s-acc $S $ACC $NS))) -; - - (= - (prune-s-acc - (Cons $SPECIFIC $S) $ACC - (Cons $SPECIFIC $NS)) + (= (prune-s-acc (Cons $SPECIFIC $S) $ACC $NS) + (member $SPECIFIC1 $ACC) + (not (== $SPECIFIC1 $SPECIFIC)) + (more-general $SPECIFIC $SPECIFIC1) + (set-det) + (prune-s-acc $S $ACC $NS)) + (= (prune-s-acc (Cons $SPECIFIC $S) $ACC (Cons $SPECIFIC $NS)) (prune-s-acc $S $ACC $NS)) -; - - (= - (prune-g $G $NG) + (= (prune-g $G $NG) (prune-g-acc $G $G $NG)) -; - - - (= - (prune-g-acc Nil $_ Nil) +; /******************************************************************/ +; /* */ +; /* call : prune_s(+G_SET,-PRUNED_G_SET) */ +; /* */ +; /* arguments : G_SET = the actual G-set */ +; /* PRUNED_G_SET = the pruned G-set */ +; /* */ +; /******************************************************************/ +; /* PRUNE_G succeeds if PRUNED_G_SET is the set of non-redundant */ +; /* elements in G_SET an element is non-redundant if there is no */ +; /* element in G_SET which is more general. PRUNE_G using an */ +; /* accumulating parameter to store intermediate results. */ +; /******************************************************************/ + + (= (prune-g-acc Nil $_ Nil) (set-det)) -; - - (= - (prune-g-acc - (Cons $GENERAL $G) $ACC $NG) - ( (member $GENERAL1 $ACC) - (not (== $GENERAL $GENERAL1)) - (more-general $GENERAL1 $GENERAL) - (set-det) - (prune-g-acc $G $ACC $NG))) -; - - (= - (prune-g-acc - (Cons $GENERAL $G) $ACC - (Cons $GENERAL $NG)) + (= (prune-g-acc (Cons $GENERAL $G) $ACC $NG) + (member $GENERAL1 $ACC) + (not (== $GENERAL $GENERAL1)) + (more-general $GENERAL1 $GENERAL) + (set-det) + (prune-g-acc $G $ACC $NG)) + (= (prune-g-acc (Cons $GENERAL $G) $ACC (Cons $GENERAL $NG)) (prune-g-acc $G $ACC $NG)) -; - - (= - (allcovers Nil $_) + (= (allcovers Nil $_) (set-det)) -; - - (= - (allcovers - (Cons $CON $REST) $EX) - ( (covers $CON $EX) (allcovers $REST $EX))) -; - +; /******************************************************************/ +; /* GENERATION OF EXAMPLES */ +; /******************************************************************/ +; /* */ +; /* call : allcovers(+CONCEPT_LIST,+EXAMPLE) */ +; /* */ +; /* arguments : CONCEPT_LIST = list of concepts */ +; /* EXAMPLE = the actual example */ +; /* */ +; /******************************************************************/ +; /* ALLCOVERS succeeds if all elements of CONCEPT_LIST cover */ +; /* EXAMPLE */ +; /******************************************************************/ + (= (allcovers (Cons $CON $REST) $EX) + (covers $CON $EX) + (allcovers $REST $EX)) ; (error ; (syntax_error operator_expected) ; (file vs/vs.pl 334 11 18121)) - (= - (generate-ex - (Cons $GENERAL $G) $S $EX) + (= (generate-ex (Cons $GENERAL $G) $S $EX) (generate-ex $G $S $EX)) -; - - (= - (find-ex Nil Nil) + (= (find-ex Nil Nil) (set-det)) -; - - (= - (find-ex - (Cons $GENERAL $G) - (Cons $LEAF $EX)) - ( (isa $LEAF $GENERAL) - (leaf $LEAF) - (find-ex $G $EX))) -; - +; /******************************************************************/ +; /* */ +; /* call : find_ex(+CONCEPT,+EXAMPLE) */ +; /* */ +; /* arguments : CONCEPT = general concept */ +; /* EXAMPLE = the actual example */ +; /* */ +; /******************************************************************/ +; /* FIND_EX succeeds if EXAMPLE is an example in the language of */ +; /* the versionspace such that it is covered by the element in */ +; /* EXAMPLE. */ +; /******************************************************************/ + (= (find-ex (Cons $GENERAL $G) (Cons $LEAF $EX)) + (isa $LEAF $GENERAL) + (leaf $LEAF) + (find-ex $G $EX)) - (= - (initialize $POS_EX - (:: $TOP) - (:: $POS_EX)) + (= (initialize $POS_EX (:: $TOP) (:: $POS_EX)) (max $TOP $POS_EX)) -; - +; /******************************************************************/ +; /* LANGUAGE DEPENDENT PREDICATES */ +; /******************************************************************/ +; /* */ +; /* call : initialize(+EXAMPLE,-G_SET,-S_SET) */ +; /* */ +; /* arguments : EXAMPLE = the positive example */ +; /* G_SET = initial G-set */ +; /* S_SET = initial S-set */ +; /* */ +; /******************************************************************/ +; /* INITIALIZE succeeds if G_SET is the g-set and S_SET is the */ +; /* s-set derived from the positive example */ +; /******************************************************************/ - (= - (covers () ()) True) -; - - (= - (covers - (Cons $C $CONCEPT) - (Cons $E $EXAMPLE)) - ( (isa $E $C) (covers $CONCEPT $EXAMPLE))) -; - + (= (covers () ()) True) +; /******************************************************************/ +; /* */ +; /* call : covers(+CONCEPT,+EXAMPLE) */ +; /* */ +; /* arguments : CONCEPT = concept description */ +; /* EXAMPLE = example */ +; /* */ +; /******************************************************************/ +; /* COVERS succeeds if CONCEPT covers EXAMPLE */ +; /******************************************************************/ + (= (covers (Cons $C $CONCEPT) (Cons $E $EXAMPLE)) + (isa $E $C) + (covers $CONCEPT $EXAMPLE)) - (= - (least_generalization () () ()) True) -; - - (= - (least-generalization - (Cons $CONCEPT $C) - (Cons $EX $E) - (Cons $NCONCEPT $N)) - ( (lge $CONCEPT $EX $NCONCEPT) (least-generalization $C $E $N))) -; - + (= (least_generalization () () ()) True) +; /******************************************************************/ +; /* */ +; /* call : least_generalization(+CONCEPT1,+EXAMPLE, */ +; /* -CONCEPT2) */ +; /* */ +; /* arguments : CONCEPT1 = concept description */ +; /* EXAMPLE = example */ +; /* CONCEPT2 = concept description */ +; /* */ +; /******************************************************************/ +; /* LEAST_GENERALIZATION succeeds if CONCEPT2 is the least */ +; /* generalization of CONCEPT1 and CONCEPT2 */ +; /******************************************************************/ + (= (least-generalization (Cons $CONCEPT $C) (Cons $EX $E) (Cons $NCONCEPT $N)) + (lge $CONCEPT $EX $NCONCEPT) + (least-generalization $C $E $N)) - (= - (greatest-specialization - (Cons $CONCEPT $C) - (Cons $EX $E) - (Cons $NCONCEPT $C)) + (= (greatest-specialization (Cons $CONCEPT $C) (Cons $EX $E) (Cons $NCONCEPT $C)) (gsp $CONCEPT $EX $NCONCEPT)) -; - - (= - (greatest-specialization - (Cons $CONCEPT $C) - (Cons $EX $E) - (Cons $CONCEPT $N)) +; /******************************************************************/ +; /* */ +; /* call : greatest_specialization(+CONCEPT1,+EXAMPLE, */ +; /* -CONCEPT2) */ +; /* */ +; /* arguments : CONCEPT1 = concept description */ +; /* EXAMPLE = example */ +; /* CONCEPT2 = concept description */ +; /* */ +; /******************************************************************/ +; /* GREATEST_SPECIALIZATION succeeds if CONCEPT2 is the greatest */ +; /* specialization of CONCEPT1 and CONCEPT2 */ +; /******************************************************************/ + (= (greatest-specialization (Cons $CONCEPT $C) (Cons $EX $E) (Cons $CONCEPT $N)) (greatest-specialization $C $E $N)) -; - - (= - (more-general $CONCEPT1 $CONCEPT2) + (= (more-general $CONCEPT1 $CONCEPT2) (covers $CONCEPT1 $CONCEPT2)) -; - +; /******************************************************************/ +; /* */ +; /* call : more_general(+CONCEPT1,+CONCEPT2) */ +; /* */ +; /* arguments : CONCEPT1 = concept description */ +; /* CONCEPT2 = concept description */ +; /* */ +; /******************************************************************/ +; /* MORE_GENERAL succeeds if CONCEPT1 is more general than CONCEPT2*/ +; /******************************************************************/ - (= - (max Nil Nil) + (= (max Nil Nil) (set-det)) -; - - (= - (max - (Cons $TOP $T) - (Cons $EX $E)) - ( (top $TOP $EX) (max $T $E))) -; - +; /******************************************************************/ +; /* APPLICATION DEPENDENT PREDICATES */ +; /******************************************************************/ +; /* */ +; /* call : max(+CONCEPT,+EXAMPLE) */ +; /* */ +; /* arguments : CONCEPT = concept description */ +; /* EXAMPLE = example */ +; /* */ +; /******************************************************************/ +; /* MAX succeeds if CONCEPT is a most general concept description */ +; /* which covers EXAMPLE */ +; /******************************************************************/ + (= (max (Cons $TOP $T) (Cons $EX $E)) + (top $TOP $EX) + (max $T $E)) ; (error ; (syntax_error operator_expected) @@ -335,28 +471,41 @@ - (= - (isa $X $X) True) -; - - (= - (isa $X $Y) - ( (son $X $Z) (isa $Z $Y))) -; - + (= (isa $X $X) True) +; /******************************************************************/ +; /* */ +; /* call : isa(X,Y) */ +; /* */ +; /* arguments : X = knot of a taxonomy */ +; /* Y = knot of a taxonomy */ +; /* */ +; /******************************************************************/ +; /* Inheritance */ +; /******************************************************************/ + (= (isa $X $Y) + (son $X $Z) + (isa $Z $Y)) - (= - (lge $X1 $X2 $X1) - ( (isa $X2 $X1) (set-det))) -; - + (= (lge $X1 $X2 $X1) + (isa $X2 $X1) + (set-det)) +; /******************************************************************/ +; /* */ +; /* call : lge(X,Y,Z) */ +; /* */ +; /* arguments : X = knot of a taxonomy */ +; /* Y = knot of a taxonomy */ +; /* Z = knot of a taxonomy */ +; /* */ +; /******************************************************************/ +; /* LGE succeeds if Z is least generalization of X and Y in a */ +; /* taxonomy. */ +; /******************************************************************/ - (= - (lge $X1 $X2 $L) - ( (son $X1 $F) (lge $F $X2 $L))) -; - + (= (lge $X1 $X2 $L) + (son $X1 $F) + (lge $F $X2 $L)) ; (error ; (syntax_error operator_expected) @@ -364,65 +513,51 @@ - (= - (gsp $X1 $X2 $G) - ( (son $S $X1) (gsp $S $X2 $G))) -; - + (= (gsp $X1 $X2 $G) + (son $S $X1) + (gsp $S $X2 $G)) - (= - (writeln $X) - ( (display $X) (nl))) -; - + (= (writeln $X) + (display $X) + (nl)) +; /******************************************************************/ +; /* UTILITIES : comments are trivial */ +; /******************************************************************/ - (= - (member $X - (Cons $X $Y)) True) -; - - (= - (member $X - (Cons $Y $Z)) + (= (member $X (Cons $X $Y)) True) + (= (member $X (Cons $Y $Z)) (member $X $Z)) -; - - (= - (append () $X $X) True) -; - - (= - (append - (Cons $X $Y) $Z - (Cons $X $W)) + (= (append () $X $X) True) + (= (append (Cons $X $Y) $Z (Cons $X $W)) (append $Y $Z $W)) -; - - (= - (setofnil $X $Y $Z) - ( (setof $X $Y $Z) (set-det))) -; - - (= - (setofnil $X $Y ()) True) -; - + (= (setofnil $X $Y $Z) + (setof $X $Y $Z) + (set-det)) +; /******************************************************************/ +; /* */ +; /* call : setofnil(-X,+Y,-Z) */ +; /* */ +; /* arguments : X = variable */ +; /* Y = relational expression */ +; /* Z = list */ +; /* */ +; /******************************************************************/ +; /* SETOFNIL succeeds if Z lists all possible instantiations of X */ +; /* for which Y is true. A^B means existential quantification. */ +; /******************************************************************/ + (= (setofnil $X $Y ()) True) - (= - (help) - ( (write ' Start VS with command: learn.') (nl))) -; - + (= (help) + (write ' Start VS with command: learn.') + (nl)) !(help *) -; - diff --git a/vs/vs_1.metta b/vs/vs_1.metta index a08cb06..000f983 100644 --- a/vs/vs_1.metta +++ b/vs/vs_1.metta @@ -1,82 +1,26 @@ - - (= - (son mono color) True) -; - - (= - (son poly color) True) -; - - (= - (son red mono) True) -; - - (= - (son blue mono) True) -; - - (= - (son white mono) True) -; - - (= - (son black mono) True) -; - - (= - (son orange poly) True) -; - - (= - (son pink poly) True) -; - +; (convert_to_metta_file vs_1 $_139518 vs/vs_1.pl vs/vs_1.metta) + + (= (son mono color) True) +; /******************************************************************/ +; /* AN EXAMPLE TAXONOMY */ +; /******************************************************************/ + (= (son poly color) True) + (= (son red mono) True) + (= (son blue mono) True) + (= (son white mono) True) + (= (son black mono) True) + (= (son orange poly) True) + (= (son pink poly) True) - (= - (son polygon shape) True) -; - - (= - (son oval shape) True) -; - - (= - (son - (- 3 sided) polygon) True) -; - - (= - (son - (- 4 sided) polygon) True) -; - - (= - (son triangle - (- 3 sided)) True) -; - - (= - (son rectangle - (- 4 sided)) True) -; - - (= - (son square - (- 4 sided)) True) -; - - (= - (son trapezoid - (- 4 sided)) True) -; - - (= - (son circle oval) True) -; - - (= - (son ellipse oval) True) -; - + (= (son polygon shape) True) + (= (son oval shape) True) + (= (son (- 3 sided) polygon) True) + (= (son (- 4 sided) polygon) True) + (= (son triangle (- 3 sided)) True) + (= (son rectangle (- 4 sided)) True) + (= (son square (- 4 sided)) True) + (= (son trapezoid (- 4 sided)) True) + (= (son circle oval) True) + (= (son ellipse oval) True)