prolog: findall/3 + bagof/3 + setof/3, 11 tests

lib/prolog/runtime.sx

@@ -364,6 +364,112 @@
                 trail
                 k))))))))
 
+(define
+  pl-deep-copy
+  (fn
+    (t var-map)
+    (let
+      ((w (pl-walk t)))
+      (cond
+        ((pl-var? w)
+          (let
+            ((id-key (str (pl-var-id w))))
+            (cond
+              ((dict-has? var-map id-key) (dict-get var-map id-key))
+              (true
+                (let
+                  ((nv (pl-mk-rt-var (dict-get w :name))))
+                  (begin (dict-set! var-map id-key nv) nv))))))
+        ((pl-compound? w)
+          (list
+            "compound"
+            (pl-fun w)
+            (map (fn (a) (pl-deep-copy a var-map)) (pl-args w))))
+        (true w)))))
+
+(define
+  pl-each-into-dict!
+  (fn
+    (terms d)
+    (cond
+      ((empty? terms) nil)
+      (true
+        (begin
+          (dict-set! d (pl-format-term (first terms)) (first terms))
+          (pl-each-into-dict! (rest terms) d))))))
+
+(define
+  pl-sort-uniq-terms
+  (fn
+    (terms)
+    (let
+      ((kv {}))
+      (begin
+        (pl-each-into-dict! terms kv)
+        (let
+          ((sorted-keys (sort (keys kv))))
+          (map (fn (k) (dict-get kv k)) sorted-keys))))))
+
+(define
+  pl-collect-solutions
+  (fn
+    (db template-rt goal-rt trail)
+    (let
+      ((box {:results (list)}) (mark (pl-trail-mark trail)))
+      (begin
+        (pl-solve!
+          db
+          goal-rt
+          trail
+          {:cut false}
+          (fn
+            ()
+            (begin
+              (append!
+                (dict-get box :results)
+                (pl-deep-copy template-rt {}))
+              false)))
+        (pl-trail-undo-to! trail mark)
+        (dict-get box :results)))))
+
+(define
+  pl-solve-findall!
+  (fn
+    (db template-rt goal-rt third-rt trail k)
+    (let
+      ((items (pl-collect-solutions db template-rt goal-rt trail)))
+      (let
+        ((rl (pl-mk-list-term items (pl-nil-term))))
+        (pl-solve-eq! third-rt rl trail k)))))
+
+(define
+  pl-solve-bagof!
+  (fn
+    (db template-rt goal-rt third-rt trail k)
+    (let
+      ((items (pl-collect-solutions db template-rt goal-rt trail)))
+      (cond
+        ((empty? items) false)
+        (true
+          (let
+            ((rl (pl-mk-list-term items (pl-nil-term))))
+            (pl-solve-eq! third-rt rl trail k)))))))
+
+(define
+  pl-solve-setof!
+  (fn
+    (db template-rt goal-rt third-rt trail k)
+    (let
+      ((items (pl-collect-solutions db template-rt goal-rt trail)))
+      (cond
+        ((empty? items) false)
+        (true
+          (let
+            ((sorted (pl-sort-uniq-terms items)))
+            (let
+              ((rl (pl-mk-list-term sorted (pl-nil-term))))
+              (pl-solve-eq! third-rt rl trail k))))))))
+
 (define
   pl-retract-try-each
   (fn
@@ -492,6 +598,30 @@
           (pl-solve-asserta! db (first (pl-args g)) k))
         ((and (pl-compound? g) (= (pl-fun g) "retract") (= (len (pl-args g)) 1))
           (pl-solve-retract! db (first (pl-args g)) trail k))
+        ((and (pl-compound? g) (= (pl-fun g) "findall") (= (len (pl-args g)) 3))
+          (pl-solve-findall!
+            db
+            (first (pl-args g))
+            (nth (pl-args g) 1)
+            (nth (pl-args g) 2)
+            trail
+            k))
+        ((and (pl-compound? g) (= (pl-fun g) "bagof") (= (len (pl-args g)) 3))
+          (pl-solve-bagof!
+            db
+            (first (pl-args g))
+            (nth (pl-args g) 1)
+            (nth (pl-args g) 2)
+            trail
+            k))
+        ((and (pl-compound? g) (= (pl-fun g) "setof") (= (len (pl-args g)) 3))
+          (pl-solve-setof!
+            db
+            (first (pl-args g))
+            (nth (pl-args g) 1)
+            (nth (pl-args g) 2)
+            trail
+            k))
         (true (pl-solve-user! db g trail cut-box k))))))
 
 (define