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

prolog: assert/asserta/assertz/retract for facts, 11 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 07:32:09 +00:00
parent 3190e770fb
commit 373d57cbcb
6 changed files with 293 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files

125
lib/prolog/runtime.sx
View File

@@ -284,6 +284,123 @@
pl-db-lookup-goal
(fn (db goal) (pl-db-lookup db (pl-goal-key goal))))
(define
pl-rt-walk-to-ast
(fn
(w)
(cond
((pl-var? w) (list "var" (str "_G" (pl-var-id w))))
((and (list? w) (not (empty? w)) (= (first w) "compound"))
(list "compound" (nth w 1) (map pl-rt-walk-to-ast (nth w 2))))
(true w))))
(define pl-rt-to-ast (fn (t) (pl-rt-walk-to-ast (pl-walk-deep t))))
(define
pl-build-clause
(fn
(ast)
(cond
((and (list? ast) (= (first ast) "compound") (= (nth ast 1) ":-") (= (len (nth ast 2)) 2))
(list "clause" (first (nth ast 2)) (nth (nth ast 2) 1)))
(true (list "clause" ast (list "atom" "true"))))))
(define
pl-db-prepend!
(fn
(db clause)
(let
((key (pl-clause-key clause)) (table (dict-get db :clauses)))
(cond
((nil? (dict-get table key)) (dict-set! table key (list clause)))
(true (dict-set! table key (cons clause (dict-get table key))))))))
(define
pl-list-without
(fn
(lst i)
(cond
((empty? lst) (list))
((= i 0) (rest lst))
(true (cons (first lst) (pl-list-without (rest lst) (- i 1)))))))
(define
pl-solve-assertz!
(fn
(db term k)
(begin (pl-db-add! db (pl-build-clause (pl-rt-to-ast term))) (k))))
(define
pl-solve-asserta!
(fn
(db term k)
(begin (pl-db-prepend! db (pl-build-clause (pl-rt-to-ast term))) (k))))
(define
pl-solve-retract!
(fn
(db term trail k)
(let
((head-runtime (cond ((and (pl-compound? term) (= (pl-fun term) ":-") (= (len (pl-args term)) 2)) (first (pl-args term))) (true term)))
(body-runtime
(cond
((and (pl-compound? term) (= (pl-fun term) ":-") (= (len (pl-args term)) 2))
(nth (pl-args term) 1))
(true (list "atom" "true")))))
(let
((wh (pl-walk head-runtime)))
(cond
((pl-var? wh) false)
(true
(let
((key (pl-head-key wh)))
(pl-retract-try-each
db
key
(pl-db-lookup db key)
head-runtime
body-runtime
0
trail
k))))))))
(define
pl-retract-try-each
(fn
(db key remaining head-rt body-rt idx trail k)
(cond
((empty? remaining) false)
(true
(let
((mark (pl-trail-mark trail))
(cl (pl-instantiate-fresh (first remaining))))
(cond
((and (pl-unify! head-rt (nth cl 1) trail) (pl-unify! body-rt (nth cl 2) trail))
(begin
(let
((all (pl-db-lookup db key)))
(dict-set!
(dict-get db :clauses)
key
(pl-list-without all idx)))
(let
((r (k)))
(cond
(r true)
(true (begin (pl-trail-undo-to! trail mark) false))))))
(true
(begin
(pl-trail-undo-to! trail mark)
(pl-retract-try-each
db
key
(rest remaining)
head-rt
body-rt
(+ idx 1)
trail
k)))))))))
(define
pl-cut?
(fn (t) (and (list? t) (not (empty? t)) (= (first t) "cut"))))
@@ -367,6 +484,14 @@
(begin
(pl-output-write! (pl-format-term (first (pl-args g))))
(k)))
((and (pl-compound? g) (= (pl-fun g) "assertz") (= (len (pl-args g)) 1))
(pl-solve-assertz! db (first (pl-args g)) k))
((and (pl-compound? g) (= (pl-fun g) "assert") (= (len (pl-args g)) 1))
(pl-solve-assertz! db (first (pl-args g)) k))
((and (pl-compound? g) (= (pl-fun g) "asserta") (= (len (pl-args g)) 1))
(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))
(true (pl-solve-user! db g trail cut-box k))))))
(define