diff --git a/tests/baseline_compat/hyperon-mettalog_sanity/unify_true_false.metta b/tests/baseline_compat/hyperon-mettalog_sanity/unify_true_false.metta new file mode 100644 index 00000000000..6d2f94bb6d2 --- /dev/null +++ b/tests/baseline_compat/hyperon-mettalog_sanity/unify_true_false.metta @@ -0,0 +1,69 @@ + +(= (same $X $X) True) +(= (eq $X $Y) + (let $C (same $X $Y) (if (== $C True) True False))) + +(= (unif $X $Y) + (unify $X $Y True False)) + + + + +!(assertEqualToResult (unif (+ 1 1) ($_1 $_2 $_)) (False)) ;; eager eval? +!(assertEqualToResult (unif (+ 1 1) 2) (True)) ;; eager eval on plus? +!(assertEqualToResult (unif (+ 1 1) (+ 1 1)) (True)) +!(assertEqualToResult (unif (+ 1 1) (+ 0 2)) (True)) ;; eager eval? +!(assertEqualToResult (unif (+ 1 1) (+ $a $b)) (False)) ;; eager eval? +!(assertEqualToResult (unif $x $x) (True)) +!(assertEqualToResult (unif $x $y) (True)) ;; identity? +!(assertEqualToResult (unif (+ 1 1) $x) (True)) ;; eager eval? +!(assertEqualToResult (unif (+ 1 2 3) (+ 1 2 3)) (True)) ;; Arity error? +!(assertEqualToResult (unif (+ 1 2 3) (+ 1 $two 3)) (True)) +!(assertEqualToResult (unif (+ 1 2) (+ 1 $two)) (False)) ;; overly eager eval? + +!(assertEqualToResult (same (+ 1 1) ($_1 $_2 $_)) ((same 2 ($_1 $_2 $_)))) +!(assertEqualToResult (same (+ 1 1) 2) (True)) +!(assertEqualToResult (same (+ 1 1) (+ 1 1)) (True)) +!(assertEqualToResult (same (+ 1 1) (+ 0 2)) (True)) +!(assertEqualToResult (same (+ 1 2 3) (+ 1 2 3)) (True)) +!(assertEqualToResult (same (+ 1 1) (+ $a $b)) ((same 2 (+ $a $b)))) +!(assertEqualToResult (same $x $y) (True)) +!(assertEqualToResult (same $x $x) (True)) +!(assertEqualToResult (same (+ 1 1) $x) (True)) +!(assertEqualToResult (same (+ 1 2 3) (+ 1 2 3)) (True)) +!(assertEqualToResult (same (+ 1 2 3) (+ 1 $two 3)) (True)) +!(assertEqualToResult (same (+ 1 2) (+ 1 $two)) ((same 3 (+ 1 $two)))) + +!(assertEqualToResult (eq (+ 1 1) ($_1 $_2 $_)) (False)) +!(assertEqualToResult (eq (+ 1 1) 2) (True)) +!(assertEqualToResult (eq (+ 1 1) (+ 1 1)) (True)) +!(assertEqualToResult (eq (+ 1 1) (+ 0 2)) (True)) +!(assertEqualToResult (eq (+ 1 2 3) (+ 1 2 3)) (True)) +!(assertEqualToResult (eq (+ 1 1) (+ $a $b)) (False)) +!(assertEqualToResult (eq $x $y) (True)) +!(assertEqualToResult (eq $x $x) (True)) +!(assertEqualToResult (eq (+ 1 1) $x) (True)) +!(assertEqualToResult (eq (+ 1 2 3) (+ 1 2 3)) (True)) +!(assertEqualToResult (eq (+ 1 2 3) (+ 1 $two 3)) (True)) +!(assertEqualToResult (eq (+ 1 2) (+ 1 $two)) (False)) + + + + + +(unify-atom (-> Atom Atom)) +(= (unify-atom $X $Y) + (unify $X $Y (quote (u $X $Y)) False)) + +!(assertEqualToResult (unify-atom (+ 1 1) ($_1 $_2 $_)) (False)) ;; eager eval? +!(assertEqualToResult (unify-atom (+ 1 1) 2) ((quote (u 2 2)))) ;; eager eval? +!(assertEqualToResult (unify-atom (+ 1 1) (+ 1 1)) ((quote (u 2 2)))) +!(assertEqualToResult (unify-atom (+ 1 1) (+ 0 2)) ((quote (u 2 2)))) ;; eager eval? +!(assertEqualToResult (unify-atom (+ 1 1) (+ $a $b)) (False)) ;; eager eval? +!(assertEqualToResult (unify-atom $x $x) ((quote (u $x $x)))) +!(assertEqualToResult (unify-atom $x $y) ((quote (u $y $y)))) ;; identity? +!(assertEqualToResult (unify-atom (+ 1 1) $x) ((quote (u 2 2)))) ;; eager eval? +!(assertEqualToResult (unify-atom (+ 1 2 3) (+ 1 2 3)) ((quote (u (Error (+ 1 2 3) IncorrectNumberOfArguments) (Error (+ 1 2 3) IncorrectNumberOfArguments))))) ;; Arity error? +!(assertEqualToResult (unify-atom (+ 1 2 3) (+ 1 $two 3)) ((quote (u (Error (+ 1 2 3) IncorrectNumberOfArguments) (Error (+ 1 2 3) IncorrectNumberOfArguments))))) +!(assertEqualToResult (unify-atom (+ 1 2) (+ 1 $two)) (False)) ;; overly eager eval? + diff --git a/tests/direct_comp/important/bc_comp.metta b/tests/direct_comp/important/bc_comp.metta new file mode 100755 index 00000000000..7a385d11e3d --- /dev/null +++ b/tests/direct_comp/important/bc_comp.metta @@ -0,0 +1,81 @@ +;!(pragma! compile full) + +(: is-variable (-> Atom Bool)) +(= (is-variable $x) (== (get-metatype $x) Variable)) + +(: lazy-or (-> Bool Atom Bool)) +(= (lazy-or False $x) $x) +(= (lazy-or True $x) True) + +(: is-expression (-> Atom Bool)) +(= (is-expression $x) (== (get-metatype $x) Expression)) + +(: is-ground (-> Atom Bool)) +(= (is-ground $x) (if (is-variable $x) + False + (if (== () $x) True + (if (is-expression $x) + (and (let $head (car-atom $x) (is-ground $head)) + (let $tail (cdr-atom $x) (is-ground $tail))) + True)))) + + +;; KB +!(bind! &kb (new-space)) + +!(add-atom &kb (: axiom (nums 2 3))) + +!(add-atom &kb (: rule1 + (-> (nums $x $y) + (rule1output $x $y)))) + +!(add-atom &kb + (: rule + (-> (rule1output $x $y) + (-> (lt $x $y) + (less $x $y))))) + +; !(add-atom &kb +; (: rule +; (-> (lt $x $y) +; (-> (rule1output $x $y) +; (less $x $y))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; DTL Backward chaining Curried ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(: bc (-> $a hyperon::space::DynSpace Nat $a)) +;; Base case +(= (bc (: $prf $ccln) $space $_1) (match $space (: $prf $ccln) (: $prf $ccln))) +;; if conclusion equals (lt $X $Y), then return (: CPU (lt $X $Y)) +;; if $x and $Y are fully grounded and (< $X $Y) +(= (bc (: CPU (lt $X $Y)) $space $_2) + (if (and (and (is-ground $X) (is-ground $Y)) (< $X $Y)) + (: CPU (lt $X $Y)) + (empty))) + +;; Recursive step +(= (bc (: ($prfabs $prfarg) $ccln) $space (S $k)) + (let* (((: $prfabs (-> $prms $ccln)) + (bc (: $prfabs (-> $prms $ccln)) $space $k)) + ((: $prfarg $prms) + (bc (: $prfarg $prms) $space $k))) + + (: ($prfabs $prfarg) $ccln))) + +;!(pragma! e trace) +;!(pragma! e-args debug) + +; Test +!(bc (: CPU (lt 2 3)) &kb Z) +!(bc (: CPU (lt 4 3)) &kb Z) + +;!(pragma! eval debug) + +;! ( rtrace! (bc (: $prf (less $x $y)) (S (S (S Z))))) + +!(bc (: $prf (less $x $y)) &kb (S (S (S Z)))) + + diff --git a/tests/direct_comp/important/fish_riddle_1_no_states.metta b/tests/direct_comp/important/fish_riddle_1_no_states.metta new file mode 100644 index 00000000000..9979cf12e6b --- /dev/null +++ b/tests/direct_comp/important/fish_riddle_1_no_states.metta @@ -0,0 +1,140 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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 $_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 + +;!(equalz $a (+ 1 1)) + +;; 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))) +) + + +;; 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 + +;; Predicate to check equality of two values +(same $x $x) + +((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/direct_comp/important/puzzle.metta b/tests/direct_comp/important/puzzle.metta new file mode 100644 index 00000000000..796b147053c --- /dev/null +++ b/tests/direct_comp/important/puzzle.metta @@ -0,0 +1,115 @@ + + +; The bank employs three people: Boris, Ivan, Semyon +; There are positions of supervisor, cashier, controller +; The cashier has no siblings and is the shortest in stature. +; Semyon is married to Boris's sister and is higher than the controller. +; determine who has what position + + + +(: List (-> $t Type)) +(: Nil (List $t)) +(: Cons (-> $t (List $t) (List $t))) + +; convert (a b c) to (Cons a (Cons b (Cons c Nil))) +(: makelist (-> Atom (List $t))) +(= (makelist $x) + (if (== () $x) Nil (let $cdr (cdr-atom $x) + (Cons (car-atom $x) (makelist $cdr))) + ) +) + +; works like ,/2 +(: and-seq (-> Atom Atom Bool)) +(= (and-seq $first $second) + (if $first $second False)) + +; direct translation of prolog code for member/2 +(= (memb $X Nil) False) + +; member(X, [X|_]). +(= (memb $X (Cons $X $Tail)) True) + +;member(X, [_|Tail]) :- +; member(X, Tail). +(= (memb $X (Cons $H $Tail)) + (memb $X $Tail)) + + +(= (same $X $X) True) +; works like =/2 +(= (eq $X $Y) + (let $C (same $X $Y) (if (== $C True) True False))) + +(= (is-variable $x) + (let $type (get-metatype $x) (if (== $type Variable) True False))) +(= (nth-var-iter $index (Cons $H $Tail) $item $base) + (nth-var $Tail $item $H $base $index)) +(= (nth-var $List $item $item $base $base) True) +(= (nth-var (Cons $H $Tail) $item $prev_head $N $base) + (let $M (+ $N 1) (nth-var $Tail $item $H $M $base))) + + +(= (nth $index Nil $item $base) False) +(= (nth $index (Cons $H $Tail) $item $base) + (if (is-variable $index) + (nth-var-iter $index (Cons $H $Tail) $item $base) + (nth-det $index (Cons $H $Tail) $item $base)) ) + +; works like nth0_det from swipl lists.pl, won't work with $index as variable +(= (nth-det $index Nil $item $base) False) +(= (nth-det $index (Cons $H $Tail) $item $base) + (if (eq $index $base) (eq $H $item) (nth-det (- $index 1) $Tail $item 1))) + + +(= (nth1 $index $list $item) (nth $index $list $item 1)) + +(= (nextto $x $y $list) + (let $r (nextto-impl $x $y $list) + (if (== $r True) $r False))) + +; nextto(X, Y, [X,Y|_]). +(= (nextto-impl $x $y (Cons $x (Cons $y $Tail))) True) + +; nextto(X, Y, [_|Zs]) :- +; nextto(X, Y, Zs). +(= (nextto-impl $x $y (Cons $head $Tail)) + (nextto-impl $x $y $Tail)) + + + + +;foo :- +; Employees=[_ , _ , _], +;% /Boris has sister/ +; member([boris, _ , has_sister], Employees), +;% /cashier is the shortest and has no sister/ +; nth1(1, Employees, [ _ , cashier, no_sister]), +;% /Semyon is higher than controller/ +; nextto([ _ , controller, _], [semyon, _ , _ ], Employees), +; member([ivan, _ , _ ], Employees), +; member([_, supervisor, _], Employees), +; print(Employees), nl. + + +(= (foo $Employees) + (and-seq (eq $Employees (makelist ($A $B $C))) + (and-seq + (memb (makelist (boris $Y has_sister)) $Employees) + (and-seq + (nth1 1 $Employees (makelist ($Z cashier no_sister))) + (and-seq + (nextto (makelist ($p controller $v)) + (makelist (semyon $v1 $v2)) + $Employees) + (and-seq (memb (makelist (ivan $v3 $v4)) $Employees) + (memb (makelist ($v5 supervisor $v6)) $Employees)) + ) + ) + ) + ) +) + +!(let $r (foo $Employees) (if $r $Employees (empty))) + diff --git a/tests/direct_comp/important/task1_whole.metta b/tests/direct_comp/important/task1_whole.metta new file mode 100755 index 00000000000..d30808c54a4 --- /dev/null +++ b/tests/direct_comp/important/task1_whole.metta @@ -0,0 +1,529 @@ + +;; took 37 seconds + +(:object a) (:object b) +(:object c) ;; +(:init ( + (on-table a) + (on-table b) + (clear a) + (clear b) + (arm-empty) + (on-table c) (clear c) ;; +)) +(:goal (And ( + (on a b) + (on b c) ;; +))) + + +(:action pickup + :parameters ($x) + :precondition (And ((clear $x) (on-table $x) (arm-empty))) + :effect (And ((holding $x) (Not (clear $x)) + (Not (on-table $x)) (Not (arm-empty))) + ) +) +(:action putdown + :parameters ($x) + :precondition (And ((holding $x))) + :effect (And ((clear $x) (arm-empty) (on-table $x) + (Not (holding $x)))) +) + +(:action stack + :parameters ($x $y) + :precondition (And ( + (clear $y) (holding $x) + )) + :effect (And ( + (arm-empty) (clear $x) (on $x $y) + (Not (clear $y)) (Not (holding $x)) + )) +) + +(:action unstack + :parameters ($x $y) + :precondition (And ((on $x $y) (clear $x) (arm-empty))) + :effect (And ( + (holding $x) (clear $y) (Not (on $x $y)) + (Not (clear $x)) (Not (arm-empty)) + )) +) + +;; TODO: how to levarage native MeTTa for typing? + +;; (State id fluent) ;; only true fluent + +;; check satisfaction of a ground formula + +;!(import! &self task0) ;; Hyperon requires to be at the top +;!(import! &self task1) ;; Hyperon requires to be at the top +;!(import! &self task2) ;; Hyperon requires to be at the top + +(= (formula-satisfaction $stateId (Not $expr)) + (not (formula-satisfaction $stateId $expr)) +) +(= (formula-satisfaction $stateId (Or $exprList)) + (if (== $exprList ()) + False + (let* ( + (($head $rest) (decons-atom $exprList)) + ($v (formula-satisfaction $stateId $head)) + ) (if $v True (or $v (formula-satisfaction $stateId (Or $rest))))) + ) +) +(= (formula-satisfaction $stateId (And $exprList)) + (if (== $exprList ()) + True + (let* ( + (($head $rest) (decons-atom $exprList)) + ($v (formula-satisfaction $stateId $head)) + ) (if (not $v) False (and $v (formula-satisfaction $stateId (And $rest))))) + ) +) + +(= (formula-satisfaction $stateId $expr) ;; base case, match positive fluent + (case $expr ( + ((And $x) (empty)) + ((Or $x) (empty)) + ((Not $x) (empty)) + ($1 (let $all (collapse (match &self (State $stateId $expr) True)) + (if (== $all ()) False True))) + )) +) + +;; check if an action is applicable in a state +(= (action-applicable $stateId $actionId $args) + (match &self (:action $actionId + :parameters $params + :precondition $preds + :effect $effs + ) (unf $args $params + (formula-satisfaction $stateId $preds) + (Error $params FailedUnification))) +) + +;; (:object x) TODO: object typing, how to only extract objects with potential updating? in a state? +;; all possible grounding for a variable ~ objects +(= (args-combination $params) + (if (== $params ()) () + (let* ( + (($1 $rest) (decons-atom $params)) + ($h (match &self (:object $o) $o)) + ($r (args-combination $rest)) + ) (cons-atom $h $r)) + ) +) + +;; for each action & combination of args, try if its precondition is satisfied in state +(= (actions-applicable $stateId) + (match &self (:action $actionId + :parameters $params + :precondition $preds + :effect $effs + ) (let* ( + ($args (args-combination $params)) + ($1 (unf $args $params True (Error $params FailedUnification))) + ) (if (formula-satisfaction $stateId $preds) ($actionId $params) (empty)) + )) +) + +(= (action-applyEffect $actionId $args) + (match &self (:action $actionId + :parameters $params + :precondition $preds + :effect $effs + ) (unf $args $params $effs FailedUnification)) +) + +(= (signed-fluents $list) + (if (== $list ()) + (() ()) + (let* ( + (($h $rest) (decons-atom $list)) + (($pos $neg) (signed-fluents $rest)) + (($isNeg $f) (unf $h (Not $v) (True $v) (False $h))) + ) (if $isNeg + ($pos (cons-atom $f $neg)) + ((cons-atom $f $pos) $neg) + )) + ) +) + +;; diffing algorithm? +(= (state-diff $allStates $diffs) + (let* ( + ((And $d) $diffs) + (($pos $neg) (signed-fluents $d)) + ($s1 (collapse (subtraction ;; remove negative fluents + (superpose $allStates) + (superpose $neg) + ))) + ($s2 (collapse (union ;; add any positive fluents + (superpose $s1) + (superpose $pos) + ))) + ) $s2) +) + +;; a list of atom to add for the next non-determinisitc state (out of all possible states) +(= (state-transition $stateId) + (let* ( + (($actionId $args) (actions-applicable $stateId)) + ($effsDiff (action-applyEffect $actionId $args)) + ($stsEffs (collapse (match &self (State $stateId $form) $form))) + ($newState (state-diff $stsEffs $effsDiff)) + ) + ; $newState + (if (== $newState ()) + (Error ($stateId $effsDiff $stsEffs) "Empty State") + (($actionId $args) $newState) + ) + ) +) + +(= (state-visited? $stateFluents) + (if (== $stateFluents ()) () + (let* ( + (($h $rest) (decons-atom $stateFluents)) + ($included (collapse (match &self (State $id $h) $id))) + ) (if (== $rest ()) + $included + (let $other (state-visited? $rest) (L-intersection $included $other)) + )) + ) +) +(= (state-visited $stateId) + (let $fs (collapse (match &self (State $stateId $form) $form)) + (state-visited? $fs) + ) +) + +(= (state-enqueued? $stateId) + (let $s (collapse (match &self (State $stateId $f) $stateId)) + (if (== $s ()) False True) + ) +) + +(= (goal-satisfied $stateId) + (match &self (:goal $expr) (formula-satisfaction $stateId $expr)) +) + +(= (retrace-steps $toStateId) + (if (== $toStateId 0) + () + (let* ( + (($fromId $action $args) (match &self + (Succ $fromId ($action $args) $toStateId) + ($fromId $action $args))) + ($prevSteps (retrace-steps $fromId)) + ) (L-push-back $prevSteps ($action $args))) + ) +) + +;; Performance note: use space for global state versus pass as arguments, +;; depends on complexity of (match) +;; TODO: match in space versus list + +;!(import! &self alist) + +(= (add-state-fluents! $stateId $fluents) + (if (== $fluents ()) + () + (let* ( + (($h $rest) (decons-atom $fluents)) + (() (add-atom &self (State $stateId $h))) + ) (add-state-fluents! $stateId $rest)) + ) +) + +;; states = [(fluents) (fluents2)] +;; for each next state, add its fluents and enqueue id +(= (enqueue-next-states! $fromID $states $nextUID) + (if (== $states ()) + $nextUID + (let* ( + (($state $rest) (decons-atom $states)) + ((($action $args) $stateFluents) $state) + ($visited (state-visited? $stateFluents)) + ) (if (== $visited ()) + (let* ( + (() (add-state-fluents! $nextUID $stateFluents)) + (() (add-atom &self (Succ $fromID ($action $args) $nextUID))) + (() (println! (ENQUEUED $nextUID))) + ($id (+ $nextUID 1)) + ) (enqueue-next-states! $fromID $rest $id)) + + (enqueue-next-states! $fromID $rest $nextUID)) ;; skipped + )) +) + +(= (fw-state-search $curState $nextUID $statesLimit) ;; CHECK VISITED STATE? + + (let () + ; () + (println! + (Processing $curState + (collapse (match &self (State $curState $f) $f)) + (collapse (match &self (Succ $from ($action $args) $curState) ($from ($action $args)))) + ; (state-visited $curState) + )) + (if (not (state-enqueued? $curState)) FailedToReachGoal + (if (goal-satisfied $curState) (retrace-steps $curState) + (if (> $curState $statesLimit) (Error $statesLimit "Limit of states exploration reached.") + (let* ( + ($nextStates (collapse (state-transition $curState))) + ($uid (enqueue-next-states! $curState $nextStates $nextUID)) + ($nextFront (+ $curState 1)) + ) (fw-state-search $nextFront $uid $statesLimit))))) + ) +) + +(= (planner-main $statesLimit) + (let* ( + ($initState ((None None) (match &self (:init $f) $f))) + ($nextUID (enqueue-next-states! -1 ($initState) 0)) + ) + ; () + (fw-state-search 0 $nextUID $statesLimit) + ) +) + +;; NEXT: modularize space + +;; work around for unify predicate +(= (unf $x $y $s $f) + (let $unf (collapse + (let $x $y True) + ) (if (== $unf ()) $f (let $x $y $s))) +) + +;; state fluents must all be grounded, TODO: semantics for non-ground state? +; !(add-atom &self (State 1 (clear b))) +; !(add-atom &self (State 1 (on-table b))) +; !(add-atom &self (State 1 (arm-empty))) +; !(state-visited? ((clear b) (on-table b) (arm-empty))) + +; !(formula-satisfaction 1 (clear b)) +; !(formula-satisfaction 1 (Not (holding b))) +; !(formula-satisfaction 1 (Or ((clear b) (holding b)))) +; !(formula-satisfaction 1 (And ((clear b) (Not (holding b))))) +; !(formula-satisfaction 1 +; (Or ((arm-empty) (And ((holding b) (clear b))))) +; ) + +; !(action-applicable 1 pickup (b)) +; !(action-applicable 1 putdown (b)) +; !(actions-applicable 1) + +;; TODO: mutable data structure in MeTTa? + +;; O(n) queue +(= (make-queue) ()) +(= (empty-queue? $q) (unify $q () True False)) +(= (front-queue $q) + (if (empty-queue? $q) + (Error $q "Can't get front of empty queue") + (car-atom $q) + ) +) +(= (pop-queue $q) (cdr-atom $q)) +(= (insert-queue $q $item) + (if (== $q ()) + ($item) + (let* ( + (($head $tail) (decons-atom $q)) + ($inserted (insert-queue $tail $item)) + ) (cons-atom $head $inserted)) + ) +) + +; !(let* ( +; ($q (make-queue)) +; ($q1 (insert-queue $q 1)) +; (() (println! $q1)) +; ($q2 (insert-queue $q1 3)) +; ($el (front-queue $q2)) +; ($q3 (pop-queue $q2)) +; (() (println! (Element $el))) +; (() (println! $q3)) +; ($q4 (insert-queue $q3 5)) +; (() (println! $q4)) +; ) ()) +(:action pickup + :parameters ($x) + :precondition (And ((clear $x) (on-table $x) (arm-empty))) + :effect (And ((holding $x) (Not (clear $x)) + (Not (on-table $x)) (Not (arm-empty))) + ) +) +(:action putdown + :parameters ($x) + :precondition (And ((holding $x))) + :effect (And ((clear $x) (arm-empty) (on-table $x) + (Not (holding $x)))) +) + +(:action stack + :parameters ($x $y) + :precondition (And ( + (clear $y) (holding $x) + )) + :effect (And ( + (arm-empty) (clear $x) (on $x $y) + (Not (clear $y)) (Not (holding $x)) + )) +) + +(:action unstack + :parameters ($x $y) + :precondition (And ((on $x $y) (clear $x) (arm-empty))) + :effect (And ( + (holding $x) (clear $y) (Not (on $x $y)) + (Not (clear $x)) (Not (arm-empty)) + )) +) + + + + +;; Collection of general-purpose utilities for list (or atom as list) +;; Inefficient and untyped, for quick prototyping only + +(= (L-empty? $list) + (if (== $list ()) True False) +) + +(= (L-size $list) + (if (L-empty? $list) + 0 + (let $tail (cdr-atom $list) (+ 1 (L-size $tail))) + ) +) + + +(= (L-push-front $list $item) + (cons-atom $item $list) +) + +(= (L-push-back $list $item) + (if (L-empty? $list) + ($item) + (let* ( + (($h $t) (decons-atom $list)) + ($pushed (L-push-back $t $item)) + ) (cons-atom $h $pushed)) + ) +) + + +(= (L-pop-front $list) + (if (L-empty? $list) + (Error L-pop-front "Empty list") + (cdr-atom $list) + ) +) + +(= (L-pop-back $list) + (if (L-empty? $list) + (Error L-pop-back "Empty list") + (let ($h $t) (decons-atom $list) + (if (L-empty? $t) + () + (let $popped (L-pop-back $t) + (cons-atom $h $popped) + ) + ) + ) + ) +) + +(= (L-append $list $list2) + (if (L-empty? $list) + $list2 + (let* ( + (($h $rest) (decons-atom $list)) + ($appended (L-append $rest $list2)) + ) (cons-atom $h $appended)) + ) +) + +(= (L-front $list) + (if (L-empty? $list) + (Error L-front "Empty list") + (car-atom $list) + ) +) + +(= (L-back $list) + (if (L-empty? $list) + (Error L-back "Empty list") + (let ($h $rest) (decons-atom $list) + (if (L-empty? $rest) + $h + (L-back $rest) + ) + ) + ) +) + +(: L-index (-> Expression Number Atom)) +(= (L-index $list $index) + (if (or (< $index 0) (and (>= $index 0) (L-empty? $list))) + (Error L-index "Index out of range") + (if (== $index 0) + (car-atom $list) + (let* ( + ($rest (cdr-atom $list)) + ($idx (- $index 1)) + ) (L-index $rest $idx)) + ) + ) +) + + +(= (L-contains? $list $item) + (if (L-empty? $list) + False + (let ($h $t) (decons-atom $list) + (if (== $h $item) True (L-contains? $t $item)) + ) + ) +) + +(= (L-subset? $list1 $list2) + (if (== $list1 ()) + True + (let ($h $rest) (decons-atom $list1) + (if (L-contains? $list2 $h) + (L-subset? $rest $list2) + False + ) + ) + ) +) + +(= (L-seteq? $list1 $list2) + (and (L-subset? $list1 $list2) + (L-subset? $list2 $list1)) +) + +(= (L-intersection $list1 $list2) + (if (== $list1 ()) + () + (let* ( + (($h $t) (decons-atom $list1)) + ($inters (L-intersection $t $list2)) + ) (if (L-contains? $list2 $h) + (cons-atom $h $inters) + $inters + )) + ) +) + + + +; !(state-transition 1) +;; Hyperon doesn't allow for importing multiple files into same space +!(planner-main 100)