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

sub_atom/5 (non-det substring) + aggregate_all/3 (count/bag/sum/max/min/set)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Details

Browse Source 
Adds two new builtins to lib/prolog/runtime.sx:

- sub_atom/5: non-deterministic substring enumeration. Iterates all
  (start, length) pairs over the atom string, tries to unify Before,
  Length, After, SubAtom for each candidate. Uses CPS loop helpers
  pl-substring, pl-sub-atom-try-one!, pl-sub-atom-loop!. Fixed trail
  undo semantics: only undo on backtrack (k returns false), not on success.

- aggregate_all/3: collects all solutions via pl-collect-solutions then
  reduces. Templates: count, bag(T), sum(E), max(E), min(E), set(T).
  max/min fail on empty; count/bag/sum/set always succeed.

New test suite lib/prolog/tests/string_agg.sx: 25 tests, all passing.
Total conformance: 496/496.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-25 13:50:13 +00:00
parent 0a8b30b7b8
commit 537e2cdb5a
5 changed files with 448 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files

168
lib/prolog/runtime.sx
View File

@@ -1517,6 +1517,139 @@
false))))
(define
pl-substring
(fn (s start sublen) (substring s start (+ start sublen))))
(define
pl-sub-atom-try-one!
(fn
(s start sublen total-len before-arg len-arg after-arg sub-arg trail k)
(let
((mark (pl-trail-mark trail))
(after-val (- total-len (+ start sublen)))
(sub (pl-substring s start sublen)))
(if
(and
(pl-unify! before-arg (list "num" start) trail)
(pl-unify! len-arg (list "num" sublen) trail)
(pl-unify! after-arg (list "num" after-val) trail)
(pl-unify! sub-arg (list "atom" sub) trail))
(let
((kresult (k)))
(if kresult kresult (begin (pl-trail-undo-to! trail mark) false)))
(begin (pl-trail-undo-to! trail mark) false)))))
(define
pl-sub-atom-loop!
(fn
(s total-len start sublen before-arg len-arg after-arg sub-arg trail k)
(cond
((> start total-len) false)
((> sublen (- total-len start))
(pl-sub-atom-loop!
s
total-len
(+ start 1)
0
before-arg
len-arg
after-arg
sub-arg
trail
k))
(true
(let
((one-result (pl-sub-atom-try-one! s start sublen total-len before-arg len-arg after-arg sub-arg trail k)))
(if
one-result
one-result
(pl-sub-atom-loop!
s
total-len
start
(+ sublen 1)
before-arg
len-arg
after-arg
sub-arg
trail
k)))))))
(define
pl-solve-aggregate-all!
(fn
(db tmpl goal result trail k)
(let
((tmpl-walked (pl-walk-deep tmpl)))
(cond
((and (pl-atom? tmpl-walked) (= (pl-atom-name tmpl-walked) "count"))
(let
((solutions (pl-collect-solutions db (list "atom" "true") goal trail)))
(if
(pl-unify! result (list "num" (len solutions)) trail)
(k)
false)))
((and (pl-compound? tmpl-walked) (= (pl-fun tmpl-walked) "bag") (= (len (pl-args tmpl-walked)) 1))
(let
((template (nth (pl-args tmpl-walked) 0)))
(let
((solutions (pl-collect-solutions db template goal trail)))
(let
((prolog-list (pl-mk-list-term solutions (pl-nil-term))))
(if (pl-unify! result prolog-list trail) (k) false)))))
((and (pl-compound? tmpl-walked) (= (pl-fun tmpl-walked) "sum") (= (len (pl-args tmpl-walked)) 1))
(let
((template (nth (pl-args tmpl-walked) 0)))
(let
((solutions (pl-collect-solutions db template goal trail)))
(let
((total (reduce (fn (acc sol) (+ acc (pl-eval-arith sol))) 0 solutions)))
(if (pl-unify! result (list "num" total) trail) (k) false)))))
((and (pl-compound? tmpl-walked) (= (pl-fun tmpl-walked) "max") (= (len (pl-args tmpl-walked)) 1))
(let
((template (nth (pl-args tmpl-walked) 0)))
(let
((solutions (pl-collect-solutions db template goal trail)))
(if
(empty? solutions)
false
(let
((vals (map pl-eval-arith solutions)))
(let
((mx (reduce (fn (a b) (if (> a b) a b)) (first vals) (rest vals))))
(if (pl-unify! result (list "num" mx) trail) (k) false)))))))
((and (pl-compound? tmpl-walked) (= (pl-fun tmpl-walked) "min") (= (len (pl-args tmpl-walked)) 1))
(let
((template (nth (pl-args tmpl-walked) 0)))
(let
((solutions (pl-collect-solutions db template goal trail)))
(if
(empty? solutions)
false
(let
((vals (map pl-eval-arith solutions)))
(let
((mn (reduce (fn (a b) (if (< a b) a b)) (first vals) (rest vals))))
(if (pl-unify! result (list "num" mn) trail) (k) false)))))))
((and (pl-compound? tmpl-walked) (= (pl-fun tmpl-walked) "set") (= (len (pl-args tmpl-walked)) 1))
(let
((template (nth (pl-args tmpl-walked) 0)))
(let
((solutions (pl-collect-solutions db template goal trail)))
(let
((deduped (pl-list-to-set-sx solutions (list))))
(let
((keyed (map (fn (t) (list (pl-format-term t) t)) deduped)))
(let
((sorted (sort keyed)))
(let
((sorted-terms (map (fn (pair) (nth pair 1)) sorted)))
(let
((prolog-list (pl-mk-list-term sorted-terms (pl-nil-term))))
(if (pl-unify! result prolog-list trail) (k) false)))))))))
(true false)))))
(define
pl-solve!
(fn
@@ -2240,7 +2373,40 @@
((and (pl-compound? g) (= (pl-fun g) "format") (= (len (pl-args g)) 1))
(pl-solve-format-1! (nth (pl-args g) 0) k))
((and (pl-compound? g) (= (pl-fun g) "format") (= (len (pl-args g)) 2))
(pl-solve-format-2! db (nth (pl-args g) 0) (nth (pl-args g) 1) trail k))
(pl-solve-format-2!
db
(nth (pl-args g) 0)
(nth (pl-args g) 1)
trail
k))
((and (pl-compound? g) (= (pl-fun g) "sub_atom") (= (len (pl-args g)) 5))
(let
((atom-term (pl-walk-deep (nth (pl-args g) 0))))
(if
(pl-atom? atom-term)
(let
((s (pl-atom-name atom-term))
(total-len (len (pl-atom-name atom-term))))
(pl-sub-atom-loop!
s
total-len
0
0
(pl-walk (nth (pl-args g) 1))
(pl-walk (nth (pl-args g) 2))
(pl-walk (nth (pl-args g) 3))
(pl-walk (nth (pl-args g) 4))
trail
k))
false)))
((and (pl-compound? g) (= (pl-fun g) "aggregate_all") (= (len (pl-args g)) 3))
(pl-solve-aggregate-all!
db
(pl-walk (nth (pl-args g) 0))
(pl-walk (nth (pl-args g) 1))
(pl-walk (nth (pl-args g) 2))
trail
k))
(true (pl-solve-user! db g trail cut-box k))))))
(define