String/atom predicates: var/nonvar/atom/number/compound/callable/atomic/is_list + atom_length/atom_concat/atom_chars/atom_codes/char_code/number_codes/number_chars
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
This commit is contained in:
@@ -595,6 +595,182 @@
|
||||
pl-cut?
|
||||
(fn (t) (and (list? t) (not (empty? t)) (= (first t) "cut"))))
|
||||
|
||||
(define
|
||||
pl-list-to-prolog
|
||||
(fn
|
||||
(xs)
|
||||
(if
|
||||
(empty? xs)
|
||||
(list "atom" "[]")
|
||||
(list "compound" "." (list (first xs) (pl-list-to-prolog (rest xs)))))))
|
||||
|
||||
(define
|
||||
pl-proper-list?
|
||||
(fn
|
||||
(t)
|
||||
(let
|
||||
((w (pl-walk t)))
|
||||
(cond
|
||||
((and (pl-atom? w) (= (pl-atom-name w) "[]")) true)
|
||||
((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
|
||||
(pl-proper-list? (nth (pl-args w) 1)))
|
||||
(true false)))))
|
||||
|
||||
(define
|
||||
pl-prolog-list-to-sx
|
||||
(fn
|
||||
(t)
|
||||
(let
|
||||
((w (pl-walk 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-walk (first (pl-args w)))
|
||||
(pl-prolog-list-to-sx (nth (pl-args w) 1))))
|
||||
(true (list))))))
|
||||
|
||||
(define
|
||||
pl-solve-atom-concat!
|
||||
(fn
|
||||
(a1-rt a2-rt a3-rt trail k)
|
||||
(let
|
||||
((a1 (pl-walk a1-rt)) (a2 (pl-walk a2-rt)) (a3 (pl-walk a3-rt)))
|
||||
(cond
|
||||
((and (pl-atom? a1) (pl-atom? a2))
|
||||
(pl-solve-eq!
|
||||
a3-rt
|
||||
(list "atom" (str (pl-atom-name a1) (pl-atom-name a2)))
|
||||
trail
|
||||
k))
|
||||
((and (pl-atom? a3) (pl-atom? a1))
|
||||
(let
|
||||
((s3 (pl-atom-name a3)) (s1 (pl-atom-name a1)))
|
||||
(if
|
||||
(starts-with? s3 s1)
|
||||
(pl-solve-eq!
|
||||
a2-rt
|
||||
(list "atom" (substring s3 (len s1) (len s3)))
|
||||
trail
|
||||
k)
|
||||
false)))
|
||||
((and (pl-atom? a3) (pl-atom? a2))
|
||||
(let
|
||||
((s3 (pl-atom-name a3)) (s2 (pl-atom-name a2)))
|
||||
(if
|
||||
(ends-with? s3 s2)
|
||||
(pl-solve-eq!
|
||||
a1-rt
|
||||
(list "atom" (substring s3 0 (- (len s3) (len s2))))
|
||||
trail
|
||||
k)
|
||||
false)))
|
||||
(true false)))))
|
||||
|
||||
(define
|
||||
pl-solve-atom-chars!
|
||||
(fn
|
||||
(atom-rt chars-rt trail k)
|
||||
(let
|
||||
((a (pl-walk atom-rt)))
|
||||
(cond
|
||||
((pl-atom? a)
|
||||
(pl-solve-eq!
|
||||
chars-rt
|
||||
(pl-list-to-prolog
|
||||
(map (fn (c) (list "atom" c)) (split (pl-atom-name a) "")))
|
||||
trail
|
||||
k))
|
||||
((pl-num? a)
|
||||
(pl-solve-eq!
|
||||
chars-rt
|
||||
(pl-list-to-prolog
|
||||
(map
|
||||
(fn (c) (list "atom" c))
|
||||
(split (str (pl-num-val a)) "")))
|
||||
trail
|
||||
k))
|
||||
((pl-var? a)
|
||||
(if
|
||||
(pl-proper-list? chars-rt)
|
||||
(let
|
||||
((char-terms (pl-prolog-list-to-sx chars-rt)))
|
||||
(pl-solve-eq!
|
||||
atom-rt
|
||||
(list
|
||||
"atom"
|
||||
(join "" (map (fn (t) (pl-atom-name t)) char-terms)))
|
||||
trail
|
||||
k))
|
||||
false))
|
||||
(true false)))))
|
||||
|
||||
(define
|
||||
pl-solve-atom-codes!
|
||||
(fn
|
||||
(atom-rt codes-rt trail k)
|
||||
(let
|
||||
((a (pl-walk atom-rt)))
|
||||
(cond
|
||||
((pl-atom? a)
|
||||
(pl-solve-eq!
|
||||
codes-rt
|
||||
(pl-list-to-prolog
|
||||
(map
|
||||
(fn (c) (list "num" (char-code c)))
|
||||
(split (pl-atom-name a) "")))
|
||||
trail
|
||||
k))
|
||||
((pl-num? a)
|
||||
(pl-solve-eq!
|
||||
codes-rt
|
||||
(pl-list-to-prolog
|
||||
(map
|
||||
(fn (c) (list "num" (char-code c)))
|
||||
(split (str (pl-num-val a)) "")))
|
||||
trail
|
||||
k))
|
||||
((pl-var? a)
|
||||
(if
|
||||
(pl-proper-list? codes-rt)
|
||||
(let
|
||||
((code-terms (pl-prolog-list-to-sx codes-rt)))
|
||||
(pl-solve-eq!
|
||||
atom-rt
|
||||
(list
|
||||
"atom"
|
||||
(join
|
||||
""
|
||||
(map
|
||||
(fn (t) (char-from-code (pl-num-val t)))
|
||||
code-terms)))
|
||||
trail
|
||||
k))
|
||||
false))
|
||||
(true false)))))
|
||||
|
||||
(define
|
||||
pl-solve-char-code!
|
||||
(fn
|
||||
(char-rt code-rt trail k)
|
||||
(let
|
||||
((c (pl-walk char-rt)) (n (pl-walk code-rt)))
|
||||
(cond
|
||||
((pl-atom? c)
|
||||
(let
|
||||
((s (pl-atom-name c)))
|
||||
(if
|
||||
(= (len s) 1)
|
||||
(pl-solve-eq! code-rt (list "num" (char-code s)) trail k)
|
||||
false)))
|
||||
((pl-num? n)
|
||||
(pl-solve-eq!
|
||||
char-rt
|
||||
(list "atom" (char-from-code (pl-num-val n)))
|
||||
trail
|
||||
k))
|
||||
(true false)))))
|
||||
|
||||
(define
|
||||
pl-solve!
|
||||
(fn
|
||||
@@ -726,6 +902,106 @@
|
||||
(nth (pl-args g) 2)
|
||||
trail
|
||||
k))
|
||||
((and (pl-compound? g) (= (pl-fun g) "var") (= (len (pl-args g)) 1))
|
||||
(let
|
||||
((a (pl-walk (first (pl-args g)))))
|
||||
(if (pl-var? a) (k) false)))
|
||||
((and (pl-compound? g) (= (pl-fun g) "nonvar") (= (len (pl-args g)) 1))
|
||||
(let
|
||||
((a (pl-walk (first (pl-args g)))))
|
||||
(if (not (pl-var? a)) (k) false)))
|
||||
((and (pl-compound? g) (= (pl-fun g) "atom") (= (len (pl-args g)) 1))
|
||||
(let
|
||||
((a (pl-walk (first (pl-args g)))))
|
||||
(if (pl-atom? a) (k) false)))
|
||||
((and (pl-compound? g) (= (pl-fun g) "number") (= (len (pl-args g)) 1))
|
||||
(let
|
||||
((a (pl-walk (first (pl-args g)))))
|
||||
(if (pl-num? a) (k) false)))
|
||||
((and (pl-compound? g) (= (pl-fun g) "integer") (= (len (pl-args g)) 1))
|
||||
(let
|
||||
((a (pl-walk (first (pl-args g)))))
|
||||
(if (pl-num? a) (k) false)))
|
||||
((and (pl-compound? g) (= (pl-fun g) "float") (= (len (pl-args g)) 1))
|
||||
false)
|
||||
((and (pl-compound? g) (= (pl-fun g) "compound") (= (len (pl-args g)) 1))
|
||||
(let
|
||||
((a (pl-walk (first (pl-args g)))))
|
||||
(if (pl-compound? a) (k) false)))
|
||||
((and (pl-compound? g) (= (pl-fun g) "callable") (= (len (pl-args g)) 1))
|
||||
(let
|
||||
((a (pl-walk (first (pl-args g)))))
|
||||
(if (or (pl-atom? a) (pl-compound? a)) (k) false)))
|
||||
((and (pl-compound? g) (= (pl-fun g) "atomic") (= (len (pl-args g)) 1))
|
||||
(let
|
||||
((a (pl-walk (first (pl-args g)))))
|
||||
(if (or (pl-atom? a) (or (pl-num? a) (pl-str? a))) (k) false)))
|
||||
((and (pl-compound? g) (= (pl-fun g) "is_list") (= (len (pl-args g)) 1))
|
||||
(if (pl-proper-list? (first (pl-args g))) (k) false))
|
||||
((and (pl-compound? g) (= (pl-fun g) "atom_length") (= (len (pl-args g)) 2))
|
||||
(let
|
||||
((a (pl-walk (first (pl-args g)))))
|
||||
(if
|
||||
(pl-atom? a)
|
||||
(pl-solve-eq!
|
||||
(nth (pl-args g) 1)
|
||||
(list "num" (len (pl-atom-name a)))
|
||||
trail
|
||||
k)
|
||||
false)))
|
||||
((and (pl-compound? g) (= (pl-fun g) "atom_concat") (= (len (pl-args g)) 3))
|
||||
(pl-solve-atom-concat!
|
||||
(first (pl-args g))
|
||||
(nth (pl-args g) 1)
|
||||
(nth (pl-args g) 2)
|
||||
trail
|
||||
k))
|
||||
((and (pl-compound? g) (= (pl-fun g) "atom_chars") (= (len (pl-args g)) 2))
|
||||
(pl-solve-atom-chars!
|
||||
(first (pl-args g))
|
||||
(nth (pl-args g) 1)
|
||||
trail
|
||||
k))
|
||||
((and (pl-compound? g) (= (pl-fun g) "atom_codes") (= (len (pl-args g)) 2))
|
||||
(pl-solve-atom-codes!
|
||||
(first (pl-args g))
|
||||
(nth (pl-args g) 1)
|
||||
trail
|
||||
k))
|
||||
((and (pl-compound? g) (= (pl-fun g) "char_code") (= (len (pl-args g)) 2))
|
||||
(pl-solve-char-code!
|
||||
(first (pl-args g))
|
||||
(nth (pl-args g) 1)
|
||||
trail
|
||||
k))
|
||||
((and (pl-compound? g) (= (pl-fun g) "number_codes") (= (len (pl-args g)) 2))
|
||||
(let
|
||||
((a (pl-walk (first (pl-args g)))))
|
||||
(if
|
||||
(pl-num? a)
|
||||
(pl-solve-eq!
|
||||
(nth (pl-args g) 1)
|
||||
(pl-list-to-prolog
|
||||
(map
|
||||
(fn (c) (list "num" (char-code c)))
|
||||
(split (str (pl-num-val a)) "")))
|
||||
trail
|
||||
k)
|
||||
false)))
|
||||
((and (pl-compound? g) (= (pl-fun g) "number_chars") (= (len (pl-args g)) 2))
|
||||
(let
|
||||
((a (pl-walk (first (pl-args g)))))
|
||||
(if
|
||||
(pl-num? a)
|
||||
(pl-solve-eq!
|
||||
(nth (pl-args g) 1)
|
||||
(pl-list-to-prolog
|
||||
(map
|
||||
(fn (c) (list "atom" c))
|
||||
(split (str (pl-num-val a)) "")))
|
||||
trail
|
||||
k)
|
||||
false)))
|
||||
(true (pl-solve-user! db g trail cut-box k))))))
|
||||
|
||||
(define
|
||||
|
||||
Reference in New Issue
Block a user