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

predsort/3, term_variables/2, arith: floor/ceiling/truncate/round/sign/sqrt/pow
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Details

Browse Source 
- pl-eval-arith: add floor, ceiling, truncate, round, sqrt, sign, pow, integer,
  float, float_integer_part, float_fractional_part, **, ^ operators
- pl-collect-vars: helper that extracts unbound variables from a term (left-to-right,
  deduplicated by var id)
- term_variables/2: dispatches via pl-collect-vars, unifies second arg with var list
- pl-predsort-insert!: inserts one element into a sorted list using a 3-arg comparator
  predicate; deduplicates elements where comparator returns '='
- pl-predsort-build!: builds sorted list via fold over pl-predsort-insert!
- predsort/3: full ISO predsort — sorts and deduplicates a list using a caller-supplied
  predicate
- lib/prolog/tests/advanced.sx: 21 tests (12 arith, 5 term_variables, 4 predsort)
- conformance.sh: add advanced suite
- scoreboard: 517/517 (was 496/496)

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-25 14:13:12 +00:00
parent bf250a24bf
commit 788ac9dd05
5 changed files with 424 additions and 45 deletions
Download Patch File Download Diff File Expand all files Collapse all files

201
lib/prolog/runtime.sx
View File

@@ -410,6 +410,72 @@
((sorted-keys (sort (keys kv))))
(map (fn (k) (dict-get kv k)) sorted-keys))))))
(define
pl-collect-vars
(fn
(term seen-ids)
(let
((walked (pl-walk term)))
(cond
((pl-var? walked)
(let
((id (pl-var-id walked)))
(if
(some (fn (s) (= s id)) seen-ids)
(list seen-ids (list))
(list (cons id seen-ids) (list walked)))))
((pl-compound? walked)
(reduce
(fn
(acc arg)
(let
((result (pl-collect-vars arg (first acc))))
(list (first result) (append (nth acc 1) (nth result 1)))))
(list seen-ids (list))
(pl-args walked)))
(true (list seen-ids (list)))))))
(define
pl-predsort-insert!
(fn
(db pred elem sorted trail)
(if
(empty? sorted)
(list elem)
(let
((head (first sorted)) (order-var (pl-mk-rt-var "_PO")))
(let
((call-goal (pl-apply-goal pred (list order-var elem head)))
(mark (pl-trail-mark trail)))
(let
((ok (pl-solve-once! db call-goal trail)))
(if
ok
(let
((order (pl-atom-name (pl-walk-deep order-var))))
(do
(pl-trail-undo-to! trail mark)
(cond
((= order "<") (cons elem sorted))
((= order "=") sorted)
((= order ">")
(let
((rest-sorted (pl-predsort-insert! db pred elem (rest sorted) trail)))
(if rest-sorted (cons head rest-sorted) false)))
(true false))))
(begin (pl-trail-undo-to! trail mark) false))))))))
(define
pl-predsort-build!
(fn
(db pred items trail)
(reduce
(fn
(sorted elem)
(if sorted (pl-predsort-insert! db pred elem sorted trail) false))
(list)
items)))
(define
pl-collect-solutions
(fn
@@ -782,6 +848,7 @@
false)))
(true false)))))
;; ── Structural equality helper (for ==/2, \==/2, delete/3) ────────
(define
pl-solve-atom-chars!
(fn
@@ -820,6 +887,7 @@
false))
(true false)))))
;; ── Flatten helper: collect all non-list leaves into SX list ───────
(define
pl-solve-atom-codes!
(fn
@@ -864,6 +932,7 @@
false))
(true false)))))
;; ── numlist helper: build SX list of ("num" i) for i in [lo..hi] ──
(define
pl-solve-char-code!
(fn
@@ -886,7 +955,7 @@
k))
(true false)))))
;; ── Structural equality helper (for ==/2, \==/2, delete/3) ────────
;; ── atomic_list_concat helper: collect atom names / num vals ───────
(define
pl-struct-eq?
(fn
@@ -896,19 +965,18 @@
(= (dict-get a :id) (dict-get b :id)))
((and (pl-atom? a) (pl-atom? b))
(= (pl-atom-name a) (pl-atom-name b)))
((and (pl-num? a) (pl-num? b))
(= (pl-num-val a) (pl-num-val b)))
((and (pl-num? a) (pl-num? b)) (= (pl-num-val a) (pl-num-val b)))
((and (pl-compound? a) (pl-compound? b))
(if
(and
(= (pl-fun a) (pl-fun b))
(= (len (pl-args a)) (len (pl-args b))))
(let
((all-eq true)
(i 0))
((all-eq true) (i 0))
(begin
(for-each
(fn (ai)
(fn
(ai)
(begin
(if
(not (pl-struct-eq? ai (nth (pl-args b) i)))
@@ -920,7 +988,7 @@
false))
(true false))))
;; ── Flatten helper: collect all non-list leaves into SX list ───────
;; ── sum_list helper ────────────────────────────────────────────────
(define
pl-flatten-prolog
(fn
@@ -941,7 +1009,7 @@
(cons h (pl-flatten-prolog tl)))))
(true (list w))))))
;; ── numlist helper: build SX list of ("num" i) for i in [lo..hi] ──
;; ── max_list / min_list helpers ────────────────────────────────────
(define
pl-numlist-build
(fn
@@ -951,7 +1019,6 @@
(list)
(cons (list "num" lo) (pl-numlist-build (+ lo 1) hi)))))
;; ── atomic_list_concat helper: collect atom names / num vals ───────
(define
pl-atomic-list-collect
(fn
@@ -959,7 +1026,8 @@
(let
((items (pl-prolog-list-to-sx prolog-list)))
(map
(fn (item)
(fn
(item)
(let
((w (pl-walk-deep item)))
(cond
@@ -968,7 +1036,7 @@
(true ""))))
items))))
;; ── sum_list helper ────────────────────────────────────────────────
;; ── delete/3 helper: remove elements struct-equal to elem ──────────
(define
pl-sum-list-sx
(fn
@@ -976,12 +1044,11 @@
(let
((items (pl-prolog-list-to-sx prolog-list)))
(reduce
(fn (acc item)
(+ acc (pl-num-val (pl-walk-deep item))))
(fn (acc item) (+ acc (pl-num-val (pl-walk-deep item))))
0
items))))
;; ── max_list / min_list helpers ────────────────────────────────────
;; ── join string list with separator ────────────────────────────────
(define
pl-max-list-sx
(fn
@@ -989,8 +1056,10 @@
(let
((items (pl-prolog-list-to-sx prolog-list)))
(reduce
(fn (acc item)
(let ((v (pl-num-val (pl-walk-deep item))))
(fn
(acc item)
(let
((v (pl-num-val (pl-walk-deep item))))
(if (> v acc) v acc)))
(pl-num-val (pl-walk-deep (first items)))
(rest items)))))
@@ -1002,26 +1071,24 @@
(let
((items (pl-prolog-list-to-sx prolog-list)))
(reduce
(fn (acc item)
(let ((v (pl-num-val (pl-walk-deep item))))
(fn
(acc item)
(let
((v (pl-num-val (pl-walk-deep item))))
(if (< v acc) v acc)))
(pl-num-val (pl-walk-deep (first items)))
(rest items)))))
;; ── delete/3 helper: remove elements struct-equal to elem ──────────
(define
pl-delete-sx
(fn
(prolog-list elem)
(let
((items (pl-prolog-list-to-sx prolog-list))
(ew (pl-walk-deep elem)))
((items (pl-prolog-list-to-sx prolog-list)) (ew (pl-walk-deep elem)))
(filter
(fn (item)
(not (pl-struct-eq? (pl-walk-deep item) ew)))
(fn (item) (not (pl-struct-eq? (pl-walk-deep item) ew)))
items))))
;; ── join string list with separator ────────────────────────────────
(define
pl-join-strings
(fn
@@ -1029,10 +1096,7 @@
(if
(empty? strs)
""
(reduce
(fn (acc s) (str acc sep s))
(first strs)
(rest strs)))))
(reduce (fn (acc s) (str acc sep s)) (first strs) (rest strs)))))
(define
pl-apply-goal
@@ -1433,14 +1497,7 @@
(let
((clause (first parsed)))
(let
((actual-term
(if
(and
(list? clause)
(= (len clause) 3)
(= (nth clause 0) "clause"))
(nth clause 1)
clause)))
((actual-term (if (and (list? clause) (= (len clause) 3) (= (nth clause 0) "clause")) (nth clause 1) clause)))
(let
((fresh (pl-instantiate actual-term {})))
(if (pl-unify! term-arg fresh trail) (k) false))))
@@ -1473,10 +1530,14 @@
(set! pl-output-buffer saved-buffer)
(if
result
(if (pl-unify! var (list "atom" captured) trail) (k) false)
(if
(pl-unify! var (list "atom" captured) trail)
(k)
false)
false))))))
false))))
(define
pl-solve-writeln!
(fn
@@ -1495,7 +1556,8 @@
(if
(pl-atom? fmt-walked)
(do
(pl-output-write! (pl-format-process (pl-atom-name fmt-walked) (list)))
(pl-output-write!
(pl-format-process (pl-atom-name fmt-walked) (list)))
(k))
false))))
@@ -1516,7 +1578,6 @@
(k)))
false))))
(define
pl-substring
(fn (s start sublen) (substring s start (+ start sublen))))
@@ -2407,6 +2468,32 @@
(pl-walk (nth (pl-args g) 2))
trail
k))
((and (pl-compound? g) (= (pl-fun g) "term_variables") (= (len (pl-args g)) 2))
(let
((term (pl-walk (nth (pl-args g) 0)))
(vars-arg (pl-walk (nth (pl-args g) 1))))
(let
((result (pl-collect-vars term (list))))
(let
((var-list (nth result 1)))
(let
((prolog-vars (pl-list-to-prolog var-list)))
(if (pl-unify! vars-arg prolog-vars trail) (k) false))))))
((and (pl-compound? g) (= (pl-fun g) "predsort") (= (len (pl-args g)) 3))
(let
((pred (pl-walk (nth (pl-args g) 0)))
(list-arg (pl-walk (nth (pl-args g) 1)))
(result-arg (pl-walk (nth (pl-args g) 2))))
(let
((items (pl-prolog-list-to-sx (pl-walk-deep list-arg))))
(let
((sorted (pl-predsort-build! db pred items trail)))
(if
sorted
(let
((prolog-sorted (pl-list-to-prolog sorted)))
(if (pl-unify! result-arg prolog-sorted trail) (k) false))
false)))))
(true (pl-solve-user! db g trail cut-box k))))))
(define
@@ -2543,6 +2630,42 @@
((va (pl-eval-arith (first args)))
(vb (pl-eval-arith (nth args 1))))
(cond ((< va vb) va) (true vb))))
((and (= f "floor") (= (len args) 1))
(floor (pl-eval-arith (first args))))
((and (= f "ceiling") (= (len args) 1))
(ceil (pl-eval-arith (first args))))
((and (= f "truncate") (= (len args) 1))
(truncate (pl-eval-arith (first args))))
((and (= f "round") (= (len args) 1))
(round (pl-eval-arith (first args))))
((and (= f "sqrt") (= (len args) 1))
(sqrt (pl-eval-arith (first args))))
((and (= f "sign") (= (len args) 1))
(let
((v (pl-eval-arith (first args))))
(cond ((< v 0) -1) ((> v 0) 1) (true 0))))
((and (= f "integer") (= (len args) 1))
(truncate (pl-eval-arith (first args))))
((and (= f "float") (= (len args) 1))
(pl-eval-arith (first args)))
((and (= f "float_integer_part") (= (len args) 1))
(truncate (pl-eval-arith (first args))))
((and (= f "float_fractional_part") (= (len args) 1))
(let
((v (pl-eval-arith (first args))))
(- v (truncate v))))
((and (= f "**") (= (len args) 2))
(pow
(pl-eval-arith (first args))
(pl-eval-arith (nth args 1))))
((and (= f "^") (= (len args) 2))
(pow
(pl-eval-arith (first args))
(pl-eval-arith (nth args 1))))
((and (= f "pow") (= (len args) 2))
(pow
(pl-eval-arith (first args))
(pl-eval-arith (nth args 1))))
(true 0))))
(true 0)))))