prolog: DFS solver (CPS, trail-based) + true/fail/=/conj built-ins, 18 tests

lib/prolog/runtime.sx

@@ -98,6 +98,11 @@
             "compound"
             fun
             (map (fn (a) (pl-instantiate a var-env)) args))))
+      ((= (first ast) "clause")
+        (let
+          ((h (pl-instantiate (nth ast 1) var-env))
+            (b (pl-instantiate (nth ast 2) var-env)))
+          (list "clause" h b)))
       (true ast))))
 
 (define pl-instantiate-fresh (fn (ast) (pl-instantiate ast {})))
@@ -278,3 +283,89 @@
 (define
   pl-db-lookup-goal
   (fn (db goal) (pl-db-lookup db (pl-goal-key goal))))
+
+(define
+  pl-solve!
+  (fn
+    (db goal trail k)
+    (let
+      ((g (pl-walk goal)))
+      (cond
+        ((pl-var? g) false)
+        ((and (pl-atom? g) (= (pl-atom-name g) "true")) (k))
+        ((and (pl-atom? g) (= (pl-atom-name g) "fail")) false)
+        ((and (pl-compound? g) (= (pl-fun g) "=") (= (len (pl-args g)) 2))
+          (pl-solve-eq! (first (pl-args g)) (nth (pl-args g) 1) trail k))
+        ((and (pl-compound? g) (= (pl-fun g) ",") (= (len (pl-args g)) 2))
+          (pl-solve!
+            db
+            (first (pl-args g))
+            trail
+            (fn () (pl-solve! db (nth (pl-args g) 1) trail k))))
+        (true (pl-solve-user! db g trail k))))))
+
+(define
+  pl-solve-eq!
+  (fn
+    (a b trail k)
+    (let
+      ((mark (pl-trail-mark trail)))
+      (cond
+        ((pl-unify! a b trail)
+          (let
+            ((r (k)))
+            (cond
+              (r true)
+              (true (begin (pl-trail-undo-to! trail mark) false)))))
+        (true (begin (pl-trail-undo-to! trail mark) false))))))
+
+(define
+  pl-solve-user!
+  (fn
+    (db goal trail k)
+    (pl-try-clauses! db goal trail (pl-db-lookup-goal db goal) k)))
+
+(define
+  pl-try-clauses!
+  (fn
+    (db goal trail clauses k)
+    (cond
+      ((empty? clauses) false)
+      (true
+        (let
+          ((mark (pl-trail-mark trail)))
+          (let
+            ((clause (pl-instantiate-fresh (first clauses))))
+            (let
+              ((head (nth clause 1)) (body (nth clause 2)))
+              (cond
+                ((pl-unify! goal head trail)
+                  (let
+                    ((r (pl-solve! db body trail k)))
+                    (cond
+                      (r true)
+                      (true
+                        (begin
+                          (pl-trail-undo-to! trail mark)
+                          (pl-try-clauses! db goal trail (rest clauses) k))))))
+                (true
+                  (begin
+                    (pl-trail-undo-to! trail mark)
+                    (pl-try-clauses! db goal trail (rest clauses) k)))))))))))
+
+(define
+  pl-solve-once!
+  (fn (db goal trail) (pl-solve! db goal trail (fn () true))))
+
+(define
+  pl-solve-count!
+  (fn
+    (db goal trail)
+    (let
+      ((box {:n 0}))
+      (pl-solve!
+        db
+        goal
+        trail
+        (fn () (begin (dict-set! box :n (+ (dict-get box :n) 1)) false)))
+      (dict-get box :n))))