prolog: cut !/0 with two-cut-box barrier scheme, 6 tests

lib/prolog/runtime.sx

@@ -284,14 +284,19 @@
   pl-db-lookup-goal
   (fn (db goal) (pl-db-lookup db (pl-goal-key goal))))
 
+(define
+  pl-cut?
+  (fn (t) (and (list? t) (not (empty? t)) (= (first t) "cut"))))
+
 (define
   pl-solve!
   (fn
-    (db goal trail k)
+    (db goal trail cut-box k)
     (let
       ((g (pl-walk goal)))
       (cond
         ((pl-var? g) false)
+        ((pl-cut? g) (begin (dict-set! cut-box :cut true) (k)))
         ((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))
@@ -301,8 +306,9 @@
             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))))))
+            cut-box
+            (fn () (pl-solve! db (nth (pl-args g) 1) trail cut-box k))))
+        (true (pl-solve-user! db g trail cut-box k))))))
 
 (define
   pl-solve-eq!
@@ -322,13 +328,25 @@
 (define
   pl-solve-user!
   (fn
-    (db goal trail k)
-    (pl-try-clauses! db goal trail (pl-db-lookup-goal db goal) k)))
+    (db goal trail outer-cut-box k)
+    (let
+      ((inner-cut-box {:cut false}))
+      (let
+        ((outer-was-cut (dict-get outer-cut-box :cut)))
+        (pl-try-clauses!
+          db
+          goal
+          trail
+          (pl-db-lookup-goal db goal)
+          outer-cut-box
+          outer-was-cut
+          inner-cut-box
+          k)))))
 
 (define
   pl-try-clauses!
   (fn
-    (db goal trail clauses k)
+    (db goal trail clauses outer-cut-box outer-was-cut inner-cut-box k)
     (cond
       ((empty? clauses) false)
       (true
@@ -341,21 +359,41 @@
               (cond
                 ((pl-unify! goal head trail)
                   (let
-                    ((r (pl-solve! db body trail k)))
+                    ((r (pl-solve! db body trail inner-cut-box k)))
                     (cond
                       (r true)
+                      ((dict-get inner-cut-box :cut)
+                        (begin (pl-trail-undo-to! trail mark) false))
+                      ((and (not outer-was-cut) (dict-get outer-cut-box :cut))
+                        (begin (pl-trail-undo-to! trail mark) false))
                       (true
                         (begin
                           (pl-trail-undo-to! trail mark)
-                          (pl-try-clauses! db goal trail (rest clauses) k))))))
+                          (pl-try-clauses!
+                            db
+                            goal
+                            trail
+                            (rest clauses)
+                            outer-cut-box
+                            outer-was-cut
+                            inner-cut-box
+                            k))))))
                 (true
                   (begin
                     (pl-trail-undo-to! trail mark)
-                    (pl-try-clauses! db goal trail (rest clauses) k)))))))))))
+                    (pl-try-clauses!
+                      db
+                      goal
+                      trail
+                      (rest clauses)
+                      outer-cut-box
+                      outer-was-cut
+                      inner-cut-box
+                      k)))))))))))
 
 (define
   pl-solve-once!
-  (fn (db goal trail) (pl-solve! db goal trail (fn () true))))
+  (fn (db goal trail) (pl-solve! db goal trail {:cut false} (fn () true))))
 
 (define
   pl-solve-count!
@@ -367,5 +405,6 @@
         db
         goal
         trail
+        {:cut false}
         (fn () (begin (dict-set! box :n (+ (dict-get box :n) 1)) false)))
       (dict-get box :n))))

lib/prolog/tests/solve.sx

@@ -181,4 +181,63 @@
   (pl-var-bound? (dict-get pl-s-env-undo "X"))
   false)
 
+(define pl-s-db-cut1 (pl-mk-db))
+
+(pl-db-load! pl-s-db-cut1 (pl-parse "g :- !. g :- true."))
+
+(pl-s-test!
+  "bare cut succeeds"
+  (pl-solve-once! pl-s-db-cut1 (pl-s-goal "g" {}) (pl-mk-trail))
+  true)
+
+(pl-s-test!
+  "cut commits to first matching clause"
+  (pl-solve-count! pl-s-db-cut1 (pl-s-goal "g" {}) (pl-mk-trail))
+  1)
+
+(define pl-s-db-cut2 (pl-mk-db))
+
+(pl-db-load! pl-s-db-cut2 (pl-parse "a(1). a(2). g(X) :- a(X), !."))
+
+(pl-s-test!
+  "cut commits to first a solution"
+  (pl-solve-count! pl-s-db-cut2 (pl-s-goal "g(X)" {}) (pl-mk-trail))
+  1)
+
+(define pl-s-db-cut3 (pl-mk-db))
+
+(pl-db-load!
+  pl-s-db-cut3
+  (pl-parse "a(1). a(2). g(X) :- a(X), !, fail. g(99)."))
+
+(pl-s-test!
+  "cut then fail blocks alt clauses"
+  (pl-solve-count! pl-s-db-cut3 (pl-s-goal "g(X)" {}) (pl-mk-trail))
+  0)
+
+(define pl-s-db-cut4 (pl-mk-db))
+
+(pl-db-load!
+  pl-s-db-cut4
+  (pl-parse "a(1). b(10). b(20). g(X, Y) :- a(X), !, b(Y)."))
+
+(pl-s-test!
+  "post-cut goal backtracks freely"
+  (pl-solve-count!
+    pl-s-db-cut4
+    (pl-s-goal "g(X, Y)" {})
+    (pl-mk-trail))
+  2)
+
+(define pl-s-db-cut5 (pl-mk-db))
+
+(pl-db-load!
+  pl-s-db-cut5
+  (pl-parse "r(1). r(2). q :- r(X), !. p :- q. p :- true."))
+
+(pl-s-test!
+  "inner cut does not commit outer predicate"
+  (pl-solve-count! pl-s-db-cut5 (pl-s-goal "p" {}) (pl-mk-trail))
+  2)
+
 (define pl-solve-tests-run! (fn () {:failed pl-s-test-fail :passed pl-s-test-pass :total pl-s-test-count :failures pl-s-test-failures}))