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

Meta/logic predicates: \\+/not/once/ignore/ground/sort/msort/atom_number/number_string (+25 tests, 342 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Details

Browse Source 
Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-25 11:06:10 +00:00
parent 8ee0928a3d
commit 0823832dcd
6 changed files with 396 additions and 6 deletions
Download Patch File Download Diff File Expand all files Collapse all files

135
lib/prolog/runtime.sx
View File

@@ -684,6 +684,32 @@
(pl-solve-nth0! (- n 1) (nth (pl-args w) 1) elem-rt trail k))))
(true false)))))
(define
pl-ground?
(fn
(t)
(let
((w (pl-walk t)))
(cond
((pl-var? w) false)
((pl-atom? w) true)
((pl-num? w) true)
((pl-str? w) true)
((pl-compound? w)
(reduce (fn (acc a) (and acc (pl-ground? a))) true (pl-args w)))
(true false)))))
(define
pl-sort-pairs-dedup
(fn
(pairs)
(cond
((empty? pairs) (list))
((= (len pairs) 1) pairs)
((= (first (first pairs)) (first (nth pairs 1)))
(pl-sort-pairs-dedup (cons (first pairs) (rest (rest pairs)))))
(true (cons (first pairs) (pl-sort-pairs-dedup (rest pairs)))))))
(define
pl-list-to-prolog
(fn
@@ -1191,6 +1217,115 @@
trail
k)
false)))
((and (pl-compound? g) (= (pl-fun g) "\\+") (= (len (pl-args g)) 1))
(let
((mark (pl-trail-mark trail)))
(let
((r (pl-solve! db (first (pl-args g)) trail {:cut false} (fn () true))))
(pl-trail-undo-to! trail mark)
(if r false (k)))))
((and (pl-compound? g) (= (pl-fun g) "not") (= (len (pl-args g)) 1))
(let
((mark (pl-trail-mark trail)))
(let
((r (pl-solve! db (first (pl-args g)) trail {:cut false} (fn () true))))
(pl-trail-undo-to! trail mark)
(if r false (k)))))
((and (pl-compound? g) (= (pl-fun g) "once") (= (len (pl-args g)) 1))
(pl-solve-if-then-else!
db
(first (pl-args g))
(list "atom" "true")
(list "atom" "fail")
trail
cut-box
k))
((and (pl-compound? g) (= (pl-fun g) "ignore") (= (len (pl-args g)) 1))
(pl-solve-if-then-else!
db
(first (pl-args g))
(list "atom" "true")
(list "atom" "true")
trail
cut-box
k))
((and (pl-compound? g) (= (pl-fun g) "ground") (= (len (pl-args g)) 1))
(if (pl-ground? (first (pl-args g))) (k) false))
((and (pl-compound? g) (= (pl-fun g) "sort") (= (len (pl-args g)) 2))
(let
((elems (pl-prolog-list-to-sx (first (pl-args g)))))
(let
((keyed (map (fn (e) (list (pl-format-term e) e)) elems)))
(let
((sorted (sort keyed)))
(let
((deduped (pl-sort-pairs-dedup sorted)))
(pl-solve-eq!
(nth (pl-args g) 1)
(pl-list-to-prolog (map (fn (p) (nth p 1)) deduped))
trail
k))))))
((and (pl-compound? g) (= (pl-fun g) "msort") (= (len (pl-args g)) 2))
(let
((elems (pl-prolog-list-to-sx (first (pl-args g)))))
(let
((keyed (map (fn (e) (list (pl-format-term e) e)) elems)))
(let
((sorted (sort keyed)))
(pl-solve-eq!
(nth (pl-args g) 1)
(pl-list-to-prolog (map (fn (p) (nth p 1)) sorted))
trail
k)))))
((and (pl-compound? g) (= (pl-fun g) "atom_number") (= (len (pl-args g)) 2))
(let
((wa (pl-walk (first (pl-args g))))
(wb (pl-walk (nth (pl-args g) 1))))
(cond
((pl-atom? wa)
(let
((n (parse-number (pl-atom-name wa))))
(if
(nil? n)
false
(pl-solve-eq!
(nth (pl-args g) 1)
(list "num" n)
trail
k))))
((pl-num? wb)
(pl-solve-eq!
(first (pl-args g))
(list "atom" (str (pl-num-val wb)))
trail
k))
(true false))))
((and (pl-compound? g) (= (pl-fun g) "number_string") (= (len (pl-args g)) 2))
(let
((wa (pl-walk (first (pl-args g))))
(wb (pl-walk (nth (pl-args g) 1))))
(cond
((pl-num? wa)
(pl-solve-eq!
(nth (pl-args g) 1)
(list "atom" (str (pl-num-val wa)))
trail
k))
((pl-var? wa)
(if
(pl-atom? wb)
(let
((n (parse-number (pl-atom-name wb))))
(if
(nil? n)
false
(pl-solve-eq!
(first (pl-args g))
(list "num" n)
trail
k)))
false))
(true false))))
(true (pl-solve-user! db g trail cut-box k))))))
(define