diff --git a/lib/prolog/conformance.sh b/lib/prolog/conformance.sh index 8e7096a3..85f87d92 100755 --- a/lib/prolog/conformance.sh +++ b/lib/prolog/conformance.sh @@ -36,6 +36,7 @@ SUITES=( "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!" ) SCRIPT='(epoch 1) diff --git a/lib/prolog/runtime.sx b/lib/prolog/runtime.sx index 2f815716..ef3edfb7 100644 --- a/lib/prolog/runtime.sx +++ b/lib/prolog/runtime.sx @@ -1213,6 +1213,152 @@ ((sx-lst (pl-prolog-list-to-sx (pl-walk-deep pl-lst)))) (some (fn (x) (pl-struct-eq? elem x)) sx-lst)))) +(define pl-char-code (fn (atom-term) (char-code (pl-atom-name atom-term)))) + +(define + pl-char-alpha? + (fn + (code) + (or (and (>= code 65) (<= code 90)) (and (>= code 97) (<= code 122))))) + +(define pl-char-digit? (fn (code) (and (>= code 48) (<= code 57)))) + +(define + pl-char-space? + (fn (code) (or (= code 32) (= code 9) (= code 10) (= code 13)))) + +(define pl-char-upper? (fn (code) (and (>= code 65) (<= code 90)))) + +(define pl-char-lower? (fn (code) (and (>= code 97) (<= code 122)))) + +(define + pl-upcase-char + (fn + (c) + (let + ((code (char-code c))) + (if (pl-char-lower? code) (char-from-code (- code 32)) c)))) + +(define + pl-downcase-char + (fn + (c) + (let + ((code (char-code c))) + (if (pl-char-upper? code) (char-from-code (+ code 32)) c)))) + +(define + pl-upcase-string + (fn (s) (join "" (map pl-upcase-char (split s ""))))) + +(define + pl-downcase-string + (fn (s) (join "" (map pl-downcase-char (split s ""))))) + +(define + pl-solve-char-type! + (fn + (db char type-term trail k) + (let + ((ch (pl-walk-deep char)) (tp (pl-walk-deep type-term))) + (if + (not (pl-atom? ch)) + false + (let + ((code (pl-char-code ch))) + (cond + ((and (pl-atom? tp) (= (pl-atom-name tp) "alpha")) + (if (pl-char-alpha? code) (k) false)) + ((and (pl-atom? tp) (= (pl-atom-name tp) "alnum")) + (if + (or (pl-char-alpha? code) (pl-char-digit? code)) + (k) + false)) + ((and (pl-atom? tp) (= (pl-atom-name tp) "digit")) + (if (pl-char-digit? code) (k) false)) + ((and (pl-compound? tp) (= (pl-fun tp) "digit") (= (len (pl-args tp)) 1)) + (if + (pl-char-digit? code) + (let + ((weight (list "num" (- code 48)))) + (if + (pl-unify! (nth (pl-args tp) 0) weight trail) + (k) + false)) + false)) + ((and (pl-atom? tp) (or (= (pl-atom-name tp) "space") (= (pl-atom-name tp) "white"))) + (if (pl-char-space? code) (k) false)) + ((and (pl-compound? tp) (= (pl-fun tp) "upper") (= (len (pl-args tp)) 1)) + (if + (pl-char-upper? code) + (let + ((lower-atom (list "atom" (char-from-code (+ code 32))))) + (if + (pl-unify! (nth (pl-args tp) 0) lower-atom trail) + (k) + false)) + false)) + ((and (pl-compound? tp) (= (pl-fun tp) "lower") (= (len (pl-args tp)) 1)) + (if + (pl-char-lower? code) + (let + ((upper-atom (list "atom" (char-from-code (- code 32))))) + (if + (pl-unify! (nth (pl-args tp) 0) upper-atom trail) + (k) + false)) + false)) + ((and (pl-compound? tp) (= (pl-fun tp) "ascii") (= (len (pl-args tp)) 1)) + (if + (< code 128) + (let + ((code-term (list "num" code))) + (if + (pl-unify! (nth (pl-args tp) 0) code-term trail) + (k) + false)) + false)) + ((and (pl-atom? tp) (= (pl-atom-name tp) "punct")) + (if + (and + (not (pl-char-alpha? code)) + (not (pl-char-digit? code)) + (not (pl-char-space? code)) + (< code 128)) + (k) + false)) + (else false))))))) + +(define + pl-solve-upcase-atom! + (fn + (atom-rt result-rt trail k) + (let + ((a (pl-walk atom-rt))) + (if + (pl-atom? a) + (pl-solve-eq! + result-rt + (list "atom" (pl-upcase-string (pl-atom-name a))) + trail + k) + false)))) + +(define + pl-solve-downcase-atom! + (fn + (atom-rt result-rt trail k) + (let + ((a (pl-walk atom-rt))) + (if + (pl-atom? a) + (pl-solve-eq! + result-rt + (list "atom" (pl-downcase-string (pl-atom-name a))) + trail + k) + false)))) + (define pl-solve! (fn @@ -1880,6 +2026,37 @@ trail k)))) false))) + ((and (pl-compound? g) (= (pl-fun g) "char_type") (= (len (pl-args g)) 2)) + (pl-solve-char-type! + db + (pl-walk (nth (pl-args g) 0)) + (pl-walk (nth (pl-args g) 1)) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "upcase_atom") (= (len (pl-args g)) 2)) + (pl-solve-upcase-atom! + (nth (pl-args g) 0) + (nth (pl-args g) 1) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "downcase_atom") (= (len (pl-args g)) 2)) + (pl-solve-downcase-atom! + (nth (pl-args g) 0) + (nth (pl-args g) 1) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "string_upper") (= (len (pl-args g)) 2)) + (pl-solve-upcase-atom! + (nth (pl-args g) 0) + (nth (pl-args g) 1) + trail + k)) + ((and (pl-compound? g) (= (pl-fun g) "string_lower") (= (len (pl-args g)) 2)) + (pl-solve-downcase-atom! + (nth (pl-args g) 0) + (nth (pl-args g) 1) + trail + k)) (true (pl-solve-user! db g trail cut-box k)))))) (define diff --git a/lib/prolog/scoreboard.json b/lib/prolog/scoreboard.json index 9a9610f2..3995ec66 100644 --- a/lib/prolog/scoreboard.json +++ b/lib/prolog/scoreboard.json @@ -1,7 +1,7 @@ { - "total_passed": 405, + "total_passed": 432, "total_failed": 0, - "total": 405, - "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}}, - "generated": "2026-04-25T12:21:38+00:00" + "total": 432, + "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}}, + "generated": "2026-04-25T12:40:55+00:00" } diff --git a/lib/prolog/scoreboard.md b/lib/prolog/scoreboard.md index eb9cfe28..2d40f88c 100644 --- a/lib/prolog/scoreboard.md +++ b/lib/prolog/scoreboard.md @@ -1,7 +1,7 @@ # Prolog scoreboard -**405 / 405 passing** (0 failure(s)). -Generated 2026-04-25T12:21:38+00:00. +**432 / 432 passing** (0 failure(s)). +Generated 2026-04-25T12:40:55+00:00. | Suite | Passed | Total | Status | |-------|--------|-------|--------| @@ -25,6 +25,7 @@ Generated 2026-04-25T12:21:38+00:00. | list_predicates | 33 | 33 | ok | | meta_call | 15 | 15 | ok | | set_predicates | 15 | 15 | ok | +| char_predicates | 27 | 27 | ok | Run `bash lib/prolog/conformance.sh` to refresh. Override the binary with `SX_SERVER=path/to/sx_server.exe bash …`. diff --git a/lib/prolog/tests/char_predicates.sx b/lib/prolog/tests/char_predicates.sx new file mode 100644 index 00000000..e60bad58 --- /dev/null +++ b/lib/prolog/tests/char_predicates.sx @@ -0,0 +1,290 @@ +;; 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})) \ No newline at end of file