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

Compare commits

base: coop:74ce9e7c750412a06e01bd7377435db5990eadea
Branches Tags
coop:main coop:loops/fed-sx-m1 coop:loops/go coop:loops/fed-prims coop:loops/erlang coop:architecture coop:lib/guest/quoting coop:loops/scheme coop:hs-f coop:lib/guest/method-chain coop:lib/guest/test-runner coop:lib/smalltalk/refl-env coop:lib/tcl/uplevel coop:loops/kernel coop:loops/apl coop:loops/datalog coop:loops/js coop:loops/ocaml coop:loops/haskell coop:loops/minikanren coop:loops/tcl coop:bugs/resume-letrec coop:bugs/jit-bytecode-loop coop:loops/prolog coop:loops/smalltalk coop:loops/ruby coop:loops/lua coop:loops/forth coop:loops/common-lisp coop:loops/hs coop:hs-e36-websocket coop:hs-e37-tokenizer coop:hs-e39-webworker coop:wasm coop:macros coop:sx coop:exorcism coop:cssx coop:decoupling coop:sexpression coop:relations
..
compare: coop:loops/common-lisp
Branches Tags
coop:loops/fed-sx-m1 coop:loops/go coop:loops/fed-prims coop:loops/erlang coop:architecture coop:lib/guest/quoting coop:loops/scheme coop:hs-f coop:lib/guest/method-chain coop:lib/guest/test-runner coop:lib/smalltalk/refl-env coop:lib/tcl/uplevel coop:loops/kernel coop:loops/apl coop:loops/datalog coop:loops/js coop:loops/ocaml coop:loops/haskell coop:loops/minikanren coop:loops/tcl coop:bugs/resume-letrec coop:bugs/jit-bytecode-loop coop:loops/prolog coop:loops/smalltalk coop:loops/ruby coop:loops/lua coop:loops/forth coop:loops/common-lisp coop:loops/hs coop:hs-e36-websocket coop:hs-e37-tokenizer coop:hs-e39-webworker coop:main coop:wasm coop:macros coop:sx coop:exorcism coop:cssx coop:decoupling coop:sexpression coop:relations

1 Commits
74ce9e7c75 ... loops/comm

Author SHA1 Message Date
giles
6d53d36495 briefing: push to origin/loops/common-lisp after each commit
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 40s
Details
2026-05-05 20:08:03 +00:00
72 changed files with 7142 additions and 24983 deletions
Expand all files Collapse all files

207
lib/common-lisp/tests/runtime.sx
View File

@@ -1,207 +0,0 @@
;; lib/common-lisp/tests/runtime.sx — tests for CL runtime layer
(load "lib/common-lisp/runtime.sx")
(defsuite
"cl-types"
(deftest "cl-null? nil" (assert= true (cl-null? nil)))
(deftest "cl-null? false" (assert= false (cl-null? false)))
(deftest
"cl-consp? pair"
(assert= true (cl-consp? (list 1 2))))
(deftest "cl-consp? nil" (assert= false (cl-consp? nil)))
(deftest "cl-listp? nil" (assert= true (cl-listp? nil)))
(deftest
"cl-listp? list"
(assert= true (cl-listp? (list 1 2))))
(deftest "cl-atom? nil" (assert= true (cl-atom? nil)))
(deftest "cl-atom? pair" (assert= false (cl-atom? (list 1))))
(deftest "cl-integerp?" (assert= true (cl-integerp? 42)))
(deftest "cl-floatp?" (assert= true (cl-floatp? 3.14)))
(deftest
"cl-characterp?"
(assert= true (cl-characterp? (integer->char 65))))
(deftest "cl-stringp?" (assert= true (cl-stringp? "hello")))
(deftest "cl-symbolp?" (assert= true (cl-symbolp? (quote foo)))))
(defsuite
"cl-arithmetic"
(deftest "cl-mod" (assert= 1 (cl-mod 10 3)))
(deftest "cl-rem" (assert= 1 (cl-rem 10 3)))
(deftest
"cl-quotient"
(assert= 3 (cl-quotient 10 3)))
(deftest "cl-gcd" (assert= 4 (cl-gcd 12 8)))
(deftest "cl-lcm" (assert= 12 (cl-lcm 4 6)))
(deftest "cl-abs pos" (assert= 5 (cl-abs 5)))
(deftest "cl-abs neg" (assert= 5 (cl-abs -5)))
(deftest "cl-min" (assert= 2 (cl-min 2 7)))
(deftest "cl-max" (assert= 7 (cl-max 2 7)))
(deftest "cl-evenp? t" (assert= true (cl-evenp? 4)))
(deftest "cl-evenp? f" (assert= false (cl-evenp? 3)))
(deftest "cl-oddp? t" (assert= true (cl-oddp? 7)))
(deftest "cl-zerop?" (assert= true (cl-zerop? 0)))
(deftest "cl-plusp?" (assert= true (cl-plusp? 1)))
(deftest "cl-minusp?" (assert= true (cl-minusp? -1)))
(deftest "cl-signum pos" (assert= 1 (cl-signum 42)))
(deftest "cl-signum neg" (assert= -1 (cl-signum -7)))
(deftest "cl-signum zero" (assert= 0 (cl-signum 0))))
(defsuite
"cl-chars"
(deftest
"cl-char-code"
(assert= 65 (cl-char-code (integer->char 65))))
(deftest "cl-code-char" (assert= true (char? (cl-code-char 65))))
(deftest
"cl-char-upcase"
(assert=
(integer->char 65)
(cl-char-upcase (integer->char 97))))
(deftest
"cl-char-downcase"
(assert=
(integer->char 97)
(cl-char-downcase (integer->char 65))))
(deftest
"cl-alpha-char-p"
(assert= true (cl-alpha-char-p (integer->char 65))))
(deftest
"cl-digit-char-p"
(assert= true (cl-digit-char-p (integer->char 48))))
(deftest
"cl-char=?"
(assert=
true
(cl-char=? (integer->char 65) (integer->char 65))))
(deftest
"cl-char<?"
(assert=
true
(cl-char<? (integer->char 65) (integer->char 90))))
(deftest
"cl-char space"
(assert= (integer->char 32) cl-char-space))
(deftest
"cl-char newline"
(assert= (integer->char 10) cl-char-newline)))
(defsuite
"cl-format"
(deftest
"cl-format nil basic"
(assert= "hello" (cl-format nil "~a" "hello")))
(deftest
"cl-format nil number"
(assert= "42" (cl-format nil "~d" 42)))
(deftest
"cl-format nil hex"
(assert= "ff" (cl-format nil "~x" 255)))
(deftest
"cl-format nil template"
(assert= "x=3 y=4" (cl-format nil "x=~d y=~d" 3 4)))
(deftest "cl-format nil tilde" (assert= "a~b" (cl-format nil "a~~b"))))
(defsuite
"cl-gensym"
(deftest
"cl-gensym returns symbol"
(assert= "symbol" (type-of (cl-gensym))))
(deftest "cl-gensym unique" (assert= false (= (cl-gensym) (cl-gensym)))))
(defsuite
"cl-sets"
(deftest "cl-make-set empty" (assert= true (cl-set? (cl-make-set))))
(deftest
"cl-set-add/member"
(let
((s (cl-make-set)))
(do
(cl-set-add s 1)
(assert= true (cl-set-memberp s 1)))))
(deftest
"cl-set-memberp false"
(assert= false (cl-set-memberp (cl-make-set) 42)))
(deftest
"cl-list->set"
(let
((s (cl-list->set (list 1 2 3))))
(assert= true (cl-set-memberp s 2)))))
(defsuite
"cl-lists"
(deftest
"cl-nth 0"
(assert=
1
(cl-nth 0 (list 1 2 3))))
(deftest
"cl-nth 2"
(assert=
3
(cl-nth 2 (list 1 2 3))))
(deftest
"cl-last"
(assert=
(list 3)
(cl-last (list 1 2 3))))
(deftest
"cl-butlast"
(assert=
(list 1 2)
(cl-butlast (list 1 2 3))))
(deftest
"cl-nthcdr 1"
(assert=
(list 2 3)
(cl-nthcdr 1 (list 1 2 3))))
(deftest
"cl-assoc hit"
(assert=
(list "b" 2)
(cl-assoc "b" (list (list "a" 1) (list "b" 2)))))
(deftest
"cl-assoc miss"
(assert= nil (cl-assoc "z" (list (list "a" 1)))))
(deftest
"cl-getf hit"
(assert= 42 (cl-getf (list "x" 42 "y" 99) "x")))
(deftest "cl-getf miss" (assert= nil (cl-getf (list "x" 42) "z")))
(deftest
"cl-adjoin new"
(assert=
(list 0 1 2)
(cl-adjoin 0 (list 1 2))))
(deftest
"cl-adjoin dup"
(assert=
(list 1 2)
(cl-adjoin 1 (list 1 2))))
(deftest
"cl-flatten"
(assert=
(list 1 2 3 4)
(cl-flatten (list 1 (list 2 3) 4))))
(deftest
"cl-member hit"
(assert=
(list 2 3)
(cl-member 2 (list 1 2 3))))
(deftest
"cl-member miss"
(assert=
nil
(cl-member 9 (list 1 2 3)))))
(defsuite
"cl-radix"
(deftest "binary" (assert= "1010" (cl-format-binary 10)))
(deftest "octal" (assert= "17" (cl-format-octal 15)))
(deftest "hex" (assert= "ff" (cl-format-hex 255)))
(deftest "decimal" (assert= "42" (cl-format-decimal 42)))
(deftest
"n->s r16"
(assert= "1f" (cl-integer-to-string 31 16)))
(deftest
"s->n r16"
(assert= 31 (cl-string-to-integer "1f" 16))))

266
lib/hyperscript/compiler.sx
View File

@@ -48,15 +48,6 @@
prop
value))
(list (quote hs-query-all) (nth base-ast 1))))
((and (list? base-ast) (= (first base-ast) (quote query)))
(list
(quote dom-set-prop)
(list
(quote hs-named-target)
(nth base-ast 1)
(list (quote hs-query-first) (nth base-ast 1)))
prop
value))
((and (list? base-ast) (= (first base-ast) dot-sym) (let ((inner (nth base-ast 1))) (and (list? inner) (= (first inner) (quote query)) (let ((s (nth inner 1))) (and (string? s) (> (len s) 0) (= (substring s 0 1) "."))))))
(let
((inner (nth base-ast 1))
@@ -155,14 +146,6 @@
(nth prop-ast 1)
value)
(list (quote set!) (hs-to-sx target) value))))))
((= th (quote query))
(list
(quote hs-set-inner-html!)
(list
(quote hs-named-target)
(nth target 1)
(list (quote hs-query-first) (nth target 1)))
value))
(true (list (quote set!) (hs-to-sx target) value)))))))
(define
emit-on
@@ -291,33 +274,17 @@
((name (nth ast 1)) (rest-parts (rest (rest ast))))
(cond
((and (= (len ast) 4) (list? (nth ast 2)) (= (first (nth ast 2)) (quote dict)))
(let
((tgt-ast (nth ast 3)))
(list
(quote dom-dispatch)
(if
(and (list? tgt-ast) (= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast))
(hs-to-sx (nth ast 3))
name
(hs-to-sx (nth ast 2)))))
(hs-to-sx (nth ast 2))))
((= (len ast) 3)
(let
((tgt-ast (nth ast 2)))
(list
(quote dom-dispatch)
(if
(and (list? tgt-ast) (= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast))
(hs-to-sx (nth ast 2))
name
(list (quote dict) "sender" (quote me)))))
(list (quote dict) "sender" (quote me))))
(true
(list
(quote dom-dispatch)
@@ -739,33 +706,6 @@
(quote fn)
(cons (quote me) (map make-symbol params))
(cons (quote do) (map hs-to-sx body)))))))
(define
hs-safe-obj
(fn
(obj-ast)
(if
(and (list? obj-ast) (= (first obj-ast) (quote ref)))
(list (quote host-global) (nth obj-ast 1))
(if
(and (list? obj-ast) (= (first obj-ast) dot-sym))
(let
((inner (nth obj-ast 1)) (prop (nth obj-ast 2)))
(list (quote host-get) (hs-safe-obj inner) prop))
(hs-to-sx obj-ast)))))
(define
hs-chain-name
(fn
(obj-ast)
(if
(and (list? obj-ast) (= (first obj-ast) (quote ref)))
(nth obj-ast 1)
(if
(and (list? obj-ast) (= (first obj-ast) dot-sym))
(str (hs-chain-name (nth obj-ast 1)) "." (nth obj-ast 2))
(if
(and (list? obj-ast) (= (first obj-ast) (quote query)))
(nth obj-ast 1)
nil)))))
(fn
(ast)
(cond
@@ -1285,22 +1225,13 @@
((raw-tgt (nth ast 2)))
(if
(and (list? raw-tgt) (= (first raw-tgt) (quote query)))
(list
(quote let)
(list
(list
(quote _tgt)
(list (quote hs-query-named-all) (nth raw-tgt 1))))
(list
(quote for-each)
(list
(quote fn)
(list (quote _el))
(list
(quote dom-add-class)
(quote _el)
(nth ast 1)))
(quote _tgt)))
(list (quote dom-add-class) (quote _el) (nth ast 1)))
(list (quote hs-query-all) (nth raw-tgt 1)))
(list
(quote dom-add-class)
(hs-to-sx raw-tgt)
@@ -1313,20 +1244,14 @@
(nth ast 2)))
((= head (quote set-styles))
(let
((pairs (nth ast 1)) (tgt-ast (nth ast 2)))
(let
((tgt (if (and (list? tgt-ast) (= (first tgt-ast) (quote query))) (list (quote hs-named-target) (nth tgt-ast 1) (list (quote hs-query-first) (nth tgt-ast 1))) (hs-to-sx tgt-ast))))
((pairs (nth ast 1)) (tgt (hs-to-sx (nth ast 2))))
(cons
(quote do)
(map
(fn
(p)
(list
(quote dom-set-style)
tgt
(first p)
(nth p 1)))
pairs)))))
(list (quote dom-set-style) tgt (first p) (nth p 1)))
pairs))))
((= head (quote multi-add-class))
(let
((target (hs-to-sx (nth ast 1)))
@@ -1423,12 +1348,6 @@
((raw-tgt (nth ast 2)))
(if
(and (list? raw-tgt) (= (first raw-tgt) (quote query)))
(list
(quote let)
(list
(list
(quote _tgt)
(list (quote hs-query-named-all) (nth raw-tgt 1))))
(list
(quote for-each)
(list
@@ -1438,7 +1357,7 @@
(quote dom-remove-class)
(quote _el)
(nth ast 1)))
(quote _tgt)))
(list (quote hs-query-all) (nth raw-tgt 1)))
(list
(quote dom-remove-class)
(if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt))
@@ -1482,32 +1401,15 @@
((tgt (nth ast 3)))
(list
(quote hs-set-attr!)
(if
(and (list? tgt) (= (first tgt) (quote query)))
(list
(quote hs-named-target)
(nth tgt 1)
(list (quote hs-query-first) (nth tgt 1)))
(hs-to-sx tgt))
(hs-to-sx tgt)
(nth ast 1)
(hs-to-sx (nth ast 2)))))
((= head (quote remove-value))
(let
((val (hs-to-sx (nth ast 1))) (raw-tgt (nth ast 2)))
((val (hs-to-sx (nth ast 1))) (tgt (nth ast 2)))
(emit-set
raw-tgt
(list
(quote hs-remove-from!)
val
(if
(and
(list? raw-tgt)
(= (first raw-tgt) (quote query)))
(list
(quote hs-named-target)
(nth raw-tgt 1)
(list (quote hs-query-first) (nth raw-tgt 1)))
(hs-to-sx raw-tgt))))))
tgt
(list (quote hs-remove-from!) val (hs-to-sx tgt)))))
((= head (quote empty-target))
(let
((tgt (nth ast 1)))
@@ -1538,19 +1440,8 @@
(hs-to-sx (nth ast 2))))
((= head (quote remove-attr))
(let
((raw-tgt (nth ast 2)))
(list
(quote dom-remove-attr)
(if
(and
(list? raw-tgt)
(= (first raw-tgt) (quote query)))
(list
(quote hs-named-target)
(nth raw-tgt 1)
(list (quote hs-query-first) (nth raw-tgt 1)))
(if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt)))
(nth ast 1))))
((tgt (if (nil? (nth ast 2)) (quote me) (hs-to-sx (nth ast 2)))))
(list (quote dom-remove-attr) tgt (nth ast 1))))
((= head (quote remove-css))
(let
((tgt (if (nil? (nth ast 2)) (quote me) (hs-to-sx (nth ast 2))))
@@ -1561,20 +1452,10 @@
(fn (p) (list (quote dom-set-style) tgt p ""))
props))))
((= head (quote toggle-class))
(let
((tgt-ast (nth ast 2)))
(list
(quote hs-toggle-class!)
(if
(and
(list? tgt-ast)
(= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast))
(nth ast 1))))
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote toggle-class-for))
(list
(quote do)
@@ -1629,21 +1510,11 @@
(hs-to-sx tgt-ast)
(hs-to-sx val-ast)))))
((= head (quote toggle-between))
(let
((tgt-ast (nth ast 3)))
(list
(quote hs-toggle-between!)
(if
(and
(list? tgt-ast)
(= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast))
(hs-to-sx (nth ast 3))
(nth ast 1)
(nth ast 2))))
(nth ast 2)))
((= head (quote toggle-style))
(let
((raw-tgt (nth ast 2)))
@@ -1667,20 +1538,10 @@
(quote list)
(map hs-to-sx (slice ast 3 (len ast))))))
((= head (quote toggle-attr))
(let
((tgt-ast (nth ast 2)))
(list
(quote hs-toggle-attr!)
(if
(and
(list? tgt-ast)
(= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast))
(nth ast 1))))
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote toggle-attr-between))
(list
(quote hs-toggle-attr-between!)
@@ -1714,22 +1575,7 @@
(emit-set
raw-tgt
(list (quote hs-put-at!) val pos (hs-to-sx raw-tgt))))
(true
(let
((tgt-ast raw-tgt))
(list
(quote hs-put!)
val
pos
(if
(and
(list? tgt-ast)
(= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast))))))))
(true (list (quote hs-put!) val pos (hs-to-sx raw-tgt))))))
((= head (quote if))
(if
(> (len ast) 3)
@@ -1805,22 +1651,12 @@
(detail (if (= (len ast) 4) (nth ast 2) nil)))
(list
(quote dom-dispatch)
(let
((tgt-ast tgt))
(if
(and
(list? tgt-ast)
(= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast)))
(hs-to-sx tgt)
name
(if has-detail (hs-to-sx detail) nil))))
((= head (quote hide))
(let
((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-named-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt))))
((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt))))
(strategy (if (> (len ast) 2) (nth ast 2) "display"))
(when-cond (if (> (len ast) 3) (nth ast 3) nil)))
(if
@@ -1836,7 +1672,7 @@
(hs-to-sx when-cond))))))
((= head (quote show))
(let
((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-named-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt))))
((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt))))
(strategy (if (> (len ast) 2) (nth ast 2) "display"))
(when-cond (if (> (len ast) 3) (nth ast 3) nil)))
(if
@@ -1899,28 +1735,13 @@
((= head (quote call))
(let
((raw-fn (nth ast 1))
(args (map hs-to-sx (rest (rest ast)))))
(fn-expr
(if
(and (list? raw-fn) (= (first raw-fn) (quote ref)))
(let
((name (nth raw-fn 1)))
(list
(quote let)
(list
(list
(quote __hs-fn)
(list (quote host-global) name)))
(cons
(quote do)
(list
(list
(quote if)
(list (quote nil?) (quote __hs-fn))
(list (quote raise) (str "'" name "' is null"))
(cons (quote __hs-fn) args))))))
(let
((fn-expr (if (string? raw-fn) (make-symbol raw-fn) (hs-to-sx raw-fn))))
(cons fn-expr args)))))
(string? raw-fn)
(make-symbol raw-fn)
(hs-to-sx raw-fn)))
(args (map hs-to-sx (rest (rest ast)))))
(cons fn-expr args)))
((= head (quote return))
(let
((val (nth ast 1)))
@@ -1933,22 +1754,7 @@
((= head (quote throw))
(list (quote raise) (hs-to-sx (nth ast 1))))
((= head (quote settle))
(let
((raw-tgt (nth ast 1)))
(list
(quote hs-settle)
(if
(nil? raw-tgt)
(quote me)
(if
(and
(list? raw-tgt)
(= (first raw-tgt) (quote query)))
(list
(quote hs-named-target)
(nth raw-tgt 1)
(list (quote hs-query-first) (nth raw-tgt 1)))
(hs-to-sx raw-tgt))))))
(list (quote hs-settle) (quote me)))
((= head (quote go))
(list (quote hs-navigate!) (hs-to-sx (nth ast 1))))
((= head (quote ask))
@@ -2068,11 +1874,7 @@
((= head (quote install))
(cons (quote hs-install) (map hs-to-sx (rest ast))))
((= head (quote measure))
(let
((raw-tgt (nth ast 1)))
(let
((compiled-tgt (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-named-target) (nth raw-tgt 1) (list (quote hs-query-first) (nth raw-tgt 1))) (hs-to-sx raw-tgt))))
(list (quote hs-measure) compiled-tgt))))
(list (quote hs-measure) (hs-to-sx (nth ast 1))))
((= head (quote increment!))
(if
(= (len ast) 3)

11
lib/hyperscript/parser.sx
View File

@@ -2455,16 +2455,7 @@
((and (= typ "keyword") (= val "answer"))
(do (adv!) (parse-answer-cmd)))
((and (= typ "keyword") (= val "settle"))
(do
(adv!)
(if
(or
(at-end?)
(and
(= (tp-type) "keyword")
(or (= (tp-val) "then") (= (tp-val) "end"))))
(list (quote settle))
(list (quote settle) (parse-expr)))))
(do (adv!) (list (quote settle))))
((and (= typ "keyword") (= val "go"))
(do (adv!) (parse-go-cmd)))
((and (= typ "keyword") (= val "return"))

289
lib/hyperscript/runtime.sx
View File

@@ -12,14 +12,37 @@
;; Register an event listener. Returns unlisten function.
;; (hs-on target event-name handler) → unlisten-fn
(begin
(define _hs-config-log-all false)
(define _hs-log-captured (list))
(define
hs-set-log-all!
(fn (flag) (set! _hs-config-log-all (if flag true false))))
(define hs-get-log-captured (fn () _hs-log-captured))
(define
hs-clear-log-captured!
(fn () (begin (set! _hs-log-captured (list)) nil)))
(define
hs-log-event!
(fn
(msg)
(when
_hs-config-log-all
(begin
(set! _hs-log-captured (append _hs-log-captured (list msg)))
(host-call (host-global "console") "log" msg)
nil)))))
;; Register for every occurrence (no queuing — each fires independently).
;; Stock hyperscript queues by default; "every" disables queuing.
(define
hs-each
(fn
(target action)
(if (list? target) (for-each action target) (action target))))
;; Register for every occurrence (no queuing — each fires independently).
;; Stock hyperscript queues by default; "every" disables queuing.
;; Run an initializer function immediately.
;; (hs-init thunk) — called at element boot time
(define
hs-on
(fn
@@ -32,17 +55,17 @@
(dom-set-data target "hs-unlisteners" (append prev (list unlisten)))
unlisten))))
;; Run an initializer function immediately.
;; (hs-init thunk) — called at element boot time
(define
hs-on-every
(fn (target event-name handler) (dom-listen target event-name handler)))
;; ── Async / timing ──────────────────────────────────────────────
;; Wait for a duration in milliseconds.
;; In hyperscript, wait is async-transparent — execution pauses.
;; Here we use perform/IO suspension for true pause semantics.
(define
hs-on-every
(fn (target event-name handler) (dom-listen target event-name handler)))
;; Wait for a DOM event on a target.
;; (hs-wait-for target event-name) — suspends until event fires
(define
hs-on-intersection-attach!
(fn
@@ -58,16 +81,15 @@
(host-call observer "observe" target)
observer)))))
;; Wait for a DOM event on a target.
;; (hs-wait-for target event-name) — suspends until event fires
(define hs-init (fn (thunk) (thunk)))
;; Wait for CSS transitions/animations to settle on an element.
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
(define hs-init (fn (thunk) (thunk)))
;; ── Class manipulation ──────────────────────────────────────────
;; Toggle a single class on an element.
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
;; Toggle between two classes — exactly one is active at a time.
(begin
(define
hs-wait-for
@@ -80,19 +102,21 @@
(target event-name timeout-ms)
(perform (list (quote io-wait-event) target event-name timeout-ms)))))
;; Toggle between two classes — exactly one is active at a time.
(define hs-settle (fn (target) (perform (list (quote io-settle) target))))
;; Take a class from siblings — add to target, remove from others.
;; (hs-take! target cls) — like radio button class behavior
(define
hs-toggle-class!
(fn (target cls) (host-call (host-get target "classList") "toggle" cls)))
(define hs-settle (fn (target) (perform (list (quote io-settle) target))))
;; ── DOM insertion ───────────────────────────────────────────────
;; Put content at a position relative to a target.
;; pos: "into" | "before" | "after"
(define
hs-toggle-class!
(fn (target cls) (host-call (host-get target "classList") "toggle" cls)))
;; ── Navigation / traversal ──────────────────────────────────────
;; Navigate to a URL.
(define
hs-toggle-between!
(fn
@@ -102,9 +126,7 @@
(do (dom-remove-class target cls1) (dom-add-class target cls2))
(do (dom-remove-class target cls2) (dom-add-class target cls1)))))
;; ── Navigation / traversal ──────────────────────────────────────
;; Navigate to a URL.
;; Find next sibling matching a selector (or any sibling).
(define
hs-toggle-style!
(fn
@@ -128,7 +150,7 @@
(dom-set-style target prop "hidden")
(dom-set-style target prop "")))))))
;; Find next sibling matching a selector (or any sibling).
;; Find previous sibling matching a selector.
(define
hs-toggle-style-between!
(fn
@@ -140,7 +162,7 @@
(dom-set-style target prop val2)
(dom-set-style target prop val1)))))
;; Find previous sibling matching a selector.
;; First element matching selector within a scope.
(define
hs-toggle-style-cycle!
(fn
@@ -161,7 +183,7 @@
(true (find-next (rest remaining))))))
(dom-set-style target prop (find-next vals)))))
;; First element matching selector within a scope.
;; Last element matching selector.
(define
hs-take!
(fn
@@ -184,8 +206,7 @@
(when with-cls (dom-remove-class target with-cls))))
(let
((attr-val (if (> (len extra) 0) (first extra) nil))
(with-val
(if (> (len extra) 1) (nth extra 1) nil)))
(with-val (if (> (len extra) 1) (nth extra 1) nil)))
(do
(for-each
(fn
@@ -202,7 +223,7 @@
(dom-set-attr target name attr-val)
(dom-set-attr target name ""))))))))
;; Last element matching selector.
;; First/last within a specific scope.
(begin
(define
hs-element?
@@ -314,7 +335,6 @@
(dom-insert-adjacent-html target "beforeend" value)
(hs-boot-subtree! target)))))))))
;; First/last within a specific scope.
(define
hs-add-to!
(fn
@@ -327,6 +347,9 @@
(append target (list value))))
(true (do (host-call target "push" value) target)))))
;; ── Iteration ───────────────────────────────────────────────────
;; Repeat a thunk N times.
(define
hs-remove-from!
(fn
@@ -334,15 +357,9 @@
(if
(list? target)
(filter (fn (x) (not (= x value))) target)
(host-call
target
"splice"
(host-call target "indexOf" value)
1))))
(host-call target "splice" (host-call target "indexOf" value) 1))))
;; ── Iteration ───────────────────────────────────────────────────
;; Repeat a thunk N times.
;; Repeat forever (until break — relies on exception/continuation).
(define
hs-splice-at!
(fn
@@ -355,10 +372,7 @@
((i (if (< idx 0) (+ n idx) idx)))
(cond
((or (< i 0) (>= i n)) target)
(true
(concat
(slice target 0 i)
(slice target (+ i 1) n))))))
(true (concat (slice target 0 i) (slice target (+ i 1) n))))))
(do
(when
target
@@ -369,7 +383,10 @@
(host-call target "splice" i 1))))
target))))
;; Repeat forever (until break — relies on exception/continuation).
;; ── Fetch ───────────────────────────────────────────────────────
;; Fetch a URL, parse response according to format.
;; (hs-fetch url format) — format is "json" | "text" | "html"
(define
hs-index
(fn
@@ -381,10 +398,10 @@
((string? obj) (nth obj key))
(true (host-get obj key)))))
;; ── Fetch ───────────────────────────────────────────────────────
;; ── Type coercion ───────────────────────────────────────────────
;; Fetch a URL, parse response according to format.
;; (hs-fetch url format) — format is "json" | "text" | "html"
;; Coerce a value to a type by name.
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
(define
hs-put-at!
(fn
@@ -406,10 +423,10 @@
((= pos "start") (host-call target "unshift" value)))
target)))))))
;; ── Type coercion ───────────────────────────────────────────────
;; ── Object creation ─────────────────────────────────────────────
;; Coerce a value to a type by name.
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
;; Make a new object of a given type.
;; (hs-make type-name) — creates empty object/collection
(define
hs-dict-without
(fn
@@ -430,27 +447,27 @@
(host-call (host-global "Reflect") "deleteProperty" out key)
out)))))
;; ── Object creation ─────────────────────────────────────────────
;; ── Behavior installation ───────────────────────────────────────
;; Make a new object of a given type.
;; (hs-make type-name) — creates empty object/collection
;; Install a behavior on an element.
;; A behavior is a function that takes (me ...params) and sets up features.
;; (hs-install behavior-fn me ...args)
(define
hs-set-on!
(fn
(props target)
(for-each (fn (k) (host-set! target k (get props k))) (keys props))))
;; ── Behavior installation ───────────────────────────────────────
;; Install a behavior on an element.
;; A behavior is a function that takes (me ...params) and sets up features.
;; (hs-install behavior-fn me ...args)
(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url))))
;; ── Measurement ─────────────────────────────────────────────────
;; Measure an element's bounding rect, store as local variables.
;; Returns a dict with x, y, width, height, top, left, right, bottom.
(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url))))
;; Return the current text selection as a string. In the browser this is
;; `window.getSelection().toString()`. In the mock test runner, a test
;; setup stashes the desired selection text at `window.__test_selection`
;; and the fallback path returns that so tests can assert on the result.
(define
hs-ask
(fn
@@ -459,10 +476,11 @@
((w (host-global "window")))
(if w (host-call w "prompt" msg) nil))))
;; Return the current text selection as a string. In the browser this is
;; `window.getSelection().toString()`. In the mock test runner, a test
;; setup stashes the desired selection text at `window.__test_selection`
;; and the fallback path returns that so tests can assert on the result.
;; ── Transition ──────────────────────────────────────────────────
;; Transition a CSS property to a value, optionally with duration.
;; (hs-transition target prop value duration)
(define
hs-answer
(fn
@@ -471,11 +489,6 @@
((w (host-global "window")))
(if w (if (host-call w "confirm" msg) yes-val no-val) no-val))))
;; ── Transition ──────────────────────────────────────────────────
;; Transition a CSS property to a value, optionally with duration.
;; (hs-transition target prop value duration)
(define
hs-answer-alert
(fn
@@ -630,25 +643,25 @@
(hs-query-all sel)
(host-call target "querySelectorAll" sel))))
(define
hs-list-set
(fn
(lst idx val)
(append (take lst idx) (cons val (drop lst (+ idx 1))))))
(define
hs-to-number
(fn (v) (if (number? v) v (or (parse-number (str v)) 0))))
;; ── Sandbox/test runtime additions ──────────────────────────────
;; Property access — dot notation and .length
(define
hs-query-first
(fn (sel) (host-call (host-global "document") "querySelector" sel)))
;; ── Sandbox/test runtime additions ──────────────────────────────
;; Property access — dot notation and .length
;; DOM query stub — sandbox returns empty list
(define
hs-query-last
(fn
@@ -656,9 +669,11 @@
(let
((all (dom-query-all (dom-body) sel)))
(if (> (len all) 0) (nth all (- (len all) 1)) nil))))
;; DOM query stub — sandbox returns empty list
(define hs-first (fn (scope sel) (dom-query-all scope sel)))
;; Method dispatch — obj.method(args)
(define hs-first (fn (scope sel) (dom-query-all scope sel)))
;; ── 0.9.90 features ─────────────────────────────────────────────
;; beep! — debug logging, returns value unchanged
(define
hs-last
(fn
@@ -666,9 +681,7 @@
(let
((all (dom-query-all scope sel)))
(if (> (len all) 0) (nth all (- (len all) 1)) nil))))
;; ── 0.9.90 features ─────────────────────────────────────────────
;; beep! — debug logging, returns value unchanged
;; Property-based is — check obj.key truthiness
(define
hs-repeat-times
(fn
@@ -686,7 +699,7 @@
((= signal "hs-continue") (do-repeat (+ i 1)))
(true (do-repeat (+ i 1))))))))
(do-repeat 0)))
;; Property-based is — check obj.key truthiness
;; Array slicing (inclusive both ends)
(define
hs-repeat-forever
(fn
@@ -702,7 +715,7 @@
((= signal "hs-continue") (do-forever))
(true (do-forever))))))
(do-forever)))
;; Array slicing (inclusive both ends)
;; Collection: sorted by
(define
hs-repeat-while
(fn
@@ -715,7 +728,7 @@
((= signal "hs-break") nil)
((= signal "hs-continue") (hs-repeat-while cond-fn thunk))
(true (hs-repeat-while cond-fn thunk)))))))
;; Collection: sorted by
;; Collection: sorted by descending
(define
hs-repeat-until
(fn
@@ -727,7 +740,7 @@
((= signal "hs-continue")
(if (cond-fn) nil (hs-repeat-until cond-fn thunk)))
(true (if (cond-fn) nil (hs-repeat-until cond-fn thunk)))))))
;; Collection: sorted by descending
;; Collection: split by
(define
hs-for-each
(fn
@@ -747,7 +760,7 @@
((= signal "hs-continue") (do-loop (rest remaining)))
(true (do-loop (rest remaining))))))))
(do-loop items))))
;; Collection: split by
;; Collection: joined by
(begin
(define
hs-append
@@ -775,7 +788,7 @@
((hs-element? target)
(dom-insert-adjacent-html target "beforeend" (str value)))
(true nil)))))
;; Collection: joined by
(define
hs-sender
(fn
@@ -1297,14 +1310,10 @@
((ch (substring sel i (+ i 1))))
(cond
((= ch ".")
(do
(flush!)
(set! mode "class")
(walk (+ i 1))))
(do (flush!) (set! mode "class") (walk (+ i 1))))
((= ch "#")
(do (flush!) (set! mode "id") (walk (+ i 1))))
(true
(do (set! cur (str cur ch)) (walk (+ i 1)))))))))
(true (do (set! cur (str cur ch)) (walk (+ i 1)))))))))
(walk 0)
(flush!)
{:tag tag :classes classes :id id}))))
@@ -1389,7 +1398,6 @@
hs-strict-eq
(fn (a b) (and (= (type-of a) (type-of b)) (= a b))))
(define
hs-eq-ignore-case
(fn (a b) (= (downcase (str a)) (downcase (str b)))))
@@ -1430,10 +1438,7 @@
((and (dict? a) (dict? b))
(let
((pos (host-call a "compareDocumentPosition" b)))
(if
(number? pos)
(not (= 0 (mod (/ pos 4) 2)))
false)))
(if (number? pos) (not (= 0 (mod (/ pos 4) 2))) false)))
(true (< (str a) (str b))))))
(define
@@ -1535,10 +1540,7 @@
((and (dict? a) (dict? b))
(let
((pos (host-call a "compareDocumentPosition" b)))
(if
(number? pos)
(not (= 0 (mod (/ pos 4) 2)))
false)))
(if (number? pos) (not (= 0 (mod (/ pos 4) 2))) false)))
(true (< (str a) (str b))))))
(define
@@ -1589,9 +1591,7 @@
(define
hs-morph-char
(fn
(s p)
(if (or (< p 0) (>= p (string-length s))) nil (nth s p))))
(fn (s p) (if (or (< p 0) (>= p (string-length s))) nil (nth s p))))
(define
hs-morph-index-from
@@ -1619,10 +1619,7 @@
(q)
(let
((c (hs-morph-char s q)))
(if
(and c (< (index-of stop c) 0))
(loop (+ q 1))
q))))
(if (and c (< (index-of stop c) 0)) (loop (+ q 1)) q))))
(let ((e (loop p))) (list (substring s p e) e))))
(define
@@ -1664,9 +1661,7 @@
(append
acc
(list
(list
name
(substring s (+ p4 1) close)))))))
(list name (substring s (+ p4 1) close)))))))
((= c2 "'")
(let
((close (hs-morph-index-from s "'" (+ p4 1))))
@@ -1676,9 +1671,7 @@
(append
acc
(list
(list
name
(substring s (+ p4 1) close)))))))
(list name (substring s (+ p4 1) close)))))))
(true
(let
((r2 (hs-morph-read-until s p4 " \t\n/>")))
@@ -1762,9 +1755,7 @@
(for-each
(fn
(c)
(when
(> (string-length c) 0)
(dom-add-class el c)))
(when (> (string-length c) 0) (dom-add-class el c)))
(split v " ")))
((and keep-id (= n "id")) nil)
(true (dom-set-attr el n v)))))
@@ -1865,8 +1856,7 @@
((parts (split resolved ":")))
(let
((prop (first parts))
(val
(if (> (len parts) 1) (nth parts 1) nil)))
(val (if (> (len parts) 1) (nth parts 1) nil)))
(cond
((and (not (= prop "display")) (not (= prop "opacity")) (not (= prop "visibility")) (not (= prop "hidden")) (not (= prop "class-hidden")) (not (= prop "class-invisible")) (not (= prop "class-opacity")) (not (= prop "details")) (not (= prop "dialog")) (dict-has? _hs-hide-strategies prop))
(let
@@ -1905,8 +1895,7 @@
((parts (split resolved ":")))
(let
((prop (first parts))
(val
(if (> (len parts) 1) (nth parts 1) nil)))
(val (if (> (len parts) 1) (nth parts 1) nil)))
(cond
((and (not (= prop "display")) (not (= prop "opacity")) (not (= prop "visibility")) (not (= prop "hidden")) (not (= prop "class-hidden")) (not (= prop "class-invisible")) (not (= prop "class-opacity")) (not (= prop "details")) (not (= prop "dialog")) (dict-has? _hs-hide-strategies prop))
(let
@@ -2010,14 +1999,10 @@
(if
(= depth 1)
j
(find-close
(+ j 1)
(- depth 1)))
(find-close (+ j 1) (- depth 1)))
(if
(= (nth raw j) "{")
(find-close
(+ j 1)
(+ depth 1))
(find-close (+ j 1) (+ depth 1))
(find-close (+ j 1) depth))))))
(let
((close (find-close start 1)))
@@ -2108,10 +2093,7 @@
(if
(= (len lst) 0)
-1
(if
(= (first lst) item)
i
(idx-loop (rest lst) (+ i 1))))))
(if (= (first lst) item) i (idx-loop (rest lst) (+ i 1))))))
(idx-loop obj 0)))
(true nil))))
@@ -2197,8 +2179,7 @@
(cond
((= end "hs-pick-end") n)
((= end "hs-pick-start") 0)
((and (number? end) (< end 0))
(max 0 (+ n end)))
((and (number? end) (< end 0)) (max 0 (+ n end)))
(true end))))
(cond
((string? col) (slice col s e))
@@ -2485,50 +2466,6 @@
((nth entry 2) val)))
_hs-dom-watchers)))
(define hs-prolog-hook nil)
(define hs-set-prolog-hook! (fn (f) (set! hs-prolog-hook f)))
(define
prolog
(fn
(db goal)
(if
(nil? hs-prolog-hook)
(raise "prolog hook not installed")
(hs-prolog-hook db goal))))
(define
hs-null-error!
(fn (selector) (raise (str "'" selector "' is null"))))
(define
hs-named-target
(fn (selector value) (if (nil? value) (hs-null-error! selector) value)))
(define
hs-named-target-list
(fn
(selector values)
(if (nil? values) (hs-null-error! selector) values)))
(define
hs-query-named-all
(fn
(selector)
(let
((results (hs-query-all selector)))
(if
(and
(or
(nil? results)
(and (list? results) (= (len results) 0)))
(string? selector)
(> (len selector) 0)
(= (substring selector 0 1) "#"))
(hs-null-error! selector)
results))))
(define
hs-dom-is-ancestor?
(fn

176
lib/prolog/compiler.sx
View File

@@ -1,176 +0,0 @@
;; lib/prolog/compiler.sx — clause compiler: parse-AST clauses → SX closures
;;
;; Each compiled clause is a lambda (fn (goal trail db cut-box k) bool)
;; that creates fresh vars, builds the instantiated head/body, and calls
;; pl-unify! + pl-solve! directly — no AST walk at solve time.
;;
;; Usage:
;; (pl-db-load! db (pl-parse src))
;; (pl-compile-db! db)
;; ; pl-solve-user! in runtime.sx automatically prefers compiled clauses
;; (pl-solve-once! db goal trail)
;; Collect unique variable names from a parse-AST clause into a dict.
(define
pl-cmp-vars-into!
(fn
(ast seen)
(cond
((not (list? ast)) nil)
((empty? ast) nil)
((= (first ast) "var")
(let
((name (nth ast 1)))
(when
(and (not (= name "_")) (not (dict-has? seen name)))
(dict-set! seen name true))))
((= (first ast) "compound")
(for-each (fn (a) (pl-cmp-vars-into! a seen)) (nth ast 2)))
((= (first ast) "clause")
(begin
(pl-cmp-vars-into! (nth ast 1) seen)
(pl-cmp-vars-into! (nth ast 2) seen))))))
;; Return list of unique var names in a clause (head + body, excluding _).
(define
pl-cmp-collect-vars
(fn
(clause)
(let ((seen {})) (pl-cmp-vars-into! clause seen) (keys seen))))
;; Create a fresh runtime var for each name in the list; return name->var dict.
(define
pl-cmp-make-var-map
(fn
(var-names)
(let
((m {}))
(for-each
(fn (name) (dict-set! m name (pl-mk-rt-var name)))
var-names)
m)))
;; Instantiate a parse-AST term using a pre-built var-map.
;; ("var" "_") always gets a fresh anonymous var.
(define
pl-cmp-build-term
(fn
(ast var-map)
(cond
((pl-var? ast) ast)
((not (list? ast)) ast)
((empty? ast) ast)
((= (first ast) "var")
(let
((name (nth ast 1)))
(if (= name "_") (pl-mk-rt-var "_") (dict-get var-map name))))
((or (= (first ast) "atom") (= (first ast) "num") (= (first ast) "str"))
ast)
((= (first ast) "compound")
(list
"compound"
(nth ast 1)
(map (fn (a) (pl-cmp-build-term a var-map)) (nth ast 2))))
((= (first ast) "clause")
(list
"clause"
(pl-cmp-build-term (nth ast 1) var-map)
(pl-cmp-build-term (nth ast 2) var-map)))
(true ast))))
;; Compile one parse-AST clause to a lambda.
;; Pre-computes var names at compile time; creates fresh vars per call.
(define
pl-compile-clause
(fn
(clause)
(let
((var-names (pl-cmp-collect-vars clause))
(head-ast (nth clause 1))
(body-ast (nth clause 2)))
(fn
(goal trail db cut-box k)
(let
((var-map (pl-cmp-make-var-map var-names)))
(let
((fresh-head (pl-cmp-build-term head-ast var-map))
(fresh-body (pl-cmp-build-term body-ast var-map)))
(let
((mark (pl-trail-mark trail)))
(if
(pl-unify! goal fresh-head trail)
(let
((r (pl-solve! db fresh-body trail cut-box k)))
(if r true (begin (pl-trail-undo-to! trail mark) false)))
(begin (pl-trail-undo-to! trail mark) false)))))))))
;; Try a list of compiled clause lambdas — same cut semantics as pl-try-clauses!.
(define
pl-try-compiled-clauses!
(fn
(db
goal
trail
compiled-clauses
outer-cut-box
outer-was-cut
inner-cut-box
k)
(cond
((empty? compiled-clauses) false)
(true
(let
((r ((first compiled-clauses) goal trail db inner-cut-box k)))
(cond
(r true)
((dict-get inner-cut-box :cut) false)
((and (not outer-was-cut) (dict-get outer-cut-box :cut)) false)
(true
(pl-try-compiled-clauses!
db
goal
trail
(rest compiled-clauses)
outer-cut-box
outer-was-cut
inner-cut-box
k))))))))
;; Compile all clauses in DB and store in :compiled table.
;; After this call, pl-solve-user! will dispatch via compiled lambdas.
;; Note: clauses assert!-ed after this call are not compiled.
(define
pl-compile-db!
(fn
(db)
(let
((src-table (dict-get db :clauses)) (compiled-table {}))
(for-each
(fn
(key)
(dict-set!
compiled-table
key
(map pl-compile-clause (dict-get src-table key))))
(keys src-table))
(dict-set! db :compiled compiled-table)
db)))
;; Cross-validate: load src into both a plain and a compiled DB,
;; run goal-str through each, return true iff solution counts match.
;; Use this to keep the interpreter as the reference implementation.
(define
pl-compiled-matches-interp?
(fn
(src goal-str)
(let
((db-interp (pl-mk-db)) (db-comp (pl-mk-db)))
(pl-db-load! db-interp (pl-parse src))
(pl-db-load! db-comp (pl-parse src))
(pl-compile-db! db-comp)
(let
((gi (pl-instantiate (pl-parse-goal goal-str) {}))
(gc (pl-instantiate (pl-parse-goal goal-str) {})))
(=
(pl-solve-count! db-interp gi (pl-mk-trail))
(pl-solve-count! db-comp gc (pl-mk-trail)))))))

129
lib/prolog/conformance.sh
View File

@@ -1,129 +0,0 @@
#!/usr/bin/env bash
# Run every Prolog test suite via sx_server and refresh scoreboard.{json,md}.
# Exit 0 if all green, 1 if any failures.
set -euo pipefail
HERE="$(cd "$(dirname "$0")" && pwd)"
ROOT="$(cd "$HERE/../.." && pwd)"
SX="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
if [[ ! -x "$SX" ]]; then
echo "sx_server not found at $SX (set SX_SERVER env to override)" >&2
exit 2
fi
cd "$ROOT"
# name : test-file : runner-fn
SUITES=(
"parse:lib/prolog/tests/parse.sx:pl-parse-tests-run!"
"unify:lib/prolog/tests/unify.sx:pl-unify-tests-run!"
"clausedb:lib/prolog/tests/clausedb.sx:pl-clausedb-tests-run!"
"solve:lib/prolog/tests/solve.sx:pl-solve-tests-run!"
"operators:lib/prolog/tests/operators.sx:pl-operators-tests-run!"
"dynamic:lib/prolog/tests/dynamic.sx:pl-dynamic-tests-run!"
"findall:lib/prolog/tests/findall.sx:pl-findall-tests-run!"
"term_inspect:lib/prolog/tests/term_inspect.sx:pl-term-inspect-tests-run!"
"append:lib/prolog/tests/programs/append.sx:pl-append-tests-run!"
"reverse:lib/prolog/tests/programs/reverse.sx:pl-reverse-tests-run!"
"member:lib/prolog/tests/programs/member.sx:pl-member-tests-run!"
"nqueens:lib/prolog/tests/programs/nqueens.sx:pl-nqueens-tests-run!"
"family:lib/prolog/tests/programs/family.sx:pl-family-tests-run!"
"atoms:lib/prolog/tests/atoms.sx:pl-atom-tests-run!"
"query_api:lib/prolog/tests/query_api.sx:pl-query-api-tests-run!"
"iso_predicates:lib/prolog/tests/iso_predicates.sx:pl-iso-predicates-tests-run!"
"meta_predicates:lib/prolog/tests/meta_predicates.sx:pl-meta-predicates-tests-run!"
"list_predicates:lib/prolog/tests/list_predicates.sx:pl-list-predicates-tests-run!"
"meta_call:lib/prolog/tests/meta_call.sx:pl-meta-call-tests-run!"
"set_predicates:lib/prolog/tests/set_predicates.sx:pl-set-predicates-tests-run!"
"char_predicates:lib/prolog/tests/char_predicates.sx:pl-char-predicates-tests-run!"
"io_predicates:lib/prolog/tests/io_predicates.sx:pl-io-predicates-tests-run!"
"assert_rules:lib/prolog/tests/assert_rules.sx:pl-assert-rules-tests-run!"
"string_agg:lib/prolog/tests/string_agg.sx:pl-string-agg-tests-run!"
"advanced:lib/prolog/tests/advanced.sx:pl-advanced-tests-run!"
"compiler:lib/prolog/tests/compiler.sx:pl-compiler-tests-run!"
"cross_validate:lib/prolog/tests/cross_validate.sx:pl-cross-validate-tests-run!"
"integration:lib/prolog/tests/integration.sx:pl-integration-tests-run!"
"hs_bridge:lib/prolog/tests/hs_bridge.sx:pl-hs-bridge-tests-run!"
)
SCRIPT='(epoch 1)
(load "lib/prolog/tokenizer.sx")
(load "lib/prolog/parser.sx")
(load "lib/prolog/runtime.sx")
(load "lib/prolog/query.sx")
(load "lib/prolog/compiler.sx")
(load "lib/prolog/hs-bridge.sx")'
for entry in "${SUITES[@]}"; do
IFS=: read -r _ file _ <<< "$entry"
SCRIPT+=$'\n(load "'"$file"$'")'
done
for entry in "${SUITES[@]}"; do
IFS=: read -r _ _ fn <<< "$entry"
SCRIPT+=$'\n(eval "('"$fn"$')")'
done
OUTPUT="$(printf '%s\n' "$SCRIPT" | "$SX" 2>&1)"
mapfile -t LINES < <(printf '%s\n' "$OUTPUT" | grep -E '^\{:failed')
if [[ ${#LINES[@]} -ne ${#SUITES[@]} ]]; then
echo "Expected ${#SUITES[@]} suite results, got ${#LINES[@]}" >&2
echo "---- raw output ----" >&2
printf '%s\n' "$OUTPUT" >&2
exit 3
fi
TOTAL_PASS=0
TOTAL_FAIL=0
TOTAL=0
JSON_SUITES=""
MD_ROWS=""
for i in "${!SUITES[@]}"; do
IFS=: read -r name _ _ <<< "${SUITES[$i]}"
line="${LINES[$i]}"
passed=$(grep -oE ':passed [0-9]+' <<< "$line" | grep -oE '[0-9]+')
total=$(grep -oE ':total [0-9]+' <<< "$line" | grep -oE '[0-9]+')
failed=$(grep -oE ':failed [0-9]+' <<< "$line" | grep -oE '[0-9]+')
TOTAL_PASS=$((TOTAL_PASS + passed))
TOTAL_FAIL=$((TOTAL_FAIL + failed))
TOTAL=$((TOTAL + total))
status="ok"
[[ "$failed" -gt 0 ]] && status="FAIL"
[[ -n "$JSON_SUITES" ]] && JSON_SUITES+=","
JSON_SUITES+="\"$name\":{\"passed\":$passed,\"total\":$total,\"failed\":$failed}"
MD_ROWS+="| $name | $passed | $total | $status |"$'\n'
done
WHEN="$(date -Iseconds 2>/dev/null || date)"
cat > "$HERE/scoreboard.json" <<JSON
{
"total_passed": $TOTAL_PASS,
"total_failed": $TOTAL_FAIL,
"total": $TOTAL,
"suites": {$JSON_SUITES},
"generated": "$WHEN"
}
JSON
cat > "$HERE/scoreboard.md" <<MD
# Prolog scoreboard
**$TOTAL_PASS / $TOTAL passing** ($TOTAL_FAIL failure(s)).
Generated $WHEN.
| Suite | Passed | Total | Status |
|-------|--------|-------|--------|
$MD_ROWS
Run \`bash lib/prolog/conformance.sh\` to refresh. Override the binary
with \`SX_SERVER=path/to/sx_server.exe bash …\`.
MD
if [[ "$TOTAL_FAIL" -gt 0 ]]; then
echo "$TOTAL_FAIL failure(s) across $TOTAL tests" >&2
exit 1
fi
echo "All $TOTAL tests pass."

84
lib/prolog/hs-bridge.sx
View File

@@ -1,84 +0,0 @@
;; lib/prolog/hs-bridge.sx — Prolog ↔ Hyperscript bridge
;;
;; Two complementary integration styles:
;;
;; 1. Hook style — for `prolog(db, "goal(args)")` call syntax in Hyperscript:
;; (pl-install-hs-hook!) ;; call once at startup
;; Requires lib/hyperscript/runtime.sx (provides hs-set-prolog-hook!)
;;
;; 2. Factory style — for named conditions like `when allowed(user, action)`:
;; (define allowed (pl-hs-predicate/2 pl-db "allowed"))
;; No parser/compiler changes needed: Hyperscript compiles
;; `allowed(user, action)` to `(allowed user action)` — a plain SX call.
;;
;; Requires tokenizer.sx, parser.sx, runtime.sx, query.sx loaded first.
;; --- Hook style ---
(define
pl-install-hs-hook!
(fn
()
(hs-set-prolog-hook!
(fn (db goal) (not (= nil (pl-query-one db goal)))))))
;; --- Factory style ---
;; Test whether a ground Prolog goal succeeds against db.
;; Returns true/false (not a solution dict).
(define
pl-hs-query
(fn (db goal-str) (not (nil? (pl-query-one db goal-str)))))
;; Build a Prolog goal string from a predicate name and arg list.
;; SX values: strings/keywords pass through; numbers are stringified via str.
(define
pl-hs-build-goal
(fn
(pred-name args)
(str pred-name "(" (join ", " (map (fn (a) (str a)) args)) ")")))
;; Return a 1-arg SX function that succeeds iff pred(a) holds in db.
(define
pl-hs-predicate/1
(fn
(db pred-name)
(fn (a) (pl-hs-query db (pl-hs-build-goal pred-name (list a))))))
;; Return a 2-arg SX function that succeeds iff pred(a, b) holds in db.
(define
pl-hs-predicate/2
(fn
(db pred-name)
(fn (a b) (pl-hs-query db (pl-hs-build-goal pred-name (list a b))))))
;; Return a 3-arg SX function that succeeds iff pred(a, b, c) holds in db.
(define
pl-hs-predicate/3
(fn
(db pred-name)
(fn (a b c) (pl-hs-query db (pl-hs-build-goal pred-name (list a b c))))))
;; Install every predicate in install-list as a named SX function backed by db.
;; install-list: list of (name arity) pairs.
;; Returns a dict {name → fn} for the caller to destructure.
(define
pl-hs-install
(fn
(db install-list)
(reduce
(fn
(acc entry)
(let
((pred-name (first entry)) (arity (nth entry 1)))
(dict-set!
acc
pred-name
(cond
((= arity 1) (pl-hs-predicate/1 db pred-name))
((= arity 2) (pl-hs-predicate/2 db pred-name))
((= arity 3) (pl-hs-predicate/3 db pred-name))
(true (fn (a b) false))))
acc))
{}
install-list)))

195
lib/prolog/parser.sx
View File

@@ -1,20 +1,28 @@
;; lib/prolog/parser.sx — tokens → Prolog AST
;;
;; Phase 4 grammar (with operator table):
;; Phase 1 grammar (NO operator table yet):
;; Program := Clause* EOF
;; Clause := Term[999] "." | Term[999] ":-" Term[1200] "."
;; Term[Pmax] uses precedence climbing on the operator table:
;; primary = Atom | Var | Number | String | Compound | List | "(" Term[1200] ")"
;; while next token is infix op `op` with prec(op) ≤ Pmax:
;; consume op; parse rhs at right-prec(op); fold into compound(op-name,[lhs,rhs])
;; Clause := Term "." | Term ":-" Term "."
;; Term := Atom | Var | Number | String | Compound | List
;; Compound := atom "(" ArgList ")"
;; ArgList := Term ("," Term)*
;; List := "[" "]" | "[" Term ("," Term)* ("|" Term)? "]"
;;
;; Op type → right-prec for op at precedence P:
;; xfx → P-1 strict-both
;; xfy → P right-associative
;; yfx → P-1 left-associative
;; Term AST shapes (all tagged lists for uniform dispatch):
;; ("atom" name) — atom
;; ("var" name) — variable template (parser-time only)
;; ("num" value) — integer or float
;; ("str" value) — string literal
;; ("compound" functor args) — compound term, args is list of term-ASTs
;; ("cut") — the cut atom !
;;
;; AST shapes are unchanged — operators just become compound terms.
;; A clause is (list "clause" head body). A fact is head with body = ("atom" "true").
;;
;; The empty list is (atom "[]"). Cons is compound "." with two args:
;; [1, 2, 3] → .(1, .(2, .(3, [])))
;; [H|T] → .(H, T)
;; ── Parser state helpers ────────────────────────────────────────────
(define
pp-peek
(fn
@@ -58,6 +66,7 @@
(if (= (get t :value) nil) "" (get t :value))
"'"))))))
;; ── AST constructors ────────────────────────────────────────────────
(define pl-mk-atom (fn (name) (list "atom" name)))
(define pl-mk-var (fn (name) (list "var" name)))
(define pl-mk-num (fn (n) (list "num" n)))
@@ -65,14 +74,18 @@
(define pl-mk-compound (fn (f args) (list "compound" f args)))
(define pl-mk-cut (fn () (list "cut")))
;; Term tag extractors
(define pl-term-tag (fn (t) (if (list? t) (first t) nil)))
(define pl-term-val (fn (t) (nth t 1)))
(define pl-compound-functor (fn (t) (nth t 1)))
(define pl-compound-args (fn (t) (nth t 2)))
;; Empty-list atom and cons helpers
(define pl-nil-term (fn () (pl-mk-atom "[]")))
(define pl-mk-cons (fn (h t) (pl-mk-compound "." (list h t))))
;; Build cons list from a list of terms + optional tail
(define
pl-mk-list-term
(fn
@@ -82,61 +95,9 @@
tail
(pl-mk-cons (first items) (pl-mk-list-term (rest items) tail)))))
;; ── Operator table (Phase 4) ──────────────────────────────────────
;; Each entry: (name precedence type). Type ∈ "xfx" "xfy" "yfx".
(define
pl-op-table
(list
(list "," 1000 "xfy")
(list ";" 1100 "xfy")
(list "->" 1050 "xfy")
(list "=" 700 "xfx")
(list "\\=" 700 "xfx")
(list "is" 700 "xfx")
(list "<" 700 "xfx")
(list ">" 700 "xfx")
(list "=<" 700 "xfx")
(list ">=" 700 "xfx")
(list "+" 500 "yfx")
(list "-" 500 "yfx")
(list "*" 400 "yfx")
(list "/" 400 "yfx")
(list ":-" 1200 "xfx")
(list "mod" 400 "yfx")))
(define
pl-op-find
(fn
(name table)
(cond
((empty? table) nil)
((= (first (first table)) name) (rest (first table)))
(true (pl-op-find name (rest table))))))
(define pl-op-lookup (fn (name) (pl-op-find name pl-op-table)))
;; Token → (name prec type) for known infix ops, else nil.
(define
pl-token-op
(fn
(t)
(let
((ty (get t :type)) (vv (get t :value)))
(cond
((and (= ty "punct") (= vv ","))
(let
((info (pl-op-lookup ",")))
(if (nil? info) nil (cons "," info))))
((or (= ty "atom") (= ty "op"))
(let
((info (pl-op-lookup vv)))
(if (nil? info) nil (cons vv info))))
(true nil)))))
;; ── Term parser ─────────────────────────────────────────────────────
;; Primary term: atom, var, num, str, compound (atom + paren), list, cut, parens.
(define
pp-parse-primary
pp-parse-term
(fn
(st)
(let
@@ -150,12 +111,6 @@
((and (= ty "op") (= vv "!"))
(do (pp-advance! st) (pl-mk-cut)))
((and (= ty "punct") (= vv "[")) (pp-parse-list st))
((and (= ty "punct") (= vv "("))
(do
(pp-advance! st)
(let
((inner (pp-parse-term-prec st 1200)))
(do (pp-expect! st "punct" ")") inner))))
((= ty "atom")
(do
(pp-advance! st)
@@ -178,51 +133,13 @@
(if (= vv nil) "" vv)
"'"))))))))
;; Operator-aware term parser: precedence climbing.
(define
pp-parse-term-prec
(fn
(st max-prec)
(let ((left (pp-parse-primary st))) (pp-parse-op-rhs st left max-prec))))
(define
pp-parse-op-rhs
(fn
(st left max-prec)
(let
((op-info (pl-token-op (pp-peek st))))
(cond
((nil? op-info) left)
(true
(let
((name (first op-info))
(prec (nth op-info 1))
(ty (nth op-info 2)))
(cond
((> prec max-prec) left)
(true
(let
((right-prec (if (= ty "xfy") prec (- prec 1))))
(do
(pp-advance! st)
(let
((right (pp-parse-term-prec st right-prec)))
(pp-parse-op-rhs
st
(pl-mk-compound name (list left right))
max-prec))))))))))))
;; Backwards-compat alias.
(define pp-parse-term (fn (st) (pp-parse-term-prec st 999)))
;; Args inside parens: parse at prec 999 so comma-as-operator (1000)
;; is not consumed; the explicit comma loop handles separation.
;; Parse one or more comma-separated terms (arguments).
(define
pp-parse-arg-list
(fn
(st)
(let
((first-arg (pp-parse-term-prec st 999)) (args (list)))
((first-arg (pp-parse-term st)) (args (list)))
(do
(append! args first-arg)
(define
@@ -233,12 +150,12 @@
(pp-at? st "punct" ",")
(do
(pp-advance! st)
(append! args (pp-parse-term-prec st 999))
(append! args (pp-parse-term st))
(loop)))))
(loop)
args))))
;; List literal.
;; Parse a [ ... ] list literal. Consumes the "[".
(define
pp-parse-list
(fn
@@ -251,7 +168,7 @@
(let
((items (list)))
(do
(append! items (pp-parse-term-prec st 999))
(append! items (pp-parse-term st))
(define
comma-loop
(fn
@@ -260,17 +177,52 @@
(pp-at? st "punct" ",")
(do
(pp-advance! st)
(append! items (pp-parse-term-prec st 999))
(append! items (pp-parse-term st))
(comma-loop)))))
(comma-loop)
(let
((tail (if (pp-at? st "punct" "|") (do (pp-advance! st) (pp-parse-term-prec st 999)) (pl-nil-term))))
((tail (if (pp-at? st "punct" "|") (do (pp-advance! st) (pp-parse-term st)) (pl-nil-term))))
(do (pp-expect! st "punct" "]") (pl-mk-list-term items tail)))))))))
;; ── Body parsing ────────────────────────────────────────────────────
;; A body is a single term parsed at prec 1200 — operator parser folds
;; `,`, `;`, `->` automatically into right-associative compounds.
(define pp-parse-body (fn (st) (pp-parse-term-prec st 1200)))
;; A clause body is a comma-separated list of goals. We flatten into a
;; right-associative `,` compound: (A, B, C) → ','(A, ','(B, C))
;; If only one goal, it's that goal directly.
(define
pp-parse-body
(fn
(st)
(let
((first-goal (pp-parse-term st)) (rest-goals (list)))
(do
(define
gloop
(fn
()
(when
(pp-at? st "punct" ",")
(do
(pp-advance! st)
(append! rest-goals (pp-parse-term st))
(gloop)))))
(gloop)
(if
(= (len rest-goals) 0)
first-goal
(pp-build-conj first-goal rest-goals))))))
(define
pp-build-conj
(fn
(first-goal rest-goals)
(if
(= (len rest-goals) 0)
first-goal
(pl-mk-compound
","
(list
first-goal
(pp-build-conj (first rest-goals) (rest rest-goals)))))))
;; ── Clause parsing ──────────────────────────────────────────────────
(define
@@ -278,11 +230,12 @@
(fn
(st)
(let
((head (pp-parse-term-prec st 999)))
((head (pp-parse-term st)))
(let
((body (if (pp-at? st "op" ":-") (do (pp-advance! st) (pp-parse-body st)) (pl-mk-atom "true"))))
(do (pp-expect! st "punct" ".") (list "clause" head body))))))
;; Parse an entire program — returns list of clauses.
(define
pl-parse-program
(fn
@@ -300,9 +253,13 @@
(ploop)
clauses))))
;; Parse a single query term (no trailing "."). Returns the term.
(define
pl-parse-query
(fn (tokens) (let ((st {:idx 0 :tokens tokens})) (pp-parse-body st))))
;; Convenience: source → clauses
(define pl-parse (fn (src) (pl-parse-program (pl-tokenize src))))
;; Convenience: source → query term
(define pl-parse-goal (fn (src) (pl-parse-query (pl-tokenize src))))

114
lib/prolog/query.sx
View File

@@ -1,114 +0,0 @@
;; lib/prolog/query.sx — high-level Prolog query API for SX/Hyperscript callers.
;;
;; Requires tokenizer.sx, parser.sx, runtime.sx to be loaded first.
;;
;; Public API:
;; (pl-load source-str) → db
;; (pl-query-all db query-str) → list of solution dicts {var-name → term-string}
;; (pl-query-one db query-str) → first solution dict or nil
;; (pl-query source-str query-str) → list of solution dicts (convenience)
;; Collect variable name strings from a parse-time AST (pre-instantiation).
;; Returns list of unique strings, excluding anonymous "_".
(define
pl-query-extract-vars
(fn
(ast)
(let
((seen {}))
(let
((collect!
(fn
(t)
(cond
((not (list? t)) nil)
((empty? t) nil)
((= (first t) "var")
(if
(not (= (nth t 1) "_"))
(dict-set! seen (nth t 1) true)
nil))
((= (first t) "compound")
(for-each collect! (nth t 2)))
(true nil)))))
(collect! ast)
(keys seen)))))
;; Build a solution dict from a var-env after a successful solve.
;; Maps each variable name string to its formatted term value.
(define
pl-query-solution-dict
(fn
(var-names var-env)
(let
((d {}))
(for-each
(fn (name) (dict-set! d name (pl-format-term (dict-get var-env name))))
var-names)
d)))
;; Parse source-str and load clauses into a fresh DB.
;; Returns the DB for reuse across multiple queries.
(define
pl-load
(fn
(source-str)
(let
((db (pl-mk-db)))
(if
(and (string? source-str) (not (= source-str "")))
(pl-db-load! db (pl-parse source-str))
nil)
db)))
;; Run query-str against db, returning a list of solution dicts.
;; Each dict maps variable name strings to their formatted term values.
;; Returns an empty list if no solutions.
(define
pl-query-all
(fn
(db query-str)
(let
((parsed (pl-parse (str "q_ :- " query-str "."))))
(let
((body-ast (nth (first parsed) 2)))
(let
((var-names (pl-query-extract-vars body-ast))
(var-env {}))
(let
((goal (pl-instantiate body-ast var-env))
(trail (pl-mk-trail))
(solutions (list)))
(let
((mark (pl-trail-mark trail)))
(pl-solve!
db
goal
trail
{:cut false}
(fn
()
(begin
(append!
solutions
(pl-query-solution-dict var-names var-env))
false)))
(pl-trail-undo-to! trail mark)
solutions)))))))
;; Return the first solution dict, or nil if no solutions.
(define
pl-query-one
(fn
(db query-str)
(let
((all (pl-query-all db query-str)))
(if (empty? all) nil (first all)))))
;; Convenience: parse source-str, then run query-str against it.
;; Returns a list of solution dicts. Creates a fresh DB each call.
(define
pl-query
(fn
(source-str query-str)
(pl-query-all (pl-load source-str) query-str)))

2562
lib/prolog/runtime.sx
View File

File diff suppressed because it is too large Load Diff

7
lib/prolog/scoreboard.json
View File

@@ -1,7 +0,0 @@
{
"total_passed": 590,
"total_failed": 0,
"total": 590,
"suites": {"parse":{"passed":25,"total":25,"failed":0},"unify":{"passed":47,"total":47,"failed":0},"clausedb":{"passed":14,"total":14,"failed":0},"solve":{"passed":62,"total":62,"failed":0},"operators":{"passed":19,"total":19,"failed":0},"dynamic":{"passed":11,"total":11,"failed":0},"findall":{"passed":11,"total":11,"failed":0},"term_inspect":{"passed":14,"total":14,"failed":0},"append":{"passed":6,"total":6,"failed":0},"reverse":{"passed":6,"total":6,"failed":0},"member":{"passed":7,"total":7,"failed":0},"nqueens":{"passed":6,"total":6,"failed":0},"family":{"passed":10,"total":10,"failed":0},"atoms":{"passed":34,"total":34,"failed":0},"query_api":{"passed":16,"total":16,"failed":0},"iso_predicates":{"passed":29,"total":29,"failed":0},"meta_predicates":{"passed":25,"total":25,"failed":0},"list_predicates":{"passed":33,"total":33,"failed":0},"meta_call":{"passed":15,"total":15,"failed":0},"set_predicates":{"passed":15,"total":15,"failed":0},"char_predicates":{"passed":27,"total":27,"failed":0},"io_predicates":{"passed":24,"total":24,"failed":0},"assert_rules":{"passed":15,"total":15,"failed":0},"string_agg":{"passed":25,"total":25,"failed":0},"advanced":{"passed":21,"total":21,"failed":0},"compiler":{"passed":17,"total":17,"failed":0},"cross_validate":{"passed":17,"total":17,"failed":0},"integration":{"passed":20,"total":20,"failed":0},"hs_bridge":{"passed":19,"total":19,"failed":0}},
"generated": "2026-05-06T08:29:09+00:00"
}

39
lib/prolog/scoreboard.md
View File

@@ -1,39 +0,0 @@
# Prolog scoreboard
**590 / 590 passing** (0 failure(s)).
Generated 2026-05-06T08:29:09+00:00.
| Suite | Passed | Total | Status |
|-------|--------|-------|--------|
| parse | 25 | 25 | ok |
| unify | 47 | 47 | ok |
| clausedb | 14 | 14 | ok |
| solve | 62 | 62 | ok |
| operators | 19 | 19 | ok |
| dynamic | 11 | 11 | ok |
| findall | 11 | 11 | ok |
| term_inspect | 14 | 14 | ok |
| append | 6 | 6 | ok |
| reverse | 6 | 6 | ok |
| member | 7 | 7 | ok |
| nqueens | 6 | 6 | ok |
| family | 10 | 10 | ok |
| atoms | 34 | 34 | ok |
| query_api | 16 | 16 | ok |
| iso_predicates | 29 | 29 | ok |
| meta_predicates | 25 | 25 | ok |
| list_predicates | 33 | 33 | ok |
| meta_call | 15 | 15 | ok |
| set_predicates | 15 | 15 | ok |
| char_predicates | 27 | 27 | ok |
| io_predicates | 24 | 24 | ok |
| assert_rules | 15 | 15 | ok |
| string_agg | 25 | 25 | ok |
| advanced | 21 | 21 | ok |
| compiler | 17 | 17 | ok |
| cross_validate | 17 | 17 | ok |
| integration | 20 | 20 | ok |
| hs_bridge | 19 | 19 | ok |
Run `bash lib/prolog/conformance.sh` to refresh. Override the binary
with `SX_SERVER=path/to/sx_server.exe bash …`.

254
lib/prolog/tests/advanced.sx
View File

@@ -1,254 +0,0 @@
;; lib/prolog/tests/advanced.sx — predsort/3, term_variables/2, arith extensions
(define pl-adv-test-count 0)
(define pl-adv-test-pass 0)
(define pl-adv-test-fail 0)
(define pl-adv-test-failures (list))
(define
pl-adv-test!
(fn
(name got expected)
(begin
(set! pl-adv-test-count (+ pl-adv-test-count 1))
(if
(= got expected)
(set! pl-adv-test-pass (+ pl-adv-test-pass 1))
(begin
(set! pl-adv-test-fail (+ pl-adv-test-fail 1))
(append!
pl-adv-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-adv-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-adv-db (pl-mk-db))
;; Load a numeric comparator for predsort tests
(pl-db-load!
pl-adv-db
(pl-parse
"cmp_num(Order, X, Y) :- (X < Y -> Order = '<' ; (X > Y -> Order = '>' ; Order = '='))."))
;; ── Arithmetic extensions ──────────────────────────────────────────
(define pl-adv-arith-env-1 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is floor(3.7)" pl-adv-arith-env-1)
(pl-mk-trail))
(pl-adv-test!
"floor(3.7) = 3"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-1 "X")))
3)
(define pl-adv-arith-env-2 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is ceiling(3.2)" pl-adv-arith-env-2)
(pl-mk-trail))
(pl-adv-test!
"ceiling(3.2) = 4"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-2 "X")))
4)
(define pl-adv-arith-env-3 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is truncate(3.9)" pl-adv-arith-env-3)
(pl-mk-trail))
(pl-adv-test!
"truncate(3.9) = 3"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-3 "X")))
3)
(define pl-adv-arith-env-4 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is truncate(0 - 3.9)" pl-adv-arith-env-4)
(pl-mk-trail))
(pl-adv-test!
"truncate(0-3.9) = -3"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-4 "X")))
-3)
(define pl-adv-arith-env-5 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is round(3.5)" pl-adv-arith-env-5)
(pl-mk-trail))
(pl-adv-test!
"round(3.5) = 4"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-5 "X")))
4)
(define pl-adv-arith-env-6 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is sqrt(4.0)" pl-adv-arith-env-6)
(pl-mk-trail))
(pl-adv-test!
"sqrt(4.0) = 2"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-6 "X")))
2)
(define pl-adv-arith-env-7 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is sign(0 - 5)" pl-adv-arith-env-7)
(pl-mk-trail))
(pl-adv-test!
"sign(0-5) = -1"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-7 "X")))
-1)
(define pl-adv-arith-env-8 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is sign(0)" pl-adv-arith-env-8)
(pl-mk-trail))
(pl-adv-test!
"sign(0) = 0"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-8 "X")))
0)
(define pl-adv-arith-env-9 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is sign(3)" pl-adv-arith-env-9)
(pl-mk-trail))
(pl-adv-test!
"sign(3) = 1"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-9 "X")))
1)
(define pl-adv-arith-env-10 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is pow(2, 3)" pl-adv-arith-env-10)
(pl-mk-trail))
(pl-adv-test!
"pow(2,3) = 8"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-10 "X")))
8)
(define pl-adv-arith-env-11 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is floor(0 - 3.7)" pl-adv-arith-env-11)
(pl-mk-trail))
(pl-adv-test!
"floor(0-3.7) = -4"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-11 "X")))
-4)
(define pl-adv-arith-env-12 {:X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "X is ceiling(0 - 3.2)" pl-adv-arith-env-12)
(pl-mk-trail))
(pl-adv-test!
"ceiling(0-3.2) = -3"
(pl-num-val (pl-walk-deep (dict-get pl-adv-arith-env-12 "X")))
-3)
;; ── term_variables/2 ──────────────────────────────────────────────
(define pl-adv-tv-env-1 {:Vs (pl-mk-rt-var "Vs")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "term_variables(hello, Vs)" pl-adv-tv-env-1)
(pl-mk-trail))
(pl-adv-test!
"term_variables(hello,Vs) -> []"
(pl-format-term (pl-walk-deep (dict-get pl-adv-tv-env-1 "Vs")))
"[]")
(define pl-adv-tv-env-2 {:Vs (pl-mk-rt-var "Vs")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "term_variables(f(a, g(b)), Vs)" pl-adv-tv-env-2)
(pl-mk-trail))
(pl-adv-test!
"term_variables(f(a,g(b)),Vs) -> []"
(pl-format-term (pl-walk-deep (dict-get pl-adv-tv-env-2 "Vs")))
"[]")
(define pl-adv-tv-env-3 {:Y (pl-mk-rt-var "Y") :Vs (pl-mk-rt-var "Vs") :X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "term_variables(f(X, Y), Vs)" pl-adv-tv-env-3)
(pl-mk-trail))
(pl-adv-test!
"term_variables(f(X,Y),Vs) has 2 vars"
(pl-list-length (pl-walk-deep (dict-get pl-adv-tv-env-3 "Vs")))
2)
(define pl-adv-tv-env-4 {:Vs (pl-mk-rt-var "Vs") :X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "term_variables(X, Vs)" pl-adv-tv-env-4)
(pl-mk-trail))
(pl-adv-test!
"term_variables(X,Vs) has 1 var"
(pl-list-length (pl-walk-deep (dict-get pl-adv-tv-env-4 "Vs")))
1)
(define pl-adv-tv-env-5 {:Y (pl-mk-rt-var "Y") :Vs (pl-mk-rt-var "Vs") :X (pl-mk-rt-var "X")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "term_variables(foo(X, Y, X), Vs)" pl-adv-tv-env-5)
(pl-mk-trail))
(pl-adv-test!
"term_variables(foo(X,Y,X),Vs) deduplicates X -> 2 vars"
(pl-list-length (pl-walk-deep (dict-get pl-adv-tv-env-5 "Vs")))
2)
;; ── predsort/3 ────────────────────────────────────────────────────
(define pl-adv-ps-env-1 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "predsort(cmp_num, [], R)" pl-adv-ps-env-1)
(pl-mk-trail))
(pl-adv-test!
"predsort([]) -> []"
(pl-format-term (pl-walk-deep (dict-get pl-adv-ps-env-1 "R")))
"[]")
(define pl-adv-ps-env-2 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "predsort(cmp_num, [1], R)" pl-adv-ps-env-2)
(pl-mk-trail))
(pl-adv-test!
"predsort([1]) -> [1]"
(pl-format-term (pl-walk-deep (dict-get pl-adv-ps-env-2 "R")))
".(1, [])")
(define pl-adv-ps-env-3 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "predsort(cmp_num, [3,1,2], R)" pl-adv-ps-env-3)
(pl-mk-trail))
(pl-adv-test!
"predsort([3,1,2]) -> [1,2,3]"
(pl-format-term (pl-walk-deep (dict-get pl-adv-ps-env-3 "R")))
".(1, .(2, .(3, [])))")
(define pl-adv-ps-env-4 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-adv-db
(pl-adv-goal "predsort(cmp_num, [3,1,2,1,3], R)" pl-adv-ps-env-4)
(pl-mk-trail))
(pl-adv-test!
"predsort([3,1,2,1,3]) dedup -> [1,2,3]"
(pl-format-term (pl-walk-deep (dict-get pl-adv-ps-env-4 "R")))
".(1, .(2, .(3, [])))")
;; ── Runner ─────────────────────────────────────────────────────────
(define pl-advanced-tests-run! (fn () {:failed pl-adv-test-fail :passed pl-adv-test-pass :total pl-adv-test-count :failures pl-adv-test-failures}))

215
lib/prolog/tests/assert_rules.sx
View File

@@ -1,215 +0,0 @@
;; lib/prolog/tests/assert_rules.sx — assert/assertz/asserta with rule terms (head :- body)
;; Tests that :- is in the op table (prec 1200 xfx) and pl-build-clause handles rule form.
(define pl-ar-test-count 0)
(define pl-ar-test-pass 0)
(define pl-ar-test-fail 0)
(define pl-ar-test-failures (list))
(define
pl-ar-test!
(fn
(name got expected)
(begin
(set! pl-ar-test-count (+ pl-ar-test-count 1))
(if
(= got expected)
(set! pl-ar-test-pass (+ pl-ar-test-pass 1))
(begin
(set! pl-ar-test-fail (+ pl-ar-test-fail 1))
(append!
pl-ar-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-ar-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
;; ── DB1: assertz a simple rule then query ──────────────────────────
(define pl-ar-db1 (pl-mk-db))
(pl-solve-once!
pl-ar-db1
(pl-ar-goal "assertz((double(X, Y) :- Y is X * 2))" {})
(pl-mk-trail))
(pl-ar-test!
"assertz rule: double(3, Y) succeeds"
(pl-solve-once!
pl-ar-db1
(pl-ar-goal "double(3, Y)" {})
(pl-mk-trail))
true)
(define pl-ar-env1 {})
(pl-solve-once!
pl-ar-db1
(pl-ar-goal "double(3, Y)" pl-ar-env1)
(pl-mk-trail))
(pl-ar-test!
"assertz rule: double(3, Y) binds Y to 6"
(pl-num-val (pl-walk-deep (dict-get pl-ar-env1 "Y")))
6)
(define pl-ar-env1b {})
(pl-solve-once!
pl-ar-db1
(pl-ar-goal "double(10, Y)" pl-ar-env1b)
(pl-mk-trail))
(pl-ar-test!
"assertz rule: double(10, Y) yields 20"
(pl-num-val (pl-walk-deep (dict-get pl-ar-env1b "Y")))
20)
;; ── DB2: assert a rule with multiple facts, count solutions ─────────
(define pl-ar-db2 (pl-mk-db))
(pl-solve-once!
pl-ar-db2
(pl-ar-goal "assert(fact(a))" {})
(pl-mk-trail))
(pl-solve-once!
pl-ar-db2
(pl-ar-goal "assert(fact(b))" {})
(pl-mk-trail))
(pl-solve-once!
pl-ar-db2
(pl-ar-goal "assertz((copy(X) :- fact(X)))" {})
(pl-mk-trail))
(pl-ar-test!
"rule copy/1 using fact/1: 2 solutions"
(pl-solve-count! pl-ar-db2 (pl-ar-goal "copy(X)" {}) (pl-mk-trail))
2)
(define pl-ar-env2a {})
(pl-solve-once! pl-ar-db2 (pl-ar-goal "copy(X)" pl-ar-env2a) (pl-mk-trail))
(pl-ar-test!
"rule copy/1: first solution is a"
(pl-atom-name (pl-walk-deep (dict-get pl-ar-env2a "X")))
"a")
;; ── DB3: asserta rule is tried before existing clauses ─────────────
(define pl-ar-db3 (pl-mk-db))
(pl-solve-once!
pl-ar-db3
(pl-ar-goal "assert(ord(a))" {})
(pl-mk-trail))
(pl-solve-once!
pl-ar-db3
(pl-ar-goal "asserta((ord(b) :- true))" {})
(pl-mk-trail))
(define pl-ar-env3 {})
(pl-solve-once! pl-ar-db3 (pl-ar-goal "ord(X)" pl-ar-env3) (pl-mk-trail))
(pl-ar-test!
"asserta rule ord(b) is tried before ord(a)"
(pl-atom-name (pl-walk-deep (dict-get pl-ar-env3 "X")))
"b")
(pl-ar-test!
"asserta: total solutions for ord/1 is 2"
(pl-solve-count! pl-ar-db3 (pl-ar-goal "ord(X)" {}) (pl-mk-trail))
2)
;; ── DB4: rule with conjunction in body ─────────────────────────────
(define pl-ar-db4 (pl-mk-db))
(pl-solve-once!
pl-ar-db4
(pl-ar-goal "assert(num(1))" {})
(pl-mk-trail))
(pl-solve-once!
pl-ar-db4
(pl-ar-goal "assert(num(2))" {})
(pl-mk-trail))
(pl-solve-once!
pl-ar-db4
(pl-ar-goal "assertz((big(X) :- num(X), X > 1))" {})
(pl-mk-trail))
(pl-ar-test!
"conjunction in rule body: big(1) fails"
(pl-solve-once! pl-ar-db4 (pl-ar-goal "big(1)" {}) (pl-mk-trail))
false)
(pl-ar-test!
"conjunction in rule body: big(2) succeeds"
(pl-solve-once! pl-ar-db4 (pl-ar-goal "big(2)" {}) (pl-mk-trail))
true)
;; ── DB5: recursive rule ─────────────────────────────────────────────
(define pl-ar-db5 (pl-mk-db))
(pl-solve-once!
pl-ar-db5
(pl-ar-goal "assert((nat(0) :- true))" {})
(pl-mk-trail))
(pl-solve-once!
pl-ar-db5
(pl-ar-goal "assertz((nat(s(X)) :- nat(X)))" {})
(pl-mk-trail))
(pl-ar-test!
"recursive rule: nat(0) succeeds"
(pl-solve-once! pl-ar-db5 (pl-ar-goal "nat(0)" {}) (pl-mk-trail))
true)
(pl-ar-test!
"recursive rule: nat(s(0)) succeeds"
(pl-solve-once!
pl-ar-db5
(pl-ar-goal "nat(s(0))" {})
(pl-mk-trail))
true)
(pl-ar-test!
"recursive rule: nat(s(s(0))) succeeds"
(pl-solve-once!
pl-ar-db5
(pl-ar-goal "nat(s(s(0)))" {})
(pl-mk-trail))
true)
(pl-ar-test!
"recursive rule: nat(bad) fails"
(pl-solve-once! pl-ar-db5 (pl-ar-goal "nat(bad)" {}) (pl-mk-trail))
false)
;; ── DB6: rule with true body (explicit) ────────────────────────────
(define pl-ar-db6 (pl-mk-db))
(pl-solve-once!
pl-ar-db6
(pl-ar-goal "assertz((always(X) :- true))" {})
(pl-mk-trail))
(pl-solve-once!
pl-ar-db6
(pl-ar-goal "assert(always(extra))" {})
(pl-mk-trail))
(pl-ar-test!
"rule body=true: always(foo) succeeds"
(pl-solve-once!
pl-ar-db6
(pl-ar-goal "always(foo)" {})
(pl-mk-trail))
true)
(pl-ar-test!
"rule body=true: always/1 has 2 clauses (1 rule + 1 fact)"
(pl-solve-count!
pl-ar-db6
(pl-ar-goal "always(X)" {})
(pl-mk-trail))
2)
;; ── Runner ──────────────────────────────────────────────────────────
(define pl-assert-rules-tests-run! (fn () {:failed pl-ar-test-fail :passed pl-ar-test-pass :total pl-ar-test-count :failures pl-ar-test-failures}))

305
lib/prolog/tests/atoms.sx
View File

@@ -1,305 +0,0 @@
;; lib/prolog/tests/atoms.sx — type predicates + string/atom built-ins
(define pl-at-test-count 0)
(define pl-at-test-pass 0)
(define pl-at-test-fail 0)
(define pl-at-test-failures (list))
(define
pl-at-test!
(fn
(name got expected)
(begin
(set! pl-at-test-count (+ pl-at-test-count 1))
(if
(= got expected)
(set! pl-at-test-pass (+ pl-at-test-pass 1))
(begin
(set! pl-at-test-fail (+ pl-at-test-fail 1))
(append!
pl-at-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-at-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-at-db (pl-mk-db))
;; ── var/1 + nonvar/1 ──
(pl-at-test!
"var(X) for unbound var"
(pl-solve-once! pl-at-db (pl-at-goal "var(X)" {}) (pl-mk-trail))
true)
(pl-at-test!
"var(foo) fails"
(pl-solve-once! pl-at-db (pl-at-goal "var(foo)" {}) (pl-mk-trail))
false)
(pl-at-test!
"nonvar(foo) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "nonvar(foo)" {})
(pl-mk-trail))
true)
(pl-at-test!
"nonvar(X) for unbound var fails"
(pl-solve-once! pl-at-db (pl-at-goal "nonvar(X)" {}) (pl-mk-trail))
false)
;; ── atom/1 ──
(pl-at-test!
"atom(foo) succeeds"
(pl-solve-once! pl-at-db (pl-at-goal "atom(foo)" {}) (pl-mk-trail))
true)
(pl-at-test!
"atom([]) succeeds"
(pl-solve-once! pl-at-db (pl-at-goal "atom([])" {}) (pl-mk-trail))
true)
(pl-at-test!
"atom(42) fails"
(pl-solve-once! pl-at-db (pl-at-goal "atom(42)" {}) (pl-mk-trail))
false)
(pl-at-test!
"atom(f(x)) fails"
(pl-solve-once!
pl-at-db
(pl-at-goal "atom(f(x))" {})
(pl-mk-trail))
false)
;; ── number/1 + integer/1 ──
(pl-at-test!
"number(42) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "number(42)" {})
(pl-mk-trail))
true)
(pl-at-test!
"number(foo) fails"
(pl-solve-once!
pl-at-db
(pl-at-goal "number(foo)" {})
(pl-mk-trail))
false)
(pl-at-test!
"integer(7) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "integer(7)" {})
(pl-mk-trail))
true)
;; ── compound/1 + callable/1 + atomic/1 ──
(pl-at-test!
"compound(f(x)) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "compound(f(x))" {})
(pl-mk-trail))
true)
(pl-at-test!
"compound(foo) fails"
(pl-solve-once!
pl-at-db
(pl-at-goal "compound(foo)" {})
(pl-mk-trail))
false)
(pl-at-test!
"callable(foo) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "callable(foo)" {})
(pl-mk-trail))
true)
(pl-at-test!
"callable(f(x)) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "callable(f(x))" {})
(pl-mk-trail))
true)
(pl-at-test!
"callable(42) fails"
(pl-solve-once!
pl-at-db
(pl-at-goal "callable(42)" {})
(pl-mk-trail))
false)
(pl-at-test!
"atomic(foo) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "atomic(foo)" {})
(pl-mk-trail))
true)
(pl-at-test!
"atomic(42) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "atomic(42)" {})
(pl-mk-trail))
true)
(pl-at-test!
"atomic(f(x)) fails"
(pl-solve-once!
pl-at-db
(pl-at-goal "atomic(f(x))" {})
(pl-mk-trail))
false)
;; ── is_list/1 ──
(pl-at-test!
"is_list([]) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "is_list([])" {})
(pl-mk-trail))
true)
(pl-at-test!
"is_list([1,2,3]) succeeds"
(pl-solve-once!
pl-at-db
(pl-at-goal "is_list([1,2,3])" {})
(pl-mk-trail))
true)
(pl-at-test!
"is_list(foo) fails"
(pl-solve-once!
pl-at-db
(pl-at-goal "is_list(foo)" {})
(pl-mk-trail))
false)
;; ── atom_length/2 ──
(define pl-at-env-al {})
(pl-solve-once!
pl-at-db
(pl-at-goal "atom_length(hello, N)" pl-at-env-al)
(pl-mk-trail))
(pl-at-test!
"atom_length(hello, N) -> N=5"
(pl-num-val (pl-walk-deep (dict-get pl-at-env-al "N")))
5)
(pl-at-test!
"atom_length empty atom"
(pl-solve-once!
pl-at-db
(pl-at-goal "atom_length('', 0)" {})
(pl-mk-trail))
true)
;; ── atom_concat/3 ──
(define pl-at-env-ac {})
(pl-solve-once!
pl-at-db
(pl-at-goal "atom_concat(foo, bar, X)" pl-at-env-ac)
(pl-mk-trail))
(pl-at-test!
"atom_concat(foo, bar, X) -> X=foobar"
(pl-atom-name (pl-walk-deep (dict-get pl-at-env-ac "X")))
"foobar")
(pl-at-test!
"atom_concat(foo, bar, foobar) check"
(pl-solve-once!
pl-at-db
(pl-at-goal "atom_concat(foo, bar, foobar)" {})
(pl-mk-trail))
true)
(pl-at-test!
"atom_concat(foo, bar, foobaz) fails"
(pl-solve-once!
pl-at-db
(pl-at-goal "atom_concat(foo, bar, foobaz)" {})
(pl-mk-trail))
false)
(define pl-at-env-ac2 {})
(pl-solve-once!
pl-at-db
(pl-at-goal "atom_concat(foo, Y, foobar)" pl-at-env-ac2)
(pl-mk-trail))
(pl-at-test!
"atom_concat(foo, Y, foobar) -> Y=bar"
(pl-atom-name (pl-walk-deep (dict-get pl-at-env-ac2 "Y")))
"bar")
;; ── atom_chars/2 ──
(define pl-at-env-ach {})
(pl-solve-once!
pl-at-db
(pl-at-goal "atom_chars(cat, Cs)" pl-at-env-ach)
(pl-mk-trail))
(pl-at-test!
"atom_chars(cat, Cs) -> Cs=[c,a,t]"
(pl-solve-once!
pl-at-db
(pl-at-goal "atom_chars(cat, [c,a,t])" {})
(pl-mk-trail))
true)
(define pl-at-env-ach2 {})
(pl-solve-once!
pl-at-db
(pl-at-goal "atom_chars(A, [h,i])" pl-at-env-ach2)
(pl-mk-trail))
(pl-at-test!
"atom_chars(A, [h,i]) -> A=hi"
(pl-atom-name (pl-walk-deep (dict-get pl-at-env-ach2 "A")))
"hi")
;; ── char_code/2 ──
(define pl-at-env-cc {})
(pl-solve-once!
pl-at-db
(pl-at-goal "char_code(a, N)" pl-at-env-cc)
(pl-mk-trail))
(pl-at-test!
"char_code(a, N) -> N=97"
(pl-num-val (pl-walk-deep (dict-get pl-at-env-cc "N")))
97)
(define pl-at-env-cc2 {})
(pl-solve-once!
pl-at-db
(pl-at-goal "char_code(C, 65)" pl-at-env-cc2)
(pl-mk-trail))
(pl-at-test!
"char_code(C, 65) -> C='A'"
(pl-atom-name (pl-walk-deep (dict-get pl-at-env-cc2 "C")))
"A")
;; ── number_codes/2 ──
(pl-at-test!
"number_codes(42, [52,50])"
(pl-solve-once!
pl-at-db
(pl-at-goal "number_codes(42, [52,50])" {})
(pl-mk-trail))
true)
;; ── number_chars/2 ──
(pl-at-test!
"number_chars(42, ['4','2'])"
(pl-solve-once!
pl-at-db
(pl-at-goal "number_chars(42, ['4','2'])" {})
(pl-mk-trail))
true)
(define pl-atom-tests-run! (fn () {:failed pl-at-test-fail :passed pl-at-test-pass :total pl-at-test-count :failures pl-at-test-failures}))

290
lib/prolog/tests/char_predicates.sx
View File

@@ -1,290 +0,0 @@
;; lib/prolog/tests/char_predicates.sx — char_type/2, upcase_atom/2, downcase_atom/2,
;; string_upper/2, string_lower/2
(define pl-cp-test-count 0)
(define pl-cp-test-pass 0)
(define pl-cp-test-fail 0)
(define pl-cp-test-failures (list))
(define
pl-cp-test!
(fn
(name got expected)
(begin
(set! pl-cp-test-count (+ pl-cp-test-count 1))
(if
(= got expected)
(set! pl-cp-test-pass (+ pl-cp-test-pass 1))
(begin
(set! pl-cp-test-fail (+ pl-cp-test-fail 1))
(append!
pl-cp-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-cp-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-cp-db (pl-mk-db))
;; ─── char_type/2 — alpha ──────────────────────────────────────────
(pl-cp-test!
"char_type(a, alpha) succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(a, alpha)" {})
(pl-mk-trail))
true)
(pl-cp-test!
"char_type('1', alpha) fails"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type('1', alpha)" {})
(pl-mk-trail))
false)
(pl-cp-test!
"char_type('A', alpha) succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type('A', alpha)" {})
(pl-mk-trail))
true)
;; ─── char_type/2 — alnum ─────────────────────────────────────────
(pl-cp-test!
"char_type('5', alnum) succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type('5', alnum)" {})
(pl-mk-trail))
true)
(pl-cp-test!
"char_type(a, alnum) succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(a, alnum)" {})
(pl-mk-trail))
true)
(pl-cp-test!
"char_type(' ', alnum) fails"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(' ', alnum)" {})
(pl-mk-trail))
false)
;; ─── char_type/2 — digit ─────────────────────────────────────────
(pl-cp-test!
"char_type('5', digit) succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type('5', digit)" {})
(pl-mk-trail))
true)
(pl-cp-test!
"char_type(a, digit) fails"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(a, digit)" {})
(pl-mk-trail))
false)
;; ─── char_type/2 — digit(Weight) ─────────────────────────────────
(define pl-cp-env-dw {})
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type('5', digit(N))" pl-cp-env-dw)
(pl-mk-trail))
(pl-cp-test!
"char_type('5', digit(N)) -> N=5"
(pl-num-val (pl-walk-deep (dict-get pl-cp-env-dw "N")))
5)
(define pl-cp-env-dw0 {})
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type('0', digit(N))" pl-cp-env-dw0)
(pl-mk-trail))
(pl-cp-test!
"char_type('0', digit(N)) -> N=0"
(pl-num-val (pl-walk-deep (dict-get pl-cp-env-dw0 "N")))
0)
;; ─── char_type/2 — space/white ───────────────────────────────────
(pl-cp-test!
"char_type(' ', space) succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(' ', space)" {})
(pl-mk-trail))
true)
(pl-cp-test!
"char_type(a, space) fails"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(a, space)" {})
(pl-mk-trail))
false)
;; ─── char_type/2 — upper(Lower) ──────────────────────────────────
(define pl-cp-env-ul {})
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type('A', upper(L))" pl-cp-env-ul)
(pl-mk-trail))
(pl-cp-test!
"char_type('A', upper(L)) -> L=a"
(pl-atom-name (pl-walk-deep (dict-get pl-cp-env-ul "L")))
"a")
(pl-cp-test!
"char_type(a, upper(L)) fails — not uppercase"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(a, upper(_))" {})
(pl-mk-trail))
false)
;; ─── char_type/2 — lower(Upper) ──────────────────────────────────
(define pl-cp-env-lu {})
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(a, lower(U))" pl-cp-env-lu)
(pl-mk-trail))
(pl-cp-test!
"char_type(a, lower(U)) -> U='A'"
(pl-atom-name (pl-walk-deep (dict-get pl-cp-env-lu "U")))
"A")
;; ─── char_type/2 — ascii(Code) ───────────────────────────────────
(define pl-cp-env-as {})
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(a, ascii(C))" pl-cp-env-as)
(pl-mk-trail))
(pl-cp-test!
"char_type(a, ascii(C)) -> C=97"
(pl-num-val (pl-walk-deep (dict-get pl-cp-env-as "C")))
97)
;; ─── char_type/2 — punct ─────────────────────────────────────────
(pl-cp-test!
"char_type('.', punct) succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type('.', punct)" {})
(pl-mk-trail))
true)
(pl-cp-test!
"char_type(a, punct) fails"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "char_type(a, punct)" {})
(pl-mk-trail))
false)
;; ─── upcase_atom/2 ───────────────────────────────────────────────
(define pl-cp-env-ua {})
(pl-solve-once!
pl-cp-db
(pl-cp-goal "upcase_atom(hello, X)" pl-cp-env-ua)
(pl-mk-trail))
(pl-cp-test!
"upcase_atom(hello, X) -> X='HELLO'"
(pl-atom-name (pl-walk-deep (dict-get pl-cp-env-ua "X")))
"HELLO")
(pl-cp-test!
"upcase_atom(hello, 'HELLO') succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "upcase_atom(hello, 'HELLO')" {})
(pl-mk-trail))
true)
(pl-cp-test!
"upcase_atom('Hello World', 'HELLO WORLD') succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "upcase_atom('Hello World', 'HELLO WORLD')" {})
(pl-mk-trail))
true)
(pl-cp-test!
"upcase_atom('', '') succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "upcase_atom('', '')" {})
(pl-mk-trail))
true)
;; ─── downcase_atom/2 ─────────────────────────────────────────────
(define pl-cp-env-da {})
(pl-solve-once!
pl-cp-db
(pl-cp-goal "downcase_atom('HELLO', X)" pl-cp-env-da)
(pl-mk-trail))
(pl-cp-test!
"downcase_atom('HELLO', X) -> X=hello"
(pl-atom-name (pl-walk-deep (dict-get pl-cp-env-da "X")))
"hello")
(pl-cp-test!
"downcase_atom('HELLO', hello) succeeds"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "downcase_atom('HELLO', hello)" {})
(pl-mk-trail))
true)
(pl-cp-test!
"downcase_atom(hello, hello) succeeds — already lowercase"
(pl-solve-once!
pl-cp-db
(pl-cp-goal "downcase_atom(hello, hello)" {})
(pl-mk-trail))
true)
;; ─── string_upper/2 + string_lower/2 (aliases) ───────────────────
(define pl-cp-env-su {})
(pl-solve-once!
pl-cp-db
(pl-cp-goal "string_upper(hello, X)" pl-cp-env-su)
(pl-mk-trail))
(pl-cp-test!
"string_upper(hello, X) -> X='HELLO'"
(pl-atom-name (pl-walk-deep (dict-get pl-cp-env-su "X")))
"HELLO")
(define pl-cp-env-sl {})
(pl-solve-once!
pl-cp-db
(pl-cp-goal "string_lower('WORLD', X)" pl-cp-env-sl)
(pl-mk-trail))
(pl-cp-test!
"string_lower('WORLD', X) -> X=world"
(pl-atom-name (pl-walk-deep (dict-get pl-cp-env-sl "X")))
"world")
(define pl-char-predicates-tests-run! (fn () {:failed pl-cp-test-fail :passed pl-cp-test-pass :total pl-cp-test-count :failures pl-cp-test-failures}))

99
lib/prolog/tests/clausedb.sx
View File

@@ -1,99 +0,0 @@
;; lib/prolog/tests/clausedb.sx — Clause DB unit tests
(define pl-db-test-count 0)
(define pl-db-test-pass 0)
(define pl-db-test-fail 0)
(define pl-db-test-failures (list))
(define
pl-db-test!
(fn
(name got expected)
(begin
(set! pl-db-test-count (+ pl-db-test-count 1))
(if
(= got expected)
(set! pl-db-test-pass (+ pl-db-test-pass 1))
(begin
(set! pl-db-test-fail (+ pl-db-test-fail 1))
(append!
pl-db-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(pl-db-test!
"head-key atom arity 0"
(pl-head-key (nth (first (pl-parse "foo.")) 1))
"foo/0")
(pl-db-test!
"head-key compound arity 2"
(pl-head-key (nth (first (pl-parse "bar(a, b).")) 1))
"bar/2")
(pl-db-test!
"clause-key of :- clause"
(pl-clause-key (first (pl-parse "likes(mary, X) :- friendly(X).")))
"likes/2")
(pl-db-test!
"empty db lookup returns empty list"
(len (pl-db-lookup (pl-mk-db) "parent/2"))
0)
(define pl-db-t1 (pl-mk-db))
(pl-db-load! pl-db-t1 (pl-parse "foo(a). foo(b). foo(c)."))
(pl-db-test!
"three facts same functor"
(len (pl-db-lookup pl-db-t1 "foo/1"))
3)
(pl-db-test!
"mismatching key returns empty"
(len (pl-db-lookup pl-db-t1 "foo/2"))
0)
(pl-db-test!
"first clause has arg a"
(pl-atom-name
(first (pl-args (nth (first (pl-db-lookup pl-db-t1 "foo/1")) 1))))
"a")
(pl-db-test!
"third clause has arg c"
(pl-atom-name
(first (pl-args (nth (nth (pl-db-lookup pl-db-t1 "foo/1") 2) 1))))
"c")
(define pl-db-t2 (pl-mk-db))
(pl-db-load! pl-db-t2 (pl-parse "foo. bar. foo. parent(a, b). parent(c, d)."))
(pl-db-test!
"atom heads keyed as foo/0"
(len (pl-db-lookup pl-db-t2 "foo/0"))
2)
(pl-db-test!
"atom heads keyed as bar/0"
(len (pl-db-lookup pl-db-t2 "bar/0"))
1)
(pl-db-test!
"compound heads keyed as parent/2"
(len (pl-db-lookup pl-db-t2 "parent/2"))
2)
(pl-db-test!
"lookup-goal extracts functor/arity"
(len
(pl-db-lookup-goal pl-db-t2 (nth (first (pl-parse "parent(X, Y).")) 1)))
2)
(pl-db-test!
"lookup-goal on atom goal"
(len (pl-db-lookup-goal pl-db-t2 (nth (first (pl-parse "foo.")) 1)))
2)
(pl-db-test!
"stored clause is clause form"
(first (first (pl-db-lookup pl-db-t2 "parent/2")))
"clause")
(define pl-clausedb-tests-run! (fn () {:failed pl-db-test-fail :passed pl-db-test-pass :total pl-db-test-count :failures pl-db-test-failures}))

185
lib/prolog/tests/compiler.sx
View File

@@ -1,185 +0,0 @@
;; lib/prolog/tests/compiler.sx — compiled clause dispatch tests
(define pl-cmp-test-count 0)
(define pl-cmp-test-pass 0)
(define pl-cmp-test-fail 0)
(define pl-cmp-test-failures (list))
(define
pl-cmp-test!
(fn
(name got expected)
(set! pl-cmp-test-count (+ pl-cmp-test-count 1))
(if
(= got expected)
(set! pl-cmp-test-pass (+ pl-cmp-test-pass 1))
(begin
(set! pl-cmp-test-fail (+ pl-cmp-test-fail 1))
(append! pl-cmp-test-failures name)))))
;; Load src, compile, return DB.
(define
pl-cmp-mk
(fn
(src)
(let
((db (pl-mk-db)))
(pl-db-load! db (pl-parse src))
(pl-compile-db! db)
db)))
;; Run goal string against compiled DB; return bool (instantiates vars).
(define
pl-cmp-once
(fn
(db src)
(pl-solve-once!
db
(pl-instantiate (pl-parse-goal src) {})
(pl-mk-trail))))
;; Count solutions for goal string against compiled DB.
(define
pl-cmp-count
(fn
(db src)
(pl-solve-count!
db
(pl-instantiate (pl-parse-goal src) {})
(pl-mk-trail))))
;; ── 1. Simple facts ──────────────────────────────────────────────
(define pl-cmp-db1 (pl-cmp-mk "color(red). color(green). color(blue)."))
(pl-cmp-test! "compiled fact hit" (pl-cmp-once pl-cmp-db1 "color(red)") true)
(pl-cmp-test!
"compiled fact miss"
(pl-cmp-once pl-cmp-db1 "color(yellow)")
false)
(pl-cmp-test! "compiled fact count" (pl-cmp-count pl-cmp-db1 "color(X)") 3)
;; ── 2. Recursive rule: append ────────────────────────────────────
(define
pl-cmp-db2
(pl-cmp-mk "append([], L, L). append([H|T], L, [H|R]) :- append(T, L, R)."))
(pl-cmp-test!
"compiled append build"
(pl-cmp-once pl-cmp-db2 "append([1,2],[3],[1,2,3])")
true)
(pl-cmp-test!
"compiled append fail"
(pl-cmp-once pl-cmp-db2 "append([1,2],[3],[1,2])")
false)
(pl-cmp-test!
"compiled append split count"
(pl-cmp-count pl-cmp-db2 "append(X, Y, [a,b])")
3)
;; ── 3. Cut ───────────────────────────────────────────────────────
(define
pl-cmp-db3
(pl-cmp-mk "first(X, [X|_]) :- !. first(X, [_|T]) :- first(X, T)."))
(pl-cmp-test!
"compiled cut: only one solution"
(pl-cmp-count pl-cmp-db3 "first(X, [a,b,c])")
1)
(let
((db pl-cmp-db3) (trail (pl-mk-trail)) (env {}))
(let
((x (pl-mk-rt-var "X")))
(dict-set! env "X" x)
(pl-solve-once!
db
(pl-instantiate (pl-parse-goal "first(X, [a,b,c])") env)
trail)
(pl-cmp-test!
"compiled cut: correct binding"
(pl-atom-name (pl-walk x))
"a")))
;; ── 4. member ────────────────────────────────────────────────────
(define
pl-cmp-db4
(pl-cmp-mk "member(X, [X|_]). member(X, [_|T]) :- member(X, T)."))
(pl-cmp-test!
"compiled member hit"
(pl-cmp-once pl-cmp-db4 "member(b, [a,b,c])")
true)
(pl-cmp-test!
"compiled member miss"
(pl-cmp-once pl-cmp-db4 "member(d, [a,b,c])")
false)
(pl-cmp-test!
"compiled member count"
(pl-cmp-count pl-cmp-db4 "member(X, [a,b,c])")
3)
;; ── 5. Arithmetic in body ────────────────────────────────────────
(define pl-cmp-db5 (pl-cmp-mk "double(X, Y) :- Y is X * 2."))
(let
((db pl-cmp-db5) (trail (pl-mk-trail)) (env {}))
(let
((y (pl-mk-rt-var "Y")))
(dict-set! env "Y" y)
(pl-solve-once!
db
(pl-instantiate (pl-parse-goal "double(5, Y)") env)
trail)
(pl-cmp-test! "compiled arithmetic in body" (pl-num-val (pl-walk y)) 10)))
;; ── 6. Transitive ancestor ───────────────────────────────────────
(define
pl-cmp-db6
(pl-cmp-mk
(str
"parent(a,b). parent(b,c). parent(c,d)."
"ancestor(X,Y) :- parent(X,Y)."
"ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y).")))
(pl-cmp-test!
"compiled ancestor direct"
(pl-cmp-once pl-cmp-db6 "ancestor(a,b)")
true)
(pl-cmp-test!
"compiled ancestor 3-step"
(pl-cmp-once pl-cmp-db6 "ancestor(a,d)")
true)
(pl-cmp-test!
"compiled ancestor fail"
(pl-cmp-once pl-cmp-db6 "ancestor(d,a)")
false)
;; ── 7. Fallback: uncompiled predicate calls compiled sub-predicate
(define
pl-cmp-db7
(let
((db (pl-mk-db)))
(pl-db-load! db (pl-parse "q(1). q(2)."))
(pl-compile-db! db)
(pl-db-load! db (pl-parse "r(X) :- q(X)."))
db))
(pl-cmp-test!
"uncompiled predicate resolves"
(pl-cmp-once pl-cmp-db7 "r(1)")
true)
(pl-cmp-test!
"uncompiled calls compiled sub-pred count"
(pl-cmp-count pl-cmp-db7 "r(X)")
2)
;; ── Runner ───────────────────────────────────────────────────────
(define pl-compiler-tests-run! (fn () {:failed pl-cmp-test-fail :passed pl-cmp-test-pass :total pl-cmp-test-count :failures pl-cmp-test-failures}))

86
lib/prolog/tests/cross_validate.sx
View File

@@ -1,86 +0,0 @@
;; lib/prolog/tests/cross_validate.sx
;; Verifies that the compiled solver produces the same solution counts as the
;; interpreter for each classic program + built-in exercise.
;; Interpreter is the reference: if they disagree, the compiler is wrong.
(define pl-xv-test-count 0)
(define pl-xv-test-pass 0)
(define pl-xv-test-fail 0)
(define pl-xv-test-failures (list))
(define
pl-xv-test!
(fn
(name got expected)
(set! pl-xv-test-count (+ pl-xv-test-count 1))
(if
(= got expected)
(set! pl-xv-test-pass (+ pl-xv-test-pass 1))
(begin
(set! pl-xv-test-fail (+ pl-xv-test-fail 1))
(append! pl-xv-test-failures name)))))
;; Shorthand: assert compiled result matches interpreter.
(define
pl-xv-match!
(fn
(name src goal)
(pl-xv-test! name (pl-compiled-matches-interp? src goal) true)))
;; ── 1. append/3 ─────────────────────────────────────────────────
(define
pl-xv-append
"append([], L, L). append([H|T], L, [H|R]) :- append(T, L, R).")
(pl-xv-match! "append build 2+2" pl-xv-append "append([1,2],[3,4],X)")
(pl-xv-match! "append split [a,b,c]" pl-xv-append "append(X, Y, [a,b,c])")
(pl-xv-match! "append member-mode" pl-xv-append "append(_, [3], [1,2,3])")
;; ── 2. member/2 ─────────────────────────────────────────────────
(define pl-xv-member "member(X, [X|_]). member(X, [_|T]) :- member(X, T).")
(pl-xv-match! "member check hit" pl-xv-member "member(b, [a,b,c])")
(pl-xv-match! "member count" pl-xv-member "member(X, [a,b,c])")
(pl-xv-match! "member empty" pl-xv-member "member(X, [])")
;; ── 3. facts + transitive rules ─────────────────────────────────
(define
pl-xv-ancestor
(str
"parent(a,b). parent(b,c). parent(c,d). parent(a,c)."
"ancestor(X,Y) :- parent(X,Y)."
"ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y)."))
(pl-xv-match! "ancestor direct" pl-xv-ancestor "ancestor(a,b)")
(pl-xv-match! "ancestor transitive" pl-xv-ancestor "ancestor(a,d)")
(pl-xv-match! "ancestor all from a" pl-xv-ancestor "ancestor(a,Y)")
;; ── 4. cut semantics ────────────────────────────────────────────
(define pl-xv-cut "first(X,[X|_]) :- !. first(X,[_|T]) :- first(X,T).")
(pl-xv-match! "cut one solution" pl-xv-cut "first(X,[a,b,c])")
(pl-xv-match! "cut empty list" pl-xv-cut "first(X,[])")
;; ── 5. arithmetic ───────────────────────────────────────────────
(define pl-xv-arith "sq(X,Y) :- Y is X * X. even(X) :- 0 is X mod 2.")
(pl-xv-match! "sq(3,Y) count" pl-xv-arith "sq(3,Y)")
(pl-xv-match! "sq(3,9) check" pl-xv-arith "sq(3,9)")
(pl-xv-match! "even(4) check" pl-xv-arith "even(4)")
(pl-xv-match! "even(3) check" pl-xv-arith "even(3)")
;; ── 6. if-then-else ─────────────────────────────────────────────
(define pl-xv-ite "classify(X, pos) :- X > 0, !. classify(_, nonpos).")
(pl-xv-match! "classify positive" pl-xv-ite "classify(5, C)")
(pl-xv-match! "classify zero" pl-xv-ite "classify(0, C)")
;; ── Runner ───────────────────────────────────────────────────────
(define pl-cross-validate-tests-run! (fn () {:failed pl-xv-test-fail :passed pl-xv-test-pass :total pl-xv-test-count :failures pl-xv-test-failures}))

158
lib/prolog/tests/dynamic.sx
View File

@@ -1,158 +0,0 @@
;; lib/prolog/tests/dynamic.sx — assert/asserta/assertz/retract.
(define pl-dy-test-count 0)
(define pl-dy-test-pass 0)
(define pl-dy-test-fail 0)
(define pl-dy-test-failures (list))
(define
pl-dy-test!
(fn
(name got expected)
(begin
(set! pl-dy-test-count (+ pl-dy-test-count 1))
(if
(= got expected)
(set! pl-dy-test-pass (+ pl-dy-test-pass 1))
(begin
(set! pl-dy-test-fail (+ pl-dy-test-fail 1))
(append!
pl-dy-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-dy-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
;; assertz then query
(define pl-dy-db1 (pl-mk-db))
(pl-solve-once!
pl-dy-db1
(pl-dy-goal "assertz(foo(1))" {})
(pl-mk-trail))
(pl-dy-test!
"assertz(foo(1)) + foo(1)"
(pl-solve-once! pl-dy-db1 (pl-dy-goal "foo(1)" {}) (pl-mk-trail))
true)
(pl-dy-test!
"after one assertz, foo/1 has 1 clause"
(pl-solve-count! pl-dy-db1 (pl-dy-goal "foo(X)" {}) (pl-mk-trail))
1)
;; assertz appends — order preserved
(define pl-dy-db2 (pl-mk-db))
(pl-solve-once!
pl-dy-db2
(pl-dy-goal "assertz(p(1))" {})
(pl-mk-trail))
(pl-solve-once!
pl-dy-db2
(pl-dy-goal "assertz(p(2))" {})
(pl-mk-trail))
(pl-dy-test!
"assertz twice — count 2"
(pl-solve-count! pl-dy-db2 (pl-dy-goal "p(X)" {}) (pl-mk-trail))
2)
(define pl-dy-env-a {})
(pl-solve-once! pl-dy-db2 (pl-dy-goal "p(X)" pl-dy-env-a) (pl-mk-trail))
(pl-dy-test!
"assertz: first solution is the first asserted (1)"
(pl-num-val (pl-walk-deep (dict-get pl-dy-env-a "X")))
1)
;; asserta prepends
(define pl-dy-db3 (pl-mk-db))
(pl-solve-once!
pl-dy-db3
(pl-dy-goal "assertz(p(1))" {})
(pl-mk-trail))
(pl-solve-once!
pl-dy-db3
(pl-dy-goal "asserta(p(99))" {})
(pl-mk-trail))
(define pl-dy-env-b {})
(pl-solve-once! pl-dy-db3 (pl-dy-goal "p(X)" pl-dy-env-b) (pl-mk-trail))
(pl-dy-test!
"asserta: prepended clause is first solution"
(pl-num-val (pl-walk-deep (dict-get pl-dy-env-b "X")))
99)
;; assert/1 = assertz/1
(define pl-dy-db4 (pl-mk-db))
(pl-solve-once!
pl-dy-db4
(pl-dy-goal "assert(g(7))" {})
(pl-mk-trail))
(pl-dy-test!
"assert/1 alias"
(pl-solve-once! pl-dy-db4 (pl-dy-goal "g(7)" {}) (pl-mk-trail))
true)
;; retract removes a fact
(define pl-dy-db5 (pl-mk-db))
(pl-solve-once!
pl-dy-db5
(pl-dy-goal "assertz(q(1))" {})
(pl-mk-trail))
(pl-solve-once!
pl-dy-db5
(pl-dy-goal "assertz(q(2))" {})
(pl-mk-trail))
(pl-solve-once!
pl-dy-db5
(pl-dy-goal "assertz(q(3))" {})
(pl-mk-trail))
(pl-dy-test!
"before retract: 3 clauses"
(pl-solve-count! pl-dy-db5 (pl-dy-goal "q(X)" {}) (pl-mk-trail))
3)
(pl-solve-once!
pl-dy-db5
(pl-dy-goal "retract(q(2))" {})
(pl-mk-trail))
(pl-dy-test!
"after retract(q(2)): 2 clauses left"
(pl-solve-count! pl-dy-db5 (pl-dy-goal "q(X)" {}) (pl-mk-trail))
2)
(define pl-dy-env-c {})
(pl-solve-once! pl-dy-db5 (pl-dy-goal "q(X)" pl-dy-env-c) (pl-mk-trail))
(pl-dy-test!
"after retract(q(2)): first remaining is 1"
(pl-num-val (pl-walk-deep (dict-get pl-dy-env-c "X")))
1)
;; retract of non-existent
(pl-dy-test!
"retract(missing(0)) on empty db fails"
(pl-solve-once!
(pl-mk-db)
(pl-dy-goal "retract(missing(0))" {})
(pl-mk-trail))
false)
;; retract with unbound var matches first
(define pl-dy-db6 (pl-mk-db))
(pl-solve-once!
pl-dy-db6
(pl-dy-goal "assertz(r(11))" {})
(pl-mk-trail))
(pl-solve-once!
pl-dy-db6
(pl-dy-goal "assertz(r(22))" {})
(pl-mk-trail))
(define pl-dy-env-d {})
(pl-solve-once!
pl-dy-db6
(pl-dy-goal "retract(r(X))" pl-dy-env-d)
(pl-mk-trail))
(pl-dy-test!
"retract(r(X)) binds X to first match"
(pl-num-val (pl-walk-deep (dict-get pl-dy-env-d "X")))
11)
(define pl-dynamic-tests-run! (fn () {:failed pl-dy-test-fail :passed pl-dy-test-pass :total pl-dy-test-count :failures pl-dy-test-failures}))

167
lib/prolog/tests/findall.sx
View File

@@ -1,167 +0,0 @@
;; lib/prolog/tests/findall.sx — findall/3, bagof/3, setof/3.
(define pl-fb-test-count 0)
(define pl-fb-test-pass 0)
(define pl-fb-test-fail 0)
(define pl-fb-test-failures (list))
(define
pl-fb-test!
(fn
(name got expected)
(begin
(set! pl-fb-test-count (+ pl-fb-test-count 1))
(if
(= got expected)
(set! pl-fb-test-pass (+ pl-fb-test-pass 1))
(begin
(set! pl-fb-test-fail (+ pl-fb-test-fail 1))
(append!
pl-fb-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-fb-term-to-sx
(fn
(t)
(cond
((pl-num? t) (pl-num-val t))
((pl-atom? t) (pl-atom-name t))
(true (list :complex)))))
(define
pl-fb-list-walked
(fn
(w)
(cond
((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list))
((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
(cons
(pl-fb-term-to-sx (first (pl-args w)))
(pl-fb-list-walked (nth (pl-args w) 1))))
(true (list :not-list)))))
(define pl-fb-list-to-sx (fn (t) (pl-fb-list-walked (pl-walk-deep t))))
(define
pl-fb-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-fb-prog-src "member(X, [X|_]). member(X, [_|T]) :- member(X, T).")
(define pl-fb-db (pl-mk-db))
(pl-db-load! pl-fb-db (pl-parse pl-fb-prog-src))
;; ── findall ──
(define pl-fb-env-1 {})
(pl-solve-once!
pl-fb-db
(pl-fb-goal "findall(X, member(X, [a, b, c]), L)" pl-fb-env-1)
(pl-mk-trail))
(pl-fb-test!
"findall member [a, b, c]"
(pl-fb-list-to-sx (dict-get pl-fb-env-1 "L"))
(list "a" "b" "c"))
(define pl-fb-env-2 {})
(pl-solve-once!
pl-fb-db
(pl-fb-goal "findall(X, (member(X, [1, 2, 3]), X >= 2), L)" pl-fb-env-2)
(pl-mk-trail))
(pl-fb-test!
"findall with comparison filter"
(pl-fb-list-to-sx (dict-get pl-fb-env-2 "L"))
(list 2 3))
(define pl-fb-env-3 {})
(pl-solve-once!
pl-fb-db
(pl-fb-goal "findall(X, fail, L)" pl-fb-env-3)
(pl-mk-trail))
(pl-fb-test!
"findall on fail succeeds with empty list"
(pl-fb-list-to-sx (dict-get pl-fb-env-3 "L"))
(list))
(pl-fb-test!
"findall(X, fail, L) the goal succeeds"
(pl-solve-once!
pl-fb-db
(pl-fb-goal "findall(X, fail, L)" {})
(pl-mk-trail))
true)
(define pl-fb-env-4 {})
(pl-solve-once!
pl-fb-db
(pl-fb-goal
"findall(p(X, Y), (member(X, [1, 2]), member(Y, [a, b])), L)"
pl-fb-env-4)
(pl-mk-trail))
(pl-fb-test!
"findall over compound template — count = 4"
(len (pl-fb-list-to-sx (dict-get pl-fb-env-4 "L")))
4)
;; ── bagof ──
(pl-fb-test!
"bagof succeeds when results exist"
(pl-solve-once!
pl-fb-db
(pl-fb-goal "bagof(X, member(X, [1, 2, 3]), L)" {})
(pl-mk-trail))
true)
(pl-fb-test!
"bagof fails on empty"
(pl-solve-once!
pl-fb-db
(pl-fb-goal "bagof(X, fail, L)" {})
(pl-mk-trail))
false)
(define pl-fb-env-5 {})
(pl-solve-once!
pl-fb-db
(pl-fb-goal "bagof(X, member(X, [c, a, b]), L)" pl-fb-env-5)
(pl-mk-trail))
(pl-fb-test!
"bagof preserves order"
(pl-fb-list-to-sx (dict-get pl-fb-env-5 "L"))
(list "c" "a" "b"))
;; ── setof ──
(define pl-fb-env-6 {})
(pl-solve-once!
pl-fb-db
(pl-fb-goal "setof(X, member(X, [c, a, b, a, c]), L)" pl-fb-env-6)
(pl-mk-trail))
(pl-fb-test!
"setof sorts + dedupes atoms"
(pl-fb-list-to-sx (dict-get pl-fb-env-6 "L"))
(list "a" "b" "c"))
(pl-fb-test!
"setof fails on empty"
(pl-solve-once!
pl-fb-db
(pl-fb-goal "setof(X, fail, L)" {})
(pl-mk-trail))
false)
(define pl-fb-env-7 {})
(pl-solve-once!
pl-fb-db
(pl-fb-goal "setof(X, member(X, [3, 1, 2, 1, 3]), L)" pl-fb-env-7)
(pl-mk-trail))
(pl-fb-test!
"setof sorts + dedupes nums"
(pl-fb-list-to-sx (dict-get pl-fb-env-7 "L"))
(list 1 2 3))
(define pl-findall-tests-run! (fn () {:failed pl-fb-test-fail :passed pl-fb-test-pass :total pl-fb-test-count :failures pl-fb-test-failures}))

165
lib/prolog/tests/hs_bridge.sx
View File

@@ -1,165 +0,0 @@
;; lib/prolog/tests/hs_bridge.sx — tests for Prolog↔Hyperscript bridge
;;
;; Verifies pl-hs-query, pl-hs-predicate/N, and pl-hs-install.
;; Also demonstrates the end-to-end DSL pattern:
;; (define allowed (pl-hs-predicate/2 db "allowed"))
;; → (allowed "alice" "edit") is what Hyperscript compiles
;; `when allowed(alice, edit)` to.
(define pl-hsb-test-count 0)
(define pl-hsb-test-pass 0)
(define pl-hsb-test-fail 0)
(define pl-hsb-test-failures (list))
(define
pl-hsb-test!
(fn
(name got expected)
(begin
(set! pl-hsb-test-count (+ pl-hsb-test-count 1))
(if
(= got expected)
(set! pl-hsb-test-pass (+ pl-hsb-test-pass 1))
(begin
(set! pl-hsb-test-fail (+ pl-hsb-test-fail 1))
(append!
pl-hsb-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
;; ── shared KB ──
(define
pl-hsb-perm-src
"role(alice, admin). role(bob, editor). role(charlie, viewer). permission(admin, read). permission(admin, write). permission(admin, delete). permission(editor, read). permission(editor, write). permission(viewer, read). allowed(U, A) :- role(U, R), permission(R, A).")
(define pl-hsb-db (pl-load pl-hsb-perm-src))
;; ── pl-hs-query ──
(pl-hsb-test!
"pl-hs-query: ground fact succeeds"
(pl-hs-query pl-hsb-db "role(alice, admin)")
true)
(pl-hsb-test!
"pl-hs-query: absent fact fails"
(pl-hs-query pl-hsb-db "role(alice, viewer)")
false)
(pl-hsb-test!
"pl-hs-query: rule derivation succeeds"
(pl-hs-query pl-hsb-db "allowed(alice, delete)")
true)
(pl-hsb-test!
"pl-hs-query: rule derivation fails"
(pl-hs-query pl-hsb-db "allowed(charlie, delete)")
false)
(pl-hsb-test!
"pl-hs-query: arithmetic goal"
(pl-hs-query pl-hsb-db "X is 3 + 4, X = 7")
true)
;; ── pl-hs-predicate/2 ──
(define pl-hsb-allowed (pl-hs-predicate/2 pl-hsb-db "allowed"))
(pl-hsb-test!
"predicate/2: alice can read"
(pl-hsb-allowed "alice" "read")
true)
(pl-hsb-test!
"predicate/2: alice can delete"
(pl-hsb-allowed "alice" "delete")
true)
(pl-hsb-test!
"predicate/2: charlie cannot write"
(pl-hsb-allowed "charlie" "write")
false)
(pl-hsb-test!
"predicate/2: bob can write"
(pl-hsb-allowed "bob" "write")
true)
(pl-hsb-test!
"predicate/2: unknown user fails"
(pl-hsb-allowed "eve" "read")
false)
;; ── DSL simulation ──
;; Hyperscript compiles `when allowed(user, action) then …`
;; to `(allowed user action)` — a direct SX function call.
;; Here we verify that pattern works end-to-end.
(define pl-hsb-user "alice")
(define pl-hsb-action "write")
(pl-hsb-test!
"DSL simulation: (allowed user action) true path"
(pl-hsb-allowed pl-hsb-user pl-hsb-action)
true)
(define pl-hsb-user2 "charlie")
(pl-hsb-test!
"DSL simulation: (allowed user action) false path"
(pl-hsb-allowed pl-hsb-user2 pl-hsb-action)
false)
;; ── pl-hs-predicate/1 ──
(define pl-hsb-viewer-src "color(red). color(green). color(blue).")
(define pl-hsb-color-db (pl-load pl-hsb-viewer-src))
(define pl-hsb-color? (pl-hs-predicate/1 pl-hsb-color-db "color"))
(pl-hsb-test! "predicate/1: color(red) succeeds" (pl-hsb-color? "red") true)
(pl-hsb-test!
"predicate/1: color(purple) fails"
(pl-hsb-color? "purple")
false)
;; ── pl-hs-predicate/3 ──
(define pl-hsb-3ary-src "between_vals(X, Lo, Hi) :- X >= Lo, X =< Hi.")
(define pl-hsb-3ary-db (pl-load pl-hsb-3ary-src))
(define pl-hsb-in-range? (pl-hs-predicate/3 pl-hsb-3ary-db "between_vals"))
(pl-hsb-test!
"predicate/3: 5 in range [1,10]"
(pl-hsb-in-range? "5" "1" "10")
true)
(pl-hsb-test!
"predicate/3: 15 not in range [1,10]"
(pl-hsb-in-range? "15" "1" "10")
false)
;; ── pl-hs-install ──
(define
pl-hsb-installed
(pl-hs-install
pl-hsb-db
(list (list "allowed" 2) (list "role" 2) (list "permission" 2))))
(pl-hsb-test!
"pl-hs-install: returns dict with allowed key"
(not (nil? (dict-get pl-hsb-installed "allowed")))
true)
(pl-hsb-test!
"pl-hs-install: installed allowed fn works"
((dict-get pl-hsb-installed "allowed") "alice" "delete")
true)
(pl-hsb-test!
"pl-hs-install: installed role fn works"
((dict-get pl-hsb-installed "role") "bob" "editor")
true)
(define pl-hs-bridge-tests-run! (fn () {:failed pl-hsb-test-fail :passed pl-hsb-test-pass :total pl-hsb-test-count :failures pl-hsb-test-failures}))

172
lib/prolog/tests/integration.sx
View File

@@ -1,172 +0,0 @@
;; lib/prolog/tests/integration.sx — end-to-end integration tests via pl-query-* API
;;
;; Tests the full source→parse→load→solve pipeline with real programs.
;; Covers: permission system, graph reachability, quicksort, fibonacci, dynamic KB.
(define pl-int-test-count 0)
(define pl-int-test-pass 0)
(define pl-int-test-fail 0)
(define pl-int-test-failures (list))
(define
pl-int-test!
(fn
(name got expected)
(begin
(set! pl-int-test-count (+ pl-int-test-count 1))
(if
(= got expected)
(set! pl-int-test-pass (+ pl-int-test-pass 1))
(begin
(set! pl-int-test-fail (+ pl-int-test-fail 1))
(append!
pl-int-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
;; ── Permission system ──
;; role/2 + permission/2 facts, allowed/2 rule
(define
pl-int-perm-src
"role(alice, admin). role(bob, editor). role(charlie, viewer). permission(admin, read). permission(admin, write). permission(admin, delete). permission(editor, read). permission(editor, write). permission(viewer, read). allowed(U, A) :- role(U, R), permission(R, A).")
(define pl-int-perm-db (pl-load pl-int-perm-src))
(pl-int-test!
"alice can read"
(len (pl-query-all pl-int-perm-db "allowed(alice, read)"))
1)
(pl-int-test!
"alice can delete"
(len (pl-query-all pl-int-perm-db "allowed(alice, delete)"))
1)
(pl-int-test!
"charlie cannot write"
(len (pl-query-all pl-int-perm-db "allowed(charlie, write)"))
0)
(pl-int-test!
"alice has 3 permissions"
(len (pl-query-all pl-int-perm-db "allowed(alice, A)"))
3)
(pl-int-test!
"only one user can delete"
(len (pl-query-all pl-int-perm-db "allowed(U, delete)"))
1)
(pl-int-test!
"the deleter is alice"
(dict-get (first (pl-query-all pl-int-perm-db "allowed(U, delete)")) "U")
"alice")
;; ── Graph reachability ──
;; Directed edges; path/2 transitive closure via two clauses
(define
pl-int-graph-src
"edge(a, b). edge(b, c). edge(c, d). edge(b, d). path(X, Y) :- edge(X, Y). path(X, Y) :- edge(X, Z), path(Z, Y).")
(define pl-int-graph-db (pl-load pl-int-graph-src))
(pl-int-test!
"direct edge a→b is a path"
(len (pl-query-all pl-int-graph-db "path(a, b)"))
1)
(pl-int-test!
"transitive path a→c"
(len (pl-query-all pl-int-graph-db "path(a, c)"))
1)
(pl-int-test!
"no path d→a (no back-edges)"
(len (pl-query-all pl-int-graph-db "path(d, a)"))
0)
(pl-int-test!
"4 derivations from a (b,c,d via two routes to d)"
(len (pl-query-all pl-int-graph-db "path(a, Y)"))
4)
;; ── Quicksort ──
;; Partition-and-recurse; uses its own append/3 to avoid DB pollution
(define
pl-int-qs-src
"partition(_, [], [], []). partition(Piv, [H|T], [H|Less], Greater) :- H =< Piv, !, partition(Piv, T, Less, Greater). partition(Piv, [H|T], Less, [H|Greater]) :- partition(Piv, T, Less, Greater). append([], L, L). append([H|T], L, [H|R]) :- append(T, L, R). quicksort([], []). quicksort([H|T], Sorted) :- partition(H, T, Less, Greater), quicksort(Less, SL), quicksort(Greater, SG), append(SL, [H|SG], Sorted).")
(define pl-int-qs-db (pl-load pl-int-qs-src))
(pl-int-test!
"quicksort([]) = [] (ground check)"
(len (pl-query-all pl-int-qs-db "quicksort([], [])"))
1)
(pl-int-test!
"quicksort([3,1,2]) = [1,2,3] (ground check)"
(len (pl-query-all pl-int-qs-db "quicksort([3,1,2], [1,2,3])"))
1)
(pl-int-test!
"quicksort([5,3,1,4,2]) = [1,2,3,4,5] (ground check)"
(len (pl-query-all pl-int-qs-db "quicksort([5,3,1,4,2], [1,2,3,4,5])"))
1)
(pl-int-test!
"quicksort([3,1,2], [3,1,2]) fails — unsorted order rejected"
(len (pl-query-all pl-int-qs-db "quicksort([3,1,2], [3,1,2])"))
0)
;; ── Fibonacci ──
;; Naive recursive; ground checks avoid list-format uncertainty
(define
pl-int-fib-src
"fib(0, 0). fib(1, 1). fib(N, F) :- N > 1, N1 is N - 1, N2 is N - 2, fib(N1, F1), fib(N2, F2), F is F1 + F2.")
(define pl-int-fib-db (pl-load pl-int-fib-src))
(pl-int-test!
"fib(0, 0) succeeds"
(len (pl-query-all pl-int-fib-db "fib(0, 0)"))
1)
(pl-int-test!
"fib(5, 5) succeeds"
(len (pl-query-all pl-int-fib-db "fib(5, 5)"))
1)
(pl-int-test!
"fib(7, 13) succeeds"
(len (pl-query-all pl-int-fib-db "fib(7, 13)"))
1)
;; ── Dynamic knowledge base ──
;; Assert and retract facts; the DB dict is mutable so mutations persist
(define pl-int-dyn-src "color(red). color(green). color(blue).")
(define pl-int-dyn-db (pl-load pl-int-dyn-src))
(pl-int-test!
"initial KB: 3 colors"
(len (pl-query-all pl-int-dyn-db "color(X)"))
3)
(pl-int-test!
"after assert(color(yellow)): 4 colors"
(begin
(pl-query-all pl-int-dyn-db "assert(color(yellow))")
(len (pl-query-all pl-int-dyn-db "color(X)")))
4)
(pl-int-test!
"after retract(color(red)): back to 3 colors"
(begin
(pl-query-all pl-int-dyn-db "retract(color(red))")
(len (pl-query-all pl-int-dyn-db "color(X)")))
3)
(define pl-integration-tests-run! (fn () {:failed pl-int-test-fail :passed pl-int-test-pass :total pl-int-test-count :failures pl-int-test-failures}))

326
lib/prolog/tests/io_predicates.sx
View File

@@ -1,326 +0,0 @@
;; lib/prolog/tests/io_predicates.sx — term_to_atom/2, term_string/2,
;; with_output_to/2, writeln/1, format/1, format/2
(define pl-io-test-count 0)
(define pl-io-test-pass 0)
(define pl-io-test-fail 0)
(define pl-io-test-failures (list))
(define
pl-io-test!
(fn
(name got expected)
(begin
(set! pl-io-test-count (+ pl-io-test-count 1))
(if
(= got expected)
(set! pl-io-test-pass (+ pl-io-test-pass 1))
(begin
(set! pl-io-test-fail (+ pl-io-test-fail 1))
(append!
pl-io-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-io-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-io-db (pl-mk-db))
;; helper: get output buffer after running a goal
(define
pl-io-capture!
(fn
(goal)
(do
(pl-output-clear!)
(pl-solve-once! pl-io-db goal (pl-mk-trail))
pl-output-buffer)))
;; ─── term_to_atom/2 — bound Term direction ─────────────────────────────────
(pl-io-test!
"term_to_atom(foo(a,b), A) — compound"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "term_to_atom(foo(a,b), A)" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "A"))))
"foo(a, b)")
(pl-io-test!
"term_to_atom(hello, A) — atom"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "term_to_atom(hello, A)" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "A"))))
"hello")
(pl-io-test!
"term_to_atom(42, A) — number"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "term_to_atom(42, A)" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "A"))))
"42")
(pl-io-test!
"term_to_atom(foo(a,b), 'foo(a, b)') — succeeds when Atom matches"
(pl-solve-once!
pl-io-db
(pl-io-goal "term_to_atom(foo(a,b), 'foo(a, b)')" {})
(pl-mk-trail))
true)
(pl-io-test!
"term_to_atom(hello, world) — fails on mismatch"
(pl-solve-once!
pl-io-db
(pl-io-goal "term_to_atom(hello, world)" {})
(pl-mk-trail))
false)
;; ─── term_to_atom/2 — parse direction (Atom bound, Term unbound) ───────────
(pl-io-test!
"term_to_atom(T, 'foo(a)') — parse direction gives compound"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "term_to_atom(T, 'foo(a)')" env)
(pl-mk-trail))
(let
((t (pl-walk-deep (dict-get env "T"))))
(and (pl-compound? t) (= (pl-fun t) "foo"))))
true)
(pl-io-test!
"term_to_atom(T, hello) — parse direction gives atom"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "term_to_atom(T, hello)" env)
(pl-mk-trail))
(let
((t (pl-walk-deep (dict-get env "T"))))
(and (pl-atom? t) (= (pl-atom-name t) "hello"))))
true)
;; ─── term_string/2 — alias ──────────────────────────────────────────────────
(pl-io-test!
"term_string(bar(x), A) — same as term_to_atom"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "term_string(bar(x), A)" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "A"))))
"bar(x)")
(pl-io-test!
"term_string(42, A) — number to string"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "term_string(42, A)" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "A"))))
"42")
;; ─── writeln/1 ─────────────────────────────────────────────────────────────
(pl-io-test!
"writeln(hello) writes 'hello\n'"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), writeln(hello))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"hello
")
(pl-io-test!
"writeln(42) writes '42\n'"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), writeln(42))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"42
")
;; ─── with_output_to/2 ──────────────────────────────────────────────────────
(pl-io-test!
"with_output_to(atom(X), write(foo)) — captures write output"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), write(foo))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"foo")
(pl-io-test!
"with_output_to(atom(X), (write(a), write(b))) — concat output"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), (write(a), write(b)))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"ab")
(pl-io-test!
"with_output_to(atom(X), nl) — captures newline"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), nl)" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"
")
(pl-io-test!
"with_output_to(atom(X), true) — captures empty string"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), true)" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"")
(pl-io-test!
"with_output_to(string(X), write(hello)) — string sink works"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(string(X), write(hello))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"hello")
(pl-io-test!
"with_output_to(atom(X), fail) — fails when goal fails"
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), fail)" {})
(pl-mk-trail))
false)
;; ─── format/1 ──────────────────────────────────────────────────────────────
(pl-io-test!
"format('hello~n') — tilde-n becomes newline"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), format('hello~n'))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"hello
")
(pl-io-test!
"format('~~') — double tilde becomes single tilde"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), format('~~'))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"~")
(pl-io-test!
"format('abc') — plain text passes through"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), format(abc))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"abc")
;; ─── format/2 ──────────────────────────────────────────────────────────────
(pl-io-test!
"format('~w+~w', [1,2]) — two ~w args"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), format('~w+~w', [1,2]))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"1+2")
(pl-io-test!
"format('hello ~a!', [world]) — ~a with atom arg"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), format('hello ~a!', [world]))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"hello world!")
(pl-io-test!
"format('n=~d', [42]) — ~d with integer arg"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), format('n=~d', [42]))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"n=42")
(pl-io-test!
"format('~w', [foo(a)]) — ~w with compound"
(let
((env {}))
(pl-solve-once!
pl-io-db
(pl-io-goal "with_output_to(atom(X), format('~w', [foo(a)]))" env)
(pl-mk-trail))
(pl-atom-name (pl-walk-deep (dict-get env "X"))))
"foo(a)")
(define
pl-io-predicates-tests-run!
(fn
()
{:failed pl-io-test-fail
:passed pl-io-test-pass
:total pl-io-test-count
:failures pl-io-test-failures}))

320
lib/prolog/tests/iso_predicates.sx
View File

@@ -1,320 +0,0 @@
;; lib/prolog/tests/iso_predicates.sx — succ/2, plus/3, between/3, length/2, last/2, nth0/3, nth1/3, max/min arith
(define pl-ip-test-count 0)
(define pl-ip-test-pass 0)
(define pl-ip-test-fail 0)
(define pl-ip-test-failures (list))
(define
pl-ip-test!
(fn
(name got expected)
(begin
(set! pl-ip-test-count (+ pl-ip-test-count 1))
(if
(= got expected)
(set! pl-ip-test-pass (+ pl-ip-test-pass 1))
(begin
(set! pl-ip-test-fail (+ pl-ip-test-fail 1))
(append!
pl-ip-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-ip-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-ip-db (pl-mk-db))
;; ── succ/2 ──
(define pl-ip-env-s1 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "succ(3, X)" pl-ip-env-s1)
(pl-mk-trail))
(pl-ip-test!
"succ(3, X) → X=4"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-s1 "X")))
4)
(define pl-ip-env-s2 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "succ(0, X)" pl-ip-env-s2)
(pl-mk-trail))
(pl-ip-test!
"succ(0, X) → X=1"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-s2 "X")))
1)
(define pl-ip-env-s3 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "succ(X, 5)" pl-ip-env-s3)
(pl-mk-trail))
(pl-ip-test!
"succ(X, 5) → X=4"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-s3 "X")))
4)
(pl-ip-test!
"succ(X, 0) fails"
(pl-solve-once!
pl-ip-db
(pl-ip-goal "succ(X, 0)" {})
(pl-mk-trail))
false)
;; ── plus/3 ──
(define pl-ip-env-p1 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "plus(2, 3, X)" pl-ip-env-p1)
(pl-mk-trail))
(pl-ip-test!
"plus(2, 3, X) → X=5"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-p1 "X")))
5)
(define pl-ip-env-p2 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "plus(2, X, 7)" pl-ip-env-p2)
(pl-mk-trail))
(pl-ip-test!
"plus(2, X, 7) → X=5"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-p2 "X")))
5)
(define pl-ip-env-p3 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "plus(X, 3, 7)" pl-ip-env-p3)
(pl-mk-trail))
(pl-ip-test!
"plus(X, 3, 7) → X=4"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-p3 "X")))
4)
(pl-ip-test!
"plus(0, 0, 0) succeeds"
(pl-solve-once!
pl-ip-db
(pl-ip-goal "plus(0, 0, 0)" {})
(pl-mk-trail))
true)
;; ── between/3 ──
(pl-ip-test!
"between(1, 3, X): 3 solutions"
(pl-solve-count!
pl-ip-db
(pl-ip-goal "between(1, 3, X)" {})
(pl-mk-trail))
3)
(pl-ip-test!
"between(1, 3, 2) succeeds"
(pl-solve-once!
pl-ip-db
(pl-ip-goal "between(1, 3, 2)" {})
(pl-mk-trail))
true)
(pl-ip-test!
"between(1, 3, 5) fails"
(pl-solve-once!
pl-ip-db
(pl-ip-goal "between(1, 3, 5)" {})
(pl-mk-trail))
false)
(pl-ip-test!
"between(5, 3, X): 0 solutions (empty range)"
(pl-solve-count!
pl-ip-db
(pl-ip-goal "between(5, 3, X)" {})
(pl-mk-trail))
0)
(define pl-ip-env-b1 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "between(1, 5, X)" pl-ip-env-b1)
(pl-mk-trail))
(pl-ip-test!
"between(1, 5, X): first solution X=1"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-b1 "X")))
1)
(pl-ip-test!
"between + condition: between(1,5,X), X > 3 → 2 solutions"
(pl-solve-count!
pl-ip-db
(pl-ip-goal "between(1, 5, X), X > 3" {})
(pl-mk-trail))
2)
;; ── length/2 ──
(define pl-ip-env-l1 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "length([1,2,3], N)" pl-ip-env-l1)
(pl-mk-trail))
(pl-ip-test!
"length([1,2,3], N) → N=3"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-l1 "N")))
3)
(define pl-ip-env-l2 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "length([], N)" pl-ip-env-l2)
(pl-mk-trail))
(pl-ip-test!
"length([], N) → N=0"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-l2 "N")))
0)
(pl-ip-test!
"length([a,b], 2) check succeeds"
(pl-solve-once!
pl-ip-db
(pl-ip-goal "length([a,b], 2)" {})
(pl-mk-trail))
true)
(define pl-ip-env-l3 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "length(L, 3)" pl-ip-env-l3)
(pl-mk-trail))
(pl-ip-test!
"length(L, 3): L is a list of length 3"
(pl-solve-once!
pl-ip-db
(pl-ip-goal "length(L, 3), is_list(L)" pl-ip-env-l3)
(pl-mk-trail))
true)
;; ── last/2 ──
(define pl-ip-env-la1 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "last([1,2,3], X)" pl-ip-env-la1)
(pl-mk-trail))
(pl-ip-test!
"last([1,2,3], X) → X=3"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-la1 "X")))
3)
(define pl-ip-env-la2 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "last([a], X)" pl-ip-env-la2)
(pl-mk-trail))
(pl-ip-test!
"last([a], X) → X=a"
(pl-atom-name (pl-walk-deep (dict-get pl-ip-env-la2 "X")))
"a")
(pl-ip-test!
"last([], X) fails"
(pl-solve-once!
pl-ip-db
(pl-ip-goal "last([], X)" {})
(pl-mk-trail))
false)
;; ── nth0/3 ──
(define pl-ip-env-n0 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "nth0(0, [a,b,c], X)" pl-ip-env-n0)
(pl-mk-trail))
(pl-ip-test!
"nth0(0, [a,b,c], X) → X=a"
(pl-atom-name (pl-walk-deep (dict-get pl-ip-env-n0 "X")))
"a")
(define pl-ip-env-n1 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "nth0(2, [a,b,c], X)" pl-ip-env-n1)
(pl-mk-trail))
(pl-ip-test!
"nth0(2, [a,b,c], X) → X=c"
(pl-atom-name (pl-walk-deep (dict-get pl-ip-env-n1 "X")))
"c")
(pl-ip-test!
"nth0(5, [a,b,c], X) fails"
(pl-solve-once!
pl-ip-db
(pl-ip-goal "nth0(5, [a,b,c], X)" {})
(pl-mk-trail))
false)
;; ── nth1/3 ──
(define pl-ip-env-n1a {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "nth1(1, [a,b,c], X)" pl-ip-env-n1a)
(pl-mk-trail))
(pl-ip-test!
"nth1(1, [a,b,c], X) → X=a"
(pl-atom-name (pl-walk-deep (dict-get pl-ip-env-n1a "X")))
"a")
(define pl-ip-env-n1b {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "nth1(3, [a,b,c], X)" pl-ip-env-n1b)
(pl-mk-trail))
(pl-ip-test!
"nth1(3, [a,b,c], X) → X=c"
(pl-atom-name (pl-walk-deep (dict-get pl-ip-env-n1b "X")))
"c")
;; ── max/min in arithmetic ──
(define pl-ip-env-m1 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "X is max(3, 5)" pl-ip-env-m1)
(pl-mk-trail))
(pl-ip-test!
"X is max(3, 5) → X=5"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-m1 "X")))
5)
(define pl-ip-env-m2 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "X is min(3, 5)" pl-ip-env-m2)
(pl-mk-trail))
(pl-ip-test!
"X is min(3, 5) → X=3"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-m2 "X")))
3)
(define pl-ip-env-m3 {})
(pl-solve-once!
pl-ip-db
(pl-ip-goal "X is max(7, 2) + min(1, 4)" pl-ip-env-m3)
(pl-mk-trail))
(pl-ip-test!
"X is max(7,2) + min(1,4) → X=8"
(pl-num-val (pl-walk-deep (dict-get pl-ip-env-m3 "X")))
8)
(define pl-iso-predicates-tests-run! (fn () {:failed pl-ip-test-fail :passed pl-ip-test-pass :total pl-ip-test-count :failures pl-ip-test-failures}))

335
lib/prolog/tests/list_predicates.sx
View File

@@ -1,335 +0,0 @@
;; lib/prolog/tests/list_predicates.sx — ==/2, \==/2, flatten/2, numlist/3,
;; atomic_list_concat/2,3, sum_list/2, max_list/2, min_list/2, delete/3
(define pl-lp-test-count 0)
(define pl-lp-test-pass 0)
(define pl-lp-test-fail 0)
(define pl-lp-test-failures (list))
(define
pl-lp-test!
(fn
(name got expected)
(begin
(set! pl-lp-test-count (+ pl-lp-test-count 1))
(if
(= got expected)
(set! pl-lp-test-pass (+ pl-lp-test-pass 1))
(begin
(set! pl-lp-test-fail (+ pl-lp-test-fail 1))
(append!
pl-lp-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-lp-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-lp-db (pl-mk-db))
;; ── ==/2 ───────────────────────────────────────────────────────────
(pl-lp-test!
"==(a, a) succeeds"
(pl-solve-once! pl-lp-db (pl-lp-goal "==(a, a)" {}) (pl-mk-trail))
true)
(pl-lp-test!
"==(a, b) fails"
(pl-solve-once! pl-lp-db (pl-lp-goal "==(a, b)" {}) (pl-mk-trail))
false)
(pl-lp-test!
"==(1, 1) succeeds"
(pl-solve-once! pl-lp-db (pl-lp-goal "==(1, 1)" {}) (pl-mk-trail))
true)
(pl-lp-test!
"==(1, 2) fails"
(pl-solve-once! pl-lp-db (pl-lp-goal "==(1, 2)" {}) (pl-mk-trail))
false)
(pl-lp-test!
"==(f(a,b), f(a,b)) succeeds"
(pl-solve-once!
pl-lp-db
(pl-lp-goal "==(f(a,b), f(a,b))" {})
(pl-mk-trail))
true)
(pl-lp-test!
"==(f(a,b), f(a,c)) fails"
(pl-solve-once!
pl-lp-db
(pl-lp-goal "==(f(a,b), f(a,c))" {})
(pl-mk-trail))
false)
;; unbound var vs atom: fails (different tags)
(pl-lp-test!
"==(X, a) fails (unbound var vs atom)"
(pl-solve-once! pl-lp-db (pl-lp-goal "==(X, a)" {}) (pl-mk-trail))
false)
;; two unbound vars with SAME name in same env share the same runtime var
(define pl-lp-env-same-var {})
(pl-lp-goal "==(X, X)" pl-lp-env-same-var)
(pl-lp-test!
"==(X, X) succeeds (same runtime var)"
(pl-solve-once!
pl-lp-db
(pl-instantiate
(nth (first (pl-parse "g :- ==(X, X).")) 2)
pl-lp-env-same-var)
(pl-mk-trail))
true)
;; ── \==/2 ──────────────────────────────────────────────────────────
(pl-lp-test!
"\\==(a, b) succeeds"
(pl-solve-once! pl-lp-db (pl-lp-goal "\\==(a, b)" {}) (pl-mk-trail))
true)
(pl-lp-test!
"\\==(a, a) fails"
(pl-solve-once! pl-lp-db (pl-lp-goal "\\==(a, a)" {}) (pl-mk-trail))
false)
(pl-lp-test!
"\\==(X, a) succeeds (unbound var differs from atom)"
(pl-solve-once! pl-lp-db (pl-lp-goal "\\==(X, a)" {}) (pl-mk-trail))
true)
(pl-lp-test!
"\\==(1, 2) succeeds"
(pl-solve-once! pl-lp-db (pl-lp-goal "\\==(1, 2)" {}) (pl-mk-trail))
true)
;; ── flatten/2 ──────────────────────────────────────────────────────
(define pl-lp-env-fl1 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "flatten([], F)" pl-lp-env-fl1)
(pl-mk-trail))
(pl-lp-test!
"flatten([], []) -> empty"
(pl-format-term (pl-walk-deep (dict-get pl-lp-env-fl1 "F")))
"[]")
(define pl-lp-env-fl2 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "flatten([1,2,3], F)" pl-lp-env-fl2)
(pl-mk-trail))
(pl-lp-test!
"flatten([1,2,3], F) -> [1,2,3]"
(pl-format-term (pl-walk-deep (dict-get pl-lp-env-fl2 "F")))
".(1, .(2, .(3, [])))")
(define pl-lp-env-fl3 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "flatten([1,[2,[3]],4], F)" pl-lp-env-fl3)
(pl-mk-trail))
(pl-lp-test!
"flatten([1,[2,[3]],4], F) -> [1,2,3,4]"
(pl-format-term (pl-walk-deep (dict-get pl-lp-env-fl3 "F")))
".(1, .(2, .(3, .(4, []))))")
(define pl-lp-env-fl4 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "flatten([[a,b],[c]], F)" pl-lp-env-fl4)
(pl-mk-trail))
(pl-lp-test!
"flatten([[a,b],[c]], F) -> [a,b,c]"
(pl-format-term (pl-walk-deep (dict-get pl-lp-env-fl4 "F")))
".(a, .(b, .(c, [])))")
;; ── numlist/3 ──────────────────────────────────────────────────────
(define pl-lp-env-nl1 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "numlist(1, 5, L)" pl-lp-env-nl1)
(pl-mk-trail))
(pl-lp-test!
"numlist(1,5,L) -> [1,2,3,4,5]"
(pl-format-term (pl-walk-deep (dict-get pl-lp-env-nl1 "L")))
".(1, .(2, .(3, .(4, .(5, [])))))")
(define pl-lp-env-nl2 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "numlist(3, 3, L)" pl-lp-env-nl2)
(pl-mk-trail))
(pl-lp-test!
"numlist(3,3,L) -> [3]"
(pl-format-term (pl-walk-deep (dict-get pl-lp-env-nl2 "L")))
".(3, [])")
(pl-lp-test!
"numlist(5, 3, L) fails (Low > High)"
(pl-solve-once!
pl-lp-db
(pl-lp-goal "numlist(5, 3, L)" {})
(pl-mk-trail))
false)
;; ── atomic_list_concat/2 ───────────────────────────────────────────
(define pl-lp-env-alc1 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "atomic_list_concat([a, b, c], R)" pl-lp-env-alc1)
(pl-mk-trail))
(pl-lp-test!
"atomic_list_concat([a,b,c], R) -> abc"
(pl-atom-name (pl-walk-deep (dict-get pl-lp-env-alc1 "R")))
"abc")
(define pl-lp-env-alc2 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "atomic_list_concat([hello, world], R)" pl-lp-env-alc2)
(pl-mk-trail))
(pl-lp-test!
"atomic_list_concat([hello,world], R) -> helloworld"
(pl-atom-name (pl-walk-deep (dict-get pl-lp-env-alc2 "R")))
"helloworld")
;; ── atomic_list_concat/3 ───────────────────────────────────────────
(define pl-lp-env-alcs1 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "atomic_list_concat([a, b, c], '-', R)" pl-lp-env-alcs1)
(pl-mk-trail))
(pl-lp-test!
"atomic_list_concat([a,b,c], '-', R) -> a-b-c"
(pl-atom-name (pl-walk-deep (dict-get pl-lp-env-alcs1 "R")))
"a-b-c")
(define pl-lp-env-alcs2 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "atomic_list_concat([x], '-', R)" pl-lp-env-alcs2)
(pl-mk-trail))
(pl-lp-test!
"atomic_list_concat([x], '-', R) -> x (single element, no sep)"
(pl-atom-name (pl-walk-deep (dict-get pl-lp-env-alcs2 "R")))
"x")
;; ── sum_list/2 ─────────────────────────────────────────────────────
(define pl-lp-env-sl1 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "sum_list([1,2,3], S)" pl-lp-env-sl1)
(pl-mk-trail))
(pl-lp-test!
"sum_list([1,2,3], S) -> 6"
(pl-num-val (pl-walk-deep (dict-get pl-lp-env-sl1 "S")))
6)
(define pl-lp-env-sl2 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "sum_list([10], S)" pl-lp-env-sl2)
(pl-mk-trail))
(pl-lp-test!
"sum_list([10], S) -> 10"
(pl-num-val (pl-walk-deep (dict-get pl-lp-env-sl2 "S")))
10)
(define pl-lp-env-sl3 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "sum_list([], S)" pl-lp-env-sl3)
(pl-mk-trail))
(pl-lp-test!
"sum_list([], S) -> 0"
(pl-num-val (pl-walk-deep (dict-get pl-lp-env-sl3 "S")))
0)
;; ── max_list/2 ─────────────────────────────────────────────────────
(define pl-lp-env-mx1 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "max_list([3,1,4,1,5,9,2,6], M)" pl-lp-env-mx1)
(pl-mk-trail))
(pl-lp-test!
"max_list([3,1,4,1,5,9,2,6], M) -> 9"
(pl-num-val (pl-walk-deep (dict-get pl-lp-env-mx1 "M")))
9)
(define pl-lp-env-mx2 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "max_list([7], M)" pl-lp-env-mx2)
(pl-mk-trail))
(pl-lp-test!
"max_list([7], M) -> 7"
(pl-num-val (pl-walk-deep (dict-get pl-lp-env-mx2 "M")))
7)
;; ── min_list/2 ─────────────────────────────────────────────────────
(define pl-lp-env-mn1 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "min_list([3,1,4,1,5,9,2,6], M)" pl-lp-env-mn1)
(pl-mk-trail))
(pl-lp-test!
"min_list([3,1,4,1,5,9,2,6], M) -> 1"
(pl-num-val (pl-walk-deep (dict-get pl-lp-env-mn1 "M")))
1)
(define pl-lp-env-mn2 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "min_list([5,2,8], M)" pl-lp-env-mn2)
(pl-mk-trail))
(pl-lp-test!
"min_list([5,2,8], M) -> 2"
(pl-num-val (pl-walk-deep (dict-get pl-lp-env-mn2 "M")))
2)
;; ── delete/3 ───────────────────────────────────────────────────────
(define pl-lp-env-del1 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "delete([1,2,3,2,1], 2, R)" pl-lp-env-del1)
(pl-mk-trail))
(pl-lp-test!
"delete([1,2,3,2,1], 2, R) -> [1,3,1]"
(pl-format-term (pl-walk-deep (dict-get pl-lp-env-del1 "R")))
".(1, .(3, .(1, [])))")
(define pl-lp-env-del2 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "delete([a,b,c], d, R)" pl-lp-env-del2)
(pl-mk-trail))
(pl-lp-test!
"delete([a,b,c], d, R) -> [a,b,c] (nothing deleted)"
(pl-format-term (pl-walk-deep (dict-get pl-lp-env-del2 "R")))
".(a, .(b, .(c, [])))")
(define pl-lp-env-del3 {})
(pl-solve-once!
pl-lp-db
(pl-lp-goal "delete([], x, R)" pl-lp-env-del3)
(pl-mk-trail))
(pl-lp-test!
"delete([], x, R) -> []"
(pl-format-term (pl-walk-deep (dict-get pl-lp-env-del3 "R")))
"[]")
(define pl-list-predicates-tests-run! (fn () {:failed pl-lp-test-fail :passed pl-lp-test-pass :total pl-lp-test-count :failures pl-lp-test-failures}))

197
lib/prolog/tests/meta_call.sx
View File

@@ -1,197 +0,0 @@
;; lib/prolog/tests/meta_call.sx — forall/2, maplist/2, maplist/3, include/3, exclude/3
(define pl-mc-test-count 0)
(define pl-mc-test-pass 0)
(define pl-mc-test-fail 0)
(define pl-mc-test-failures (list))
(define
pl-mc-test!
(fn
(name got expected)
(begin
(set! pl-mc-test-count (+ pl-mc-test-count 1))
(if
(= got expected)
(set! pl-mc-test-pass (+ pl-mc-test-pass 1))
(begin
(set! pl-mc-test-fail (+ pl-mc-test-fail 1))
(append!
pl-mc-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-mc-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define
pl-mc-term-to-sx
(fn
(t)
(cond
((pl-num? t) (pl-num-val t))
((pl-atom? t) (pl-atom-name t))
(else t))))
(define
pl-mc-list-sx
(fn
(t)
(let
((w (pl-walk-deep t)))
(cond
((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list))
((and (pl-compound? w) (= (pl-fun w) "."))
(cons
(pl-mc-term-to-sx (first (pl-args w)))
(pl-mc-list-sx (nth (pl-args w) 1))))
(else (list :not-list))))))
(define pl-mc-db (pl-mk-db))
(pl-db-load!
pl-mc-db
(pl-parse "member(X, [X|_]). member(X, [_|T]) :- member(X, T)."))
(pl-db-load! pl-mc-db (pl-parse "double(X, Y) :- Y is X * 2."))
(pl-db-load! pl-mc-db (pl-parse "even(X) :- 0 is X mod 2."))
;; -- forall/2 --
(pl-mc-test!
"forall(member(X,[2,4,6]), 0 is X mod 2) — all even"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "forall(member(X,[2,4,6]), 0 is X mod 2)" {})
(pl-mk-trail))
true)
(pl-mc-test!
"forall(member(X,[2,3,6]), 0 is X mod 2) — 3 is odd, fails"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "forall(member(X,[2,3,6]), 0 is X mod 2)" {})
(pl-mk-trail))
false)
(pl-mc-test!
"forall(member(_,[]), true) — vacuously true"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "forall(member(_,[]), true)" {})
(pl-mk-trail))
true)
;; -- maplist/2 --
(pl-mc-test!
"maplist(atom, [a,b,c]) — all atoms"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "maplist(atom, [a,b,c])" {})
(pl-mk-trail))
true)
(pl-mc-test!
"maplist(atom, [a,1,c]) — 1 is not atom, fails"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "maplist(atom, [a,1,c])" {})
(pl-mk-trail))
false)
(pl-mc-test!
"maplist(atom, []) — vacuously true"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "maplist(atom, [])" {})
(pl-mk-trail))
true)
;; -- maplist/3 --
(pl-mc-test!
"maplist(double, [1,2,3], [2,4,6]) — deterministic check"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "maplist(double, [1,2,3], [2,4,6])" {})
(pl-mk-trail))
true)
(pl-mc-test!
"maplist(double, [1,2,3], [2,4,7]) — wrong result fails"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "maplist(double, [1,2,3], [2,4,7])" {})
(pl-mk-trail))
false)
(define pl-mc-env-ml3 {:L (pl-mk-rt-var "L")})
(pl-solve-once!
pl-mc-db
(pl-mc-goal "maplist(double, [1,2,3], L)" pl-mc-env-ml3)
(pl-mk-trail))
(pl-mc-test!
"maplist(double, [1,2,3], L) — L bound to [2,4,6]"
(pl-mc-list-sx (dict-get pl-mc-env-ml3 "L"))
(list 2 4 6))
;; -- include/3 --
(pl-mc-test!
"include(even, [1,2,3,4,5,6], [2,4,6])"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "include(even, [1,2,3,4,5,6], [2,4,6])" {})
(pl-mk-trail))
true)
(pl-mc-test!
"include(even, [], [])"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "include(even, [], [])" {})
(pl-mk-trail))
true)
(define pl-mc-env-inc {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-mc-db
(pl-mc-goal "include(even, [1,2,3,4,5,6], R)" pl-mc-env-inc)
(pl-mk-trail))
(pl-mc-test!
"include(even, [1,2,3,4,5,6], R) — R bound to [2,4,6]"
(pl-mc-list-sx (dict-get pl-mc-env-inc "R"))
(list 2 4 6))
;; -- exclude/3 --
(pl-mc-test!
"exclude(even, [1,2,3,4,5,6], [1,3,5])"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "exclude(even, [1,2,3,4,5,6], [1,3,5])" {})
(pl-mk-trail))
true)
(pl-mc-test!
"exclude(even, [], [])"
(pl-solve-once!
pl-mc-db
(pl-mc-goal "exclude(even, [], [])" {})
(pl-mk-trail))
true)
(define pl-mc-env-exc {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-mc-db
(pl-mc-goal "exclude(even, [1,2,3,4,5,6], R)" pl-mc-env-exc)
(pl-mk-trail))
(pl-mc-test!
"exclude(even, [1,2,3,4,5,6], R) — R bound to [1,3,5]"
(pl-mc-list-sx (dict-get pl-mc-env-exc "R"))
(list 1 3 5))
(define pl-meta-call-tests-run! (fn () {:failed pl-mc-test-fail :passed pl-mc-test-pass :total pl-mc-test-count :failures pl-mc-test-failures}))

252
lib/prolog/tests/meta_predicates.sx
View File

@@ -1,252 +0,0 @@
;; lib/prolog/tests/meta_predicates.sx — \+/1, not/1, once/1, ignore/1, ground/1, sort/2, msort/2, atom_number/2, number_string/2
(define pl-mp-test-count 0)
(define pl-mp-test-pass 0)
(define pl-mp-test-fail 0)
(define pl-mp-test-failures (list))
(define
pl-mp-test!
(fn
(name got expected)
(begin
(set! pl-mp-test-count (+ pl-mp-test-count 1))
(if
(= got expected)
(set! pl-mp-test-pass (+ pl-mp-test-pass 1))
(begin
(set! pl-mp-test-fail (+ pl-mp-test-fail 1))
(append!
pl-mp-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-mp-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-mp-db (pl-mk-db))
(pl-db-load!
pl-mp-db
(pl-parse "member(X, [X|_]). member(X, [_|T]) :- member(X, T)."))
;; -- \+/1 --
(pl-mp-test!
"\\+(fail) succeeds"
(pl-solve-once! pl-mp-db (pl-mp-goal "\\+(fail)" {}) (pl-mk-trail))
true)
(pl-mp-test!
"\\+(true) fails"
(pl-solve-once! pl-mp-db (pl-mp-goal "\\+(true)" {}) (pl-mk-trail))
false)
(pl-mp-test!
"\\+(member(d, [a,b,c])) succeeds"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "\\+(member(d, [a,b,c]))" {})
(pl-mk-trail))
true)
(pl-mp-test!
"\\+(member(a, [a,b,c])) fails"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "\\+(member(a, [a,b,c]))" {})
(pl-mk-trail))
false)
(define pl-mp-env-neg {})
(pl-solve-once!
pl-mp-db
(pl-mp-goal "\\+(X = 5)" pl-mp-env-neg)
(pl-mk-trail))
(pl-mp-test!
"\\+(X=5) fails, X stays unbound (bindings undone)"
(nil? (pl-var-binding (dict-get pl-mp-env-neg "X")))
true)
;; -- not/1 --
(pl-mp-test!
"not(fail) succeeds"
(pl-solve-once! pl-mp-db (pl-mp-goal "not(fail)" {}) (pl-mk-trail))
true)
(pl-mp-test!
"not(true) fails"
(pl-solve-once! pl-mp-db (pl-mp-goal "not(true)" {}) (pl-mk-trail))
false)
;; -- once/1 --
(pl-mp-test!
"once(member(X,[1,2,3])) succeeds once"
(pl-solve-count!
pl-mp-db
(pl-mp-goal "once(member(X,[1,2,3]))" {})
(pl-mk-trail))
1)
(define pl-mp-env-once {})
(pl-solve-once!
pl-mp-db
(pl-mp-goal "once(member(X,[1,2,3]))" pl-mp-env-once)
(pl-mk-trail))
(pl-mp-test!
"once(member(X,[1,2,3])): X=1 (first solution)"
(pl-num-val (pl-walk-deep (dict-get pl-mp-env-once "X")))
1)
(pl-mp-test!
"once(fail) fails"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "once(fail)" {})
(pl-mk-trail))
false)
;; -- ignore/1 --
(pl-mp-test!
"ignore(true) succeeds"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "ignore(true)" {})
(pl-mk-trail))
true)
(pl-mp-test!
"ignore(fail) still succeeds"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "ignore(fail)" {})
(pl-mk-trail))
true)
;; -- ground/1 --
(pl-mp-test!
"ground(foo(1, a)) succeeds"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "ground(foo(1, a))" {})
(pl-mk-trail))
true)
(pl-mp-test!
"ground(foo(X, a)) fails (X unbound)"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "ground(foo(X, a))" {})
(pl-mk-trail))
false)
(pl-mp-test!
"ground(42) succeeds"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "ground(42)" {})
(pl-mk-trail))
true)
;; -- sort/2 --
(pl-mp-test!
"sort([b,a,c], [a,b,c])"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "sort([b,a,c], [a,b,c])" {})
(pl-mk-trail))
true)
(pl-mp-test!
"sort([b,a,a,c], [a,b,c]) (removes duplicates)"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "sort([b,a,a,c], [a,b,c])" {})
(pl-mk-trail))
true)
(pl-mp-test!
"sort([], [])"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "sort([], [])" {})
(pl-mk-trail))
true)
;; -- msort/2 --
(pl-mp-test!
"msort([b,a,a,c], [a,a,b,c]) (keeps duplicates)"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "msort([b,a,a,c], [a,a,b,c])" {})
(pl-mk-trail))
true)
(pl-mp-test!
"msort([3,1,2,1], [1,1,2,3])"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "msort([3,1,2,1], [1,1,2,3])" {})
(pl-mk-trail))
true)
;; -- atom_number/2 --
(define pl-mp-env-an1 {})
(pl-solve-once!
pl-mp-db
(pl-mp-goal "atom_number('42', N)" pl-mp-env-an1)
(pl-mk-trail))
(pl-mp-test!
"atom_number('42', N) -> N=42"
(pl-num-val (pl-walk-deep (dict-get pl-mp-env-an1 "N")))
42)
(define pl-mp-env-an2 {})
(pl-solve-once!
pl-mp-db
(pl-mp-goal "atom_number(A, 7)" pl-mp-env-an2)
(pl-mk-trail))
(pl-mp-test!
"atom_number(A, 7) -> A='7'"
(pl-atom-name (pl-walk-deep (dict-get pl-mp-env-an2 "A")))
"7")
(pl-mp-test!
"atom_number(foo, N) fails (not a number)"
(pl-solve-once!
pl-mp-db
(pl-mp-goal "atom_number(foo, N)" {})
(pl-mk-trail))
false)
;; -- number_string/2 --
(define pl-mp-env-ns1 {})
(pl-solve-once!
pl-mp-db
(pl-mp-goal "number_string(42, S)" pl-mp-env-ns1)
(pl-mk-trail))
(pl-mp-test!
"number_string(42, S) -> S='42'"
(pl-atom-name (pl-walk-deep (dict-get pl-mp-env-ns1 "S")))
"42")
(define pl-mp-env-ns2 {})
(pl-solve-once!
pl-mp-db
(pl-mp-goal "number_string(N, '3.14')" pl-mp-env-ns2)
(pl-mk-trail))
(pl-mp-test!
"number_string(N, '3.14') -> N=3.14"
(pl-num-val (pl-walk-deep (dict-get pl-mp-env-ns2 "N")))
3.14)
(define pl-meta-predicates-tests-run! (fn () {:failed pl-mp-test-fail :passed pl-mp-test-pass :total pl-mp-test-count :failures pl-mp-test-failures}))

193
lib/prolog/tests/operators.sx
View File

@@ -1,193 +0,0 @@
;; lib/prolog/tests/operators.sx — operator-table parsing + comparison built-ins.
(define pl-op-test-count 0)
(define pl-op-test-pass 0)
(define pl-op-test-fail 0)
(define pl-op-test-failures (list))
(define
pl-op-test!
(fn
(name got expected)
(begin
(set! pl-op-test-count (+ pl-op-test-count 1))
(if
(= got expected)
(set! pl-op-test-pass (+ pl-op-test-pass 1))
(begin
(set! pl-op-test-fail (+ pl-op-test-fail 1))
(append!
pl-op-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define pl-op-empty-db (pl-mk-db))
(define
pl-op-body
(fn (src) (nth (first (pl-parse (str "g :- " src "."))) 2)))
(define pl-op-goal (fn (src env) (pl-instantiate (pl-op-body src) env)))
;; ── parsing tests ──
(pl-op-test!
"infix +"
(pl-op-body "a + b")
(list "compound" "+" (list (list "atom" "a") (list "atom" "b"))))
(pl-op-test!
"infix * tighter than +"
(pl-op-body "a + b * c")
(list
"compound"
"+"
(list
(list "atom" "a")
(list "compound" "*" (list (list "atom" "b") (list "atom" "c"))))))
(pl-op-test!
"parens override precedence"
(pl-op-body "(a + b) * c")
(list
"compound"
"*"
(list
(list "compound" "+" (list (list "atom" "a") (list "atom" "b")))
(list "atom" "c"))))
(pl-op-test!
"+ is yfx (left-assoc)"
(pl-op-body "a + b + c")
(list
"compound"
"+"
(list
(list "compound" "+" (list (list "atom" "a") (list "atom" "b")))
(list "atom" "c"))))
(pl-op-test!
"; is xfy (right-assoc)"
(pl-op-body "a ; b ; c")
(list
"compound"
";"
(list
(list "atom" "a")
(list "compound" ";" (list (list "atom" "b") (list "atom" "c"))))))
(pl-op-test!
"= folds at 700"
(pl-op-body "X = 5")
(list "compound" "=" (list (list "var" "X") (list "num" 5))))
(pl-op-test!
"is + nests via 700>500>400"
(pl-op-body "X is 2 + 3 * 4")
(list
"compound"
"is"
(list
(list "var" "X")
(list
"compound"
"+"
(list
(list "num" 2)
(list "compound" "*" (list (list "num" 3) (list "num" 4))))))))
(pl-op-test!
"< parses at 700"
(pl-op-body "2 < 3")
(list "compound" "<" (list (list "num" 2) (list "num" 3))))
(pl-op-test!
"mod parses as yfx 400"
(pl-op-body "10 mod 3")
(list "compound" "mod" (list (list "num" 10) (list "num" 3))))
(pl-op-test!
"comma in body folds right-assoc"
(pl-op-body "a, b, c")
(list
"compound"
","
(list
(list "atom" "a")
(list "compound" "," (list (list "atom" "b") (list "atom" "c"))))))
;; ── solver tests via infix ──
(pl-op-test!
"X is 2 + 3 binds X = 5"
(let
((env {}) (trail (pl-mk-trail)))
(begin
(pl-solve-once! pl-op-empty-db (pl-op-goal "X is 2 + 3" env) trail)
(pl-num-val (pl-walk-deep (dict-get env "X")))))
5)
(pl-op-test!
"infix conjunction parses + solves"
(pl-solve-once!
pl-op-empty-db
(pl-op-goal "X = 5, X = 5" {})
(pl-mk-trail))
true)
(pl-op-test!
"infix mismatch fails"
(pl-solve-once!
pl-op-empty-db
(pl-op-goal "X = 5, X = 6" {})
(pl-mk-trail))
false)
(pl-op-test!
"infix disjunction picks left"
(pl-solve-once!
pl-op-empty-db
(pl-op-goal "true ; fail" {})
(pl-mk-trail))
true)
(pl-op-test!
"2 < 5 succeeds"
(pl-solve-once!
pl-op-empty-db
(pl-op-goal "2 < 5" {})
(pl-mk-trail))
true)
(pl-op-test!
"5 < 2 fails"
(pl-solve-once!
pl-op-empty-db
(pl-op-goal "5 < 2" {})
(pl-mk-trail))
false)
(pl-op-test!
"5 >= 5 succeeds"
(pl-solve-once!
pl-op-empty-db
(pl-op-goal "5 >= 5" {})
(pl-mk-trail))
true)
(pl-op-test!
"3 =< 5 succeeds"
(pl-solve-once!
pl-op-empty-db
(pl-op-goal "3 =< 5" {})
(pl-mk-trail))
true)
(pl-op-test!
"infix < with arithmetic both sides"
(pl-solve-once!
pl-op-empty-db
(pl-op-goal "1 + 2 < 2 * 3" {})
(pl-mk-trail))
true)
(define pl-operators-tests-run! (fn () {:failed pl-op-test-fail :passed pl-op-test-pass :total pl-op-test-count :failures pl-op-test-failures}))

5
lib/prolog/tests/programs/append.pl
View File

@@ -1,5 +0,0 @@
%% append/3 — list concatenation, classic Prolog
%% Two clauses: empty-prefix base case + recursive cons-prefix.
%% Bidirectional — works in all modes: build, check, split.
append([], L, L).
append([H|T], L, [H|R]) :- append(T, L, R).

114
lib/prolog/tests/programs/append.sx
View File

@@ -1,114 +0,0 @@
;; lib/prolog/tests/programs/append.sx — append/3 test runner
;;
;; Mirrors the Prolog source in append.pl (embedded as a string here because
;; the SX runtime has no file-read primitive yet).
(define pl-ap-test-count 0)
(define pl-ap-test-pass 0)
(define pl-ap-test-fail 0)
(define pl-ap-test-failures (list))
(define
pl-ap-test!
(fn
(name got expected)
(begin
(set! pl-ap-test-count (+ pl-ap-test-count 1))
(if
(= got expected)
(set! pl-ap-test-pass (+ pl-ap-test-pass 1))
(begin
(set! pl-ap-test-fail (+ pl-ap-test-fail 1))
(append!
pl-ap-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-ap-term-to-sx
(fn
(t)
(cond
((pl-num? t) (pl-num-val t))
((pl-atom? t) (pl-atom-name t))
(true (list :complex)))))
(define
pl-ap-list-walked
(fn
(w)
(cond
((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list))
((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
(cons
(pl-ap-term-to-sx (first (pl-args w)))
(pl-ap-list-walked (nth (pl-args w) 1))))
(true (list :not-list)))))
(define pl-ap-list-to-sx (fn (t) (pl-ap-list-walked (pl-walk-deep t))))
(define
pl-ap-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define
pl-ap-prog-src
"append([], L, L). append([H|T], L, [H|R]) :- append(T, L, R).")
(define pl-ap-db (pl-mk-db))
(pl-db-load! pl-ap-db (pl-parse pl-ap-prog-src))
(define pl-ap-env-1 {})
(define pl-ap-goal-1 (pl-ap-goal "append([], [a, b], X)" pl-ap-env-1))
(pl-solve-once! pl-ap-db pl-ap-goal-1 (pl-mk-trail))
(pl-ap-test!
"append([], [a, b], X) → X = [a, b]"
(pl-ap-list-to-sx (dict-get pl-ap-env-1 "X"))
(list "a" "b"))
(define pl-ap-env-2 {})
(define pl-ap-goal-2 (pl-ap-goal "append([1, 2], [3, 4], X)" pl-ap-env-2))
(pl-solve-once! pl-ap-db pl-ap-goal-2 (pl-mk-trail))
(pl-ap-test!
"append([1, 2], [3, 4], X) → X = [1, 2, 3, 4]"
(pl-ap-list-to-sx (dict-get pl-ap-env-2 "X"))
(list 1 2 3 4))
(pl-ap-test!
"append([1], [2, 3], [1, 2, 3]) succeeds"
(pl-solve-once!
pl-ap-db
(pl-ap-goal "append([1], [2, 3], [1, 2, 3])" {})
(pl-mk-trail))
true)
(pl-ap-test!
"append([1, 2], [3], [1, 2, 4]) fails"
(pl-solve-once!
pl-ap-db
(pl-ap-goal "append([1, 2], [3], [1, 2, 4])" {})
(pl-mk-trail))
false)
(pl-ap-test!
"append(X, Y, [1, 2, 3]) backtracks 4 times"
(pl-solve-count!
pl-ap-db
(pl-ap-goal "append(X, Y, [1, 2, 3])" {})
(pl-mk-trail))
4)
(define pl-ap-env-6 {})
(define pl-ap-goal-6 (pl-ap-goal "append(X, [3], [1, 2, 3])" pl-ap-env-6))
(pl-solve-once! pl-ap-db pl-ap-goal-6 (pl-mk-trail))
(pl-ap-test!
"append(X, [3], [1, 2, 3]) deduces X = [1, 2]"
(pl-ap-list-to-sx (dict-get pl-ap-env-6 "X"))
(list 1 2))
(define pl-append-tests-run! (fn () {:failed pl-ap-test-fail :passed pl-ap-test-pass :total pl-ap-test-count :failures pl-ap-test-failures}))

24
lib/prolog/tests/programs/family.pl
View File

@@ -1,24 +0,0 @@
%% family — facts + transitive ancestor + derived relations.
%% Five-generation tree: tom -> bob -> {ann, pat} -> jim, plus tom's
%% other child liz.
parent(tom, bob).
parent(tom, liz).
parent(bob, ann).
parent(bob, pat).
parent(pat, jim).
male(tom).
male(bob).
male(jim).
male(pat).
female(liz).
female(ann).
father(F, C) :- parent(F, C), male(F).
mother(M, C) :- parent(M, C), female(M).
ancestor(X, Y) :- parent(X, Y).
ancestor(X, Y) :- parent(X, Z), ancestor(Z, Y).
sibling(X, Y) :- parent(P, X), parent(P, Y), \=(X, Y).

116
lib/prolog/tests/programs/family.sx
View File

@@ -1,116 +0,0 @@
;; lib/prolog/tests/programs/family.sx — facts + ancestor + sibling relations.
(define pl-fa-test-count 0)
(define pl-fa-test-pass 0)
(define pl-fa-test-fail 0)
(define pl-fa-test-failures (list))
(define
pl-fa-test!
(fn
(name got expected)
(begin
(set! pl-fa-test-count (+ pl-fa-test-count 1))
(if
(= got expected)
(set! pl-fa-test-pass (+ pl-fa-test-pass 1))
(begin
(set! pl-fa-test-fail (+ pl-fa-test-fail 1))
(append!
pl-fa-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-fa-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define
pl-fa-prog-src
"parent(tom, bob). parent(tom, liz). parent(bob, ann). parent(bob, pat). parent(pat, jim). male(tom). male(bob). male(jim). male(pat). female(liz). female(ann). father(F, C) :- parent(F, C), male(F). mother(M, C) :- parent(M, C), female(M). ancestor(X, Y) :- parent(X, Y). ancestor(X, Y) :- parent(X, Z), ancestor(Z, Y). sibling(X, Y) :- parent(P, X), parent(P, Y), \\=(X, Y).")
(define pl-fa-db (pl-mk-db))
(pl-db-load! pl-fa-db (pl-parse pl-fa-prog-src))
(pl-fa-test!
"parent(tom, bob) is a fact"
(pl-solve-once!
pl-fa-db
(pl-fa-goal "parent(tom, bob)" {})
(pl-mk-trail))
true)
(pl-fa-test!
"parent(tom, ann) — not a direct parent"
(pl-solve-once!
pl-fa-db
(pl-fa-goal "parent(tom, ann)" {})
(pl-mk-trail))
false)
(pl-fa-test!
"5 parent/2 facts in total"
(pl-solve-count!
pl-fa-db
(pl-fa-goal "parent(X, Y)" {})
(pl-mk-trail))
5)
(pl-fa-test!
"ancestor(tom, jim) — three-step transitive"
(pl-solve-once!
pl-fa-db
(pl-fa-goal "ancestor(tom, jim)" {})
(pl-mk-trail))
true)
(pl-fa-test!
"tom has 5 ancestors-of: bob, liz, ann, pat, jim"
(pl-solve-count!
pl-fa-db
(pl-fa-goal "ancestor(tom, X)" {})
(pl-mk-trail))
5)
(pl-fa-test!
"father(bob, ann) succeeds"
(pl-solve-once!
pl-fa-db
(pl-fa-goal "father(bob, ann)" {})
(pl-mk-trail))
true)
(pl-fa-test!
"father(liz, ann) fails (liz is female)"
(pl-solve-once!
pl-fa-db
(pl-fa-goal "father(liz, ann)" {})
(pl-mk-trail))
false)
(pl-fa-test!
"mother(liz, X) fails (liz has no children)"
(pl-solve-once!
pl-fa-db
(pl-fa-goal "mother(liz, X)" {})
(pl-mk-trail))
false)
(pl-fa-test!
"sibling(ann, pat) succeeds"
(pl-solve-once!
pl-fa-db
(pl-fa-goal "sibling(ann, pat)" {})
(pl-mk-trail))
true)
(pl-fa-test!
"sibling(ann, ann) fails by \\="
(pl-solve-once!
pl-fa-db
(pl-fa-goal "sibling(ann, ann)" {})
(pl-mk-trail))
false)
(define pl-family-tests-run! (fn () {:failed pl-fa-test-fail :passed pl-fa-test-pass :total pl-fa-test-count :failures pl-fa-test-failures}))

4
lib/prolog/tests/programs/member.pl
View File

@@ -1,4 +0,0 @@
%% member/2 — list membership.
%% Generates all solutions on backtracking when the element is unbound.
member(X, [X|_]).
member(X, [_|T]) :- member(X, T).

91
lib/prolog/tests/programs/member.sx
View File

@@ -1,91 +0,0 @@
;; lib/prolog/tests/programs/member.sx — member/2 generator.
(define pl-mb-test-count 0)
(define pl-mb-test-pass 0)
(define pl-mb-test-fail 0)
(define pl-mb-test-failures (list))
(define
pl-mb-test!
(fn
(name got expected)
(begin
(set! pl-mb-test-count (+ pl-mb-test-count 1))
(if
(= got expected)
(set! pl-mb-test-pass (+ pl-mb-test-pass 1))
(begin
(set! pl-mb-test-fail (+ pl-mb-test-fail 1))
(append!
pl-mb-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-mb-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-mb-prog-src "member(X, [X|_]). member(X, [_|T]) :- member(X, T).")
(define pl-mb-db (pl-mk-db))
(pl-db-load! pl-mb-db (pl-parse pl-mb-prog-src))
(pl-mb-test!
"member(2, [1, 2, 3]) succeeds"
(pl-solve-once!
pl-mb-db
(pl-mb-goal "member(2, [1, 2, 3])" {})
(pl-mk-trail))
true)
(pl-mb-test!
"member(4, [1, 2, 3]) fails"
(pl-solve-once!
pl-mb-db
(pl-mb-goal "member(4, [1, 2, 3])" {})
(pl-mk-trail))
false)
(pl-mb-test!
"member(X, []) fails"
(pl-solve-once!
pl-mb-db
(pl-mb-goal "member(X, [])" {})
(pl-mk-trail))
false)
(pl-mb-test!
"member(X, [a, b, c]) generates 3 solutions"
(pl-solve-count!
pl-mb-db
(pl-mb-goal "member(X, [a, b, c])" {})
(pl-mk-trail))
3)
(define pl-mb-env-1 {})
(define pl-mb-goal-1 (pl-mb-goal "member(X, [11, 22, 33])" pl-mb-env-1))
(pl-solve-once! pl-mb-db pl-mb-goal-1 (pl-mk-trail))
(pl-mb-test!
"member(X, [11, 22, 33]) first solution X = 11"
(pl-num-val (pl-walk-deep (dict-get pl-mb-env-1 "X")))
11)
(pl-mb-test!
"member(2, [1, 2, 3, 2, 1]) matches twice on backtrack"
(pl-solve-count!
pl-mb-db
(pl-mb-goal "member(2, [1, 2, 3, 2, 1])" {})
(pl-mk-trail))
2)
(pl-mb-test!
"member with unbound list cell unifies"
(pl-solve-once!
pl-mb-db
(pl-mb-goal "member(a, [X, b, c])" {})
(pl-mk-trail))
true)
(define pl-member-tests-run! (fn () {:failed pl-mb-test-fail :passed pl-mb-test-pass :total pl-mb-test-count :failures pl-mb-test-failures}))

27
lib/prolog/tests/programs/nqueens.pl
View File

@@ -1,27 +0,0 @@
%% nqueens — permutation-and-test formulation.
%% Caller passes the row list [1..N]; queens/2 finds N column placements
%% s.t. no two queens attack on a diagonal. Same-column attacks are
%% structurally impossible — Qs is a permutation, all distinct.
%%
%% No `>/2` `</2` `=</2` built-ins yet, so range/3 is omitted; tests pass
%; the literal range list. Once the operator table lands and arithmetic
%% comparison built-ins are in, range/3 can be added.
queens(L, Qs) :- permute(L, Qs), safe(Qs).
permute([], []).
permute(L, [H|T]) :- select(H, L, R), permute(R, T).
select(X, [X|T], T).
select(X, [H|T], [H|R]) :- select(X, T, R).
safe([]).
safe([Q|Qs]) :- safe(Qs), no_attack(Q, Qs, 1).
no_attack(_, [], _).
no_attack(Q, [Q1|Qs], D) :-
is(D2, +(Q, D)),
\=(D2, Q1),
is(D3, -(Q, D)),
\=(D3, Q1),
is(D1, +(D, 1)),
no_attack(Q, Qs, D1).

108
lib/prolog/tests/programs/nqueens.sx
View File

@@ -1,108 +0,0 @@
;; lib/prolog/tests/programs/nqueens.sx — N-queens via permute + safe.
(define pl-nq-test-count 0)
(define pl-nq-test-pass 0)
(define pl-nq-test-fail 0)
(define pl-nq-test-failures (list))
(define
pl-nq-test!
(fn
(name got expected)
(begin
(set! pl-nq-test-count (+ pl-nq-test-count 1))
(if
(= got expected)
(set! pl-nq-test-pass (+ pl-nq-test-pass 1))
(begin
(set! pl-nq-test-fail (+ pl-nq-test-fail 1))
(append!
pl-nq-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-nq-term-to-sx
(fn
(t)
(cond
((pl-num? t) (pl-num-val t))
((pl-atom? t) (pl-atom-name t))
(true (list :complex)))))
(define
pl-nq-list-walked
(fn
(w)
(cond
((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list))
((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
(cons
(pl-nq-term-to-sx (first (pl-args w)))
(pl-nq-list-walked (nth (pl-args w) 1))))
(true (list :not-list)))))
(define pl-nq-list-to-sx (fn (t) (pl-nq-list-walked (pl-walk-deep t))))
(define
pl-nq-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define
pl-nq-prog-src
"queens(L, Qs) :- permute(L, Qs), safe(Qs). permute([], []). permute(L, [H|T]) :- select(H, L, R), permute(R, T). select(X, [X|T], T). select(X, [H|T], [H|R]) :- select(X, T, R). safe([]). safe([Q|Qs]) :- safe(Qs), no_attack(Q, Qs, 1). no_attack(_, [], _). no_attack(Q, [Q1|Qs], D) :- is(D2, +(Q, D)), \\=(D2, Q1), is(D3, -(Q, D)), \\=(D3, Q1), is(D1, +(D, 1)), no_attack(Q, Qs, D1).")
(define pl-nq-db (pl-mk-db))
(pl-db-load! pl-nq-db (pl-parse pl-nq-prog-src))
(pl-nq-test!
"queens([1], Qs) → 1 solution"
(pl-solve-count!
pl-nq-db
(pl-nq-goal "queens([1], Qs)" {})
(pl-mk-trail))
1)
(pl-nq-test!
"queens([1, 2], Qs) → 0 solutions"
(pl-solve-count!
pl-nq-db
(pl-nq-goal "queens([1, 2], Qs)" {})
(pl-mk-trail))
0)
(pl-nq-test!
"queens([1, 2, 3], Qs) → 0 solutions"
(pl-solve-count!
pl-nq-db
(pl-nq-goal "queens([1, 2, 3], Qs)" {})
(pl-mk-trail))
0)
(pl-nq-test!
"queens([1, 2, 3, 4], Qs) → 2 solutions"
(pl-solve-count!
pl-nq-db
(pl-nq-goal "queens([1, 2, 3, 4], Qs)" {})
(pl-mk-trail))
2)
(pl-nq-test!
"queens([1, 2, 3, 4, 5], Qs) → 10 solutions"
(pl-solve-count!
pl-nq-db
(pl-nq-goal "queens([1, 2, 3, 4, 5], Qs)" {})
(pl-mk-trail))
10)
(define pl-nq-env-1 {})
(define pl-nq-goal-1 (pl-nq-goal "queens([1, 2, 3, 4], Qs)" pl-nq-env-1))
(pl-solve-once! pl-nq-db pl-nq-goal-1 (pl-mk-trail))
(pl-nq-test!
"queens([1..4], Qs) first solution = [2, 4, 1, 3]"
(pl-nq-list-to-sx (dict-get pl-nq-env-1 "Qs"))
(list 2 4 1 3))
(define pl-nqueens-tests-run! (fn () {:failed pl-nq-test-fail :passed pl-nq-test-pass :total pl-nq-test-count :failures pl-nq-test-failures}))

7
lib/prolog/tests/programs/reverse.pl
View File

@@ -1,7 +0,0 @@
%% reverse/2 — naive reverse via append/3.
%% Quadratic — accumulates the reversed prefix one append per cons.
reverse([], []).
reverse([H|T], R) :- reverse(T, RT), append(RT, [H], R).
append([], L, L).
append([H|T], L, [H|R]) :- append(T, L, R).

113
lib/prolog/tests/programs/reverse.sx
View File

@@ -1,113 +0,0 @@
;; lib/prolog/tests/programs/reverse.sx — naive reverse/2 via append/3.
;;
;; Mirrors reverse.pl (embedded as a string here).
(define pl-rv-test-count 0)
(define pl-rv-test-pass 0)
(define pl-rv-test-fail 0)
(define pl-rv-test-failures (list))
(define
pl-rv-test!
(fn
(name got expected)
(begin
(set! pl-rv-test-count (+ pl-rv-test-count 1))
(if
(= got expected)
(set! pl-rv-test-pass (+ pl-rv-test-pass 1))
(begin
(set! pl-rv-test-fail (+ pl-rv-test-fail 1))
(append!
pl-rv-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-rv-term-to-sx
(fn
(t)
(cond
((pl-num? t) (pl-num-val t))
((pl-atom? t) (pl-atom-name t))
(true (list :complex)))))
(define
pl-rv-list-walked
(fn
(w)
(cond
((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list))
((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
(cons
(pl-rv-term-to-sx (first (pl-args w)))
(pl-rv-list-walked (nth (pl-args w) 1))))
(true (list :not-list)))))
(define pl-rv-list-to-sx (fn (t) (pl-rv-list-walked (pl-walk-deep t))))
(define
pl-rv-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define
pl-rv-prog-src
"reverse([], []). reverse([H|T], R) :- reverse(T, RT), append(RT, [H], R). append([], L, L). append([H|T], L, [H|R]) :- append(T, L, R).")
(define pl-rv-db (pl-mk-db))
(pl-db-load! pl-rv-db (pl-parse pl-rv-prog-src))
(define pl-rv-env-1 {})
(define pl-rv-goal-1 (pl-rv-goal "reverse([], X)" pl-rv-env-1))
(pl-solve-once! pl-rv-db pl-rv-goal-1 (pl-mk-trail))
(pl-rv-test!
"reverse([], X) → X = []"
(pl-rv-list-to-sx (dict-get pl-rv-env-1 "X"))
(list))
(define pl-rv-env-2 {})
(define pl-rv-goal-2 (pl-rv-goal "reverse([1], X)" pl-rv-env-2))
(pl-solve-once! pl-rv-db pl-rv-goal-2 (pl-mk-trail))
(pl-rv-test!
"reverse([1], X) → X = [1]"
(pl-rv-list-to-sx (dict-get pl-rv-env-2 "X"))
(list 1))
(define pl-rv-env-3 {})
(define pl-rv-goal-3 (pl-rv-goal "reverse([1, 2, 3], X)" pl-rv-env-3))
(pl-solve-once! pl-rv-db pl-rv-goal-3 (pl-mk-trail))
(pl-rv-test!
"reverse([1, 2, 3], X) → X = [3, 2, 1]"
(pl-rv-list-to-sx (dict-get pl-rv-env-3 "X"))
(list 3 2 1))
(define pl-rv-env-4 {})
(define pl-rv-goal-4 (pl-rv-goal "reverse([a, b, c, d], X)" pl-rv-env-4))
(pl-solve-once! pl-rv-db pl-rv-goal-4 (pl-mk-trail))
(pl-rv-test!
"reverse([a, b, c, d], X) → X = [d, c, b, a]"
(pl-rv-list-to-sx (dict-get pl-rv-env-4 "X"))
(list "d" "c" "b" "a"))
(pl-rv-test!
"reverse([1, 2, 3], [3, 2, 1]) succeeds"
(pl-solve-once!
pl-rv-db
(pl-rv-goal "reverse([1, 2, 3], [3, 2, 1])" {})
(pl-mk-trail))
true)
(pl-rv-test!
"reverse([1, 2], [1, 2]) fails"
(pl-solve-once!
pl-rv-db
(pl-rv-goal "reverse([1, 2], [1, 2])" {})
(pl-mk-trail))
false)
(define pl-reverse-tests-run! (fn () {:failed pl-rv-test-fail :passed pl-rv-test-pass :total pl-rv-test-count :failures pl-rv-test-failures}))

127
lib/prolog/tests/query_api.sx
View File

@@ -1,127 +0,0 @@
;; lib/prolog/tests/query_api.sx — tests for pl-load/pl-query-all/pl-query-one/pl-query
(define pl-qa-test-count 0)
(define pl-qa-test-pass 0)
(define pl-qa-test-fail 0)
(define pl-qa-test-failures (list))
(define
pl-qa-test!
(fn
(name got expected)
(begin
(set! pl-qa-test-count (+ pl-qa-test-count 1))
(if
(= got expected)
(set! pl-qa-test-pass (+ pl-qa-test-pass 1))
(begin
(set! pl-qa-test-fail (+ pl-qa-test-fail 1))
(append!
pl-qa-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-qa-src
"parent(tom, bob). parent(tom, liz). parent(bob, ann). ancestor(X, Y) :- parent(X, Y). ancestor(X, Y) :- parent(X, Z), ancestor(Z, Y).")
(define pl-qa-db (pl-load pl-qa-src))
;; ── pl-load ──
(pl-qa-test!
"pl-load returns a usable DB (pl-query-all non-nil)"
(not (nil? pl-qa-db))
true)
;; ── pl-query-all: basic fact lookup ──
(pl-qa-test!
"query-all parent(tom, X): 2 solutions"
(len (pl-query-all pl-qa-db "parent(tom, X)"))
2)
(pl-qa-test!
"query-all parent(tom, X): first solution X=bob"
(dict-get (first (pl-query-all pl-qa-db "parent(tom, X)")) "X")
"bob")
(pl-qa-test!
"query-all parent(tom, X): second solution X=liz"
(dict-get (nth (pl-query-all pl-qa-db "parent(tom, X)") 1) "X")
"liz")
;; ── pl-query-all: no solutions ──
(pl-qa-test!
"query-all no solutions returns empty list"
(pl-query-all pl-qa-db "parent(liz, X)")
(list))
;; ── pl-query-all: boolean query (no vars) ──
(pl-qa-test!
"boolean success: 1 solution (empty dict)"
(len (pl-query-all pl-qa-db "parent(tom, bob)"))
1)
(pl-qa-test!
"boolean success: solution has no bindings"
(empty? (keys (first (pl-query-all pl-qa-db "parent(tom, bob)"))))
true)
(pl-qa-test!
"boolean fail: 0 solutions"
(len (pl-query-all pl-qa-db "parent(bob, tom)"))
0)
;; ── pl-query-all: multi-var ──
(pl-qa-test!
"query-all parent(X, Y): 3 solutions total"
(len (pl-query-all pl-qa-db "parent(X, Y)"))
3)
;; ── pl-query-all: rule-based (ancestor/2) ──
(pl-qa-test!
"query-all ancestor(tom, X): 3 descendants (bob, liz, ann)"
(len (pl-query-all pl-qa-db "ancestor(tom, X)"))
3)
;; ── pl-query-all: built-in in query ──
(pl-qa-test!
"query with is/2 built-in"
(dict-get (first (pl-query-all pl-qa-db "X is 2 + 3")) "X")
"5")
;; ── pl-query-one ──
(pl-qa-test!
"query-one returns first solution"
(dict-get (pl-query-one pl-qa-db "parent(tom, X)") "X")
"bob")
(pl-qa-test!
"query-one returns nil for no solutions"
(pl-query-one pl-qa-db "parent(liz, X)")
nil)
;; ── pl-query convenience ──
(pl-qa-test!
"pl-query convenience: count solutions"
(len (pl-query "likes(alice, bob). likes(alice, carol)." "likes(alice, X)"))
2)
(pl-qa-test!
"pl-query convenience: first solution"
(dict-get (first (pl-query "likes(alice, bob). likes(alice, carol)." "likes(alice, X)")) "X")
"bob")
(pl-qa-test!
"pl-query with empty source (built-ins only)"
(dict-get (first (pl-query "" "X is 6 * 7")) "X")
"42")
(define pl-query-api-tests-run! (fn () {:failed pl-qa-test-fail :passed pl-qa-test-pass :total pl-qa-test-count :failures pl-qa-test-failures}))

195
lib/prolog/tests/set_predicates.sx
View File

@@ -1,195 +0,0 @@
;; lib/prolog/tests/set_predicates.sx — foldl/4, list_to_set/2, intersection/3, subtract/3, union/3
(define pl-sp-test-count 0)
(define pl-sp-test-pass 0)
(define pl-sp-test-fail 0)
(define pl-sp-test-failures (list))
(define
pl-sp-test!
(fn
(name got expected)
(begin
(set! pl-sp-test-count (+ pl-sp-test-count 1))
(if
(= got expected)
(set! pl-sp-test-pass (+ pl-sp-test-pass 1))
(begin
(set! pl-sp-test-fail (+ pl-sp-test-fail 1))
(append!
pl-sp-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-sp-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
;; DB with add/3 for foldl tests
(define pl-sp-db (pl-mk-db))
(pl-db-load! pl-sp-db (pl-parse "add(X, Acc, NAcc) :- NAcc is Acc + X."))
;; ── foldl/4 ────────────────────────────────────────────────────────
(define pl-sp-env-fl1 {:S (pl-mk-rt-var "S")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "foldl(add, [1,2,3,4], 0, S)" pl-sp-env-fl1)
(pl-mk-trail))
(pl-sp-test!
"foldl(add,[1,2,3,4],0,S) -> S=10"
(pl-num-val (pl-walk-deep (dict-get pl-sp-env-fl1 "S")))
10)
(define pl-sp-env-fl2 {:S (pl-mk-rt-var "S")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "foldl(add, [], 5, S)" pl-sp-env-fl2)
(pl-mk-trail))
(pl-sp-test!
"foldl(add,[],5,S) -> S=5"
(pl-num-val (pl-walk-deep (dict-get pl-sp-env-fl2 "S")))
5)
(define pl-sp-env-fl3 {:S (pl-mk-rt-var "S")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "foldl(add, [1,2,3], 0, S)" pl-sp-env-fl3)
(pl-mk-trail))
(pl-sp-test!
"foldl(add,[1,2,3],0,S) -> S=6"
(pl-num-val (pl-walk-deep (dict-get pl-sp-env-fl3 "S")))
6)
;; ── list_to_set/2 ──────────────────────────────────────────────────
(define pl-sp-env-lts1 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "list_to_set([1,2,3,2,1], R)" pl-sp-env-lts1)
(pl-mk-trail))
(pl-sp-test!
"list_to_set([1,2,3,2,1],R) -> [1,2,3]"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-lts1 "R")))
".(1, .(2, .(3, [])))")
(define pl-sp-env-lts2 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "list_to_set([], R)" pl-sp-env-lts2)
(pl-mk-trail))
(pl-sp-test!
"list_to_set([],R) -> []"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-lts2 "R")))
"[]")
(define pl-sp-env-lts3 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "list_to_set([a,b,a,c], R)" pl-sp-env-lts3)
(pl-mk-trail))
(pl-sp-test!
"list_to_set([a,b,a,c],R) -> [a,b,c]"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-lts3 "R")))
".(a, .(b, .(c, [])))")
;; ── intersection/3 ─────────────────────────────────────────────────
(define pl-sp-env-int1 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "intersection([1,2,3,4], [2,4,6], R)" pl-sp-env-int1)
(pl-mk-trail))
(pl-sp-test!
"intersection([1,2,3,4],[2,4,6],R) -> [2,4]"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-int1 "R")))
".(2, .(4, []))")
(define pl-sp-env-int2 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "intersection([1,2,3], [4,5,6], R)" pl-sp-env-int2)
(pl-mk-trail))
(pl-sp-test!
"intersection([1,2,3],[4,5,6],R) -> []"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-int2 "R")))
"[]")
(define pl-sp-env-int3 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "intersection([], [1,2,3], R)" pl-sp-env-int3)
(pl-mk-trail))
(pl-sp-test!
"intersection([],[1,2,3],R) -> []"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-int3 "R")))
"[]")
;; ── subtract/3 ─────────────────────────────────────────────────────
(define pl-sp-env-sub1 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "subtract([1,2,3,4], [2,4], R)" pl-sp-env-sub1)
(pl-mk-trail))
(pl-sp-test!
"subtract([1,2,3,4],[2,4],R) -> [1,3]"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-sub1 "R")))
".(1, .(3, []))")
(define pl-sp-env-sub2 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "subtract([1,2,3], [], R)" pl-sp-env-sub2)
(pl-mk-trail))
(pl-sp-test!
"subtract([1,2,3],[],R) -> [1,2,3]"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-sub2 "R")))
".(1, .(2, .(3, [])))")
(define pl-sp-env-sub3 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "subtract([], [1,2], R)" pl-sp-env-sub3)
(pl-mk-trail))
(pl-sp-test!
"subtract([],[1,2],R) -> []"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-sub3 "R")))
"[]")
;; ── union/3 ────────────────────────────────────────────────────────
(define pl-sp-env-uni1 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "union([1,2,3], [2,3,4], R)" pl-sp-env-uni1)
(pl-mk-trail))
(pl-sp-test!
"union([1,2,3],[2,3,4],R) -> [1,2,3,4]"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-uni1 "R")))
".(1, .(2, .(3, .(4, []))))")
(define pl-sp-env-uni2 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "union([], [1,2], R)" pl-sp-env-uni2)
(pl-mk-trail))
(pl-sp-test!
"union([],[1,2],R) -> [1,2]"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-uni2 "R")))
".(1, .(2, []))")
(define pl-sp-env-uni3 {:R (pl-mk-rt-var "R")})
(pl-solve-once!
pl-sp-db
(pl-sp-goal "union([1,2], [], R)" pl-sp-env-uni3)
(pl-mk-trail))
(pl-sp-test!
"union([1,2],[],R) -> [1,2]"
(pl-format-term (pl-walk-deep (dict-get pl-sp-env-uni3 "R")))
".(1, .(2, []))")
;; ── Runner ─────────────────────────────────────────────────────────
(define pl-set-predicates-tests-run! (fn () {:failed pl-sp-test-fail :passed pl-sp-test-pass :total pl-sp-test-count :failures pl-sp-test-failures}))

618
lib/prolog/tests/solve.sx
View File

@@ -1,618 +0,0 @@
;; lib/prolog/tests/solve.sx — DFS solver unit tests
(define pl-s-test-count 0)
(define pl-s-test-pass 0)
(define pl-s-test-fail 0)
(define pl-s-test-failures (list))
(define
pl-s-test!
(fn
(name got expected)
(begin
(set! pl-s-test-count (+ pl-s-test-count 1))
(if
(= got expected)
(set! pl-s-test-pass (+ pl-s-test-pass 1))
(begin
(set! pl-s-test-fail (+ pl-s-test-fail 1))
(append!
pl-s-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-s-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-s-empty-db (pl-mk-db))
(pl-s-test!
"true succeeds"
(pl-solve-once! pl-s-empty-db (pl-s-goal "true" {}) (pl-mk-trail))
true)
(pl-s-test!
"fail fails"
(pl-solve-once! pl-s-empty-db (pl-s-goal "fail" {}) (pl-mk-trail))
false)
(pl-s-test!
"= identical atoms"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "=(a, a)" {})
(pl-mk-trail))
true)
(pl-s-test!
"= different atoms"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "=(a, b)" {})
(pl-mk-trail))
false)
(pl-s-test!
"= var to atom"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "=(X, foo)" {})
(pl-mk-trail))
true)
(define pl-s-env-bind {})
(define pl-s-trail-bind (pl-mk-trail))
(define pl-s-goal-bind (pl-s-goal "=(X, foo)" pl-s-env-bind))
(pl-solve-once! pl-s-empty-db pl-s-goal-bind pl-s-trail-bind)
(pl-s-test!
"X bound to foo after =(X, foo)"
(pl-atom-name (pl-walk-deep (dict-get pl-s-env-bind "X")))
"foo")
(pl-s-test!
"true , true succeeds"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "true, true" {})
(pl-mk-trail))
true)
(pl-s-test!
"true , fail fails"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "true, fail" {})
(pl-mk-trail))
false)
(pl-s-test!
"consistent X bindings succeed"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "=(X, a), =(X, a)" {})
(pl-mk-trail))
true)
(pl-s-test!
"conflicting X bindings fail"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "=(X, a), =(X, b)" {})
(pl-mk-trail))
false)
(define pl-s-db1 (pl-mk-db))
(pl-db-load!
pl-s-db1
(pl-parse "parent(tom, bob). parent(bob, liz). parent(bob, ann)."))
(pl-s-test!
"fact lookup hit"
(pl-solve-once!
pl-s-db1
(pl-s-goal "parent(tom, bob)" {})
(pl-mk-trail))
true)
(pl-s-test!
"fact lookup miss"
(pl-solve-once!
pl-s-db1
(pl-s-goal "parent(tom, liz)" {})
(pl-mk-trail))
false)
(pl-s-test!
"all parent solutions"
(pl-solve-count!
pl-s-db1
(pl-s-goal "parent(X, Y)" {})
(pl-mk-trail))
3)
(pl-s-test!
"fixed first arg solutions"
(pl-solve-count!
pl-s-db1
(pl-s-goal "parent(bob, Y)" {})
(pl-mk-trail))
2)
(define pl-s-db2 (pl-mk-db))
(pl-db-load!
pl-s-db2
(pl-parse
"parent(tom, bob). parent(bob, ann). ancestor(X, Y) :- parent(X, Y). ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z)."))
(pl-s-test!
"rule direct ancestor"
(pl-solve-once!
pl-s-db2
(pl-s-goal "ancestor(tom, bob)" {})
(pl-mk-trail))
true)
(pl-s-test!
"rule transitive ancestor"
(pl-solve-once!
pl-s-db2
(pl-s-goal "ancestor(tom, ann)" {})
(pl-mk-trail))
true)
(pl-s-test!
"rule no path"
(pl-solve-once!
pl-s-db2
(pl-s-goal "ancestor(ann, tom)" {})
(pl-mk-trail))
false)
(define pl-s-env-undo {})
(define pl-s-trail-undo (pl-mk-trail))
(define pl-s-goal-undo (pl-s-goal "=(X, a), fail" pl-s-env-undo))
(pl-solve-once! pl-s-empty-db pl-s-goal-undo pl-s-trail-undo)
(pl-s-test!
"trail undone after failure leaves X unbound"
(pl-var-bound? (dict-get pl-s-env-undo "X"))
false)
(define pl-s-db-cut1 (pl-mk-db))
(pl-db-load! pl-s-db-cut1 (pl-parse "g :- !. g :- true."))
(pl-s-test!
"bare cut succeeds"
(pl-solve-once! pl-s-db-cut1 (pl-s-goal "g" {}) (pl-mk-trail))
true)
(pl-s-test!
"cut commits to first matching clause"
(pl-solve-count! pl-s-db-cut1 (pl-s-goal "g" {}) (pl-mk-trail))
1)
(define pl-s-db-cut2 (pl-mk-db))
(pl-db-load! pl-s-db-cut2 (pl-parse "a(1). a(2). g(X) :- a(X), !."))
(pl-s-test!
"cut commits to first a solution"
(pl-solve-count! pl-s-db-cut2 (pl-s-goal "g(X)" {}) (pl-mk-trail))
1)
(define pl-s-db-cut3 (pl-mk-db))
(pl-db-load!
pl-s-db-cut3
(pl-parse "a(1). a(2). g(X) :- a(X), !, fail. g(99)."))
(pl-s-test!
"cut then fail blocks alt clauses"
(pl-solve-count! pl-s-db-cut3 (pl-s-goal "g(X)" {}) (pl-mk-trail))
0)
(define pl-s-db-cut4 (pl-mk-db))
(pl-db-load!
pl-s-db-cut4
(pl-parse "a(1). b(10). b(20). g(X, Y) :- a(X), !, b(Y)."))
(pl-s-test!
"post-cut goal backtracks freely"
(pl-solve-count!
pl-s-db-cut4
(pl-s-goal "g(X, Y)" {})
(pl-mk-trail))
2)
(define pl-s-db-cut5 (pl-mk-db))
(pl-db-load!
pl-s-db-cut5
(pl-parse "r(1). r(2). q :- r(X), !. p :- q. p :- true."))
(pl-s-test!
"inner cut does not commit outer predicate"
(pl-solve-count! pl-s-db-cut5 (pl-s-goal "p" {}) (pl-mk-trail))
2)
(pl-s-test!
"\\= different atoms succeeds"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "\\=(a, b)" {})
(pl-mk-trail))
true)
(pl-s-test!
"\\= same atoms fails"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "\\=(a, a)" {})
(pl-mk-trail))
false)
(pl-s-test!
"\\= var-vs-atom would unify so fails"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "\\=(X, a)" {})
(pl-mk-trail))
false)
(define pl-s-env-ne {})
(define pl-s-trail-ne (pl-mk-trail))
(define pl-s-goal-ne (pl-s-goal "\\=(X, a)" pl-s-env-ne))
(pl-solve-once! pl-s-empty-db pl-s-goal-ne pl-s-trail-ne)
(pl-s-test!
"\\= leaves no bindings"
(pl-var-bound? (dict-get pl-s-env-ne "X"))
false)
(pl-s-test!
"; left succeeds"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal ";(true, fail)" {})
(pl-mk-trail))
true)
(pl-s-test!
"; right succeeds when left fails"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal ";(fail, true)" {})
(pl-mk-trail))
true)
(pl-s-test!
"; both fail"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal ";(fail, fail)" {})
(pl-mk-trail))
false)
(pl-s-test!
"; both branches counted"
(pl-solve-count!
pl-s-empty-db
(pl-s-goal ";(true, true)" {})
(pl-mk-trail))
2)
(define pl-s-db-call (pl-mk-db))
(pl-db-load! pl-s-db-call (pl-parse "p(1). p(2)."))
(pl-s-test!
"call(true) succeeds"
(pl-solve-once!
pl-s-db-call
(pl-s-goal "call(true)" {})
(pl-mk-trail))
true)
(pl-s-test!
"call(p(X)) yields all solutions"
(pl-solve-count!
pl-s-db-call
(pl-s-goal "call(p(X))" {})
(pl-mk-trail))
2)
(pl-s-test!
"call of bound goal var resolves"
(pl-solve-once!
pl-s-db-call
(pl-s-goal "=(G, true), call(G)" {})
(pl-mk-trail))
true)
(define pl-s-db-ite (pl-mk-db))
(pl-db-load! pl-s-db-ite (pl-parse "p(1). p(2). q(yes). q(no)."))
(pl-s-test!
"if-then-else: cond true → then runs"
(pl-solve-once!
pl-s-db-ite
(pl-s-goal ";(->(true, =(X, ok)), =(X, fallback))" {})
(pl-mk-trail))
true)
(define pl-s-env-ite1 {})
(pl-solve-once!
pl-s-db-ite
(pl-s-goal ";(->(true, =(X, ok)), =(X, fallback))" pl-s-env-ite1)
(pl-mk-trail))
(pl-s-test!
"if-then-else: cond true binds via then"
(pl-atom-name (pl-walk-deep (dict-get pl-s-env-ite1 "X")))
"ok")
(pl-s-test!
"if-then-else: cond false → else"
(pl-solve-once!
pl-s-db-ite
(pl-s-goal ";(->(fail, =(X, ok)), =(X, fallback))" {})
(pl-mk-trail))
true)
(define pl-s-env-ite2 {})
(pl-solve-once!
pl-s-db-ite
(pl-s-goal ";(->(fail, =(X, ok)), =(X, fallback))" pl-s-env-ite2)
(pl-mk-trail))
(pl-s-test!
"if-then-else: cond false binds via else"
(pl-atom-name (pl-walk-deep (dict-get pl-s-env-ite2 "X")))
"fallback")
(pl-s-test!
"if-then-else: cond commits to first solution (count = 1)"
(pl-solve-count!
pl-s-db-ite
(pl-s-goal ";(->(p(X), =(Y, found)), =(Y, none))" {})
(pl-mk-trail))
1)
(pl-s-test!
"if-then-else: then can backtrack"
(pl-solve-count!
pl-s-db-ite
(pl-s-goal ";(->(true, p(X)), =(X, none))" {})
(pl-mk-trail))
2)
(pl-s-test!
"if-then-else: else can backtrack"
(pl-solve-count!
pl-s-db-ite
(pl-s-goal ";(->(fail, =(X, ignored)), p(X))" {})
(pl-mk-trail))
2)
(pl-s-test!
"standalone -> with true cond succeeds"
(pl-solve-once!
pl-s-db-ite
(pl-s-goal "->(true, =(X, hi))" {})
(pl-mk-trail))
true)
(pl-s-test!
"standalone -> with false cond fails"
(pl-solve-once!
pl-s-db-ite
(pl-s-goal "->(fail, =(X, hi))" {})
(pl-mk-trail))
false)
(pl-s-test!
"write(hello)"
(begin
(pl-output-clear!)
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "write(hello)" {})
(pl-mk-trail))
pl-output-buffer)
"hello")
(pl-s-test!
"nl outputs newline"
(begin
(pl-output-clear!)
(pl-solve-once! pl-s-empty-db (pl-s-goal "nl" {}) (pl-mk-trail))
pl-output-buffer)
"\n")
(pl-s-test!
"write(42) outputs digits"
(begin
(pl-output-clear!)
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "write(42)" {})
(pl-mk-trail))
pl-output-buffer)
"42")
(pl-s-test!
"write(foo(a, b)) formats compound"
(begin
(pl-output-clear!)
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "write(foo(a, b))" {})
(pl-mk-trail))
pl-output-buffer)
"foo(a, b)")
(pl-s-test!
"write conjunction"
(begin
(pl-output-clear!)
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "write(a), write(b)" {})
(pl-mk-trail))
pl-output-buffer)
"ab")
(pl-s-test!
"write of bound var walks binding"
(begin
(pl-output-clear!)
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "=(X, hello), write(X)" {})
(pl-mk-trail))
pl-output-buffer)
"hello")
(pl-s-test!
"write then nl"
(begin
(pl-output-clear!)
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "write(hi), nl" {})
(pl-mk-trail))
pl-output-buffer)
"hi\n")
(define pl-s-env-arith1 {})
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(X, 42)" pl-s-env-arith1)
(pl-mk-trail))
(pl-s-test!
"is(X, 42) binds X to 42"
(pl-num-val (pl-walk-deep (dict-get pl-s-env-arith1 "X")))
42)
(define pl-s-env-arith2 {})
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(X, +(2, 3))" pl-s-env-arith2)
(pl-mk-trail))
(pl-s-test!
"is(X, +(2, 3)) binds X to 5"
(pl-num-val (pl-walk-deep (dict-get pl-s-env-arith2 "X")))
5)
(define pl-s-env-arith3 {})
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(X, *(2, 3))" pl-s-env-arith3)
(pl-mk-trail))
(pl-s-test!
"is(X, *(2, 3)) binds X to 6"
(pl-num-val (pl-walk-deep (dict-get pl-s-env-arith3 "X")))
6)
(define pl-s-env-arith4 {})
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(X, -(10, 3))" pl-s-env-arith4)
(pl-mk-trail))
(pl-s-test!
"is(X, -(10, 3)) binds X to 7"
(pl-num-val (pl-walk-deep (dict-get pl-s-env-arith4 "X")))
7)
(define pl-s-env-arith5 {})
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(X, /(10, 2))" pl-s-env-arith5)
(pl-mk-trail))
(pl-s-test!
"is(X, /(10, 2)) binds X to 5"
(pl-num-val (pl-walk-deep (dict-get pl-s-env-arith5 "X")))
5)
(define pl-s-env-arith6 {})
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(X, mod(10, 3))" pl-s-env-arith6)
(pl-mk-trail))
(pl-s-test!
"is(X, mod(10, 3)) binds X to 1"
(pl-num-val (pl-walk-deep (dict-get pl-s-env-arith6 "X")))
1)
(define pl-s-env-arith7 {})
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(X, abs(-(0, 5)))" pl-s-env-arith7)
(pl-mk-trail))
(pl-s-test!
"is(X, abs(-(0, 5))) binds X to 5"
(pl-num-val (pl-walk-deep (dict-get pl-s-env-arith7 "X")))
5)
(define pl-s-env-arith8 {})
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(X, +(2, *(3, 4)))" pl-s-env-arith8)
(pl-mk-trail))
(pl-s-test!
"is(X, +(2, *(3, 4))) binds X to 14 (nested)"
(pl-num-val (pl-walk-deep (dict-get pl-s-env-arith8 "X")))
14)
(pl-s-test!
"is(5, +(2, 3)) succeeds (LHS num matches)"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(5, +(2, 3))" {})
(pl-mk-trail))
true)
(pl-s-test!
"is(6, +(2, 3)) fails (LHS num mismatch)"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "is(6, +(2, 3))" {})
(pl-mk-trail))
false)
(pl-s-test!
"is propagates bound vars on RHS"
(pl-solve-once!
pl-s-empty-db
(pl-s-goal "=(Y, 4), is(X, +(Y, 1)), =(X, 5)" {})
(pl-mk-trail))
true)
(define pl-solve-tests-run! (fn () {:failed pl-s-test-fail :passed pl-s-test-pass :total pl-s-test-count :failures pl-s-test-failures}))

273
lib/prolog/tests/string_agg.sx
View File

@@ -1,273 +0,0 @@
;; lib/prolog/tests/string_agg.sx -- sub_atom/5 + aggregate_all/3
(define pl-sa-test-count 0)
(define pl-sa-test-pass 0)
(define pl-sa-test-fail 0)
(define pl-sa-test-failures (list))
(define
pl-sa-test!
(fn
(name got expected)
(begin
(set! pl-sa-test-count (+ pl-sa-test-count 1))
(if
(= got expected)
(set! pl-sa-test-pass (+ pl-sa-test-pass 1))
(begin
(set! pl-sa-test-fail (+ pl-sa-test-fail 1))
(append!
pl-sa-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-sa-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-sa-db (pl-mk-db))
(define
pl-sa-num-val
(fn (env key) (pl-num-val (pl-walk-deep (dict-get env key)))))
(define
pl-sa-list-to-atoms
(fn
(t)
(let
((w (pl-walk-deep t)))
(cond
((and (pl-atom? w) (= (pl-atom-name w) "[]")) (list))
((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
(cons
(pl-atom-name (first (pl-args w)))
(pl-sa-list-to-atoms (nth (pl-args w) 1))))
(true (list))))))
(define pl-sa-prog-src "member(X, [X|_]). member(X, [_|T]) :- member(X, T).")
(pl-db-load! pl-sa-db (pl-parse pl-sa-prog-src))
;; -- sub_atom/5 --
(pl-sa-test!
"sub_atom ground: sub_atom(abcde,0,3,2,abc)"
(pl-solve-once!
pl-sa-db
(pl-sa-goal "sub_atom(abcde, 0, 3, 2, abc)" {})
(pl-mk-trail))
true)
(pl-sa-test!
"sub_atom ground: sub_atom(abcde,2,2,1,cd)"
(pl-solve-once!
pl-sa-db
(pl-sa-goal "sub_atom(abcde, 2, 2, 1, cd)" {})
(pl-mk-trail))
true)
(pl-sa-test!
"sub_atom ground mismatch fails"
(pl-solve-once!
pl-sa-db
(pl-sa-goal "sub_atom(abcde, 0, 2, 3, cd)" {})
(pl-mk-trail))
false)
(pl-sa-test!
"sub_atom empty sub at start"
(pl-solve-once!
pl-sa-db
(pl-sa-goal "sub_atom(abcde, 0, 0, 5, '')" {})
(pl-mk-trail))
true)
(pl-sa-test!
"sub_atom whole string"
(pl-solve-once!
pl-sa-db
(pl-sa-goal "sub_atom(hello, 0, 5, 0, hello)" {})
(pl-mk-trail))
true)
(define pl-sa-env-b1 {})
(pl-solve-once!
pl-sa-db
(pl-sa-goal "sub_atom(abcde, B, 2, A, cd)" pl-sa-env-b1)
(pl-mk-trail))
(pl-sa-test!
"sub_atom bound SubAtom gives B=2"
(pl-sa-num-val pl-sa-env-b1 "B")
2)
(pl-sa-test!
"sub_atom bound SubAtom gives A=1"
(pl-sa-num-val pl-sa-env-b1 "A")
1)
(define pl-sa-env-b2 {})
(pl-solve-once!
pl-sa-db
(pl-sa-goal "sub_atom(hello, B, L, A, ello)" pl-sa-env-b2)
(pl-mk-trail))
(pl-sa-test! "sub_atom ello: B=1" (pl-sa-num-val pl-sa-env-b2 "B") 1)
(pl-sa-test! "sub_atom ello: L=4" (pl-sa-num-val pl-sa-env-b2 "L") 4)
(pl-sa-test! "sub_atom ello: A=0" (pl-sa-num-val pl-sa-env-b2 "A") 0)
(pl-sa-test!
"sub_atom ab: 6 total solutions"
(let
((env {}))
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(count, sub_atom(ab, _, _, _, _), N)" env)
(pl-mk-trail))
(pl-sa-num-val env "N"))
6)
(pl-sa-test!
"sub_atom a: 3 total solutions"
(let
((env {}))
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(count, sub_atom(a, _, _, _, _), N)" env)
(pl-mk-trail))
(pl-sa-num-val env "N"))
3)
;; -- aggregate_all/3 --
(pl-sa-test!
"aggregate_all count member [a,b,c] = 3"
(let
((env {}))
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(count, member(_, [a,b,c]), N)" env)
(pl-mk-trail))
(pl-sa-num-val env "N"))
3)
(pl-sa-test!
"aggregate_all count fail = 0"
(let
((env {}))
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(count, fail, N)" env)
(pl-mk-trail))
(pl-sa-num-val env "N"))
0)
(pl-sa-test!
"aggregate_all count always succeeds"
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(count, fail, _)" {})
(pl-mk-trail))
true)
(define pl-sa-env-bag1 {})
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(bag(X), member(X, [a,b,c]), L)" pl-sa-env-bag1)
(pl-mk-trail))
(pl-sa-test!
"aggregate_all bag [a,b,c]"
(pl-sa-list-to-atoms (dict-get pl-sa-env-bag1 "L"))
(list "a" "b" "c"))
(define pl-sa-env-bag2 {})
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(bag(X), member(X, []), L)" pl-sa-env-bag2)
(pl-mk-trail))
(pl-sa-test!
"aggregate_all bag empty goal = []"
(pl-sa-list-to-atoms (dict-get pl-sa-env-bag2 "L"))
(list))
(pl-sa-test!
"aggregate_all sum [1,2,3,4] = 10"
(let
((env {}))
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(sum(X), member(X, [1,2,3,4]), S)" env)
(pl-mk-trail))
(pl-sa-num-val env "S"))
10)
(pl-sa-test!
"aggregate_all max [3,1,4,1,5,9,2,6] = 9"
(let
((env {}))
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(max(X), member(X, [3,1,4,1,5,9,2,6]), M)" env)
(pl-mk-trail))
(pl-sa-num-val env "M"))
9)
(pl-sa-test!
"aggregate_all max empty fails"
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(max(X), member(X, []), M)" {})
(pl-mk-trail))
false)
(pl-sa-test!
"aggregate_all min [3,1,4,1,5,9,2,6] = 1"
(let
((env {}))
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(min(X), member(X, [3,1,4,1,5,9,2,6]), M)" env)
(pl-mk-trail))
(pl-sa-num-val env "M"))
1)
(pl-sa-test!
"aggregate_all min empty fails"
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(min(X), member(X, []), M)" {})
(pl-mk-trail))
false)
(define pl-sa-env-set1 {})
(pl-solve-once!
pl-sa-db
(pl-sa-goal
"aggregate_all(set(X), member(X, [b,a,c,a,b]), S)"
pl-sa-env-set1)
(pl-mk-trail))
(pl-sa-test!
"aggregate_all set [b,a,c,a,b] = [a,b,c]"
(pl-sa-list-to-atoms (dict-get pl-sa-env-set1 "S"))
(list "a" "b" "c"))
(define pl-sa-env-set2 {})
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(set(X), fail, S)" pl-sa-env-set2)
(pl-mk-trail))
(pl-sa-test!
"aggregate_all set fail = []"
(pl-sa-list-to-atoms (dict-get pl-sa-env-set2 "S"))
(list))
(pl-sa-test!
"aggregate_all sum empty = 0"
(let
((env {}))
(pl-solve-once!
pl-sa-db
(pl-sa-goal "aggregate_all(sum(X), fail, S)" env)
(pl-mk-trail))
(pl-sa-num-val env "S"))
0)
(define pl-string-agg-tests-run! (fn () {:failed pl-sa-test-fail :passed pl-sa-test-pass :total pl-sa-test-count :failures pl-sa-test-failures}))

147
lib/prolog/tests/term_inspect.sx
View File

@@ -1,147 +0,0 @@
;; lib/prolog/tests/term_inspect.sx — copy_term/2, functor/3, arg/3.
(define pl-tt-test-count 0)
(define pl-tt-test-pass 0)
(define pl-tt-test-fail 0)
(define pl-tt-test-failures (list))
(define
pl-tt-test!
(fn
(name got expected)
(begin
(set! pl-tt-test-count (+ pl-tt-test-count 1))
(if
(= got expected)
(set! pl-tt-test-pass (+ pl-tt-test-pass 1))
(begin
(set! pl-tt-test-fail (+ pl-tt-test-fail 1))
(append!
pl-tt-test-failures
(str name "\n expected: " expected "\n got: " got)))))))
(define
pl-tt-goal
(fn
(src env)
(pl-instantiate (nth (first (pl-parse (str "g :- " src "."))) 2) env)))
(define pl-tt-db (pl-mk-db))
;; ── copy_term/2 ──
(pl-tt-test!
"copy_term ground compound succeeds + copy = original"
(pl-solve-once!
pl-tt-db
(pl-tt-goal "copy_term(foo(a, b), X), X = foo(a, b)" {})
(pl-mk-trail))
true)
(pl-tt-test!
"copy_term preserves var aliasing in source"
(pl-solve-once!
pl-tt-db
(pl-tt-goal "copy_term(p(Y, Y), p(A, B)), A = 5, B = 5" {})
(pl-mk-trail))
true)
(pl-tt-test!
"copy_term distinct vars stay distinct"
(pl-solve-once!
pl-tt-db
(pl-tt-goal "copy_term(p(Y, Y), p(A, B)), A = 5, B = 6" {})
(pl-mk-trail))
false)
(define pl-tt-env-1 {})
(pl-solve-once!
pl-tt-db
(pl-tt-goal "copy_term(X, Y), Y = 5" pl-tt-env-1)
(pl-mk-trail))
(pl-tt-test!
"copy_term: binding the copy doesn't bind the source"
(pl-var-bound? (dict-get pl-tt-env-1 "X"))
false)
;; ── functor/3 ──
(define pl-tt-env-2 {})
(pl-solve-once!
pl-tt-db
(pl-tt-goal "functor(foo(a, b, c), F, N)" pl-tt-env-2)
(pl-mk-trail))
(pl-tt-test!
"functor of compound: F = foo"
(pl-atom-name (pl-walk-deep (dict-get pl-tt-env-2 "F")))
"foo")
(pl-tt-test!
"functor of compound: N = 3"
(pl-num-val (pl-walk-deep (dict-get pl-tt-env-2 "N")))
3)
(define pl-tt-env-3 {})
(pl-solve-once!
pl-tt-db
(pl-tt-goal "functor(hello, F, N)" pl-tt-env-3)
(pl-mk-trail))
(pl-tt-test!
"functor of atom: F = hello"
(pl-atom-name (pl-walk-deep (dict-get pl-tt-env-3 "F")))
"hello")
(pl-tt-test!
"functor of atom: N = 0"
(pl-num-val (pl-walk-deep (dict-get pl-tt-env-3 "N")))
0)
(pl-tt-test!
"functor construct compound: T unifies with foo(a, b)"
(pl-solve-once!
pl-tt-db
(pl-tt-goal "functor(T, foo, 2), T = foo(a, b)" {})
(pl-mk-trail))
true)
(pl-tt-test!
"functor construct atom: T = hello"
(pl-solve-once!
pl-tt-db
(pl-tt-goal "functor(T, hello, 0), T = hello" {})
(pl-mk-trail))
true)
;; ── arg/3 ──
(pl-tt-test!
"arg(1, foo(a, b, c), a)"
(pl-solve-once!
pl-tt-db
(pl-tt-goal "arg(1, foo(a, b, c), a)" {})
(pl-mk-trail))
true)
(pl-tt-test!
"arg(2, foo(a, b, c), X) → X = b"
(pl-solve-once!
pl-tt-db
(pl-tt-goal "arg(2, foo(a, b, c), X), X = b" {})
(pl-mk-trail))
true)
(pl-tt-test!
"arg out-of-range high fails"
(pl-solve-once!
pl-tt-db
(pl-tt-goal "arg(4, foo(a, b, c), X)" {})
(pl-mk-trail))
false)
(pl-tt-test!
"arg(0, ...) fails (1-indexed)"
(pl-solve-once!
pl-tt-db
(pl-tt-goal "arg(0, foo(a), X)" {})
(pl-mk-trail))
false)
(define pl-term-inspect-tests-run! (fn () {:failed pl-tt-test-fail :passed pl-tt-test-pass :total pl-tt-test-count :failures pl-tt-test-failures}))

4
plans/agent-briefings/common-lisp-loop.md
View File

@@ -11,7 +11,7 @@ isolation: worktree
## Prompt
You are the sole background agent working `/root/rose-ash/plans/common-lisp-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push.
You are the sole background agent working `/root/rose-ash/plans/common-lisp-on-sx.md`. Isolated worktree, forever, one commit per feature. Push to `origin/loops/common-lisp` after every commit.
## Restart baseline — check before iterating
@@ -42,7 +42,7 @@ Every iteration: implement → test → commit → tick `[ ]` → Progress log
- **Shared-file issues** → plan's Blockers with minimal repro.
- **Delimited continuations** are in `lib/callcc.sx` + `spec/evaluator.sx` Step 5. `sx_summarise` spec/evaluator.sx first — 2300+ lines.
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
- **Worktree:** commit locally. Never push. Never touch `main`.
- **Worktree:** commit, then push to `origin/loops/common-lisp`. Never touch `main`.
- **Commit granularity:** one feature per commit.
- **Plan file:** update Progress log + tick boxes every commit.

7
plans/agent-briefings/prolog-loop.md
View File

@@ -11,7 +11,7 @@ isolation: worktree
## Prompt
You are the sole background agent working `/root/rose-ash/plans/prolog-on-sx.md`. You run in an isolated git worktree. You work the plan's roadmap forever, one commit per feature. Push to `origin/loops/prolog` after every commit.
You are the sole background agent working `/root/rose-ash/plans/prolog-on-sx.md`. You run in an isolated git worktree. You work the plan's roadmap forever, one commit per feature. You never push.
## Restart baseline — check before iterating
@@ -39,13 +39,12 @@ Every iteration: implement → test → commit → tick `[ ]` in plan → append
## Ground rules (hard)
- **Scope:** only `lib/prolog/**` and `plans/prolog-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib/<lang>/` dirs, `lib/stdlib.sx`, or `lib/` root. Prolog primitives go in `lib/prolog/runtime.sx`. You may **read** `lib/hyperscript/runtime.sx` to understand the hook API but do not edit it — `hs-set-prolog-hook!` is already implemented there.
- **Hyperscript bridge is NOT blocked:** `lib/prolog/hs-bridge.sx` already exists and `lib/hyperscript/runtime.sx` already exports `hs-set-prolog-hook!` / `hs-prolog-hook`. The Phase 5 DSL item just needs tests and wiring.
- **Scope:** only `lib/prolog/**` and `plans/prolog-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib/<lang>/` dirs, `lib/stdlib.sx`, or `lib/` root. Prolog primitives go in `lib/prolog/runtime.sx`.
- **NEVER call `sx_build`.** 600s watchdog will kill you before OCaml finishes. If sx_server binary is broken, add Blockers entry and stop.
- **Shared-file issues** → plan's Blockers section with a minimal repro. Don't fix them.
- **Delimited continuations** are in `lib/callcc.sx` + `spec/evaluator.sx` Step 5 (IO suspension via `perform`/`cek-resume`). `sx_summarise` spec/evaluator.sx first — it's 2300+ lines.
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits. Never `Edit`/`Read`/`Write` on `.sx`.
- **Worktree:** commit, then push to `origin/loops/prolog`. Never touch `main`.
- **Worktree:** commit locally. Never push. Never touch `main`.
- **Commit granularity:** one feature per commit.
- **Plan file:** update Progress log + tick boxes every commit.
- **If blocked** for two iterations on the same issue, add to Blockers and move on.

145
plans/datalog-on-sx.md
View File

@@ -1,145 +0,0 @@
# Datalog-on-SX: Datalog on the CEK/VM
Datalog is a declarative query language: a restricted subset of Prolog with no function
symbols, only relations. Programs are sets of facts and rules; queries ask what follows.
Evaluation is bottom-up (fixpoint iteration) rather than Prolog's top-down DFS — which
means no infinite loops, guaranteed termination, and efficient incremental updates.
The unique angle: Datalog is a natural companion to the Prolog implementation already in
progress (`lib/prolog/`). The parser and term representation can share infrastructure;
the evaluator is an entirely different fixpoint engine rather than a DFS solver.
End-state goal: **full core Datalog** (facts, rules, stratified negation, aggregation,
recursion) with a clean SX query API, and a demonstration of Datalog as a query engine
for rose-ash data (e.g. federation graph, content relationships).
## Ground rules
- **Scope:** only touch `lib/datalog/**` and `plans/datalog-on-sx.md`. Do **not** edit
`spec/`, `hosts/`, `shared/`, `lib/prolog/**`, or other `lib/<lang>/`.
- **Shared-file issues** go under "Blockers" below with a minimal repro; do not fix here.
- **SX files:** use `sx-tree` MCP tools only.
- **Architecture:** Datalog source → term AST → fixpoint evaluator. No transpiler to SX AST —
the evaluator is written in SX and works directly on term structures.
- **Reference:** Ramakrishnan & Ullman "A Survey of Deductive Database Systems";
Dalmau "Datalog and Constraint Satisfaction".
- **Commits:** one feature per commit. Keep `## Progress log` updated and tick boxes.
## Architecture sketch
```
Datalog source text
│
▼
lib/datalog/tokenizer.sx — atoms, variables, numbers, strings, punct (?- :- , . ( ) [ ])
│
▼
lib/datalog/parser.sx — facts: atom(args). rules: head :- body. queries: ?- goal.
│ No function symbols (only constants and variables in args).
▼
lib/datalog/db.sx — extensional DB (EDB): ground facts; IDB: derived relations;
│ clause index by relation name/arity
▼
lib/datalog/eval.sx — bottom-up fixpoint: semi-naive evaluation with delta sets;
│ stratification for negation; incremental update API
▼
lib/datalog/query.sx — query API: (datalog-query db goal) → list of substitutions;
SX embedding: define facts/rules as SX data directly
```
Key differences from Prolog:
- **No function symbols** — args are atoms, numbers, strings, or variables only. No `f(a,b)`.
- **No cuts** — no procedural control.
- **Bottom-up** — derive all consequences of all rules before answering; no search tree.
- **Termination guaranteed** — no infinite derivation chains (no function symbols → finite Herbrand base).
- **Stratified negation** — `not(P)` legal iff P does not recursively depend on its own negation.
- **Aggregation** — `count`, `sum`, `min`, `max` over derived tuples (Datalog+).
## Roadmap
### Phase 1 — tokenizer + parser
- [ ] Tokenizer: atoms (lowercase/quoted), variables (uppercase/`_`), numbers, strings,
operators (`:- `, `?-`, `,`, `.`), comments (`%`, `/* */`)
Note: no function symbol syntax (no nested `f(...)` in arg position).
- [ ] Parser:
- Facts: `parent(tom, bob).` → `{:head (parent tom bob) :body ()}`
- Rules: `ancestor(X,Z) :- parent(X,Y), ancestor(Y,Z).`
→ `{:head (ancestor X Z) :body ((parent X Y) (ancestor Y Z))}`
- Queries: `?- ancestor(tom, X).` → `{:query (ancestor tom X)}`
- Negation: `not(parent(X,Y))` in body position → `{:neg (parent X Y)}`
- [ ] Tests in `lib/datalog/tests/parse.sx`
### Phase 2 — unification + substitution
- [ ] Share or port unification from `lib/prolog/` — term walk, occurs check off by default
- [ ] `dl-unify` `t1` `t2` `subst` → extended subst or nil (no function symbols means simpler)
- [ ] `dl-ground?` `term` → bool — all variables bound in substitution
- [ ] Tests: atom/atom, var/atom, var/var, list args
### Phase 3 — extensional DB + naive evaluation
- [ ] EDB: `{:relation-name → set-of-ground-tuples}` using SX sets (Phase 18 of primitives)
- [ ] `dl-add-fact!` `db` `relation` `args` → add ground tuple
- [ ] `dl-add-rule!` `db` `head` `body` → add rule clause
- [ ] Naive evaluation: iterate rules until fixpoint
For each rule, for each combination of body tuples that unify, derive head tuple.
Repeat until no new tuples added.
- [ ] `dl-query` `db` `goal` → list of substitutions satisfying goal against derived DB
- [ ] Tests: transitive closure (ancestor), sibling, same-generation — classic Datalog programs
### Phase 4 — semi-naive evaluation (performance)
- [ ] Delta sets: track newly derived tuples per iteration
- [ ] Semi-naive rule: only join against delta tuples from last iteration, not full relation
- [ ] Significant speedup for recursive rules — avoids re-deriving known tuples
- [ ] `dl-stratify` `db` → dependency graph + SCC analysis → stratum ordering
- [ ] Tests: verify semi-naive produces same results as naive; benchmark on large ancestor chain
### Phase 5 — stratified negation
- [ ] Dependency graph analysis: which relations depend on which (positively or negatively)
- [ ] Stratification check: error if negation is in a cycle (non-stratifiable program)
- [ ] Evaluation: process strata in order — lower stratum fully computed before using its
complement in a higher stratum
- [ ] `not(P)` in rule body: at evaluation time, check P is NOT in the derived EDB
- [ ] Tests: non-member (`not(member(X,L))`), colored-graph (`not(same-color(X,Y))`),
stratification error detection
### Phase 6 — aggregation (Datalog+)
- [ ] `count(X, Goal)` → number of distinct X satisfying Goal
- [ ] `sum(X, Goal)` → sum of X values satisfying Goal
- [ ] `min(X, Goal)` / `max(X, Goal)` → min/max of X satisfying Goal
- [ ] `group-by` semantics: `count(X, sibling(bob, X))` → count of bob's siblings
- [ ] Aggregation breaks stratification — evaluate in a separate post-fixpoint pass
- [ ] Tests: social network statistics, grade aggregation, inventory sums
### Phase 7 — SX embedding API
- [ ] `(dl-program facts rules)` → database from SX data directly (no parsing required)
```
(dl-program
'((parent tom bob) (parent tom liz) (parent bob ann))
'((ancestor X Z :- (parent X Y) (ancestor Y Z))
(ancestor X Y :- (parent X Y))))
```
- [ ] `(dl-query db '(ancestor tom ?X))` → `((ann) (bob) (liz) (pat))`
- [ ] `(dl-assert! db '(parent ann pat))` → incremental fact addition + re-derive
- [ ] `(dl-retract! db '(parent tom bob))` → fact removal + re-derive from scratch
- [ ] Integration demo: federation graph query — `(ancestor actor1 actor2)` over
rose-ash ActivityPub follow relationships
### Phase 8 — Datalog as a query language for rose-ash
- [ ] Schema: map SQLAlchemy model relationships to Datalog EDB facts
(e.g. `(follows user1 user2)`, `(authored user post)`, `(tagged post tag)`)
- [ ] Loader: `dl-load-from-db!` — query PostgreSQL, populate Datalog EDB
- [ ] Query examples:
- `?- ancestor(me, X), authored(X, Post), tagged(Post, cooking).`
→ posts about cooking by people I follow (transitively)
- `?- popular(Post) :- tagged(Post, T), count(L, (liked(L, Post))) >= 10.`
→ posts with 10+ likes
- [ ] Expose as a rose-ash service endpoint: `POST /internal/datalog` with program + query
## Blockers
_(none yet)_
## Progress log
_Newest first._
_(awaiting phase 1)_

80
plans/designs/f-breakpoint.md
View File

@@ -1,80 +0,0 @@
# F-Breakpoint — `breakpoint` command (+2)
**Suite:** `hs-upstream-breakpoint`
**Target:** Both tests are `SKIP (untranslated)`.
## 1. The 2 tests
- `parses as a top-level command`
- `parses inside an event handler`
Both are untranslated — no test body exists. The test names say "parses" — these are parser tests, not runtime tests.
## 2. What upstream checks
From `test/core/breakpoint.js`:
```js
it('parses as a top-level command', () => {
expect(() => _hyperscript.evaluate("breakpoint")).not.toThrow();
});
it('parses inside an event handler', () => {
const el = document.createElement('div');
el.setAttribute('_', 'on click breakpoint');
expect(() => _hyperscript.processNode(el)).not.toThrow();
});
```
Both tests verify that `breakpoint` is accepted by the parser without throwing. Neither test checks that the debugger actually fires. `breakpoint` is a no-op command in production builds — it calls `debugger` in JS, which is a no-op when devtools are closed.
## 3. What's needed
### Parser (`lib/hyperscript/parser.sx`)
Add `breakpoint` to the command dispatch — it should parse as a zero-argument command. The parser's command `cond` (wherever `add`, `remove`, `hide` etc. are dispatched) needs a branch:
```
((= val "breakpoint") (hs-parse-breakpoint))
```
`hs-parse-breakpoint` just returns a `{:cmd "breakpoint"}` AST node (or however commands are represented). It consumes no additional tokens.
### Compiler (`lib/hyperscript/compiler.sx`)
Add a compiler branch for `breakpoint` AST node. Emits a no-op or a `debugger` statement equivalent. Since we're in SX (not JS), a no-op `(do nil)` is correct.
### Generator (`tests/playwright/generate-sx-tests.py`)
The 2 tests are simple — hand-write them:
```lisp
(deftest "parses as a top-level command"
(let ((result (guard (e (true false))
(hs-compile "breakpoint")
true)))
(assert result)))
(deftest "parses inside an event handler"
(hs-cleanup!)
(let ((el (dom-create-element "div")))
(dom-set-attr el "_" "on click breakpoint")
(let ((result (guard (e (true false))
(hs-activate! el)
true)))
(assert result))))
```
## 4. Implementation checklist
1. `sx_find_all` in `lib/hyperscript/parser.sx` for the command dispatch `cond`.
2. Add `breakpoint` branch → `hs-parse-breakpoint` function returning minimal command node.
3. `sx_find_all` in `lib/hyperscript/compiler.sx` for command compilation dispatch.
4. Add `breakpoint` branch → emit no-op.
5. Replace 2 `SKIP` bodies in `spec/tests/test-hyperscript-behavioral.sx` with translated tests above.
6. Run `hs_test_run suite="hs-upstream-breakpoint"` — expect 2/2.
7. Run smoke 0–195 — no regressions.
8. Commit: `HS: breakpoint command — parser + no-op compiler (+2)`
## 5. Risk
Very low. Zero-argument no-op command. The only risk is mis-locating the command dispatch branch in the parser.

68
plans/designs/f1-null-safety.md
View File

@@ -1,68 +0,0 @@
# F1 — Null Safety Reporting (+7)
**Suite:** `hs-upstream-core/runtimeErrors`
**Target:** 7 currently-failing tests (decrement, default, increment, put, remove, settle, transition commands)
## 1. Failing tests
The suite has 18 tests total; 11 already pass. The 7 failures all share the pattern:
```
Expected '#doesntExist' is null, got
```
The `eval-hs-error` helper already exists (landed in null-safety piece 1). It compiles and runs a HS snippet and returns the error string. The problem is that the listed commands don't guard against null targets before operating, so they produce no error (or a cryptic one) instead of `"'#doesntExist' is null"`.
| Test | Command | Null target expression |
|------|---------|----------------------|
| decrement | `decrement #doesntExist's innerHTML` | `#doesntExist` |
| default | `default #doesntExist's innerHTML to 'foo'` | `#doesntExist` |
| increment | `increment #doesntExist's innerHTML` | `#doesntExist` |
| put | `put 'foo' into/before/after/at start of/at end of #doesntExist` | `#doesntExist` |
| remove | `remove .foo/.@foo/#doesntExist from #doesntExist` | `#doesntExist` |
| settle | `settle #doesntExist` | `#doesntExist` |
| transition | `transition #doesntExist's *visibility to 0` | `#doesntExist` |
Note: add, hide, measure, send, sets, show, toggle, trigger already pass — they already guard.
## 2. Required error format
```
'#doesntExist' is null
```
The apostrophe-quoted selector string followed by ` is null`. The selector text is the original source text of the element expression (e.g. `#doesntExist`, not a stringified DOM node).
This is the same format already used by passing commands. The null-safety piece 1 commit added `eval-hs-error` and `hs-null-error` helper — just need to call it at the right point in each missing command.
## 3. Where to add guards
All in `lib/hyperscript/runtime.sx`. Pattern for each command:
```
(when (nil? target)
(hs-null-error target-source-text))
```
Where `hs-null-error` (or equivalent) raises with the formatted message.
### Per-command location
- **decrement / increment** — after resolving the target element, before reading/writing innerHTML
- **default** — after resolving target element, before reading current value
- **put** — after resolving destination element (covers all put variants: into, before, after, at start, at end)
- **remove** — after resolving the `from` target element
- **settle** — after resolving target element, before starting transition poll
- **transition** — after resolving target element, before reading/setting style
## 4. Implementation checklist
1. Find each failing command's runtime function in `lib/hyperscript/runtime.sx` using `sx_find_all`.
2. For each: `sx_read_subtree` on the function body, locate where target is resolved, insert null guard calling `hs-null-error` (or the equivalent raise form already used by passing commands).
3. After all 7: run `hs_test_run suite="hs-upstream-core/runtimeErrors"` — expect 18/18.
4. Run smoke range 0–195 — expect no regressions.
5. Commit: `HS: null-safety guards on decrement/default/increment/put/remove/settle/transition (+7)`
## 5. Risk
Low. The pattern is established by the 11 already-passing tests. The only risk is finding the correct point in each command where the element is resolved and before it's first used.

166
plans/designs/f13-step-limit-and-meta.md
View File

@@ -1,166 +0,0 @@
# F13 — Step Limit + `meta.caller` (+5 → 100%)
Five tests currently timeout or produce wrong values due to two root causes:
step budget exhaustion and a missing `meta` implementation.
## Tests
| # | Suite | Test | Failure |
|---|-------|------|---------|
| 198 | `hs-upstream-core/runtime` | `has proper stack from event handler` | wrong-value: `meta.caller` returns `""` instead of an object with `.meta.feature.type = "onFeature"` |
| 200 | `hs-upstream-core/runtime` | `hypertrace is reasonable` | TIMEOUT (15s, step limit) |
| 615 | `hs-upstream-expressions/in` | `query template returns values` | TIMEOUT (37s, step limit) |
| 1197 | `hs-upstream-repeat` | `repeat forever works` | TIMEOUT (step limit) |
| 1198 | `hs-upstream-repeat` | `repeat forever works w/o keyword` | TIMEOUT (step limit) |
---
## Root cause A — Step limit (tests 200, 615, 1197, 1198)
The runner sets `HS_STEP_LIMIT=200000`. Every CEK step consumed by any
expression in a test — including the double compilation warm-up guard blocks
that appear before the actual DOM test — counts against this shared budget.
### `repeat forever` (1197, 1198)
The loop body terminates in exactly **5 iterations** (`if retVal == 5 then return`).
This is bounded, not infinite. The step budget is exhausted before the loop
runs because two `eval-expr-cek` compilation warm-up calls each consume tens
of thousands of steps.
Fix: each warm-up guard compiles and discards a HS function definition. Those
calls are defensive (wrapped in `guard` that swallows errors). We do NOT need
to run the compiled code — the warm-up's purpose is just to ensure the
compiler doesn't crash, not to consume steps. The step counter should not tick
during compilation (compilation is a pure transform, not evaluation). If that's
impractical to gate, raise `HS_STEP_LIMIT` to `2000000` (10×).
### `hypertrace is reasonable` (200)
Defines `bar()` → calls `baz()` → throws. Simple call chain. The "hypertrace"
in the test name implies the HS runtime trace recorder is active during the
test. If trace recording is on globally, every CEK step generates a trace entry
allocation. Fix: confirm whether trace recording is always-on in the test runner
and disable it by default (trace should only be on when explicitly requested).
Alternatively raise step limit.
### `query template returns values` (615)
Uses `<${"p"}/>` — a CSS query selector built from a template string. Takes 37
seconds. Likely the template selector evaluation triggers repeated DOM scanning
or expensive string construction per step. Fix: profile with `hs_test_run
verbose=true` to identify which step is slow. If it's a regex compilation
per-call, cache it. If step limit only, raise to 2M.
### Unified fix: raise `HS_STEP_LIMIT` to `2000000`
The simplest fix that unblocks all four timeout tests. In
`tests/hs-run-filtered.js`, change the default step limit. Per-test overrides
can still be set via `HS_STEP_LIMIT` env var for debugging.
If the `query template` test is still slow at 2M steps (37s × 10 = 370s, which
would be unacceptable), that test needs a separate performance fix — cache the
compiled regex/query from the template string rather than rebuilding it on every
access.
---
## Root cause B — `meta.caller` not implemented (test 198)
The HS `meta` object is available inside any function call. It exposes:
- `meta.caller` — the calling context object
- `meta.caller.meta.feature.type` — the HS feature type of the caller
(e.g. `"onFeature"` when called from an `on click` handler)
Test script:
```
def bar()
log meta.caller
return meta.caller
end
```
Triggered via `on click put bar().meta.feature.type into my.innerHTML`.
Expects `"onFeature"` in innerHTML. Currently gets `""`.
### What `meta` needs
`meta` is a dict-like object injected into every function's execution context
at call time. Minimum fields for this test:
```
meta = {
:caller <the calling context — a dict with its own :meta field>
:element <the element the script is attached to>
}
```
`meta.caller.meta.feature.type` must return `"onFeature"` when called from an
`on` event handler. The feature type string `"onFeature"` is already used
internally (event handler features are tagged with this type).
### Implementation
In `lib/hyperscript/runtime.sx`, at the point where a HS `def` function is
called:
1. Build a `meta` dict:
```
{:caller calling-context :element current-element}
```
where `calling-context` is the current runtime context dict (which includes
its own `:meta` field with `:feature {:type "onFeature"}` for event handlers).
2. Bind `meta` in the function's execution env.
3. Ensure event handler contexts carry `{:meta {:feature {:type "onFeature"}}}`.
This is an additive change — nothing currently uses `meta`, so no regression
risk.
---
## Implementation checklist
### Step A — Raise step limit
1. In `tests/hs-run-filtered.js`, change default `HS_STEP_LIMIT` from `200000`
to `2000000`.
2. Run tests 1197–1198: `hs_test_run(start=1197, end=1199)` — expect 2/2.
3. Run test 615: `hs_test_run(start=615, end=616)` — expect 1/1 or note if
still too slow.
4. Run test 200: `hs_test_run(start=200, end=201)` — expect 1/1.
### Step B — `meta.caller` (test 198)
5. `sx_find_all` in `lib/hyperscript/runtime.sx` for where `def` functions are
called / where event handler contexts are constructed.
6. Add `meta` dict construction at call time; bind in function env.
7. Ensure `on` handler context carries `{:meta {:feature {:type "onFeature"}}}`.
8. Run test 198: `hs_test_run(start=198, end=199)` — expect 1/1.
### Step C — Query template performance (if still slow after step A)
9. Profile `hs_test_run(start=615, end=616, step_limit=2000000, verbose=true)`.
10. If the CSS template query `<${"p"}/>` rebuilds on every call, add a memoize
cache keyed on the template result string.
11. Rerun — expect < 5s.
### Step D — Full suite verification
12. Run all ranges with raised step limit:
- `hs_test_run(start=0, end=201, step_limit=2000000)`
- `hs_test_run(start=201, end=616, step_limit=2000000)`
- `hs_test_run(start=616, end=1200, step_limit=2000000)`
- `hs_test_run(start=1200, end=1496, step_limit=2000000)`
13. Confirm all previously-passing tests still pass.
14. Commit: `HS: raise step limit to 2M + meta.caller for onFeature stack (+5)`
---
## Risk
- **Step limit raise:** May make test suite slower overall (more steps to exhaust
before timeout). But if tests pass quickly the limit is never reached.
The 37s query-template test is the only real concern — if it genuinely needs
2M steps × (time per step), it needs a performance fix too.
- **`meta.caller`:** Additive binding in function scope. Zero regression risk.
The only complexity is constructing the right shape for the calling context
chain — but since only one test exercises this and the shape is simple, the
risk is low.

81
plans/designs/f2-tell.md
View File

@@ -1,81 +0,0 @@
# F2 — `tell` Semantics Fix (+3)
**Suite:** `hs-upstream-tell`
**Target:** 3 failing tests out of 10. 7 already pass.
## 1. Failing tests
### "attributes refer to the thing being told"
```
on click tell #d2 then put @foo into me
```
d2 has attribute `foo="bar"`. After click, d1's text content should be `"bar"`.
`@foo` is an attribute ref — it should resolve against the **told element** (d2), not the event target (d1).
Currently gets `""` — attribute resolves against d1, which has no `foo` attribute.
### "your symbol represents the thing being told"
```
on click tell #d2 then put your innerText into me
```
d2 has innerText `"foo"`. After click, d1's text content should be `"foo"`.
`your` is the possessive of `you` — inside a `tell` block, `you`/`your` should bind to the told element.
Currently gets `""`.
### "does not overwrite the me symbol"
```
on click add .foo then tell #d2 then add .bar to me
```
After click: d1 should have both `.foo` and `.bar`; d2 should have neither.
`me` inside the `tell` block must still refer to d1 (the original event target).
Currently: assertion fails — `.bar` is going to d2 instead of d1.
## 2. What the 7 passing tests reveal about current behaviour
The passing tests include:
- `you symbol represents the thing being told` — `add .bar to you` adds to d2 ✓
- `establishes a proper beingTold symbol` — bare `add .bar` (no target) adds to the told element ✓
- `restores a proper implicit me symbol` — after `tell` block ends, bare commands target d1 again ✓
- `yourself attribute also works` — `remove yourself` inside tell removes d2 ✓
So `you`, `yourself`, and bare implicit target all work. The three bugs are:
1. Attribute refs (`@foo`) don't resolve against the told element
2. `your` (possessive of `you`) doesn't resolve
3. `me` is being rebound to the told element instead of kept as d1
## 3. Root cause analysis
Inside a `tell X` block, the runtime sets the implicit target to X. The three failures suggest:
**Bug A — attribute refs:** `@foo` resolves via a property-access path that reads from the *current event target* (`me`/`self`), not from the *implicit tell target*. The tell block sets implicit target but the attribute ref lookup skips it.
**Bug B — `your`:** `your` is parsed as a possessive modifier expecting `you` to be bound. If `you` is not bound in the tell scope (and only the implicit target is set), `your X` fails to resolve.
**Bug C — `me` rebinding:** The tell command saves/restores `me` but the save/restore is either not happening or is restoring the wrong value. `me` inside the block should remain d1 while the implicit default target is d2.
## 4. Fix
In `lib/hyperscript/runtime.sx`, find the `tell` command handler (search for `hs-tell` or the tell dispatch branch).
The correct semantics:
- Save current `me` value
- Set implicit target (used by bare commands like `add .bar`) to the told element
- Bind `you` = told element (so `you`, `your`, `yourself` work)
- Do **not** rebind `me` — keep it as the original event target
- Restore implicit target and unbind `you` after the block
For attribute refs (`@foo`): resolve against the current *implicit target* (told element), not against `me`. Find where `@attr` expressions are evaluated and ensure they read from the implicit target when inside a tell block.
## 5. Implementation checklist
1. `sx_find_all` in `lib/hyperscript/runtime.sx` for tell handler.
2. `sx_read_subtree` on the tell handler — verify save/restore of `me` vs implicit target.
3. Fix `me` rebinding: save old implicit target, set new one, do NOT touch `me`.
4. Bind `you`/`your`/`yourself` to told element in the tell scope env.
5. Find attribute ref (`@`) evaluation — ensure it reads from implicit target.
6. Run `hs_test_run suite="hs-upstream-tell"` — expect 10/10.
7. Run smoke 0–195 — no regressions.
8. Commit: `HS: tell — fix me rebinding, your/attribute-ref resolution (+3)`
## 6. Risk
Medium. The 7 passing tests constrain what can change — the fix must preserve `you`, `yourself`, bare implicit target, and restore-after-tell semantics. The three bugs are independent enough that they can be fixed one at a time and verified after each.

128
plans/designs/f5-cookies.md
View File

@@ -1,128 +0,0 @@
# F5 — Cookie API (+5)
**Suite:** `hs-upstream-expressions/cookies`
**Target:** All 5 tests are `SKIP (untranslated)`.
## 1. The 5 tests
From upstream `test/expressions/cookies.js`:
| Test | What it checks |
|------|---------------|
| `length is 0 when no cookies are set` | `cookies.length == 0` with no cookies set |
| `basic set cookie values work` | `set cookies.name to "value"` then `cookies.name == "value"` |
| `update cookie values work` | set, then set again, value updates |
| `basic clear cookie values work` | `set cookies.name to "value"` then `clear cookies.name`, then `cookies.name == undefined` |
| `iterate cookies values work` | `for name in cookies` iterates cookie names |
## 2. HyperScript cookie syntax
`cookies` is a special global expression in HyperScript backed by `document.cookie`. The upstream implementation wraps `document.cookie` in a proxy:
- `cookies.name` → read cookie by name (returns string or `undefined`)
- `set cookies.name to val` → write cookie (sets `document.cookie = "name=val"`)
- `clear cookies.name` → delete cookie (sets max-age=-1)
- `cookies.length` → number of cookies set
- `for name in cookies` → iterate over cookie names
## 3. Test runner mock
All 5 tests are untranslated — no SX test bodies exist yet. The generator needs patterns for the cookie expressions, and `hs-run-filtered.js` needs a `document.cookie` mock.
### Mock in `tests/hs-run-filtered.js`
Add a simple in-memory cookie store to the `dom` mock:
```js
let _cookieStore = {};
Object.defineProperty(global.document, 'cookie', {
get() {
return Object.entries(_cookieStore)
.map(([k,v]) => `${k}=${v}`)
.join('; ');
},
set(str) {
const [pair, ...attrs] = str.split(';');
const [name, val] = pair.split('=').map(s => s.trim());
const maxAge = attrs.find(a => a.trim().startsWith('max-age='));
if (maxAge && parseInt(maxAge.split('=')[1]) < 0) {
delete _cookieStore[name];
} else {
_cookieStore[name] = val;
}
},
configurable: true
});
```
Add `_cookieStore = {}` reset to `hs-cleanup!` equivalent in the runner.
## 4. SX runtime additions in `lib/hyperscript/runtime.sx`
HS needs a `cookies` special expression that the compiler resolves. Two approaches:
**Option A (simpler):** Treat `cookies` as a built-in variable bound to a proxy dict at runtime. When property access `cookies.name` is evaluated, dispatch to cookie read/write helpers.
**Option B (upstream-faithful):** Parse `cookies` as a special primary expression, emit runtime calls `hs-cookie-get`, `hs-cookie-set`, `hs-cookie-delete`, `hs-cookie-length`, `hs-cookie-names`.
Option A is less invasive. The runtime env gets a `cookies` binding pointing to a special object; property access and assignment on it dispatch to the cookie helpers, which call `(platform-cookie-get name)` / `(platform-cookie-set name val)` / `(platform-cookie-delete name)`.
Platform cookie operations map to `document.cookie` reads/writes in JS.
## 5. Generator patterns (`tests/playwright/generate-sx-tests.py`)
The upstream tests use patterns like:
```js
await page.evaluate(() => { _hyperscript.evaluate("set cookies.foo to 'bar'") });
expect(await page.evaluate(() => _hyperscript.evaluate("cookies.foo"))).toBe("bar");
```
In our SX harness these become direct `eval-hs` calls. Since all 5 tests are untranslated, hand-write them rather than extending the generator (similar to E39).
## 6. Translated test bodies
```lisp
(deftest "length is 0 when no cookies are set"
(hs-cleanup!)
(assert= (eval-hs "cookies.length") 0))
(deftest "basic set cookie values work"
(hs-cleanup!)
(eval-hs "set cookies.foo to 'bar'")
(assert= (eval-hs "cookies.foo") "bar"))
(deftest "update cookie values work"
(hs-cleanup!)
(eval-hs "set cookies.foo to 'bar'")
(eval-hs "set cookies.foo to 'baz'")
(assert= (eval-hs "cookies.foo") "baz"))
(deftest "basic clear cookie values work"
(hs-cleanup!)
(eval-hs "set cookies.foo to 'bar'")
(eval-hs "clear cookies.foo")
(assert= (eval-hs "cookies.foo") nil))
(deftest "iterate cookies values work"
(hs-cleanup!)
(eval-hs "set cookies.a to '1'")
(eval-hs "set cookies.b to '2'")
(let ((names (eval-hs "for name in cookies collect name")))
(assert (contains? names "a"))
(assert (contains? names "b"))))
```
## 7. Implementation checklist
1. Add cookie mock to `tests/hs-run-filtered.js`. Wire reset into test cleanup.
2. Add `hs-cookie-get`, `hs-cookie-set`, `hs-cookie-delete`, `hs-cookie-length`, `hs-cookie-names` to `lib/hyperscript/runtime.sx`.
3. Add `cookies` as a special expression in the HS parser/evaluator that dispatches to the above.
4. Replace 5 `SKIP` bodies in `spec/tests/test-hyperscript-behavioral.sx` with translated test bodies above.
5. Run `hs_test_run suite="hs-upstream-expressions/cookies"` — expect 5/5.
6. Run smoke 0–195 — no regressions.
7. Commit: `HS: cookie API — document.cookie proxy + 5 tests`
## 8. Risk
Medium. The mock is simple. The main risk is the `cookies` expression integration in the parser — it needs to hook into property-access and assignment paths that are already well-exercised. Keep the implementation thin: `cookies` is a runtime value with a special type, not a new parse form.

107
plans/designs/f8-eval-statically.md
View File

@@ -1,107 +0,0 @@
# F8 — evalStatically (+3)
**Suite:** `hs-upstream-core/evalStatically`
**Target:** 3 failing (untranslated) out of 8. 5 already pass.
## 1. Current state
5 passing tests use `(eval-hs expr)` and check the return value for literals: booleans, null, numbers, plain strings, time expressions. These call `_hyperscript.evaluate(src)` and return the result.
3 failing tests are named:
- `throws on math expressions`
- `throws on symbol references`
- `throws on template strings`
All are `SKIP (untranslated)` — no test body has been generated.
## 2. What upstream checks
From `test/core/evalStatically.js`, the `throwErrors` mode:
```js
expect(() => _hyperscript.evaluate("1 + 2")).toThrow();
expect(() => _hyperscript.evaluate("x")).toThrow();
expect(() => _hyperscript.evaluate(`"hello ${name}"`)).toThrow();
```
`_hyperscript.evaluate(src)` in strict static mode throws when the expression is not a pure literal — math operators, symbol references, and template string interpolation all involve runtime evaluation that can't be statically resolved.
The "static" constraint: only literals that can be evaluated without any runtime context or side effects are allowed. `1 + 2` is not static (it's a math op). `x` is not static (symbol lookup). `"hello ${name}"` is not static (interpolation).
## 3. What `eval-hs` currently does
`eval-hs` in our harness calls `(hs-compile-and-run src)` or equivalent. It does NOT currently have a "static mode" — it runs everything with the full runtime.
We need a new harness helper `eval-hs-static-error` that:
1. Calls `(hs-compile src)` with a flag that makes it throw on non-literal expressions
2. Returns the caught error message, or raises if no error was thrown
## 4. Implementation options
### Option A — Static analysis pass (accurate)
Before evaluation, walk the AST and reject any node that isn't a literal:
- Number literal ✓
- String literal (no interpolation) ✓
- Boolean literal ✓
- Null literal ✓
- Time expression (`200ms`, `2s`) ✓
- Everything else → throw `"expression is not static"`
This is a pre-eval AST check, not a runtime change. Lives in `lib/hyperscript/compiler.sx` as `hs-check-static`.
### Option B — Generator translation (simpler)
The 3 tests are untranslated. All three just verify that `_hyperscript.evaluate(expr)` throws. In our SX harness we can test this with a `guard` form:
```lisp
(deftest "throws on math expressions"
(let ((result (guard (e (true true))
(eval-hs "1 + 2")
false)))
(assert result)))
```
But this only works if `eval-hs` actually throws on math expressions. Currently it doesn't — `eval-hs "1 + 2"` returns `3`. So we'd need the static analysis anyway to make the test pass.
### Chosen approach: Option A
Add `hs-static-check` to the compiler: a fast AST walker that throws on any non-literal node. Wire it as an optional mode. The test harness calls `eval-hs-static` which runs with static-check enabled.
Actually, reading the upstream more carefully: `_hyperscript.evaluate` already throws in static mode without additional flags — the "evaluate" API is documented as static-only. Our `eval-hs` in the passing tests works because booleans/numbers/strings/time ARE static. `1 + 2`, `x`, and template strings are NOT static and should throw.
So the fix is: make `hs-compile-and-run` (or whatever backs `eval-hs`) reject non-literal AST nodes. The 5 passing tests will continue to pass (they use literals). The 3 failing tests will get translated using `eval-hs-error` or a guard pattern.
## 5. Non-literal AST node types to reject
| Expression | AST node type | Reject? |
|-----------|--------------|---------|
| `1`, `3.14` | number literal | ✓ allow |
| `"hello"`, `'world'` | string literal (no interpolation) | ✓ allow |
| `true`, `false` | boolean literal | ✓ allow |
| `null` | null literal | ✓ allow |
| `200ms`, `2s` | time literal | ✓ allow |
| `1 + 2` | math operator | ✗ throw |
| `x` | symbol reference | ✗ throw |
| `"hello ${name}"` | template string | ✗ throw |
## 6. Implementation checklist
1. In `lib/hyperscript/compiler.sx`, add `hs-static?` predicate: returns true only for literal AST node types.
2. In the `eval-hs` path (wherever `hs-compile-and-run` is called for the evaluate API), call `hs-static?` on the parsed AST and throw `"expression is not statically evaluable"` if false.
3. Replace 3 `SKIP` bodies in `spec/tests/test-hyperscript-behavioral.sx`:
```lisp
(deftest "throws on math expressions"
(assert (string? (eval-hs-error "1 + 2"))))
(deftest "throws on symbol references"
(assert (string? (eval-hs-error "x"))))
(deftest "throws on template strings"
(assert (string? (eval-hs-error "\"hello ${name}\""))))
```
4. Run `hs_test_run suite="hs-upstream-core/evalStatically"` — expect 8/8.
5. Run smoke 0–195 — verify the 5 passing tests still pass.
6. Commit: `HS: evalStatically — static literal check, 3 tests (+3)`
## 7. Risk
Low-medium. The main risk is that `eval-hs` is used in many tests for non-static expressions and adding a static check to the shared path would break them. The fix must be gated — either a separate `eval-hs-static` helper or a flag parameter. The passing tests must not be affected.

341
plans/designs/hs-plugin-system.md
View File

@@ -1,341 +0,0 @@
# HyperScript Plugin / Extension System
Post-Bucket-F capability work. No conformance delta on its own — the payoff is
clean architecture for language embeds (Lua, Prolog, Worker runtime) and
alignment with real `_hyperscript`'s extension model.
---
## 1. Motivation
### 1a. Real `_hyperscript` has a plugin API
Stock `_hyperscript` ships a core bundle with feature stubs and a `use(ext)`
hook that loads named extensions at runtime. The worker feature is the canonical
example: the core parser has a stub that errors helpfully; loading the worker
extension replaces the stub with a real implementation.
We currently have no equivalent. New grammar or compiler targets require editing
`parse-feat`'s hardcoded `cond` or `hs-to-sx`'s hardcoded dispatch. This is
fine for conformance work but wrong for language embeds.
### 1b. Ad-hoc hooks are accumulating
`runtime.sx` already has `hs-prolog-hook` / `hs-set-prolog-hook!` / `prolog`
(nodes 140–142) — an informal plugin slot bolted on outside the parser and
compiler. This pattern will repeat for Lua, and again for the Worker runtime.
A proper registry prevents the drift.
### 1c. E39 worker stub is a placeholder
The stub added in E39 (`parse-feat` raises immediately on `"worker"`) was
explicitly designed to be replaced by a real plugin at a single site. This plan
is where that replacement happens.
### 1d. Bucket-F Group 10 needs a converter registry
`as MyType` via registered converter is already in the Bucket-F plan (Group 10).
A `hs-register-converter!` registry is the natural home for it — and the plugin
system is the right time to add registries generally.
---
## 2. Scope
**In scope:**
- Parser feature registry (`parse-feat` dispatch)
- Compiler command registry (`hs-to-sx` dispatch)
- `as` converter registry (`hs-coerce` dispatch)
- Migration of E39 worker stub to use the parser registry
- Migration of `hs-prolog-hook` ad-hoc slot to a proper plugin
- Worker full runtime plugin (first real plugin)
- Lua embed plugin
- Prolog embed plugin
**Out of scope:**
- Changing the test runner or generator
- Any conformance delta (this plan doesn't target failing tests)
- Third-party plugin loading from external URLs (future)
- Hot-reload of plugins (future)
---
## 3. Registry design
Three registries, all SX dicts. Checked before the hardcoded `cond` in each
dispatch. Registration functions defined alongside the registries in their
respective files.
### 3a. Parser feature registry (`lib/hyperscript/parser.sx`)
```lisp
(define _hs-feature-registry (dict))
(define hs-register-feature!
(fn (keyword parse-fn)
(set! _hs-feature-registry
(dict-set _hs-feature-registry keyword parse-fn))))
```
In `parse-feat`, prepend a registry lookup before the existing `cond`:
```lisp
(let ((registered (dict-get _hs-feature-registry val)))
(if registered
(registered) ;; call the registered parse-fn (no args; uses closure over adv!/tp-val etc.)
(cond ;; existing dispatch unchanged below
...)))
```
`parse-fn` is a zero-arg thunk that has access to the parser's internal state
via the same closure that the existing `parse-*` helpers use. Since `parse-feat`
is itself defined inside the big `let` in `hs-parse`, all the parser helpers
(`adv!`, `tp-val`, `tp-typ`, `parse-cmd-list`, etc.) are in scope.
### 3b. Compiler command registry (`lib/hyperscript/compiler.sx`)
```lisp
(define _hs-compiler-registry (dict))
(define hs-register-compiler!
(fn (head compile-fn)
(set! _hs-compiler-registry
(dict-set _hs-compiler-registry (str head) compile-fn))))
```
In `hs-to-sx`, before the existing `cond` on `head`, check the registry:
```lisp
(let ((registered (dict-get _hs-compiler-registry (str head))))
(if registered
(registered ast)
(cond ...)))
```
`compile-fn` receives the full AST node and returns an SX expression.
### 3c. `as` converter registry (`lib/hyperscript/runtime.sx`)
```lisp
(define _hs-converters (dict))
(define hs-register-converter!
(fn (type-name converter-fn)
(set! _hs-converters
(dict-set _hs-converters type-name converter-fn))))
```
In `hs-coerce`, add a registry lookup as the last `cond` clause before the
fallthrough error:
```lisp
((dict-get _hs-converters type-name)
((dict-get _hs-converters type-name) value))
```
This is also the hook that Bucket-F Group 10 (`can accept custom conversions`)
hangs on — so implementing it here kills two birds.
---
## 4. First-party plugins
Each plugin is a `.sx` file in `lib/hyperscript/plugins/`. Plugins call the
registration functions at load time (top-level `do` forms). The host loads
plugins explicitly after the core files.
### 4a. Worker plugin (`lib/hyperscript/plugins/worker.sx`)
**Phase 1 — stub migration (immediate):**
Remove the inline error branch from `parse-feat` (the E39 stub). Replace with:
```lisp
(hs-register-feature! "worker"
(fn ()
(error "worker plugin is not installed — see https://hyperscript.org/features/worker")))
```
This is identical behaviour to E39 but routed through the registry. The stub
lives in the plugin file, not the core parser. No test regression.
**Phase 2 — full runtime:**
Parser: `parse-worker-feat` — consumes `worker <Name> [(<url>*)] <def|js>* end`,
returns `(worker Name urls defs)` AST node.
Compiler: registered under `"worker"` head:
- Emits `(hs-worker-define! "Name" urls defs)` call.
Runtime additions in the plugin file:
- `hs-worker-define!` — creates a `{:_hs-worker true :name N :handle H :exports (...)}` record,
binds it in the HS top-level env under `Name`.
- `hs-method-call` (existing) detects `:_hs-worker` and dispatches via `postMessage`.
- Worker script body compiled to a standalone SX bundle posted to a Blob URL.
- Return values are promise-wrapped; async-transparent via `perform`/IO suspension.
Mock env additions for the test runner: `Worker` constructor + synchronous
message loop for the 7 sibling `test.skip(...)` upstream tests (the ones
deferred in E39).
### 4b. Prolog plugin (`lib/hyperscript/plugins/prolog.sx`)
Replaces the ad-hoc `hs-prolog-hook` in `runtime.sx`.
**Parser:** Register `"prolog"` feature — parses
`prolog(<db-expr>, <goal-expr>)` at feature level (alternative: keep as an
expression, register a compiler extension only).
**Compiler:** Registered under `"prolog"` head — emits `(prolog db goal)`.
**Runtime:** The existing `prolog` function in `runtime.sx` moves here.
`hs-prolog-hook` and `hs-set-prolog-hook!` are removed from `runtime.sx` and
the hook mechanism is replaced by the plugin loading `lib/prolog/runtime.sx`
and wiring the solver directly.
Remove from `runtime.sx` nodes 140–142 once the plugin is live.
### 4c. Lua plugin (`lib/hyperscript/plugins/lua.sx`)
**Parser:** Register `"lua"` feature — parses `lua ... end` block, captures
the body as a raw string.
**Compiler:** Registered under `"lua"` head — emits `(lua-eval <body-string>)`.
**Runtime:** `lua-eval` calls `lib/lua/runtime.sx`'s eval entry point, returns
result as an SX value via `hs-host-to-sx`. Errors surface as HS `catch`-able
exceptions.
This enables inline Lua in HyperScript:
```
on click
lua
return document.title:upper()
end
put it into me
end
```
---
## 5. Load order
```
lib/hyperscript/parser.sx ;; defines _hs-feature-registry, hs-register-feature!
lib/hyperscript/compiler.sx ;; defines _hs-compiler-registry, hs-register-compiler!
lib/hyperscript/runtime.sx ;; defines _hs-converters, hs-register-converter!
lib/hyperscript/plugins/worker.sx
lib/hyperscript/plugins/prolog.sx
lib/hyperscript/plugins/lua.sx
```
The test runner (`tests/hs-run-filtered.js`) loads plugins after core. The
browser WASM bundle includes all three by default (plugins are small; no
reason to lazy-load them).
---
## 6. Migration checklist
The work below is ordered to keep main green at every commit. Each step is
independently committable.
### Step 1 — Registries (infrastructure, no behaviour change)
1. Add `_hs-feature-registry` + `hs-register-feature!` to `parser.sx`.
Thread the registry check into `parse-feat`. No entries yet → behaviour
unchanged.
2. Add `_hs-compiler-registry` + `hs-register-compiler!` to `compiler.sx`.
Thread into `hs-to-sx`. No entries yet → behaviour unchanged.
3. Add `_hs-converters` + `hs-register-converter!` to `runtime.sx`. Thread
into `hs-coerce`. No entries yet → behaviour unchanged.
4. `sx_validate` all three files. Run full HS suite — expect zero regressions.
5. Commit: `HS: plugin registry infrastructure (parser + compiler + converter)`.
### Step 2 — Worker stub migration
6. Create `lib/hyperscript/plugins/worker.sx`. Register the worker stub error.
7. Remove the inline `((= val "worker") ...)` branch from `parse-feat` in
`parser.sx`.
8. Update the test runner to load `worker.sx` after core.
9. Run `HS_SUITE=hs-upstream-worker` — expect 1/1. Run full suite — expect no
regressions.
10. Commit: `HS: migrate E39 worker stub to plugin registry`.
### Step 3 — Prolog plugin
11. Create `lib/hyperscript/plugins/prolog.sx`. Wire to `lib/prolog/runtime.sx`.
12. Remove `hs-prolog-hook`, `hs-set-prolog-hook!`, `prolog` from `runtime.sx`
nodes 140–142.
13. Update test runner to load `prolog.sx`.
14. Validate and run full suite.
15. Commit: `HS: prolog plugin replaces ad-hoc hook`.
### Step 4 — `as` converter registry (bridges Bucket-F Group 10)
16. Confirm `hs-register-converter!` satisfies the Group 10 test
`can accept custom conversions`. If yes, this step may be pulled into
Bucket-F Group 10 instead (no duplication — just move step 3 of §6 there).
17. Commit: `HS: as-converter registry wired into hs-coerce`.
### Step 5 — Lua plugin
18. Create `lib/hyperscript/plugins/lua.sx`.
19. Add `lua-eval` to `runtime.sx` or directly in the plugin file.
20. Parser: `parse-lua-feat` consuming `lua … end`.
21. Compiler: registered `"lua"` head.
22. Write 3–5 tests in `spec/tests/test-hyperscript-lua.sx`:
- Lua returns a string → HS uses it.
- Lua error → HS catch.
- Lua reads a passed argument.
23. Commit: `HS: Lua plugin — inline lua...end blocks`.
### Step 6 — Worker full runtime plugin
24. Extend `worker.sx`: implement `parse-worker-feat`, compiler entry,
`hs-worker-define!`, `hs-method-call` worker branch.
25. Extend test runner: `Worker` constructor + synchronous message loop.
26. Un-skip the 7 sibling worker tests from upstream.
27. Target: 7/7 worker suite.
28. Commit: `HS: Worker plugin full runtime (+7 tests)`.
---
## 7. Risks
- **`parse-feat` closure scope** — `hs-register-feature!` stores parse-fns
that need access to parser-internal helpers (`adv!`, `tp-val`, etc.). These
are only in scope inside `hs-parse`'s big `let`. Two options:
(a) the registry stores fns that receive a parser-context dict as arg, or
(b) the registry is checked *inside* `parse-feat` where helpers are in scope
and fns are zero-arg closures captured at registration time.
Option (b) is simpler but requires plugins to be loaded while the parser
`let` is being evaluated — i.e., plugins must be defined *inside* the parser
file or the context dict must be exposed. **Recommended:** expose a
`_hs-parser-ctx` dict at the module level that parse-fns receive as their
sole argument. This makes the API explicit and plugins independent files.
- **Worker Blob URL in WASM** — `URL.createObjectURL` is available in browsers
but not in the OCaml WASM host. Worker full runtime is browser-only; flag it
with a capability check and graceful fallback.
- **Lua/Prolog mutual recursion** — a Lua block calling back into HS calling
back into Lua is theoretically possible via the IO suspension machinery.
Don't try to support it initially; raise a clear error if detected.
- **Plugin load-order sensitivity** — `hs-register-feature!` must be called
before any source is parsed. If a plugin is loaded lazily (future), a
`worker MyWorker` in the page would hit the stub before the full plugin
registers. Acceptable for now; document that plugins must be loaded at boot.
- **`runtime.sx` cleanup for prolog** — nodes 140–142 are referenced nowhere
else in the codebase (grep confirms). Safe to delete once the plugin is live.
---
## 8. Non-goals
- Runtime `use(ext)` API (JS-style dynamic plugin install) — future.
- Plugin namespacing / versioning — future.
- Any conformance tests other than the 7 worker tests in step 6.
- Changing how the WASM bundle is built or split.

173
plans/elixir-on-sx.md
View File

@@ -1,173 +0,0 @@
# Elixir-on-SX: Elixir on the CEK/VM
Compile Elixir source to SX AST; the existing CEK evaluator runs it. The natural companion
to `lib/erlang/` — Elixir compiles to the BEAM and most of its runtime semantics are
Erlang's. The interesting parts are Elixir-specific: the macro system (`quote`/`unquote`),
the pipe operator `|>`, `with` expressions, `defmodule`/`def`/`defp`, protocol dispatch,
and the `Stream` lazy evaluation library.
End-state goal: **core Elixir programs running**, including modules, pattern matching, the
pipe operator, macros (`quote`/`unquote`/`defmacro`), protocols, and actor-style processes
reusing the Erlang runtime foundation.
## Ground rules
- **Scope:** only touch `lib/elixir/**` and `plans/elixir-on-sx.md`. Do **not** edit
`spec/`, `hosts/`, `shared/`, or other `lib/<lang>/`. Reuse `lib/erlang/` runtime
functions where possible — import them, don't duplicate.
- **Shared-file issues** go under "Blockers" below with a minimal repro; do not fix here.
- **SX files:** use `sx-tree` MCP tools only.
- **Architecture:** Elixir source → Elixir AST → SX AST. Reuse Erlang runtime for process/
message/pattern primitives; add Elixir-specific surface in `lib/elixir/`.
- **Commits:** one feature per commit. Keep `## Progress log` updated and tick boxes.
## Architecture sketch
```
Elixir source text
│
▼
lib/elixir/tokenizer.sx — atoms (:atom), strings (""), charlists (''), sigils (~r, ~s etc.),
│ operators (|>, <>, ++, :::, etc.), do/end blocks
▼
lib/elixir/parser.sx — Elixir AST: defmodule, def/defp/defmacro, @attribute,
│ pattern matching, |> pipe, with, for comprehension, quote/unquote,
│ case/cond/if/unless, fn, receive, try/rescue/catch/after
▼
lib/elixir/transpile.sx — Elixir AST → SX AST
│
├── lib/erlang/runtime.sx (reused: processes, message passing, pattern match)
└── lib/elixir/runtime.sx — Elixir-specific: Kernel, String, Enum, Stream, Map,
List, Tuple, IO, protocol dispatch, macro expansion
```
Key semantic mappings (differences from Erlang):
- `defmodule M do ... end` → SX `define-library` + module dict `{:module "M" :fns {...}}`
- `def f(args) do body end` → named function in module dict, with pattern-match dispatch
- `|>` pipe → left-to-right function composition; `a |> f(b)` = `f(a, b)`
- `with x <- expr, y <- expr2 do body else patterns end` → chained pattern match with early exit
- `for x <- list, filter, do: expr` → list comprehension (SX `map`/`filter`)
- `quote do expr end` → returns AST as SX list (homoiconic — Elixir AST IS SX-like)
- `unquote(expr)` → evaluate expr and splice into surrounding `quote`
- `defmacro` → macro in module; expanded at compile time by calling the SX macro
- Protocol → dict of implementations keyed by type name; `defprotocol` defines interface,
`defimpl` registers an implementation
- `Stream` → lazy sequences using SX promises/coroutines (Phase 9/4 of primitives)
- `Agent`/`GenServer` → SX coroutine + message queue (similar to Erlang process model)
## Roadmap
### Phase 1 — tokenizer + parser
- [ ] Tokenizer: atoms (`:atom`, `:"atom with spaces"`), strings (`""`), charlists (`''`),
numbers (int, float, hex `0xFF`, octal `0o77`, binary `0b11`), booleans (`true`/`false`/`nil`),
operators (`|>`, `<>`, `++`, `--`, `:::`, `&&`, `||`, `!`, `..`, `<-`, `=~`),
sigils (`~r/regex/`, `~s"string"`, `~w(word list)`), do/end blocks, keywords as args
`f(key: val)`, `@module_attribute`
- [ ] Parser:
- Module: `defmodule Name do ... end` → module AST with body
- Functions: `def f(pat) do body end`, `def f(pat) when guard do body end`,
multi-clause `def f(a) do ...; def f(b) do ...` → clause list
- `defp` (private), `defmacro`, `defmacrop`
- `@doc`, `@moduledoc`, `@spec`, `@type`, `@behaviour` module attributes
- `case expr do patterns end`, `cond do clauses end`, `if`/`unless`
- `with x <- e, y <- e2, do: body, else: [pattern -> body]`
- `for x <- list, filter, into: acc, do: expr` comprehension
- `fn pat -> body end` anonymous function; capture `&Module.fun/arity`, `&(&1 + 1)`
- `receive do patterns after timeout -> body end`
- `try do body rescue e -> ... catch type, val -> ... after ... end`
- `quote do ... end`, `unquote(expr)`, `unquote_splicing(list)`
- `|>` pipe chain: `a |> f |> g(b)` → `g(f(a), b)`
- [ ] Tests in `lib/elixir/tests/parse.sx`
### Phase 2 — transpile: basic Elixir (no macros, no processes)
- [ ] `ex-eval-ast` entry
- [ ] Arithmetic, string `<>`, list `++`/`--`, comparison, boolean (`and`/`or`/`not`)
- [ ] Pattern matching in `=`, function heads, `case` — reuse Erlang pattern engine
- [ ] `def`/`defp` → SX `define` with clause dispatch (like Erlang function clauses)
- [ ] Module as a dict of named functions; `ModuleName.function(args)` dispatch
- [ ] `|>` pipe: desugar `a |> f(b, c)` → `f(a, b, c)` at transpile time
- [ ] `with` expression: chain of `<-` bindings, short-circuit on mismatch to `else`
- [ ] `for` comprehension: `for x <- list, filter do body end` → `map`/`filter`
- [ ] `fn` anonymous functions, `&` capture forms
- [ ] `if`/`unless`/`cond`/`case`
- [ ] String interpolation: `"Hello #{name}"` → string concat
- [ ] Keyword lists `[key: val]` → SX list of `{:key val}` dicts; maps `%{key: val}` → SX dict
- [ ] Tuples `{a, b, c}` → SX list (or vector); `elem/2`, `put_elem/3`
- [ ] 40+ eval tests in `lib/elixir/tests/eval.sx`
### Phase 3 — macro system
- [ ] `quote do expr end` → returns Elixir AST as SX list structure
(Elixir AST is 3-tuples `{name, meta, args}` — map to SX `(list name meta args)`)
- [ ] `unquote(expr)` → evaluate and splice into surrounding `quote`
- [ ] `unquote_splicing(list)` → splice list into surrounding `quote`
- [ ] `defmacro` → define a macro in the module; macro receives AST args, returns AST
- [ ] Macro expansion: expand macros before transpiling (two-pass: collect defs, then expand)
- [ ] `use Module` → calls `Module.__using__/1` macro, injects code into caller
- [ ] `import Module` → bring functions into scope without prefix
- [ ] `alias Module, as: M` → short name for module
- [ ] Tests: `defmacro unless`, `defmacro my_if`, `use` injection, `__MODULE__`, `__DIR__`
### Phase 4 — protocols
- [ ] `defprotocol P do @spec f(t) :: result end` → defines protocol dict + dispatch fn
- [ ] `defimpl P, for: Type do def f(t) do ... end end` → register implementation
- [ ] Protocol dispatch: `P.f(value)` → look up type of value, find implementation, call it
- [ ] Built-in protocols: `Enumerable`, `Collectable`, `String.Chars`, `Inspect`
- [ ] `Enumerable` implementation for lists, maps, ranges — enables `Enum.*` on custom types
- [ ] `derive` — automatic protocol implementation for simple structs
- [ ] Tests: custom type implementing `Enumerable`, `String.Chars`, protocol fallback
### Phase 5 — structs + behaviours
- [ ] `defstruct [:field1, field2: default]` → defines `%ModuleName{}` struct type
Structs are maps with `__struct__: ModuleName` key + defined fields
- [ ] Struct pattern matching: `%User{name: n} = user`
- [ ] `@behaviour Module` → declares behaviour callbacks; compile-time check
- [ ] `@impl true` / `@impl BehaviourName` → marks function as behaviour implementation
- [ ] Built-in behaviours: `GenServer`, `Supervisor`, `Agent`, `Task`
- [ ] Tests: struct creation, update syntax `%{struct | field: val}`, behaviour callbacks
### Phase 6 — processes + OTP patterns (reuses Erlang runtime)
- [ ] `spawn(fn -> ... end)` / `spawn(M, f, args)` → SX coroutine on scheduler
Reuse `lib/erlang/` process + message queue infrastructure
- [ ] `send(pid, msg)` / `receive do patterns end` — already in Erlang runtime
- [ ] `GenServer` behaviour: `start_link`, `call`, `cast`, `handle_call`, `handle_cast`,
`handle_info`, `init` — implement as SX macros expanding to process + message loop
- [ ] `Agent` — simple state wrapper over GenServer; `Agent.start_link`, `get`, `update`
- [ ] `Task` — async computation; `Task.async`, `Task.await`
- [ ] `Supervisor` — child spec, restart strategy (`one_for_one`, `one_for_all`)
- [ ] Tests: counter GenServer, bank account Agent, parallel Task, supervised worker
### Phase 7 — standard library
- [ ] `Enum.*` — `map`, `filter`, `reduce`, `each`, `into`, `flat_map`, `zip`, `sort`,
`sort_by`, `min_by`, `max_by`, `group_by`, `frequencies`, `count`, `any?`, `all?`,
`find`, `take`, `drop`, `take_while`, `drop_while`, `chunk_every`, `chunk_by`,
`flat_map_reduce`, `scan`, `uniq`, `uniq_by`, `member?`, `empty?`, `sum`, `product`
- [ ] `Stream.*` — lazy versions of Enum; `Stream.map`, `Stream.filter`, `Stream.take`,
`Stream.cycle`, `Stream.iterate`, `Stream.unfold`, `Stream.resource`
Uses SX promises (Phase 9) for laziness
- [ ] `String.*` — `length`, `upcase`, `downcase`, `trim`, `split`, `replace`, `contains?`,
`starts_with?`, `ends_with?`, `slice`, `at`, `graphemes`, `codepoints`, `to_integer`,
`to_float`, `pad_leading`, `pad_trailing`, `duplicate`, `match?`
- [ ] `Map.*` — `new`, `get`, `put`, `delete`, `update`, `merge`, `keys`, `values`,
`to_list`, `from_struct`, `has_key?`, `filter`, `map`, `reject`, `take`, `drop`
- [ ] `List.*` — `first`, `last`, `flatten`, `zip`, `unzip`, `keystore`, `keyfind`,
`wrap`, `duplicate`, `improper?`, `delete`, `insert_at`, `replace_at`
- [ ] `Tuple.*` — `to_list`, `from_list`, `append`, `insert_at`, `delete_at`
- [ ] `Integer.*` / `Float.*` — `parse`, `to_string`, `digits`, `pow`, `is_odd?`, `is_even?`
- [ ] `IO.*` — `puts`, `gets`, `inspect`, `write`, `read` → SX IO perform
- [ ] `Kernel.*` — built-in functions: `is_integer?`, `is_binary?`, `length`, `hd`, `tl`,
`elem`, `put_elem`, `apply`, `raise`, `exit`, `inspect`
- [ ] `inspect/1` / `IO.inspect/2` — debug printing using `Inspect` protocol
### Phase 8 — conformance target
- [ ] Vendor or hand-build 100+ Elixir program tests in `lib/elixir/tests/programs/`
- [ ] Drive scoreboard
## Blockers
_(none yet)_
## Progress log
_Newest first._
_(awaiting phase 1)_

131
plans/elm-on-sx.md
View File

@@ -1,131 +0,0 @@
# Elm-on-SX: Elm 0.19 on the CEK/VM
Compile Elm source to SX AST; the existing CEK evaluator runs it. The unique angle: SX's
reactive island system (`defisland`, signals, `provide`/`context`) is a natural host for
The Elm Architecture — Model/Update/View maps almost directly onto SX's reactive runtime.
This is the only language in the set that targets SX's browser-side reactivity rather than
the server-side evaluator.
End-state goal: **core Elm programs running in the browser via SX islands**, with The Elm
Architecture wired to SX signals. Not a full Elm compiler — no exhaustiveness checking, no
module system, no type inference — but a faithful runtime that can run Elm programs written
in idiomatic style.
## Ground rules
- **Scope:** only touch `lib/elm/**` and `plans/elm-on-sx.md`. Do **not** edit `spec/`,
`hosts/`, `shared/`, or other `lib/<lang>/`.
- **Shared-file issues** go under "Blockers" below with a minimal repro; do not fix here.
- **SX files:** use `sx-tree` MCP tools only.
- **Architecture:** Elm source → Elm AST → SX AST. No standalone Elm evaluator.
- **Type system:** defer. Focus on runtime semantics. Type errors surface at eval time.
- **Commits:** one feature per commit. Keep `## Progress log` updated and tick boxes.
## Architecture sketch
```
Elm source text
│
▼
lib/elm/tokenizer.sx — numbers, strings, idents, operators, indentation-sensitive lexer
│
▼
lib/elm/parser.sx — Elm AST: module, import, type alias, type, let, case, lambda,
│ if, list/tuple/record literals, pipe operator |>
▼
lib/elm/transpile.sx — Elm AST → SX AST
│
▼
lib/elm/runtime.sx — TEA runtime: Program, sandbox, element; Cmd/Sub wrappers;
│ Html.* shims; Browser.* shims
▼
SX island / reactive runtime (browser)
```
Key semantic mappings:
- `Model` → SX signal (`make-signal`)
- `update : Msg -> Model -> Model` → SX signal updater (called on each message)
- `view : Model -> Html Msg` → SX component (re-renders on model signal change)
- `Cmd` → SX `perform` IO request
- `Sub` → SX event listener registered via `dom-listen`
- `Maybe a` → `nil` (Nothing) or value (Just a) — uses ADTs from Phase 6 of primitives
- `Result a b` → ADT `(Ok val)` / `(Err err)`
## Roadmap
### Phase 1 — tokenizer + parser
- [ ] Tokenizer: keywords (`module`, `import`, `type`, `alias`, `let`, `in`, `if`, `then`,
`else`, `case`, `of`, `port`), indentation tokens (indent/dedent/newline), string
literals, number literals, operators (`|>`, `>>`, `<<`, `<|`, `++`, `::`), type vars
- [ ] Parser: module declaration, imports, type aliases, union types, function definitions
with pattern matching, `let`/`in`, `case`/`of`, `if`/`then`/`else`, lambda `\x -> e`,
list literals `[1,2,3]`, tuple literals `(a,b)`, record literals `{x=1, y=2}`,
record update `{ r | x = 1 }`, pipe operator `|>`
- [ ] Skip for phase 1: ports, subscriptions, effects manager, type annotations
- [ ] Tests in `lib/elm/tests/parse.sx`
### Phase 2 — transpile: expressions + pattern matching
- [ ] `elm-eval-ast` entry
- [ ] Arithmetic, string `++`, comparison, boolean ops
- [ ] Lambda → SX `fn`; function application
- [ ] `let`/`in` → SX `let`
- [ ] `if`/`then`/`else` → SX `if`
- [ ] `case`/`of` with constructor, literal, tuple, list, wildcard patterns → SX `cond`
using ADT match (Phase 6 primitives)
- [ ] List ops: `List.map`, `List.filter`, `List.foldl`, `List.foldr`
- [ ] `Maybe` and `Result` as ADTs
- [ ] 30+ eval tests in `lib/elm/tests/eval.sx`
### Phase 3 — The Elm Architecture runtime
- [ ] `Browser.sandbox` — pure TEA loop (no Cmds, no Subs)
`{ init : model, update : msg -> model -> model, view : model -> Html msg }`
Wires to: SX signal for model, SX component for view, message dispatch on user events
- [ ] `Html.*` shims: `div`, `p`, `button`, `input`, `text`, `h1`–`h6`, `ul`, `li`, `a`,
`span`, `img` — emit SX component calls
- [ ] `Html.Attributes.*`: `class`, `id`, `href`, `src`, `type_`, `placeholder`, `value`
- [ ] `Html.Events.*`: `onClick`, `onInput`, `onSubmit`, `onBlur`, `onFocus`
- [ ] `Browser.element` — adds `init` returning `(model, Cmd msg)`, `subscriptions`
- [ ] Demo: counter app (`init=0`, `update Increment m = m+1`, `view` shows count + button)
### Phase 4 — Cmds and Subs
- [ ] `Cmd` — mapped to SX `perform` IO requests. `Cmd.none`, `Cmd.batch`
- [ ] `Http.get`/`Http.post` → SX fetch IO
- [ ] `Sub` — mapped to SX `dom-listen`. `Sub.none`, `Sub.batch`
- [ ] `Browser.Events.onClick`, `onKeyPress`, `onAnimationFrame`
- [ ] `Time.every` — periodic subscription via SX timer IO
- [ ] `Task.perform`/`Task.attempt` — single-shot async operations
### Phase 5 — standard library
- [ ] `String.*` — `length`, `append`, `concat`, `split`, `join`, `trim`, `toUpper`, `toLower`,
`contains`, `startsWith`, `endsWith`, `replace`, `toInt`, `toFloat`, `fromInt`, `fromFloat`
- [ ] `List.*` — `map`, `filter`, `foldl`, `foldr`, `head`, `tail`, `isEmpty`, `length`,
`reverse`, `append`, `concat`, `member`, `sort`, `sortBy`, `indexedMap`, `range`
- [ ] `Dict.*` — SX immutable dict; `fromList`, `toList`, `get`, `insert`, `remove`, `update`,
`member`, `keys`, `values`, `map`, `filter`, `foldl`
- [ ] `Set.*` — SX set primitive (Phase 18); `fromList`, `toList`, `member`, `insert`,
`remove`, `union`, `intersect`, `diff`
- [ ] `Maybe.*` — `withDefault`, `map`, `andThen`, `map2`
- [ ] `Result.*` — `withDefault`, `map`, `andThen`, `mapError`, `toMaybe`
- [ ] `Tuple.*` — `first`, `second`, `pair`, `mapFirst`, `mapSecond`
- [ ] `Basics.*` — `identity`, `always`, `not`, `xor`, `modBy`, `remainderBy`, `clamp`,
`min`, `max`, `abs`, `sqrt`, `logBase`, `e`, `pi`, `floor`, `ceiling`, `round`,
`truncate`, `toFloat`, `isNaN`, `isInfinite`, `compare`
- [ ] `Random.*` — seed-based PRNG via SX IO perform
### Phase 6 — full browser integration
- [ ] `Browser.application` — URL routing, `onUrlChange`, `onUrlRequest`
- [ ] `Browser.Navigation.*` — `pushUrl`, `replaceUrl`, `back`, `forward`
- [ ] `Url.Parser.*` — path segment parsing
- [ ] `Json.Decode.*` — JSON decoder combinators
- [ ] `Json.Encode.*` — JSON encoder
- [ ] `Ports` — `port` keyword; JS interop via SX `host-call`
## Blockers
_(none yet)_
## Progress log
_Newest first._
_(awaiting phase 1)_

145
plans/go-on-sx.md
View File

@@ -1,145 +0,0 @@
# Go-on-SX: Go on the CEK/VM
Compile Go source to SX AST; the existing CEK evaluator runs it. The unique angle: Go's
goroutines and channels map cleanly onto SX's IO suspension machinery (`perform`/`cek-resume`)
— a goroutine is a `cek-step-loop` running in a cooperative scheduler, a channel send/receive
is a `perform` that suspends until the other end is ready.
End-state goal: **core Go programs running**, including goroutines, channels, defer/panic/recover,
interfaces, and structs. Not a full Go compiler — no generics, no CGo, no full stdlib — but
a faithful runtime for idiomatic Go concurrent programs.
## Ground rules
- **Scope:** only touch `lib/go/**` and `plans/go-on-sx.md`. Do **not** edit `spec/`,
`hosts/`, `shared/`, or other `lib/<lang>/`.
- **Shared-file issues** go under "Blockers" below with a minimal repro; do not fix here.
- **SX files:** use `sx-tree` MCP tools only.
- **Architecture:** Go source → Go AST → SX AST. No standalone Go evaluator.
- **Concurrency model:** cooperative, not preemptive. Goroutines yield at channel ops and
`time.Sleep`. A round-robin scheduler in SX drives them.
- **Commits:** one feature per commit. Keep `## Progress log` updated and tick boxes.
## Architecture sketch
```
Go source text
│
▼
lib/go/tokenizer.sx — Go tokens: keywords, idents, string/rune/number literals,
│ operators, semicolon insertion rules
▼
lib/go/parser.sx — Go AST: package, import, var, const, type, func, struct,
│ interface, goroutine, channel ops, defer, select, for range
▼
lib/go/transpile.sx — Go AST → SX AST
│
▼
lib/go/runtime.sx — goroutine scheduler, channel primitives, defer stack,
│ panic/recover, interface dispatch, slice/map ops
▼
CEK / VM
```
Key semantic mappings:
- `go fn()` → spawn new coroutine (SX coroutine primitive, Phase 4 of primitives)
- `ch <- v` (send) → `perform` that suspends until receiver ready; scheduler picks next goroutine
- `v := <-ch` (receive) → `perform` that suspends until sender ready
- `select { case ... }` → scheduler checks all channel readiness, picks first ready
- `defer fn()` → push onto a per-goroutine defer stack; run on return/panic
- `panic(v)` → `raise` the value; `recover()` catches it in deferred function
- `interface{}` → any SX value (duck typed)
- `struct { ... }` → SX hash table with field names as keys
- `slice` → SX vector with length + capacity metadata
- `map[K]V` → SX mutable hash table (Phase 10 of primitives)
## Roadmap
### Phase 1 — tokenizer + parser
- [ ] Tokenizer: keywords (`package`, `import`, `func`, `var`, `const`, `type`, `struct`,
`interface`, `go`, `chan`, `select`, `defer`, `return`, `if`, `else`, `for`, `range`,
`switch`, `case`, `default`, `break`, `continue`, `goto`, `fallthrough`, `map`,
`make`, `new`, `nil`, `true`, `false`), automatic semicolon insertion, string literals
(interpreted + raw `` `...` ``), rune literals `'a'`, number literals (int, float, hex,
octal, binary, complex), operators, slices `[:]`
- [ ] Parser: package clause, imports, top-level `func`/`var`/`const`/`type`; function
bodies: short variable decl `:=`, assignments, `if`/`else`, `for`/`range`, `switch`,
`return`, struct literals, slice literals, map literals, composite literals, type
assertions `v.(T)`, method calls `v.Method(args)`, goroutine `go`, channel ops
`<-ch`, `ch <- v`, `defer`, `select`
- [ ] Tests in `lib/go/tests/parse.sx`
### Phase 2 — transpile: basic Go (no goroutines)
- [ ] `go-eval-ast` entry
- [ ] Arithmetic, string ops, comparison, boolean
- [ ] Variables, short decl, assignment, multiple assignment
- [ ] `if`/`else if`/`else`
- [ ] `for` (C-style), `for range` over slice/map/string
- [ ] Functions: named + anonymous, multiple return values (SX multiple values, Phase 8)
- [ ] Structs → SX hash tables; field access `.field`; struct literals `T{f: v}`
- [ ] Slices → SX vectors; `len`, `cap`, `append`, `copy`, slice expressions `s[a:b]`
- [ ] Maps → SX hash tables; `make(map[K]V)`, `m[k]`, `m[k] = v`, `delete(m, k)`,
comma-ok `v, ok := m[k]`
- [ ] Pointers — modelled as single-element mutable vectors; `&x` creates wrapper, `*p` dereferences
- [ ] `fmt.Println`/`fmt.Printf`/`fmt.Sprintf` → SX IO perform (print)
- [ ] 40+ eval tests in `lib/go/tests/eval.sx`
### Phase 3 — defer / panic / recover
- [ ] Defer stack per function frame — SX list of thunks, run LIFO on return
- [ ] `defer` statement pushes thunk; transpiler wraps function body in try/finally equivalent
- [ ] `panic(v)` → `raise` with Go panic wrapper
- [ ] `recover()` → catches panic value inside a deferred function; returns nil otherwise
- [ ] Panic propagation across call stack until recovered or fatal
- [ ] Tests: defer ordering, panic/recover, panic in goroutine without recover
### Phase 4 — goroutines + channels
- [ ] Coroutine-based goroutine type using SX coroutine primitive (Phase 4 of primitives)
- [ ] Round-robin scheduler in `lib/go/runtime.sx`: maintains run queue, steps each
goroutine one turn at a time, suspends at channel ops
- [ ] Unbuffered channels: `make(chan T)` → rendezvous point; send suspends until receive
and vice versa. Implemented as a pair of waiting queues + `cek-resume`.
- [ ] Buffered channels: `make(chan T, n)` → circular buffer; send only blocks when full,
receive only blocks when empty
- [ ] `close(ch)` — mark channel closed; receivers drain then get zero value + `false`
- [ ] `select` — scheduler inspects all cases, picks a ready one (random if multiple),
blocks if none ready until at least one becomes ready
- [ ] `go fn(args)` — spawns new goroutine on run queue
- [ ] `time.Sleep(d)` — yields current goroutine, re-queues after d milliseconds
(simulated with IO perform timer)
- [ ] Tests: ping-pong, fan-out, fan-in, select with default, range over channel
### Phase 5 — interfaces
- [ ] Interface type → SX dict `{:type "T" :methods {...}}` dispatch table
- [ ] `interface{}` / `any` → any SX value (already implicit)
- [ ] Type assertion `v.(T)` → check `:type` field, panic if mismatch
- [ ] Type switch `switch v.(type) { case T: ... }` → dispatches on `:type`
- [ ] Method sets — structs implement interfaces implicitly if they have the right methods
- [ ] Value vs pointer receivers — pointer receiver gets the mutable vector wrapper
- [ ] Built-in interfaces: `error` (`Error() string`), `Stringer` (`String() string`)
- [ ] Tests: interface satisfaction, type assertion, type switch, error interface
### Phase 6 — standard library subset
- [ ] `fmt` — `Println`, `Printf`, `Sprintf`, `Fprintf`, `Errorf`, `Stringer` dispatch
- [ ] `strings` — `Contains`, `HasPrefix`, `HasSuffix`, `Split`, `Join`, `TrimSpace`,
`ToUpper`, `ToLower`, `Replace`, `Index`, `Count`, `Repeat`
- [ ] `strconv` — `Itoa`, `Atoi`, `FormatFloat`, `ParseFloat`, `ParseInt`, `FormatInt`
- [ ] `math` — full surface via SX math primitives (Phase 15)
- [ ] `sort` — `sort.Slice`, `sort.Ints`, `sort.Strings`
- [ ] `errors` — `errors.New`, `errors.Is`, `errors.As`
- [ ] `sync` — `sync.Mutex` (cooperative — just a boolean flag + goroutine queue),
`sync.WaitGroup`, `sync.Once`
- [ ] `io` — `io.Reader`/`io.Writer` interfaces; `io.ReadAll`; `strings.NewReader`
### Phase 7 — full conformance target
- [ ] Vendor a Go test suite or hand-build 100+ program tests in `lib/go/tests/programs/`
- [ ] Drive scoreboard
## Blockers
_(none yet)_
## Progress log
_Newest first._
_(awaiting phase 1)_

351
plans/hs-bucket-f.md
View File

@@ -1,351 +0,0 @@
# HS Conformance — Bucket F Plan
Based on a full suite run on 2026-04-26. Current score: **~1297/1489 covered** (~87%).
Skipped from runs: tests 197–200 (hypertrace, slow), 615 (slow), 1197–1198 (repeat-forever timeouts).
**⚠ Updated 2026-04-26:** The hs-loop completed significant Bucket D work before being stopped.
`hs-f` branches from `loops/hs` HEAD which already includes:
- MutationObserver mock + `on mutation` dispatch (+7) → **Group 4 likely done**
- Cookie API partial (+3/5) → **Group 5 partially done**
- `elsewhere`/`from elsewhere` + count filters (+7) → **Group 3a/3c partially done**
- Namespaced `def` (+3) → already done
- SourceInfo E38 (+4) + WebWorker E39 (+1) → already merged
**The Bucket F agent must run `hs_test_run` on each group's suite before implementing,
to verify what's actually still failing. Skip any group that already passes.**
Total remaining failures: ~193. Broken into groups below.
---
## Group 0 — Bucket E payoff (~47 tests, will land automatically)
These are already implemented or in-flight on Bucket E branches. Once merged they close ~47 tests.
| Suite | Tests | Status |
|-------|------:|-------|
| `hs-upstream-core/tokenizer` | 17 | E37 in progress |
| `hs-upstream-socket` | 16 | E36 in progress |
| `hs-upstream-fetch` | 8 | E40 in progress |
| `hs-upstream-core/sourceInfo` | 4 | E38 done, not yet merged |
| `hs-upstream-worker` | 1 | E39 done, not yet merged |
| E37 string interpolation bug | 1 | E37 |
**Do not plan these — they resolve when Bucket E merges.**
---
## Group 1 — Null safety reporting (+7)
**Suite:** `hs-upstream-core/runtimeErrors`
**Failures:** 7 tests, all "Expected `'#doesntExist' is null`, got ``"
**What's needed:** When a command like `put`, `increment`, `decrement`, `default`, `remove`, `settle`, `transition` receives a null element (e.g. `#doesntExist`), HS must throw a structured null-safety error with the element reference in the message. The null check + error format is already designed in Bucket D #31 (cluster 31 of `hs-conformance-to-100.md`).
**Estimate:** +7. Straightforward — null guard at command dispatch entry.
---
## Group 2 — `tell` semantics (+3)
**Suite:** `hs-upstream-tell`
**Failures:**
- `attributes refer to the thing being told` — Expected `bar`, got ``
- `your symbol represents the thing being told` — Expected `foo`, got ``
- `does not overwrite the me symbol` — assertion fail
**What's needed:** Inside a `tell X` block, `you`/`your` must resolve to X, attribute refs must resolve against X, and `me` must retain its original value (not be rebound to X). Currently `tell` rebinds `me` instead of introducing a separate `you` binding.
**Estimate:** +3. Scoping fix in the `tell` command handler.
---
## Group 3 — `on` event handler features (+19, skip-list)
**Suite:** `hs-upstream-on`
**34 tests on skip-list.** Prioritise tractable subsets:
### 3a — Event filtering by count (+6)
- `can filter events based on count`
- `can filter events based on count range`
- `can filter events based on unbounded count range`
- `can mix ranges`
- `on first click fires only once`
- `multiple event handlers at a time are allowed to execute with the every keyword`
The `on (N)`, `on (N to M)`, `on first`, `every` modifiers. Parser + runtime counter state per handler.
### 3b — `finally` blocks (+6)
- `basic finally blocks work`
- `async basic finally blocks work`
- `exceptions in finally block don't kill the event queue`
- `async exceptions in finally block don't kill the event queue`
- `finally blocks work when exception thrown in catch`
- `async finally blocks work when exception thrown in catch`
`on … catch … finally` analogous to JS try/catch/finally. Needs a finally-frame in the CEK machine (similar to dynamic-wind).
### 3c — `elsewhere` modifier (+2)
- `supports "elsewhere" modifier`
- `supports "from elsewhere" modifier`
`on click elsewhere` = click outside the element. Needs a global listener + target exclusion check.
### 3d — Exception events (+3)
- `rethrown exceptions trigger 'exception' event`
- `uncaught exceptions trigger 'exception' event`
- `can catch exceptions thrown in hyperscript functions`
- `can catch exceptions thrown in js functions`
When an unhandled exception escapes an `on` handler, HS must dispatch an `exception` CustomEvent on the element.
### 3e — Element removal cleanup (+2)
- `listeners on other elements are removed when the registering element is removed`
- `listeners on self are not removed when the element is removed`
Cleanup hook via MutationObserver watching for element removal.
### Deferred (skip-list, complex):
- `can be in a top level script tag` — requires script tag re-initialisation
- `can ignore when target doesn't exist` — target null guard
- `can handle an or after a from clause` — parser edge case
- `each behavior installation has its own event queue` — behavior isolation
---
## Group 4 — MutationObserver / `on mutation` (+10)
**Suite:** `hs-upstream-on` (mutation subset, skip-list)
**Tests:**
- `can listen for attribute mutations`
- `can listen for attribute mutations on other elements`
- `can listen for childList mutations`
- `can listen for general mutations`
- `can listen for multiple mutations`
- `can listen for multiple mutations 2`
- `can listen for specific attribute mutations`
- `can pick event properties out by name`
- `can pick detail fields out by name`
- `attribute observers are persistent (not recreated on re-run)` (hs-upstream-when)
**What's needed:** MutationObserver mock in the test runner (`hs-run-filtered.js`) + `on mutation` command in the parser/runtime. Already prototyped in Bucket D #32.
**Estimate:** +10.
---
## Group 5 — Cookie API (+5)
**Suite:** `hs-upstream-expressions/cookies`
All 5 tests untranslated. Cookie read/write as an expression: `cookies.name`, `set cookies.name to val`, `cookies.name is undefined`. Needs `document.cookie` mock in runner + cookie-expression parse path.
**Estimate:** +5. Self-contained.
---
## Group 6 — Block literals (+4)
**Suite:** `hs-upstream-expressions/blockLiteral`
All 4 untranslated. Syntax: `[x | x + 1]` — an inline lambda. Used as a first-class value passable to `map`, `filter` etc.
- `basic block literals work`
- `basic identity works`
- `basic two arg identity works`
- `can map an array`
**Estimate:** +4. Parser addition + runtime callable wrapping.
---
## Group 7 — Async logical operators (+5)
**Suite:** `hs-upstream-expressions/logicalOperator`
Promise-aware `and`/`or`:
- `and short-circuits when lhs promise resolves to false`
- `or short-circuits when lhs promise resolves to true`
- `or evaluates rhs when lhs promise resolves to false`
- `should short circuit with and expression`
- `should short circuit with or expression`
**What's needed:** `and`/`or` must await promise operands before short-circuiting. Currently they evaluate eagerly without awaiting.
**Estimate:** +5. Async await integration in logical operator eval.
---
## Group 8 — `evalStatically` (+3)
**Suite:** `hs-upstream-core/evalStatically`
- `throws on math expressions`
- `throws on symbol references`
- `throws on template strings`
`_hyperscript.evaluate(src, {}, { throwErrors: true })` must throw synchronously for expressions with side-effects or unresolved symbols. Currently the static evaluator doesn't gate on `throwErrors`.
**Estimate:** +3. Flag-gated error throw path.
---
## Group 9 — Parse error API (+6)
**Suite:** `hs-upstream-core/parser` + `hs-upstream-core/bootstrap`
- `basic parse error messages work`
- `fires hyperscript:parse-error event with all errors`
- `parse error at EOF on trailing newline does not crash`
- `_hyperscript() evaluate API still throws on first error`
- `fires hyperscript:before:init and hyperscript:after:init` (bootstrap)
- `hyperscript:before:init can cancel initialization` (bootstrap)
**What's needed:**
- Parser must emit a `hyperscript:parse-error` CustomEvent on `document` when compilation fails, with the error list as detail.
- `hyperscript:before:init` / `hyperscript:after:init` lifecycle events dispatched around element initialization.
- `before:init` can cancel (return false / `event.preventDefault()`).
**Estimate:** +6. Event dispatch hooks in the bootstrap/init path.
---
## Group 10 — `as` expression conversions (+8)
**Suite:** `hs-upstream-expressions/asExpression`
Currently 30/42 = 12 failures. Tractable subset:
- `converts a NodeList into HTML` — NodeList → outerHTML join
- `converts strings into fragments` — string → DocumentFragment
- `converts elements into fragments` — element → DocumentFragment
- `converts arrays into fragments` — array of elements → DocumentFragment
- `converts array as Set` — array → Set (dedup)
- `converts object as Map` — object → Map
- `can accept custom conversions` — `as MyType` via registered converter
- `can use the a modifier if you like` — `as a Number` synonym
Two already-broken non-skip failures:
- `converts a complete form into Values` — Expected `dog`, got ``
- `converts multiple selects with programmatically changed selections` — Expected `cat`, got `dog`
**Estimate:** +8 for the tractable subset. Custom converters and Map/Set require runtime additions.
---
## Group 11 — Miscellaneous runtime bugs (+12)
Small scattered failures, each 1–3 tests:
| Suite | Failure | Likely cause |
|-------|---------|-------------|
| `hs-upstream-put` | `properly processes hyperscript` ×3 (got 40, expected 42) | Off-by-one in `put ... before/after` reprocessing |
| `hs-upstream-put` | `waits on promises` | Promise await missing from put target eval |
| `hs-upstream-js` | `can return values to _hyperscript` | JS block return value not threaded back |
| `hs-upstream-js` | `can do both of the above` | Same |
| `hs-upstream-js` | `handles rejected promises without hanging` | Rejected promise in js block uncaught |
| `hs-upstream-set` | `set waits on promises` | Same as put |
| `hs-upstream-set` | `can set into indirect style ref 3` | Indirect style ref path bug |
| `hs-upstream-hide` | `retain original display` | `none` vs `block` display tracking |
| `hs-upstream-toggle` | `toggle for fixed time` | Timed toggle assertion timing |
| `hs-upstream-transition` | `initial value` | `initial` keyword not restoring computed value |
| `hs-upstream-expressions/arrayLiteral` | `objects with _order` | `_order` internal key leaking into equality check |
| `hs-upstream-core/bootstrap` | 4 bugs | Event handler bugs in reinit, cleanup, respond |
| `hs-upstream-expressions/closest` | `where clause` | `where` consumed by `closest` instead of outer |
| `hs-upstream-core/scoping` | 2 bugs | Pseudo-possessive, built-in variable clash |
**Estimate:** +12 once individually triaged.
---
## Group 12 — Formerly "hard floor" — now in scope
Initial assessment was wrong — these are medium difficulty, not genuinely hard. All 16 are worth attempting.
| Suite | Tests | Actual difficulty | What's needed |
|-------|------:|-------------------|---------------|
| `hs-upstream-breakpoint` | 2 | **Trivial** | No-op parser command + generator translation. Design: `plans/designs/f-breakpoint.md` |
| `hs-upstream-expressions/logicalOperator` (unparenthesized error) | 2 | Low | Parser strictness: `1 + 2 + 3` should throw "ambiguous operator precedence" |
| `hs-upstream-core/security` | 1 | Medium | `_hyperscript.config.disableScripting = true` guard at `hs-activate!` time |
| `hs-upstream-expressions/asExpression` (Date, custom dynamic) | 3 | Medium | `as a Date` → `new Date(val)`; custom converters via `_hyperscript.addType` registry |
| `hs-upstream-on` (remaining skip-list) | ~8 | Medium | Script tag reinit (MutationObserver on `<script>` changes); behavior isolation queue |
**Breakpoint** — both tests just check that `breakpoint` *parses* without throwing. No devtools. See design doc.
**Security** — test creates a div with `_="on click add .foo"`, activates it, clicks, asserts `.foo` is NOT added. This is a `disableScripting` config flag: when set, `hs-activate!` skips initialisation. One guard at activation entry.
**Unparenthesized operator error** — `1 + 2 + 3` in HS is ambiguous (no defined associativity for chained operators). Parser should throw a parse error rather than silently picking left-associativity. Needs a "multiple operators at same precedence level" check after parsing a binary expression.
**Sequence these last** — after groups 1–11 are done. Breakpoint is a 30-min job and should be pulled into the quick-wins batch.
---
## Summary
| Group | Tests | Difficulty | Design doc |
|-------|------:|-----------|-----------|
| 0 — Bucket E payoff | ~47 | Free | (E branches) |
| 1 — Null safety | +7 | Low | `f1-null-safety.md` |
| 2 — `tell` semantics | +3 | Low | `f2-tell.md` |
| 3 — `on` event features | +19 | Medium | (TBD) |
| 4 — MutationObserver | +10 | Medium | (TBD) |
| 5 — Cookie API | +5 | Low | `f5-cookies.md` |
| 6 — Block literals | +4 | Medium | (TBD) |
| 7 — Async logical ops | +5 | Medium | (TBD) |
| 8 — evalStatically | +3 | Low | `f8-eval-statically.md` |
| 9 — Parse error API | +6 | Medium | (TBD) |
| 10 — `as` conversions | +8 | Medium | (TBD) |
| 11 — Misc bugs | +12 | Low–Medium | (TBD) |
| 12 — Breakpoint | +2 | Trivial | `f-breakpoint.md` |
| 12 — Security config | +1 | Medium | (TBD) |
| 12 — Unparenthesized op error | +2 | Low | (TBD) |
| 12 — `as` Date + custom | +3 | Medium | (TBD) |
| 12 — `on` remaining | +8 | Medium | (TBD) |
| **Total recoverable** | **~145** | | |
## Group 13 — Step limit + `meta.caller` (+5 → 100%)
Design doc: `plans/designs/f13-step-limit-and-meta.md`
| Test | Failure | Fix |
|------|---------|-----|
| `repeat forever works` (×2) | Step limit — loop terminates in 5 iterations but two compilation warm-up guards eat the budget first | Raise `HS_STEP_LIMIT` to 2,000,000 in `hs-run-filtered.js` |
| `hypertrace is reasonable` | Step limit — trace recorder may be on globally inflating step count | Raise step limit; disable global trace if on |
| `query template returns values` | Step limit (37s) — CSS template query `<${"p"}/>` may rebuild on every call | Raise step limit; cache compiled template query if still slow |
| `has proper stack from event handler` | Wrong value — `meta.caller.meta.feature.type` returns `""` instead of `"onFeature"` | Implement `meta` dict in `def` function call scope; wire `{:feature {:type "onFeature"}}` into event handler contexts |
---
## Summary
| Group | Tests | Difficulty | Design doc |
|-------|------:|-----------|-----------|
| 0 — Bucket E payoff | ~47 | Free | (E branches) |
| 1 — Null safety | +7 | Low | `f1-null-safety.md` |
| 2 — `tell` semantics | +3 | Low | `f2-tell.md` |
| 3 — `on` event features | +19 | Medium | (TBD) |
| 4 — MutationObserver | +10 | Medium | (TBD) |
| 5 — Cookie API | +5 | Low | `f5-cookies.md` |
| 6 — Block literals | +4 | Medium | (TBD) |
| 7 — Async logical ops | +5 | Medium | (TBD) |
| 8 — evalStatically | +3 | Low | `f8-eval-statically.md` |
| 9 — Parse error API | +6 | Medium | (TBD) |
| 10 — `as` conversions | +8 | Medium | (TBD) |
| 11 — Misc bugs | +12 | Low–Medium | (TBD) |
| 12 — Breakpoint | +2 | Trivial | `f-breakpoint.md` |
| 12 — Security config | +1 | Medium | (TBD) |
| 12 — Unparenthesized op error | +2 | Low | (TBD) |
| 12 — `as` Date + custom | +3 | Medium | (TBD) |
| 12 — `on` remaining | +8 | Medium | (TBD) |
| 13 — Step limit + meta.caller | +5 | Low | `f13-step-limit-and-meta.md` |
| **Total recoverable** | **~150** | | |
**Projected ceiling: ~1299 + 47 + 150 = 1496/1496 = 100%**
---
## Suggested sequencing for Bucket F loop
1. Groups 1, 2, 5, 8 + breakpoint — quick wins, design docs ready, ~20 tests
2. Groups 11 misc bugs — isolate and fix one suite at a time
3. Group 9 parse error API — hooks into bootstrap, needs care
4. Groups 3a, 3b (on-count + finally) — medium, self-contained
5. Groups 4 (MutationObserver) + 3c/3d/3e (elsewhere, exceptions, cleanup)
6. Groups 6, 7 (block literals, async logical ops) — new syntax
7. Group 10 (as conversions) — additive, low regression risk
8. Group 12 remainder — security config, unparenthesized op error, as-Date, on remaining
Each group should get a design doc in `plans/designs/f<N>-<name>.md` before implementation starts.

229
plans/koka-on-sx.md
View File

@@ -1,229 +0,0 @@
# Koka-on-SX: Koka on the CEK/VM
Implement a Koka interpreter on SX. The unique angle: Koka's algebraic effects and
handlers map directly onto SX's `perform`/`cek-resume` machinery — this is the language
that will stress-test whether SX's effect system is principled enough, and expose any
gaps. Every other language in the set works around effects ad-hoc; Koka makes them the
primary abstraction.
End-state goal: **core Koka programs running on the SX CEK evaluator**, with algebraic
effect handlers wired through `perform`/`cek-resume`. Not a full Koka compiler — no type
inference, no row-polymorphic effect types, no LLVM backend — but a faithful runtime for
idiomatic Koka programs.
## What Koka adds that nothing else covers
- **Structured effect declarations**: `effect state<s> { fun get() : s; fun set(s) : () }`
— named, typed effect operations, not just untyped `perform` tokens
- **Resumable handlers**: `handler { return(x) -> x; get() -> resume(0); set(x) -> resume(()) }`
— multi-shot continuations, handlers as first-class values
- **Effect polymorphism**: functions declare their effect set (`a -> <state<int>,console> b`)
— exposes whether SX can track which effects are in scope
- **Tail-resumptive handlers**: most practical handlers resume exactly once, which should
be optimisable — tests whether the CEK machine can detect and collapse this
- **Algebraic data types as the foundation**: `type maybe<a> { Nothing; Just(value: a) }`
— exercises the Phase 6 ADT primitive directly
## Ground rules
- **Scope:** only touch `lib/koka/**` and `plans/koka-on-sx.md`. Do **not** edit `spec/`,
`hosts/`, `shared/`, or other `lib/<lang>/`.
- **Shared-file issues** go under "Blockers" below with a minimal repro; do not fix here.
- **SX files:** use `sx-tree` MCP tools only.
- **Architecture:** Koka source → Koka AST → interpret directly via CEK. No separate
Koka evaluator — host the semantics in SX, run on the existing CEK machine.
- **Effect types:** defer type inference entirely. Track effects at runtime only — an
unhandled effect at the top level raises a runtime error, not a type error.
- **Commits:** one feature per commit. Keep `## Progress log` updated and tick boxes.
## Architecture
```
Koka source text
│
▼
lib/koka/tokenizer.sx — keywords, operators, indent-sensitivity, type-level syntax
│
▼
lib/koka/parser.sx — Koka AST: fun, val, effect, handler, with, match, resume,
│ return clause, ADT definitions, basic type expressions
▼
lib/koka/eval.sx — Koka AST → CEK evaluation via SX primitives:
│ ADT (define-type/match from Phase 6)
│ Effects (perform/cek-resume from spec/evaluator.sx)
│ Coroutines optional (Phase 4 primitives)
▼
SX CEK evaluator (both JS and OCaml hosts)
```
Key semantic mappings:
| Koka construct | SX mapping |
|---------------|-----------|
| `fun f(x) body` | `(define (f x) body)` |
| `val x = expr` | `(let ((x expr)) ...)` |
| `effect E { fun op() : t }` | register effect tag `E/op` in effect env |
| `op()` inside handler scope | `(perform (list "E" "op" args))` |
| `handler { return(x)->e; op()->resume(v) }` | `(guard ...)` + `cek-resume` |
| `with handler { body }` | install handler for duration of body |
| `match x { Nothing -> e1; Just(v) -> e2 }` | SX `(match x ...)` via Phase 6 ADT |
| `type maybe<a> { Nothing; Just(value:a) }` | `(define-type maybe (Nothing) (Just value))` |
| `resume(v)` in handler | `(cek-resume k v)` where k is captured continuation |
| `return(x) -> expr` | final-value clause when no effect fires |
## Koka semantics in brief
### Effects and handlers
```koka
effect console
fun println(s : string) : ()
fun greet(name : string) : <console> ()
println("Hello, " ++ name)
fun main()
with handler
return(x) -> x
println(s) -> { print-string(s ++ "\n"); resume(()) }
greet("world")
```
- `effect console` declares an effect with one operation `println`
- `greet` uses `console` — any call to `println` inside will look up the nearest
enclosing handler
- `with handler { ... }` installs a handler; `resume(())` continues the suspended
computation
### Multi-shot resumption
```koka
effect choice
fun choose() : bool
fun xor(p : bool, q : bool) : <choice> bool
val a = choose()
val b = choose()
(a || b) && !(a && b)
fun all-results()
with handler
return(x) -> [x]
choose() -> resume(True) ++ resume(False)
xor(True, False)
// => [True, True, False, True]
```
This is the test that exposes whether `cek-resume` supports multi-shot (calling the
same continuation twice). SX's delimited continuations do support this — Koka will
verify it end-to-end.
## Roadmap
### Phase 1 — Tokenizer + parser (core expressions)
- [ ] Tokenizer: keywords (`fun`, `val`, `effect`, `handler`, `with`, `match`, `return`,
`resume`, `type`, `alias`, `if`, `then`, `else`, `fn`), operators (`++`, `->`,
`|>`, `:`, `<`, `>`, `,`), identifiers, numbers, strings, booleans
- [ ] Parser — expressions:
- literals: int, float, bool (`True`/`False`), string
- `val x = e` bindings
- `fun f(x, y) body` definitions
- `if c then e1 else e2`
- `match x { Pat -> e; ... }`
- lambda `fn(x) -> e`
- function application `f(x, y)`
- infix operators: `++`, `+`, `-`, `*`, `/`, `==`, `!=`, `<`, `>`, `&&`, `||`
- pipe `|>`: `x |> f` = `f(x)`
- [ ] Tests: `lib/koka/tests/parse.sx` — 40+ parse round-trip tests
### Phase 2 — ADT definitions + match
- [ ] Parser: `type name<a> { Ctor1; Ctor2(field: t); ... }` declarations
- [ ] Eval: map to SX `define-type` + `match` (requires Phase 6 primitives)
- [ ] Built-in: `maybe<a>` (Nothing / Just), `result<a,e>` (Ok / Error), `list<a>` (Nil / Cons)
- [ ] Tests: ADT construction, matching, nested patterns — 25+ tests
### Phase 3 — Core evaluator
- [ ] `koka-eval` entry: walks Koka AST, evaluates in SX env
- [ ] Arithmetic, string `++`, comparison, boolean ops
- [ ] `val`/`let` binding
- [ ] Function definitions and application (first-class functions)
- [ ] `if`/`then`/`else`
- [ ] `match` with constructor, literal, variable, wildcard patterns
- [ ] Basic list ops: `map`, `filter`, `foldl`, `length`, `head`, `tail`
- [ ] Tests: `lib/koka/tests/eval.sx` — 40+ tests, pure expressions only
### Phase 4 — Effect system
- [ ] Effect declaration: `(koka-declare-effect! "console" (list "println"))`
registers operations in a global effect registry
- [ ] Effect operation call: when `println(s)` is evaluated inside a handler scope,
emit `(perform (list :effect "console" :op "println" :args (list s)))`
- [ ] Handler installation: `with handler { return(x)->e; println(s)->resume(v) }`
installs a `guard`-like frame that catches `perform` signals matching the effect,
binds arguments, and exposes `resume` as a callable that invokes `cek-resume`
- [ ] `resume(v)`: calls `(cek-resume captured-k v)` where `captured-k` is the
continuation captured at the `perform` point
- [ ] `return(x) -> e` clause: handles the normal return value when no effect fires
- [ ] Tests: `lib/koka/tests/effects.sx` — 30+ tests:
- basic handler (state, console, exception)
- unhandled effect → runtime error
- nested handlers (inner shadows outer)
- multi-shot resumption (choice effect — the key test)
- tail-resumptive handler (resumes exactly once — verify no extra allocation)
### Phase 5 — Standard effect library
- [ ] `console` effect: `println`, `print`, `readline` (mock)
- [ ] `exn` effect: `throw`, `catch` wrappers
- [ ] `state<s>` effect: `get`, `set`, `modify`
- [ ] `async` effect: `await` mapped to SX `perform` IO suspension
- [ ] Tests: programs using each stdlib effect — 20+ tests
### Phase 6 — Classic Koka programs as integration tests
- [ ] `counter.koka` — stateful counter via state effect
- [ ] `choice.koka` — multi-shot choice generating all results
- [ ] `iterator.koka` — yield-based iteration via a custom effect
- [ ] `exception.koka` — structured exception handling
- [ ] `coroutine.koka` — producer/consumer via two interleaved effects
- [ ] Each as a self-contained test in `lib/koka/tests/programs.sx`
## Key blockers / dependencies
- **Phase 6 ADT primitive** (`define-type`/`match`) — required before Phase 2.
Track: `plans/agent-briefings/primitives-loop.md` Phase 6.
- **Multi-shot continuations** — `cek-resume` must support calling the same
continuation multiple times. Verify with: `(let ((k #f)) (perform 'x) ...)` called
twice. This should already work given the multi-shot delimited continuation work.
- **Effect handler stack** — SX's `guard` is not quite the right primitive for
deep-handler semantics. May need `(with-handler effect-tag handler-fn body)` as a
new evaluator form, or can be emulated via `guard` + `perform` reshaping.
## Comparison to other languages in the set
| Language | Effect model |
|----------|-------------|
| Lua | none (errors only) |
| Prolog | none (cuts only) |
| Erlang | message-passing (not algebraic) |
| Haskell | IO monad (monadic, not algebraic) |
| JS | promise/async-await (one-shot) |
| Ruby | exceptions + fibers |
| **Koka** | **algebraic effects + multi-shot handlers** |
Koka is the only language that uses SX's effect system as its *primary* computational
model. It will expose whether `perform`/`cek-resume` is sufficient or needs typed effect
tagging, scoping rules, and a handler stack distinct from `guard`.
## Progress log
_Newest first._
- _(none yet)_
## Blockers
- ADT primitive (Phase 6 of primitives-loop) must land before Phase 2 starts.

138
plans/minikanren-on-sx.md
View File

@@ -1,138 +0,0 @@
# miniKanren-on-SX: relational programming on the CEK/VM
miniKanren is not a language to parse — it is an **embedded DSL** implemented as a library
of SX functions. No tokenizer, no transpiler. The entire system is a set of `define` forms
in `lib/minikanren/`. Programs are SX expressions using the miniKanren API.
The unique angle: SX's delimited continuation machinery (`perform`/`cek-resume`, call/cc)
maps almost perfectly to the search monad miniKanren needs. Backtracking is cooperative
suspension, not a separate trail machine. This is the cleanest possible host for miniKanren.
End-state goal: **full core miniKanren** (`run`, `fresh`, `==`, `conde`, `condu`, `onceo`,
`project`, `matche`) + **core.logic-style relations** (`appendo`, `membero`, `listo`,
`numbero`, etc.) + **arithmetic constraints** (`fd` domain, `CLP(FD)` subset).
## Ground rules
- **Scope:** only touch `lib/minikanren/**` and `plans/minikanren-on-sx.md`. Do **not**
edit `spec/`, `hosts/`, `shared/`, or other `lib/<lang>/`.
- **Shared-file issues** go under "Blockers" below with a minimal repro; do not fix here.
- **SX files:** use `sx-tree` MCP tools only.
- **Architecture:** pure library — no source parser. Programs are written in SX using the API.
- **Reference:** *The Reasoned Schemer* (Friedman/Byrd/Kiselyov) + Byrd's dissertation.
- **Commits:** one feature per commit. Keep `## Progress log` updated and tick boxes.
## Architecture sketch
```
SX program using miniKanren API
│
├── lib/minikanren/unify.sx — terms, variables, walk, unification, occurs check
├── lib/minikanren/substitution.sx — substitution as association list / hash table
├── lib/minikanren/stream.sx — lazy streams of substitutions (via delay/force)
├── lib/minikanren/goals.sx — == / fresh / conde / condu / onceo / project / matche
├── lib/minikanren/run.sx — run* / run n — drive the search, extract answers
├── lib/minikanren/relations.sx — standard relations: appendo, membero, listo, etc.
└── lib/minikanren/clpfd.sx — arithmetic constraints (CLP(FD) subset)
```
Key semantic mappings:
- **Logic variable** → SX vector of length 1 (mutable box); `make-var` creates fresh one;
`walk` follows the substitution chain
- **Substitution** → SX association list (or hash table for performance) mapping var → term
- **Stream of substitutions** → lazy list using `delay`/`force` (Phase 9 of primitives)
- **Goal** → SX function `substitution → stream-of-substitutions`
- **`==`** → unifies two terms, extending substitution or failing (empty stream)
- **`fresh`** → introduces new logic variables; `(fresh (x y) goal)` → goal with x, y bound
- **`conde`** → interleave streams from multiple goal clauses (depth-first with interleaving)
- **`run n`** → drive the stream, collect first n substitutions, reify answers
## Roadmap
### Phase 1 — variables + unification
- [ ] `make-var` → fresh logic variable (unique mutable box)
- [ ] `var?` `v` → bool — is this a logic variable?
- [ ] `walk` `term` `subst` → follow substitution chain to ground term or unbound var
- [ ] `walk*` `term` `subst` → deep walk (recurse into lists/dicts)
- [ ] `unify` `u` `v` `subst` → extended substitution or `#f` (failure)
Handles: var/var, var/term, term/var, list unification, number/string/symbol equality.
No occurs check by default; `unify-check` with occurs check as opt-in.
- [ ] Empty substitution `empty-s` = `(list)` (empty assoc list)
- [ ] Tests in `lib/minikanren/tests/unify.sx`: ground terms, vars, lists, failure, occurs
### Phase 2 — streams + goals
- [ ] Stream type: `mzero` (empty stream = `nil`), `unit s` (singleton = `(list s)`),
`mplus` (interleave two streams), `bind` (apply goal to stream)
- [ ] Lazy streams via `delay`/`force` — mature pairs for depth-first, immature for lazy
- [ ] `==` goal: `(fn (s) (let ((s2 (unify u v s))) (if s2 (unit s2) mzero)))`
- [ ] `succeed` / `fail` — trivial goals
- [ ] `fresh` — `(fn (f) (fn (s) ((f (make-var)) s)))` — introduces one var; `fresh*` for many
- [ ] `conde` — interleaving disjunction of goal lists
- [ ] `condu` — committed choice (soft-cut): only explores first successful clause
- [ ] `onceo` — succeeds at most once
- [ ] Tests: basic goal composition, backtracking, interleaving
### Phase 3 — run + reification
- [ ] `run*` `goal` → list of all answers (reified)
- [ ] `run n` `goal` → list of first n answers
- [ ] `reify` `term` `subst` → replace unbound vars with `_0`, `_1`, ... names
- [ ] `reify-s` → builds reification substitution for naming unbound vars consistently
- [ ] `fresh` with multiple variables: `(fresh (x y z) goal)` sugar
- [ ] Query variable conventions: `q` as canonical query variable
- [ ] Tests: classic miniKanren programs — `(run* q (== q 1))` → `(1)`,
`(run* q (conde ((== q 1)) ((== q 2))))` → `(1 2)`,
Peano arithmetic, `appendo` preview
### Phase 4 — standard relations
- [ ] `appendo` `l` `s` `ls` — list append, runs forwards and backwards
- [ ] `membero` `x` `l` — x is a member of l
- [ ] `listo` `l` — l is a proper list
- [ ] `nullo` `l` — l is empty
- [ ] `pairo` `p` — p is a pair (cons cell)
- [ ] `caro` `p` `a` — car of pair
- [ ] `cdro` `p` `d` — cdr of pair
- [ ] `conso` `a` `d` `p` — cons
- [ ] `firsto` / `resto` — aliases for caro/cdro
- [ ] `reverseo` `l` `r` — reverse of list
- [ ] `flatteno` `l` `f` — flatten nested lists
- [ ] `permuteo` `l` `p` — permutation of list
- [ ] `lengtho` `l` `n` — length as a relation (Peano or integer)
- [ ] Tests: run each relation forwards and backwards; generate from partial inputs
### Phase 5 — `project` + `matche` + negation
- [ ] `project` `(x ...) body` — access reified values of logic vars inside a goal;
escapes to ground values for arithmetic or string ops
- [ ] `matche` — pattern matching over logic terms (extension from core.logic)
`(matche l ((head . tail) goal) (() goal))`
- [ ] `conda` — soft-cut disjunction (like Prolog `->`)
- [ ] `condu` — committed choice (already in phase 2; refine semantics here)
- [ ] `nafc` — negation as finite failure with constraint
- [ ] Tests: Zebra puzzle, N-queens, Sudoku via `project`, family relations via `matche`
### Phase 6 — arithmetic constraints CLP(FD)
- [ ] Finite domain variables: `fd-var` with domain `[lo..hi]`
- [ ] `in` `x` `domain` — constrain x to domain
- [ ] `fd-eq` `x` `y` — x = y (constraint propagation)
- [ ] `fd-neq` `x` `y` — x ≠ y
- [ ] `fd-lt` `fd-lte` `fd-gt` `fd-gte` — ordering constraints
- [ ] `fd-plus` `x` `y` `z` — x + y = z (constraint)
- [ ] `fd-times` `x` `y` `z` — x * y = z
- [ ] Arc consistency propagation — when domain narrows, propagate to constrained vars
- [ ] Labelling: `fd-run` drives search by splitting domains when propagation stalls
- [ ] Tests: send-more-money, N-queens with CLP(FD), map coloring, cryptarithmetic
### Phase 7 — tabling (memoization of relations)
- [ ] `tabled` annotation: memoize calls to a relation using a hash table
- [ ] Prevents infinite loops in recursive relations like `patho` on cyclic graphs
- [ ] Producer/consumer scheduling for tabled relations (variant of SLG resolution)
- [ ] Tests: cyclic graph reachability, mutual recursion, Fibonacci via tabling
## Blockers
_(none yet)_
## Progress log
_Newest first._
_(awaiting phase 1)_

315
plans/ocaml-on-sx.md
View File

@@ -1,315 +0,0 @@
# OCaml-on-SX: OCaml + ReasonML + Dream on the CEK/VM
The meta-circular demo: SX's native evaluator is OCaml, so implementing OCaml on top of
SX closes the loop — the source language of the host is running inside the host it
compiles to. Beyond the elegance, it's practically useful: once OCaml expressions run on
the SX CEK/VM you get Dream (a clean OCaml web framework) almost for free, and ReasonML
is a syntax variant that shares the same transpiler output.
End-state goal: **OCaml programs running on the SX CEK/VM**, with enough of the standard
library to support Dream's middleware model. Dream-on-SX is the integration target —
a `handler`/`middleware`/`router` API that feels idiomatic while running purely in SX.
ReasonML (Phase 8) adds an alternative syntax frontend that targets the same transpiler.
## What this covers that nothing else in the set does
- **Strict ML semantics** — unlike Haskell, OCaml is call-by-value with explicit `Lazy.t`
for laziness. Pattern match is exhaustive. Polymorphic variants. Structural equality.
- **First-class modules and functors** — modules as values (phase 4); functors as SX
higher-order functions over module records. Unlike Haskell typeclasses, OCaml's module
system is explicit and compositional.
- **Mutable state without monads** — `ref`, `:=`, `!` are primitives. Arrays. `Hashtbl`.
The IO model is direct; `Lwt`/Dream map to `perform`/`cek-resume` for async.
- **Dream's composable HTTP model** — `handler = request -> response promise`,
`middleware = handler -> handler`. Algebraically clean; `@@` composition maps to SX
function composition trivially.
- **ReasonML** — same semantics, JS-friendly surface syntax. JSX variant pairs with SX
component rendering.
## Ground rules
- **Scope:** only touch `lib/ocaml/**`, `lib/dream/**`, `lib/reasonml/**`, and
`plans/ocaml-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, or other
`lib/<lang>/`.
- **Shared-file issues** go under "Blockers" below with a minimal repro; do not fix here.
- **SX files:** use `sx-tree` MCP tools only.
- **Architecture:** OCaml source → AST → SX AST → CEK. No standalone OCaml evaluator.
The OCaml AST is walked by an `ocaml-eval` function in SX that produces SX values.
- **Type system:** deferred until Phase 5. Phases 1–4 are intentionally untyped —
get the evaluator right first, then layer HM inference on top.
- **Dream:** implemented as a library in Phase 7; no separate build step. `Dream.run`
wraps SX's existing HTTP server machinery via `perform`/`cek-resume`.
- **Commits:** one feature per commit. Keep `## Progress log` updated and tick boxes.
## Architecture sketch
```
OCaml source text
│
▼
lib/ocaml/tokenizer.sx — keywords, operators, string/char literals, comments
│
▼
lib/ocaml/parser.sx — OCaml AST: let/let rec, fun, match, if, begin/end,
│ module/struct/functor, type decls, expressions
▼
lib/ocaml/desugar.sx — surface → core: tuple patterns, or-patterns,
│ sequence (;) → (do), when guards, field punning
▼
lib/ocaml/transpile.sx — OCaml AST → SX AST
│
▼
lib/ocaml/runtime.sx — ADT constructors, module primitives, ref/array ops,
│ Stdlib shims, Dream server (phase 7)
▼
SX CEK evaluator (both JS and OCaml hosts)
```
## Semantic mappings
| OCaml construct | SX mapping |
|----------------|-----------|
| `let x = e` (top-level) | `(define x e)` |
| `let f x y = e` | `(define (f x y) e)` |
| `let rec f x = e` | `(define (f x) e)` — SX define is already recursive |
| `fun x -> e` | `(fn (x) e)` |
| `e1 \|> f` | `(f e1)` — pipe desugars to reverse application |
| `e1; e2` | `(do e1 e2)` |
| `begin e1; e2; e3 end` | `(do e1 e2 e3)` |
| `if c then e1 else e2` | `(if c e1 e2)` |
| `match x with \| P -> e` | `(match x (P e) ...)` via Phase 6 ADT primitive |
| `type t = A \| B of int` | `(define-type t (A) (B v))` |
| `module M = struct ... end` | SX dict `{:let-bindings ...}` — module as record |
| `functor (M : S) -> ...` | `(fn (M) ...)` — functor as SX lambda over module record |
| `open M` | inject M's bindings into scope via `env-merge` |
| `M.field` | `(get M :field)` |
| `{ r with f = v }` | `(dict-set r :f v)` |
| `ref x` | `(make-ref x)` — mutable cell |
| `!r` | `(deref-ref r)` |
| `r := v` | `(set-ref! r v)` |
| `(a, b, c)` | tagged list `(:tuple a b c)` |
| `[1; 2; 3]` | `(list 1 2 3)` |
| `[| 1; 2; 3 |]` | `(make-array 1 2 3)` (Phase 6) |
| `try e with \| Ex -> h` | `(guard (fn (ex) h) e)` via SX exception system |
| `raise Ex` | `(perform (:raise Ex))` |
| `Printf.printf "%d" x` | `(perform (:print (format "%d" x)))` |
## Dream semantic mappings (Phase 7)
| Dream construct | SX mapping |
|----------------|-----------|
| `handler = request -> response promise` | `(fn (req) (perform (:http-respond ...)))` |
| `middleware = handler -> handler` | `(fn (next) (fn (req) ...))` |
| `Dream.router [routes]` | `(ocaml-dream-router routes)` — dispatch on method+path |
| `Dream.get "/path" h` | route record `{:method "GET" :path "/path" :handler h}` |
| `Dream.scope "/p" [ms] [rs]` | prefix mount with middleware chain |
| `Dream.param req "name"` | path param extracted during routing |
| `m1 @@ m2 @@ handler` | `(m1 (m2 handler))` — left-fold composition |
| `Dream.session_field req "k"` | `(perform (:session-get req "k"))` |
| `Dream.set_session_field req "k" v` | `(perform (:session-set req "k" v))` |
| `Dream.flash req` | `(perform (:flash-get req))` |
| `Dream.form req` | `(perform (:form-parse req))` — returns Ok/Error ADT |
| `Dream.websocket handler` | `(perform (:websocket handler))` |
| `Dream.run handler` | starts SX HTTP server with handler as root |
## Roadmap
### Phase 1 — Tokenizer + parser
- [ ] **Tokenizer:** keywords (`let`, `rec`, `in`, `fun`, `function`, `match`, `with`,
`type`, `of`, `module`, `struct`, `end`, `functor`, `sig`, `open`, `include`,
`if`, `then`, `else`, `begin`, `try`, `exception`, `raise`, `mutable`,
`for`, `while`, `do`, `done`, `and`, `as`, `when`), operators (`->`, `|>`,
`<|`, `@@`, `@`, `:=`, `!`, `::`, `**`, `:`, `;`, `;;`), identifiers (lower,
upper/ctor, labels `~label:`, optional `?label:`), char literals `'c'`,
string literals (escaped + heredoc `{|...|}`), int/float literals,
line comments `(*` nested block comments `*)`.
- [ ] **Parser:** top-level `let`/`let rec`/`type`/`module`/`exception`/`open`/`include`
declarations; expressions: literals, identifiers, constructor application,
lambda, application (left-assoc), binary ops with precedence table,
`if`/`then`/`else`, `match`/`with`, `try`/`with`, `let`/`in`, `begin`/`end`,
`fun`/`function`, tuples, list literals, record literals/updates, field access,
sequences `;`, unit `()`.
- [ ] **Patterns:** constructor, literal, variable, wildcard `_`, tuple, list cons `::`,
list literal, record, `as`, or-pattern `P1 | P2`, `when` guard.
- [ ] OCaml is **not** indentation-sensitive — no layout algorithm needed.
- [ ] Tests in `lib/ocaml/tests/parse.sx` — 50+ round-trip parse tests.
### Phase 2 — Core evaluator (untyped)
- [ ] `ocaml-eval` entry: walks OCaml AST, produces SX values.
- [ ] `let`/`let rec`/`let ... in` (mutually recursive with `and`).
- [ ] Lambda + application (curried by default — auto-curry multi-param defs).
- [ ] `fun`/`function` (single-arg lambda with immediate match on arg).
- [ ] `if`/`then`/`else`, `begin`/`end`, sequence `;`.
- [ ] Arithmetic, comparison, boolean ops, string `^`, `mod`.
- [ ] Unit `()` value; `ignore`.
- [ ] References: `ref`, `!`, `:=`.
- [ ] Mutable record fields.
- [ ] `for i = lo to hi do ... done` loop; `while cond do ... done`.
- [ ] `try`/`with` — maps to SX `guard`; `raise` via perform.
- [ ] Tests in `lib/ocaml/tests/eval.sx` — 50+ tests, pure + imperative.
### Phase 3 — ADTs + pattern matching
- [ ] `type` declarations: `type t = A | B of t1 * t2 | C of { x: int }`.
- [ ] Constructors as tagged lists: `A` → `(:A)`, `B(1, "x")` → `(:B 1 "x")`.
- [ ] `match`/`with`: constructor, literal, variable, wildcard, tuple, list cons/nil,
`as` binding, or-patterns, nested patterns, `when` guard.
- [ ] Exhaustiveness: runtime error on incomplete match (no compile-time check yet).
- [ ] Built-in types: `option` (`None`/`Some`), `result` (`Ok`/`Error`),
`list` (nil/cons), `bool`, `unit`, `exn`.
- [ ] `exception` declarations; built-in: `Not_found`, `Invalid_argument`,
`Failure`, `Match_failure`.
- [ ] Polymorphic variants (surface syntax `\`Tag value`; runtime same tagged list).
- [ ] Tests in `lib/ocaml/tests/adt.sx` — 40+ tests: ADTs, match, option/result.
### Phase 4 — Modules + functors
- [ ] `module M = struct let x = 1 let f y = x + y end` → SX dict `{:x 1 :f <fn>}`.
- [ ] `module type S = sig val x : int val f : int -> int end` → interface record
(runtime stub; typed checking in Phase 5).
- [ ] `module M : S = struct ... end` — coercive sealing (runtime: pass-through).
- [ ] `functor (M : S) -> struct ... end` → SX `(fn (M) ...)`.
- [ ] `module F = Functor(Base)` — functor application.
- [ ] `open M` — merge M's dict into current env (`env-merge`).
- [ ] `include M` — same as open at structure level.
- [ ] `M.name` — dict get via `:name` key.
- [ ] First-class modules (pack/unpack) — deferred to Phase 5.
- [ ] Standard module hierarchy: `List`, `Option`, `Result`, `String`, `Char`,
`Int`, `Float`, `Bool`, `Unit`, `Printf`, `Format` (stubs, filled in Phase 6).
- [ ] Tests in `lib/ocaml/tests/modules.sx` — 30+ tests.
### Phase 5 — Hindley-Milner type inference
- [ ] Algorithm W: `gen`/`inst`, `unify`, `infer-expr`, `infer-decl`.
- [ ] Type variables: `'a`, `'b`; unification with occur-check.
- [ ] Let-polymorphism: generalise at let-bindings.
- [ ] ADT types: `type 'a option = None | Some of 'a`.
- [ ] Function types, tuple types, record types.
- [ ] Type signatures: `val f : int -> int` — verify against inferred type.
- [ ] Module type checking: seal against `sig` (Phase 4 stubs become real checks).
- [ ] Error reporting: position-tagged errors with expected vs actual types.
- [ ] First-class modules: `(module M : S)` pack; `(val m : (module S))` unpack.
- [ ] No rank-2 polymorphism, no GADTs (out of scope).
- [ ] Tests in `lib/ocaml/tests/types.sx` — 60+ inference tests.
### Phase 6 — Standard library
- [ ] `List`: `map`, `filter`, `fold_left`, `fold_right`, `length`, `rev`, `append`,
`concat`, `flatten`, `iter`, `iteri`, `mapi`, `for_all`, `exists`, `find`,
`find_opt`, `mem`, `assoc`, `assq`, `sort`, `stable_sort`, `nth`, `hd`, `tl`,
`init`, `combine`, `split`, `partition`.
- [ ] `Option`: `map`, `bind`, `fold`, `get`, `value`, `join`, `iter`, `to_list`,
`to_result`, `is_none`, `is_some`.
- [ ] `Result`: `map`, `bind`, `fold`, `get_ok`, `get_error`, `map_error`,
`to_option`, `is_ok`, `is_error`.
- [ ] `String`: `length`, `get`, `sub`, `concat`, `split_on_char`, `trim`,
`uppercase_ascii`, `lowercase_ascii`, `contains`, `starts_with`, `ends_with`,
`index_opt`, `replace_all` (non-stdlib but needed).
- [ ] `Char`: `code`, `chr`, `escaped`, `lowercase_ascii`, `uppercase_ascii`.
- [ ] `Int`/`Float`: arithmetic, `to_string`, `of_string_opt`, `min_int`, `max_int`.
- [ ] `Hashtbl`: `create`, `add`, `replace`, `find`, `find_opt`, `remove`, `mem`,
`iter`, `fold`, `length` — backed by SX mutable dict.
- [ ] `Map.Make` functor — balanced BST backed by SX sorted dict.
- [ ] `Set.Make` functor.
- [ ] `Printf`: `sprintf`, `printf`, `eprintf` — format strings via `(format ...)`.
- [ ] `Sys`: `argv`, `getenv_opt`, `getcwd` — via `perform` IO.
- [ ] Scoreboard runner: `lib/ocaml/conformance.sh` + `scoreboard.json`.
- [ ] Target: 150+ tests across all stdlib modules.
### Phase 7 — Dream web framework (`lib/dream/`)
The five types: `request`, `response`, `handler = request -> response`,
`middleware = handler -> handler`, `route`. Everything else is a function over these.
- [ ] **Core types** in `lib/dream/types.sx`: request/response records, route record.
- [ ] **Router** in `lib/dream/router.sx`:
- `dream-get path handler`, `dream-post path handler`, etc. for all HTTP methods.
- `dream-scope prefix middlewares routes` — prefix mount with middleware chain.
- `dream-router routes` — dispatch tree, returns handler; no match → 404.
- Path param extraction: `:name` segments, `**` wildcard.
- `dream-param req name` — retrieve matched path param.
- [ ] **Middleware** in `lib/dream/middleware.sx`:
- `dream-pipeline middlewares handler` — compose middleware left-to-right.
- `dream-no-middleware` — identity.
- Logger: `(dream-logger next req)` — logs method, path, status, timing.
- Content-type sniffer.
- [ ] **Sessions** in `lib/dream/session.sx`:
- Cookie-backed session middleware.
- `dream-session-field req key`, `dream-set-session-field req key val`.
- `dream-invalidate-session req`.
- [ ] **Flash messages** in `lib/dream/flash.sx`:
- `dream-flash-middleware` — single-request cookie store.
- `dream-add-flash-message req category msg`.
- `dream-flash-messages req` — returns list of `(category, msg)`.
- [ ] **Forms + CSRF** in `lib/dream/form.sx`:
- `dream-form req` — returns `(Ok fields)` or `(Err :csrf-token-invalid)`.
- `dream-multipart req` — streaming multipart form data.
- CSRF middleware: stateless signed tokens, session-scoped.
- `dream-csrf-tag req` — returns hidden input fragment for SX templates.
- [ ] **WebSockets** in `lib/dream/websocket.sx`:
- `dream-websocket handler` — upgrades request; handler `(fn (ws) ...)`.
- `dream-send ws msg`, `dream-receive ws`, `dream-close ws`.
- [ ] **Static files:** `dream-static root-path` — serves files, ETags, range requests.
- [ ] **`dream-run`**: wires root handler into SX's `perform (:http-listen ...)`.
- [ ] **Demos** in `lib/dream/demos/`:
- `hello.ml` → `lib/dream/demos/hello.sx`: "Hello, World!" route.
- `counter.ml` → `lib/dream/demos/counter.sx`: in-memory counter with sessions.
- `chat.ml` → `lib/dream/demos/chat.sx`: multi-room WebSocket chat.
- `todo.ml` → `lib/dream/demos/todo.sx`: CRUD list with forms + CSRF.
- [ ] Tests in `lib/dream/tests/`: routing dispatch, middleware composition,
session round-trip, CSRF accept/reject, flash read-after-write — 60+ tests.
### Phase 8 — ReasonML syntax variant (`lib/reasonml/`)
ReasonML is OCaml with a JS-friendly surface: semicolons, `let` with `=` everywhere,
`=>` for lambdas, `switch` for match, `{j|...|j}` string interpolation. Same semantics —
different tokenizer + parser, same `lib/ocaml/transpile.sx` output.
- [ ] **Tokenizer** in `lib/reasonml/tokenizer.sx`:
- `let x = e;` binding syntax (semicolons required).
- `(x, y) => e` arrow function syntax.
- `switch (x) { | Pat => e | ... }` for match.
- JSX: `<Comp prop=val />`, `<div>children</div>`.
- String interpolation: `{j|hello $(name)|j}`.
- Type annotations: `x : int`, `let f : int => int = x => x + 1`.
- [ ] **Parser** in `lib/reasonml/parser.sx`:
- Produce same OCaml AST nodes as `lib/ocaml/parser.sx`.
- JSX → SX component calls: `<Comp x=1 />` → `(~comp :x 1)`.
- Multi-arg functions: `(x, y) => e` → auto-curried pair.
- [ ] Shared transpiler: `lib/reasonml/transpile.sx` delegates to
`lib/ocaml/transpile.sx` (parse → ReasonML AST → OCaml AST → SX AST).
- [ ] Tests in `lib/reasonml/tests/`: tokenizer, parser, eval, JSX — 40+ tests.
- [ ] ReasonML Dream demos: translate Phase 7 demos to ReasonML syntax.
## The meta-circular angle
SX is bootstrapped to OCaml (`hosts/ocaml/`). Running OCaml inside SX running on OCaml is
the "mother tongue" closure: OCaml → SX → OCaml. This means:
- The OCaml host's native pattern matching and ADTs are exact reference semantics for
the SX-level implementation — any mismatch is a bug.
- The SX `match` / `define-type` primitives (Phase 6 of the primitives roadmap) were
built knowing OCaml was the intended target.
- When debugging the transpiler, the OCaml REPL is always available as oracle.
- Dream running in SX can serve the sx.rose-ash.com docs site — the framework that
describes the runtime it runs on.
## Key dependencies
- **Phase 6 ADT primitive** (`define-type`/`match`) — required before Phase 3.
- **`perform`/`cek-resume`** IO suspension — required before Phase 7 (Dream async).
- **HO forms** and first-class lambdas — already in spec, no blocker.
- **Module system** (Phase 4) is independent of type inference (Phase 5) — can overlap.
- **ReasonML** (Phase 8) can start once OCaml parser is stable (after Phase 2).
## Progress log
_Newest first._
_(awaiting phase 1)_
## Blockers
_(none yet)_

100
plans/prolog-on-sx.md
View File

@@ -39,93 +39,59 @@ Representation choices (finalise in phase 1, document here):
## Roadmap
### Phase 1 — tokenizer + term parser (no operator table)
- [x] Tokenizer: atoms (lowercase/quoted), variables (uppercase/`_`), numbers, strings, punct `( ) , . [ ] | ! :-`, comments (`%`, `/* */`)
- [x] Parser: clauses `head :- body.` and facts `head.`; terms `atom | Var | number | compound(args) | [list,sugar]`
- [x] **Skip for phase 1:** operator table. `X is Y + 1` must be written `is(X, '+'(Y, 1))`; `=` written `=(X, Y)`. Operators land in phase 4.
- [x] Unit tests in `lib/prolog/tests/parse.sx` — 25 pass
- [ ] Tokenizer: atoms (lowercase/quoted), variables (uppercase/`_`), numbers, strings, punct `( ) , . [ ] | ! :-`, comments (`%`, `/* */`)
- [ ] Parser: clauses `head :- body.` and facts `head.`; terms `atom | Var | number | compound(args) | [list,sugar]`
- [ ] **Skip for phase 1:** operator table. `X is Y + 1` must be written `is(X, '+'(Y, 1))`; `=` written `=(X, Y)`. Operators land in phase 4.
- [ ] Unit tests in `lib/prolog/tests/parse.sx`
### Phase 2 — unification + trail
- [x] `make-var`, `walk` (follow binding chain), `prolog-unify!` (terms + trail → bool), `trail-undo-to!`
- [x] Occurs-check off by default, exposed as flag
- [x] 30+ unification tests in `lib/prolog/tests/unify.sx`: atoms, vars, compounds, lists, cyclic (no-occurs-check), mutual occurs — 47 pass
- [ ] `make-var`, `walk` (follow binding chain), `prolog-unify!` (terms + trail → bool), `trail-undo-to!`
- [ ] Occurs-check off by default, exposed as flag
- [ ] 30+ unification tests in `lib/prolog/tests/unify.sx`: atoms, vars, compounds, lists, cyclic (no-occurs-check), mutual occurs
### Phase 3 — clause DB + DFS solver + cut + first classic programs
- [x] Clause DB: `"functor/arity" → list-of-clauses`, loader inserts — `pl-mk-db` / `pl-db-add!` / `pl-db-load!` / `pl-db-lookup` / `pl-db-lookup-goal`, 14 tests in `tests/clausedb.sx`
- [x] Solver: DFS with choice points backed by delimited continuations (`lib/callcc.sx`). On goal entry, capture; per matching clause, unify head + recurse body; on failure, undo trail, try next — first cut: trail-based undo + CPS k (no shift/reset yet, per briefing gotcha). Built-ins so far: `true/0`, `fail/0`, `=/2`, `,/2`. Refactor to delimited conts later.
- [x] Cut (`!`): cut barrier at current choice-point frame; collapse all up to barrier — two-cut-box scheme: each `pl-solve-user!` creates a fresh inner-cut-box (set by `!` in this predicate's body) AND snapshots the outer-cut-box state on entry. After body fails, abandon clause alternatives if (a) inner was set or (b) outer transitioned false→true during this call. Lets post-cut goals backtrack normally while blocking pre-cut alternatives. 6 cut tests cover bare cut, clause-commit, choice-commit, cut+fail, post-cut backtracking, nested-cut isolation.
- [x] Built-ins: `=/2`, `\\=/2`, `true/0`, `fail/0`, `!/0`, `,/2`, `;/2`, `->/2` inside `;`, `call/1`, `write/1`, `nl/0` — all 11 done. `write/1` and `nl/0` use a global `pl-output-buffer` string + `pl-output-clear!` for testability; `pl-format-term` walks deep then renders atoms/nums/strs/compounds/vars (var → `_<id>`). Note: cut-transparency via `;` not testable yet without operator support — `;(,(a,!), b)` parser-rejects because `,` is body-operator-only; revisit in phase 4.
- [x] Arithmetic `is/2` with `+ - * / mod abs` — `pl-eval-arith` walks deep, recurses on compounds, dispatches on functor; binary `+ - * / mod`, binary AND unary `-`, unary `abs`. `is/2` evaluates RHS, wraps as `("num" v)`, unifies via `pl-solve-eq!`. 11 tests cover each op + nested + ground LHS match/mismatch + bound-var-on-RHS chain.
- [x] Classic programs in `lib/prolog/tests/programs/`:
- [x] `append.pl` — list append (with backtracking) — `lib/prolog/tests/programs/append.{pl,sx}`. 6 tests cover: build (`append([], L, X)`, `append([1,2], [3,4], X)`), check ground match/mismatch, full split-backtracking (`append(X, Y, [1,2,3])` → 4 solutions), single-deduce (`append(X, [3], [1,2,3])` → X=[1,2]).
- [x] `reverse.pl` — naive reverse — `lib/prolog/tests/programs/reverse.{pl,sx}`. Naive reverse via append: `reverse([H|T], R) :- reverse(T, RT), append(RT, [H], R)`. 6 tests cover empty, singleton, 3-list, 4-atom-list, ground match, ground mismatch.
- [x] `member.pl` — generate all solutions via backtracking — `lib/prolog/tests/programs/member.{pl,sx}`. Classic 2-clause `member(X, [X|_])` + `member(X, [_|T]) :- member(X, T)`. 7 tests cover bound-element hit/miss, empty list, generator (count = list length), first-solution binding, duplicate matches counted twice, anonymous head-cell unification.
- [x] `nqueens.pl` — 8-queens — `lib/prolog/tests/programs/nqueens.{pl,sx}`. Permute-and-test formulation: `queens(L, Qs) :- permute(L, Qs), safe(Qs)` + `select` + `safe` + `no_attack`. Tested at N=1 (1), N=2 (0), N=3 (0), N=4 (2), N=5 (10) plus first-solution check at N=4 = `[2, 4, 1, 3]`. N=8 omitted — interpreter is too slow (40320 perms); add once compiled clauses or constraint-style placement land. `range/3` skipped pending arithmetic-comparison built-ins (`>/2` etc.).
- [x] `family.pl` — facts + rules (parent/ancestor) — `lib/prolog/tests/programs/family.{pl,sx}`. 5 parent facts + male/female + derived `father`/`mother`/`ancestor`/`sibling`. 10 tests cover direct facts, fact count, transitive ancestor through 3 generations, descendant counting, gender-restricted father/mother, sibling via shared parent + `\=`.
- [x] `lib/prolog/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md` — bash script feeds load + eval epoch script to sx_server, parses each suite's `{:failed N :passed N :total N :failures (...)}` line, writes JSON (machine) + MD (human) scoreboards. Exit non-zero on any failure. `SX_SERVER` env var overrides binary path. First scoreboard: 183 / 183.
- [x] Target: all 5 classic programs passing — append (6) + reverse (6) + member (7) + nqueens (6) + family (10) = 35 program tests, all green. Phase 3 architecturally complete bar the conformance harness/scoreboard.
- [ ] Clause DB: `"functor/arity" → list-of-clauses`, loader inserts
- [ ] Solver: DFS with choice points backed by delimited continuations (`lib/callcc.sx`). On goal entry, capture; per matching clause, unify head + recurse body; on failure, undo trail, try next
- [ ] Cut (`!`): cut barrier at current choice-point frame; collapse all up to barrier
- [ ] Built-ins: `=/2`, `\\=/2`, `true/0`, `fail/0`, `!/0`, `,/2`, `;/2`, `->/2` inside `;`, `call/1`, `write/1`, `nl/0`
- [ ] Arithmetic `is/2` with `+ - * / mod abs`
- [ ] Classic programs in `lib/prolog/tests/programs/`:
- [ ] `append.pl` — list append (with backtracking)
- [ ] `reverse.pl` — naive reverse
- [ ] `member.pl` — generate all solutions via backtracking
- [ ] `nqueens.pl` — 8-queens
- [ ] `family.pl` — facts + rules (parent/ancestor)
- [ ] `lib/prolog/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`
- [ ] Target: all 5 classic programs passing
### Phase 4 — operator table + more built-ins (next run)
- [x] Operator table parsing (prefix/infix/postfix, precedence, assoc) — `pl-op-table` (15 entries: `, ; -> = \= is < > =< >= + - * / mod`); precedence-climbing parser via `pp-parse-primary` + `pp-parse-term-prec` + `pp-parse-op-rhs`. Parens override precedence. Args inside compounds parsed at 999 so `,` stays as separator. xfx/xfy/yfx supported; prefix/postfix deferred (so `-5` still tokenises as bare atom + num as before). Comparison built-ins `</2 >/2 =</2 >=/2` added. New `tests/operators.sx` 19 tests cover assoc/precedence/parens + solver via infix.
- [x] `assert/1`, `asserta/1`, `assertz/1`, `retract/1` — `assert` aliases `assertz`. Helpers `pl-rt-to-ast` (deep-walk + replace runtime vars with `_G<id>` parse markers) + `pl-build-clause` (detect `:-` head). `assertz` uses `pl-db-add!`; `asserta` uses new `pl-db-prepend!`. `retract` walks goal, looks up by functor/arity, tries each clause via unification, removes first match by index (`pl-list-without`). 11 tests in `tests/dynamic.sx`. Rule-asserts now work — `:-` added to op table (prec 1200 xfx) with fix to `pl-token-op` accepting `"op"` token type. 15 tests in `tests/assert_rules.sx`.
- [x] `findall/3`, `bagof/3`, `setof/3` — shared `pl-collect-solutions` runs the goal in a fresh cut-box, deep-copies the template (via `pl-deep-copy` with var-map for shared-var preservation) on each success, returns false to backtrack, then restores trail. `findall` always succeeds with a (possibly empty) list. `bagof` fails on empty. `setof` builds a string-keyed dict via `pl-format-term` for sort+dedupe (via `keys` + `sort`), fails on empty. Existential `^` deferred (operator). 11 tests in `tests/findall.sx`.
- [x] `copy_term/2`, `functor/3`, `arg/3`, `=../2` — `copy_term/2` reuses `pl-deep-copy` with a fresh var-map (preserves source aliasing). `functor/3` handles 4 modes: compound→{name, arity}, atom→{atom, 0}, num→{num, 0}, var with ground name+arity→constructed term (`pl-make-fresh-args` for compound case). `arg/3` extracts 1-indexed arg from compound. **`=../2` deferred** — the tokenizer treats `.` as the clause terminator unconditionally, so `=..` lexes as `=` + `.` + `.`; needs special-case lex (or surface syntax via a different name). 14 tests in `tests/term_inspect.sx`.
- [x] String/atom predicates
- [ ] Operator table parsing (prefix/infix/postfix, precedence, assoc)
- [ ] `assert/1`, `asserta/1`, `assertz/1`, `retract/1`
- [ ] `findall/3`, `bagof/3`, `setof/3`
- [ ] `copy_term/2`, `functor/3`, `arg/3`, `=../2`
- [ ] String/atom predicates
### Phase 5 — Hyperscript integration
- [x] `prolog-query` primitive callable from SX/Hyperscript
- [x] Hyperscript DSL: `when allowed(user, action) then …` — `lib/prolog/hs-bridge.sx`: `pl-hs-query` (bool goal test) + `pl-hs-predicate/1,2,3` factories + `pl-hs-install`. No parser/compiler changes needed: Hyperscript already compiles `allowed(user, action)` to `(allowed user action)` — a plain SX call backed by the Prolog DB.
- [x] Integration suite
- [ ] `prolog-query` primitive callable from SX/Hyperscript
- [ ] Hyperscript DSL: `when allowed(user, :edit) then …`
- [ ] Integration suite
### Phase 6 — ISO conformance
- [x] Vendor Hirst's conformance tests
- [x] Drive scoreboard to 200+
- [ ] Vendor Hirst's conformance tests
- [ ] Drive scoreboard to 200+
### Phase 7 — compiler (later, optional)
- [x] Compile clauses to SX continuations for speed
- [x] Keep interpreter as the reference
- [ ] Compile clauses to SX continuations for speed
- [ ] Keep interpreter as the reference
## Progress log
_Newest first. Agent appends on every commit._
- 2026-05-06 — Hyperscript bridge (`lib/prolog/hs-bridge.sx`): `pl-hs-query`, `pl-hs-predicate/1,2,3`, `pl-hs-install`. No parser/compiler changes needed — Hyperscript already compiles `when allowed(user, action)` to `(allowed user action)`, a plain SX call; bridge factories wire a Prolog DB as the backing implementation. 19 tests in `tests/hs_bridge.sx`. Total **590** (+19).
- 2026-05-05 — Integration test suite (`tests/integration.sx`): 20 end-to-end tests via `pl-query-*` API covering permission system (6), graph reachability (4), quicksort (4), fibonacci (3), dynamic KB (3). Suite added to conformance harness. Total **571** (+20).
- 2026-04-25 — `pl-compiled-matches-interp?` cross-validator in `compiler.sx`: loads source into both a plain and a compiled DB, runs the same goal, returns true iff solution counts match. `tests/cross_validate.sx` applies this to 17 goals across append/member/ancestor/cut/arithmetic/if-then-else, locking the interpreter as the reference against which any future compiler change must agree. Total **551** (+17).
- 2026-04-25 — Clause compiler (`lib/prolog/compiler.sx`): `pl-compile-clause` converts parse-AST clauses to SX closures `(fn (goal trail db cut-box k) bool)`. Pre-collects var names at compile time; `pl-cmp-build-term` reconstructs fresh runtime terms per call. `pl-compile-db!` compiles all clauses in a DB and stores them in `:compiled` table. `pl-solve-user!` in runtime.sx auto-dispatches to compiled lambdas when present, falls back to interpreted. `pl-try-compiled-clauses!` mirrors `pl-try-clauses!` cut semantics. 17 tests in `tests/compiler.sx`. Total **534** (+17).
- 2026-04-25 — `predsort/3` (insertion-sort with 3-arg comparator predicate, deduplicates `=` pairs), `term_variables/2` (collect unbound vars left-to-right, dedup by id), arithmetic extensions (`floor/1`, `ceiling/1`, `truncate/1`, `round/1`, `sign/1`, `sqrt/1`, `pow/2`, `**/2`, `^/2`, `integer/1`, `float/1`, `float_integer_part/1`, `float_fractional_part/1`). 21 tests in `tests/advanced.sx`. Total **517** (+21).
- 2026-04-25 — `sub_atom/5` (non-deterministic substring enumeration; CPS loop over all (start,sublen) pairs; trail-undo only on backtrack) + `aggregate_all/3` (6 templates: count/bag/sum/max/min/set; uses `pl-collect-solutions`). 25 tests in `tests/string_agg.sx`. Total **496** (+25).
- 2026-04-25 — `:-` operator + assert with rules: added `(list ":-" 1200 "xfx")` to `pl-op-table`; fixed `pl-token-op` to accept `"op"` token type (tokenizer emits `:-` as `"op"`, not `"atom"`). `pl-build-clause` already handled `("compound" ":-" ...)`. `assert((head :- body))` now works for facts+rules. 15 tests in `tests/assert_rules.sx`. Total **471** (+15).
- 2026-04-25 — IO/term predicates: `term_to_atom/2` (bidirectional: format term or parse atom), `term_string/2` (alias), `with_output_to/2` (atom/string sinks — saves/restores `pl-output-buffer`), `writeln/1`, `format/1` (~n/~t/~~), `format/2` (~w/~a/~d pull from arg list). 24 tests in `tests/io_predicates.sx`. Total **456** (+24).
- 2026-04-25 — Char predicates: `char_type/2` (9 modes: alpha/alnum/digit/digit(N)/space/white/upper(L)/lower(U)/ascii(C)/punct), `upcase_atom/2`, `downcase_atom/2`, `string_upper/2`, `string_lower/2`. 10 helpers using `char-code`/`char-from-code` SX primitives. 27 tests in `tests/char_predicates.sx`. Total **432** (+27).
- 2026-04-25 — Set/fold predicates: `foldl/4` (CPS fold-left, threads accumulator via `pl-apply-goal`), `list_to_set/2` (dedup preserving first-occurrence), `intersection/3`, `subtract/3`, `union/3` (all via `pl-struct-eq?`). 3 new helpers, 15 tests in `tests/set_predicates.sx`. Total **405** (+15).
- 2026-04-25 — Meta-call predicates: `forall/2` (negation-of-counterexample), `maplist/2` (goal over list), `maplist/3` (map goal building output list), `include/3` (filter by goal success), `exclude/3` (filter by goal failure). New `pl-apply-goal` helper extends a goal with extra args. 15 tests in `tests/meta_call.sx`. Total **390** (+15).
- 2026-04-25 — List/utility predicates: `==/2`, `\==/2` (structural equality/inequality via `pl-struct-eq?`), `flatten/2` (deep Prolog-list flatten), `numlist/3` (integer range list), `atomic_list_concat/2` (join with no sep), `atomic_list_concat/3` (join with separator), `sum_list/2`, `max_list/2`, `min_list/2` (arithmetic folds), `delete/3` (remove all struct-equal elements). 7 new helpers, 33 tests in `tests/list_predicates.sx`. Total **375** (+33).
- 2026-04-25 — Meta/logic predicates: `\+/1` (negation-as-failure, trail-undo on success), `not/1` (alias), `once/1` (commit to first solution via if-then-else), `ignore/1` (always succeed), `ground/1` (all vars bound), `sort/2` (sort + dedup by formatted key), `msort/2` (sort, keep dups), `atom_number/2` (bidirectional), `number_string/2` (bidirectional). 2 helpers (`pl-ground?`, `pl-sort-pairs-dedup`). 25 tests in `tests/meta_predicates.sx`. Total **342** (+25).
- 2026-04-25 — ISO utility predicates batch: `succ/2` (bidirectional), `plus/3` (3-mode bidirectional), `between/3` (backtracking range generator), `length/2` (bidirectional list length + var-list constructor), `last/2`, `nth0/3`, `nth1/3`, `max/2` + `min/2` in arithmetic eval. 6 new helper functions (`pl-list-length`, `pl-make-list-of-vars`, `pl-between-loop!`, `pl-solve-between!`, `pl-solve-last!`, `pl-solve-nth0!`). 29 tests in `tests/iso_predicates.sx`. Phase 6 complete: scoreboard already at 317, far above 200+ target. Hyperscript DSL blocked (needs `lib/hyperscript/**`). Total **317** (+29).
- 2026-04-25 — `prolog-query` SX API (`lib/prolog/query.sx`). New public API layer: `pl-load source-str → db`, `pl-query-all db query-str → list of solution dicts`, `pl-query-one db query-str → dict or nil`, `pl-query src query → list` (convenience). Each solution dict maps variable name strings to their formatted term strings. Var names extracted from pre-instantiation parse AST. Trail is marked before solve and reset after to ensure clean state. 16 tests in `tests/query_api.sx` cover fact lookup, no-solution, boolean queries, multi-var, recursive rules, is/2 built-in, query-one, convenience form. Total **288** (+16).
- 2026-04-25 — String/atom predicates. Type-test predicates: `var/1`, `nonvar/1`, `atom/1`, `number/1`, `integer/1`, `float/1` (always-fail), `compound/1`, `callable/1`, `atomic/1`, `is_list/1`. String/atom operations: `atom_length/2`, `atom_concat/3` (3 modes: both-ground, result+first, result+second), `atom_chars/2` (bidirectional), `atom_codes/2` (bidirectional), `char_code/2` (bidirectional), `number_codes/2`, `number_chars/2`. 7 helper functions in runtime.sx (`pl-list-to-prolog`, `pl-proper-list?`, `pl-prolog-list-to-sx`, `pl-solve-atom-concat!`, `pl-solve-atom-chars!`, `pl-solve-atom-codes!`, `pl-solve-char-code!`). 34 tests in `tests/atoms.sx`. Total **272** (+34).
- 2026-04-25 — `copy_term/2` + `functor/3` + `arg/3` (term inspection). `copy_term` is a one-line dispatch to existing `pl-deep-copy`. `functor/3` is bidirectional — decomposes a bound compound/atom/num into name+arity OR constructs from ground name+arity (atom+positive-arity → compound with N anonymous fresh args via `pl-make-fresh-args`; arity 0 → atom/num). `arg/3` extracts 1-indexed arg with bounds-fail. New helper `pl-solve-eq2!` for paired-unification with shared trail-undo. 14 tests in `tests/term_inspect.sx`. Total **238** (+14). `=..` deferred — `.` always tokenizes as clause terminator; needs special lexer case.
- 2026-04-25 — `findall/3` + `bagof/3` + `setof/3`. Shared collector `pl-collect-solutions` runs the goal in a fresh cut-box, deep-copies the template per success (`pl-deep-copy` walks term, allocates fresh runtime vars via shared var-map so co-occurrences keep aliasing), returns false to keep backtracking, then `pl-trail-undo-to!` to clean up. `findall` always builds a list. `bagof` fails on empty. `setof` uses a `pl-format-term`-keyed dict + SX `sort` for dedupe + ordering. New `tests/findall.sx` 11 tests. Total **224** (+11). Existential `^` deferred — needs operator.
- 2026-04-25 — Dynamic clauses: `assert/1`, `assertz/1`, `asserta/1`, `retract/1`. New helpers `pl-rt-to-ast` (deep-walk runtime term → parse-AST, mapping unbound runtime vars to `_G<id>` markers so `pl-instantiate-fresh` produces fresh vars per call) + `pl-build-clause` + `pl-db-prepend!` + `pl-list-without`. `retract` keeps runtime vars (so the caller's vars get bound), walks head for the functor/arity key, tries each stored clause via `pl-unify!`, removes the first match by index. 11 tests in `tests/dynamic.sx`; conformance script gained dynamic row. Total **213** (+11). Rule-form asserts (`(H :- B)`) deferred until `:-` is in the op table.
- 2026-04-25 — Phase 4 starts: operator-table parsing. Parser rewrite uses precedence climbing (xfx/xfy/yfx); 15-op table covers control (`, ; ->`), comparison (`= \\= is < > =< >=`), arithmetic (`+ - * / mod`). Parens override. Backwards-compatible: prefix-syntax compounds (`=(X, Y)`, `+(2, 3)`) still parse as before; existing 183 tests untouched. Added comparison built-ins `</2 >/2 =</2 >=/2` to runtime (eval both sides, compare). New `tests/operators.sx` 19 tests; conformance script gained an operators row. Total **202** (+19). Prefix/postfix deferred — `-5` keeps old bare-atom semantics.
- 2026-04-25 — Conformance harness landed. `lib/prolog/conformance.sh` runs all 9 suites in one sx_server epoch, parses the `{:failed/:passed/:total/:failures}` summary lines, and writes `scoreboard.json` + `scoreboard.md`. `SX_SERVER` env var overrides the binary path; default points at the main-repo build. Phase 3 fully complete: 183 / 183 passing across parse/unify/clausedb/solve/append/reverse/member/nqueens/family.
- 2026-04-25 — `family.pl` fifth classic program — completes the 5-program target. 5-fact pedigree + male/female + derived father/mother/ancestor/sibling. 10 tests cover fact lookup + count, transitive ancestor through 3 generations, descendant counting (5), gender-restricted derivations, sibling via shared parent guarded by `\=`. Total 183 (+10). All 5 classic programs ticked; Phase 3 needs only conformance harness + scoreboard left.
- 2026-04-25 — `nqueens.pl` fourth classic program. Permute-and-test variant exercises every Phase-3 feature: lists with `[H|T]` cons sugar, multi-clause backtracking, recursive `permute`/`select`/`safe`/`no_attack`, `is/2` arithmetic on diagonals, `\=/2` for diagonal-conflict check. 6 tests at N ∈ {1,2,3,4,5} with expected counts {1,0,0,2,10} + first-solution `[2,4,1,3]`. N=5 takes ~30s (120 perms × safe-check); N=8 omitted as it would be ~thousands of seconds. Total 173 (+6).
- 2026-04-25 — `member.pl` third classic program. Standard 2-clause definition; 7 tests cover bound-element hit/miss, empty-list fail, generator-count = list length, first-solution binding (X=11), duplicate elements matched twice on backtrack, anonymous-head unification (`member(a, [X, b, c])` binds X=a). Total 167 (+7).
- 2026-04-25 — `reverse.pl` second classic program. Naive reverse defined via append. 6 tests (empty/singleton/3-list/4-atom-list/ground match/ground mismatch). Confirms the solver handles non-trivial recursive composition: `reverse([1,2,3], R)` recurses to depth 3 then unwinds via 3 nested `append`s. Total 160 (+6).
- 2026-04-25 — `append.pl` first classic program. `lib/prolog/tests/programs/append.pl` is the canonical 2-clause source; `append.sx` embeds the source as a string (no file-read primitive in SX yet) and runs 6 tests covering build, check, full split-backtrack (4 solutions), and deduction modes. Helpers `pl-ap-list-to-sx` / `pl-ap-term-to-sx` convert deep-walked Prolog lists (`("compound" "." (h t))` / `("atom" "[]")`) to SX lists for structural assertion. Total 154 (+6).
- 2026-04-25 — `is/2` arithmetic landed. `pl-eval-arith` recursively evaluates ground RHS expressions (binary `+ - * /`, `mod`; binary+unary `-`; unary `abs`); `is/2` wraps the value as `("num" v)` and unifies via `pl-solve-eq!`, so it works in all three modes — bind unbound LHS, check ground LHS for equality, propagate from earlier var bindings on RHS. 11 tests, total 148 (+11). Without operator support, expressions must be written prefix: `is(X, +(2, *(3, 4)))`.
- 2026-04-25 — `write/1` + `nl/0` landed using global string buffer (`pl-output-buffer` + `pl-output-clear!` + `pl-output-write!`). `pl-format-term` walks deep + dispatches on atom/num/str/compound/var; `pl-format-args` recursively comma-joins. 7 new tests cover atom/num/compound formatting, conjunction order, var-walk, and `nl`. Built-ins box (`=/2`, `\\=/2`, `true/0`, `fail/0`, `!/0`, `,/2`, `;/2`, `->/2`, `call/1`, `write/1`, `nl/0`) now ticked. Total 137 (+7).
- 2026-04-25 — `->/2` if-then-else landed (both `;(->(C,T), E)` and standalone `->(C, T)` ≡ `(C -> T ; fail)`). `pl-solve-or!` now special-cases `->` in left arg → `pl-solve-if-then-else!`. Cond runs in a fresh local cut-box (ISO opacity for cut inside cond). Then-branch can backtrack, else-branch can backtrack, but cond commits to first solution. 9 new tests covering both forms, both branches, binding visibility, cond-commit, then-backtrack, else-backtrack. Total 130 (+9).
- 2026-04-25 — Built-ins `\=/2`, `;/2`, `call/1` landed. `pl-solve-not-eq!` (try unify, always undo, succeed iff unify failed). `pl-solve-or!` (try left, on failure check cut and only try right if not cut). `call/1` opens a fresh inner cut-box (ISO opacity: cut inside `call(G)` commits G, not caller). 11 new tests in `tests/solve.sx` cover atoms+vars for `\=`, both branches + count for `;`, and `call/1` against atoms / compounds / bound goal vars. Total 121 (+11). Box not yet ticked — `->/2`, `write/1`, `nl/0` still pending.
- 2026-04-25 — Cut (`!/0`) landed. `pl-cut?` predicate; solver functions all take a `cut-box`; `pl-solve-user!` creates a fresh inner-cut-box and snapshots `outer-was-cut`; `pl-try-clauses!` abandons alternatives when inner.cut OR (outer.cut transitioned false→true during this call). 6 new cut tests in `tests/solve.sx` covering bare cut, clause-commit, choice-commit, cut+fail blocks alt clauses, post-cut goal backtracks freely, inner cut isolation. Total 110 (+6).
- 2026-04-25 — Phase 3 DFS solver landed (CPS, trail-based backtracking; delimited conts deferred). `pl-solve!` + `pl-solve-eq!` + `pl-solve-user!` + `pl-try-clauses!` + `pl-solve-once!` + `pl-solve-count!` in runtime.sx. Built-ins: `true/0`, `fail/0`, `=/2`, `,/2`. New `tests/solve.sx` 18/18 green covers atomic goals, =, conjunction, fact lookup, multi-solution count, recursive ancestor rule, trail-undo verification. Bug fix: `pl-instantiate` had no `("clause" h b)` case → vars in rule head/body were never instantiated, so rule resolution silently failed against runtime-var goals. Added clause case to recurse with shared var-env. Total 104 (+18).
- 2026-04-24 — Phase 3 clause DB landed: `pl-mk-db` + `pl-head-key` / `pl-clause-key` / `pl-goal-key` + `pl-db-add!` / `pl-db-load!` / `pl-db-lookup` / `pl-db-lookup-goal` in runtime.sx. New `tests/clausedb.sx` 14/14 green. Total 86 (+14). Loader preserves declaration order (append!).
- 2026-04-24 — Verified phase 1+2 already implemented on loops/prolog: `pl-parse-tests-run!` 25/25, `pl-unify-tests-run!` 47/47 (72 total). Ticked phase 1+2 boxes.
- _(awaiting phase 1)_
## Blockers
_Shared-file issues that need someone else to fix. Minimal repro only._
- **Phase 5 Hyperscript DSL** — `lib/hyperscript/**` is out of scope for this loop. Needs `lib/hyperscript/parser.sx` + evaluator to add `when allowed(user, :edit) then …` syntax. Skipping; Phase 5 item 1 (`prolog-query` SX API) is done.
- _(none yet)_

41
scripts/sx-hs-e-down.sh
View File

@@ -1,41 +0,0 @@
#!/usr/bin/env bash
# Stop the sx-hs-e tmux session. Optionally (--clean) remove worktrees.
set -euo pipefail
SESSION="sx-hs-e"
WORKTREE_BASE="/root/rose-ash-e"
CLEAN=0
for arg in "$@"; do
case "$arg" in
--clean) CLEAN=1 ;;
*) echo "Unknown arg: $arg"; exit 2 ;;
esac
done
if tmux has-session -t "$SESSION" 2>/dev/null; then
WINDOWS=$(tmux list-windows -t "$SESSION" -F '#W')
for w in $WINDOWS; do
tmux send-keys -t "$SESSION:$w" "/exit" C-m 2>/dev/null || true
done
echo "Sent /exit to all windows. Waiting 5s..."
sleep 5
tmux kill-session -t "$SESSION"
echo "Killed tmux session '$SESSION'."
else
echo "No $SESSION tmux session running."
fi
if [ "$CLEAN" = "1" ]; then
cd "$(dirname "$0")/.."
for item in e36 e37 e38 e39 e40; do
wt="$WORKTREE_BASE/$item"
if [ -d "$wt" ]; then
git worktree remove --force "$wt" 2>/dev/null || rm -rf "$wt"
echo "Removed worktree: $wt"
fi
done
git worktree prune
echo "Branches preserved. Remove manually if desired:"
echo " git branch -D hs-e36-websocket hs-e37-tokenizer hs-e38-sourceinfo hs-e39-webworker hs-e40-fetch"
fi

190
scripts/sx-hs-e-up.sh
View File

@@ -1,190 +0,0 @@
#!/usr/bin/env bash
# Spawn 5 claude sessions in tmux, one per Bucket-E HS subsystem.
# Each runs in its own git worktree rooted at /root/rose-ash-e/<item>,
# on branch hs-e<N>, rebased onto loops/hs.
#
# Usage: ./scripts/sx-hs-e-up.sh [interval]
# interval defaults to self-paced (omit to let model decide)
#
# After the script prints done:
# tmux a -t sx-hs-e
# Ctrl-B + <0..4> to switch (0=e36 ... 4=e40)
# Ctrl-B + d to detach
#
# Stop: ./scripts/sx-hs-e-down.sh
set -euo pipefail
ROOT="$(cd "$(dirname "$0")/.." && pwd)"
cd "$ROOT"
SESSION="sx-hs-e"
WORKTREE_BASE="/root/rose-ash-e"
INTERVAL="${1:-}"
BOOT_WAIT=20
if tmux has-session -t "$SESSION" 2>/dev/null; then
echo "Session '$SESSION' already exists."
echo " Attach: tmux a -t $SESSION"
echo " Kill: ./scripts/sx-hs-e-down.sh"
exit 1
fi
declare -A DESIGN=(
[e36]=e36-websocket.md
[e37]=e37-tokenizer-api.md
[e38]=e38-sourceinfo.md
[e39]=e39-webworker.md
[e40]=e40-real-fetch.md
)
declare -A BRANCH=(
[e36]=hs-e36-websocket
[e37]=hs-e37-tokenizer
[e38]=hs-e38-sourceinfo
[e39]=hs-e39-webworker
[e40]=hs-e40-fetch
)
declare -A LABEL=(
[e36]="E36 WebSocket (+16)"
[e37]="E37 Tokenizer-as-API (+17)"
[e38]="E38 SourceInfo (+4)"
[e39]="E39 WebWorker (+1)"
[e40]="E40 Fetch/non-2xx (+7)"
)
ORDER=(e36 e37 e38 e39 e40)
write_worktree_settings() {
local wt="$1"
local settings_dir="$wt/.claude"
mkdir -p "$settings_dir"
cat > "$settings_dir/settings.local.json" <<'SETTINGS'
{
"permissions": {
"allow": [
"mcp__sx-tree__sx_summarise",
"mcp__sx-tree__sx_read_tree",
"mcp__sx-tree__sx_read_subtree",
"mcp__sx-tree__sx_get_context",
"mcp__sx-tree__sx_find_all",
"mcp__sx-tree__sx_find_across",
"mcp__sx-tree__sx_get_siblings",
"mcp__sx-tree__sx_validate",
"mcp__sx-tree__sx_replace_node",
"mcp__sx-tree__sx_insert_child",
"mcp__sx-tree__sx_insert_near",
"mcp__sx-tree__sx_delete_node",
"mcp__sx-tree__sx_wrap_node",
"mcp__sx-tree__sx_rename_symbol",
"mcp__sx-tree__sx_replace_by_pattern",
"mcp__sx-tree__sx_rename_across",
"mcp__sx-tree__sx_write_file",
"mcp__sx-tree__sx_pretty_print",
"mcp__sx-tree__sx_eval",
"mcp__sx-tree__sx_harness_eval",
"mcp__sx-tree__sx_macroexpand",
"mcp__sx-tree__sx_trace",
"mcp__sx-tree__sx_deps",
"mcp__sx-tree__sx_diff",
"mcp__sx-tree__sx_diff_branch",
"mcp__sx-tree__sx_changed",
"mcp__sx-tree__sx_blame",
"mcp__sx-tree__sx_build",
"mcp__sx-tree__sx_build_manifest",
"mcp__sx-tree__sx_build_bytecode",
"mcp__sx-tree__sx_test",
"mcp__sx-tree__sx_format_check",
"mcp__sx-tree__sx_comp_list",
"mcp__sx-tree__sx_comp_usage",
"mcp__sx-tree__sx_nav",
"mcp__sx-tree__sx_env",
"mcp__sx-tree__sx_playwright",
"mcp__hs-test__hs_test_run",
"mcp__hs-test__hs_test_regen",
"mcp__hs-test__hs_test_kill",
"mcp__hs-test__hs_test_status",
"Bash(node *)",
"Bash(python3 *)",
"Bash(bash *)",
"Bash(cp *)",
"Bash(git *)"
]
},
"enabledMcpjsonServers": [
"sx-tree",
"rose-ash-services",
"hs-test"
]
}
SETTINGS
}
echo "Preparing Bucket-E worktrees under $WORKTREE_BASE ..."
mkdir -p "$WORKTREE_BASE"
for item in "${ORDER[@]}"; do
wt="$WORKTREE_BASE/$item"
branch="${BRANCH[$item]}"
# Create or reset implementation branch from loops/hs
if git show-ref --verify --quiet "refs/heads/$branch"; then
echo " $item: branch $branch exists"
else
git branch "$branch" loops/hs
echo " $item: created branch $branch from loops/hs"
fi
# Add worktree
if [ -d "$wt/.git" ] || [ -f "$wt/.git" ]; then
echo " $item: worktree exists at $wt"
else
git worktree add "$wt" "$branch"
echo " $item: worktree created at $wt"
fi
write_worktree_settings "$wt"
done
# Create tmux session
tmux new-session -d -s "$SESSION" -n "${ORDER[0]}" -c "$WORKTREE_BASE/${ORDER[0]}"
for item in "${ORDER[@]:1}"; do
tmux new-window -t "$SESSION" -n "$item" -c "$WORKTREE_BASE/$item"
done
echo "Starting ${#ORDER[@]} claude sessions..."
for item in "${ORDER[@]}"; do
tmux send-keys -t "$SESSION:$item" "claude" C-m
done
echo "Waiting ${BOOT_WAIT}s for claude to boot..."
sleep "$BOOT_WAIT"
for item in "${ORDER[@]}"; do
design="${DESIGN[$item]}"
label="${LABEL[$item]}"
branch="${BRANCH[$item]}"
if [ -n "$INTERVAL" ]; then
preamble="/loop $INTERVAL "
else
preamble="/loop "
fi
cmd="${preamble}You are implementing HS conformance Bucket-E item ${label}. Read plans/designs/${design} carefully — it is your complete spec. Do ONE piece of work per fire: implement the next unimplemented step from the design doc, run the relevant hs_test_run suite to verify, commit with a short factual message, then stop. Scope: lib/hyperscript/**, tests/playwright/generate-sx-tests.py, tests/hs-run-filtered.js only — never touch spec/, hosts/, shared/ kernel, or other lib/<lang>/. Use sx-tree MCP for all .sx edits. You are on branch ${branch} in worktree /root/rose-ash-e/${item}; push commits to origin/${branch} (never main or loops/hs)."
tmux send-keys -t "$SESSION:$item" "$cmd"
sleep 0.5
tmux send-keys -t "$SESSION:$item" Enter
done
echo ""
echo "Done. 5 Bucket-E loops started in tmux session '$SESSION'."
echo ""
echo " Attach: tmux a -t $SESSION"
echo " Switch: Ctrl-B <0..4> (0=e36 1=e37 2=e38 3=e39 4=e40)"
echo " List: Ctrl-B w"
echo " Detach: Ctrl-B d"
echo " Stop: ./scripts/sx-hs-e-down.sh"
echo ""
echo "Worktrees:"
git worktree list | grep rose-ash-e || true

67
scripts/sx-loops-up.sh
View File

@@ -48,72 +48,6 @@ ORDER=(lua prolog forth erlang haskell js hs smalltalk common-lisp apl ruby tcl)
mkdir -p "$WORKTREE_BASE"
# Settings written into every worktree so loops never stall on sx-tree permission prompts
write_worktree_settings() {
local wt="$1"
local settings_dir="$wt/.claude"
mkdir -p "$settings_dir"
cat > "$settings_dir/settings.local.json" <<'SETTINGS'
{
"permissions": {
"allow": [
"mcp__sx-tree__sx_summarise",
"mcp__sx-tree__sx_read_tree",
"mcp__sx-tree__sx_read_subtree",
"mcp__sx-tree__sx_get_context",
"mcp__sx-tree__sx_find_all",
"mcp__sx-tree__sx_find_across",
"mcp__sx-tree__sx_get_siblings",
"mcp__sx-tree__sx_validate",
"mcp__sx-tree__sx_replace_node",
"mcp__sx-tree__sx_insert_child",
"mcp__sx-tree__sx_insert_near",
"mcp__sx-tree__sx_delete_node",
"mcp__sx-tree__sx_wrap_node",
"mcp__sx-tree__sx_rename_symbol",
"mcp__sx-tree__sx_replace_by_pattern",
"mcp__sx-tree__sx_rename_across",
"mcp__sx-tree__sx_write_file",
"mcp__sx-tree__sx_pretty_print",
"mcp__sx-tree__sx_eval",
"mcp__sx-tree__sx_harness_eval",
"mcp__sx-tree__sx_macroexpand",
"mcp__sx-tree__sx_trace",
"mcp__sx-tree__sx_deps",
"mcp__sx-tree__sx_diff",
"mcp__sx-tree__sx_diff_branch",
"mcp__sx-tree__sx_changed",
"mcp__sx-tree__sx_blame",
"mcp__sx-tree__sx_build",
"mcp__sx-tree__sx_build_manifest",
"mcp__sx-tree__sx_build_bytecode",
"mcp__sx-tree__sx_test",
"mcp__sx-tree__sx_format_check",
"mcp__sx-tree__sx_comp_list",
"mcp__sx-tree__sx_comp_usage",
"mcp__sx-tree__sx_nav",
"mcp__sx-tree__sx_env",
"mcp__sx-tree__sx_playwright",
"mcp__hs-test__hs_test_run",
"mcp__hs-test__hs_test_regen",
"mcp__hs-test__hs_test_kill",
"mcp__hs-test__hs_test_status",
"Bash(node *)",
"Bash(python3 *)",
"Bash(bash *)",
"Bash(cp *)",
"Bash(git *)"
]
},
"enabledMcpjsonServers": [
"sx-tree",
"rose-ash-services",
"hs-test"
]
}
SETTINGS
}
echo "Preparing per-language worktrees under $WORKTREE_BASE ..."
for lang in "${ORDER[@]}"; do
wt="$WORKTREE_BASE/$lang"
@@ -129,7 +63,6 @@ for lang in "${ORDER[@]}"; do
fi
echo " $lang: worktree created at $wt on $branch"
fi
write_worktree_settings "$wt"
done
# Create tmux session with one window per language, each cwd in its worktree

15
scripts/sx-primitives-down.sh
View File

@@ -1,15 +0,0 @@
#!/usr/bin/env bash
# Stop the sx-primitives tmux session.
set -euo pipefail
SESSION="sx-primitives"
if tmux has-session -t "$SESSION" 2>/dev/null; then
tmux send-keys -t "$SESSION:primitives" "/exit" C-m 2>/dev/null || true
echo "Sent /exit. Waiting 5s..."
sleep 5
tmux kill-session -t "$SESSION"
echo "Killed tmux session '$SESSION'."
else
echo "No $SESSION tmux session running."
fi

70
shared/static/scripts/sx-browser.js
View File

@@ -41,7 +41,7 @@
// =========================================================================
var NIL = Object.freeze({ _nil: true, toString: function() { return "nil"; } });
var SX_VERSION = "2026-05-01T19:10:01Z";
var SX_VERSION = "2026-05-01T18:54:28Z";
function isNil(x) { return x === NIL || x === null || x === undefined; }
function isSxTruthy(x) { return x !== false && !isNil(x); }
@@ -186,7 +186,6 @@
if (x._hash_table) return "hash-table";
if (x._sxset) return "set";
if (x._regexp) return "regexp";
if (x._bytevector) return "bytevector";
if (x._rational) return "rational";
if (typeof Node !== "undefined" && x instanceof Node) return "dom-node";
if (Array.isArray(x)) return "list";
@@ -1214,73 +1213,6 @@
};
// stdlib.bytevectors — R7RS bytevector type backed by Uint8Array
function SxBytevector(size_or_buf) {
if (size_or_buf instanceof Uint8Array) {
this.data = size_or_buf;
} else {
this.data = new Uint8Array(typeof size_or_buf === "number" ? size_or_buf : 0);
}
this._bytevector = true;
}
SxBytevector.prototype._type = "bytevector";
PRIMITIVES["make-bytevector"] = function(n, fill) {
var bv = new SxBytevector(n);
if (fill !== undefined) bv.data.fill(fill & 0xff);
return bv;
};
PRIMITIVES["bytevector?"] = function(v) { return v instanceof SxBytevector; };
PRIMITIVES["bytevector-length"] = function(bv) { return bv.data.length; };
PRIMITIVES["bytevector-u8-ref"] = function(bv, i) { return bv.data[i]; };
PRIMITIVES["bytevector-u8-set!"] = function(bv, i, byte) { bv.data[i] = byte & 0xff; return NIL; };
PRIMITIVES["bytevector-copy"] = function(bv, start, end_) {
var s = start === undefined ? 0 : start;
var e = end_ === undefined ? bv.data.length : end_;
return new SxBytevector(bv.data.slice(s, e));
};
PRIMITIVES["bytevector-copy!"] = function(dst, at, src, start, end_) {
var s = start === undefined ? 0 : start;
var e = end_ === undefined ? src.data.length : end_;
dst.data.set(src.data.subarray(s, e), at);
return NIL;
};
PRIMITIVES["bytevector-append"] = function() {
var total = 0;
for (var i = 0; i < arguments.length; i++) total += arguments[i].data.length;
var result = new Uint8Array(total);
var pos = 0;
for (var i = 0; i < arguments.length; i++) {
result.set(arguments[i].data, pos);
pos += arguments[i].data.length;
}
return new SxBytevector(result);
};
PRIMITIVES["utf8->string"] = function(bv, start, end_) {
var s = start === undefined ? 0 : start;
var e = end_ === undefined ? bv.data.length : end_;
var dec = new TextDecoder("utf-8");
return dec.decode(bv.data.subarray(s, e));
};
PRIMITIVES["string->utf8"] = function(str, start, end_) {
var enc = new TextEncoder();
var full = enc.encode(str);
var s = start === undefined ? 0 : start;
var e = end_ === undefined ? full.length : end_;
return new SxBytevector(full.slice(s, e));
};
PRIMITIVES["bytevector->list"] = function(bv) {
var out = [];
for (var i = 0; i < bv.data.length; i++) out.push(bv.data[i]);
return out;
};
PRIMITIVES["list->bytevector"] = function(lst) {
if (!Array.isArray(lst)) lst = [];
var b = new Uint8Array(lst.length);
for (var i = 0; i < lst.length; i++) b[i] = lst[i] & 0xff;
return new SxBytevector(b);
};
function isPrimitive(name) { return name in PRIMITIVES; }
function getPrimitive(name) { return PRIMITIVES[name]; }

150
shared/static/wasm/sx/hs-compiler.sx
View File

@@ -274,33 +274,17 @@
((name (nth ast 1)) (rest-parts (rest (rest ast))))
(cond
((and (= (len ast) 4) (list? (nth ast 2)) (= (first (nth ast 2)) (quote dict)))
(let
((tgt-ast (nth ast 3)))
(list
(quote dom-dispatch)
(if
(and (list? tgt-ast) (= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast))
(hs-to-sx (nth ast 3))
name
(hs-to-sx (nth ast 2)))))
(hs-to-sx (nth ast 2))))
((= (len ast) 3)
(let
((tgt-ast (nth ast 2)))
(list
(quote dom-dispatch)
(if
(and (list? tgt-ast) (= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast))
(hs-to-sx (nth ast 2))
name
(list (quote dict) "sender" (quote me)))))
(list (quote dict) "sender" (quote me))))
(true
(list
(quote dom-dispatch)
@@ -1241,22 +1225,13 @@
((raw-tgt (nth ast 2)))
(if
(and (list? raw-tgt) (= (first raw-tgt) (quote query)))
(list
(quote let)
(list
(list
(quote _tgt)
(list (quote hs-query-named-all) (nth raw-tgt 1))))
(list
(quote for-each)
(list
(quote fn)
(list (quote _el))
(list
(quote dom-add-class)
(quote _el)
(nth ast 1)))
(quote _tgt)))
(list (quote dom-add-class) (quote _el) (nth ast 1)))
(list (quote hs-query-all) (nth raw-tgt 1)))
(list
(quote dom-add-class)
(hs-to-sx raw-tgt)
@@ -1269,20 +1244,14 @@
(nth ast 2)))
((= head (quote set-styles))
(let
((pairs (nth ast 1)) (tgt-ast (nth ast 2)))
(let
((tgt (if (and (list? tgt-ast) (= (first tgt-ast) (quote query))) (list (quote hs-named-target) (nth tgt-ast 1) (list (quote hs-query-first) (nth tgt-ast 1))) (hs-to-sx tgt-ast))))
((pairs (nth ast 1)) (tgt (hs-to-sx (nth ast 2))))
(cons
(quote do)
(map
(fn
(p)
(list
(quote dom-set-style)
tgt
(first p)
(nth p 1)))
pairs)))))
(list (quote dom-set-style) tgt (first p) (nth p 1)))
pairs))))
((= head (quote multi-add-class))
(let
((target (hs-to-sx (nth ast 1)))
@@ -1379,12 +1348,6 @@
((raw-tgt (nth ast 2)))
(if
(and (list? raw-tgt) (= (first raw-tgt) (quote query)))
(list
(quote let)
(list
(list
(quote _tgt)
(list (quote hs-query-named-all) (nth raw-tgt 1))))
(list
(quote for-each)
(list
@@ -1394,7 +1357,7 @@
(quote dom-remove-class)
(quote _el)
(nth ast 1)))
(quote _tgt)))
(list (quote hs-query-all) (nth raw-tgt 1)))
(list
(quote dom-remove-class)
(if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt))
@@ -1435,18 +1398,10 @@
(list (quote hs-add-to!) val (hs-to-sx tgt)))))
((= head (quote add-attr))
(let
((tgt-ast tgt))
((tgt (nth ast 3)))
(list
(quote hs-set-attr!)
(if
(and
(list? tgt-ast)
(= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast))
(hs-to-sx tgt)
(nth ast 1)
(hs-to-sx (nth ast 2)))))
((= head (quote remove-value))
@@ -1497,20 +1452,10 @@
(fn (p) (list (quote dom-set-style) tgt p ""))
props))))
((= head (quote toggle-class))
(let
((tgt-ast (nth ast 2)))
(list
(quote hs-toggle-class!)
(if
(and
(list? tgt-ast)
(= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast))
(nth ast 1))))
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote toggle-class-for))
(list
(quote do)
@@ -1565,21 +1510,11 @@
(hs-to-sx tgt-ast)
(hs-to-sx val-ast)))))
((= head (quote toggle-between))
(let
((tgt-ast (nth ast 3)))
(list
(quote hs-toggle-between!)
(if
(and
(list? tgt-ast)
(= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast))
(hs-to-sx (nth ast 3))
(nth ast 1)
(nth ast 2))))
(nth ast 2)))
((= head (quote toggle-style))
(let
((raw-tgt (nth ast 2)))
@@ -1603,20 +1538,10 @@
(quote list)
(map hs-to-sx (slice ast 3 (len ast))))))
((= head (quote toggle-attr))
(let
((tgt-ast (nth ast 2)))
(list
(quote hs-toggle-attr!)
(if
(and
(list? tgt-ast)
(= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast))
(nth ast 1))))
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote toggle-attr-between))
(list
(quote hs-toggle-attr-between!)
@@ -1650,22 +1575,7 @@
(emit-set
raw-tgt
(list (quote hs-put-at!) val pos (hs-to-sx raw-tgt))))
(true
(let
((tgt-ast raw-tgt))
(list
(quote hs-put!)
val
pos
(if
(and
(list? tgt-ast)
(= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast))))))))
(true (list (quote hs-put!) val pos (hs-to-sx raw-tgt))))))
((= head (quote if))
(if
(> (len ast) 3)
@@ -1741,22 +1651,12 @@
(detail (if (= (len ast) 4) (nth ast 2) nil)))
(list
(quote dom-dispatch)
(let
((tgt-ast tgt))
(if
(and
(list? tgt-ast)
(= (first tgt-ast) (quote query)))
(list
(quote hs-named-target)
(nth tgt-ast 1)
(list (quote hs-query-first) (nth tgt-ast 1)))
(hs-to-sx tgt-ast)))
(hs-to-sx tgt)
name
(if has-detail (hs-to-sx detail) nil))))
((= head (quote hide))
(let
((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-named-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt))))
((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt))))
(strategy (if (> (len ast) 2) (nth ast 2) "display"))
(when-cond (if (> (len ast) 3) (nth ast 3) nil)))
(if
@@ -1772,7 +1672,7 @@
(hs-to-sx when-cond))))))
((= head (quote show))
(let
((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-named-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt))))
((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt))))
(strategy (if (> (len ast) 2) (nth ast 2) "display"))
(when-cond (if (> (len ast) 3) (nth ast 3) nil)))
(if
@@ -1974,11 +1874,7 @@
((= head (quote install))
(cons (quote hs-install) (map hs-to-sx (rest ast))))
((= head (quote measure))
(let
((raw-tgt (nth ast 1)))
(let
((compiled-tgt (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-named-target) (nth raw-tgt 1) (list (quote hs-query-first) (nth raw-tgt 1))) (hs-to-sx raw-tgt))))
(list (quote hs-measure) compiled-tgt))))
(list (quote hs-measure) (hs-to-sx (nth ast 1))))
((= head (quote increment!))
(if
(= (len ast) 3)

29
shared/static/wasm/sx/hs-runtime.sx
View File

@@ -2466,35 +2466,6 @@
((nth entry 2) val)))
_hs-dom-watchers)))
(define
hs-null-error!
(fn (selector) (raise (str "'" selector "' is null"))))
(define
hs-named-target
(fn (selector value) (if (nil? value) (hs-null-error! selector) value)))
(define
hs-named-target-list
(fn
(selector values)
(if (nil? values) (hs-null-error! selector) values)))
(define
hs-query-named-all
(fn
(selector)
(let
((results (hs-query-all selector)))
(if
(and
(or (nil? results) (and (list? results) (= (len results) 0)))
(string? selector)
(> (len selector) 0)
(= (substring selector 0 1) "#"))
(hs-null-error! selector)
results))))
(define
hs-dom-is-ancestor?
(fn

17897
shared/static/wasm/sx_browser.bc.js
View File

File diff suppressed because one or more lines are too long

2
shared/static/wasm/sx_browser.bc.wasm.js
View File

@@ -1792,7 +1792,7 @@
blake2_js_for_wasm_create: blake2_js_for_wasm_create};
}
(globalThis))
({"link":[["runtime-0db9b496",0],["prelude-d7e4b000",0],["stdlib-23ce0836",[]],["re-9a0de245",[2]],["sx-3a32ee22",[2,3]],["jsoo_runtime-f96b44a8",[2]],["js_of_ocaml-651f6707",[2,5]],["dune__exe__Sx_browser-456e4a54",[2,4,6]],["std_exit-10fb8830",[2]],["start-f808dbe1",0]],"generated":(b=>{var
({"link":[["runtime-0db9b496",0],["prelude-d7e4b000",0],["stdlib-23ce0836",[]],["re-9a0de245",[2]],["sx-f783241f",[2,3]],["jsoo_runtime-f96b44a8",[2]],["js_of_ocaml-651f6707",[2,5]],["dune__exe__Sx_browser-30cab65c",[2,4,6]],["std_exit-10fb8830",[2]],["start-f808dbe1",0]],"generated":(b=>{var
c=b,a=b?.module?.export||b;return{"env":{"caml_ba_kind_of_typed_array":()=>{throw new
Error("caml_ba_kind_of_typed_array not implemented")},"caml_exn_with_js_backtrace":()=>{throw new
Error("caml_exn_with_js_backtrace not implemented")},"caml_int64_create_lo_mi_hi":()=>{throw new

28
sx/sxc/pages/sx_router.py
View File

@@ -200,21 +200,14 @@ async def eval_sx_url(raw_path: str) -> Any:
ocaml_ctx = {"_helper_service": "sx"}
if is_htmx_request():
# HTMX: render everything to HTML server-side.
# aser_slot left content component calls unexpanded (browser
# doesn't have their definitions). bridge.render expands all
# server-affinity components — ~layouts/doc, content pages,
# syntax highlighting — before the response is sent.
# handle-html-response in engine.sx processes sx-swap-oob
# attributes (filter/aside/root-menu/sx-nav) as OOB swaps,
# then puts the remaining #main-panel section in the target.
# HTMX: single-pass — OOB wrapper + content in ONE aser_slot
oob_ast = [
Symbol("~shared:layout/oob-sx"),
Keyword("content"), wrapped_ast,
]
html = await bridge.render(serialize(oob_ast), ctx=ocaml_ctx)
return await make_response(html, 200,
{"Content-Type": "text/html; charset=utf-8"})
content_sx = SxExpr(await bridge.aser_slot(
serialize(oob_ast), ctx=ocaml_ctx))
return sx_response(content_sx)
else:
# Full page: single OCaml call — aser-slot + shell render
full_ast = [
@@ -243,18 +236,9 @@ async def eval_sx_url(raw_path: str) -> Any:
logger.error("SX URL render failed for %s: %s", raw_path, e, exc_info=True)
return None
# Return response (Python path — SX_USE_OCAML=0 only)
# Return response (Python path)
if is_htmx_request():
from shared.sx.async_eval import async_render
from shared.sx.jinja_bridge import get_component_env
oob_ast = [
Symbol("~shared:layout/oob-sx"),
Keyword("content"), wrapped_ast,
]
env2 = dict(get_component_env())
html = await async_render(oob_ast, env2, ctx)
return await make_response(html, 200,
{"Content-Type": "text/html; charset=utf-8"})
return sx_response(await oob_page_sx(content=content_sx))
else:
tctx = await get_template_context()
html = await full_page_sx(tctx, header_rows="", content=content_sx)