diff --git a/tests/zebra/README.md b/tests/zebra/README.md new file mode 100644 index 00000000000..ed16a3ee10c --- /dev/null +++ b/tests/zebra/README.md @@ -0,0 +1,44 @@ + +``` +deb12user@GODLIKE:~/metta-wam/tests/zebra$ time mettalog fish_riddle_2_no_states.metta +!(include dv-pl) + +Deterministic: () +!(query &self (because red house keeps dogs the $norwegian is the fish owner)) + +Deterministic: (Succeed ((quote (because red house keeps dogs the norwegian is the fish owner)))) +!(query &self (because blue house keeps dogs the $brit is the fish owner)) + +Deterministic: (Succeed ((quote (because blue house keeps dogs the brit is the fish owner)))) +!(query &self (because red house keeps cats the $norwegian is the fish owner)) + +Deterministic: (Succeed ((quote (because red house keeps cats the norwegian is the fish owner)))) +% 4,329,368 inferences, 0.375 CPU in 0.377 seconds (100% CPU, 11540291 Lips) + +[()] + +[(Succeed ((quote (because red house keeps dogs the norwegian is the fish owner))))] + +[(Succeed ((quote (because blue house keeps dogs the brit is the fish owner))))] + +[(Succeed ((quote (because red house keeps cats the norwegian is the fish owner))))] +; DEBUG Exit code of METTA_CMD: 7 + +real 0m3.445s +user 0m3.356s +sys 0m0.106s +``` + +``` +(venv) deb12user@GODLIKE:~/metta-wam/tests/zebra$ time metta fish_riddle_2_no_states.metta +[(Succeed ((quote (because red house keeps dogs the norwegian is the fish owner)) (quote (because red house keeps dogs the norwegian is the fish owner))))] +[(Succeed ((quote (because blue house keeps dogs the brit is the fish owner)) (quote (because blue house keeps dogs the brit is the fish owner))))] +[(Succeed ((quote (because red house keeps cats the norwegian is the fish owner)) (quote (because red house keeps cats the norwegian is the fish owner))))] + +real 2m52.320s +user 2m52.054s +sys 0m0.260s + +``` + + diff --git a/tests/zebra/bec.metta b/tests/zebra/bec.metta deleted file mode 100644 index aff5ed5a36f..00000000000 --- a/tests/zebra/bec.metta +++ /dev/null @@ -1,63 +0,0 @@ -;; Basic event calculus axioms without constraints - - -; (= (tp-domain! $max-tp) ( -; (if (== $max-tp 0) -; (add-atom &self (tp 0)) -; (let () (add-atom &self (tp $max-tp)) -; (tp-domain! (- $max-tp 1))) -; ) -; )) - -((stoppedIn $t1 $f $t2) :- ( - (tp $t1) (tp $t2) - (bool (< $t1 $t)) - (bool (< $t $t2)) - (terminates $e $f $t) - (happens $e $t) -)) - -((stoppedIn $t1 $f $t2) :- ( - (tp $t1) (tp $t2) - (bool (< $t1 $t)) - (bool (< $t $t2)) - (releases $e $f $t) - (happens $e $t) -)) - -((holdsAt $f2 $t2) :- ( - (tp $t2) (tp $t1) - (initiates $e $f1 $t1) - (happens $e $t1) - (naf (stoppedIn $t1 $f1 $t2)) -)) - -((holdsAt $f $t) :- ( - (tp $t) - (bool (< 0 $t)) - (initiallyP $f) - (naf (stoppedIn 0 $f $t)) -)) - -((-holdsAt $f $t) :- ( - (tp $t) - (bool (< 0 $t)) - (initiallyN $f) - (naf (startedIn 0 $f $t)) -)) - -((holdsAt $f $t2) :- ( - (tp $t2) (tp $t1) - (bool (< $t1 $t2)) - (initiates $e $f $t1) - (happens $e $t1) - (naf (stoppedIn $t1 $f $t2)) -)) - -((-holdsAt $f $t2) :- ( - (tp $t1) (tp $t2) - (bool (< $t1 $t2)) - (terminates $e $f $t1) - (happens $e $t1) - (naf (startedIn $t1 $f $t2)) -)) \ No newline at end of file diff --git a/tests/zebra/dv-pl.metta b/tests/zebra/dv-pl.metta new file mode 100644 index 00000000000..f091e19da1d --- /dev/null +++ b/tests/zebra/dv-pl.metta @@ -0,0 +1,266 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Backward chaining logic +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;!(import! &self dv-pl) +;; Predicate signatures for backward chaining logic +(: cur= (-> Atom Atom)) ; Current goal +(: retVal= (-> Atom Atom)) ; Return value +(: goal= (-> Atom Atom)) ; Final goal + +;; Interface for backward chaining (quotes the arguement) +(: backward-chain (-> Atom Atom Atom Atom Atom)) +(= (backward-chain $info $goal $kb $rb) + (backward-chain-q $info (quote $goal) $kb $rb)) + +;; Handle specific cases during backward chaining +(: backward-chain-q (-> Atom Atom Atom Atom Atom)) +(= (backward-chain-q $info (quote $goal) $kb $rb) + (case (quote $goal) ( + ((quote (is $a $b)) (let $a $b (quote $goal))) ; Assignment + ((quote (bool $expr)) (if $expr (quote $goal) (empty))) ; Boolean evaluation + ((quote (eval= $a $expr)) (let $a $expr (quote $goal))) ; Expression evaluation + ((quote (nonvar $var)) (if (== Variable (get-metatype $var)) (empty) (quote $goal))) ; Non-variable check + ((quote (var $var)) (if (== Variable (get-metatype $var)) (quote $goal) (empty))) ; Variable check + ((quote (true)) (quote $goal)) ; Always succeeds + ((quote (fail)) (empty)) ; Always fails + ((quote (cut $signal)) (if (equalz $info $signal) (quote $goal) (quote $goal))) ; Cut operator for pruning + ((quote (naf $expr)) (if (has-match $kb $expr) (empty) (quote $goal))) ; Negation as failure + ((quote (qnaf $expr)) (let (Failed $_1) (backward-chain $info2 $expr $kb $rb) (quote $goal))) ; Negation as failure at query level + ($_2 (backward-chain-q2 $info (quote $goal) $kb $rb)) ; Match against knowledge base + ))) + +(= (backward-chain-q2 $info (quote $goal) $kb $rb) + (match $kb $goal (quote $goal))) +;; Recursive case for backward chaining +(= (backward-chain-q2 $old_info (quote $goal) $kb $rb) + (function + (return ;; if $info is bound that means a clause has called a cut (thus we return empty) + (if (== Variable (get-metatype $old_info)) + (let $r (match $rb ($goal :- $body) + (match-body $info $body $kb $rb $goal)) + (if (== Variable (get-metatype $info)) ;; if not cut + $r ;; then return normal + (return $r))) ;; else return early + (empty))))) + + +;; Match predicate: checks if a goal has at least one match in a space +;; This is less efficient, as it processes the entire space to find matches +(: has-match (-> Atom Atom Bool)) +(= (has-match $space $g) + (let $m (collapse (match $space $g True)) ; Attempt to match $g in $space + (if (== $m ()) ; If no match is found + False ; Return False + True ; Otherwise, return True + ) + ) +) + +;; Predicate to check if a function definition exists in a given space +(= (has-fundef $space $g) + (let $m (collapse (match $space (= $g $_1) True)) ; Match $g as a function in $space + (if (== $m ()) ; If no match is found + False ; Return False + True ; Otherwise, return True + ) + ) +) + +;; Chain through each element in the body and return the goal +(: match-body (-> Atom Atom Atom Atom Atom Atom)) +(= (match-body $info $body $kb $rb $goal) + (if (== $body ()) + (quote $goal) ; Base case: no more elements to match + (let* ( + (($cur $rest) (decons-atom $body)) ; Deconstruct body + ($debugging False) ;; Print debug or not + ($bugcheck False) ;; Catch a bug where we dont return the quoted goals + (() (if $debugging (println! (quote (IN (cur= $cur) (goal= $goal)))) ())) ; Debugging: log input + ($_12 (if $bugcheck + (let* (($retVal (backward-chain $info $cur $kb $rb)) ; Recursive chaining + ($m (collapse (equalz (quote $cur) $retVal))) ; Check match + (() (if (== $m ()) (println! (quote (BAD!!!!!!!! (cur= $cur) (retVal= $retVal))) ()))) + ) ()) ())) + ((quote $cur) (backward-chain $info $cur $kb $rb)) ; Recursive chaining + (() (if $debugging (println! (quote (OUT (cur= $cur) (goal= $goal)))) ())) ; Debugging: log output + ) + (match-body $info $rest $kb $rb $goal) ; Continue matching + ) + ) +) + + +;; Predicate for general atom equality +(: equalz (-> Atom Atom Bool)) ; Compares two atoms +(= (equalz $A $A) True) ; Atoms are equal if they are identical + +(: quote-equalz (-> Atom Atom Bool)) +(= (quote-equalz $A $A) True) +(= (quote-equalz $A $B) (equalz (quote $A) $B)) +(= (quote-equalz $A $B) (equalz $A (quote $B))) + +(: is-equals (-> %Undefined %Undefined% Bool)) ; Compares two atoms +(: is-equals (-> $t $t Bool)) ; Compares two things +(= (is-equals $A $A) True) ; Atoms are equal if they are identical + +;; Define natural numbers using Zero (Z) and Successor (S) +(: Z Nat) ; Base case for natural numbers (0) +(: S (-> Nat Nat)) ; Successor function for incrementing natural numbers + +;; Predicate for natural number equality +(: nat-equal (-> Nat Nat Bool)) ; Compares two natural numbers +(= (nat-equal $A $A) True) ; Two numbers are equal if they are identical + + +;; Query execution logic +(: query (-> Atom Atom Atom)) +(= (query $kb $goal) + (let $m (collapse (backward-chain $info $goal $kb $kb)) + (if (== $m ()) (Failed (quote $goal)) (Succeed $m))) +) + +(: query-f (-> Atom Atom Atom)) +(= (query-f $kb $goal) + (let $m (collapse (backward-chain $info $goal $kb $kb)) + (if (== $m ()) Passed-Negation (Failed $m))) +) + + +;!(equalz $a (+ 1 1)) +;!(is-equals 2 (+ 1 1)) +;!(is-equals $b (+ 1 1)) + + +;; Predicate: Check if an element is a member of a list +(member $Elem ($Cons $Elem $_1)) ; Base case: element found +((member $Elem ($Cons $_1 $Tail)) :- + ((member $Elem $Tail))) ; Recursive case: continue checking + + +;; Zero-based natural number indexing in lists +(nat-nth Z ($Cons $Elem $_1) $Elem) ; Base case: first element +((nat-nth (S $N) ($Cons $_1 $Rest) $Elem) :- + ((nat-nth $N $Rest $Elem))) ; Recursive case: move to next element + +;; Append two lists +(cons-append Nil $List2 $List2) ; Base case: append empty list +((cons-append ($Cons $H $T) $List2 ($Cons $H $T2)) :- + ((cons-append $T $List2 $T2))) ; Recursive case: append remaining elements + +;; Predicate to check equality of two values +(same $x $x) + +;; Predicate to get the last element of a list +(last $x ($Cons $x Nil)) ; Base case: last element +((last $x ($Cons $_1 $rest)) :- + ((last $x $rest))) ; Recursive case: move to next element + +;; Calculate length of a list +(length Nil 0) ; Base case: empty list has length 0 +((length ($Cons $_1 $rest) $out) :- + ((length $rest $out2) + (is $out (+ $out2 1)))) ; Recursive case: increment length + +;; Calculate sum of natural numbers from 0 to $n +(sum 0 0) ; Base case: sum to 0 is 0 +((sum $n $s) :- ( + (bool (> $n 0)) ; Ensure $n is positive + (is $n1 (- $n 1)) ; Decrement $n + (sum $n1 $s1) ; Calculate sum for smaller range + (is $s (+ $n $s1)))) ; Add $n to sum of smaller range + +;; Predicate to append lists +(append Nil $L $L) ; Base case: appending an empty list +((append ($Cons $H $T) $L ($Cons $H $R)) :- ( + (append $T $L $R) ; Recursive case: append remaining elements +)) + + + +;; Negation as failure test +((bachelor $x) :- ( + (man $x) ; $x must be a man + (naf (married $x)) ; $x must not be married +)) + +; Facts: Men and marital status +(man John) (man Tim) +(married Tim) + +;; Predicate to define a woman +((woman $x) :- ( + (naf (man $x)) ; $x is a woman if not a man +)) + +;;;;;;;;;;;;;;;;; +;; TEST Queries ;; +;;;;;;;;;;;;;;;;; + +(: traced-eval (-> Atom Atom)) +(= (traced-eval $arg) (traced-eval-q (quote $arg))) +(: traced-eval-q (-> Expression Atom)) +(= (traced-eval-q (quote $arg)) + (let* ( + (() (println! (quote (====>EVAL $arg)))) + ($r $arg) + (() (println! (quote (RET<=== $r))))) + $r)) + +(: progn (-> Atom Atom)) +(= (progn $body) (progn-q (quote $body))) +(: progn-q (-> Expression Atom)) +(= (progn-q (quote $body)) + (if (== (quote $body) (quote ())) () + (let* ( + (($head $rest) (decons-atom $body)) ; Deconstruct body + ($r (traced-eval-q (quote $head)))) + (if (== (quote $rest) (quote ())) + $r (progn-q (quote $rest)))))) + +(= (test_normal_queries $kb) + + (progn-q (quote ( + +; Query for the last element in a list + (query $kb (last $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) + +; Query for the length of a list + (query $kb (length ($Cons 1 ($Cons 2 ($Cons 3 Nil))) $out)) + +; Query for the sum of numbers up to 3 + (query $kb (sum 3 $x)) + +; Query for appending lists + (query $kb (append ($Cons 1 ($Cons 2 Nil)) ($Cons 3 ($Cons 4 Nil)) $x)) + (query $kb (append ($Cons 1 ($Cons 2 Nil)) $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) + (query $kb (append $What $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) + +;; Test list operations + (query $kb (append ($Cons 1 Nil) ($Cons 2 ($Cons 3 Nil)) $Result)) ; Appending lists + (query $kb (append ($Cons 1 ($Cons 2 Nil)) $Rest ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) ; Partial list append + +;; Negation as failure tests with bachelors and marital status + (query $kb (bachelor $x)) ; Finds bachelors who are not married + (query-f $kb (woman Tim)) ; Tests failure for a man labeled as a woman + (query $kb (woman Jane)) ; Should succeed for Jane if defined as a woman + (query-f $kb (woman $x)) ; Negative query for undefined women + +;; Check if an element is a member of a list + (query $kb (member 3 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ; Should succeed + (query-f $kb (member 5 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ; Should fail, 5 is not in the list + (query $kb (member $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ; Should find members one by one + +;; Query for basic arithmetic + (query $kb (is $x (+ 1 1))) ; $x should be assigned 2 + +;; Query for natural number indexing + (query $kb (nat-nth (S (S Z)) (SomethingAtThird $1 $2) Third)) ; Should find the third element + +)))) + +;!(import! &self dv-pl) +; !(test_normal_queries) +; !(test_normal_queries) + + + diff --git a/tests/zebra/fish_riddle_1_no_states.metta b/tests/zebra/fish_riddle_1_no_states.metta index d33efb8a978..d8fd875f0c8 100644 --- a/tests/zebra/fish_riddle_1_no_states.metta +++ b/tests/zebra/fish_riddle_1_no_states.metta @@ -1,7 +1,11 @@ - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Backward chaining logic ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;!(import! &self dv-pl) +;; Predicate signatures for backward chaining logic +(: cur= (-> Atom Atom)) ; Current goal +(: retVal= (-> Atom Atom)) ; Return value +(: goal= (-> Atom Atom)) ; Final goal ;; Interface for backward chaining (quotes the arguement) (: backward-chain (-> Atom Atom Atom Atom Atom)) @@ -16,26 +20,29 @@ ((quote (bool $expr)) (if $expr (quote $goal) (empty))) ; Boolean evaluation ((quote (eval= $a $expr)) (let $a $expr (quote $goal))) ; Expression evaluation ((quote (nonvar $var)) (if (== Variable (get-metatype $var)) (empty) (quote $goal))) ; Non-variable check - ((quote (var $var)) (if (== Variable (get-metatype $var)) (quote $goal) (empty))) ; Variable check + ((quote (var $var)) (if (== Variable (get-metatype $var)) (quote $goal) (empty))) ; Variable check ((quote (true)) (quote $goal)) ; Always succeeds ((quote (fail)) (empty)) ; Always fails - ((quote (cut $signal)) (if (equalz $info $signal) (quote $goal) (quote $goal))) ; Cut operator for pruning + ((quote (cut $signal)) (if (equalz $info $signal) (quote $goal) (quote $goal))) ; Cut operator for pruning ((quote (naf $expr)) (if (has-match $kb $expr) (empty) (quote $goal))) ; Negation as failure - ((quote (qnaf $expr)) (let (Failed $_) (backward-chain $info2 $expr $kb $rb) (quote $goal))) ; Negation as failure at query level - ($_ (match $kb $goal (quote $goal))) ; Match against knowledge base + ((quote (qnaf $expr)) (let (Failed $_1) (backward-chain $info2 $expr $kb $rb) (quote $goal))) ; Negation as failure at query level + ($_2 (backward-chain-q2 $info (quote $goal) $kb $rb)) ; Match against knowledge base ))) +(= (backward-chain-q2 $info (quote $goal) $kb $rb) + (match $kb $goal (quote $goal))) ;; Recursive case for backward chaining -(= (backward-chain-q $info (quote $goal) $kb $rb) +(= (backward-chain-q2 $old_info (quote $goal) $kb $rb) (function - (return ;; if $info is bound that means a clause has called a cut (thus we return empty) - (if (== Variable (get-metatype $info)) - (let $res (match $rb ($goal :- $body) - (match-body $info $body $kb $rb $goal)) - (if (== Variable (get-metatype $info)) ;; if not cut - $res ;; then return normal - (return $res))) ;; else return early - (empty))))) + (return ;; if $info is bound that means a clause has called a cut (thus we return empty) + (if (== Variable (get-metatype $old_info)) + (let $r (match $rb ($goal :- $body) + (match-body $info $body $kb $rb $goal)) + (if (== Variable (get-metatype $info)) ;; if not cut + $r ;; then return normal + (return $r))) ;; else return early + (empty))))) + ;; Match predicate: checks if a goal has at least one match in a space ;; This is less efficient, as it processes the entire space to find matches @@ -49,50 +56,212 @@ ) ) +;; Predicate to check if a function definition exists in a given space +(= (has-fundef $space $g) + (let $m (collapse (match $space (= $g $_1) True)) ; Match $g as a function in $space + (if (== $m ()) ; If no match is found + False ; Return False + True ; Otherwise, return True + ) + ) +) + ;; Chain through each element in the body and return the goal (: match-body (-> Atom Atom Atom Atom Atom Atom)) (= (match-body $info $body $kb $rb $goal) (if (== $body ()) (quote $goal) ; Base case: no more elements to match (let* ( - (($cur $rest) (decons-atom $body)) ; Deconstruct body - ($debugging True) ;; Print debug or not - ($bugcheck False) ;; Catch a bug where we dont return the quoted goals + (($cur $rest) (decons-atom $body)) ; Deconstruct body + ($debugging False) ;; Print debug or not + ($bugcheck False) ;; Catch a bug where we dont return the quoted goals (() (if $debugging (println! (quote (IN (cur= $cur) (goal= $goal)))) ())) ; Debugging: log input - ($_ (if $bugcheck + ($_12 (if $bugcheck (let* (($retVal (backward-chain $info $cur $kb $rb)) ; Recursive chaining ($m (collapse (equalz (quote $cur) $retVal))) ; Check match (() (if (== $m ()) (println! (quote (BAD!!!!!!!! (cur= $cur) (retVal= $retVal))) ()))) ) ()) ())) - ((quote $cur) (backward-chain $info $cur $kb $rb)) ; Recursive chaining + ((quote $cur) (backward-chain $info $cur $kb $rb)) ; Recursive chaining (() (if $debugging (println! (quote (OUT (cur= $cur) (goal= $goal)))) ())) ; Debugging: log output - ) + ) (match-body $info $rest $kb $rb $goal) ; Continue matching ) - ) + ) ) -;; Query execution logic -(: query (-> Atom Atom)) -(= (query $goal) - (let $m (collapse (backward-chain $info $goal &self &self)) - (if (== $m ()) (Failed (quote $goal)) (Succeed $m))) -) ;; Predicate for general atom equality (: equalz (-> Atom Atom Bool)) ; Compares two atoms (= (equalz $A $A) True) ; Atoms are equal if they are identical -(same $x $x) +(: quote-equalz (-> Atom Atom Bool)) +(= (quote-equalz $A $A) True) +(= (quote-equalz $A $B) (equalz (quote $A) $B)) +(= (quote-equalz $A $B) (equalz $A (quote $B))) + +(: is-equals (-> %Undefined %Undefined% Bool)) ; Compares two atoms +(: is-equals (-> $t $t Bool)) ; Compares two things +(= (is-equals $A $A) True) ; Atoms are equal if they are identical + +;; Define natural numbers using Zero (Z) and Successor (S) +(: Z Nat) ; Base case for natural numbers (0) +(: S (-> Nat Nat)) ; Successor function for incrementing natural numbers + +;; Predicate for natural number equality +(: nat-equal (-> Nat Nat Bool)) ; Compares two natural numbers +(= (nat-equal $A $A) True) ; Two numbers are equal if they are identical + + +;; Query execution logic +(: query (-> Atom Atom Atom)) +(= (query $kb $goal) + (let $m (collapse (backward-chain $info $goal $kb $kb)) + (if (== $m ()) (Failed (quote $goal)) (Succeed $m))) +) + +(: query-f (-> Atom Atom Atom)) +(= (query-f $kb $goal) + (let $m (collapse (backward-chain $info $goal $kb $kb)) + (if (== $m ()) Passed-Negation (Failed $m))) +) + + +;!(equalz $a (+ 1 1)) +;!(is-equals 2 (+ 1 1)) +;!(is-equals $b (+ 1 1)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; End VU/Douglas Backchainer -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Predicate: Check if an element is a member of a list -(member $Elem ($Cons $Elem $_)) ; Base case: element found -((member $Elem ($Cons $Nonvar $Tail)) :- - ( (nonvar $Nonvar) (member $Elem $Tail))) ; Recursive case: continue checking +(member $Elem ($Cons $Elem $_1)) ; Base case: element found +((member $Elem ($Cons $_1 $Tail)) :- + ((member $Elem $Tail))) ; Recursive case: continue checking + + +;; Zero-based natural number indexing in lists +(nat-nth Z ($Cons $Elem $_1) $Elem) ; Base case: first element +((nat-nth (S $N) ($Cons $_1 $Rest) $Elem) :- + ((nat-nth $N $Rest $Elem))) ; Recursive case: move to next element + +;; Append two lists +(cons-append Nil $List2 $List2) ; Base case: append empty list +((cons-append ($Cons $H $T) $List2 ($Cons $H $T2)) :- + ((cons-append $T $List2 $T2))) ; Recursive case: append remaining elements + +;; Predicate to check equality of two values +(same $x $x) + +;; Predicate to get the last element of a list +(last $x ($Cons $x Nil)) ; Base case: last element +((last $x ($Cons $_1 $rest)) :- + ((last $x $rest))) ; Recursive case: move to next element + +;; Calculate length of a list +(length Nil 0) ; Base case: empty list has length 0 +((length ($Cons $_1 $rest) $out) :- + ((length $rest $out2) + (is $out (+ $out2 1)))) ; Recursive case: increment length + +;; Calculate sum of natural numbers from 0 to $n +(sum 0 0) ; Base case: sum to 0 is 0 +((sum $n $s) :- ( + (bool (> $n 0)) ; Ensure $n is positive + (is $n1 (- $n 1)) ; Decrement $n + (sum $n1 $s1) ; Calculate sum for smaller range + (is $s (+ $n $s1)))) ; Add $n to sum of smaller range + +;; Predicate to append lists +(append Nil $L $L) ; Base case: appending an empty list +((append ($Cons $H $T) $L ($Cons $H $R)) :- ( + (append $T $L $R) ; Recursive case: append remaining elements +)) + + + +;; Negation as failure test +((bachelor $x) :- ( + (man $x) ; $x must be a man + (naf (married $x)) ; $x must not be married +)) + +; Facts: Men and marital status +(man John) (man Tim) +(married Tim) + +;; Predicate to define a woman +((woman $x) :- ( + (naf (man $x)) ; $x is a woman if not a man +)) + +;;;;;;;;;;;;;;;;; +;; TEST Queries ;; +;;;;;;;;;;;;;;;;; + +(: traced-eval (-> Atom Atom)) +(= (traced-eval $arg) (traced-eval-q (quote $arg))) +(: traced-eval-q (-> Expression Atom)) +(= (traced-eval-q (quote $arg)) + (let* ( + (() (println! (quote (====>EVAL $arg)))) + ($r $arg) + (() (println! (quote (RET<=== $r))))) + $r)) + +(: progn (-> Atom Atom)) +(= (progn $body) (progn-q (quote $body))) +(: progn-q (-> Expression Atom)) +(= (progn-q (quote $body)) + (if (== (quote $body) (quote ())) () + (let* ( + (($head $rest) (decons-atom $body)) ; Deconstruct body + ($r (traced-eval-q (quote $head)))) + (if (== (quote $rest) (quote ())) + $r (progn-q (quote $rest)))))) + +(= (test_normal_queries $kb) + + (progn-q (quote ( + +; Query for the last element in a list + (query $kb (last $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) + +; Query for the length of a list + (query $kb (length ($Cons 1 ($Cons 2 ($Cons 3 Nil))) $out)) + +; Query for the sum of numbers up to 3 + (query $kb (sum 3 $x)) + +; Query for appending lists + (query $kb (append ($Cons 1 ($Cons 2 Nil)) ($Cons 3 ($Cons 4 Nil)) $x)) + (query $kb (append ($Cons 1 ($Cons 2 Nil)) $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) + (query $kb (append $What $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) + +;; Test list operations + (query $kb (append ($Cons 1 Nil) ($Cons 2 ($Cons 3 Nil)) $Result)) ; Appending lists + (query $kb (append ($Cons 1 ($Cons 2 Nil)) $Rest ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) ; Partial list append + +;; Negation as failure tests with bachelors and marital status + (query $kb (bachelor $x)) ; Finds bachelors who are not married + (query-f $kb (woman Tim)) ; Tests failure for a man labeled as a woman + (query $kb (woman Jane)) ; Should succeed for Jane if defined as a woman + (query-f $kb (woman $x)) ; Negative query for undefined women + +;; Check if an element is a member of a list + (query $kb (member 3 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ; Should succeed + (query-f $kb (member 5 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ; Should fail, 5 is not in the list + (query $kb (member $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ; Should find members one by one + +;; Query for basic arithmetic + (query $kb (is $x (+ 1 1))) ; $x should be assigned 2 + +;; Query for natural number indexing + (query $kb (nat-nth (S (S Z)) (SomethingAtThird $1 $2) Third)) ; Should find the third element + +)))) + + +;!(import! &self dv-pl) +;!(test_normal_queries) +;!(test_normal_queries) ((because $color house keeps $other the $nationality is the $type owner) :- ((same $Houses @@ -115,12 +284,13 @@ ; Determine the $nationality of owns the $type (member ( $_31 $nationality $_32 $_33 $type $_34) $Houses))) -;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;; ;; TEST Queries ;; -;;;;;;;;;;;;;;;;; -!(query (because red house keeps dogs the $norwegian is the fish owner)) +;;;;;;;;;;;;;;;;;; + +!(query &self (because red house keeps dogs the $norwegian is the fish owner)) -!(query (because blue house keeps dogs the $brit is the fish owner)) +!(query &self (because blue house keeps dogs the $brit is the fish owner)) -!(query (because red house keeps cats the $norwegian is the fish owner)) +!(query &self (because red house keeps cats the $norwegian is the fish owner)) diff --git a/tests/zebra/fish_riddle_2_no_states.metta b/tests/zebra/fish_riddle_2_no_states.metta index ac16991923d..6a297e9a40e 100644 --- a/tests/zebra/fish_riddle_2_no_states.metta +++ b/tests/zebra/fish_riddle_2_no_states.metta @@ -1,95 +1,19 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Backward chaining logic -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Interface for backward chaining (quotes the arguement) -(: backward-chain (-> Atom Atom Atom Atom Atom)) -(= (backward-chain $info $goal $kb $rb) - (backward-chain-q $info (quote $goal) $kb $rb)) - -;; Handle specific cases during backward chaining -(: backward-chain-q (-> Atom Atom Atom Atom Atom)) -(= (backward-chain-q $info (quote $goal) $kb $rb) - (case (quote $goal) ( - ((quote (is $a $b)) (let $a $b (quote $goal))) ; Assignment - ((quote (bool $expr)) (if $expr (quote $goal) (empty))) ; Boolean evaluation - ((quote (eval= $a $expr)) (let $a $expr (quote $goal))) ; Expression evaluation - ((quote (nonvar $var)) (if (== Variable (get-metatype $var)) (empty) (quote $goal))) ; Non-variable check - ((quote (var $var)) (if (== Variable (get-metatype $var)) (quote $goal) (empty))) ; Variable check - ((quote (true)) (quote $goal)) ; Always succeeds - ((quote (fail)) (empty)) ; Always fails - ((quote (cut $signal)) (if (equalz $info $signal) (quote $goal) (quote $goal))) ; Cut operator for pruning - ((quote (naf $expr)) (if (has-match $kb $expr) (empty) (quote $goal))) ; Negation as failure - ((quote (qnaf $expr)) (let (Failed $_) (backward-chain $info2 $expr $kb $rb) (quote $goal))) ; Negation as failure at query level - ($_ (match $kb $goal (quote $goal))) ; Match against knowledge base - ))) - -;; Recursive case for backward chaining -(= (backward-chain-q $info (quote $goal) $kb $rb) - (function - (return ;; if $info is bound that means a clause has called a cut (thus we return empty) - (if (== Variable (get-metatype $info)) - (let $res (match $rb ($goal :- $body) - (match-body $info $body $kb $rb $goal)) - (if (== Variable (get-metatype $info)) ;; if not cut - $res ;; then return normal - (return $res))) ;; else return early - (empty))))) - -;; Match predicate: checks if a goal has at least one match in a space -;; This is less efficient, as it processes the entire space to find matches -(: has-match (-> Atom Atom Bool)) -(= (has-match $space $g) - (let $m (collapse (match $space $g True)) ; Attempt to match $g in $space - (if (== $m ()) ; If no match is found - False ; Return False - True ; Otherwise, return True - ) - ) -) - -;; Chain through each element in the body and return the goal -(: match-body (-> Atom Atom Atom Atom Atom Atom)) -(= (match-body $info $body $kb $rb $goal) - (if (== $body ()) - (quote $goal) ; Base case: no more elements to match - (let* ( - (($cur $rest) (decons-atom $body)) ; Deconstruct body - ;(() (println! (IN (cur= $cur) (goal= $goal)))) ; Debugging: log input - ;($retVal (backward-chain $info $cur $kb $rb)) ; Recursive chaining - ;($m (collapse (equalz (quote $cur) $retVal))) ; Check match - ;(() (if (== $m ()) (println! (BAD!!!!!!!! (cur= $cur) (retVal= $retVal))) ())) - ;((quote $cur) $retVal) ; Unify variables - ((quote $cur) (backward-chain $info $cur $kb $rb)) ; Recursive chaining - ;(() (println! (OUT (cur= $cur) (goal= $goal)))) ; Debugging: log output - ) - (match-body $info $rest $kb $rb $goal) ; Continue matching - ) - ) -) - -;; Query execution logic -(: query (-> Atom Atom)) -(= (query $goal) - (let $m (collapse (backward-chain $info $goal &self &self)) - (if (== $m ()) (Failed (quote $goal)) (Succeed $m))) -) - -;; Predicate for general atom equality -(: equalz (-> Atom Atom Bool)) ; Compares two atoms -(= (equalz $A $A) True) ; Atoms are equal if they are identical - -(same $x $x) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; End VU/Douglas Backchainer -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Predicate: Check if an element is a member of a list -(member $Elem ($Cons $Elem $_)) ; Base case: element found -((member $Elem ($Cons $Nonvar $Tail)) :- - ( (nonvar $Nonvar) (member $Elem $Tail))) ; Recursive case: continue checking + + + + + + +; !(include dv-pl) ; why does include work but not import in H-E? +!(import! &self dv-pl) +; !(test_normal_queries) +; !(test_normal_queries) + + +;;;;;;;;;;;;;;;;;; +;; TEST Queries ;; +;;;;;;;;;;;;;;;;;; ((because $color house keeps $other the $nationality is the $type owner) :- ((same $Houses @@ -112,12 +36,15 @@ ; Determine the $nationality of owns the $type (member ( $_31 $nationality $_32 $_33 $type $_34) $Houses))) -;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;; ;; TEST Queries ;; -;;;;;;;;;;;;;;;;; -!(query (because red house keeps dogs the $norwegian is the fish owner)) +;;;;;;;;;;;;;;;;;; + +!(query &self (because red house keeps dogs the $norwegian is the fish owner)) + +!(query &self (because blue house keeps dogs the $brit is the fish owner)) + +!(query &self (because red house keeps cats the $norwegian is the fish owner)) -!(query (because blue house keeps dogs the $brit is the fish owner)) -!(query (because red house keeps cats the $norwegian is the fish owner)) diff --git a/tests/zebra/fish_riddle_3_no_states.metta b/tests/zebra/fish_riddle_3_no_states.metta new file mode 100644 index 00000000000..3e979fbc306 --- /dev/null +++ b/tests/zebra/fish_riddle_3_no_states.metta @@ -0,0 +1,50 @@ + + + + + + + +!(include dv-pl) ; why does include work but not import in H-E? +;!(import! &self dv-pl) +;!(test_normal_queries) +;!(test_normal_queries) + + +;;;;;;;;;;;;;;;;;; +;; TEST Queries ;; +;;;;;;;;;;;;;;;;;; + +((because $color house keeps $other the $nationality is the $type owner) :- + ((same $Houses + (Cons ( 1 $_1 $_2 $_3 $_4 $_5) ; First house + (Cons ( 2 $_6 $_7 $_8 $_9 $_10) ; Second house + $Open))) + + ;(same $Open Nil) + + ; Clue 1: The Norwegian lives in the first house + (member ( 1 norwegian $_11 $_12 $_13 $_14) $Houses) + ; Clue 2: The Brit lives in the red house + (member ( $_15 brit red $_16 $_17 $_18) $Houses) + ; Clue 3: The owner of the blue house drinks tea + (member ( $_19 $_20 blue tea $_21 $_22) $Houses) + ; Clue 4: The owner of the red house keeps $other + (member ( $_23 $_24 $color $_25 $other $_26) $Houses) + ; Clue 5: The owner of the tea-drinking house smokes Prince + (member ( $_27 $_28 $_29 tea $_30 prince) $Houses) + ; Determine the $nationality of owns the $type + (member ( $_31 $nationality $_32 $_33 $type $_34) $Houses))) + +;;;;;;;;;;;;;;;;;; +;; TEST Queries ;; +;;;;;;;;;;;;;;;;;; + +!(query &self (because red house keeps dogs the $norwegian is the fish owner)) + +!(query &self (because blue house keeps dogs the $brit is the fish owner)) + +!(query &self (because red house keeps cats the $norwegian is the fish owner)) + + + diff --git a/tests/zebra/fish_riddle_5_no_states.metta b/tests/zebra/fish_riddle_5_no_states.metta deleted file mode 100644 index 0d70bf82635..00000000000 --- a/tests/zebra/fish_riddle_5_no_states.metta +++ /dev/null @@ -1,113 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Backward chaining logic -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Interface for backward chaining (quotes the arguement) -(: backward-chain (-> Atom Atom Atom Atom Atom)) -(= (backward-chain $info $goal $kb $rb) - (backward-chain-q $info (quote $goal) $kb $rb)) - -;; Handle specific cases during backward chaining -(: backward-chain-q (-> Atom Atom Atom Atom Atom)) -(= (backward-chain-q $info (quote $goal) $kb $rb) - (case (quote $goal) ( - ((quote (is $a $b)) (let $a $b (quote $goal))) ; Assignment - ((quote (bool $expr)) (if $expr (quote $goal) (empty))) ; Boolean evaluation - ((quote (eval= $a $expr)) (let $a $expr (quote $goal))) ; Expression evaluation - ((quote (nonvar $var)) (if (== Variable (get-metatype $var)) (empty) (quote $goal))) ; Non-variable check - ((quote (var $var)) (if (== Variable (get-metatype $var)) (quote $goal) (empty))) ; Variable check - ((quote (true)) (quote $goal)) ; Always succeeds - ((quote (fail)) (empty)) ; Always fails - ((quote (cut $_)) (if (equalz $info $goal) (quote $goal) (quote $goal))) ; Cut operator for pruning - ((quote (naf $expr)) (if (has-match $kb $expr) (empty) (quote $goal))) ; Negation as failure - ($_ (match $kb $goal (quote $goal))) ; Match against knowledge base - )) -) - -;; Match predicate: checks if a goal has at least one match in a space -;; This is less efficient, as it processes the entire space to find matches -(: has-match (-> Atom Atom Bool)) -(= (has-match $space $g) - (let $m (collapse (match $space $g True)) ; Attempt to match $g in $space - (if (== $m ()) ; If no match is found - False ; Return False - True ; Otherwise, return True - ) - ) -) - -;; Recursive case for backward chaining -(= (backward-chain-q $info (quote $goal) $kb $rb) - (match $rb ($goal :- $body) - (match-body $info $body $kb $rb $goal)) -) - -;; Chain through each element in the body and return the goal -(: match-body (-> Atom Atom Atom Atom Atom Atom)) -(= (match-body $info $body $kb $rb $goal) - (if (== $body ()) - (quote $goal) ; Base case: no more elements to match - (let* ( - (($cur $rest) (decons-atom $body)) ; Deconstruct body - ;(() (println! (IN (cur= $cur) (goal= $goal)))) ; Debugging: log input - ;($retVal (backward-chain $info $cur $kb $rb)) ; Recursive chaining - ;($m (collapse (equalz (quote $cur) $retVal))) ; Check match - ;(() (if (== $m ()) (println! (BAD!!!!!!!! (cur= $cur) (retVal= $retVal))) ())) - ;((quote $cur) $retVal) ; Unify variables - ((quote $cur) (backward-chain $info $cur $kb $rb)) ; Recursive chaining - ;(() (println! (OUT (cur= $cur) (goal= $goal)))) ; Debugging: log output - ) - (match-body $info $rest $kb $rb $goal) ; Continue matching - ) - ) -) - -;; Query execution logic -(: query (-> Atom Atom)) -(= (query $goal) - (let $m (collapse (backward-chain $info $goal &self &self)) - (if (== $m ()) (Fail $goal) (Succeed $m))) -) - -;; Predicate for general atom equality -(: equalz (-> Atom Atom Bool)) ; Compares two atoms -(= (equalz $A $A) True) ; Atoms are equal if they are identical - -(same $x $x) - -;; Predicate: Check if an element is a member of a list -(member $Elem ($Cons $Elem $_)) ; Base case: element found -((member $Elem ($Cons $Nonvar $Tail)) :- - ( (nonvar $Nonvar) (member $Elem $Tail))) ; Recursive case: continue checking - -((because $color house keeps $other the $nationality is the $type owner) :- - ((same $Houses - (Cons ( 1 $_1 $_2 $_3 $_4 $_5) ; First house - (Cons ( 2 $_6 $_7 $_8 $_9 $_10) ; Second house - $Open))) - - (same $Open Nil) - - ; Clue 1: The Norwegian lives in the first house - (member ( 1 norwegian $_11 $_12 $_13 $_14) $Houses) - ; Clue 2: The Brit lives in the red house - (member ( $_15 brit red $_16 $_17 $_18) $Houses) - ; Clue 3: The owner of the blue house drinks tea - (member ( $_19 $_20 blue tea $_21 $_22) $Houses) - ; Clue 4: The owner of the red house keeps $other - (member ( $_23 $_24 $color $_25 $other $_26) $Houses) - ; Clue 5: The owner of the tea-drinking house smokes Prince - (member ( $_27 $_28 $_29 tea $_30 prince) $Houses) - ; Determine the $nationality of owns the $type - (member ( $_31 $nationality $_32 $_33 $type $_34) $Houses))) - -;;;;;;;;;;;;;;;;; -;; TEST Queries ;; -;;;;;;;;;;;;;;;;; -!(query (because red house keeps dogs the $norwegian is the fish owner)) - -!(query (because blue house keeps dogs the $brit is the fish owner)) - -!(query (because red house keeps cats the $norwegian is the fish owner)) - diff --git a/tests/zebra/fol-bc-kb.metta b/tests/zebra/fol-bc-kb.metta deleted file mode 100644 index f51c96ff362..00000000000 --- a/tests/zebra/fol-bc-kb.metta +++ /dev/null @@ -1,39 +0,0 @@ - -;; last of list -(last $x (Cons $x Nil)) -((last $x (Cons $_ $rest)) :- ( (last $x $rest) ) ) - -;; length list -(length Nil 0) -((length (Cons $x $rest) $out) :- ( - (length $rest $out2) - (is $out (+ $out2 1)) -) -) - -;; sum from 0 to n -(sum 0 0) -((sum $n $s) :- ( - (bool (> $n 0)) - (is $n1 (- $n 1)) - (sum $n1 $s1) - (is $s (+ $n $s1)) -)) - -;; list append -(append Nil $L $L) -((append (Cons $H $T) $L (Cons $H $R)) :- ( - (append $T $L $R) -)) - -;; negation as failure test -((bachelor $x) :- ( - (man $x) - (naf (married $x)) -)) -(man John) (man Tim) -(married Tim) - -((woman $x) :- ( - (naf (man $x)) -)) diff --git a/tests/zebra/fol-bc.metta b/tests/zebra/fol-bc.metta deleted file mode 100644 index b64375a507f..00000000000 --- a/tests/zebra/fol-bc.metta +++ /dev/null @@ -1,44 +0,0 @@ -;; First-order logic backward chainer using match - -;; TODO: this is inefficient, we just need at least 1 match -(= (has-match $space $g) - (let $m (collapse (match $space $g True)) - (if (== $m ()) - False - True - ) - ) -) - -;; Base case -(= (backward-chain $goal $kb $rb) - (case $goal ( - ((is $a $b) (let $a $b (is $a $b))) ;; prolog eval & assign - ((bool $expr) (if $expr $goal (empty))) ;; if predicate is a boolean. This might be unnecessary - ((naf $expr) (if (has-match $kb $expr) (empty) $goal)) ;; negation-as-failure - ($_ (match $kb $goal $goal)) - )) -) - -;; Recursive Case -(= (backward-chain $goal $kb $rb) - (match $rb ($goal :- $body) - (match-body $body $kb $rb $goal) - ) -) - -;; do matching for each atom in the body, then returns goal -(= (match-body $body $kb $rb $goal) - (if (== $body ()) - $goal - (let* ( - (($cur $rest) (decons-atom $body)) - ; (() (println! (IN $cur $goal))) - ($cur (backward-chain $cur $kb $rb)) ;; chain on cur & unify back to propagate vars to $goal - ; (() (println! (OUT $cur $goal))) - ) - (match-body $rest $kb $rb $goal) - ) - ) -) - diff --git a/tests/zebra/fol-bc.test.metta b/tests/zebra/fol-bc.test.metta deleted file mode 100644 index e351f2b5b24..00000000000 --- a/tests/zebra/fol-bc.test.metta +++ /dev/null @@ -1,32 +0,0 @@ - -!(import! &self fol-bc) -; !(bind! &baseall (new-space)) -!(import! &baseall fol-bc-kb) -(= (query $goal) - (backward-chain $goal &baseall &baseall) -) - -;;;;;;;;;;;;;;;;; -;; TEST query ;;; -;;;;;;;;;;;;;;;;;; - - -; last element of list -!(query (last $x (Cons 1 (Cons 2 (Cons 3 Nil))))) - -;; length of list -!(query (length (Cons 1 (Cons 2 (Cons 3 Nil))) $out)) - -;; sum up to 3 -!(query (sum 3 $x)) - -;; append (multi-directional) -!(query (append (Cons 1 (Cons 2 Nil)) (Cons 3 (Cons 4 Nil)) $x)) -!(query (append (Cons 1 (Cons 2 Nil)) $Out (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil)))))) -!(query (append $What $Out (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil)))))) - -;; Negation as failure test -!(query (bachelor $x)) -!(query (woman Tim)) ;; should be no -!(query (woman Jane)) ;; should succeed -!(query (woman $x)) ;; should be no \ No newline at end of file diff --git a/tests/zebra/fol-bc.zebra.metta b/tests/zebra/fol-bc.zebra.metta deleted file mode 100644 index 84dcf616e54..00000000000 --- a/tests/zebra/fol-bc.zebra.metta +++ /dev/null @@ -1,32 +0,0 @@ - -!(import! &self fol-bc) -; !(bind! &baseall (new-space)) -!(import! &baseall zebra1) -(= (query $goal) - (backward-chain $goal &baseall &baseall) -) - -;;;;;;;;;;;;;;;;; -;; TEST query ;;; -;;;;;;;;;;;;;;;;;; - - -; last element of list -!(query (last $x (Cons 1 (Cons 2 (Cons 3 Nil))))) - -;; length of list -!(query (length (Cons 1 (Cons 2 (Cons 3 Nil))) $out)) - -;; sum up to 3 -!(query (sum 3 $x)) - -;; append (multi-directional) -!(query (append (Cons 1 (Cons 2 Nil)) (Cons 3 (Cons 4 Nil)) $x)) -!(query (append (Cons 1 (Cons 2 Nil)) $Out (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil)))))) -!(query (append $What $Out (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil)))))) - -;; Negation as failure test -!(query (bachelor $x)) -!(query (woman Tim)) ;; should be no -!(query (woman Jane)) ;; should succeed -!(query (woman $x)) ;; should be no \ No newline at end of file diff --git a/tests/zebra/main.metta b/tests/zebra/main.metta deleted file mode 100644 index 2dc0edaa901..00000000000 --- a/tests/zebra/main.metta +++ /dev/null @@ -1,11 +0,0 @@ -!(import! &self fol-bc) -; !(bind! &kb (new-space)) -!(import! &kb yaleshooting) -; !(import! &kb bec) -(= (query $goal) - (backward-chain $goal &kb &kb) -) - -; !(query (happens $f $t)) -; !(query (tp $t)) -!(query (holdsAt $f $t)) diff --git a/tests/zebra/progn.metta b/tests/zebra/progn.metta new file mode 100644 index 00000000000..b0d3e533bd3 --- /dev/null +++ b/tests/zebra/progn.metta @@ -0,0 +1,21 @@ +(: traced-eval (-> Atom Atom)) +(= (traced-eval $arg) (traced-eval-q (quote $arg))) +(: traced-eval-q (-> Atom Atom)) +(= (traced-eval-q (quote $arg)) + (let* ( + (() (println! (quote (====>EVAL $arg)))) + ($r $arg) + (() (println! (quote (RET<=== $r))))) + $r)) + +(: progn (-> Atom Atom)) +(= (progn $body) (progn-q (quote $body))) +(: progn-q (-> Atom Atom)) +(= (progn-q (quote $body)) + (if (== (quote $body) (quote ())) () + (let* ( + (($head $rest) (decons-atom $body)) ; Deconstruct body + ($r (traced-eval-q (quote $head)))) + (if (== (quote $rest) (quote ())) + $r (progn-q (quote $rest)))))) + diff --git a/tests/zebra/prop_test.metta b/tests/zebra/prop_test.metta index ef8bbb481b3..7522f33cc65 100644 --- a/tests/zebra/prop_test.metta +++ b/tests/zebra/prop_test.metta @@ -1,4 +1,6 @@ +!(import! &self dv-pl) + ; !(bind! &exists-props (new-state Nil)) ((context $ctx) :- ( @@ -26,221 +28,33 @@ ;; Ensure Exists is a member of Houses ((something-existing $Exists in the $ctx) :- - ((same $ctx ($Houses $_)) + ((same $ctx ($Houses $_U)) (member $Exists $Houses))) ;; Member predicate for lists -(member $Elem ($Cons $Elem $_)) -((member $Elem ($Cons $_ $Tail)) :- +(member $Elem ($Cons $Elem $_U)) +((member $Elem ($Cons $_U $Tail)) :- ((member $Elem $Tail))) ;; Map property names to their positions (numbers) ((get-declare-num $PropName $Num in the $ctx) :- - ((same ($_ $PropList) $ctx) + ((same ($_U $PropList) $ctx) (declare-index $PropName $PropList Z $Num))) ((get-declare-num-not-working $PropName $Num in the $ctx) :- - ((same ($_ $PropList) $ctx) + ((same ($_U $PropList) $ctx) (eval= $dc (declare-index-m $PropName $PropList Z $Num)))) (: declare-index-m (-> Symbol Expression Nat Nat Bool)) (= (declare-index-m $PropName $PropList $Acc $Num) (case $PropList - ((($Cons $PropName $_) (nat-equal $Acc $Num)) - (($Cons $_ $Rest) (declare-index-m $PropName $Rest (S $Acc) $Num))))) + ((($Cons $PropName $_U) (nat-equal $Acc $Num)) + (($Cons $_U $Rest) (declare-index-m $PropName $Rest (S $Acc) $Num))))) -(declare-index $PropName ($Cons $PropName $_) $Num $Num) +(declare-index $PropName ($Cons $PropName $_U) $Num $Num) ((declare-index $PropName ($Cons $Nonvar $Rest) $Acc $Num) :- ( (nonvar $Nonvar) (declare-index $PropName $Rest (S $Acc) $Num))) -;((declare-index $PropName ($Cons $_ $Rest) $Acc $Num) :- ((declare-index $PropName $Rest (S $Acc) $Num))) -;((declare-index $PropName $PropList $Acc $Acc) :- ;; If property not found, add it -; ((cons-append $_PropList ($Cons $PropName $_Open) $PropList))) - -;; Zero-based nat-nth predicate -(nat-nth Z ($Cons $Elem $_) $Elem) -((nat-nth (S $N) ($Cons $_ $Rest) $Elem) :- - ((nat-nth $N $Rest $Elem))) - -;; Append two lists -(cons-append Nil $List2 $List2) -((cons-append ($Cons $H $T) $List2 ($Cons $H $T2)) :- - ((cons-append $T $List2 $T2))) - - -(same $x $x) - -;; last of list -(last $x ($Cons $x Nil)) -((last $x ($Cons $_ $rest)) :- ( (last $x $rest) ) ) - -;; length list -(length Nil 0) -((length ($Cons $x $rest) $out) :- - ((length $rest $out2) - (is $out (+ $out2 1)))) - -;; sum from 0 to n -(sum 0 0) -((sum $n $s) :- ( - (bool (> $n 0)) - (is $n1 (- $n 1)) - (sum $n1 $s1) - (is $s (+ $n $s1)) -)) - -;; list append -(append Nil $L $L) -((append (Cons $H $T) $L (Cons $H $R)) :- ( - (append $T $L $R) -)) - -;; negation as failure test -((bachelor $x) :- ( - (man $x) - (naf (married $x)) -)) -(man John) (man Tim) -(married Tim) - -((woman $x) :- ( - (naf (man $x)) -)) - - -(: cur= (-> Atom Atom)) -(: retVal= (-> Atom Atom)) -(: goal= (-> Atom Atom)) - -(: backward-chain (-> Atom Atom Atom Atom Atom)) -(: backward-chain-q (-> Atom Atom Atom Atom Atom)) -(: match-body (-> Atom Atom Atom Atom Atom Atom)) -(: has-match (-> Atom Atom Bool)) -(: has-fundef (-> Atom Atom Bool)) -;; First-order logic backward chainer using match - - -(: Z Nat) -(: S (-> Nat Nat)) - -(: nat-equal (-> Nat Nat Bool)) -(= (nat-equal $A $A) True) - -(: equalz (-> Atom Atom Bool)) -(= (equalz $A $A) True) - -(: quote-equalz (-> Atom Atom Bool)) -(= (quote-equalz $A $A) True) -(= (quote-equalz $A $B) (equalz (quote $A) $B)) -(= (quote-equalz $A $B) (equalz $A (quote $B))) - -;; TODO: this is inefficient, we just need at least 1 match -(= (has-match $space $g) - (let $m (collapse (match $space $g True)) - (if (== $m ()) - False - True - ) - ) -) -(= (has-fundef $space $g) - (let $m (collapse (match $space (= $g $_) True)) - (if (== $m ()) - False - True - ) - ) -) - - -(= (backward-chain $info $goal $kb $rb) - (backward-chain-q $info (quote $goal) $kb $rb)) - -;; Base case -(= (backward-chain-q $info (quote $goal) $kb $rb) - (case (quote $goal) ( - ((quote (is $a $b)) (let $a $b (quote $goal))) ;; prolog eval & assign - ((quote (bool $expr)) (if $expr (quote $goal) (empty))) ;; if predicate is a boolean. This might be unnecessary - ((quote (eval= $a $expr)) (let $a $expr (quote $goal))) ;; if predicate is a boolean. This might be unnecessary - ((quote (nonvar $var)) (if (== Variable (get-metatype $var)) (empty) (quote $goal))) - ((quote (var $var)) (if (== Variable (get-metatype $var)) (quote $goal) (empty))) - ((quote (true)) (quote $goal)) - ((quote (fail)) (empty)) - ((quote (cut $_)) (if (equalz $info $goal) (quote $goal) (quote $goal))) - ((quote (naf $expr)) (if (has-match $kb $expr) (empty) (quote $goal))) ;; negation-as-failure - ($_ (match $kb $goal (quote $goal))) - )) -) - -;; Recursive Case -(= (backward-chain-q $info (quote $goal) $kb $rb) - (match $rb ($goal :- $body) - (match-body $info $body $kb $rb $goal)) -) - -(= (backward-chain $info (quote $goal) $kb $rb) - (if (has-fundef $kb $goal) $goal - (let $r $goal (if (equalz $r $goal) (empty) $r)))) - - -;; do matching for each atom in the body, then returns goal -(= (match-body $info $body $kb $rb $goal) - (if (== $body ()) - (quote $goal) - (let* ( - (($cur $rest) (decons-atom $body)) - (() (println! (IN (cur= $cur) (goal= $goal)))) - ($retVal (backward-chain $info $cur $kb $rb)) - ($m (collapse (equalz (quote $cur) $retVal))) - (() (if (== $m ()) (println! (BAD (cur= $cur) (retVal= $retVal))) ())) - ((quote $cur) $retVal) ;; chain on cur & unify back to propagate vars to $goal - (() (println! (OUT (cur= $cur) (goal= $goal)))) - ) - (match-body $info $rest $kb $rb $goal) - ) - ) -) - -(: query (-> Atom Atom)) -; !(bind! &baseall (new-space)) -(= (query $goal) - (let $m (collapse (backward-chain $info $goal &self &self)) - (if (== $m ()) (Fail $goal) (Succeed $m))) -) -(: query-f (-> Atom Atom)) -(= (query-f $goal) - (let $m (collapse (backward-chain $info $goal &self &self)) - (if (== $m ()) Passed-Negation (Failed $m))) -) - -; last element of list -!(query (last $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) - -;; length of list -!(query (length ($Cons 1 ($Cons 2 ($Cons 3 Nil))) $out)) - -;; sum up to 3 -!(query (sum 3 $x)) - -;; append (multi-directional) -!(query (append ($Cons 1 ($Cons 2 Nil)) ($Cons 3 ($Cons 4 Nil)) $x)) -!(query (append ($Cons 1 ($Cons 2 Nil)) $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) -!(query (append $What $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) - -;; Negation as failure test -!(query (bachelor $x)) - -!(query-f (woman Tim)) ;; should be no -!(query (woman Jane)) ;; should succeed -!(query-f (woman $x)) ;; should be no - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ADDITIONAL TEST QUERIES ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Check if an element is a member of a list -!(query (member 3 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) -!(query-f (member 5 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ;; Should fail -!(query (member $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) + + !(query (is $x (+ 1 1))) !(query (same $ctx ($Houses $Props))) diff --git a/tests/zebra/sec.metta b/tests/zebra/sec.metta deleted file mode 100644 index c2eaf0d5058..00000000000 --- a/tests/zebra/sec.metta +++ /dev/null @@ -1,151 +0,0 @@ -;; Extremely simplified event calculus with deductive temporal projection task -;; No constraints or preconditions - -(: InitiallyP (-> Atom Atom)) -(: InitiallyN (-> Atom Atom)) -(: Holds (-> Atom Number Atom)) -(: Happens (-> Atom Number Atom)) -(: Initiates (-> Atom Atom Atom)) -(: Terminates (-> Atom Atom Atom)) - -;; TODO: use with limit, we only need check at least 1 -(= (has-match $space $pattern) - (let $all (collapse (match $space $pattern True)) - (if (== $all ()) - False True - ) - ) -) - -(: add-holds! (-> Grounded Atom Atom Number (->))) -(= (add-holds! $kb $fluent $TrueOrFalse $time) - (if (or - (== $fluent NIL) - (has-match $kb (Holds ($fluent := $TrueOrFalse) $time))) - () - (add-atom $kb (Holds ($fluent := $TrueOrFalse) $time))) -) - -(: add-holds-list! (-> Grounded Expression Atom Number (->))) -(= (add-holds-list! $kb $fluents $TrueOrFalse $time) - (if (== $fluents ()) - () - (let* ( - (($head $rest) (decons-atom $fluents)) - (() (add-holds! $kb $head $TrueOrFalse $time)) - ) (add-holds-list! $kb $rest $TrueOrFalse $time)) - ) -) - -(: temporal-project-helper! (-> Grounded Number Number (->))) -(= (temporal-project-helper! $kb 0 $maxTime) - (let* ( - ($posFluents (collapse (match $kb (InitiallyP $x) $x))) - ($negFluents (collapse (match $kb (InitiallyN $y) $y))) - (() (add-holds-list! $kb $posFluents true 0)) - (() (add-holds-list! $kb $negFluents false 0)) - ) (temporal-project-helper! $kb 1 $maxTime)) -) -(= (temporal-project-helper! $kb $t $maxTime) - (if (or (== $t 0) (> $t $maxTime)) () - (let* ( - ($tp (- $t 1)) - ;; if initiated - ($posFluents (collapse (match $kb - (, (Happens $ep $tp) - (Initiates $ep $fp) - ) $fp - ))) - (() (add-holds-list! $kb $posFluents true $t)) - - ;; iertia for pos fluents - ($prevPosFluents (collapse (match $kb (Holds ($fp1 := true) $tp) $fp1))) - ($1_ (map-atom $prevPosFluents $posF1 (let () - ;; covertly negation-as-failure - (if (has-match $kb (, (Happens $ep1 $tp) (Terminates $ep1 $posF1))) - () - (add-holds! $kb $posF1 true $t) - ) - () - ))) - - ;; if terminated - ($negFluents (collapse (match $kb - (, (Happens $en $tp) - (Terminates $en $fn) - ) $fn - ))) - (() (add-holds-list! $kb $negFluents false $t)) - - ; ;; inertia for negative fluents - ($prevNegFluents (collapse (match $kb (Holds ($fn1 := false) $tp) $fn1))) - ($2_ (map-atom $prevNegFluents $negF1 (let () - (if (has-match $kb (, (Happens $en1 $tp) (Initiates $en1 $negF1))) - () - (add-holds! $kb $negF1 false $t) - ) - () - ))) - ) (temporal-project-helper! $kb (+ 1 $t) $maxTime)) - ) -) - -(= (temporal-project! $kb $maxTime) - (temporal-project-helper! $kb 0 $maxTime) -) - -(= (add-atoms! $kb $atoms-list) - (if (== $atoms-list ()) () - (let* ( - (($head $rest) (decons-atom $atoms-list)) - (() (add-atom $kb $head)) - ) (add-atoms! $kb $rest)) - ) -) -;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Problem Encodings ;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Yale Shooting scenario -!(bind! &yaleshooting (new-space)) -!(add-atoms! &yaleshooting ( - (InitiallyP Unloaded) (InitiallyP Alive) - (InitiallyN Loaded) (InitiallyN Dead) - (Initiates Load Loaded) (Terminates Load Unloaded) - (Initiates Shoot Dead) (Terminates Shoot Alive) - (Initiates Shoot Unloaded) (Terminates Shoot Loaded) - (Happens Load 1) (Happens Wait 2) (Happens Shoot 3) -)) - -!(temporal-project! &yaleshooting 4) - -!(match &yaleshooting - (, (Holds ($f := true) $t) - (Holds ($f := false) $t) - ) - (Error (Yaleshooting $f $t) ContradictingFluent) -) -!(assertEqualToResult - (match &yaleshooting (Holds (Unloaded := true) $t) $t) - (0 1 4)) -!(assertEqualToResult - (match &yaleshooting (Holds (Unloaded := false) $t) $t) - (2 3)) -!(assertEqualToResult - (match &yaleshooting (Holds (Loaded := true) $t) $t) - (2 3)) -!(assertEqualToResult - (match &yaleshooting (Holds (Loaded := false) $t) $t) - (0 1 4)) -!(assertEqualToResult - (match &yaleshooting (Holds (Alive := true) $t) $t) - (0 1 2 3)) -!(assertEqualToResult - (match &yaleshooting (Holds (Alive := false) $t) $t) - (4)) -!(assertEqualToResult - (match &yaleshooting (Holds (Dead := false) $t) $t) - (0 1 2 3)) -!(assertEqualToResult - (match &yaleshooting (Holds (Dead := true) $t) $t) - (4)) diff --git a/tests/zebra/zebra7_no_states.metta b/tests/zebra/stateless_zebra_1.metta similarity index 51% rename from tests/zebra/zebra7_no_states.metta rename to tests/zebra/stateless_zebra_1.metta index 9b97bee0604..c66fddd5be0 100644 --- a/tests/zebra/zebra7_no_states.metta +++ b/tests/zebra/stateless_zebra_1.metta @@ -1,8 +1,26 @@ + + ; Initialize a new state for exists-props ; !(bind! &exists-props (new-state Nil)) -((context $ctx) :- +((context5 $ctx) :- ( + ; Define the structure of $Houses and initialize it + (same $Houses + (Places (House $_1 $_2) + (Places (House $_3 $_4) + (Places (House $_5 $_6) + (Places (House $_7 $_8) + (Places (House $_9 $_10) Nil)))))) + + ; Define $Props structure for all properties + (same $Props + (Props nationality + (Props color + (Props pet + (Props drink + (Props smokes Nil)))))) + ; Ensure $Props represents a specific structure (same $Props (Props $_H6 $_T6)) ; Ensure $ctx is a combination of $Houses and $Props @@ -20,56 +38,77 @@ ;; Main predicate to find the owner of the fish ((zebra-owner $Owner) :- ( - ; Define the structure of $Houses and initialize it - (same $Houses - (Places (House $__202438 $_39) - (Places (House $__208019 $_1_208020)))) - - ; Define $Props structure for all properties - (same $Props - (Props nationality - (Props color - (Props pet - (Props drink - (Props smokes Nil)))))) - - ; Ensure the context is a combination of houses and properties - (same $ctx ($Houses $Props)) - - (is () (println! (Houses0= $ctx))) + (context5 $ctx) - (same $FirstHouse (House $__202438 $_39)) - ;; Clue 1: The Norwegian lives in the first house + + ;; Clue 8: The man in the center house drinks milk + (center-house $CenterHouse in the $ctx) + (declare drink $CenterHouse milk in the $ctx) + + ;; Clue 9: The Norwegian lives in the first house (first-house $FirstHouse in the $ctx) (declare nationality $FirstHouse norwegian in the $ctx) - (is () (println! (Houses1= $ctx))) + ;; Clue 14: The Norwegian lives next to the blue house + (declare nationality $Norwegian norwegian in the $ctx) + (next-to $Norwegian $HouseBlue in the $ctx) + (declare color $HouseBlue blue in the $ctx) - ;; Clue 2: The Brit lives in the red house + ;; Clue 1: The Brit lives in the red house (declare nationality $Brit brit in the $ctx) (declare color $Brit red in the $ctx) - (is () (println! (Houses2= $ctx))) + ;; Clue 2: The Swede keeps dogs as pets + (declare nationality $Swede swede in the $ctx) + (declare pet $Swede dog in the $ctx) + + ;; Clue 3: The Dane drinks tea + (declare nationality $Dane dane in the $ctx) + (declare drink $Dane tea in the $ctx) + + ;; Clue 4: The green house is immediately to the left of the white house + (left-of $Green $White in the $ctx) + (declare color $Green green in the $ctx) + (declare color $White white in the $ctx) - ;; Clue 3: The owner of the blue house drinks tea - (declare color $BlueHouse blue in the $ctx) - (declare drink $BlueHouse tea in the $ctx) + ;; Clue 5: The owner of the green house drinks coffee + (declare color $Green green in the $ctx) + (declare drink $Green coffee in the $ctx) + ;; Clue 6: The person who smokes Pall Mall rears birds + (declare smokes $PallMallSmoker pallmall in the $ctx) + (declare pet $PallMallSmoker birds in the $ctx) - (is () (println! (Houses3= $ctx))) + ;; Clue 7: The owner of the yellow house smokes Dunhill + (declare color $Yellow yellow in the $ctx) + (declare smokes $Yellow dunhill in the $ctx) - ;; Clue 4: The owner of the red house keeps dogs - (declare color $RedHouse red in the $ctx) - (declare pet $RedHouse dog in the $ctx) + ;; Clue 10: The man who smokes Blends lives next to the one who keeps cats + (declare smokes $SmokesBlends blends in the $ctx) + (next-to $SmokesBlends $HouseCat in the $ctx) + (declare pet $HouseCat cat in the $ctx) - ;; Clue 5: The owner of the tea-drinking house smokes Prince - (declare drink $TeaHouse tea in the $ctx) - (declare smokes $TeaHouse prince in the $ctx) + ;; Clue 11: The man who keeps horses lives next to the man who smokes Dunhill + (declare pet $HorseKeeper horse in the $ctx) + (next-to $HorseKeeper $SmokesDunhills in the $ctx) + (declare smokes $SmokesDunhills dunhill in the $ctx) - ;; Determine who owns the fish + ;; Clue 12: The owner who smokes BlueMaster drinks beer + (declare smokes $SmokesBlueMaster bluemaster in the $ctx) + (declare drink $SmokesBlueMaster beer in the $ctx) + + ;; Clue 13: The German smokes Prince + (declare nationality $German german in the $ctx) + (declare smokes $German prince in the $ctx) + + ;; Clue 15: The man who smokes Blends has a neighbor who drinks water + (declare smokes $BlendsSmoker blends in the $ctx) + (next-to $BlendsSmoker $WaterDrinker in the $ctx) + (declare drink $WaterDrinker water in the $ctx) + + ;; Determine who owns the fish (declare pet $FishOwner fish in the $ctx) (declare nationality $FishOwner $Owner in the $ctx) - )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -87,16 +126,16 @@ (make-houses Z Nil) ; Base case: no houses left to create ;; Create an 'exists' structure for a house -(create-exists ($Cons $_ $_1)) +(create-exists ($Cons $_1 $_1)) ;; Predicate: $L is immediately to the left of $R in the list ((left-of $L $R in the $ctx) :- - ((same $ctx ($Houses $_)) ; Verify context contains the houses list + ((same $ctx ($Houses $_1)) ; Verify context contains the houses list (left-of-list $L $R $Houses))) ;; Helper for 'left-of' within a list structure -(left-of-list $L $R ($Cons $L ($Cons $R $_))) ; Base case: $L is followed by $R -((left-of-list $L $R ($Cons $_ $Rest)) :- +(left-of-list $L $R ($Cons $L ($Cons $R $_1))) ; Base case: $L is followed by $R +((left-of-list $L $R ($Cons $_1 $Rest)) :- ((left-of-list $L $R $Rest))) ; Recursive case: continue checking the list ;; Predicate: $A and $B are next to each other in the list @@ -107,13 +146,13 @@ ;; Predicate: Get the first house in the list ((first-house $First in the $ctx) :- - ((same $ctx ($Houses $_)) ; Verify context contains houses + ((same $ctx ($Houses $_1)) ; Verify context contains houses (nat-nth Z $Houses $First))) ; First element (index 0) ;; Predicate: Get the center house in the list ((center-house $Center in the $ctx) :- - ((same $ctx ($Houses $_)) ; Verify context contains houses - (nat-nth (S Z) $Houses $Center))) ; Center element for 3 houses + ((same $ctx ($Houses $_1)) ; Verify context contains houses + (nat-nth (S (S Z)) $Houses $Center))) ; Center element for 5 houses ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Property handling predicates @@ -128,27 +167,163 @@ ;; Ensure $Exists is a member of Houses ((something-existing $Exists in the $ctx) :- - ((same $ctx ($Houses $_)) ; Verify context contains houses + ((same $ctx ($Houses $_1)) ; Verify context contains houses (member $Exists $Houses))) ; Check if $Exists is in houses -;; Predicate: Check if an element is a member of a list -(member $Elem ($Cons $Elem $_)) ; Base case: element found -((member $Elem ($Cons $_ $Tail)) :- - ((member $Elem $Tail))) ; Recursive case: continue checking ;; Map property names to their positions (numbers) ((get-declare-num $PropName $Num in the $ctx) :- - ((same ($_ $PropList) $ctx);Extractpropertylistfromcontext - (declare-index $PropName $PropList Z $Num)));Getindexofproperty + ((same ($_1 $PropList) $ctx) ; Extract property list from context + (declare-index $PropName $PropList Z $Num))) ; Get index of property ;; Map property names using manual declaration with incremental indexing -(declare-index $PropName ($Cons $PropName $_) $Num $Num) ; Found property +(declare-index $PropName ($Cons $PropName $_1) $Num $Num) ; Found property ((declare-index $PropName ($Cons $Nonvar $Rest) $Acc $Num) :- ((nonvar $Nonvar) (declare-index $PropName $Rest (S $Acc) $Num))) ; Increment index + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Backward chaining logic +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;!(import! &self dv-pl) +;; Predicate signatures for backward chaining logic +(: cur= (-> Atom Atom)) ; Current goal +(: retVal= (-> Atom Atom)) ; Return value +(: goal= (-> Atom Atom)) ; Final goal + +;; Interface for backward chaining (quotes the arguement) +(: backward-chain (-> Atom Atom Atom Atom Atom)) +(= (backward-chain $info $goal $kb $rb) + (backward-chain-q $info (quote $goal) $kb $rb)) + +;; Handle specific cases during backward chaining +(: backward-chain-q (-> Atom Atom Atom Atom Atom)) +(= (backward-chain-q $info (quote $goal) $kb $rb) + (case (quote $goal) ( + ((quote (is $a $b)) (let $a $b (quote $goal))) ; Assignment + ((quote (bool $expr)) (if $expr (quote $goal) (empty))) ; Boolean evaluation + ((quote (eval= $a $expr)) (let $a $expr (quote $goal))) ; Expression evaluation + ((quote (nonvar $var)) (if (== Variable (get-metatype $var)) (empty) (quote $goal))) ; Non-variable check + ((quote (var $var)) (if (== Variable (get-metatype $var)) (quote $goal) (empty))) ; Variable check + ((quote (true)) (quote $goal)) ; Always succeeds + ((quote (fail)) (empty)) ; Always fails + ((quote (cut $signal)) (if (equalz $info $signal) (quote $goal) (quote $goal))) ; Cut operator for pruning + ((quote (naf $expr)) (if (has-match $kb $expr) (empty) (quote $goal))) ; Negation as failure + ((quote (qnaf $expr)) (let (Failed $_1) (backward-chain $info2 $expr $kb $rb) (quote $goal))) ; Negation as failure at query level + ($_2 (backward-chain-q2 $info (quote $goal) $kb $rb)) ; Match against knowledge base + ))) + +(= (backward-chain-q2 $info (quote $goal) $kb $rb) + (match $kb $goal (quote $goal))) +;; Recursive case for backward chaining +(= (backward-chain-q2 $old_info (quote $goal) $kb $rb) + (function + (return ;; if $info is bound that means a clause has called a cut (thus we return empty) + (if (== Variable (get-metatype $old_info)) + (let $r (match $rb ($goal :- $body) + (match-body $info $body $kb $rb $goal)) + (if (== Variable (get-metatype $info)) ;; if not cut + $r ;; then return normal + (return $r))) ;; else return early + (empty))))) + + +;; Match predicate: checks if a goal has at least one match in a space +;; This is less efficient, as it processes the entire space to find matches +(: has-match (-> Atom Atom Bool)) +(= (has-match $space $g) + (let $m (collapse (match $space $g True)) ; Attempt to match $g in $space + (if (== $m ()) ; If no match is found + False ; Return False + True ; Otherwise, return True + ) + ) +) + +;; Predicate to check if a function definition exists in a given space +(= (has-fundef $space $g) + (let $m (collapse (match $space (= $g $_1) True)) ; Match $g as a function in $space + (if (== $m ()) ; If no match is found + False ; Return False + True ; Otherwise, return True + ) + ) +) + +;; Chain through each element in the body and return the goal +(: match-body (-> Atom Atom Atom Atom Atom Atom)) +(= (match-body $info $body $kb $rb $goal) + (if (== $body ()) + (quote $goal) ; Base case: no more elements to match + (let* ( + (($cur $rest) (decons-atom $body)) ; Deconstruct body + ($debugging False) ;; Print debug or not + ($bugcheck False) ;; Catch a bug where we dont return the quoted goals + (() (if $debugging (println! (quote (IN (cur= $cur) (goal= $goal)))) ())) ; Debugging: log input + ($_12 (if $bugcheck + (let* (($retVal (backward-chain $info $cur $kb $rb)) ; Recursive chaining + ($m (collapse (equalz (quote $cur) $retVal))) ; Check match + (() (if (== $m ()) (println! (quote (BAD!!!!!!!! (cur= $cur) (retVal= $retVal))) ()))) + ) ()) ())) + ((quote $cur) (backward-chain $info $cur $kb $rb)) ; Recursive chaining + (() (if $debugging (println! (quote (OUT (cur= $cur) (goal= $goal)))) ())) ; Debugging: log output + ) + (match-body $info $rest $kb $rb $goal) ; Continue matching + ) + ) +) + + +;; Predicate for general atom equality +(: equalz (-> Atom Atom Bool)) ; Compares two atoms +(= (equalz $A $A) True) ; Atoms are equal if they are identical + +(: quote-equalz (-> Atom Atom Bool)) +(= (quote-equalz $A $A) True) +(= (quote-equalz $A $B) (equalz (quote $A) $B)) +(= (quote-equalz $A $B) (equalz $A (quote $B))) + +(: is-equals (-> %Undefined %Undefined% Bool)) ; Compares two atoms +(: is-equals (-> $t $t Bool)) ; Compares two things +(= (is-equals $A $A) True) ; Atoms are equal if they are identical + +;; Define natural numbers using Zero (Z) and Successor (S) +(: Z Nat) ; Base case for natural numbers (0) +(: S (-> Nat Nat)) ; Successor function for incrementing natural numbers + +;; Predicate for natural number equality +(: nat-equal (-> Nat Nat Bool)) ; Compares two natural numbers +(= (nat-equal $A $A) True) ; Two numbers are equal if they are identical + + +;; Query execution logic +(: query (-> Atom Atom Atom)) +(= (query $kb $goal) + (let $m (collapse (backward-chain $info $goal $kb $kb)) + (if (== $m ()) (Failed (quote $goal)) (Succeed $m))) +) + +(: query-f (-> Atom Atom Atom)) +(= (query-f $kb $goal) + (let $m (collapse (backward-chain $info $goal $kb $kb)) + (if (== $m ()) Passed-Negation (Failed $m))) +) + + +;!(equalz $a (+ 1 1)) +;!(is-equals 2 (+ 1 1)) +;!(is-equals $b (+ 1 1)) + + +;; Predicate: Check if an element is a member of a list +(member $Elem ($Cons $Elem $_1)) ; Base case: element found +((member $Elem ($Cons $_1 $Tail)) :- + ((member $Elem $Tail))) ; Recursive case: continue checking + + ;; Zero-based natural number indexing in lists -(nat-nth Z ($Cons $Elem $_) $Elem) ; Base case: first element -((nat-nth (S $N) ($Cons $_ $Rest) $Elem) :- +(nat-nth Z ($Cons $Elem $_1) $Elem) ; Base case: first element +((nat-nth (S $N) ($Cons $_1 $Rest) $Elem) :- ((nat-nth $N $Rest $Elem))) ; Recursive case: move to next element ;; Append two lists @@ -161,29 +336,31 @@ ;; Predicate to get the last element of a list (last $x ($Cons $x Nil)) ; Base case: last element -((last $x ($Cons $_ $rest)) :- +((last $x ($Cons $_1 $rest)) :- ((last $x $rest))) ; Recursive case: move to next element ;; Calculate length of a list (length Nil 0) ; Base case: empty list has length 0 -((length ($Cons $_ $rest) $out) :- +((length ($Cons $_1 $rest) $out) :- ((length $rest $out2) (is $out (+ $out2 1)))) ; Recursive case: increment length ;; Calculate sum of natural numbers from 0 to $n (sum 0 0) ; Base case: sum to 0 is 0 ((sum $n $s) :- ( - (bool (> $n 0)) ; Ensure $n is positive - (is $n1 (- $n 1)) ; Decrement $n - (sum $n1 $s1) ; Calculate sum for smaller range - (is $s (+ $n $s1)))) ; Add $n to sum of smaller range + (bool (> $n 0)) ; Ensure $n is positive + (is $n1 (- $n 1)) ; Decrement $n + (sum $n1 $s1) ; Calculate sum for smaller range + (is $s (+ $n $s1)))) ; Add $n to sum of smaller range ;; Predicate to append lists (append Nil $L $L) ; Base case: appending an empty list ((append ($Cons $H $T) $L ($Cons $H $R)) :- ( - (append $T $L $R) ; Recursive case: append remaining elements + (append $T $L $R) ; Recursive case: append remaining elements )) + + ;; Negation as failure test ((bachelor $x) :- ( (man $x) ; $x must be a man @@ -199,181 +376,114 @@ (naf (man $x)) ; $x is a woman if not a man )) -;; Predicate signatures for backward chaining logic -(: cur= (-> Atom Atom)) ; Current goal -(: retVal= (-> Atom Atom)) ; Return value -(: goal= (-> Atom Atom)) ; Final goal +;;;;;;;;;;;;;;;;; +;; TEST Queries ;; +;;;;;;;;;;;;;;;;; -;; Backward chaining logic -(: backward-chain (-> Atom Atom Atom Atom Atom)) -(: backward-chain-q (-> Atom Atom Atom Atom Atom)) -(: match-body (-> Atom Atom Atom Atom Atom Atom)) -(: has-match (-> Atom Atom Bool)) -(: has-fundef (-> Atom Atom Bool)) -;; First-order logic backward chainer using match +(: traced-eval (-> Atom Atom)) +(= (traced-eval $arg) (traced-eval-q (quote $arg))) +(: traced-eval-q (-> Expression Atom)) +(= (traced-eval-q (quote $arg)) + (let* ( + (() (println! (quote (====>EVAL $arg)))) + ($r $arg) + (() (println! (quote (RET<=== $r))))) + $r)) + +(: progn (-> Atom Atom)) +(= (progn $body) (progn-q (quote $body))) +(: progn-q (-> Expression Atom)) +(= (progn-q (quote $body)) + (if (== (quote $body) (quote ())) () + (let* ( + (($head $rest) (decons-atom $body)) ; Deconstruct body + ($r (traced-eval-q (quote $head)))) + (if (== (quote $rest) (quote ())) + $r (progn-q (quote $rest)))))) -;; Define natural numbers using Zero (Z) and Successor (S) -(: Z Nat) ; Base case for natural numbers (0) -(: S (-> Nat Nat)) ; Successor function for incrementing natural numbers +(= (test_normal_queries $kb) -;; Predicate for natural number equality -(: nat-equal (-> Nat Nat Bool)) ; Compares two natural numbers -(= (nat-equal $A $A) True) ; Two numbers are equal if they are identical + (progn-q (quote ( -;; Predicate for general atom equality -(: equalz (-> Atom Atom Bool)) ; Compares two atoms -(= (equalz $A $A) True) ; Atoms are equal if they are identical +; Query for the last element in a list + (query $kb (last $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) -;; Predicate for quoted atom equality -(: quote-equalz (-> Atom Atom Bool)) ; Compares quoted atoms -(= (quote-equalz $A $A) True) ; Identical quoted atoms are equal -(= (quote-equalz $A $B) (equalz (quote $A) $B)) ; $A quoted matches $B -(= (quote-equalz $A $B) (equalz $A (quote $B))) ; $B quoted matches $A +; Query for the length of a list + (query $kb (length ($Cons 1 ($Cons 2 ($Cons 3 Nil))) $out)) -;; Match predicate: checks if a goal has at least one match in a space -;; This is less efficient, as it processes the entire space to find matches -(= (has-match $space $g) - (let $m (collapse (match $space $g True)) ; Attempt to match $g in $space - (if (== $m ()) ; If no match is found - False ; Return False - True ; Otherwise, return True - ) - ) -) +; Query for the sum of numbers up to 3 + (query $kb (sum 3 $x)) -;; Predicate to check if a function definition exists in a given space -(= (has-fundef $space $g) - (let $m (collapse (match $space (= $g $_) True)) ; Match $g as a function in $space - (if (== $m ()) ; If no match is found - False ; Return False - True ; Otherwise, return True - ) - ) -) +; Query for appending lists + (query $kb (append ($Cons 1 ($Cons 2 Nil)) ($Cons 3 ($Cons 4 Nil)) $x)) + (query $kb (append ($Cons 1 ($Cons 2 Nil)) $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) + (query $kb (append $What $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) -;; Interface for backward chaining (quotes the arguement) -(= (backward-chain $info $goal $kb $rb) - (backward-chain-q $info (quote $goal) $kb $rb)) +;; Test list operations + (query $kb (append ($Cons 1 Nil) ($Cons 2 ($Cons 3 Nil)) $Result)) ; Appending lists + (query $kb (append ($Cons 1 ($Cons 2 Nil)) $Rest ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) ; Partial list append -;; Handle specific cases during backward chaining -(= (backward-chain-q $info (quote $goal) $kb $rb) - (case (quote $goal) ( - ((quote (is $a $b)) (let $a $b (quote $goal))) ; Assignment - ((quote (bool $expr)) (if $expr (quote $goal) (empty))) ; Boolean evaluation - ((quote (eval= $a $expr)) (let $a $expr (quote $goal))) ; Expression evaluation - ((quote (nonvar $var)) (if (== Variable (get-metatype $var)) (empty) (quote $goal))) ; Non-variable check - ((quote (var $var)) (if (== Variable (get-metatype $var)) (quote $goal) (empty))) ; Variable check - ((quote (true)) (quote $goal)) ; Always succeeds - ((quote (fail)) (empty)) ; Always fails - ((quote (cut $_)) (if (equalz $info $goal) (quote $goal) (quote $goal))) ; Cut operator for pruning - ((quote (naf $expr)) (if (has-match $kb $expr) (empty) (quote $goal))) ; Negation as failure - ($_ (match $kb $goal (quote $goal))) ; Match against knowledge base - )) -) +;; Negation as failure tests with bachelors and marital status + (query $kb (bachelor $x)) ; Finds bachelors who are not married + (query-f $kb (woman Tim)) ; Tests failure for a man labeled as a woman + (query $kb (woman Jane)) ; Should succeed for Jane if defined as a woman + (query-f $kb (woman $x)) ; Negative query for undefined women -;; Recursive case for backward chaining -(= (backward-chain-q $info (quote $goal) $kb $rb) - (match $rb ($goal :- $body) - (match-body $info $body $kb $rb $goal)) -) +;; Check if an element is a member of a list + (query $kb (member 3 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ; Should succeed + (query-f $kb (member 5 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ; Should fail, 5 is not in the list + (query $kb (member $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ; Should find members one by one -(= (backward-chain-disabled $info (quote $goal) $kb $rb) - (if (has-fundef $kb $goal) $goal - (let $r $goal (if (equalz $r $goal) (empty) $r)))) +;; Query for basic arithmetic + (query $kb (is $x (+ 1 1))) ; $x should be assigned 2 -;; Chain through each element in the body and return the goal -(= (match-body $info $body $kb $rb $goal) - (if (== $body ()) - (quote $goal) ; Base case: no more elements to match - (let* ( - (($cur $rest) (decons-atom $body)) ; Deconstruct body - ;(() (println! (IN (cur= $cur) (goal= $goal)))) ; Debugging: log input - ;($retVal (backward-chain $info $cur $kb $rb)) ; Recursive chaining - ;($m (collapse (equalz (quote $cur) $retVal))) ; Check match - ;(() (if (== $m ()) (println! (BAD!!!!!!!! (cur= $cur) (retVal= $retVal))) ())) - ;((quote $cur) $retVal) ; Unify variables - ((quote $cur) (backward-chain $info $cur $kb $rb)) ; Recursive chaining - ;(() (println! (OUT (cur= $cur) (goal= $goal)))) ; Debugging: log output - ) - (match-body $info $rest $kb $rb $goal) ; Continue matching - ) - ) -) +;; Query for natural number indexing + (query $kb (nat-nth (S (S Z)) (SomethingAtThird $1 $2) Third)) ; Should find the third element -;; Query execution logic -(: query (-> Atom Atom)) -(= (query $goal) - (let $m (collapse (backward-chain $info $goal &self &self)) - (if (== $m ()) (Fail $goal) (Succeed $m))) -) +)))) -(: query-f (-> Atom Atom)) -(= (query-f $goal) - (let $m (collapse (backward-chain $info $goal &self &self)) - (if (== $m ()) Passed-Negation (Failed $m))) -) +;!(import! &self dv-pl) +;!(test_normal_queries) +;!(test_normal_queries) -((solve-fish-owner $FishOwner) :- +((because $color house keeps $other the $nationality is the $type owner) :- ((same $Houses (Cons ( 1 $_1 $_2 $_3 $_4 $_5) ; First house (Cons ( 2 $_6 $_7 $_8 $_9 $_10) ; Second house - Nil))) + $Open))) + + (same $Open Nil) + ; Clue 1: The Norwegian lives in the first house (member ( 1 norwegian $_11 $_12 $_13 $_14) $Houses) ; Clue 2: The Brit lives in the red house (member ( $_15 brit red $_16 $_17 $_18) $Houses) ; Clue 3: The owner of the blue house drinks tea (member ( $_19 $_20 blue tea $_21 $_22) $Houses) - ; Clue 4: The owner of the red house keeps dogs - (member ( $_23 $_24 red $_25 dog $_26) $Houses) + ; Clue 4: The owner of the red house keeps $other + (member ( $_23 $_24 $color $_25 $other $_26) $Houses) ; Clue 5: The owner of the tea-drinking house smokes Prince (member ( $_27 $_28 $_29 tea $_30 prince) $Houses) - ; Determine who owns the fish - (member ( $_31 $FishOwner $_32 $_33 fish $_34) $Houses))) + ; Determine the $nationality of owns the $type + (member ( $_31 $nationality $_32 $_33 $type $_34) $Houses))) -;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;; ;; TEST Queries ;; -;;;;;;;;;;;;;;;;; -!(query (solve-fish-owner $FishOwner)) +;;;;;;;;;;;;;;;;;; +!(query &self (because red house keeps dogs the $norwegian is the fish owner)) +!(query &self (because blue house keeps dogs the $brit is the fish owner)) +!(query &self (because red house keeps cats the $norwegian is the fish owner)) -; Query for the last element in a list -!(query (last $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) -; Query for the length of a list -!(query (length ($Cons 1 ($Cons 2 ($Cons 3 Nil))) $out)) - -; Query for the sum of numbers up to 3 -!(query (sum 3 $x)) - -; Query for appending lists -!(query (append ($Cons 1 ($Cons 2 Nil)) ($Cons 3 ($Cons 4 Nil)) $x)) -!(query (append ($Cons 1 ($Cons 2 Nil)) $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) -!(query (append $What $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) - -;; Negation as failure tests with bachelors and marital status -!(query (bachelor $x)) ; Finds bachelors who are not married -!(query-f (woman Tim)) ; Tests failure for a man labeled as a woman -!(query (woman Jane)) ; Should succeed for Jane if defined as a woman -!(query-f (woman $x)) ; Negative query for undefined women ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ADDITIONAL TEST QUERIES ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Check if an element is a member of a list -!(query (member 3 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ; Should succeed -!(query-f (member 5 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ; Should fail, 5 is not in the list -!(query (member $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ; Should find members one by one - -;; Query for basic arithmetic -!(query (is $x (+ 1 1))) ; $x should be assigned 2 - -;; Query for natural number indexing -!(query (nat-nth (S (S Z)) (SomethingAtThird $1 $2) Third)) ; Should find the third element ;; Solve the zebra-owner problem (Who owns the fish?) !(query (zebra-owner $Owner)) ; Should find the owner of the fish @@ -389,8 +499,4 @@ ;; Verify properties related to the zebra-owner problem; ;!(query (declare nationality $Owner norwegian)) ; Declare that $Owner is Norwegian -;; Test list operations -;!(query (append ($Cons 1 Nil) ($Cons 2 ($Cons 3 Nil)) $Result)) ; Appending lists -;!(query (append ($Cons 1 ($Cons 2 Nil)) $Rest ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) ; Partial list append - diff --git a/tests/zebra/stateless_zebra_2.metta b/tests/zebra/stateless_zebra_2.metta new file mode 100644 index 00000000000..f4e05fe2712 --- /dev/null +++ b/tests/zebra/stateless_zebra_2.metta @@ -0,0 +1,170 @@ + +!(import! &self dv-pl) + +; Initialize a new state for exists-props +; !(bind! &exists-props (new-state Nil)) +((context5 $ctx) :- + ( + + ; Define the structure of $Houses and initialize it + (same $Houses + (Places (House $_7 $_8) + (Places (House $_9 $_10) Nil)))) + + ; Define $Props structure for all properties + (same $Props + (Props nationality + (Props color + (Props pet + (Props drink + (Props smokes Nil)))))) + + ; Ensure $Props represents a specific structure + (same $Props (Props $_H6 $_T6)) + ; Ensure $ctx is a combination of $Houses and $Props + (same $ctx ($Houses $Props)) + + ; Declare numerical properties for various attributes in the context + (get-declare-num nationality $Num1 in the $ctx) + (get-declare-num color $Num2 in the $ctx) + (get-declare-num pet $Num3 in the $ctx) + (get-declare-num drink $Num4 in the $ctx) + (get-declare-num drink $Num5 in the $ctx) ; this should not change the context since its already there + (get-declare-num smokes $Num6 in the $ctx))) + + +;; Main predicate to find the owner of the fish +((zebra-owner $Owner) :- + ( + ; Define the structure of $Houses and initialize it + (same $Houses + (Places (House $_1 $_2) + (Places (House $_3 $_4)))) + + ; Define $Props structure for all properties + (same $Props + (Props nationality + (Props color + (Props pet + (Props drink + (Props smokes Nil)))))) + + ; Ensure the context is a combination of houses and properties + (same $ctx ($Houses $Props)) + + ; (is () (println! (Houses0= $ctx))) + + (same $FirstHouse (House $_1 $_2)) + ;; Clue 1: The Norwegian lives in the first house + (first-house $FirstHouse in the $ctx) + (declare nationality $FirstHouse norwegian in the $ctx) + + + ;; Clue 2: The Brit lives in the red house + (declare nationality $Brit brit in the $ctx) + (declare color $Brit red in the $ctx) + ;; Clue 3: The owner of the blue house drinks tea + (declare color $BlueHouse blue in the $ctx) + (declare drink $BlueHouse tea in the $ctx) + + ;; Clue 4: The owner of the red house keeps dogs + (declare color $RedHouse red in the $ctx) + (declare pet $RedHouse dog in the $ctx) + + ;; Clue 5: The owner of the tea-drinking house smokes Prince + (declare drink $TeaHouse tea in the $ctx) + (declare smokes $TeaHouse prince in the $ctx) + + ;; Determine who owns the fish + (declare pet $FishOwner fish in the $ctx) + (declare nationality $FishOwner $Owner in the $ctx) + +)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Helper predicates +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Initialize Houses as a list of uninitialized 'exists' +((init-houses $Num $Houses) :- + (make-houses $Num $Houses)) + +;; Recursive creation of houses list based on number +((make-houses (S $N) ($Cons $House $Rest)) :- + ((create-exists $House) ; Initialize a new 'exists' for the house + (make-houses $N $Rest))) ; Continue for the remaining houses +(make-houses Z Nil) ; Base case: no houses left to create + +;; Create an 'exists' structure for a house +(create-exists ($Cons $_1 $_1)) + +;; Predicate: $L is immediately to the left of $R in the list +((left-of $L $R in the $ctx) :- + ((same $ctx ($Houses $_1)) ; Verify context contains the houses list + (left-of-list $L $R $Houses))) + +;; Helper for 'left-of' within a list structure +(left-of-list $L $R ($Cons $L ($Cons $R $_1))) ; Base case: $L is followed by $R +((left-of-list $L $R ($Cons $_1 $Rest)) :- + ((left-of-list $L $R $Rest))) ; Recursive case: continue checking the list + +;; Predicate: $A and $B are next to each other in the list +((next-to $A $B in the $ctx) :- + ((left-of $A $B in the $ctx))) ; $A is left of $B +((next-to $A $B in the $ctx) :- + ((left-of $B $A in the $ctx))) ; $B is left of $A + +;; Predicate: Get the first house in the list +((first-house $First in the $ctx) :- + ((same $ctx ($Houses $_1)) ; Verify context contains houses + (nat-nth Z $Houses $First))) ; First element (index 0) + +;; Predicate: Get the center house in the list +((center-house $Center in the $ctx) :- + ((same $ctx ($Houses $_1)) ; Verify context contains houses + (nat-nth (S Z) $Houses $Center))) ; Center element for 3 houses + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Property handling predicates +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; General property declaration predicate +((declare $PropName $Object $PropValue in the $ctx) :- + ((get-declare-num $PropName $Num in the $ctx) ; Get position for the property + (nat-nth $Num $Template $PropValue) ; Assign value to property + (something-existing $Exists in the $ctx) ; Ensure object exists in houses + (same $Template $Exists) (same $Template $Object))) + +;; Ensure $Exists is a member of Houses +((something-existing $Exists in the $ctx) :- + ((same $ctx ($Houses $_1)) ; Verify context contains houses + (member $Exists $Houses))) ; Check if $Exists is in houses + + +;; Map property names to their positions (numbers) +((get-declare-num $PropName $Num in the $ctx) :- + ((same ($_1 $PropList) $ctx);Extract property list from context + (declare-index $PropName $PropList Z $Num)));Get index of property + +;; Map property names using manual declaration with incremental indexing +(declare-index $PropName ($Cons $PropName $_1) $Num $Num) ; Found property +((declare-index $PropName ($Cons $Nonvar $Rest) $Acc $Num) :- + ((nonvar $Nonvar) (declare-index $PropName $Rest (S $Acc) $Num))) ; Increment index + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ADDITIONAL TEST QUERIES ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Solve the zebra-owner problem (Who owns the fish?) +!(query (zebra-owner $Owner)) ; Should find the owner of the fish + +;; Basic declaration tests +;!(query (declare nationality $Brit brit)) ; Tests nationality declaration +;!(query (something-existing $Exists)) ; Tests if an entity exists in the context + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ADDITIONAL LOGICAL RELATIONSHIPS ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Verify properties related to the zebra-owner problem; +;!(query (declare nationality $Owner norwegian)) ; Declare that $Owner is Norwegian diff --git a/tests/zebra/stateless_zebra_3.metta b/tests/zebra/stateless_zebra_3.metta new file mode 100644 index 00000000000..df4e0afc506 --- /dev/null +++ b/tests/zebra/stateless_zebra_3.metta @@ -0,0 +1,194 @@ + +!(import! &self dv-pl) + +; Initialize a new state for exists-props +; !(bind! &exists-props (new-state Nil)) +((context5 $ctx) :- + ( + + ; Define the structure of $Houses and initialize it + (same $Houses + (Places (House $_1 $_2) + (Places (House $_3 $_4) + (Places (House $_5 $_6) + (Places (House $_7 $_8) + (Places (House $_9 $_10) Nil)))))) + + ; Define $Props structure for all properties + (same $Props + (Props nationality + (Props color + (Props pet + (Props drink + (Props smokes Nil)))))) + + ; Ensure $Props represents a specific structure + (same $Props (Props $_H6 $_T6)) + ; Ensure $ctx is a combination of $Houses and $Props + (same $ctx ($Houses $Props)) + + ; Declare numerical properties for various attributes in the context + (get-declare-num nationality $Num1 in the $ctx) + (get-declare-num color $Num2 in the $ctx) + (get-declare-num pet $Num3 in the $ctx) + (get-declare-num drink $Num4 in the $ctx) + (get-declare-num drink $Num5 in the $ctx) ; this should not change the context since its already there + (get-declare-num smokes $Num6 in the $ctx))) + + +;; Main predicate to find the owner of the fish +((zebra-owner $Owner) :- + ( + ; Define the structure of $Houses and initialize it + (same $Houses + (Places (House $_1 $_2) + (Places (House $_3 $_4) + (Places (House $_5 $_6))))) + + ; Define $Props structure for all properties + (same $Props + (Props nationality + (Props color + (Props pet + (Props drink + (Props smokes Nil)))))) + + ; Ensure the context is a combination of houses and properties + (same $ctx ($Houses $Props)) + + ;; Clue 1: The man in the center house drinks milk + (center-house $CenterHouse in the $ctx) + (declare drink $CenterHouse milk in the $ctx) + + ;; Clue 2: The Norwegian lives in the first house + (first-house $FirstHouse in the $ctx) + (declare nationality $FirstHouse norwegian in the $ctx) + + ;; Clue 3: The Norwegian lives next to the blue house + (declare nationality $Norwegian norwegian in the $ctx) + (next-to $Norwegian $HouseBlue in the $ctx) + (declare color $HouseBlue blue in the $ctx) + + ;; Clue 4: The Brit lives in the red house + (declare nationality $Brit brit in the $ctx) + (declare color $Brit red in the $ctx) + + ;; Clue 5: The Swede keeps dogs as pets + (declare nationality $Swede swede in the $ctx) + (declare pet $Swede dog in the $ctx) + + ;; Clue 6: The green house is next to the white house + (next-to $Green $White in the $ctx) + (declare color $Green green in the $ctx) + (declare color $White white in the $ctx) + + ;; Clue 7: The owner of the green house drinks coffee + (declare color $Green green in the $ctx) + (declare drink $Green coffee in the $ctx) + + ;; Clue 8: The owner who smokes Pall Mall keeps birds + (declare smokes $PallMallSmoker pallmall in the $ctx) + (declare pet $PallMallSmoker birds in the $ctx) + + ;; Clue 9: The man who smokes Blends lives next to the one who drinks tea + (declare smokes $SmokesBlends blends in the $ctx) + (next-to $SmokesBlends $TeaDrinker in the $ctx) + (declare drink $TeaDrinker tea in the $ctx) + + ;; Clue 10: The German smokes Prince + (declare nationality $German german in the $ctx) + (declare smokes $German prince in the $ctx) + + ;; Determine who owns the fish + (declare pet $FishOwner fish in the $ctx) + (declare nationality $FishOwner $Owner in the $ctx) + +)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Helper predicates +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Initialize Houses as a list of uninitialized 'exists' +((init-houses $Num $Houses) :- + (make-houses $Num $Houses)) + +;; Recursive creation of houses list based on number +((make-houses (S $N) ($Cons $House $Rest)) :- + ((create-exists $House) ; Initialize a new 'exists' for the house + (make-houses $N $Rest))) ; Continue for the remaining houses +(make-houses Z Nil) ; Base case: no houses left to create + +;; Create an 'exists' structure for a house +(create-exists ($Cons $_1 $_1)) + +;; Predicate: $L is immediately to the left of $R in the list +((left-of $L $R in the $ctx) :- + ((same $ctx ($Houses $_1)) ; Verify context contains the houses list + (left-of-list $L $R $Houses))) + +;; Helper for 'left-of' within a list structure +(left-of-list $L $R ($Cons $L ($Cons $R $_1))) ; Base case: $L is followed by $R +((left-of-list $L $R ($Cons $_1 $Rest)) :- + ((left-of-list $L $R $Rest))) ; Recursive case: continue checking the list + +;; Predicate: $A and $B are next to each other in the list +((next-to $A $B in the $ctx) :- + ((left-of $A $B in the $ctx))) ; $A is left of $B +((next-to $A $B in the $ctx) :- + ((left-of $B $A in the $ctx))) ; $B is left of $A + +;; Predicate: Get the first house in the list +((first-house $First in the $ctx) :- + ((same $ctx ($Houses $_1)) ; Verify context contains houses + (nat-nth Z $Houses $First))) ; First element (index 0) + +;; Predicate: Get the center house in the list +((center-house $Center in the $ctx) :- + ((same $ctx ($Houses $_1)) ; Verify context contains houses + (nat-nth (S Z) $Houses $Center))) ; Center element for 3 houses + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Property handling predicates +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; General property declaration predicate +((declare $PropName $Object $PropValue in the $ctx) :- + ((get-declare-num $PropName $Num in the $ctx) ; Get position for the property + (nat-nth $Num $Template $PropValue) ; Assign value to property + (something-existing $Exists in the $ctx) ; Ensure object exists in houses + (same $Template $Exists) (same $Template $Object))) + +;; Ensure $Exists is a member of Houses +((something-existing $Exists in the $ctx) :- + ((same $ctx ($Houses $_1)) ; Verify context contains houses + (member $Exists $Houses))) ; Check if $Exists is in houses + + +;; Map property names to their positions (numbers) +((get-declare-num $PropName $Num in the $ctx) :- + ((same ($_1 $PropList) $ctx);Extract property list from context + (declare-index $PropName $PropList Z $Num)));Get index of property + +;; Map property names using manual declaration with incremental indexing +(declare-index $PropName ($Cons $PropName $_1) $Num $Num) ; Found property +((declare-index $PropName ($Cons $Nonvar $Rest) $Acc $Num) :- + ((nonvar $Nonvar) (declare-index $PropName $Rest (S $Acc) $Num))) ; Increment index + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ADDITIONAL TEST QUERIES ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Solve the zebra-owner problem (Who owns the fish?) +!(query (zebra-owner $Owner)) ; Should find the owner of the fish + +;; Basic declaration tests +;!(query (declare nationality $Brit brit)) ; Tests nationality declaration +;!(query (something-existing $Exists)) ; Tests if an entity exists in the context + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ADDITIONAL LOGICAL RELATIONSHIPS ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Verify properties related to the zebra-owner problem; +;!(query (declare nationality $Owner norwegian)) ; Declare that $Owner is Norwegian diff --git a/tests/zebra/trail_test.metta b/tests/zebra/trail_test.metta index 92003c07370..02322faff81 100644 --- a/tests/zebra/trail_test.metta +++ b/tests/zebra/trail_test.metta @@ -1,4 +1,7 @@ +!(import! &self dv-pl) + + ; !(bind! &exists-props (new-state Nil)) ((context $ctx) :- ( @@ -104,7 +107,6 @@ (create-exists ($Cons $_ $_1)) - ;; Predicate: L is immediately to the left of R in the list ((left-of $L $R in the $ctx) :- ((same $ctx ($Houses $_)) @@ -146,11 +148,6 @@ ((same $ctx ($Houses $_)) (member $Exists $Houses))) -;; Member predicate for lists -(member $Elem ($Cons $Elem $_)) -((member $Elem ($Cons $_ $Tail)) :- - ((member $Elem $Tail))) - ;; Map property names to their positions (numbers) ((get-declare-num $PropName $Num in the $ctx) :- ((same ($_ $PropList) $ctx) @@ -168,203 +165,4 @@ (declare-index $PropName ($Cons $PropName $_) $Num $Num) ((declare-index $PropName ($Cons $Nonvar $Rest) $Acc $Num) :- ( (nonvar $Nonvar) (declare-index $PropName $Rest (S $Acc) $Num))) -;((declare-index $PropName ($Cons $_ $Rest) $Acc $Num) :- ((declare-index $PropName $Rest (S $Acc) $Num))) -;((declare-index $PropName $PropList $Acc $Acc) :- ;; If property not found, add it -; ((cons-append $_PropList ($Cons $PropName $_Open) $PropList))) - -;; Zero-based nat-nth predicate -(nat-nth Z ($Cons $Elem $_) $Elem) -((nat-nth (S $N) ($Cons $_ $Rest) $Elem) :- - ((nat-nth $N $Rest $Elem))) - -;; Append two lists -(cons-append Nil $List2 $List2) -((cons-append ($Cons $H $T) $List2 ($Cons $H $T2)) :- - ((cons-append $T $List2 $T2))) - - -(same $x $x) - -;; last of list -(last $x ($Cons $x Nil)) -((last $x ($Cons $_ $rest)) :- ( (last $x $rest) ) ) - -;; length list -(length Nil 0) -((length ($Cons $x $rest) $out) :- - ((length $rest $out2) - (is $out (+ $out2 1)))) - -;; sum from 0 to n -(sum 0 0) -((sum $n $s) :- ( - (bool (> $n 0)) - (is $n1 (- $n 1)) - (sum $n1 $s1) - (is $s (+ $n $s1)) -)) - -;; list append -(append Nil $L $L) -((append (Cons $H $T) $L (Cons $H $R)) :- ( - (append $T $L $R) -)) - -;; negation as failure test -((bachelor $x) :- ( - (man $x) - (naf (married $x)) -)) -(man John) (man Tim) -(married Tim) - -((woman $x) :- ( - (naf (man $x)) -)) - - -(: cur= (-> Atom Atom)) -(: retVal= (-> Atom Atom)) -(: goal= (-> Atom Atom)) - -(: backward-chain (-> Atom Atom Atom Atom Atom)) -(: backward-chain-q (-> Atom Atom Atom Atom Atom)) -(: match-body (-> Atom Atom Atom Atom Atom Atom)) -(: has-match (-> Atom Atom Bool)) -(: has-fundef (-> Atom Atom Bool)) -;; First-order logic backward chainer using match - - -(: Z Nat) -(: S (-> Nat Nat)) - -(: nat-equal (-> Nat Nat Bool)) -(= (nat-equal $A $A) True) - -(: equalz (-> Atom Atom Bool)) -(= (equalz $A $A) True) - -(: quote-equalz (-> Atom Atom Bool)) -(= (quote-equalz $A $A) True) -(= (quote-equalz $A $B) (equalz (quote $A) $B)) -(= (quote-equalz $A $B) (equalz $A (quote $B))) - -;; TODO: this is inefficient, we just need at least 1 match -(= (has-match $space $g) - (let $m (collapse (match $space $g True)) - (if (== $m ()) - False - True - ) - ) -) -(= (has-fundef $space $g) - (let $m (collapse (match $space (= $g $_) True)) - (if (== $m ()) - False - True - ) - ) -) - - -(= (backward-chain $info $goal $kb $rb) - (backward-chain-q $info (quote $goal) $kb $rb)) - -;; Base case -(= (backward-chain-q $info (quote $goal) $kb $rb) - (case (quote $goal) ( - ((quote (is $a $b)) (let $a $b (quote $goal))) ;; prolog eval & assign - ((quote (bool $expr)) (if $expr (quote $goal) (empty))) ;; if predicate is a boolean. This might be unnecessary - ((quote (eval= $a $expr)) (let $a $expr (quote $goal))) ;; if predicate is a boolean. This might be unnecessary - ((quote (nonvar $var)) (if (== Variable (get-metatype $var)) (empty) (quote $goal))) - ((quote (var $var)) (if (== Variable (get-metatype $var)) (quote $goal) (empty))) - ((quote (true)) (quote $goal)) - ((quote (fail)) (empty)) - ((quote (cut $_)) (if (equalz $info $goal) (quote $goal) (quote $goal))) - ((quote (naf $expr)) (if (has-match $kb $expr) (empty) (quote $goal))) ;; negation-as-failure - ($_ (match $kb $goal (quote $goal))) - )) -) - -;; Recursive Case -(= (backward-chain-q $info (quote $goal) $kb $rb) - (match $rb ($goal :- $body) - (match-body $info $body $kb $rb $goal)) -) - -(= (backward-chain $info (quote $goal) $kb $rb) - (if (has-fundef $kb $goal) $goal - (let $r $goal (if (equalz $r $goal) (empty) $r)))) - - -;; do matching for each atom in the body, then returns goal -(= (match-body $info $body $kb $rb $goal) - (if (== $body ()) - (quote $goal) - (let* ( - (($cur $rest) (decons-atom $body)) - (() (println! (IN (cur= $cur) (goal= $goal)))) - ($retVal (backward-chain $info $cur $kb $rb)) - ($m (collapse (equalz (quote $cur) $retVal))) - (() (if (== $m ()) (println! (BAD (cur= $cur) (retVal= $retVal))) ())) - ((quote $cur) $retVal) ;; chain on cur & unify back to propagate vars to $goal - (() (println! (OUT (cur= $cur) (goal= $goal)))) - ) - (match-body $info $rest $kb $rb $goal) - ) - ) -) - - -(: query (-> Atom Atom)) -; !(bind! &baseall (new-space)) -(= (query $goal) - (let $m (collapse (backward-chain $info $goal &self &self)) - (if (== $m ()) (Fail $goal) (Succeed $m))) -) -(: query-f (-> Atom Atom)) -(= (query-f $goal) - (let $m (collapse (backward-chain $info $goal &self &self)) - (if (== $m ()) Passed-Negation (Failed $m))) -) - -;;;;;;;;;;;;;;;;; -;; TEST query ;;; -;;;;;;;;;;;;;;;;;; -; last element of list -!(query (last $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) - -;; length of list -!(query (length ($Cons 1 ($Cons 2 ($Cons 3 Nil))) $out)) - -;; sum up to 3 -!(query (sum 3 $x)) - -;; append (multi-directional) -!(query (append ($Cons 1 ($Cons 2 Nil)) ($Cons 3 ($Cons 4 Nil)) $x)) -!(query (append ($Cons 1 ($Cons 2 Nil)) $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) -!(query (append $What $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) - -;; Negation as failure test -!(query (bachelor $x)) - -!(query-f (woman Tim)) ;; should be no -!(query (woman Jane)) ;; should succeed -!(query-f (woman $x)) ;; should be no - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ADDITIONAL TEST QUERIES ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Check if an element is a member of a list -!(query (member 3 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) -!(query-f (member 5 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ;; Should fail -!(query (member $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) - -!(query (is $x (+ 1 1))) -!(query (same $ctx ($Houses $Props))) -; !(query (context $ctx)) -!(query (zebra-owner $Owner)) ;; Solves for the owner of the fish diff --git a/tests/zebra/trail_test_old.metta b/tests/zebra/trail_test_old.metta deleted file mode 100644 index 3a95ac88475..00000000000 --- a/tests/zebra/trail_test_old.metta +++ /dev/null @@ -1,226 +0,0 @@ - -; !(bind! &exists-props (new-state Nil)) -((context $ctx) :- - ( - - (same $Props (Props $_H6 $_T6)) - (same $ctx ($Houses $Props)) - - (get-declare-num nationality $Num1 in the $ctx))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Property handling predicates -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; General property declaration predicate -((declare $PropName $Object $PropValue in the $ctx) :- - ((get-declare-num $PropName $Num in the $ctx) - (nat-nth $Num $Template $PropValue) - (something-existing $Exists in the $ctx) - (same $Template $Exists) (same $Template $Object))) - -;; Ensure Exists is a member of Houses -((something-existing $Exists in the $ctx) :- - ((same $ctx ($Houses $_)) - (member $Exists $Houses))) - -;; Member predicate for lists -(member $Elem ($Cons $Elem $_)) -((member $Elem ($Cons $_ $Tail)) :- - ((member $Elem $Tail))) - -;; Map property names to their positions (numbers) -((get-declare-num $PropName $Num in the $ctx) :- - ((same ($_ $PropList) $ctx) - (eval (declare-index $PropName $PropList Z $Num)))) - -(: declare-index (-> Symbol Expression Nat Nat Bool)) -(= (declare-index $PropName $PropList $Acc $Num) - (case $PropList - ((($Cons $PropName $_) (nat-equal $Acc $Num)) - (($Cons $_ $Rest) (declare-index $PropName $Rest (S $Acc) $Num))))) - -(: Z Nat) -(: S (-> Nat Nat)) - -(: nat-equal (-> Nat Nat Bool)) -(= (nat-equal $A $A) True) - -(: equalz (-> Atom Atom Bool)) -(= (equalz $A $A) True) - -(: quote-equalz (-> Atom Atom Bool)) -(= (quote-equalz $A $A) True) -(= (quote-equalz $A $B) (equalz (quote $A) $B)) -(= (quote-equalz $A $B) (equalz $A (quote $B))) - -;((declare-index $PropName ($Cons $_ $Rest) $Acc $Num) :- ((declare-index $PropName $Rest (S $Acc) $Num))) -;((declare-index $PropName $PropList $Acc $Acc) :- ;; If property not found, add it -; ((cons-append $_PropList ($Cons $PropName $_Open) $PropList))) - -;; Zero-based nat-nth predicate -(nat-nth Z ($Cons $Elem $_) $Elem) -((nat-nth (S $N) ($Cons $_ $Rest) $Elem) :- - ((nat-nth $N $Rest $Elem))) - -;; Append two lists -(cons-append Nil $List2 $List2) -((cons-append ($Cons $H $T) $List2 ($Cons $H $T2)) :- - ((cons-append $T $List2 $T2))) - - -(same $x $x) - -;; last of list -(last $x ($Cons $x Nil)) -((last $x ($Cons $_ $rest)) :- ( (last $x $rest) ) ) - -;; length list -(length Nil 0) -((length ($Cons $x $rest) $out) :- - ((length $rest $out2) - (is $out (+ $out2 1)))) - -;; sum from 0 to n -(sum 0 0) -((sum $n $s) :- ( - (bool (> $n 0)) - (is $n1 (- $n 1)) - (sum $n1 $s1) - (is $s (+ $n $s1)) -)) - -;; list append -(append Nil $L $L) -((append (Cons $H $T) $L (Cons $H $R)) :- ( - (append $T $L $R) -)) - -;; negation as failure test -((bachelor $x) :- ( - (man $x) - (naf (married $x)) -)) -(man John) (man Tim) -(married Tim) - -((woman $x) :- ( - (naf (man $x)) -)) - - -(: cur= (-> Atom Atom)) -(: retVal= (-> Atom Atom)) -(: goal= (-> Atom Atom)) - -(: backward-chain (-> Atom Atom Atom Atom Atom)) -(: backward-chain-q (-> Atom Atom Atom Atom Atom)) -(: match-body (-> Atom Atom Atom Atom Atom Atom)) -(: has-match (-> Atom Atom Bool)) -(: has-fundef (-> Atom Atom Bool)) -;; First-order logic backward chainer using match - - -;; TODO: this is inefficient, we just need at least 1 match -(= (has-match $space $g) - (let $m (collapse (match $space $g True)) - (if (== $m ()) - False - True - ) - ) -) -(= (has-fundef $space $g) - (let $m (collapse (match $space (= $g $_) True)) - (if (== $m ()) - False - True - ) - ) -) - -(= (backward-chain-hide $info $goal $kb $rb) - (if (has-fundef $kb $goal) $goal - (let $r $goal (if (equalz $r $goal) (empty) $r)))) - -;; Base case -(= (backward-chain $info $goal $kb $rb) - (case $goal ( - ((is $a $b) (let $a $b (is $a $b))) ;; prolog eval & assign - ((bool $expr) (if $expr $goal (empty))) ;; if predicate is a boolean. This might be unnecessary - ((naf $expr) (if (has-match $kb $expr) (empty) $goal)) ;; negation-as-failure - ($_ (match $kb $goal $goal)) - )) -) - -;; Recursive Case -(= (backward-chain $info $goal $kb $rb) - (match $rb ($goal :- $body) - (match-body $info $body $kb $rb $goal)) -) - -;; do matching for each atom in the body, then returns goal -(= (match-body $info $body $kb $rb $goal) - (if (== $body ()) - $goal - (let* ( - (($cur $rest) (decons-atom $body)) - (() (println! (IN $cur $goal))) - ($cur (backward-chain $info $cur $kb $rb)) ;; chain on cur & unify back to propagate vars to $goal - (() (println! (OUT $cur $goal))) - ) - (match-body $info $rest $kb $rb $goal) - ) - ) -) - - -(: query (-> Atom Atom)) -; !(bind! &baseall (new-space)) -(= (query $goal) - (let $m (collapse (backward-chain $info $goal &self &self)) - (if (== $m ()) (Fail $goal) (Succeed $m))) -) -(: query-f (-> Atom Atom)) -(= (query-f $goal) - (let $m (collapse (backward-chain $info $goal &self &self)) - (if (== $m ()) Passed-Negation (Failed $m))) -) - -; last element of list -!(query (last $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) - -;; length of list -!(query (length ($Cons 1 ($Cons 2 ($Cons 3 Nil))) $out)) - -;; sum up to 3 -!(query (sum 3 $x)) - -;; append (multi-directional) -!(query (append ($Cons 1 ($Cons 2 Nil)) ($Cons 3 ($Cons 4 Nil)) $x)) -!(query (append ($Cons 1 ($Cons 2 Nil)) $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) -!(query (append $What $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) - -;; Negation as failure test -!(query (bachelor $x)) - -!(query-f (woman Tim)) ;; should be no -!(query (woman Jane)) ;; should succeed -!(query-f (woman $x)) ;; should be no - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ADDITIONAL TEST QUERIES ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Check if an element is a member of a list -!(query (member 3 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) -!(query-f (member 5 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ;; Should fail -!(query (member $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) - -!(query (is $x (+ 1 1))) -!(query (same $ctx ($Houses $Props))) -!(query (context $ctx)) - - diff --git a/tests/zebra/yaleshooting.metta b/tests/zebra/yaleshooting.metta deleted file mode 100644 index 968e9070177..00000000000 --- a/tests/zebra/yaleshooting.metta +++ /dev/null @@ -1,18 +0,0 @@ -(initiates Load Loaded $t) -((initiates Shoot Dead $t) :- ( - (holdsAt Loaded $t) -)) - -((terminates Shoot Alive $t) :- ( - (holdsAt Loaded $t) -)) - -(initiallyP Alive) -(happens Load 1) -(happens Sneeze 3) -(happens Shoot 4) - -(tp 0) (tp 1) (tp 2) (tp 3) (tp 4) -(tp 5) - -!(import! &self bec) \ No newline at end of file diff --git a/tests/zebra/zebra1.metta b/tests/zebra/zebra1.metta index 26318789915..76de462c600 100644 --- a/tests/zebra/zebra1.metta +++ b/tests/zebra/zebra1.metta @@ -1,75 +1,112 @@ +!(import! &self dv-pl) + +; Initialize a new state for exists-props ; !(bind! &exists-props (new-state Nil)) +((context5 $ctx) :- + ( + + ; Define the structure of $Houses and initialize it + (same $Houses + (Places (House $_1 $_2) + (Places (House $_3 $_4) + (Places (House $_5 $_6) + (Places (House $_7 $_8) + (Places (House $_9 $_10) Nil)))))) + + (set-global &neighborhood $Houses) + + ; Define $Props structure for all properties + (same $Props + (Props nationality + (Props color + (Props pet + (Props drink + (Props smokes Nil)))))) + + + ; Ensure $Props represents a specific structure + (same $Props (Props $_H6 $_T6)) + ; Ensure $ctx is a combination of $Houses and $Props + (same $ctx ($Houses $Props)) + + ; Declare numerical properties for various attributes in the context + (get-declare-num nationality $Num1) + (get-declare-num color $Num2) + (get-declare-num pet $Num3) + (get-declare-num drink $Num4) + (get-declare-num drink $Num5) ; this should not change the context since its already there + (get-declare-num smokes $Num6))) + ;; Main predicate to find the owner of the fish ((zebra-owner $Owner) :- ( - (set-global &exists-props Nil) + (set-global &exists-props $_Props) + (init-houses (S (S (S (S (S Z)))))) - (init-houses (S (S (S (S (S Z)))))) + + ;; Clue 8: The man in the center house drinks milk + (center-house $CenterHouse) + (declare drink $CenterHouse milk) + ;; Clue 9: The Norwegian lives in the first house + (first-house $FirstHouse) + (declare nationality $FirstHouse norwegian) + + ;; Clue 14: The Norwegian lives next to the blue house + (declare nationality $Norwegian norwegian) + (next-to $Norwegian $HouseBlue) + (declare color $HouseBlue blue) - ;; Clue 1: The Brit lives in the red house. + ;; Clue 1: The Brit lives in the red house (declare nationality $Brit brit) (declare color $Brit red) - ;; Clue 2: The Swede keeps dogs as pets. + ;; Clue 2: The Swede keeps dogs as pets (declare nationality $Swede swede) (declare pet $Swede dog) - ;; Clue 3: The Dane drinks tea. + ;; Clue 3: The Dane drinks tea (declare nationality $Dane dane) (declare drink $Dane tea) - ;; Clue 4: The green house is immediately to the left of the white house. + ;; Clue 4: The green house is immediately to the left of the white house (left-of $Green $White) (declare color $Green green) (declare color $White white) - ;; Clue 5: The owner of the green house drinks coffee. + ;; Clue 5: The owner of the green house drinks coffee (declare color $Green green) (declare drink $Green coffee) - ;; Clue 6: The person who smokes Pall Mall rears birds. + ;; Clue 6: The person who smokes Pall Mall rears birds (declare smokes $PallMallSmoker pallmall) (declare pet $PallMallSmoker birds) - ;; Clue 7: The owner of the yellow house smokes Dunhill. + ;; Clue 7: The owner of the yellow house smokes Dunhill (declare color $Yellow yellow) (declare smokes $Yellow dunhill) - ;; Clue 8: The man living in the center house drinks milk. - (center-house $CenterHouse) - (declare drink $CenterHouse milk) - - ;; Clue 9: The Norwegian lives in the first house. - (first-house $FirstHouse) - (declare nationality $FirstHouse norwegian) - - ;; Clue 10: The man who smokes Blends lives next to the one who keeps cats. + ;; Clue 10: The man who smokes Blends lives next to the one who keeps cats (declare smokes $SmokesBlends blends) (next-to $SmokesBlends $HouseCat) (declare pet $HouseCat cat) - ;; Clue 11: The man who keeps horses lives next to the man who smokes Dunhill. + ;; Clue 11: The man who keeps horses lives next to the man who smokes Dunhill (declare pet $HorseKeeper horse) (next-to $HorseKeeper $SmokesDunhills) (declare smokes $SmokesDunhills dunhill) - ;; Clue 12: The owner who smokes BlueMaster drinks beer. + ;; Clue 12: The owner who smokes BlueMaster drinks beer (declare smokes $SmokesBlueMaster bluemaster) (declare drink $SmokesBlueMaster beer) - ;; Clue 13: The German smokes Prince. + ;; Clue 13: The German smokes Prince (declare nationality $German german) (declare smokes $German prince) - ;; Clue 14: The Norwegian lives next to the blue house. - (declare nationality $Norwegian norwegian) - (next-to $Norwegian $HouseBlue) - (declare color $HouseBlue blue) - - ;; Clue 15: The man who smokes Blends has a neighbor who drinks water. + ;; Clue 15: The man who smokes Blends has a neighbor who drinks water (declare smokes $BlendsSmoker blends) (next-to $BlendsSmoker $WaterDrinker) (declare drink $WaterDrinker water) @@ -82,43 +119,45 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Helper predicates ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Initialize Houses as a list of uninitialized exists -((init-houses $Num) :- - ((make-houses $Num $Houses) - (set-global &neighborhood $Houses))) -((make-houses (S $N) (Cons $House $Rest)) :- - ((create-exists $House) - (make-houses $N $Rest))) -(make-houses Z Nil) +;; Initialize Houses as a list of uninitialized 'exists' +((init-houses $Num $Houses) :- + (make-houses $Num $Houses)) -(create-exists (Cons $_ $_1)) +;; Recursive creation of houses list based on number +((make-houses (S $N) ($Cons $House $Rest)) :- + ((create-exists $House) ; Initialize a new 'exists' for the house + (make-houses $N $Rest))) ; Continue for the remaining houses +(make-houses Z Nil) ; Base case: no houses left to create +;; Create an 'exists' structure for a house +(create-exists ($Cons $_1 $_1)) -;; Predicate: L is immediately to the left of R in the list +;; Predicate: $L is immediately to the left of $R in the list ((left-of $L $R) :- - ((get-global &neighborhood $Houses) + ((get-global &neighborhood $Houses) ; Verify context contains the houses list (left-of-list $L $R $Houses))) -(left-of-list $L $R (Cons $L (Cons $R $_))) -((left-of-list $L $R (Cons $_ $Rest)) :- - ((left-of-list $L $R $Rest))) +;; Helper for 'left-of' within a list structure +(left-of-list $L $R ($Cons $L ($Cons $R $_1))) ; Base case: $L is followed by $R +((left-of-list $L $R ($Cons $_1 $Rest)) :- + ((left-of-list $L $R $Rest))) ; Recursive case: continue checking the list -;; Predicate: A and B are next to each other in the list +;; Predicate: $A and $B are next to each other in the list ((next-to $A $B) :- - ((left-of $A $B))) + ((left-of $A $B))) ; $A is left of $B ((next-to $A $B) :- - ((left-of $B $A))) + ((left-of $B $A))) ; $B is left of $A -;; Predicate to get the first house in the list +;; Predicate: Get the first house in the list ((first-house $First) :- - ((get-global &neighborhood $Houses) - (nat-nth Z $Houses $First))) + ((get-global &neighborhood $Houses) ; Verify context contains houses + (nat-nth Z $Houses $First))) ; First element (index 0) -;; Predicate to get the center house in the list +;; Predicate: Get the center house in the list ((center-house $Center) :- - ((get-global &neighborhood $Houses) - (nat-nth (S (S Z)) $Houses $Center))) + ((get-global &neighborhood $Houses) ; Verify context contains houses + (nat-nth (S (S Z)) $Houses $Center))) ; Center element for 5 houses ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Property handling predicates @@ -126,210 +165,289 @@ ;; General property declaration predicate ((declare $PropName $Object $PropValue) :- - ((get-declare-num $PropName $Num) - (nat-nth $Num $Template $PropValue) - (something-existing $Exists) - (same $Template $Object) (same $Template $Object))) + ((get-declare-num $PropName $Num) ; Get position for the property + (nat-nth $Num $Template $PropValue) ; Assign value to property + (something-existing $Exists) ; Ensure object exists in houses + (same $Template $Exists) (same $Template $Object))) -;; Ensure Exists is a member of Houses +;; Ensure $Exists is a member of Houses ((something-existing $Exists) :- - ((get-global &neighborhood $Houses) - (member $Exists $Houses))) + ((get-global &neighborhood $Houses) ; Verify context contains houses + (member $Exists $Houses))) ; Check if $Exists is in houses -;; Member predicate for lists -(member $Elem (Cons $Elem $_)) -((member $Elem (Cons $_ $Tail)) :- - ((member $Elem $Tail))) ;; Map property names to their positions (numbers) ((get-declare-num $PropName $Num) :- - ((get-global &exists-props $PropList) - (declare-index $PropName $PropList Z $Num))) - -(declare-index $PropName (Cons $PropName $_) $Num $Num) -((declare-index $PropName (Cons $_ $Rest) $Acc $Num) :- - ((declare-index $PropName $Rest (S $Acc) $Num))) -((declare-index $PropName Nil $Acc $Acc) :- ;; If property not found, add it - ((get-global &exists-props $PropList) - (cons-append $PropList (Cons $PropName Nil) $NewPropList) - (set-global &exists-props $NewPropList))) - -;; Zero-based nat-nth predicate -(nat-nth Z (Cons $Elem $_) $Elem) -((nat-nth (S $N) (Cons $_ $Rest) $Elem) :- - ((nat-nth $N $Rest $Elem))) + ((get-global &exists-props $PropList) ; Extract property list from context + (declare-index $PropName $PropList Z $Num) ; Get index of property + (set-global &exists-props $PropList))) ; Set index of property -;; Append two lists -(cons-append Nil $List2 $List2) -((cons-append (Cons $H $T) $List2 (Cons $H $T2)) :- - ((cons-append $T $List2 $T2))) +;; Map property names using manual declaration with incremental indexing +(declare-index $PropName ($Cons $PropName $_1) $Num $Num) ; Found property +((declare-index $PropName ($Cons $Nonvar $Rest) $Acc $Num) :- + ((nonvar $Nonvar) (declare-index $PropName $Rest (S $Acc) $Num))) ; Increment index -((set-global $var $val) :- - (eval (bind! $var (new-state $val)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Backward chaining logic +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -((get-global $var $val) :- - (is $val (get-state $var))) +;; Predicate signatures for backward chaining logic +(: cur= (-> Atom Atom)) ; Current goal +(: retVal= (-> Atom Atom)) ; Return value +(: goal= (-> Atom Atom)) ; Final goal + +;; Interface for backward chaining (quotes the arguement) +(: backward-chain (-> Atom Atom Atom Atom Atom)) +(= (backward-chain $info $goal $kb $rb) + (backward-chain-q $info (quote $goal) $kb $rb)) + +;; Handle specific cases during backward chaining +(: backward-chain-q (-> Atom Atom Atom Atom Atom)) +(= (backward-chain-q $info (quote $goal) $kb $rb) + (case (quote $goal) ( + ((quote (is $a $b)) (let $a $b (quote $goal))) ; Assignment + ((quote (bool $expr)) (if $expr (quote $goal) (empty))) ; Boolean evaluation + ((quote (eval= $a $expr)) (let $a $expr (quote $goal))) ; Expression evaluation + ((quote (nonvar $var)) (if (== Variable (get-metatype $var)) (empty) (quote $goal))) ; Non-variable check + ((quote (var $var)) (if (== Variable (get-metatype $var)) (quote $goal) (empty))) ; Variable check + ((quote (true)) (quote $goal)) ; Always succeeds + ((quote (fail)) (empty)) ; Always fails + ((quote (cut $signal)) (if (equalz $info $signal) (quote $goal) (quote $goal))) ; Cut operator for pruning + ((quote (naf $expr)) (if (has-match $kb $expr) (empty) (quote $goal))) ; Negation as failure + ((quote (qnaf $expr)) (let (Failed $_1) (backward-chain $info2 $expr $kb $rb) (quote $goal))) ; Negation as failure at query level + ($_2 (match $kb $goal (quote $goal))) ; Match against knowledge base + ))) +) +;; Recursive case for backward chaining +(= (backward-chain-q $info (quote $goal) $kb $rb) + (function + (return ;; if $info is bound that means a clause has called a cut (thus we return empty) + (if (== Variable (get-metatype $info)) + (let $r (match $rb ($goal :- $body) + (match-body $info $body $kb $rb $goal)) + (if (== Variable (get-metatype $info)) ;; if not cut + $r ;; then return normal + (return $r))) ;; else return early + (empty))))) + + +;; Match predicate: checks if a goal has at least one match in a space +;; This is less efficient, as it processes the entire space to find matches +(: has-match (-> Atom Atom Bool)) +(= (has-match $space $g) + (let $m (collapse (match $space $g True)) ; Attempt to match $g in $space + (if (== $m ()) ; If no match is found + False ; Return False + True ; Otherwise, return True + ) + ) +) -(same $x $x) +;; Predicate to check if a function definition exists in a given space +(= (has-fundef $space $g) + (let $m (collapse (match $space (= $g $_1) True)) ; Match $g as a function in $space + (if (== $m ()) ; If no match is found + False ; Return False + True ; Otherwise, return True + ) + ) +) + +;; Chain through each element in the body and return the goal +(: match-body (-> Atom Atom Atom Atom Atom Atom)) +(= (match-body $info $body $kb $rb $goal) + (if (== $body ()) + (quote $goal) ; Base case: no more elements to match + (let* ( + (($cur $rest) (decons-atom $body)) ; Deconstruct body + ($debugging False) ;; Print debug or not + ($bugcheck False) ;; Catch a bug where we dont return the quoted goals + (() (if $debugging (println! (quote (IN (cur= $cur) (goal= $goal)))) ())) ; Debugging: log input + ($_12 (if $bugcheck + (let* (($retVal (backward-chain $info $cur $kb $rb)) ; Recursive chaining + ($m (collapse (equalz (quote $cur) $retVal))) ; Check match + (() (if (== $m ()) (println! (quote (BAD!!!!!!!! (cur= $cur) (retVal= $retVal))) ()))) + ) ()) ())) + ((quote $cur) (backward-chain $info $cur $kb $rb)) ; Recursive chaining + (() (if $debugging (println! (quote (OUT (cur= $cur) (goal= $goal)))) ())) ; Debugging: log output + ) + (match-body $info $rest $kb $rb $goal) ; Continue matching + ) + ) +) + + +;; Predicate for general atom equality +(: equalz (-> Atom Atom Bool)) ; Compares two atoms +(= (equalz $A $A) True) ; Atoms are equal if they are identical + +(: quote-equalz (-> Atom Atom Bool)) +(= (quote-equalz $A $A) True) +(= (quote-equalz $A $B) (equalz (quote $A) $B)) +(= (quote-equalz $A $B) (equalz $A (quote $B))) + +(: is-equals (-> %Undefined %Undefined% Bool)) ; Compares two atoms +(: is-equals (-> $t $t Bool)) ; Compares two things +(= (is-equals $A $A) True) ; Atoms are equal if they are identical -;; last of list -(last $x (Cons $x Nil)) -((last $x (Cons $_ $rest)) :- ( (last $x $rest) ) ) +;; Define natural numbers using Zero (Z) and Successor (S) +(: Z Nat) ; Base case for natural numbers (0) +(: S (-> Nat Nat)) ; Successor function for incrementing natural numbers -;; length list -(length Nil 0) -((length (Cons $x $rest) $out) :- ( - (length $rest $out2) - (is $out (+ $out2 1)) +;; Predicate for natural number equality +(: nat-equal (-> Nat Nat Bool)) ; Compares two natural numbers +(= (nat-equal $A $A) True) ; Two numbers are equal if they are identical + + +;; Query execution logic +(: query (-> Atom Atom)) +(= (query $goal) + (let $m (collapse (backward-chain $info $goal &self &self)) + (if (== $m ()) (Failed (quote $goal)) (Succeed $m))) ) + +(: query-f (-> Atom Atom)) +(= (query-f $goal) + (let $m (collapse (backward-chain $info $goal &self &self)) + (if (== $m ()) Passed-Negation (Failed $m))) ) -;; sum from 0 to n -(sum 0 0) + +;!(equalz $a (+ 1 1)) +;!(is-equals 2 (+ 1 1)) +;!(is-equals $b (+ 1 1)) + + +;; Predicate: Check if an element is a member of a list +(member $Elem ($Cons $Elem $_1)) ; Base case: element found +((member $Elem ($Cons $_1 $Tail)) :- + ((member $Elem $Tail))) ; Recursive case: continue checking + + +;; Zero-based natural number indexing in lists +(nat-nth Z ($Cons $Elem $_1) $Elem) ; Base case: first element +((nat-nth (S $N) ($Cons $_1 $Rest) $Elem) :- + ((nat-nth $N $Rest $Elem))) ; Recursive case: move to next element + +;; Append two lists +(cons-append Nil $List2 $List2) ; Base case: append empty list +((cons-append ($Cons $H $T) $List2 ($Cons $H $T2)) :- + ((cons-append $T $List2 $T2))) ; Recursive case: append remaining elements + +;; Predicate to check equality of two values +(same $x $x) + +;; Predicate to get the last element of a list +(last $x ($Cons $x Nil)) ; Base case: last element +((last $x ($Cons $_1 $rest)) :- + ((last $x $rest))) ; Recursive case: move to next element + +;; Calculate length of a list +(length Nil 0) ; Base case: empty list has length 0 +((length ($Cons $_1 $rest) $out) :- + ((length $rest $out2) + (is $out (+ $out2 1)))) ; Recursive case: increment length + +;; Calculate sum of natural numbers from 0 to $n +(sum 0 0) ; Base case: sum to 0 is 0 ((sum $n $s) :- ( - (bool (> $n 0)) - (is $n1 (- $n 1)) - (sum $n1 $s1) - (is $s (+ $n $s1)) + (bool (> $n 0)) ; Ensure $n is positive + (is $n1 (- $n 1)) ; Decrement $n + (sum $n1 $s1) ; Calculate sum for smaller range + (is $s (+ $n $s1)))) ; Add $n to sum of smaller range + +;; Predicate to append lists +(append Nil $L $L) ; Base case: appending an empty list +((append ($Cons $H $T) $L ($Cons $H $R)) :- ( + (append $T $L $R) ; Recursive case: append remaining elements )) -;; list append -(append Nil $L $L) -((append (Cons $H $T) $L (Cons $H $R)) :- ( - (append $T $L $R) -)) -;; negation as failure test + +;; Negation as failure test ((bachelor $x) :- ( - (man $x) - (naf (married $x)) + (man $x) ; $x must be a man + (naf (married $x)) ; $x must not be married )) + +; Facts: Men and marital status (man John) (man Tim) (married Tim) +;; Predicate to define a woman ((woman $x) :- ( - (naf (man $x)) + (naf (man $x)) ; $x is a woman if not a man )) +;;;;;;;;;;;;;;;;; +;; TEST Queries ;; +;;;;;;;;;;;;;;;;; -;; First-order logic backward chainer using match - -;; TODO: this is inefficient, we just need at least 1 match -(: has-match (-> Atom Atom Bool)) -(= (has-match $space $g) - (let $m (collapse (match $space $g True)) - (if (== $m ()) - False - True - ) - ) -) +(= (test_normal_queries) -(: backward-chain (-> Atom Atom Atom Atom )) -(: backward-chain1 (-> Atom Atom Atom Atom )) -(: backward-chain2 (-> Atom Atom Atom Atom )) - -(= (backward-chain $goal $kb $rb) (backward-chain2 $goal $kb $rb)) -(= (backward-chain $goal $kb $rb) (backward-chain1 $goal $kb $rb)) - -;; Base case -(= (backward-chain1 $goal $kb $rb) - (case $goal ( - ((is $a $b) (let $a $b (is $a $b))) ;; prolog eval & assign - ((bool $expr) (if $expr $goal (empty))) ;; if predicate is a boolean. This might be unnecessary - ((eval $expr) (let $_ $expr True)) ;; if predicate is a boolean. This might be unnecessary - ((naf $expr) (if (has-match $kb $expr) (empty) $goal)) ;; negation-as-failure - ($_ (match $kb $goal $goal)) - )) -) +(progn ( -;; Recursive Case -(= (backward-chain2 $goal $kb $rb) - (match $rb ($goal :- $body) - (match-body $body $kb $rb $goal) - ) -) +; Query for the last element in a list + (query (last $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) -(: match-body (-> Atom Atom Atom Atom Atom )) -;; do matching for each atom in the body, then returns goal -(= (match-body $body $kb $rb $goal) - (if (== $body ()) - $goal - (let* ( - (($cur $rest) (decons-atom $body)) - (() (println! (IN $cur $goal))) - ($cur (backward-chain $cur $kb $rb)) ;; chain on cur & unify back to propagate vars to $goal - (() (println! (OUT $cur $goal))) - ) - (match-body $rest $kb $rb $goal) - ) - ) -) +; Query for the length of a list + (query (length ($Cons 1 ($Cons 2 ($Cons 3 Nil))) $out)) -(: query (-> Atom Atom )) -; !(bind! &baseall (new-space)) -(= (query $goal) - (backward-chain $goal &self &self) -) +; Query for the sum of numbers up to 3 + (query (sum 3 $x)) -;;;;;;;;;;;;;;;;; -;; TEST query ;;; -;;;;;;;;;;;;;;;;;; +; Query for appending lists + (query (append ($Cons 1 ($Cons 2 Nil)) ($Cons 3 ($Cons 4 Nil)) $x)) + (query (append ($Cons 1 ($Cons 2 Nil)) $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) + (query (append $What $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) +;; Test list operations + (query (append ($Cons 1 Nil) ($Cons 2 ($Cons 3 Nil)) $Result)) ; Appending lists + (query (append ($Cons 1 ($Cons 2 Nil)) $Rest ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) ; Partial list append -; last element of list -!(query (last $x (Cons 1 (Cons 2 (Cons 3 Nil))))) +;; Negation as failure tests with bachelors and marital status + (query (bachelor $x)) ; Finds bachelors who are not married + (query-f (woman Tim)) ; Tests failure for a man labeled as a woman + (query (woman Jane)) ; Should succeed for Jane if defined as a woman + (query-f (woman $x)) ; Negative query for undefined women -;; length of list -!(query (length (Cons 1 (Cons 2 (Cons 3 Nil))) $out)) +;; Check if an element is a member of a list + (query (member 3 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ; Should succeed + (query-f (member 5 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ; Should fail, 5 is not in the list + (query (member $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ; Should find members one by one -;; sum up to 3 -!(query (sum 3 $x)) +;; Query for basic arithmetic + (query (is $x (+ 1 1))) ; $x should be assigned 2 -;; append (multi-directional) -!(query (append (Cons 1 (Cons 2 Nil)) (Cons 3 (Cons 4 Nil)) $x)) -!(query (append (Cons 1 (Cons 2 Nil)) $Out (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil)))))) -!(query (append $What $Out (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil)))))) +;; Query for natural number indexing + (query (nat-nth (S (S Z)) (SomethingAtThird $1 $2) Third)) ; Should find the third element -;; Negation as failure test -!(query (bachelor $x)) -!(query (woman Tim)) ;; should be no -!(query (woman Jane)) ;; should succeed -!(query (woman $x)) ;; should be no +))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ADDITIONAL TEST QUERIES ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Check if an element is a member of a list -;!(query (member 3 (Cons 1 (Cons 2 (Cons 3 Nil))))) -;!(query (member 5 (Cons 1 (Cons 2 (Cons 3 Nil))))) ;; Should fail -;!(query (member $x (Cons 1 (Cons 2 (Cons 3 Nil))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; SOLVING FOR THE ZEBRA OWNER ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -!(query (backward-chain (zebra-owner $Owner) &self &self)) ;; Solve for $Owner - -;; Query for the zebra owner (who owns the fish) -!(query (zebra-owner $Owner)) ;; Solves for the owner of the fish -!(query (declare nationality $Brit brit)) +;; Solve the zebra-owner problem (Who owns the fish?) +!(query (zebra-owner $Owner)) ; Should find the owner of the fish -!(get-state &exists-props) -!(get-state &neighborhood) +;; Basic declaration tests +;!(query (declare nationality $Brit brit)) ; Tests nationality declaration +;!(query (something-existing $Exists)) ; Tests if an entity exists in the context -!(query (something-existing $Exists)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ADDITIONAL LOGICAL RELATIONSHIPS ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Verify properties related to the zebra-owner problem; +;!(query (declare nationality $Owner norwegian)) ; Declare that $Owner is Norwegian -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ADDITIONAL LOGICAL RELATIONSHIP QUERIES ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Verify properties related to the zebra-owner problem -!(query (declare nationality $Owner norwegian)) +!(query (is $x (+ 1 1))) +!(query (same $ctx ($Houses $Props))) +!(query (context $ctx)) diff --git a/tests/zebra/zebra2.metta b/tests/zebra/zebra2.metta index fe42fcf645d..c3a9946ae0f 100644 --- a/tests/zebra/zebra2.metta +++ b/tests/zebra/zebra2.metta @@ -1,69 +1,112 @@ + +!(import! &self dv-pl) + +; Initialize a new state for exists-props +; !(bind! &exists-props (new-state Nil)) +((context5 $ctx) :- + ( + + ; Define the structure of $Houses and initialize it + (same $Houses + (Places (House $_1 $_2) + (Places (House $_3 $_4) + (Places (House $_5 $_6) + (Places (House $_7 $_8) + (Places (House $_9 $_10) Nil)))))) + + (set-global &neighborhood $Houses) + + ; Define $Props structure for all properties + (same $Props + (Props nationality + (Props color + (Props pet + (Props drink + (Props smokes Nil)))))) + + + ; Ensure $Props represents a specific structure + (same $Props (Props $_H6 $_T6)) + ; Ensure $ctx is a combination of $Houses and $Props + (same $ctx ($Houses $Props)) + + ; Declare numerical properties for various attributes in the context + (get-declare-num nationality $Num1) + (get-declare-num color $Num2) + (get-declare-num pet $Num3) + (get-declare-num drink $Num4) + (get-declare-num drink $Num5) ; this should not change the context since its already there + (get-declare-num smokes $Num6))) + + ;; Main predicate to find the owner of the fish -(zebra-owner $Owner) :- - ((init-houses (S (S (S (S (S Z)))))) - (set-global &exists-props Nil) +((zebra-owner $Owner) :- + ( + (set-global &exists-props $_Props) + (init-houses (S (S (S (S (S Z)))))) + + + ;; Clue 8: The man in the center house drinks milk + (center-house $CenterHouse) + (declare drink $CenterHouse milk) + + ;; Clue 9: The Norwegian lives in the first house + (first-house $FirstHouse) + (declare nationality $FirstHouse norwegian) + + ;; Clue 14: The Norwegian lives next to the blue house + (declare nationality $Norwegian norwegian) + (next-to $Norwegian $HouseBlue) + (declare color $HouseBlue blue) - ;; Clue 1: The Brit lives in the red house. + ;; Clue 1: The Brit lives in the red house (declare nationality $Brit brit) (declare color $Brit red) - ;; Clue 2: The Swede keeps dogs as pets. + ;; Clue 2: The Swede keeps dogs as pets (declare nationality $Swede swede) (declare pet $Swede dog) - ;; Clue 3: The Dane drinks tea. + ;; Clue 3: The Dane drinks tea (declare nationality $Dane dane) (declare drink $Dane tea) - ;; Clue 4: The green house is immediately to the left of the white house. + ;; Clue 4: The green house is immediately to the left of the white house (left-of $Green $White) (declare color $Green green) (declare color $White white) - ;; Clue 5: The owner of the green house drinks coffee. + ;; Clue 5: The owner of the green house drinks coffee (declare color $Green green) (declare drink $Green coffee) - ;; Clue 6: The person who smokes Pall Mall rears birds. + ;; Clue 6: The person who smokes Pall Mall rears birds (declare smokes $PallMallSmoker pallmall) (declare pet $PallMallSmoker birds) - ;; Clue 7: The owner of the yellow house smokes Dunhill. + ;; Clue 7: The owner of the yellow house smokes Dunhill (declare color $Yellow yellow) (declare smokes $Yellow dunhill) - ;; Clue 8: The man living in the center house drinks milk. - (center-house $CenterHouse) - (declare drink $CenterHouse milk) - - ;; Clue 9: The Norwegian lives in the first house. - (first-house $FirstHouse) - (declare nationality $FirstHouse norwegian) - - ;; Clue 10: The man who smokes Blends lives next to the one who keeps cats. + ;; Clue 10: The man who smokes Blends lives next to the one who keeps cats (declare smokes $SmokesBlends blends) (next-to $SmokesBlends $HouseCat) (declare pet $HouseCat cat) - ;; Clue 11: The man who keeps horses lives next to the man who smokes Dunhill. + ;; Clue 11: The man who keeps horses lives next to the man who smokes Dunhill (declare pet $HorseKeeper horse) (next-to $HorseKeeper $SmokesDunhills) (declare smokes $SmokesDunhills dunhill) - ;; Clue 12: The owner who smokes BlueMaster drinks beer. + ;; Clue 12: The owner who smokes BlueMaster drinks beer (declare smokes $SmokesBlueMaster bluemaster) (declare drink $SmokesBlueMaster beer) - ;; Clue 13: The German smokes Prince. + ;; Clue 13: The German smokes Prince (declare nationality $German german) (declare smokes $German prince) - ;; Clue 14: The Norwegian lives next to the blue house. - (declare nationality $Norwegian norwegian) - (next-to $Norwegian $HouseBlue) - (declare color $HouseBlue blue) - - ;; Clue 15: The man who smokes Blends has a neighbor who drinks water. + ;; Clue 15: The man who smokes Blends has a neighbor who drinks water (declare smokes $BlendsSmoker blends) (next-to $BlendsSmoker $WaterDrinker) (declare drink $WaterDrinker water) @@ -71,272 +114,100 @@ ;; Determine who owns the fish (declare pet $FishOwner fish) (declare nationality $FishOwner $Owner) -) +)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Helper predicates ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Initialize Houses as a list of uninitialized exists -(init-houses $Num) :- - ((make-houses $Num $Houses) - (set-global &neighborhood $Houses)) -(make-houses Z Nil) -(make-houses (S $N) (Cons $House $Rest)) :- - ((create-exists $House) - (make-houses $N $Rest)) - -(create-exists (Cons $_ $_1)) - - -;; Predicate: L is immediately to the left of R in the list -(left-of $L $R) :- - ((get-global &neighborhood $Houses) - (left-of-list $L $R $Houses)) - -(left-of-list $L $R (Cons $L (Cons $R $_))) -(left-of-list $L $R (Cons $_ $Rest)) :- - ((left-of-list $L $R $Rest)) - -;; Predicate: A and B are next to each other in the list -(next-to $A $B) :- - ((left-of $A $B)) -(next-to $A $B) :- - ((left-of $B $A)) - -;; Predicate to get the first house in the list -(first-house $First) :- - ((get-global &neighborhood $Houses) - (nat-nth Z $Houses $First)) - -;; Predicate to get the center house in the list -(center-house $Center) :- - ((get-global &neighborhood $Houses) - (nat-nth (S (S Z)) $Houses $Center)) +;; Initialize Houses as a list of uninitialized 'exists' +((init-houses $Num $Houses) :- + (make-houses $Num $Houses)) + +;; Recursive creation of houses list based on number +((make-houses (S $N) ($Cons $House $Rest)) :- + ((create-exists $House) ; Initialize a new 'exists' for the house + (make-houses $N $Rest))) ; Continue for the remaining houses +(make-houses Z Nil) ; Base case: no houses left to create + +;; Create an 'exists' structure for a house +(create-exists ($Cons $_1 $_1)) + +;; Predicate: $L is immediately to the left of $R in the list +((left-of $L $R) :- + ((get-global &neighborhood $Houses) ; Verify context contains the houses list + (left-of-list $L $R $Houses))) + +;; Helper for 'left-of' within a list structure +(left-of-list $L $R ($Cons $L ($Cons $R $_1))) ; Base case: $L is followed by $R +((left-of-list $L $R ($Cons $_1 $Rest)) :- + ((left-of-list $L $R $Rest))) ; Recursive case: continue checking the list + +;; Predicate: $A and $B are next to each other in the list +((next-to $A $B) :- + ((left-of $A $B))) ; $A is left of $B +((next-to $A $B) :- + ((left-of $B $A))) ; $B is left of $A + +;; Predicate: Get the first house in the list +((first-house $First) :- + ((get-global &neighborhood $Houses) ; Verify context contains houses + (nat-nth Z $Houses $First))) ; First element (index 0) + +;; Predicate: Get the center house in the list +((center-house $Center) :- + ((get-global &neighborhood $Houses) ; Verify context contains houses + (nat-nth (S (S Z)) $Houses $Center))) ; Center element for 5 houses ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Property handling predicates ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; General property declaration predicate -(declare $PropName $Exists $PropValue) :- - ((prop $PropName $Exists $PropValue)) - -(prop $PropName $Object $PropValue) :- - ((get-prop-num $PropName $Num) - (nat-nth $Num $Object $PropValue) - (something-existing $Object)) +((declare $PropName $Object $PropValue) :- + ((get-declare-num $PropName $Num) ; Get position for the property + (nat-nth $Num $Template $PropValue) ; Assign value to property + (something-existing $Exists) ; Ensure object exists in houses + (same $Template $Exists) (same $Template $Object))) -;; Ensure Exists is a member of Houses -(something-existing $Exists) :- - ((get-global &neighborhood $Houses) - (member $Exists $Houses)) +;; Ensure $Exists is a member of Houses +((something-existing $Exists) :- + ((get-global &neighborhood $Houses) ; Verify context contains houses + (member $Exists $Houses))) ; Check if $Exists is in houses -;; Member predicate for lists -(member $Elem (Cons $Elem $_)) -(member $Elem (Cons $_ $Tail)) :- - ((member $Elem $Tail)) ;; Map property names to their positions (numbers) -(get-prop-num $PropName $Num) :- - ((get-global &exists-props $PropList) - (prop-index $PropName $PropList Z $Num)) - -(prop-index $PropName (Cons $PropName $_) $Num $Num) -(prop-index $PropName (Cons $_ $Rest) $Acc $Num) :- - ((prop-index $PropName $Rest (S $Acc) $Num)) -(prop-index $PropName Nil $Acc $Acc) :- ;; If property not found, add it - ((get-global &exists-props $PropList) - (append $PropList (Cons $PropName Nil) $NewPropList) - (set-global &exists-props $NewPropList)) - -;; Zero-based nat-nth predicate -(nat-nth Z ($Cons $Elem $_) $Elem) -((nat-nth (S $N) ($Cons $_ $Rest) $Elem) :- - ((nat-nth $N $Rest $Elem))) - -;; Append two lists -(cons-append Nil $List2 $List2) -((cons-append ($Cons $H $T) $List2 ($Cons $H $T2)) :- - ((cons-append $T $List2 $T2))) - - -(same $x $x) - -;; last of list -(last $x ($Cons $x Nil)) -((last $x ($Cons $_ $rest)) :- ( (last $x $rest) ) ) - -;; length list -(length Nil 0) -((length ($Cons $x $rest) $out) :- - ((length $rest $out2) - (is $out (+ $out2 1)))) - -;; sum from 0 to n -(sum 0 0) -((sum $n $s) :- ( - (bool (> $n 0)) - (is $n1 (- $n 1)) - (sum $n1 $s1) - (is $s (+ $n $s1)) -)) +((get-declare-num $PropName $Num) :- + ((get-global &exists-props $PropList) ; Extract property list from context + (declare-index $PropName $PropList Z $Num) ; Get index of property + (set-global &exists-props $PropList))) ; Set index of property -;; list append -(append Nil $L $L) -((append (Cons $H $T) $L (Cons $H $R)) :- ( - (append $T $L $R) -)) +;; Map property names using manual declaration with incremental indexing +(declare-index $PropName ($Cons $PropName $_1) $Num $Num) ; Found property +((declare-index $PropName ($Cons $Nonvar $Rest) $Acc $Num) :- + ((nonvar $Nonvar) (declare-index $PropName $Rest (S $Acc) $Num))) ; Increment index -;; negation as failure test -((bachelor $x) :- ( - (man $x) - (naf (married $x)) -)) -(man John) (man Tim) -(married Tim) -((woman $x) :- ( - (naf (man $x)) -)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ADDITIONAL TEST QUERIES ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(: cur= (-> Atom Atom)) -(: retVal= (-> Atom Atom)) -(: goal= (-> Atom Atom)) - -(: backward-chain (-> Atom Atom Atom Atom Atom)) -(: backward-chain-q (-> Atom Atom Atom Atom Atom)) -(: match-body (-> Atom Atom Atom Atom Atom Atom)) -(: has-match (-> Atom Atom Bool)) -(: has-fundef (-> Atom Atom Bool)) -;; First-order logic backward chainer using match - - -(: Z Nat) -(: S (-> Nat Nat)) - -(: nat-equal (-> Nat Nat Bool)) -(= (nat-equal $A $A) True) - -(: equalz (-> Atom Atom Bool)) -(= (equalz $A $A) True) - -(: quote-equalz (-> Atom Atom Bool)) -(= (quote-equalz $A $A) True) -(= (quote-equalz $A $B) (equalz (quote $A) $B)) -(= (quote-equalz $A $B) (equalz $A (quote $B))) - -;; TODO: this is inefficient, we just need at least 1 match -(= (has-match $space $g) - (let $m (collapse (match $space $g True)) - (if (== $m ()) - False - True - ) - ) -) -(= (has-fundef $space $g) - (let $m (collapse (match $space (= $g $_) True)) - (if (== $m ()) - False - True - ) - ) -) - - -(= (backward-chain $info $goal $kb $rb) - (backward-chain-q $info (quote $goal) $kb $rb)) - -;; Base case -(= (backward-chain-q $info (quote $goal) $kb $rb) - (case (quote $goal) ( - ((quote (is $a $b)) (let $a $b (quote $goal))) ;; prolog eval & assign - ((quote (bool $expr)) (if $expr (quote $goal) (empty))) ;; if predicate is a boolean. This might be unnecessary - ((quote (eval= $a $expr)) (let $a $expr (quote $goal))) ;; if predicate is a boolean. This might be unnecessary - ((quote (nonvar $var)) (if (== Variable (get-metatype $var)) (empty) (quote $goal))) - ((quote (var $var)) (if (== Variable (get-metatype $var)) (quote $goal) (empty))) - ((quote (true)) (quote $goal)) - ((quote (fail)) (empty)) - ((quote (cut $_)) (if (equalz $info $goal) (quote $goal) (quote $goal))) - ((quote (naf $expr)) (if (has-match $kb $expr) (empty) (quote $goal))) ;; negation-as-failure - ($_ (match $kb $goal (quote $goal))) - )) -) - -;; Recursive Case -(= (backward-chain-q $info (quote $goal) $kb $rb) - (match $rb ($goal :- $body) - (match-body $info $body $kb $rb $goal)) -) - -(= (backward-chain $info (quote $goal) $kb $rb) - (if (has-fundef $kb $goal) $goal - (let $r $goal (if (equalz $r $goal) (empty) $r)))) - - -;; do matching for each atom in the body, then returns goal -(= (match-body $info $body $kb $rb $goal) - (if (== $body ()) - (quote $goal) - (let* ( - (($cur $rest) (decons-atom $body)) - (() (println! (IN (cur= $cur) (goal= $goal)))) - ($retVal (backward-chain $info $cur $kb $rb)) - ($m (collapse (equalz (quote $cur) $retVal))) - (() (if (== $m ()) (println! (BAD (cur= $cur) (retVal= $retVal))) ())) - ((quote $cur) $retVal) ;; chain on cur & unify back to propagate vars to $goal - (() (println! (OUT (cur= $cur) (goal= $goal)))) - ) - (match-body $info $rest $kb $rb $goal) - ) - ) -) - - -(: query (-> Atom Atom)) -; !(bind! &baseall (new-space)) -(= (query $goal) - (let $m (collapse (backward-chain $info $goal &self &self)) - (if (== $m ()) (Fail $goal) (Succeed $m))) -) -(: query-f (-> Atom Atom)) -(= (query-f $goal) - (let $m (collapse (backward-chain $info $goal &self &self)) - (if (== $m ()) Passed-Negation (Failed $m))) -) - -; last element of list -!(query (last $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) - -;; length of list -!(query (length ($Cons 1 ($Cons 2 ($Cons 3 Nil))) $out)) - -;; sum up to 3 -!(query (sum 3 $x)) - -;; append (multi-directional) -!(query (append ($Cons 1 ($Cons 2 Nil)) ($Cons 3 ($Cons 4 Nil)) $x)) -!(query (append ($Cons 1 ($Cons 2 Nil)) $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) -!(query (append $What $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) - -;; Negation as failure test -!(query (bachelor $x)) - -!(query-f (woman Tim)) ;; should be no -!(query (woman Jane)) ;; should succeed -!(query-f (woman $x)) ;; should be no +;; Solve the zebra-owner problem (Who owns the fish?) +!(query (zebra-owner $Owner)) ; Should find the owner of the fish +;; Basic declaration tests +;!(query (declare nationality $Brit brit)) ; Tests nationality declaration +;!(query (something-existing $Exists)) ; Tests if an entity exists in the context + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ADDITIONAL LOGICAL RELATIONSHIPS ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Verify properties related to the zebra-owner problem; +;!(query (declare nationality $Owner norwegian)) ; Declare that $Owner is Norwegian -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ADDITIONAL TEST QUERIES ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Check if an element is a member of a list -!(query (member 3 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) -!(query-f (member 5 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ;; Should fail -!(query (member $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) !(query (is $x (+ 1 1))) !(query (same $ctx ($Houses $Props))) diff --git a/tests/zebra/zebra3.metta b/tests/zebra/zebra3.metta index 03ad34c6e66..c3a9946ae0f 100644 --- a/tests/zebra/zebra3.metta +++ b/tests/zebra/zebra3.metta @@ -1,200 +1,215 @@ -!(add-logic - ;; Main predicate to find the owner of the fish - ((zebra-owner $Owner) - :- - ;; Initialize Houses and exists_props - (init-houses 5) - (set-global 'exists-props nil) - - ;; Clue 1: The Brit lives in the red house. + +!(import! &self dv-pl) + +; Initialize a new state for exists-props +; !(bind! &exists-props (new-state Nil)) +((context5 $ctx) :- + ( + + ; Define the structure of $Houses and initialize it + (same $Houses + (Places (House $_1 $_2) + (Places (House $_3 $_4) + (Places (House $_5 $_6) + (Places (House $_7 $_8) + (Places (House $_9 $_10) Nil)))))) + + (set-global &neighborhood $Houses) + + ; Define $Props structure for all properties + (same $Props + (Props nationality + (Props color + (Props pet + (Props drink + (Props smokes Nil)))))) + + + ; Ensure $Props represents a specific structure + (same $Props (Props $_H6 $_T6)) + ; Ensure $ctx is a combination of $Houses and $Props + (same $ctx ($Houses $Props)) + + ; Declare numerical properties for various attributes in the context + (get-declare-num nationality $Num1) + (get-declare-num color $Num2) + (get-declare-num pet $Num3) + (get-declare-num drink $Num4) + (get-declare-num drink $Num5) ; this should not change the context since its already there + (get-declare-num smokes $Num6))) + + +;; Main predicate to find the owner of the fish +((zebra-owner $Owner) :- + ( + (set-global &exists-props $_Props) + (init-houses (S (S (S (S (S Z)))))) + + + ;; Clue 8: The man in the center house drinks milk + (center-house $CenterHouse) + (declare drink $CenterHouse milk) + + ;; Clue 9: The Norwegian lives in the first house + (first-house $FirstHouse) + (declare nationality $FirstHouse norwegian) + + ;; Clue 14: The Norwegian lives next to the blue house + (declare nationality $Norwegian norwegian) + (next-to $Norwegian $HouseBlue) + (declare color $HouseBlue blue) + + ;; Clue 1: The Brit lives in the red house (declare nationality $Brit brit) (declare color $Brit red) - ;; Clue 2: The Swede keeps dogs as pets. + ;; Clue 2: The Swede keeps dogs as pets (declare nationality $Swede swede) (declare pet $Swede dog) - ;; Clue 3: The Dane drinks tea. + ;; Clue 3: The Dane drinks tea (declare nationality $Dane dane) (declare drink $Dane tea) - ;; Clue 4: The green house is immediately to the left of the white house. + ;; Clue 4: The green house is immediately to the left of the white house (left-of $Green $White) (declare color $Green green) (declare color $White white) - ;; Clue 5: The owner of the green house drinks coffee. + ;; Clue 5: The owner of the green house drinks coffee (declare color $Green green) (declare drink $Green coffee) - ;; Clue 6: The person who smokes Pall Mall rears birds. + ;; Clue 6: The person who smokes Pall Mall rears birds (declare smokes $PallMallSmoker pallmall) (declare pet $PallMallSmoker birds) - ;; Clue 7: The owner of the yellow house smokes Dunhill. + ;; Clue 7: The owner of the yellow house smokes Dunhill (declare color $Yellow yellow) (declare smokes $Yellow dunhill) - ;; Clue 8: The man living in the center house drinks milk. - (center-house $CenterHouse) - (declare drink $CenterHouse milk) - - ;; Clue 9: The Norwegian lives in the first house. - (first-house $FirstHouse) - (declare nationality $FirstHouse norwegian) - - ;; Clue 10: The man who smokes Blends lives next to the one who keeps cats. + ;; Clue 10: The man who smokes Blends lives next to the one who keeps cats (declare smokes $SmokesBlends blends) (next-to $SmokesBlends $HouseCat) (declare pet $HouseCat cat) - ;; Clue 11: The man who keeps horses lives next to the man who smokes Dunhill. + ;; Clue 11: The man who keeps horses lives next to the man who smokes Dunhill (declare pet $HorseKeeper horse) (next-to $HorseKeeper $SmokesDunhills) (declare smokes $SmokesDunhills dunhill) - ;; Clue 12: The owner who smokes BlueMaster drinks beer. + ;; Clue 12: The owner who smokes BlueMaster drinks beer (declare smokes $SmokesBlueMaster bluemaster) (declare drink $SmokesBlueMaster beer) - ;; Clue 13: The German smokes Prince. + ;; Clue 13: The German smokes Prince (declare nationality $German german) (declare smokes $German prince) - ;; Clue 14: The Norwegian lives next to the blue house. - (declare nationality $Norwegian norwegian) - (next-to $Norwegian $HouseBlue) - (declare color $HouseBlue blue) - - ;; Clue 15: The man who smokes Blends has a neighbor who drinks water. + ;; Clue 15: The man who smokes Blends has a neighbor who drinks water (declare smokes $BlendsSmoker blends) (next-to $BlendsSmoker $WaterDrinker) (declare drink $WaterDrinker water) - ;; Determine who owns the fish + ;; Determine who owns the fish (declare pet $FishOwner fish) (declare nationality $FishOwner $Owner) - )) - -;; Initialize Houses as a list of uninitialized exists -!(add-logic - ((init-houses $Num) - :- - (make-houses $Num $Houses) - (set-global 'neighborhood $Houses))) - -!(add-logic - ((make-houses 0 nil)) - ((make-houses $N (Cons $House $Rest)) - :- - (> $N 0) - (- $N 1 $N1) - (create-exists $House) - (make-houses $N1 $Rest))) - -!(add-logic - ((create-exists (Cons _ _)))) +)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Helper predicates +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Initialize Houses as a list of uninitialized 'exists' +((init-houses $Num $Houses) :- + (make-houses $Num $Houses)) -;; Predicate: L is immediately to the left of R in the list -!(add-logic - ((left-of $L $R) - :- - (get-global 'neighborhood $Houses) +;; Recursive creation of houses list based on number +((make-houses (S $N) ($Cons $House $Rest)) :- + ((create-exists $House) ; Initialize a new 'exists' for the house + (make-houses $N $Rest))) ; Continue for the remaining houses +(make-houses Z Nil) ; Base case: no houses left to create + +;; Create an 'exists' structure for a house +(create-exists ($Cons $_1 $_1)) + +;; Predicate: $L is immediately to the left of $R in the list +((left-of $L $R) :- + ((get-global &neighborhood $Houses) ; Verify context contains the houses list (left-of-list $L $R $Houses))) -!(add-logic - ((left-of-list $L $R (Cons $L (Cons $R _)))) - ((left-of-list $L $R (Cons _ $Rest)) - :- - (left-of-list $L $R $Rest))) - -;; Predicate: A and B are next to each other in the list -!(add-logic - ((next-to $A $B) - :- - (left-of $A $B)) - ((next-to $A $B) - :- - (left-of $B $A))) - -;; Predicate to get the first house in the list -!(add-logic - ((first-house $First) - :- - (get-global 'neighborhood $Houses) - (nth 0 $Houses $First))) - -;; Predicate to get the center house in the list -!(add-logic - ((center-house $Center) - :- - (get-global 'neighborhood $Houses) - (nth 2 $Houses $Center))) +;; Helper for 'left-of' within a list structure +(left-of-list $L $R ($Cons $L ($Cons $R $_1))) ; Base case: $L is followed by $R +((left-of-list $L $R ($Cons $_1 $Rest)) :- + ((left-of-list $L $R $Rest))) ; Recursive case: continue checking the list + +;; Predicate: $A and $B are next to each other in the list +((next-to $A $B) :- + ((left-of $A $B))) ; $A is left of $B +((next-to $A $B) :- + ((left-of $B $A))) ; $B is left of $A + +;; Predicate: Get the first house in the list +((first-house $First) :- + ((get-global &neighborhood $Houses) ; Verify context contains houses + (nat-nth Z $Houses $First))) ; First element (index 0) + +;; Predicate: Get the center house in the list +((center-house $Center) :- + ((get-global &neighborhood $Houses) ; Verify context contains houses + (nat-nth (S (S Z)) $Houses $Center))) ; Center element for 5 houses +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Property handling predicates +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; General property declaration predicate -!(add-logic - ((declare $PropName $Exists $PropValue) - :- - (prop $PropName $Exists $PropValue))) - -!(add-logic - ((prop $PropName $Object $PropValue) - :- - (get-prop-num $PropName $Num) - (nth $Num $Object $PropValue) - (something-existing $Object))) - -;; Ensure Exists is a member of Houses -!(add-logic - ((something-existing $Exists) - :- - (get-global 'neighborhood $Houses) - (member $Exists $Houses))) - -;; Member predicate for lists -!(add-logic - ((member $Elem (Cons $Elem _))) - ((member $Elem (Cons _ $Tail)) - :- - (member $Elem $Tail))) +((declare $PropName $Object $PropValue) :- + ((get-declare-num $PropName $Num) ; Get position for the property + (nat-nth $Num $Template $PropValue) ; Assign value to property + (something-existing $Exists) ; Ensure object exists in houses + (same $Template $Exists) (same $Template $Object))) + +;; Ensure $Exists is a member of Houses +((something-existing $Exists) :- + ((get-global &neighborhood $Houses) ; Verify context contains houses + (member $Exists $Houses))) ; Check if $Exists is in houses + ;; Map property names to their positions (numbers) -!(add-logic - ((get-prop-num $PropName $Num) - :- - (get-global 'exists-props $PropList) - (prop-index $PropName $PropList 0 $Num))) - -!(add-logic - ((prop-index $PropName (Cons $PropName _) $Num $Num)) - ((prop-index $PropName (Cons _ $Rest) $Acc $Num) - :- - (+ $Acc 1 $Acc1) - (prop-index $PropName $Rest $Acc1 $Num)) - ((prop-index $PropName nil $Acc $Acc) - :- - ;; If property not found, add it - (get-global 'exists-props $PropList) - (append $PropList (list $PropName) $NewPropList) - (set-global 'exists-props $NewPropList))) - -;; Zero-based nth predicate -!(add-logic - ((nth 0 (Cons $Elem _) $Elem)) - ((nth $N (Cons _ $Rest) $Elem) - :- - (> $N 0) - (- $N 1 $N1) - (nth $N1 $Rest $Elem))) - -;; Append two lists -!(add-logic - ((append nil $List2 $List2)) - ((append (Cons $H $T) $List2 (Cons $H $T2)) - :- - (append $T $List2 $T2))) +((get-declare-num $PropName $Num) :- + ((get-global &exists-props $PropList) ; Extract property list from context + (declare-index $PropName $PropList Z $Num) ; Get index of property + (set-global &exists-props $PropList))) ; Set index of property + +;; Map property names using manual declaration with incremental indexing +(declare-index $PropName ($Cons $PropName $_1) $Num $Num) ; Found property +((declare-index $PropName ($Cons $Nonvar $Rest) $Acc $Num) :- + ((nonvar $Nonvar) (declare-index $PropName $Rest (S $Acc) $Num))) ; Increment index + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ADDITIONAL TEST QUERIES ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;; Solve the zebra-owner problem (Who owns the fish?) +!(query (zebra-owner $Owner)) ; Should find the owner of the fish + +;; Basic declaration tests +;!(query (declare nationality $Brit brit)) ; Tests nationality declaration +;!(query (something-existing $Exists)) ; Tests if an entity exists in the context + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ADDITIONAL LOGICAL RELATIONSHIPS ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Verify properties related to the zebra-owner problem; +;!(query (declare nationality $Owner norwegian)) ; Declare that $Owner is Norwegian + + + +!(query (is $x (+ 1 1))) +!(query (same $ctx ($Houses $Props))) +!(query (context $ctx)) diff --git a/tests/zebra/zebra4.metta b/tests/zebra/zebra4.metta deleted file mode 100644 index 6d532005124..00000000000 --- a/tests/zebra/zebra4.metta +++ /dev/null @@ -1,162 +0,0 @@ -;; Main predicate to find the owner of the fish -(zebra-owner $Owner) :- - ((init-houses (S (S (S (S (S Z)))))) - (set-global &exists-props Nil) - - ;; Clue 1: The Brit lives in the red house. - (declare nationality $Brit brit) - (declare color $Brit red) - - ;; Clue 2: The Swede keeps dogs as pets. - (declare nationality $Swede swede) - (declare pet $Swede dog) - - ;; Clue 3: The Dane drinks tea. - (declare nationality $Dane dane) - (declare drink $Dane tea) - - ;; Clue 4: The green house is immediately to the left of the white house. - (left-of $Green $White) - (declare color $Green green) - (declare color $White white) - - ;; Clue 5: The owner of the green house drinks coffee. - (declare color $Green green) - (declare drink $Green coffee) - - ;; Clue 6: The person who smokes Pall Mall rears birds. - (declare smokes $PallMallSmoker pallmall) - (declare pet $PallMallSmoker birds) - - ;; Clue 7: The owner of the yellow house smokes Dunhill. - (declare color $Yellow yellow) - (declare smokes $Yellow dunhill) - - ;; Clue 8: The man living in the center house drinks milk. - (center-house $CenterHouse) - (declare drink $CenterHouse milk) - - ;; Clue 9: The Norwegian lives in the first house. - (first-house $FirstHouse) - (declare nationality $FirstHouse norwegian) - - ;; Clue 10: The man who smokes Blends lives next to the one who keeps cats. - (declare smokes $SmokesBlends blends) - (next-to $SmokesBlends $HouseCat) - (declare pet $HouseCat cat) - - ;; Clue 11: The man who keeps horses lives next to the man who smokes Dunhill. - (declare pet $HorseKeeper horse) - (next-to $HorseKeeper $SmokesDunhills) - (declare smokes $SmokesDunhills dunhill) - - ;; Clue 12: The owner who smokes BlueMaster drinks beer. - (declare smokes $SmokesBlueMaster bluemaster) - (declare drink $SmokesBlueMaster beer) - - ;; Clue 13: The German smokes Prince. - (declare nationality $German german) - (declare smokes $German prince) - - ;; Clue 14: The Norwegian lives next to the blue house. - (declare nationality $Norwegian norwegian) - (next-to $Norwegian $HouseBlue) - (declare color $HouseBlue blue) - - ;; Clue 15: The man who smokes Blends has a neighbor who drinks water. - (declare smokes $BlendsSmoker blends) - (next-to $BlendsSmoker $WaterDrinker) - (declare drink $WaterDrinker water) - - ;; Determine who owns the fish - (declare pet $FishOwner fish) - (declare nationality $FishOwner $Owner) -) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Helper predicates -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Initialize Houses as a list of uninitialized exists -(init-houses $Num) :- - ((make-houses $Num $Houses) - (set-global &neighborhood $Houses)) - -(make-houses Z Nil) -(make-houses (S $N) (Cons $House $Rest)) :- - ((create-exists $House) - (make-houses $N $Rest)) - -(create-exists (Cons $_ $_1)) - - -;; Predicate: L is immediately to the left of R in the list -(left-of $L $R) :- - ((get-global &neighborhood $Houses) - (left-of-list $L $R $Houses)) - -(left-of-list $L $R (Cons $L (Cons $R $_))) -(left-of-list $L $R (Cons $_ $Rest)) :- - ((left-of-list $L $R $Rest)) - -;; Predicate: A and B are next to each other in the list -(next-to $A $B) :- - ((left-of $A $B)) -(next-to $A $B) :- - ((left-of $B $A)) - -;; Predicate to get the first house in the list -(first-house $First) :- - ((get-global &neighborhood $Houses) - (nat-nth Z $Houses $First)) - -;; Predicate to get the center house in the list -(center-house $Center) :- - ((get-global &neighborhood $Houses) - (nat-nth (S (S Z)) $Houses $Center)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Property handling predicates -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; General property declaration predicate -(declare $PropName $Exists $PropValue) :- - ((prop $PropName $Exists $PropValue)) - -(prop $PropName $Object $PropValue) :- - ((get-prop-num $PropName $Num) - (nat-nth $Num $Object $PropValue) - (something-existing $Object)) - -;; Ensure Exists is a member of Houses -(something-existing $Exists) :- - ((get-global &neighborhood $Houses) - (member $Exists $Houses)) - -;; Member predicate for lists -(member $Elem (Cons $Elem $_)) -(member $Elem (Cons $_ $Tail)) :- - ((member $Elem $Tail)) - -;; Map property names to their positions (numbers) -(get-prop-num $PropName $Num) :- - ((get-global &exists-props $PropList) - (prop-index $PropName $PropList Z $Num)) - -(prop-index $PropName (Cons $PropName $_) $Num $Num) -(prop-index $PropName (Cons $_ $Rest) $Acc $Num) :- - ((prop-index $PropName $Rest (S $Acc) $Num)) -(prop-index $PropName Nil $Acc $Acc) :- ;; If property not found, add it - ((get-global &exists-props $PropList) - (append $PropList (Cons $PropName Nil) $NewPropList) - (set-global &exists-props $NewPropList)) - -;; Zero-based nat-nth predicate -(nat-nth Z (Cons $Elem $_) $Elem) -(nat-nth (S $N) (Cons $_ $Rest) $Elem) :- - ((nat-nth $N $Rest $Elem)) - -;; Append two lists -(append Nil $List2 $List2) -(append (Cons $H $T) $List2 (Cons $H $T2)) :- - ((append $T $List2 $T2)) - diff --git a/tests/zebra/zebra5_no_states.metta b/tests/zebra/zebra5_no_states.metta index a71bccc9175..01eb5130f2d 100644 --- a/tests/zebra/zebra5_no_states.metta +++ b/tests/zebra/zebra5_no_states.metta @@ -124,16 +124,16 @@ (make-houses Z Nil) ; Base case: no houses left to create ;; Create an 'exists' structure for a house -(create-exists ($Cons $_ $_1)) +(create-exists ($Cons $_1 $_2)) ;; Predicate: $L is immediately to the left of $R in the list ((left-of $L $R in the $ctx) :- - ((same $ctx ($Houses $_)) ; Verify context contains the houses list + ((same $ctx ($Houses $_1)) ; Verify context contains the houses list (left-of-list $L $R $Houses))) ;; Helper for 'left-of' within a list structure -(left-of-list $L $R ($Cons $L ($Cons $R $_))) ; Base case: $L is followed by $R -((left-of-list $L $R ($Cons $_ $Rest)) :- +(left-of-list $L $R ($Cons $L ($Cons $R $_1))) ; Base case: $L is followed by $R +((left-of-list $L $R ($Cons $_1 $Rest)) :- ((left-of-list $L $R $Rest))) ; Recursive case: continue checking the list ;; Predicate: $A and $B are next to each other in the list @@ -144,12 +144,12 @@ ;; Predicate: Get the first house in the list ((first-house $First in the $ctx) :- - ((same $ctx ($Houses $_)) ; Verify context contains houses + ((same $ctx ($Houses $_1)) ; Verify context contains houses (nat-nth Z $Houses $First))) ; First element (index 0) ;; Predicate: Get the center house in the list ((center-house $Center in the $ctx) :- - ((same $ctx ($Houses $_)) ; Verify context contains houses + ((same $ctx ($Houses $_1)) ; Verify context contains houses (nat-nth (S (S Z)) $Houses $Center))) ; Center element for 5 houses ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -165,27 +165,27 @@ ;; Ensure $Exists is a member of Houses ((something-existing $Exists in the $ctx) :- - ((same $ctx ($Houses $_)) ; Verify context contains houses + ((same $ctx ($Houses $_1)) ; Verify context contains houses (member $Exists $Houses))) ; Check if $Exists is in houses ;; Predicate: Check if an element is a member of a list -(member $Elem ($Cons $Elem $_)) ; Base case: element found -((member $Elem ($Cons $_ $Tail)) :- +(member $Elem ($Cons $Elem $_1)) ; Base case: element found +((member $Elem ($Cons $_1 $Tail)) :- ((member $Elem $Tail))) ; Recursive case: continue checking ;; Map property names to their positions (numbers) ((get-declare-num $PropName $Num in the $ctx) :- - ((same ($_ $PropList) $ctx);Extractpropertylistfromcontext + ((same ($_1 $PropList) $ctx);Extractpropertylistfromcontext (declare-index $PropName $PropList Z $Num)));Getindexofproperty ;; Map property names using manual declaration with incremental indexing -(declare-index $PropName ($Cons $PropName $_) $Num $Num) ; Found property +(declare-index $PropName ($Cons $PropName $_1) $Num $Num) ; Found property ((declare-index $PropName ($Cons $Nonvar $Rest) $Acc $Num) :- ((nonvar $Nonvar) (declare-index $PropName $Rest (S $Acc) $Num))) ; Increment index ;; Zero-based natural number indexing in lists -(nat-nth Z ($Cons $Elem $_) $Elem) ; Base case: first element -((nat-nth (S $N) ($Cons $_ $Rest) $Elem) :- +(nat-nth Z ($Cons $Elem $_1) $Elem) ; Base case: first element +((nat-nth (S $N) ($Cons $_1 $Rest) $Elem) :- ((nat-nth $N $Rest $Elem))) ; Recursive case: move to next element ;; Append two lists @@ -198,12 +198,12 @@ ;; Predicate to get the last element of a list (last $x ($Cons $x Nil)) ; Base case: last element -((last $x ($Cons $_ $rest)) :- +((last $x ($Cons $_1 $rest)) :- ((last $x $rest))) ; Recursive case: move to next element ;; Calculate length of a list (length Nil 0) ; Base case: empty list has length 0 -((length ($Cons $_ $rest) $out) :- +((length ($Cons $_1 $rest) $out) :- ((length $rest $out2) (is $out (+ $out2 1)))) ; Recursive case: increment length @@ -280,7 +280,7 @@ ;; Predicate to check if a function definition exists in a given space (= (has-fundef $space $g) - (let $m (collapse (match $space (= $g $_) True)) ; Match $g as a function in $space + (let $m (collapse (match $space (= $g $_1) True)) ; Match $g as a function in $space (if (== $m ()) ; If no match is found False ; Return False True ; Otherwise, return True @@ -302,9 +302,9 @@ ((quote (var $var)) (if (== Variable (get-metatype $var)) (quote $goal) (empty))) ; Variable check ((quote (true)) (quote $goal)) ; Always succeeds ((quote (fail)) (empty)) ; Always fails - ((quote (cut $_)) (if (equalz $info $goal) (quote $goal) (quote $goal))) ; Cut operator for pruning + ((quote (cut $_1)) (if (equalz $info $goal) (quote $goal) (quote $goal))) ; Cut operator for pruning ((quote (naf $expr)) (if (has-match $kb $expr) (empty) (quote $goal))) ; Negation as failure - ($_ (match $kb $goal (quote $goal))) ; Match against knowledge base + ($_1 (match $kb $goal (quote $goal))) ; Match against knowledge base )) ) diff --git a/tests/zebra/zebra6_no_states.metta b/tests/zebra/zebra6_no_states.metta deleted file mode 100644 index 241910105ab..00000000000 --- a/tests/zebra/zebra6_no_states.metta +++ /dev/null @@ -1,387 +0,0 @@ -; Initialize a new state for exists-props -; !(bind! &exists-props (new-state Nil)) -((context $ctx) :- - ( - - ; Ensure $Props represents a specific structure - (same $Props (Props $_H6 $_T6)) - ; Ensure $ctx is a combination of $Houses and $Props - (same $ctx ($Houses $Props)) - - ; Declare numerical properties for various attributes in the context - (get-declare-num nationality $Num1 in the $ctx) - (get-declare-num color $Num2 in the $ctx) - (get-declare-num pet $Num3 in the $ctx) - (get-declare-num drink $Num4 in the $ctx) - (get-declare-num drink $Num5 in the $ctx) ; this should not change the context since its already there - (get-declare-num smokes $Num6 in the $ctx))) - - -;; Main predicate to find the owner of the fish -((zebra-owner $Owner) :- - ( - ; Define the structure of $Houses and initialize it - (same $Houses - (Places (House $__202438 $_39) - (Places (House $__208019 $_1_208020) - (Places (House $_1968 $_11969))))) - - ; Define $Props structure for all properties - (same $Props - (Props nationality - (Props color - (Props pet - (Props drink - (Props smokes Nil)))))) - - ; Ensure the context is a combination of houses and properties - (same $ctx ($Houses $Props)) - - ;; Clue 1: The man in the center house drinks milk - (center-house $CenterHouse in the $ctx) - (declare drink $CenterHouse milk in the $ctx) - - ;; Clue 2: The Norwegian lives in the first house - (first-house $FirstHouse in the $ctx) - (declare nationality $FirstHouse norwegian in the $ctx) - - ;; Clue 3: The Norwegian lives next to the blue house - (declare nationality $Norwegian norwegian in the $ctx) - (next-to $Norwegian $HouseBlue in the $ctx) - (declare color $HouseBlue blue in the $ctx) - - ;; Clue 4: The Brit lives in the red house - (declare nationality $Brit brit in the $ctx) - (declare color $Brit red in the $ctx) - - ;; Clue 5: The Swede keeps dogs as pets - (declare nationality $Swede swede in the $ctx) - (declare pet $Swede dog in the $ctx) - - ;; Clue 6: The green house is next to the white house - (next-to $Green $White in the $ctx) - (declare color $Green green in the $ctx) - (declare color $White white in the $ctx) - - ;; Clue 7: The owner of the green house drinks coffee - (declare color $Green green in the $ctx) - (declare drink $Green coffee in the $ctx) - - ;; Clue 8: The owner who smokes Pall Mall keeps birds - (declare smokes $PallMallSmoker pallmall in the $ctx) - (declare pet $PallMallSmoker birds in the $ctx) - - ;; Clue 9: The man who smokes Blends lives next to the one who drinks tea - (declare smokes $SmokesBlends blends in the $ctx) - (next-to $SmokesBlends $TeaDrinker in the $ctx) - (declare drink $TeaDrinker tea in the $ctx) - - ;; Clue 10: The German smokes Prince - (declare nationality $German german in the $ctx) - (declare smokes $German prince in the $ctx) - - ;; Determine who owns the fish - (declare pet $FishOwner fish in the $ctx) - (declare nationality $FishOwner $Owner in the $ctx) - -)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Helper predicates -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Initialize Houses as a list of uninitialized 'exists' -((init-houses $Num $Houses) :- - (make-houses $Num $Houses)) - -;; Recursive creation of houses list based on number -((make-houses (S $N) ($Cons $House $Rest)) :- - ((create-exists $House) ; Initialize a new 'exists' for the house - (make-houses $N $Rest))) ; Continue for the remaining houses -(make-houses Z Nil) ; Base case: no houses left to create - -;; Create an 'exists' structure for a house -(create-exists ($Cons $_ $_1)) - -;; Predicate: $L is immediately to the left of $R in the list -((left-of $L $R in the $ctx) :- - ((same $ctx ($Houses $_)) ; Verify context contains the houses list - (left-of-list $L $R $Houses))) - -;; Helper for 'left-of' within a list structure -(left-of-list $L $R ($Cons $L ($Cons $R $_))) ; Base case: $L is followed by $R -((left-of-list $L $R ($Cons $_ $Rest)) :- - ((left-of-list $L $R $Rest))) ; Recursive case: continue checking the list - -;; Predicate: $A and $B are next to each other in the list -((next-to $A $B in the $ctx) :- - ((left-of $A $B in the $ctx))) ; $A is left of $B -((next-to $A $B in the $ctx) :- - ((left-of $B $A in the $ctx))) ; $B is left of $A - -;; Predicate: Get the first house in the list -((first-house $First in the $ctx) :- - ((same $ctx ($Houses $_)) ; Verify context contains houses - (nat-nth Z $Houses $First))) ; First element (index 0) - -;; Predicate: Get the center house in the list -((center-house $Center in the $ctx) :- - ((same $ctx ($Houses $_)) ; Verify context contains houses - (nat-nth (S Z) $Houses $Center))) ; Center element for 3 houses - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Property handling predicates -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; General property declaration predicate -((declare $PropName $Object $PropValue in the $ctx) :- - ((get-declare-num $PropName $Num in the $ctx) ; Get position for the property - (nat-nth $Num $Template $PropValue) ; Assign value to property - (something-existing $Exists in the $ctx) ; Ensure object exists in houses - (same $Template $Exists) (same $Template $Object))) - -;; Ensure $Exists is a member of Houses -((something-existing $Exists in the $ctx) :- - ((same $ctx ($Houses $_)) ; Verify context contains houses - (member $Exists $Houses))) ; Check if $Exists is in houses - -;; Predicate: Check if an element is a member of a list -(member $Elem ($Cons $Elem $_)) ; Base case: element found -((member $Elem ($Cons $_ $Tail)) :- - ((member $Elem $Tail))) ; Recursive case: continue checking - -;; Map property names to their positions (numbers) -((get-declare-num $PropName $Num in the $ctx) :- - ((same ($_ $PropList) $ctx);Extractpropertylistfromcontext - (declare-index $PropName $PropList Z $Num)));Getindexofproperty - -;; Map property names using manual declaration with incremental indexing -(declare-index $PropName ($Cons $PropName $_) $Num $Num) ; Found property -((declare-index $PropName ($Cons $Nonvar $Rest) $Acc $Num) :- - ((nonvar $Nonvar) (declare-index $PropName $Rest (S $Acc) $Num))) ; Increment index - -;; Zero-based natural number indexing in lists -(nat-nth Z ($Cons $Elem $_) $Elem) ; Base case: first element -((nat-nth (S $N) ($Cons $_ $Rest) $Elem) :- - ((nat-nth $N $Rest $Elem))) ; Recursive case: move to next element - -;; Append two lists -(cons-append Nil $List2 $List2) ; Base case: append empty list -((cons-append ($Cons $H $T) $List2 ($Cons $H $T2)) :- - ((cons-append $T $List2 $T2))) ; Recursive case: append remaining elements - -;; Predicate to check equality of two values -(same $x $x) - -;; Predicate to get the last element of a list -(last $x ($Cons $x Nil)) ; Base case: last element -((last $x ($Cons $_ $rest)) :- - ((last $x $rest))) ; Recursive case: move to next element - -;; Calculate length of a list -(length Nil 0) ; Base case: empty list has length 0 -((length ($Cons $_ $rest) $out) :- - ((length $rest $out2) - (is $out (+ $out2 1)))) ; Recursive case: increment length - -;; Calculate sum of natural numbers from 0 to $n -(sum 0 0) ; Base case: sum to 0 is 0 -((sum $n $s) :- ( - (bool (> $n 0)) ; Ensure $n is positive - (is $n1 (- $n 1)) ; Decrement $n - (sum $n1 $s1) ; Calculate sum for smaller range - (is $s (+ $n $s1)))) ; Add $n to sum of smaller range - -;; Predicate to append lists -(append Nil $L $L) ; Base case: appending an empty list -((append ($Cons $H $T) $L ($Cons $H $R)) :- ( - (append $T $L $R) ; Recursive case: append remaining elements -)) - -;; Negation as failure test -((bachelor $x) :- ( - (man $x) ; $x must be a man - (naf (married $x)) ; $x must not be married -)) - -; Facts: Men and marital status -(man John) (man Tim) -(married Tim) - -;; Predicate to define a woman -((woman $x) :- ( - (naf (man $x)) ; $x is a woman if not a man -)) - -;; Predicate signatures for backward chaining logic -(: cur= (-> Atom Atom)) ; Current goal -(: retVal= (-> Atom Atom)) ; Return value -(: goal= (-> Atom Atom)) ; Final goal - -;; Backward chaining logic -(: backward-chain (-> Atom Atom Atom Atom Atom)) -(: backward-chain-q (-> Atom Atom Atom Atom Atom)) -(: match-body (-> Atom Atom Atom Atom Atom Atom)) -(: has-match (-> Atom Atom Bool)) -(: has-fundef (-> Atom Atom Bool)) -;; First-order logic backward chainer using match - -;; Define natural numbers using Zero (Z) and Successor (S) -(: Z Nat) ; Base case for natural numbers (0) -(: S (-> Nat Nat)) ; Successor function for incrementing natural numbers - -;; Predicate for natural number equality -(: nat-equal (-> Nat Nat Bool)) ; Compares two natural numbers -(= (nat-equal $A $A) True) ; Two numbers are equal if they are identical - -;; Predicate for general atom equality -(: equalz (-> Atom Atom Bool)) ; Compares two atoms -(= (equalz $A $A) True) ; Atoms are equal if they are identical - -;; Predicate for quoted atom equality -(: quote-equalz (-> Atom Atom Bool)) ; Compares quoted atoms -(= (quote-equalz $A $A) True) ; Identical quoted atoms are equal -(= (quote-equalz $A $B) (equalz (quote $A) $B)) ; $A quoted matches $B -(= (quote-equalz $A $B) (equalz $A (quote $B))) ; $B quoted matches $A - -;; Match predicate: checks if a goal has at least one match in a space -;; This is less efficient, as it processes the entire space to find matches -(= (has-match $space $g) - (let $m (collapse (match $space $g True)) ; Attempt to match $g in $space - (if (== $m ()) ; If no match is found - False ; Return False - True ; Otherwise, return True - ) - ) -) - -;; Predicate to check if a function definition exists in a given space -(= (has-fundef $space $g) - (let $m (collapse (match $space (= $g $_) True)) ; Match $g as a function in $space - (if (== $m ()) ; If no match is found - False ; Return False - True ; Otherwise, return True - ) - ) -) - -;; Interface for backward chaining (quotes the arguement) -(= (backward-chain $info $goal $kb $rb) - (backward-chain-q $info (quote $goal) $kb $rb)) - -;; Handle specific cases during backward chaining -(= (backward-chain-q $info (quote $goal) $kb $rb) - (case (quote $goal) ( - ((quote (is $a $b)) (let $a $b (quote $goal))) ; Assignment - ((quote (bool $expr)) (if $expr (quote $goal) (empty))) ; Boolean evaluation - ((quote (eval= $a $expr)) (let $a $expr (quote $goal))) ; Expression evaluation - ((quote (nonvar $var)) (if (== Variable (get-metatype $var)) (empty) (quote $goal))) ; Non-variable check - ((quote (var $var)) (if (== Variable (get-metatype $var)) (quote $goal) (empty))) ; Variable check - ((quote (true)) (quote $goal)) ; Always succeeds - ((quote (fail)) (empty)) ; Always fails - ((quote (cut $_)) (if (equalz $info $goal) (quote $goal) (quote $goal))) ; Cut operator for pruning - ((quote (naf $expr)) (if (has-match $kb $expr) (empty) (quote $goal))) ; Negation as failure - ($_ (match $kb $goal (quote $goal))) ; Match against knowledge base - )) -) - -;; Recursive case for backward chaining -(= (backward-chain-q $info (quote $goal) $kb $rb) - (match $rb ($goal :- $body) - (match-body $info $body $kb $rb $goal)) -) - -(= (backward-chain-disabled $info (quote $goal) $kb $rb) - (if (has-fundef $kb $goal) $goal - (let $r $goal (if (equalz $r $goal) (empty) $r)))) - -;; Chain through each element in the body and return the goal -(= (match-body $info $body $kb $rb $goal) - (if (== $body ()) - (quote $goal) ; Base case: no more elements to match - (let* ( - (($cur $rest) (decons-atom $body)) ; Deconstruct body - (() (println! (IN (cur= $cur) (goal= $goal)))) ; Debugging: log input - ;($retVal (backward-chain $info $cur $kb $rb)) ; Recursive chaining - ;($m (collapse (equalz (quote $cur) $retVal))) ; Check match - ;(() (if (== $m ()) (println! (BAD!!!!!!!! (cur= $cur) (retVal= $retVal))) ())) - ;((quote $cur) $retVal) ; Unify variables - ((quote $cur) (backward-chain $info $cur $kb $rb)) ; Recursive chaining - (() (println! (OUT (cur= $cur) (goal= $goal)))) ; Debugging: log output - ) - (match-body $info $rest $kb $rb $goal) ; Continue matching - ) - ) -) - -;; Query execution logic -(: query (-> Atom Atom)) -(= (query $goal) - (let $m (collapse (backward-chain $info $goal &self &self)) - (if (== $m ()) (Fail $goal) (Succeed $m))) -) - -(: query-f (-> Atom Atom)) -(= (query-f $goal) - (let $m (collapse (backward-chain $info $goal &self &self)) - (if (== $m ()) Passed-Negation (Failed $m))) -) - -;;;;;;;;;;;;;;;;; -;; TEST Queries ;; -;;;;;;;;;;;;;;;;; - -; Query for the last element in a list -!(query (last $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) - -; Query for the length of a list -!(query (length ($Cons 1 ($Cons 2 ($Cons 3 Nil))) $out)) - -; Query for the sum of numbers up to 3 -!(query (sum 3 $x)) - -; Query for appending lists -!(query (append ($Cons 1 ($Cons 2 Nil)) ($Cons 3 ($Cons 4 Nil)) $x)) -!(query (append ($Cons 1 ($Cons 2 Nil)) $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) -!(query (append $What $Out ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) - -;; Negation as failure tests with bachelors and marital status -!(query (bachelor $x)) ; Finds bachelors who are not married -!(query-f (woman Tim)) ; Tests failure for a man labeled as a woman -!(query (woman Jane)) ; Should succeed for Jane if defined as a woman -!(query-f (woman $x)) ; Negative query for undefined women - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ADDITIONAL TEST QUERIES ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Check if an element is a member of a list -!(query (member 3 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ; Should succeed -!(query-f (member 5 ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ; Should fail, 5 is not in the list -!(query (member $x ($Cons 1 ($Cons 2 ($Cons 3 Nil))))) ; Should find members one by one - -;; Query for basic arithmetic -!(query (is $x (+ 1 1))) ; $x should be assigned 2 - -;; Query for natural number indexing -!(query (nat-nth (S (S Z)) (SomethingAtThird $1 $2) Third)) ; Should find the third element - -;; Solve the zebra-owner problem (Who owns the fish?) -!(query (zebra-owner $Owner)) ; Should find the owner of the fish - -;; Basic declaration tests -;!(query (declare nationality $Brit brit)) ; Tests nationality declaration -;!(query (something-existing $Exists)) ; Tests if an entity exists in the context - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ADDITIONAL LOGICAL RELATIONSHIPS ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Verify properties related to the zebra-owner problem; -;!(query (declare nationality $Owner norwegian)) ; Declare that $Owner is Norwegian - -;; Test list operations -;!(query (append ($Cons 1 Nil) ($Cons 2 ($Cons 3 Nil)) $Result)) ; Appending lists -;!(query (append ($Cons 1 ($Cons 2 Nil)) $Rest ($Cons 1 ($Cons 2 ($Cons 3 ($Cons 4 Nil)))))) ; Partial list append - - diff --git a/tests/zebra/zebra8_no_states.metta b/tests/zebra/zebra8_no_states.metta deleted file mode 100644 index 23969023b5e..00000000000 --- a/tests/zebra/zebra8_no_states.metta +++ /dev/null @@ -1,339 +0,0 @@ -; Initialize a new state for exists-props -; !(bind! &exists-props (new-state Nil)) -((context $ctx) :- - ( - - ; Ensure $Props represents a specific structure - (same $Props (Props $_H6 $_T6)) - ; Ensure $ctx is a combination of $Houses and $Props - (same $ctx ($Houses $Props)) - - ; Declare numerical properties for various attributes in the context - (get-declare-num nationality $Num1 in the $ctx) - (get-declare-num color $Num2 in the $ctx) - (get-declare-num pet $Num3 in the $ctx) - (get-declare-num drink $Num4 in the $ctx) - (get-declare-num drink $Num5 in the $ctx) ; this should not change the context since its already there - (get-declare-num smokes $Num6 in the $ctx))) - - -;; Main predicate to find the owner of the fish -((zebra-owner $Owner) :- - ( - ; Define the structure of $Houses and initialize it - (same $Houses - (Places (House $__202438 $_39) - (Places (House $__208019 $_1_208020)))) - - ; Define $Props structure for all properties - (same $Props - (Props nationality - (Props color - (Props pet - (Props drink - (Props smokes Nil)))))) - - ; Ensure the context is a combination of houses and properties - (same $ctx ($Houses $Props)) - - (is () (println! (Houses0= $ctx))) - - (same $FirstHouse (House $__202438 $_39)) - ;; Clue 1: The Norwegian lives in the first house - (first-house $FirstHouse in the $ctx) - (declare nationality $FirstHouse norwegian in the $ctx) - - (is () (println! (Houses1= $ctx))) - - ;; Clue 2: The Brit lives in the red house - (declare nationality $Brit brit in the $ctx) - (declare color $Brit red in the $ctx) - - (is () (println! (Houses2= $ctx))) - - ;; Clue 3: The owner of the blue house drinks tea - (declare color $BlueHouse blue in the $ctx) - (declare drink $BlueHouse tea in the $ctx) - - - (is () (println! (Houses3= $ctx))) - - ;; Clue 4: The owner of the red house keeps dogs - (declare color $RedHouse red in the $ctx) - (declare pet $RedHouse dog in the $ctx) - - ;; Clue 5: The owner of the tea-drinking house smokes Prince - (declare drink $TeaHouse tea in the $ctx) - (declare smokes $TeaHouse prince in the $ctx) - - ;; Determine who owns the fish - (declare pet $FishOwner fish in the $ctx) - (declare nationality $FishOwner $Owner in the $ctx) - -)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Helper predicates -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Initialize Houses as a list of uninitialized 'exists' -((init-houses $Num $Houses) :- - (make-houses $Num $Houses)) - -;; Recursive creation of houses list based on number -((make-houses (S $N) ($Cons $House $Rest)) :- - ((create-exists $House) ; Initialize a new 'exists' for the house - (make-houses $N $Rest))) ; Continue for the remaining houses -(make-houses Z Nil) ; Base case: no houses left to create - -;; Create an 'exists' structure for a house -(create-exists ($Cons $_ $_1)) - -;; Predicate: $L is immediately to the left of $R in the list -((left-of $L $R in the $ctx) :- - ((same $ctx ($Houses $_)) ; Verify context contains the houses list - (left-of-list $L $R $Houses))) - -;; Helper for 'left-of' within a list structure -(left-of-list $L $R ($Cons $L ($Cons $R $_))) ; Base case: $L is followed by $R -((left-of-list $L $R ($Cons $_ $Rest)) :- - ((left-of-list $L $R $Rest))) ; Recursive case: continue checking the list - -;; Predicate: $A and $B are next to each other in the list -((next-to $A $B in the $ctx) :- - ((left-of $A $B in the $ctx))) ; $A is left of $B -((next-to $A $B in the $ctx) :- - ((left-of $B $A in the $ctx))) ; $B is left of $A - -;; Predicate: Get the first house in the list -((first-house $First in the $ctx) :- - ((same $ctx ($Houses $_)) ; Verify context contains houses - (nat-nth Z $Houses $First))) ; First element (index 0) - -;; Predicate: Get the center house in the list -((center-house $Center in the $ctx) :- - ((same $ctx ($Houses $_)) ; Verify context contains houses - (nat-nth (S Z) $Houses $Center))) ; Center element for 3 houses - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Property handling predicates -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; General property declaration predicate -((declare $PropName $Object $PropValue in the $ctx) :- - ((get-declare-num $PropName $Num in the $ctx) ; Get position for the property - (nat-nth $Num $Template $PropValue) ; Assign value to property - (something-existing $Exists in the $ctx) ; Ensure object exists in houses - (same $Template $Exists) (same $Template $Object))) - -;; Ensure $Exists is a member of Houses -((something-existing $Exists in the $ctx) :- - ((same $ctx ($Houses $_)) ; Verify context contains houses - (member $Exists $Houses))) ; Check if $Exists is in houses - -;; Predicate: Check if an element is a member of a list -(member $Elem ($Cons $Elem $_)) ; Base case: element found -((member $Elem ($Cons $_ $Tail)) :- - ((member $Elem $Tail))) ; Recursive case: continue checking - -;; Map property names to their positions (numbers) -((get-declare-num $PropName $Num in the $ctx) :- - ((same ($_ $PropList) $ctx);Extractpropertylistfromcontext - (declare-index $PropName $PropList Z $Num)));Getindexofproperty - -;; Map property names using manual declaration with incremental indexing -(declare-index $PropName ($Cons $PropName $_) $Num $Num) ; Found property -((declare-index $PropName ($Cons $Nonvar $Rest) $Acc $Num) :- - ((nonvar $Nonvar) (declare-index $PropName $Rest (S $Acc) $Num))) ; Increment index - -;; Zero-based natural number indexing in lists -(nat-nth Z ($Cons $Elem $_) $Elem) ; Base case: first element -((nat-nth (S $N) ($Cons $_ $Rest) $Elem) :- - ((nat-nth $N $Rest $Elem))) ; Recursive case: move to next element - -;; Append two lists -(cons-append Nil $List2 $List2) ; Base case: append empty list -((cons-append ($Cons $H $T) $List2 ($Cons $H $T2)) :- - ((cons-append $T $List2 $T2))) ; Recursive case: append remaining elements - -;; Predicate to check equality of two values -(same $x $x) - -;; Predicate to get the last element of a list -(last $x ($Cons $x Nil)) ; Base case: last element -((last $x ($Cons $_ $rest)) :- - ((last $x $rest))) ; Recursive case: move to next element - -;; Calculate length of a list -(length Nil 0) ; Base case: empty list has length 0 -((length ($Cons $_ $rest) $out) :- - ((length $rest $out2) - (is $out (+ $out2 1)))) ; Recursive case: increment length - -;; Calculate sum of natural numbers from 0 to $n -(sum 0 0) ; Base case: sum to 0 is 0 -((sum $n $s) :- ( - (bool (> $n 0)) ; Ensure $n is positive - (is $n1 (- $n 1)) ; Decrement $n - (sum $n1 $s1) ; Calculate sum for smaller range - (is $s (+ $n $s1)))) ; Add $n to sum of smaller range - -;; Predicate to append lists -(append Nil $L $L) ; Base case: appending an empty list -((append ($Cons $H $T) $L ($Cons $H $R)) :- ( - (append $T $L $R) ; Recursive case: append remaining elements -)) - -;; Negation as failure test -((bachelor $x) :- ( - (man $x) ; $x must be a man - (naf (married $x)) ; $x must not be married -)) - -; Facts: Men and marital status -(man John) (man Tim) -(married Tim) - -;; Predicate to define a woman -((woman $x) :- ( - (naf (man $x)) ; $x is a woman if not a man -)) - -;; Predicate signatures for backward chaining logic -(: cur= (-> Atom Atom)) ; Current goal -(: retVal= (-> Atom Atom)) ; Return value -(: goal= (-> Atom Atom)) ; Final goal - -;; Backward chaining logic -(: backward-chain (-> Atom Atom Atom Atom Atom)) -(: backward-chain-q (-> Atom Atom Atom Atom Atom)) -(: match-body (-> Atom Atom Atom Atom Atom Atom)) -(: has-match (-> Atom Atom Bool)) -(: has-fundef (-> Atom Atom Bool)) -;; First-order logic backward chainer using match - -;; Define natural numbers using Zero (Z) and Successor (S) -(: Z Nat) ; Base case for natural numbers (0) -(: S (-> Nat Nat)) ; Successor function for incrementing natural numbers - -;; Predicate for natural number equality -(: nat-equal (-> Nat Nat Bool)) ; Compares two natural numbers -(= (nat-equal $A $A) True) ; Two numbers are equal if they are identical - -;; Predicate for general atom equality -(: equalz (-> Atom Atom Bool)) ; Compares two atoms -(= (equalz $A $A) True) ; Atoms are equal if they are identical - -;; Predicate for quoted atom equality -(: quote-equalz (-> Atom Atom Bool)) ; Compares quoted atoms -(= (quote-equalz $A $A) True) ; Identical quoted atoms are equal -(= (quote-equalz $A $B) (equalz (quote $A) $B)) ; $A quoted matches $B -(= (quote-equalz $A $B) (equalz $A (quote $B))) ; $B quoted matches $A - -;; Match predicate: checks if a goal has at least one match in a space -;; This is less efficient, as it processes the entire space to find matches -(= (has-match $space $g) - (let $m (collapse (match $space $g True)) ; Attempt to match $g in $space - (if (== $m ()) ; If no match is found - False ; Return False - True ; Otherwise, return True - ) - ) -) - -;; Predicate to check if a function definition exists in a given space -(= (has-fundef $space $g) - (let $m (collapse (match $space (= $g $_) True)) ; Match $g as a function in $space - (if (== $m ()) ; If no match is found - False ; Return False - True ; Otherwise, return True - ) - ) -) - -;; Interface for backward chaining (quotes the arguement) -(= (backward-chain $info $goal $kb $rb) - (backward-chain-q $info (quote $goal) $kb $rb)) - -;; Handle specific cases during backward chaining -(= (backward-chain-q $info (quote $goal) $kb $rb) - (case (quote $goal) ( - ((quote (is $a $b)) (let $a $b (quote $goal))) ; Assignment - ((quote (bool $expr)) (if $expr (quote $goal) (empty))) ; Boolean evaluation - ((quote (eval= $a $expr)) (let $a $expr (quote $goal))) ; Expression evaluation - ((quote (nonvar $var)) (if (== Variable (get-metatype $var)) (empty) (quote $goal))) ; Non-variable check - ((quote (var $var)) (if (== Variable (get-metatype $var)) (quote $goal) (empty))) ; Variable check - ((quote (true)) (quote $goal)) ; Always succeeds - ((quote (fail)) (empty)) ; Always fails - ((quote (cut $_)) (if (equalz $info $goal) (quote $goal) (quote $goal))) ; Cut operator for pruning - ((quote (naf $expr)) (if (has-match $kb $expr) (empty) (quote $goal))) ; Negation as failure - ($_ (match $kb $goal (quote $goal))) ; Match against knowledge base - )) -) - -;; Recursive case for backward chaining -(= (backward-chain-q $info (quote $goal) $kb $rb) - (match $rb ($goal :- $body) - (match-body $info $body $kb $rb $goal)) -) - -(= (backward-chain-disabled $info (quote $goal) $kb $rb) - (if (has-fundef $kb $goal) $goal - (let $r $goal (if (equalz $r $goal) (empty) $r)))) - -;; Chain through each element in the body and return the goal -(= (match-body $info $body $kb $rb $goal) - (if (== $body ()) - (quote $goal) ; Base case: no more elements to match - (let* ( - (($cur $rest) (decons-atom $body)) ; Deconstruct body - ;(() (println! (IN (cur= $cur) (goal= $goal)))) ; Debugging: log input - ;($retVal (backward-chain $info $cur $kb $rb)) ; Recursive chaining - ;($m (collapse (equalz (quote $cur) $retVal))) ; Check match - ;(() (if (== $m ()) (println! (BAD!!!!!!!! (cur= $cur) (retVal= $retVal))) ())) - ;((quote $cur) $retVal) ; Unify variables - ((quote $cur) (backward-chain $info $cur $kb $rb)) ; Recursive chaining - ;(() (println! (OUT (cur= $cur) (goal= $goal)))) ; Debugging: log output - ) - (match-body $info $rest $kb $rb $goal) ; Continue matching - ) - ) -) - -;; Query execution logic -(: query (-> Atom Atom)) -(= (query $goal) - (let $m (collapse (backward-chain $info $goal &self &self)) - (if (== $m ()) (Fail $goal) (Succeed $m))) -) - -(: query-f (-> Atom Atom)) -(= (query-f $goal) - (let $m (collapse (backward-chain $info $goal &self &self)) - (if (== $m ()) Passed-Negation (Failed $m))) -) - - -((solve-fish-owner $FishOwner) :- - ((same $Houses - (Cons ( 1 $_1 $_2 $_3 $_4 $_5) ; First house - (Cons ( 2 $_6 $_7 $_8 $_9 $_10) ; Second house - Nil))) - ; Clue 1: The Norwegian lives in the first house - (member ( 1 norwegian $_11 $_12 $_13 $_14) $Houses) - ; Clue 2: The Brit lives in the red house - (member ( $_15 brit red $_16 $_17 $_18) $Houses) - ; Clue 3: The owner of the blue house drinks tea - (member ( $_19 $_20 blue tea $_21 $_22) $Houses) - ; Clue 4: The owner of the red house keeps dogs - (member ( $_23 $_24 red $_25 dog $_26) $Houses) - ; Clue 5: The owner of the tea-drinking house smokes Prince - (member ( $_27 $_28 $_29 tea $_30 prince) $Houses) - ; Determine who owns the fish - (member ( $_31 $FishOwner $_32 $_33 fish $_34) $Houses))) - -;;;;;;;;;;;;;;;;; -;; TEST Queries ;; -;;;;;;;;;;;;;;;;; -!(query (solve-fish-owner $FishOwner)) - diff --git a/tests/zebra/zebra9_no_states.metta b/tests/zebra/zebra9_no_states.metta deleted file mode 100644 index 0d70bf82635..00000000000 --- a/tests/zebra/zebra9_no_states.metta +++ /dev/null @@ -1,113 +0,0 @@ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Backward chaining logic -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Interface for backward chaining (quotes the arguement) -(: backward-chain (-> Atom Atom Atom Atom Atom)) -(= (backward-chain $info $goal $kb $rb) - (backward-chain-q $info (quote $goal) $kb $rb)) - -;; Handle specific cases during backward chaining -(: backward-chain-q (-> Atom Atom Atom Atom Atom)) -(= (backward-chain-q $info (quote $goal) $kb $rb) - (case (quote $goal) ( - ((quote (is $a $b)) (let $a $b (quote $goal))) ; Assignment - ((quote (bool $expr)) (if $expr (quote $goal) (empty))) ; Boolean evaluation - ((quote (eval= $a $expr)) (let $a $expr (quote $goal))) ; Expression evaluation - ((quote (nonvar $var)) (if (== Variable (get-metatype $var)) (empty) (quote $goal))) ; Non-variable check - ((quote (var $var)) (if (== Variable (get-metatype $var)) (quote $goal) (empty))) ; Variable check - ((quote (true)) (quote $goal)) ; Always succeeds - ((quote (fail)) (empty)) ; Always fails - ((quote (cut $_)) (if (equalz $info $goal) (quote $goal) (quote $goal))) ; Cut operator for pruning - ((quote (naf $expr)) (if (has-match $kb $expr) (empty) (quote $goal))) ; Negation as failure - ($_ (match $kb $goal (quote $goal))) ; Match against knowledge base - )) -) - -;; Match predicate: checks if a goal has at least one match in a space -;; This is less efficient, as it processes the entire space to find matches -(: has-match (-> Atom Atom Bool)) -(= (has-match $space $g) - (let $m (collapse (match $space $g True)) ; Attempt to match $g in $space - (if (== $m ()) ; If no match is found - False ; Return False - True ; Otherwise, return True - ) - ) -) - -;; Recursive case for backward chaining -(= (backward-chain-q $info (quote $goal) $kb $rb) - (match $rb ($goal :- $body) - (match-body $info $body $kb $rb $goal)) -) - -;; Chain through each element in the body and return the goal -(: match-body (-> Atom Atom Atom Atom Atom Atom)) -(= (match-body $info $body $kb $rb $goal) - (if (== $body ()) - (quote $goal) ; Base case: no more elements to match - (let* ( - (($cur $rest) (decons-atom $body)) ; Deconstruct body - ;(() (println! (IN (cur= $cur) (goal= $goal)))) ; Debugging: log input - ;($retVal (backward-chain $info $cur $kb $rb)) ; Recursive chaining - ;($m (collapse (equalz (quote $cur) $retVal))) ; Check match - ;(() (if (== $m ()) (println! (BAD!!!!!!!! (cur= $cur) (retVal= $retVal))) ())) - ;((quote $cur) $retVal) ; Unify variables - ((quote $cur) (backward-chain $info $cur $kb $rb)) ; Recursive chaining - ;(() (println! (OUT (cur= $cur) (goal= $goal)))) ; Debugging: log output - ) - (match-body $info $rest $kb $rb $goal) ; Continue matching - ) - ) -) - -;; Query execution logic -(: query (-> Atom Atom)) -(= (query $goal) - (let $m (collapse (backward-chain $info $goal &self &self)) - (if (== $m ()) (Fail $goal) (Succeed $m))) -) - -;; Predicate for general atom equality -(: equalz (-> Atom Atom Bool)) ; Compares two atoms -(= (equalz $A $A) True) ; Atoms are equal if they are identical - -(same $x $x) - -;; Predicate: Check if an element is a member of a list -(member $Elem ($Cons $Elem $_)) ; Base case: element found -((member $Elem ($Cons $Nonvar $Tail)) :- - ( (nonvar $Nonvar) (member $Elem $Tail))) ; Recursive case: continue checking - -((because $color house keeps $other the $nationality is the $type owner) :- - ((same $Houses - (Cons ( 1 $_1 $_2 $_3 $_4 $_5) ; First house - (Cons ( 2 $_6 $_7 $_8 $_9 $_10) ; Second house - $Open))) - - (same $Open Nil) - - ; Clue 1: The Norwegian lives in the first house - (member ( 1 norwegian $_11 $_12 $_13 $_14) $Houses) - ; Clue 2: The Brit lives in the red house - (member ( $_15 brit red $_16 $_17 $_18) $Houses) - ; Clue 3: The owner of the blue house drinks tea - (member ( $_19 $_20 blue tea $_21 $_22) $Houses) - ; Clue 4: The owner of the red house keeps $other - (member ( $_23 $_24 $color $_25 $other $_26) $Houses) - ; Clue 5: The owner of the tea-drinking house smokes Prince - (member ( $_27 $_28 $_29 tea $_30 prince) $Houses) - ; Determine the $nationality of owns the $type - (member ( $_31 $nationality $_32 $_33 $type $_34) $Houses))) - -;;;;;;;;;;;;;;;;; -;; TEST Queries ;; -;;;;;;;;;;;;;;;;; -!(query (because red house keeps dogs the $norwegian is the fish owner)) - -!(query (because blue house keeps dogs the $brit is the fish owner)) - -!(query (because red house keeps cats the $norwegian is the fish owner)) -