diff --git a/README.md b/README.md index 0cd9a84dd..781f42bd8 100755 --- a/README.md +++ b/README.md @@ -92,17 +92,34 @@ metta+>^D # Exit the REPL with `ctrl-D`. To run a script: ```bash -mettalog tests/baseline_compat/metta-morph_tests/nalifier.metta +mettalog exmaples/puzzles/nalifier.metta ``` To run a script and then enter the repl: ```bash -mettalog tests/baseline_compat/metta-morph_tests/nalifier.metta --repl +mettalog exmaples/puzzles//nalifier.metta --repl +metta+>!(query &self (because blue house keeps parrots the $who is the fish owner)) +[(Succeed ((quote (because blue house keeps parrots the brit is the fish owner))))] +metta+> + ``` -Execute a unit test: +## Unit tests + +One exmaple is provided in this repository ```bash +mettalog --test exmaples/tests/unit_test_example.metta # The output is saved as an HTML file in the same directory. +``` + +The rest are in a large REPO @ +```bash +git clone https://github.com/logicmoo/metta-testsuite/ +ln -s metta-testsuite/tests/ ./tests +``` + +Run a single test +```bash mettalog --test tests/baseline_compat/metta-morph_tests/tests0.metta ``` Execute baseline sanity tests: diff --git a/examples/puzzles/fish_riddle_1_no_states.metta b/examples/puzzles/fish_riddle_1_no_states.metta new file mode 100644 index 000000000..9979cf12e --- /dev/null +++ b/examples/puzzles/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/examples/puzzles/nalifier.metta b/examples/puzzles/nalifier.metta new file mode 100755 index 000000000..fd92e0107 --- /dev/null +++ b/examples/puzzles/nalifier.metta @@ -0,0 +1,120 @@ +(: If (-> Bool Atom Atom)) +(= (If True $then) $then) +(= (If False $then) (let $x 0 (let $x 1 $x))) + +(: If (-> Bool Atom Atom Atom)) +(= (If $cond $then $else) (if $cond $then $else)) + +(: sequential (-> Expression %Undefined%)) +(= (sequential $1) (superpose $1)) + +(: do (-> Expression %Undefined%)) +(= (do $1) (case $1 ())) + +(= (max $1 $2) (if (> $1 $2) $1 $2)) +(= (min $1 $2) (if (< $1 $2) $1 $2)) +(= (abs $x) (If (< $x 0) (- 0 $x) $x)) + +(= (TupleConcat $Ev1 $Ev2) (collapse (superpose ((superpose $Ev1) (superpose $Ev2))))) + +;; Truth functions +(= (Truth_c2w $c) (/ $c (- 1 $c))) +(= (Truth_w2c $w) (/ $w (+ $w 1))) +(= (Truth_Deduction ($f1 $c1) ($f2 $c2)) ((* $f1 $f2) (* (* $f1 $f2) (* $c1 $c2)))) +(= (Truth_Abduction ($f1 $c1) ($f2 $c2)) ($f2 (Truth_w2c (* (* $f1 $c1) $c2)))) +(= (Truth_Induction $T1 $T2) (Truth_Abduction $T2 $T1)) +(= (Truth_Revision ($f1 $c1) ($f2 $c2)) + (let* (($w1 (Truth_c2w $c1)) ($w2 (Truth_c2w $c2)) ($w (+ $w1 $w2)) + ($f (/ (+ (* $w1 $f1) (* $w2 $f2)) $w)) ($c (Truth_w2c $w))) + ((min 1.00 $f) (min 0.99 (max (max $c $c1) $c2))))) +(= (Truth_Expectation ($f $c)) (+ (* $c (- $f 0.5)) 0.5)) + +;;NAL-1 +;;!Syllogistic rules for Inheritance: +(= (|- ($T $T1) ($T $T2)) ($T (Truth_Revision $T1 $T2))) +(= (|- (($a --> $b) $T1) (($b --> $c) $T2)) (($a --> $c) (Truth_Deduction $T1 $T2))) +(= (|- (($a --> $b) $T1) (($a --> $c) $T2)) (($c --> $b) (Truth_Induction $T1 $T2))) +(= (|- (($a --> $c) $T1) (($b --> $c) $T2)) (($b --> $a) (Truth_Abduction $T1 $T2))) + +;Whether evidence was just counted once +(= (StampDisjoint $Ev1 $Ev2) + (== () (collapse (let* (($x (superpose $Ev1)) + ($y (superpose $Ev2))) + (case (== $x $y) ((True overlap))))))) + +;actually that is quite cool and 4x faster in MeTTa than below (yet still 130 times slower than metta-morph with below) +;but it depends on more advanced pattern matching features which are not yet in metta-morph +;(= (query $Term) +; (match &self (, (= (|- ($A $T1) ($B $T2)) ($Term ($f $T1 $T2))) +; (($A $T1) $Ev1) (($B $T2) $Ev2)) +; (If (StampDisjoint $Ev1 $Ev2) +; (($Term ($f $T1 $T2)) (TupleConcat $Ev1 $Ev2))))) + +(= (query $Term) + (match &self (, (($A $T1) $Ev1) (($B $T2) $Ev2)) + (let ($TermNew $T) (|- ($A $T1) ($B $T2)) + (If (and (== $TermNew $Term) (StampDisjoint $Ev1 $Ev2)) + (($Term $T) (TupleConcat $Ev1 $Ev2)))))) + +;choice between two options of different term +(= (Choice (($Term1 $T1) $ev1) (($Term2 $T2) $ev2)) + (If (> (Truth_Expectation $T1) (Truth_Expectation $T2)) + (($Term1 $T1) $ev1) + (($Term2 $T2) $ev2))) + +;revise if there is no evidential overlap, else use higher-confident candidate +(= (RevisionAndChoice (($Term1 ($f1 $c1)) $ev1) (($Term2 ($f2 $c2)) $ev2)) + (let $ConclusionStamp (TupleConcat $ev1 $ev2) + (If (StampDisjoint $ev1 $ev2) + (($Term2 (Truth_Revision ($f1 $c1) ($f2 $c2))) $ConclusionStamp) + (If (> $c1 $c2) + (($Term1 ($f1 $c1)) $ev1) + (($Term2 ($f2 $c2)) $ev2))))) + +;reduce beliefs +(= (reduceBeliefs $revChoiceOrBoth $option $options) + (If (== $options ()) + $option + (let* (($head (car-atom $options)) + ($rest (cdr-atom $options)) + ($revi ($revChoiceOrBoth $option $head))) + (reduceBeliefs $revChoiceOrBoth $revi $rest)))) + +;an empty event for reduction purposes +(= (EmptyEvent todo) ((x (1.0 0.0)) ())) + +;evidence query tries to maximize evidence for the passed statement term +(= (evidenceQuery $Term) (reduceBeliefs RevisionAndChoice (EmptyEvent todo) (collapse (query $Term)))) + +;choice query picks the option of highest truth expectation among the options of different term +(= (choiceQuery $Terms) + (let $options (collapse (evidenceQuery (superpose $Terms))) + (reduceBeliefs Choice (EmptyEvent todo) $options))) + + + +(((dog --> (IntSet brown)) (1.0 0.9)) (1)) +(((dog --> (IntSet small)) (1.0 0.9)) (2)) +(((dog --> (IntSet furry)) (1.0 0.9)) (3)) +(((dog --> (IntSet barks)) (1.0 0.9)) (4)) + +(((duck --> (IntSet yellow)) (1.0 0.9)) (5)) +(((duck --> (IntSet small)) (1.0 0.9)) (6)) +(((duck --> (IntSet feathered)) (1.0 0.9)) (7)) +(((duck --> (IntSet quacks)) (1.0 0.9)) (8)) + +(((swan --> (IntSet white)) (1.0 0.9)) (9)) +(((swan --> (IntSet big)) (1.0 0.9)) (10)) +(((swan --> (IntSet feathered)) (1.0 0.9)) (11)) + +((((ExtSet sam) --> (IntSet white)) (1.0 0.9)) (12)) +((((ExtSet sam) --> (IntSet small)) (1.0 0.9)) (13)) +((((ExtSet sam) --> (IntSet quacks)) (1.0 0.9)) (14)) + +!(let ($S $EV) (choiceQuery (((ExtSet sam) --> duck) + ((ExtSet sam) --> swan) + ((ExtSet sam) --> dog))) + $S) + + +; !(repl!) diff --git a/examples/puzzles/task1_whole.metta b/examples/puzzles/task1_whole.metta new file mode 100755 index 000000000..d30808c54 --- /dev/null +++ b/examples/puzzles/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)