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

Char predicates: char_type/2, upcase_atom/2, downcase_atom/2, string_upper/2, string_lower/2
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Details

Browse Source 
27 new tests, 432/432 total. char_type/2 supports alpha, alnum, digit,
digit(Weight), space/white, upper(Lower), lower(Upper), ascii(Code), punct.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-25 12:41:31 +00:00
parent 776ae18a20
commit 04ed092f88
5 changed files with 475 additions and 6 deletions
Download Patch File Download Diff File Expand all files Collapse all files

177
lib/prolog/runtime.sx
View File

@@ -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