coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

prolog: cut !/0 with two-cut-box barrier scheme, 6 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Details

Browse Source
This commit is contained in:
giles
2026-04-25 01:14:12 +00:00
parent 738f44e47d
commit f019d42727
3 changed files with 110 additions and 11 deletions
Download Patch File Download Diff File Expand all files Collapse all files

59
lib/prolog/runtime.sx
View File

@@ -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))))