giles
8a9c074141
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
2795 lines
89 KiB
Plaintext
2795 lines
89 KiB
Plaintext
;; lib/prolog/runtime.sx — unification, trail, and (later) solver
|
|
;;
|
|
;; Phase 2 focus: runtime terms + unification + trail.
|
|
;;
|
|
;; Term representation at runtime:
|
|
;; atom ("atom" name) -- immutable tagged list, same as parse AST
|
|
;; num ("num" n) -- likewise
|
|
;; str ("str" s) -- likewise
|
|
;; compound ("compound" fun args) -- args is a regular list of terms
|
|
;; var {:tag "var" -- MUTABLE dict; :binding = nil (unbound) or term
|
|
;; :name "X"
|
|
;; :id <int>
|
|
;; :binding <term-or-nil>}
|
|
;;
|
|
;; Parse-time ("var" name) tokens must be instantiated into runtime vars
|
|
;; before unification. Fresh renaming happens per clause resolution so
|
|
;; that two separate calls to the same clause don't share variables.
|
|
;;
|
|
;; Trail:
|
|
;; {:entries (<var> <var> ...) :len N} -- stack of vars that got bound
|
|
;; Mark = integer length of the entries list at checkpoint time.
|
|
;; trail-undo-to! pops entries pushed since the mark, nil'ing :binding.
|
|
;;
|
|
;; Occurs-check: off by default; configurable via trail :occurs-check flag.
|
|
|
|
;; ── Var id counter ─────────────────────────────────────────────────
|
|
(define pl-var-counter {:n 0})
|
|
|
|
(define
|
|
pl-fresh-id
|
|
(fn
|
|
()
|
|
(let
|
|
((n (dict-get pl-var-counter :n)))
|
|
(dict-set! pl-var-counter :n (+ n 1))
|
|
n)))
|
|
|
|
;; ── Term constructors / predicates ─────────────────────────────────
|
|
(define pl-mk-rt-var (fn (name) {:tag "var" :id (pl-fresh-id) :name name :binding nil}))
|
|
|
|
(define pl-var? (fn (t) (and (dict? t) (= (dict-get t :tag) "var"))))
|
|
|
|
(define
|
|
pl-atom?
|
|
(fn (t) (and (list? t) (not (empty? t)) (= (first t) "atom"))))
|
|
|
|
(define
|
|
pl-num?
|
|
(fn (t) (and (list? t) (not (empty? t)) (= (first t) "num"))))
|
|
|
|
(define
|
|
pl-str?
|
|
(fn (t) (and (list? t) (not (empty? t)) (= (first t) "str"))))
|
|
|
|
(define
|
|
pl-compound?
|
|
(fn (t) (and (list? t) (not (empty? t)) (= (first t) "compound"))))
|
|
|
|
(define pl-var-name (fn (v) (dict-get v :name)))
|
|
(define pl-var-id (fn (v) (dict-get v :id)))
|
|
(define pl-var-binding (fn (v) (dict-get v :binding)))
|
|
(define pl-var-bound? (fn (v) (not (nil? (dict-get v :binding)))))
|
|
|
|
(define pl-atom-name (fn (t) (nth t 1)))
|
|
(define pl-num-val (fn (t) (nth t 1)))
|
|
(define pl-str-val (fn (t) (nth t 1)))
|
|
(define pl-fun (fn (t) (nth t 1)))
|
|
(define pl-args (fn (t) (nth t 2)))
|
|
|
|
;; ── Instantiate parse AST into runtime terms ──────────────────────
|
|
;; Walk a parser AST term, replacing ("var" name) occurrences with fresh
|
|
;; runtime vars. A name->var dict is threaded so that repeated uses of
|
|
;; the same variable within a clause share the same runtime var.
|
|
;; "_" is anonymous: each occurrence gets a NEW fresh var (never shared).
|
|
|
|
(define
|
|
pl-instantiate
|
|
(fn
|
|
(ast var-env)
|
|
(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 "_")
|
|
(if
|
|
(dict-has? var-env name)
|
|
(dict-get var-env name)
|
|
(let ((v (pl-mk-rt-var name))) (dict-set! var-env name v) v)))))
|
|
((= (first ast) "compound")
|
|
(let
|
|
((fun (nth ast 1)) (args (nth ast 2)))
|
|
(list
|
|
"compound"
|
|
fun
|
|
(map (fn (a) (pl-instantiate a var-env)) args))))
|
|
((= (first ast) "clause")
|
|
(let
|
|
((h (pl-instantiate (nth ast 1) var-env))
|
|
(b (pl-instantiate (nth ast 2) var-env)))
|
|
(list "clause" h b)))
|
|
(true ast))))
|
|
|
|
(define pl-instantiate-fresh (fn (ast) (pl-instantiate ast {})))
|
|
|
|
;; ── Walk: follow binding chain ─────────────────────────────────────
|
|
(define
|
|
pl-walk
|
|
(fn
|
|
(t)
|
|
(if
|
|
(pl-var? t)
|
|
(if (pl-var-bound? t) (pl-walk (pl-var-binding t)) t)
|
|
t)))
|
|
|
|
;; Deep-walk: recursively resolve variables inside compound terms.
|
|
(define
|
|
pl-walk-deep
|
|
(fn
|
|
(t)
|
|
(let
|
|
((w (pl-walk t)))
|
|
(if
|
|
(pl-compound? w)
|
|
(list "compound" (pl-fun w) (map pl-walk-deep (pl-args w)))
|
|
w))))
|
|
|
|
;; ── Trail ─────────────────────────────────────────────────────────
|
|
(define pl-mk-trail (fn () {:entries () :len 0 :occurs-check false}))
|
|
|
|
(define pl-trail-mark (fn (trail) (dict-get trail :len)))
|
|
|
|
(define
|
|
pl-trail-push!
|
|
(fn
|
|
(trail v)
|
|
(dict-set! trail :entries (cons v (dict-get trail :entries)))
|
|
(dict-set! trail :len (+ 1 (dict-get trail :len)))))
|
|
|
|
(define
|
|
pl-trail-undo-to!
|
|
(fn
|
|
(trail mark)
|
|
(let
|
|
loop
|
|
()
|
|
(when
|
|
(> (dict-get trail :len) mark)
|
|
(let
|
|
((entries (dict-get trail :entries)))
|
|
(let
|
|
((top (first entries)) (rest (rest entries)))
|
|
(dict-set! top :binding nil)
|
|
(dict-set! trail :entries rest)
|
|
(dict-set! trail :len (- (dict-get trail :len) 1))
|
|
(loop)))))))
|
|
|
|
;; Bind variable v to term t, recording on the trail.
|
|
(define
|
|
pl-bind!
|
|
(fn (v t trail) (dict-set! v :binding t) (pl-trail-push! trail v)))
|
|
|
|
;; ── Occurs check ──────────────────────────────────────────────────
|
|
(define
|
|
pl-occurs?
|
|
(fn
|
|
(v t)
|
|
(let
|
|
((w (pl-walk t)))
|
|
(cond
|
|
((pl-var? w) (= (pl-var-id v) (pl-var-id w)))
|
|
((pl-compound? w) (some (fn (a) (pl-occurs? v a)) (pl-args w)))
|
|
(true false)))))
|
|
|
|
;; ── Unify ─────────────────────────────────────────────────────────
|
|
;; Unify two terms, mutating trail. Returns true on success.
|
|
;; On failure, the caller must undo to a pre-unify mark.
|
|
(define
|
|
pl-unify!
|
|
(fn
|
|
(t1 t2 trail)
|
|
(let
|
|
((a (pl-walk t1)) (b (pl-walk t2)))
|
|
(cond
|
|
((and (pl-var? a) (pl-var? b) (= (pl-var-id a) (pl-var-id b)))
|
|
true)
|
|
((pl-var? a)
|
|
(if
|
|
(and (dict-get trail :occurs-check) (pl-occurs? a b))
|
|
false
|
|
(do (pl-bind! a b trail) true)))
|
|
((pl-var? b)
|
|
(if
|
|
(and (dict-get trail :occurs-check) (pl-occurs? b a))
|
|
false
|
|
(do (pl-bind! b a trail) true)))
|
|
((and (pl-atom? a) (pl-atom? b))
|
|
(= (pl-atom-name a) (pl-atom-name b)))
|
|
((and (pl-num? a) (pl-num? b)) (= (pl-num-val a) (pl-num-val b)))
|
|
((and (pl-str? a) (pl-str? b)) (= (pl-str-val a) (pl-str-val b)))
|
|
((and (pl-compound? a) (pl-compound? b))
|
|
(if
|
|
(and
|
|
(= (pl-fun a) (pl-fun b))
|
|
(= (len (pl-args a)) (len (pl-args b))))
|
|
(pl-unify-lists! (pl-args a) (pl-args b) trail)
|
|
false))
|
|
(true false)))))
|
|
|
|
(define
|
|
pl-unify-lists!
|
|
(fn
|
|
(xs ys trail)
|
|
(cond
|
|
((and (empty? xs) (empty? ys)) true)
|
|
((or (empty? xs) (empty? ys)) false)
|
|
(true
|
|
(if
|
|
(pl-unify! (first xs) (first ys) trail)
|
|
(pl-unify-lists! (rest xs) (rest ys) trail)
|
|
false)))))
|
|
|
|
;; Convenience: try-unify with auto-undo on failure.
|
|
(define
|
|
pl-try-unify!
|
|
(fn
|
|
(t1 t2 trail)
|
|
(let
|
|
((mark (pl-trail-mark trail)))
|
|
(if
|
|
(pl-unify! t1 t2 trail)
|
|
true
|
|
(do (pl-trail-undo-to! trail mark) false)))))
|
|
|
|
(define pl-mk-db (fn () {:clauses {}}))
|
|
|
|
(define
|
|
pl-head-key
|
|
(fn
|
|
(head)
|
|
(cond
|
|
((pl-compound? head) (str (pl-fun head) "/" (len (pl-args head))))
|
|
((pl-atom? head) (str (pl-atom-name head) "/0"))
|
|
(true (error "pl-head-key: invalid head")))))
|
|
|
|
(define pl-clause-key (fn (clause) (pl-head-key (nth clause 1))))
|
|
|
|
(define pl-goal-key (fn (goal) (pl-head-key goal)))
|
|
|
|
(define
|
|
pl-db-add!
|
|
(fn
|
|
(db clause)
|
|
(let
|
|
((key (pl-clause-key clause)) (table (dict-get db :clauses)))
|
|
(cond
|
|
((nil? (dict-get table key)) (dict-set! table key (list clause)))
|
|
(true (begin (append! (dict-get table key) clause) nil))))))
|
|
|
|
(define
|
|
pl-db-load!
|
|
(fn
|
|
(db program)
|
|
(cond
|
|
((empty? program) nil)
|
|
(true
|
|
(begin
|
|
(pl-db-add! db (first program))
|
|
(pl-db-load! db (rest program)))))))
|
|
|
|
(define
|
|
pl-db-lookup
|
|
(fn
|
|
(db key)
|
|
(let
|
|
((v (dict-get (dict-get db :clauses) key)))
|
|
(cond ((nil? v) (list)) (true v)))))
|
|
|
|
(define
|
|
pl-db-lookup-goal
|
|
(fn (db goal) (pl-db-lookup db (pl-goal-key goal))))
|
|
|
|
(define
|
|
pl-rt-walk-to-ast
|
|
(fn
|
|
(w)
|
|
(cond
|
|
((pl-var? w) (list "var" (str "_G" (pl-var-id w))))
|
|
((and (list? w) (not (empty? w)) (= (first w) "compound"))
|
|
(list "compound" (nth w 1) (map pl-rt-walk-to-ast (nth w 2))))
|
|
(true w))))
|
|
|
|
(define pl-rt-to-ast (fn (t) (pl-rt-walk-to-ast (pl-walk-deep t))))
|
|
|
|
(define
|
|
pl-build-clause
|
|
(fn
|
|
(ast)
|
|
(cond
|
|
((and (list? ast) (= (first ast) "compound") (= (nth ast 1) ":-") (= (len (nth ast 2)) 2))
|
|
(list "clause" (first (nth ast 2)) (nth (nth ast 2) 1)))
|
|
(true (list "clause" ast (list "atom" "true"))))))
|
|
|
|
(define
|
|
pl-db-prepend!
|
|
(fn
|
|
(db clause)
|
|
(let
|
|
((key (pl-clause-key clause)) (table (dict-get db :clauses)))
|
|
(cond
|
|
((nil? (dict-get table key)) (dict-set! table key (list clause)))
|
|
(true (dict-set! table key (cons clause (dict-get table key))))))))
|
|
|
|
(define
|
|
pl-list-without
|
|
(fn
|
|
(lst i)
|
|
(cond
|
|
((empty? lst) (list))
|
|
((= i 0) (rest lst))
|
|
(true (cons (first lst) (pl-list-without (rest lst) (- i 1)))))))
|
|
|
|
(define
|
|
pl-solve-assertz!
|
|
(fn
|
|
(db term k)
|
|
(begin (pl-db-add! db (pl-build-clause (pl-rt-to-ast term))) (k))))
|
|
|
|
(define
|
|
pl-solve-asserta!
|
|
(fn
|
|
(db term k)
|
|
(begin (pl-db-prepend! db (pl-build-clause (pl-rt-to-ast term))) (k))))
|
|
|
|
(define
|
|
pl-solve-retract!
|
|
(fn
|
|
(db term trail k)
|
|
(let
|
|
((head-runtime (cond ((and (pl-compound? term) (= (pl-fun term) ":-") (= (len (pl-args term)) 2)) (first (pl-args term))) (true term)))
|
|
(body-runtime
|
|
(cond
|
|
((and (pl-compound? term) (= (pl-fun term) ":-") (= (len (pl-args term)) 2))
|
|
(nth (pl-args term) 1))
|
|
(true (list "atom" "true")))))
|
|
(let
|
|
((wh (pl-walk head-runtime)))
|
|
(cond
|
|
((pl-var? wh) false)
|
|
(true
|
|
(let
|
|
((key (pl-head-key wh)))
|
|
(pl-retract-try-each
|
|
db
|
|
key
|
|
(pl-db-lookup db key)
|
|
head-runtime
|
|
body-runtime
|
|
0
|
|
trail
|
|
k))))))))
|
|
|
|
(define
|
|
pl-deep-copy
|
|
(fn
|
|
(t var-map)
|
|
(let
|
|
((w (pl-walk t)))
|
|
(cond
|
|
((pl-var? w)
|
|
(let
|
|
((id-key (str (pl-var-id w))))
|
|
(cond
|
|
((dict-has? var-map id-key) (dict-get var-map id-key))
|
|
(true
|
|
(let
|
|
((nv (pl-mk-rt-var (dict-get w :name))))
|
|
(begin (dict-set! var-map id-key nv) nv))))))
|
|
((pl-compound? w)
|
|
(list
|
|
"compound"
|
|
(pl-fun w)
|
|
(map (fn (a) (pl-deep-copy a var-map)) (pl-args w))))
|
|
(true w)))))
|
|
|
|
(define
|
|
pl-each-into-dict!
|
|
(fn
|
|
(terms d)
|
|
(cond
|
|
((empty? terms) nil)
|
|
(true
|
|
(begin
|
|
(dict-set! d (pl-format-term (first terms)) (first terms))
|
|
(pl-each-into-dict! (rest terms) d))))))
|
|
|
|
(define
|
|
pl-sort-uniq-terms
|
|
(fn
|
|
(terms)
|
|
(let
|
|
((kv {}))
|
|
(begin
|
|
(pl-each-into-dict! terms kv)
|
|
(let
|
|
((sorted-keys (sort (keys kv))))
|
|
(map (fn (k) (dict-get kv k)) sorted-keys))))))
|
|
|
|
(define
|
|
pl-collect-vars
|
|
(fn
|
|
(term seen-ids)
|
|
(let
|
|
((walked (pl-walk term)))
|
|
(cond
|
|
((pl-var? walked)
|
|
(let
|
|
((id (pl-var-id walked)))
|
|
(if
|
|
(some (fn (s) (= s id)) seen-ids)
|
|
(list seen-ids (list))
|
|
(list (cons id seen-ids) (list walked)))))
|
|
((pl-compound? walked)
|
|
(reduce
|
|
(fn
|
|
(acc arg)
|
|
(let
|
|
((result (pl-collect-vars arg (first acc))))
|
|
(list (first result) (append (nth acc 1) (nth result 1)))))
|
|
(list seen-ids (list))
|
|
(pl-args walked)))
|
|
(true (list seen-ids (list)))))))
|
|
|
|
(define
|
|
pl-predsort-insert!
|
|
(fn
|
|
(db pred elem sorted trail)
|
|
(if
|
|
(empty? sorted)
|
|
(list elem)
|
|
(let
|
|
((head (first sorted)) (order-var (pl-mk-rt-var "_PO")))
|
|
(let
|
|
((call-goal (pl-apply-goal pred (list order-var elem head)))
|
|
(mark (pl-trail-mark trail)))
|
|
(let
|
|
((ok (pl-solve-once! db call-goal trail)))
|
|
(if
|
|
ok
|
|
(let
|
|
((order (pl-atom-name (pl-walk-deep order-var))))
|
|
(do
|
|
(pl-trail-undo-to! trail mark)
|
|
(cond
|
|
((= order "<") (cons elem sorted))
|
|
((= order "=") sorted)
|
|
((= order ">")
|
|
(let
|
|
((rest-sorted (pl-predsort-insert! db pred elem (rest sorted) trail)))
|
|
(if rest-sorted (cons head rest-sorted) false)))
|
|
(true false))))
|
|
(begin (pl-trail-undo-to! trail mark) false))))))))
|
|
|
|
(define
|
|
pl-predsort-build!
|
|
(fn
|
|
(db pred items trail)
|
|
(reduce
|
|
(fn
|
|
(sorted elem)
|
|
(if sorted (pl-predsort-insert! db pred elem sorted trail) false))
|
|
(list)
|
|
items)))
|
|
|
|
(define
|
|
pl-collect-solutions
|
|
(fn
|
|
(db template-rt goal-rt trail)
|
|
(let
|
|
((box {:results (list)}) (mark (pl-trail-mark trail)))
|
|
(begin
|
|
(pl-solve!
|
|
db
|
|
goal-rt
|
|
trail
|
|
{:cut false}
|
|
(fn
|
|
()
|
|
(begin
|
|
(append!
|
|
(dict-get box :results)
|
|
(pl-deep-copy template-rt {}))
|
|
false)))
|
|
(pl-trail-undo-to! trail mark)
|
|
(dict-get box :results)))))
|
|
|
|
(define
|
|
pl-solve-findall!
|
|
(fn
|
|
(db template-rt goal-rt third-rt trail k)
|
|
(let
|
|
((items (pl-collect-solutions db template-rt goal-rt trail)))
|
|
(let
|
|
((rl (pl-mk-list-term items (pl-nil-term))))
|
|
(pl-solve-eq! third-rt rl trail k)))))
|
|
|
|
(define
|
|
pl-solve-bagof!
|
|
(fn
|
|
(db template-rt goal-rt third-rt trail k)
|
|
(let
|
|
((items (pl-collect-solutions db template-rt goal-rt trail)))
|
|
(cond
|
|
((empty? items) false)
|
|
(true
|
|
(let
|
|
((rl (pl-mk-list-term items (pl-nil-term))))
|
|
(pl-solve-eq! third-rt rl trail k)))))))
|
|
|
|
(define
|
|
pl-solve-setof!
|
|
(fn
|
|
(db template-rt goal-rt third-rt trail k)
|
|
(let
|
|
((items (pl-collect-solutions db template-rt goal-rt trail)))
|
|
(cond
|
|
((empty? items) false)
|
|
(true
|
|
(let
|
|
((sorted (pl-sort-uniq-terms items)))
|
|
(let
|
|
((rl (pl-mk-list-term sorted (pl-nil-term))))
|
|
(pl-solve-eq! third-rt rl trail k))))))))
|
|
|
|
(define
|
|
pl-solve-eq2!
|
|
(fn
|
|
(a1 b1 a2 b2 trail k)
|
|
(let
|
|
((mark (pl-trail-mark trail)))
|
|
(cond
|
|
((and (pl-unify! a1 b1 trail) (pl-unify! a2 b2 trail))
|
|
(let
|
|
((r (k)))
|
|
(cond
|
|
(r true)
|
|
(true (begin (pl-trail-undo-to! trail mark) false)))))
|
|
(true (begin (pl-trail-undo-to! trail mark) false))))))
|
|
|
|
(define
|
|
pl-make-fresh-args
|
|
(fn
|
|
(n)
|
|
(cond
|
|
((<= n 0) (list))
|
|
(true (cons (pl-mk-rt-var "_") (pl-make-fresh-args (- n 1)))))))
|
|
|
|
(define
|
|
pl-solve-functor-construct!
|
|
(fn
|
|
(term-rt name-rt arity-rt trail k)
|
|
(let
|
|
((wn (pl-walk name-rt)) (wa (pl-walk arity-rt)))
|
|
(cond
|
|
((and (pl-num? wa) (= (pl-num-val wa) 0))
|
|
(cond
|
|
((or (pl-atom? wn) (pl-num? wn))
|
|
(pl-solve-eq! term-rt wn trail k))
|
|
(true false)))
|
|
((and (pl-num? wa) (> (pl-num-val wa) 0) (pl-atom? wn))
|
|
(let
|
|
((new-args (pl-make-fresh-args (pl-num-val wa))))
|
|
(pl-solve-eq!
|
|
term-rt
|
|
(list "compound" (pl-atom-name wn) new-args)
|
|
trail
|
|
k)))
|
|
(true false)))))
|
|
|
|
(define
|
|
pl-solve-functor!
|
|
(fn
|
|
(term-rt name-rt arity-rt trail k)
|
|
(let
|
|
((wt (pl-walk term-rt)))
|
|
(cond
|
|
((pl-var? wt)
|
|
(pl-solve-functor-construct! term-rt name-rt arity-rt trail k))
|
|
((pl-atom? wt)
|
|
(pl-solve-eq2! name-rt wt arity-rt (list "num" 0) trail k))
|
|
((pl-num? wt)
|
|
(pl-solve-eq2! name-rt wt arity-rt (list "num" 0) trail k))
|
|
((pl-compound? wt)
|
|
(pl-solve-eq2!
|
|
name-rt
|
|
(list "atom" (pl-fun wt))
|
|
arity-rt
|
|
(list "num" (len (pl-args wt)))
|
|
trail
|
|
k))
|
|
(true false)))))
|
|
|
|
(define
|
|
pl-solve-arg!
|
|
(fn
|
|
(n-rt term-rt arg-rt trail k)
|
|
(let
|
|
((wn (pl-walk n-rt)) (wt (pl-walk term-rt)))
|
|
(cond
|
|
((and (pl-num? wn) (pl-compound? wt))
|
|
(let
|
|
((idx (pl-num-val wn)) (args (pl-args wt)))
|
|
(cond
|
|
((and (>= idx 1) (<= idx (len args)))
|
|
(pl-solve-eq! arg-rt (nth args (- idx 1)) trail k))
|
|
(true false))))
|
|
(true false)))))
|
|
|
|
(define
|
|
pl-retract-try-each
|
|
(fn
|
|
(db key remaining head-rt body-rt idx trail k)
|
|
(cond
|
|
((empty? remaining) false)
|
|
(true
|
|
(let
|
|
((mark (pl-trail-mark trail))
|
|
(cl (pl-instantiate-fresh (first remaining))))
|
|
(cond
|
|
((and (pl-unify! head-rt (nth cl 1) trail) (pl-unify! body-rt (nth cl 2) trail))
|
|
(begin
|
|
(let
|
|
((all (pl-db-lookup db key)))
|
|
(dict-set!
|
|
(dict-get db :clauses)
|
|
key
|
|
(pl-list-without all idx)))
|
|
(let
|
|
((r (k)))
|
|
(cond
|
|
(r true)
|
|
(true (begin (pl-trail-undo-to! trail mark) false))))))
|
|
(true
|
|
(begin
|
|
(pl-trail-undo-to! trail mark)
|
|
(pl-retract-try-each
|
|
db
|
|
key
|
|
(rest remaining)
|
|
head-rt
|
|
body-rt
|
|
(+ idx 1)
|
|
trail
|
|
k)))))))))
|
|
|
|
(define
|
|
pl-cut?
|
|
(fn (t) (and (list? t) (not (empty? t)) (= (first t) "cut"))))
|
|
|
|
(define
|
|
pl-list-length
|
|
(fn
|
|
(t)
|
|
(let
|
|
((w (pl-walk t)))
|
|
(cond
|
|
((and (pl-atom? w) (= (pl-atom-name w) "[]")) 0)
|
|
((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
|
|
(+ 1 (pl-list-length (nth (pl-args w) 1))))
|
|
(true -1)))))
|
|
|
|
(define
|
|
pl-make-list-of-vars
|
|
(fn
|
|
(n)
|
|
(cond
|
|
((= n 0) (list "atom" "[]"))
|
|
(true
|
|
(list
|
|
"compound"
|
|
"."
|
|
(list (pl-mk-rt-var "_") (pl-make-list-of-vars (- n 1))))))))
|
|
|
|
(define
|
|
pl-between-loop!
|
|
(fn
|
|
(i hi x-rt trail k)
|
|
(cond
|
|
((> i hi) false)
|
|
(true
|
|
(let
|
|
((mark (pl-trail-mark trail)))
|
|
(cond
|
|
((pl-unify! x-rt (list "num" i) trail)
|
|
(let
|
|
((r (k)))
|
|
(cond
|
|
(r true)
|
|
(true
|
|
(begin
|
|
(pl-trail-undo-to! trail mark)
|
|
(pl-between-loop! (+ i 1) hi x-rt trail k))))))
|
|
(true
|
|
(begin
|
|
(pl-trail-undo-to! trail mark)
|
|
(pl-between-loop! (+ i 1) hi x-rt trail k)))))))))
|
|
|
|
(define
|
|
pl-solve-between!
|
|
(fn
|
|
(low-rt high-rt x-rt trail k)
|
|
(let
|
|
((wl (pl-walk low-rt)) (wh (pl-walk high-rt)))
|
|
(if
|
|
(and (pl-num? wl) (pl-num? wh))
|
|
(pl-between-loop! (pl-num-val wl) (pl-num-val wh) x-rt trail k)
|
|
false))))
|
|
|
|
(define
|
|
pl-solve-last!
|
|
(fn
|
|
(list-rt elem-rt trail k)
|
|
(let
|
|
((w (pl-walk list-rt)))
|
|
(cond
|
|
((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
|
|
(let
|
|
((tail (pl-walk (nth (pl-args w) 1))))
|
|
(cond
|
|
((and (pl-atom? tail) (= (pl-atom-name tail) "[]"))
|
|
(pl-solve-eq! elem-rt (first (pl-args w)) trail k))
|
|
(true (pl-solve-last! (nth (pl-args w) 1) elem-rt trail k)))))
|
|
(true false)))))
|
|
|
|
(define
|
|
pl-solve-nth0!
|
|
(fn
|
|
(n list-rt elem-rt trail k)
|
|
(let
|
|
((w (pl-walk list-rt)))
|
|
(cond
|
|
((and (pl-compound? w) (= (pl-fun w) ".") (= (len (pl-args w)) 2))
|
|
(cond
|
|
((= n 0) (pl-solve-eq! elem-rt (first (pl-args w)) trail k))
|
|
(true
|
|
(pl-solve-nth0! (- n 1) (nth (pl-args w) 1) elem-rt trail k))))
|
|
(true false)))))
|
|
|
|
(define
|
|
pl-ground?
|
|
(fn
|
|
(t)
|
|
(let
|
|
((w (pl-walk t)))
|
|
(cond
|
|
((pl-var? w) false)
|
|
((pl-atom? w) true)
|
|
((pl-num? w) true)
|
|
((pl-str? w) true)
|
|
((pl-compound? w)
|
|
(reduce (fn (acc a) (and acc (pl-ground? a))) true (pl-args w)))
|
|
(true false)))))
|
|
|
|
(define
|
|
pl-sort-pairs-dedup
|
|
(fn
|
|
(pairs)
|
|
(cond
|
|
((empty? pairs) (list))
|
|
((= (len pairs) 1) pairs)
|
|
((= (first (first pairs)) (first (nth pairs 1)))
|
|
(pl-sort-pairs-dedup (cons (first pairs) (rest (rest pairs)))))
|
|
(true (cons (first pairs) (pl-sort-pairs-dedup (rest pairs)))))))
|
|
|
|
(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)))))
|
|
|
|
;; ── Structural equality helper (for ==/2, \==/2, delete/3) ────────
|
|
(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)))))
|
|
|
|
;; ── Flatten helper: collect all non-list leaves into SX list ───────
|
|
(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)))))
|
|
|
|
;; ── numlist helper: build SX list of ("num" i) for i in [lo..hi] ──
|
|
(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)))))
|
|
|
|
;; ── atomic_list_concat helper: collect atom names / num vals ───────
|
|
(define
|
|
pl-struct-eq?
|
|
(fn
|
|
(a b)
|
|
(cond
|
|
((and (pl-var? a) (pl-var? b))
|
|
(= (dict-get a :id) (dict-get b :id)))
|
|
((and (pl-atom? a) (pl-atom? b))
|
|
(= (pl-atom-name a) (pl-atom-name b)))
|
|
((and (pl-num? a) (pl-num? b)) (= (pl-num-val a) (pl-num-val b)))
|
|
((and (pl-compound? a) (pl-compound? b))
|
|
(if
|
|
(and
|
|
(= (pl-fun a) (pl-fun b))
|
|
(= (len (pl-args a)) (len (pl-args b))))
|
|
(let
|
|
((all-eq true) (i 0))
|
|
(begin
|
|
(for-each
|
|
(fn
|
|
(ai)
|
|
(begin
|
|
(if
|
|
(not (pl-struct-eq? ai (nth (pl-args b) i)))
|
|
(set! all-eq false)
|
|
nil)
|
|
(set! i (+ i 1))))
|
|
(pl-args a))
|
|
all-eq))
|
|
false))
|
|
(true false))))
|
|
|
|
;; ── sum_list helper ────────────────────────────────────────────────
|
|
(define
|
|
pl-flatten-prolog
|
|
(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))
|
|
(let
|
|
((h (pl-walk-deep (first (pl-args w))))
|
|
(tl (nth (pl-args w) 1)))
|
|
(if
|
|
(or
|
|
(and (pl-atom? h) (= (pl-atom-name h) "[]"))
|
|
(and (pl-compound? h) (= (pl-fun h) ".")))
|
|
(append (pl-flatten-prolog h) (pl-flatten-prolog tl))
|
|
(cons h (pl-flatten-prolog tl)))))
|
|
(true (list w))))))
|
|
|
|
;; ── max_list / min_list helpers ────────────────────────────────────
|
|
(define
|
|
pl-numlist-build
|
|
(fn
|
|
(lo hi)
|
|
(if
|
|
(> lo hi)
|
|
(list)
|
|
(cons (list "num" lo) (pl-numlist-build (+ lo 1) hi)))))
|
|
|
|
(define
|
|
pl-atomic-list-collect
|
|
(fn
|
|
(prolog-list)
|
|
(let
|
|
((items (pl-prolog-list-to-sx prolog-list)))
|
|
(map
|
|
(fn
|
|
(item)
|
|
(let
|
|
((w (pl-walk-deep item)))
|
|
(cond
|
|
((pl-atom? w) (pl-atom-name w))
|
|
((pl-num? w) (str (pl-num-val w)))
|
|
(true ""))))
|
|
items))))
|
|
|
|
;; ── delete/3 helper: remove elements struct-equal to elem ──────────
|
|
(define
|
|
pl-sum-list-sx
|
|
(fn
|
|
(prolog-list)
|
|
(let
|
|
((items (pl-prolog-list-to-sx prolog-list)))
|
|
(reduce
|
|
(fn (acc item) (+ acc (pl-num-val (pl-walk-deep item))))
|
|
0
|
|
items))))
|
|
|
|
;; ── join string list with separator ────────────────────────────────
|
|
(define
|
|
pl-max-list-sx
|
|
(fn
|
|
(prolog-list)
|
|
(let
|
|
((items (pl-prolog-list-to-sx prolog-list)))
|
|
(reduce
|
|
(fn
|
|
(acc item)
|
|
(let
|
|
((v (pl-num-val (pl-walk-deep item))))
|
|
(if (> v acc) v acc)))
|
|
(pl-num-val (pl-walk-deep (first items)))
|
|
(rest items)))))
|
|
|
|
(define
|
|
pl-min-list-sx
|
|
(fn
|
|
(prolog-list)
|
|
(let
|
|
((items (pl-prolog-list-to-sx prolog-list)))
|
|
(reduce
|
|
(fn
|
|
(acc item)
|
|
(let
|
|
((v (pl-num-val (pl-walk-deep item))))
|
|
(if (< v acc) v acc)))
|
|
(pl-num-val (pl-walk-deep (first items)))
|
|
(rest items)))))
|
|
|
|
(define
|
|
pl-delete-sx
|
|
(fn
|
|
(prolog-list elem)
|
|
(let
|
|
((items (pl-prolog-list-to-sx prolog-list)) (ew (pl-walk-deep elem)))
|
|
(filter
|
|
(fn (item) (not (pl-struct-eq? (pl-walk-deep item) ew)))
|
|
items))))
|
|
|
|
(define
|
|
pl-join-strings
|
|
(fn
|
|
(strs sep)
|
|
(if
|
|
(empty? strs)
|
|
""
|
|
(reduce (fn (acc s) (str acc sep s)) (first strs) (rest strs)))))
|
|
|
|
(define
|
|
pl-apply-goal
|
|
(fn
|
|
(goal args)
|
|
(let
|
|
((w (pl-walk-deep goal)))
|
|
(cond
|
|
((pl-atom? w) (list "compound" (pl-atom-name w) args))
|
|
((pl-compound? w)
|
|
(list "compound" (pl-fun w) (append (pl-args w) args)))
|
|
(else w)))))
|
|
|
|
(define
|
|
pl-solve-forall!
|
|
(fn
|
|
(db cond-g action-g trail cut-box k)
|
|
(let
|
|
((mark (pl-trail-mark trail)))
|
|
(let
|
|
((found-counterexample (pl-solve! db cond-g trail {:cut false} (fn () (let ((mark2 (pl-trail-mark trail))) (let ((action-ok (pl-solve-once! db action-g trail))) (pl-trail-undo-to! trail mark2) (if action-ok false true)))))))
|
|
(pl-trail-undo-to! trail mark)
|
|
(if found-counterexample false (k))))))
|
|
|
|
(define
|
|
pl-solve-maplist2!
|
|
(fn
|
|
(db goal lst trail k)
|
|
(let
|
|
((l (pl-walk-deep lst)))
|
|
(cond
|
|
((and (pl-atom? l) (= (pl-atom-name l) "[]")) (k))
|
|
((and (pl-compound? l) (= (pl-fun l) "."))
|
|
(let
|
|
((head (first (pl-args l))) (tail (nth (pl-args l) 1)))
|
|
(let
|
|
((call-goal (pl-apply-goal goal (list head))))
|
|
(if
|
|
(pl-solve-once! db call-goal trail)
|
|
(pl-solve-maplist2! db goal tail trail k)
|
|
false))))
|
|
(else false)))))
|
|
|
|
(define
|
|
pl-solve-maplist3!
|
|
(fn
|
|
(db goal list1 list2 trail k)
|
|
(let
|
|
((l1 (pl-walk-deep list1)) (l2 (pl-walk-deep list2)))
|
|
(cond
|
|
((and (pl-atom? l1) (= (pl-atom-name l1) "[]"))
|
|
(let
|
|
((nil-atom (list "atom" "[]")))
|
|
(if (pl-unify! l2 nil-atom trail) (k) false)))
|
|
((and (pl-compound? l1) (= (pl-fun l1) "."))
|
|
(let
|
|
((h1 (first (pl-args l1))) (t1 (nth (pl-args l1) 1)))
|
|
(let
|
|
((h2-var (pl-mk-rt-var "_M")))
|
|
(let
|
|
((call-goal (pl-apply-goal goal (list h1 h2-var))))
|
|
(if
|
|
(pl-solve-once! db call-goal trail)
|
|
(let
|
|
((t2-var (pl-mk-rt-var "_MT")))
|
|
(let
|
|
((cons2 (list "compound" "." (list h2-var t2-var))))
|
|
(if
|
|
(pl-unify! l2 cons2 trail)
|
|
(pl-solve-maplist3! db goal t1 t2-var trail k)
|
|
false)))
|
|
false)))))
|
|
(else false)))))
|
|
|
|
(define
|
|
pl-solve-include!
|
|
(fn
|
|
(db goal lst result trail k)
|
|
(let
|
|
((l (pl-walk-deep lst)))
|
|
(cond
|
|
((and (pl-atom? l) (= (pl-atom-name l) "[]"))
|
|
(let
|
|
((nil-atom (list "atom" "[]")))
|
|
(if (pl-unify! result nil-atom trail) (k) false)))
|
|
((and (pl-compound? l) (= (pl-fun l) "."))
|
|
(let
|
|
((head (first (pl-args l))) (tail (nth (pl-args l) 1)))
|
|
(let
|
|
((call-goal (pl-apply-goal goal (list head))))
|
|
(let
|
|
((included (pl-solve-once! db call-goal trail)))
|
|
(if
|
|
included
|
|
(let
|
|
((rest-var (pl-mk-rt-var "_IR")))
|
|
(let
|
|
((cons-res (list "compound" "." (list head rest-var))))
|
|
(if
|
|
(pl-unify! result cons-res trail)
|
|
(pl-solve-include! db goal tail rest-var trail k)
|
|
false)))
|
|
(pl-solve-include! db goal tail result trail k))))))
|
|
(else false)))))
|
|
|
|
(define
|
|
pl-solve-exclude!
|
|
(fn
|
|
(db goal lst result trail k)
|
|
(let
|
|
((l (pl-walk-deep lst)))
|
|
(cond
|
|
((and (pl-atom? l) (= (pl-atom-name l) "[]"))
|
|
(let
|
|
((nil-atom (list "atom" "[]")))
|
|
(if (pl-unify! result nil-atom trail) (k) false)))
|
|
((and (pl-compound? l) (= (pl-fun l) "."))
|
|
(let
|
|
((head (first (pl-args l))) (tail (nth (pl-args l) 1)))
|
|
(let
|
|
((call-goal (pl-apply-goal goal (list head))))
|
|
(let
|
|
((excluded (pl-solve-once! db call-goal trail)))
|
|
(if
|
|
excluded
|
|
(pl-solve-exclude! db goal tail result trail k)
|
|
(let
|
|
((rest-var (pl-mk-rt-var "_ER")))
|
|
(let
|
|
((cons-res (list "compound" "." (list head rest-var))))
|
|
(if
|
|
(pl-unify! result cons-res trail)
|
|
(pl-solve-exclude! db goal tail rest-var trail k)
|
|
false))))))))
|
|
(else false)))))
|
|
|
|
(define
|
|
pl-solve-foldl!
|
|
(fn
|
|
(db goal lst vin vout trail k)
|
|
(let
|
|
((l (pl-walk-deep lst)) (v0 (pl-walk vin)))
|
|
(cond
|
|
((and (pl-atom? l) (= (pl-atom-name l) "[]"))
|
|
(if (pl-unify! vout v0 trail) (k) false))
|
|
((and (pl-compound? l) (= (pl-fun l) "."))
|
|
(let
|
|
((head (first (pl-args l))) (tail (nth (pl-args l) 1)))
|
|
(let
|
|
((v1-var (pl-mk-rt-var "_FV")))
|
|
(let
|
|
((call-goal (pl-apply-goal goal (list head v0 v1-var))))
|
|
(if
|
|
(pl-solve-once! db call-goal trail)
|
|
(pl-solve-foldl! db goal tail v1-var vout trail k)
|
|
false)))))
|
|
(else false)))))
|
|
|
|
(define
|
|
pl-list-to-set-sx
|
|
(fn
|
|
(lst seen)
|
|
(if
|
|
(empty? lst)
|
|
(list)
|
|
(let
|
|
((head (first lst)) (tail (rest lst)))
|
|
(if
|
|
(some (fn (s) (pl-struct-eq? head s)) seen)
|
|
(pl-list-to-set-sx tail seen)
|
|
(cons head (pl-list-to-set-sx tail (cons head seen))))))))
|
|
|
|
(define
|
|
pl-pl-list-contains?
|
|
(fn
|
|
(pl-lst elem)
|
|
(let
|
|
((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-format-process
|
|
(fn
|
|
(fmt-str args-list)
|
|
(let
|
|
((chars (split fmt-str "")) (result "") (remaining args-list))
|
|
(define
|
|
do-char
|
|
(fn
|
|
(cs r rem)
|
|
(cond
|
|
((empty? cs) r)
|
|
((= (first cs) "~")
|
|
(if
|
|
(empty? (rest cs))
|
|
(str r "~")
|
|
(let
|
|
((directive (first (rest cs))) (tail (rest (rest cs))))
|
|
(cond
|
|
((= directive "n") (do-char tail (str r "\n") rem))
|
|
((= directive "N") (do-char tail (str r "\n") rem))
|
|
((= directive "t") (do-char tail (str r "\t") rem))
|
|
((= directive "~") (do-char tail (str r "~") rem))
|
|
((= directive "w")
|
|
(if
|
|
(empty? rem)
|
|
(do-char tail (str r "?") rem)
|
|
(do-char
|
|
tail
|
|
(str r (pl-format-term (first rem)))
|
|
(rest rem))))
|
|
((= directive "a")
|
|
(if
|
|
(empty? rem)
|
|
(do-char tail (str r "?") rem)
|
|
(do-char
|
|
tail
|
|
(str r (pl-format-term (first rem)))
|
|
(rest rem))))
|
|
((= directive "d")
|
|
(if
|
|
(empty? rem)
|
|
(do-char tail (str r "?") rem)
|
|
(do-char
|
|
tail
|
|
(str r (pl-format-term (first rem)))
|
|
(rest rem))))
|
|
(true (do-char tail (str r "~" directive) rem))))))
|
|
(true (do-char (rest cs) (str r (first cs)) rem)))))
|
|
(do-char chars "" args-list))))
|
|
|
|
(define
|
|
pl-solve-term-to-atom!
|
|
(fn
|
|
(term-arg atom-arg trail k)
|
|
(let
|
|
((t-walked (pl-walk term-arg)) (a-walked (pl-walk atom-arg)))
|
|
(cond
|
|
((not (pl-var? t-walked))
|
|
(let
|
|
((formatted (pl-format-term t-walked)))
|
|
(let
|
|
((result-atom (list "atom" formatted)))
|
|
(if (pl-unify! atom-arg result-atom trail) (k) false))))
|
|
((and (pl-var? t-walked) (pl-atom? a-walked))
|
|
(let
|
|
((atom-str (pl-atom-name a-walked)))
|
|
(let
|
|
((parsed (pl-parse (str atom-str "."))))
|
|
(if
|
|
(and (list? parsed) (> (len parsed) 0))
|
|
(let
|
|
((clause (first parsed)))
|
|
(let
|
|
((actual-term (if (and (list? clause) (= (len clause) 3) (= (nth clause 0) "clause")) (nth clause 1) clause)))
|
|
(let
|
|
((fresh (pl-instantiate actual-term {})))
|
|
(if (pl-unify! term-arg fresh trail) (k) false))))
|
|
false))))
|
|
(true false)))))
|
|
|
|
(define
|
|
pl-solve-with-output-to!
|
|
(fn
|
|
(db sink goal trail cut-box k)
|
|
(let
|
|
((sink-walked (pl-walk-deep sink)))
|
|
(if
|
|
(and
|
|
(pl-compound? sink-walked)
|
|
(or
|
|
(= (pl-fun sink-walked) "atom")
|
|
(= (pl-fun sink-walked) "string"))
|
|
(= (len (pl-args sink-walked)) 1))
|
|
(let
|
|
((var (first (pl-args sink-walked)))
|
|
(saved-buffer pl-output-buffer))
|
|
(do
|
|
(set! pl-output-buffer "")
|
|
(let
|
|
((result (pl-solve-once! db goal trail)))
|
|
(let
|
|
((captured pl-output-buffer))
|
|
(do
|
|
(set! pl-output-buffer saved-buffer)
|
|
(if
|
|
result
|
|
(if
|
|
(pl-unify! var (list "atom" captured) trail)
|
|
(k)
|
|
false)
|
|
false))))))
|
|
false))))
|
|
|
|
|
|
(define
|
|
pl-solve-writeln!
|
|
(fn
|
|
(term-arg k)
|
|
(do
|
|
(pl-output-write! (pl-format-term term-arg))
|
|
(pl-output-write! "\n")
|
|
(k))))
|
|
|
|
(define
|
|
pl-solve-format-1!
|
|
(fn
|
|
(fmt-arg k)
|
|
(let
|
|
((fmt-walked (pl-walk-deep fmt-arg)))
|
|
(if
|
|
(pl-atom? fmt-walked)
|
|
(do
|
|
(pl-output-write!
|
|
(pl-format-process (pl-atom-name fmt-walked) (list)))
|
|
(k))
|
|
false))))
|
|
|
|
(define
|
|
pl-solve-format-2!
|
|
(fn
|
|
(db fmt-arg args-arg trail k)
|
|
(let
|
|
((fmt-walked (pl-walk-deep fmt-arg))
|
|
(args-walked (pl-walk-deep args-arg)))
|
|
(if
|
|
(pl-atom? fmt-walked)
|
|
(let
|
|
((args-sx (pl-prolog-list-to-sx args-walked)))
|
|
(do
|
|
(pl-output-write!
|
|
(pl-format-process (pl-atom-name fmt-walked) args-sx))
|
|
(k)))
|
|
false))))
|
|
|
|
(define
|
|
pl-substring
|
|
(fn (s start sublen) (substring s start (+ start sublen))))
|
|
|
|
(define
|
|
pl-sub-atom-try-one!
|
|
(fn
|
|
(s start sublen total-len before-arg len-arg after-arg sub-arg trail k)
|
|
(let
|
|
((mark (pl-trail-mark trail))
|
|
(after-val (- total-len (+ start sublen)))
|
|
(sub (pl-substring s start sublen)))
|
|
(if
|
|
(and
|
|
(pl-unify! before-arg (list "num" start) trail)
|
|
(pl-unify! len-arg (list "num" sublen) trail)
|
|
(pl-unify! after-arg (list "num" after-val) trail)
|
|
(pl-unify! sub-arg (list "atom" sub) trail))
|
|
(let
|
|
((kresult (k)))
|
|
(if kresult kresult (begin (pl-trail-undo-to! trail mark) false)))
|
|
(begin (pl-trail-undo-to! trail mark) false)))))
|
|
|
|
(define
|
|
pl-sub-atom-loop!
|
|
(fn
|
|
(s total-len start sublen before-arg len-arg after-arg sub-arg trail k)
|
|
(cond
|
|
((> start total-len) false)
|
|
((> sublen (- total-len start))
|
|
(pl-sub-atom-loop!
|
|
s
|
|
total-len
|
|
(+ start 1)
|
|
0
|
|
before-arg
|
|
len-arg
|
|
after-arg
|
|
sub-arg
|
|
trail
|
|
k))
|
|
(true
|
|
(let
|
|
((one-result (pl-sub-atom-try-one! s start sublen total-len before-arg len-arg after-arg sub-arg trail k)))
|
|
(if
|
|
one-result
|
|
one-result
|
|
(pl-sub-atom-loop!
|
|
s
|
|
total-len
|
|
start
|
|
(+ sublen 1)
|
|
before-arg
|
|
len-arg
|
|
after-arg
|
|
sub-arg
|
|
trail
|
|
k)))))))
|
|
|
|
(define
|
|
pl-solve-aggregate-all!
|
|
(fn
|
|
(db tmpl goal result trail k)
|
|
(let
|
|
((tmpl-walked (pl-walk-deep tmpl)))
|
|
(cond
|
|
((and (pl-atom? tmpl-walked) (= (pl-atom-name tmpl-walked) "count"))
|
|
(let
|
|
((solutions (pl-collect-solutions db (list "atom" "true") goal trail)))
|
|
(if
|
|
(pl-unify! result (list "num" (len solutions)) trail)
|
|
(k)
|
|
false)))
|
|
((and (pl-compound? tmpl-walked) (= (pl-fun tmpl-walked) "bag") (= (len (pl-args tmpl-walked)) 1))
|
|
(let
|
|
((template (nth (pl-args tmpl-walked) 0)))
|
|
(let
|
|
((solutions (pl-collect-solutions db template goal trail)))
|
|
(let
|
|
((prolog-list (pl-mk-list-term solutions (pl-nil-term))))
|
|
(if (pl-unify! result prolog-list trail) (k) false)))))
|
|
((and (pl-compound? tmpl-walked) (= (pl-fun tmpl-walked) "sum") (= (len (pl-args tmpl-walked)) 1))
|
|
(let
|
|
((template (nth (pl-args tmpl-walked) 0)))
|
|
(let
|
|
((solutions (pl-collect-solutions db template goal trail)))
|
|
(let
|
|
((total (reduce (fn (acc sol) (+ acc (pl-eval-arith sol))) 0 solutions)))
|
|
(if (pl-unify! result (list "num" total) trail) (k) false)))))
|
|
((and (pl-compound? tmpl-walked) (= (pl-fun tmpl-walked) "max") (= (len (pl-args tmpl-walked)) 1))
|
|
(let
|
|
((template (nth (pl-args tmpl-walked) 0)))
|
|
(let
|
|
((solutions (pl-collect-solutions db template goal trail)))
|
|
(if
|
|
(empty? solutions)
|
|
false
|
|
(let
|
|
((vals (map pl-eval-arith solutions)))
|
|
(let
|
|
((mx (reduce (fn (a b) (if (> a b) a b)) (first vals) (rest vals))))
|
|
(if (pl-unify! result (list "num" mx) trail) (k) false)))))))
|
|
((and (pl-compound? tmpl-walked) (= (pl-fun tmpl-walked) "min") (= (len (pl-args tmpl-walked)) 1))
|
|
(let
|
|
((template (nth (pl-args tmpl-walked) 0)))
|
|
(let
|
|
((solutions (pl-collect-solutions db template goal trail)))
|
|
(if
|
|
(empty? solutions)
|
|
false
|
|
(let
|
|
((vals (map pl-eval-arith solutions)))
|
|
(let
|
|
((mn (reduce (fn (a b) (if (< a b) a b)) (first vals) (rest vals))))
|
|
(if (pl-unify! result (list "num" mn) trail) (k) false)))))))
|
|
((and (pl-compound? tmpl-walked) (= (pl-fun tmpl-walked) "set") (= (len (pl-args tmpl-walked)) 1))
|
|
(let
|
|
((template (nth (pl-args tmpl-walked) 0)))
|
|
(let
|
|
((solutions (pl-collect-solutions db template goal trail)))
|
|
(let
|
|
((deduped (pl-list-to-set-sx solutions (list))))
|
|
(let
|
|
((keyed (map (fn (t) (list (pl-format-term t) t)) deduped)))
|
|
(let
|
|
((sorted (sort keyed)))
|
|
(let
|
|
((sorted-terms (map (fn (pair) (nth pair 1)) sorted)))
|
|
(let
|
|
((prolog-list (pl-mk-list-term sorted-terms (pl-nil-term))))
|
|
(if (pl-unify! result prolog-list trail) (k) false)))))))))
|
|
(true false)))))
|
|
|
|
(define
|
|
pl-solve!
|
|
(fn
|
|
(db goal trail cut-box k)
|
|
(let
|
|
((g (pl-walk goal)))
|
|
(cond
|
|
((pl-var? g) false)
|
|
((pl-cut? g) (begin (dict-set! cut-box :cut true) (k)))
|
|
((and (pl-atom? g) (= (pl-atom-name g) "true")) (k))
|
|
((and (pl-atom? g) (= (pl-atom-name g) "fail")) false)
|
|
((and (pl-atom? g) (= (pl-atom-name g) "nl"))
|
|
(begin (pl-output-write! "\n") (k)))
|
|
((and (pl-compound? g) (= (pl-fun g) "=") (= (len (pl-args g)) 2))
|
|
(pl-solve-eq! (first (pl-args g)) (nth (pl-args g) 1) trail k))
|
|
((and (pl-compound? g) (= (pl-fun g) "\\=") (= (len (pl-args g)) 2))
|
|
(pl-solve-not-eq!
|
|
(first (pl-args g))
|
|
(nth (pl-args g) 1)
|
|
trail
|
|
k))
|
|
((and (pl-compound? g) (= (pl-fun g) "is") (= (len (pl-args g)) 2))
|
|
(pl-solve-eq!
|
|
(first (pl-args g))
|
|
(list "num" (pl-eval-arith (nth (pl-args g) 1)))
|
|
trail
|
|
k))
|
|
((and (pl-compound? g) (= (pl-fun g) "<") (= (len (pl-args g)) 2))
|
|
(cond
|
|
((< (pl-eval-arith (first (pl-args g))) (pl-eval-arith (nth (pl-args g) 1)))
|
|
(k))
|
|
(true false)))
|
|
((and (pl-compound? g) (= (pl-fun g) ">") (= (len (pl-args g)) 2))
|
|
(cond
|
|
((> (pl-eval-arith (first (pl-args g))) (pl-eval-arith (nth (pl-args g) 1)))
|
|
(k))
|
|
(true false)))
|
|
((and (pl-compound? g) (= (pl-fun g) "=<") (= (len (pl-args g)) 2))
|
|
(cond
|
|
((<= (pl-eval-arith (first (pl-args g))) (pl-eval-arith (nth (pl-args g) 1)))
|
|
(k))
|
|
(true false)))
|
|
((and (pl-compound? g) (= (pl-fun g) ">=") (= (len (pl-args g)) 2))
|
|
(cond
|
|
((>= (pl-eval-arith (first (pl-args g))) (pl-eval-arith (nth (pl-args g) 1)))
|
|
(k))
|
|
(true false)))
|
|
((and (pl-compound? g) (= (pl-fun g) ",") (= (len (pl-args g)) 2))
|
|
(pl-solve!
|
|
db
|
|
(first (pl-args g))
|
|
trail
|
|
cut-box
|
|
(fn () (pl-solve! db (nth (pl-args g) 1) trail cut-box k))))
|
|
((and (pl-compound? g) (= (pl-fun g) ";") (= (len (pl-args g)) 2))
|
|
(pl-solve-or!
|
|
db
|
|
(first (pl-args g))
|
|
(nth (pl-args g) 1)
|
|
trail
|
|
cut-box
|
|
k))
|
|
((and (pl-compound? g) (= (pl-fun g) "->") (= (len (pl-args g)) 2))
|
|
(pl-solve-if-then-else!
|
|
db
|
|
(first (pl-args g))
|
|
(nth (pl-args g) 1)
|
|
(list "atom" "fail")
|
|
trail
|
|
cut-box
|
|
k))
|
|
((and (pl-compound? g) (= (pl-fun g) "call") (= (len (pl-args g)) 1))
|
|
(let
|
|
((call-cb {:cut false}))
|
|
(pl-solve! db (first (pl-args g)) trail call-cb k)))
|
|
((and (pl-compound? g) (= (pl-fun g) "write") (= (len (pl-args g)) 1))
|
|
(begin
|
|
(pl-output-write! (pl-format-term (first (pl-args g))))
|
|
(k)))
|
|
((and (pl-compound? g) (= (pl-fun g) "assertz") (= (len (pl-args g)) 1))
|
|
(pl-solve-assertz! db (first (pl-args g)) k))
|
|
((and (pl-compound? g) (= (pl-fun g) "assert") (= (len (pl-args g)) 1))
|
|
(pl-solve-assertz! db (first (pl-args g)) k))
|
|
((and (pl-compound? g) (= (pl-fun g) "asserta") (= (len (pl-args g)) 1))
|
|
(pl-solve-asserta! db (first (pl-args g)) k))
|
|
((and (pl-compound? g) (= (pl-fun g) "retract") (= (len (pl-args g)) 1))
|
|
(pl-solve-retract! db (first (pl-args g)) trail k))
|
|
((and (pl-compound? g) (= (pl-fun g) "findall") (= (len (pl-args g)) 3))
|
|
(pl-solve-findall!
|
|
db
|
|
(first (pl-args g))
|
|
(nth (pl-args g) 1)
|
|
(nth (pl-args g) 2)
|
|
trail
|
|
k))
|
|
((and (pl-compound? g) (= (pl-fun g) "bagof") (= (len (pl-args g)) 3))
|
|
(pl-solve-bagof!
|
|
db
|
|
(first (pl-args g))
|
|
(nth (pl-args g) 1)
|
|
(nth (pl-args g) 2)
|
|
trail
|
|
k))
|
|
((and (pl-compound? g) (= (pl-fun g) "setof") (= (len (pl-args g)) 3))
|
|
(pl-solve-setof!
|
|
db
|
|
(first (pl-args g))
|
|
(nth (pl-args g) 1)
|
|
(nth (pl-args g) 2)
|
|
trail
|
|
k))
|
|
((and (pl-compound? g) (= (pl-fun g) "copy_term") (= (len (pl-args g)) 2))
|
|
(pl-solve-eq!
|
|
(nth (pl-args g) 1)
|
|
(pl-deep-copy (first (pl-args g)) {})
|
|
trail
|
|
k))
|
|
((and (pl-compound? g) (= (pl-fun g) "functor") (= (len (pl-args g)) 3))
|
|
(pl-solve-functor!
|
|
(first (pl-args g))
|
|
(nth (pl-args g) 1)
|
|
(nth (pl-args g) 2)
|
|
trail
|
|
k))
|
|
((and (pl-compound? g) (= (pl-fun g) "arg") (= (len (pl-args g)) 3))
|
|
(pl-solve-arg!
|
|
(first (pl-args g))
|
|
(nth (pl-args g) 1)
|
|
(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)))
|
|
((and (pl-compound? g) (= (pl-fun g) "succ") (= (len (pl-args g)) 2))
|
|
(let
|
|
((wa (pl-walk (first (pl-args g))))
|
|
(wb (pl-walk (nth (pl-args g) 1))))
|
|
(cond
|
|
((pl-num? wa)
|
|
(pl-solve-eq!
|
|
(nth (pl-args g) 1)
|
|
(list "num" (+ (pl-num-val wa) 1))
|
|
trail
|
|
k))
|
|
((pl-num? wb)
|
|
(if
|
|
(> (pl-num-val wb) 0)
|
|
(pl-solve-eq!
|
|
(first (pl-args g))
|
|
(list "num" (- (pl-num-val wb) 1))
|
|
trail
|
|
k)
|
|
false))
|
|
(true false))))
|
|
((and (pl-compound? g) (= (pl-fun g) "plus") (= (len (pl-args g)) 3))
|
|
(let
|
|
((wa (pl-walk (first (pl-args g))))
|
|
(wb (pl-walk (nth (pl-args g) 1)))
|
|
(wc (pl-walk (nth (pl-args g) 2))))
|
|
(cond
|
|
((and (pl-num? wa) (pl-num? wb))
|
|
(pl-solve-eq!
|
|
(nth (pl-args g) 2)
|
|
(list "num" (+ (pl-num-val wa) (pl-num-val wb)))
|
|
trail
|
|
k))
|
|
((and (pl-num? wa) (pl-num? wc))
|
|
(pl-solve-eq!
|
|
(nth (pl-args g) 1)
|
|
(list "num" (- (pl-num-val wc) (pl-num-val wa)))
|
|
trail
|
|
k))
|
|
((and (pl-num? wb) (pl-num? wc))
|
|
(pl-solve-eq!
|
|
(first (pl-args g))
|
|
(list "num" (- (pl-num-val wc) (pl-num-val wb)))
|
|
trail
|
|
k))
|
|
(true false))))
|
|
((and (pl-compound? g) (= (pl-fun g) "between") (= (len (pl-args g)) 3))
|
|
(pl-solve-between!
|
|
(first (pl-args g))
|
|
(nth (pl-args g) 1)
|
|
(nth (pl-args g) 2)
|
|
trail
|
|
k))
|
|
((and (pl-compound? g) (= (pl-fun g) "length") (= (len (pl-args g)) 2))
|
|
(let
|
|
((wl (pl-walk (first (pl-args g))))
|
|
(wn (pl-walk (nth (pl-args g) 1))))
|
|
(cond
|
|
((pl-proper-list? (first (pl-args g)))
|
|
(pl-solve-eq!
|
|
(nth (pl-args g) 1)
|
|
(list "num" (pl-list-length (first (pl-args g))))
|
|
trail
|
|
k))
|
|
((and (pl-var? wl) (pl-num? wn))
|
|
(if
|
|
(>= (pl-num-val wn) 0)
|
|
(pl-solve-eq!
|
|
(first (pl-args g))
|
|
(pl-make-list-of-vars (pl-num-val wn))
|
|
trail
|
|
k)
|
|
false))
|
|
(true false))))
|
|
((and (pl-compound? g) (= (pl-fun g) "last") (= (len (pl-args g)) 2))
|
|
(pl-solve-last! (first (pl-args g)) (nth (pl-args g) 1) trail k))
|
|
((and (pl-compound? g) (= (pl-fun g) "nth0") (= (len (pl-args g)) 3))
|
|
(let
|
|
((wn (pl-walk (first (pl-args g)))))
|
|
(if
|
|
(pl-num? wn)
|
|
(pl-solve-nth0!
|
|
(pl-num-val wn)
|
|
(nth (pl-args g) 1)
|
|
(nth (pl-args g) 2)
|
|
trail
|
|
k)
|
|
false)))
|
|
((and (pl-compound? g) (= (pl-fun g) "nth1") (= (len (pl-args g)) 3))
|
|
(let
|
|
((wn (pl-walk (first (pl-args g)))))
|
|
(if
|
|
(and (pl-num? wn) (> (pl-num-val wn) 0))
|
|
(pl-solve-nth0!
|
|
(- (pl-num-val wn) 1)
|
|
(nth (pl-args g) 1)
|
|
(nth (pl-args g) 2)
|
|
trail
|
|
k)
|
|
false)))
|
|
((and (pl-compound? g) (= (pl-fun g) "\\+") (= (len (pl-args g)) 1))
|
|
(let
|
|
((mark (pl-trail-mark trail)))
|
|
(let
|
|
((r (pl-solve! db (first (pl-args g)) trail {:cut false} (fn () true))))
|
|
(pl-trail-undo-to! trail mark)
|
|
(if r false (k)))))
|
|
((and (pl-compound? g) (= (pl-fun g) "not") (= (len (pl-args g)) 1))
|
|
(let
|
|
((mark (pl-trail-mark trail)))
|
|
(let
|
|
((r (pl-solve! db (first (pl-args g)) trail {:cut false} (fn () true))))
|
|
(pl-trail-undo-to! trail mark)
|
|
(if r false (k)))))
|
|
((and (pl-compound? g) (= (pl-fun g) "once") (= (len (pl-args g)) 1))
|
|
(pl-solve-if-then-else!
|
|
db
|
|
(first (pl-args g))
|
|
(list "atom" "true")
|
|
(list "atom" "fail")
|
|
trail
|
|
cut-box
|
|
k))
|
|
((and (pl-compound? g) (= (pl-fun g) "ignore") (= (len (pl-args g)) 1))
|
|
(pl-solve-if-then-else!
|
|
db
|
|
(first (pl-args g))
|
|
(list "atom" "true")
|
|
(list "atom" "true")
|
|
trail
|
|
cut-box
|
|
k))
|
|
((and (pl-compound? g) (= (pl-fun g) "ground") (= (len (pl-args g)) 1))
|
|
(if (pl-ground? (first (pl-args g))) (k) false))
|
|
((and (pl-compound? g) (= (pl-fun g) "sort") (= (len (pl-args g)) 2))
|
|
(let
|
|
((elems (pl-prolog-list-to-sx (first (pl-args g)))))
|
|
(let
|
|
((keyed (map (fn (e) (list (pl-format-term e) e)) elems)))
|
|
(let
|
|
((sorted (sort keyed)))
|
|
(let
|
|
((deduped (pl-sort-pairs-dedup sorted)))
|
|
(pl-solve-eq!
|
|
(nth (pl-args g) 1)
|
|
(pl-list-to-prolog (map (fn (p) (nth p 1)) deduped))
|
|
trail
|
|
k))))))
|
|
((and (pl-compound? g) (= (pl-fun g) "msort") (= (len (pl-args g)) 2))
|
|
(let
|
|
((elems (pl-prolog-list-to-sx (first (pl-args g)))))
|
|
(let
|
|
((keyed (map (fn (e) (list (pl-format-term e) e)) elems)))
|
|
(let
|
|
((sorted (sort keyed)))
|
|
(pl-solve-eq!
|
|
(nth (pl-args g) 1)
|
|
(pl-list-to-prolog (map (fn (p) (nth p 1)) sorted))
|
|
trail
|
|
k)))))
|
|
((and (pl-compound? g) (= (pl-fun g) "atom_number") (= (len (pl-args g)) 2))
|
|
(let
|
|
((wa (pl-walk (first (pl-args g))))
|
|
(wb (pl-walk (nth (pl-args g) 1))))
|
|
(cond
|
|
((pl-atom? wa)
|
|
(let
|
|
((n (parse-number (pl-atom-name wa))))
|
|
(if
|
|
(nil? n)
|
|
false
|
|
(pl-solve-eq!
|
|
(nth (pl-args g) 1)
|
|
(list "num" n)
|
|
trail
|
|
k))))
|
|
((pl-num? wb)
|
|
(pl-solve-eq!
|
|
(first (pl-args g))
|
|
(list "atom" (str (pl-num-val wb)))
|
|
trail
|
|
k))
|
|
(true false))))
|
|
((and (pl-compound? g) (= (pl-fun g) "number_string") (= (len (pl-args g)) 2))
|
|
(let
|
|
((wa (pl-walk (first (pl-args g))))
|
|
(wb (pl-walk (nth (pl-args g) 1))))
|
|
(cond
|
|
((pl-num? wa)
|
|
(pl-solve-eq!
|
|
(nth (pl-args g) 1)
|
|
(list "atom" (str (pl-num-val wa)))
|
|
trail
|
|
k))
|
|
((pl-var? wa)
|
|
(if
|
|
(pl-atom? wb)
|
|
(let
|
|
((n (parse-number (pl-atom-name wb))))
|
|
(if
|
|
(nil? n)
|
|
false
|
|
(pl-solve-eq!
|
|
(first (pl-args g))
|
|
(list "num" n)
|
|
trail
|
|
k)))
|
|
false))
|
|
(true false))))
|
|
((and (pl-compound? g) (= (pl-fun g) "==") (= (len (pl-args g)) 2))
|
|
(let
|
|
((a (pl-walk-deep (first (pl-args g))))
|
|
(b (pl-walk-deep (nth (pl-args g) 1))))
|
|
(if (pl-struct-eq? a b) (k) false)))
|
|
((and (pl-compound? g) (= (pl-fun g) "\\==") (= (len (pl-args g)) 2))
|
|
(let
|
|
((a (pl-walk-deep (first (pl-args g))))
|
|
(b (pl-walk-deep (nth (pl-args g) 1))))
|
|
(if (pl-struct-eq? a b) false (k))))
|
|
((and (pl-compound? g) (= (pl-fun g) "flatten") (= (len (pl-args g)) 2))
|
|
(let
|
|
((lst-rt (pl-walk (first (pl-args g)))))
|
|
(if
|
|
(pl-proper-list? lst-rt)
|
|
(let
|
|
((flat-sx (pl-flatten-prolog lst-rt)))
|
|
(pl-solve-eq!
|
|
(nth (pl-args g) 1)
|
|
(pl-list-to-prolog flat-sx)
|
|
trail
|
|
k))
|
|
false)))
|
|
((and (pl-compound? g) (= (pl-fun g) "numlist") (= (len (pl-args g)) 3))
|
|
(let
|
|
((wlo (pl-walk-deep (first (pl-args g))))
|
|
(whi (pl-walk-deep (nth (pl-args g) 1))))
|
|
(if
|
|
(and (pl-num? wlo) (pl-num? whi))
|
|
(let
|
|
((lo (pl-num-val wlo)) (hi (pl-num-val whi)))
|
|
(if
|
|
(> lo hi)
|
|
false
|
|
(pl-solve-eq!
|
|
(nth (pl-args g) 2)
|
|
(pl-list-to-prolog (pl-numlist-build lo hi))
|
|
trail
|
|
k)))
|
|
false)))
|
|
((and (pl-compound? g) (= (pl-fun g) "atomic_list_concat") (= (len (pl-args g)) 2))
|
|
(let
|
|
((lst-rt (pl-walk (first (pl-args g)))))
|
|
(if
|
|
(pl-proper-list? lst-rt)
|
|
(let
|
|
((strs (pl-atomic-list-collect lst-rt)))
|
|
(pl-solve-eq!
|
|
(nth (pl-args g) 1)
|
|
(list "atom" (reduce (fn (a b) (str a b)) "" strs))
|
|
trail
|
|
k))
|
|
false)))
|
|
((and (pl-compound? g) (= (pl-fun g) "atomic_list_concat") (= (len (pl-args g)) 3))
|
|
(let
|
|
((lst-rt (pl-walk (first (pl-args g))))
|
|
(sep-rt (pl-walk-deep (nth (pl-args g) 1))))
|
|
(if
|
|
(and (pl-proper-list? lst-rt) (pl-atom? sep-rt))
|
|
(let
|
|
((strs (pl-atomic-list-collect lst-rt))
|
|
(sep (pl-atom-name sep-rt)))
|
|
(pl-solve-eq!
|
|
(nth (pl-args g) 2)
|
|
(list "atom" (pl-join-strings strs sep))
|
|
trail
|
|
k))
|
|
false)))
|
|
((and (pl-compound? g) (= (pl-fun g) "sum_list") (= (len (pl-args g)) 2))
|
|
(let
|
|
((lst-rt (pl-walk (first (pl-args g)))))
|
|
(if
|
|
(pl-proper-list? lst-rt)
|
|
(pl-solve-eq!
|
|
(nth (pl-args g) 1)
|
|
(list "num" (pl-sum-list-sx lst-rt))
|
|
trail
|
|
k)
|
|
false)))
|
|
((and (pl-compound? g) (= (pl-fun g) "max_list") (= (len (pl-args g)) 2))
|
|
(let
|
|
((lst-rt (pl-walk (first (pl-args g)))))
|
|
(if
|
|
(and
|
|
(pl-proper-list? lst-rt)
|
|
(not
|
|
(and (pl-atom? lst-rt) (= (pl-atom-name lst-rt) "[]"))))
|
|
(pl-solve-eq!
|
|
(nth (pl-args g) 1)
|
|
(list "num" (pl-max-list-sx lst-rt))
|
|
trail
|
|
k)
|
|
false)))
|
|
((and (pl-compound? g) (= (pl-fun g) "min_list") (= (len (pl-args g)) 2))
|
|
(let
|
|
((lst-rt (pl-walk (first (pl-args g)))))
|
|
(if
|
|
(and
|
|
(pl-proper-list? lst-rt)
|
|
(not
|
|
(and (pl-atom? lst-rt) (= (pl-atom-name lst-rt) "[]"))))
|
|
(pl-solve-eq!
|
|
(nth (pl-args g) 1)
|
|
(list "num" (pl-min-list-sx lst-rt))
|
|
trail
|
|
k)
|
|
false)))
|
|
((and (pl-compound? g) (= (pl-fun g) "delete") (= (len (pl-args g)) 3))
|
|
(let
|
|
((lst-rt (pl-walk (first (pl-args g))))
|
|
(elem-rt (nth (pl-args g) 1)))
|
|
(if
|
|
(pl-proper-list? lst-rt)
|
|
(let
|
|
((filtered (pl-delete-sx lst-rt elem-rt)))
|
|
(pl-solve-eq!
|
|
(nth (pl-args g) 2)
|
|
(pl-list-to-prolog filtered)
|
|
trail
|
|
k))
|
|
false)))
|
|
((and (pl-compound? g) (= (pl-fun g) "exclude") (= (len (pl-args g)) 3))
|
|
(let
|
|
((exc-goal (pl-walk (first (pl-args g))))
|
|
(exc-lst (pl-walk (nth (pl-args g) 1)))
|
|
(exc-res (pl-walk (nth (pl-args g) 2))))
|
|
(pl-solve-exclude! db exc-goal exc-lst exc-res trail k)))
|
|
((and (pl-compound? g) (= (pl-fun g) "include") (= (len (pl-args g)) 3))
|
|
(let
|
|
((inc-goal (pl-walk (first (pl-args g))))
|
|
(inc-lst (pl-walk (nth (pl-args g) 1)))
|
|
(inc-res (pl-walk (nth (pl-args g) 2))))
|
|
(pl-solve-include! db inc-goal inc-lst inc-res trail k)))
|
|
((and (pl-compound? g) (= (pl-fun g) "maplist") (= (len (pl-args g)) 3))
|
|
(let
|
|
((ml-goal (pl-walk (first (pl-args g))))
|
|
(ml-l1 (pl-walk (nth (pl-args g) 1)))
|
|
(ml-l2 (pl-walk (nth (pl-args g) 2))))
|
|
(pl-solve-maplist3! db ml-goal ml-l1 ml-l2 trail k)))
|
|
((and (pl-compound? g) (= (pl-fun g) "maplist") (= (len (pl-args g)) 2))
|
|
(let
|
|
((ml-goal (pl-walk (first (pl-args g))))
|
|
(ml-lst (pl-walk (nth (pl-args g) 1))))
|
|
(pl-solve-maplist2! db ml-goal ml-lst trail k)))
|
|
((and (pl-compound? g) (= (pl-fun g) "forall") (= (len (pl-args g)) 2))
|
|
(let
|
|
((cond-g (pl-walk (first (pl-args g))))
|
|
(action-g (pl-walk (nth (pl-args g) 1))))
|
|
(pl-solve-forall! db cond-g action-g trail cut-box k)))
|
|
((and (pl-compound? g) (= (pl-fun g) "foldl") (= (len (pl-args g)) 4))
|
|
(pl-solve-foldl!
|
|
db
|
|
(pl-walk (first (pl-args g)))
|
|
(pl-walk (nth (pl-args g) 1))
|
|
(pl-walk (nth (pl-args g) 2))
|
|
(pl-walk (nth (pl-args g) 3))
|
|
trail
|
|
k))
|
|
((and (pl-compound? g) (= (pl-fun g) "list_to_set") (= (len (pl-args g)) 2))
|
|
(let
|
|
((lst-rt (pl-walk (first (pl-args g))))
|
|
(res-rt (pl-walk (nth (pl-args g) 1))))
|
|
(if
|
|
(pl-proper-list? lst-rt)
|
|
(let
|
|
((sx-lst (map (fn (x) (pl-walk-deep x)) (pl-prolog-list-to-sx lst-rt))))
|
|
(let
|
|
((unique-lst (pl-list-to-set-sx sx-lst (list))))
|
|
(pl-solve-eq! res-rt (pl-list-to-prolog unique-lst) trail k)))
|
|
false)))
|
|
((and (pl-compound? g) (= (pl-fun g) "intersection") (= (len (pl-args g)) 3))
|
|
(let
|
|
((s1-rt (pl-walk (first (pl-args g))))
|
|
(s2-rt (pl-walk (nth (pl-args g) 1)))
|
|
(res-rt (pl-walk (nth (pl-args g) 2))))
|
|
(if
|
|
(and (pl-proper-list? s1-rt) (pl-proper-list? s2-rt))
|
|
(let
|
|
((s1-sx (map (fn (x) (pl-walk-deep x)) (pl-prolog-list-to-sx s1-rt)))
|
|
(s2-sx
|
|
(map
|
|
(fn (x) (pl-walk-deep x))
|
|
(pl-prolog-list-to-sx s2-rt))))
|
|
(let
|
|
((inter (filter (fn (x) (some (fn (y) (pl-struct-eq? x y)) s2-sx)) s1-sx)))
|
|
(pl-solve-eq! res-rt (pl-list-to-prolog inter) trail k)))
|
|
false)))
|
|
((and (pl-compound? g) (= (pl-fun g) "subtract") (= (len (pl-args g)) 3))
|
|
(let
|
|
((s1-rt (pl-walk (first (pl-args g))))
|
|
(s2-rt (pl-walk (nth (pl-args g) 1)))
|
|
(res-rt (pl-walk (nth (pl-args g) 2))))
|
|
(if
|
|
(and (pl-proper-list? s1-rt) (pl-proper-list? s2-rt))
|
|
(let
|
|
((s1-sx (map (fn (x) (pl-walk-deep x)) (pl-prolog-list-to-sx s1-rt)))
|
|
(s2-sx
|
|
(map
|
|
(fn (x) (pl-walk-deep x))
|
|
(pl-prolog-list-to-sx s2-rt))))
|
|
(let
|
|
((diff (filter (fn (x) (not (some (fn (y) (pl-struct-eq? x y)) s2-sx))) s1-sx)))
|
|
(pl-solve-eq! res-rt (pl-list-to-prolog diff) trail k)))
|
|
false)))
|
|
((and (pl-compound? g) (= (pl-fun g) "union") (= (len (pl-args g)) 3))
|
|
(let
|
|
((s1-rt (pl-walk (first (pl-args g))))
|
|
(s2-rt (pl-walk (nth (pl-args g) 1)))
|
|
(res-rt (pl-walk (nth (pl-args g) 2))))
|
|
(if
|
|
(and (pl-proper-list? s1-rt) (pl-proper-list? s2-rt))
|
|
(let
|
|
((s1-sx (map (fn (x) (pl-walk-deep x)) (pl-prolog-list-to-sx s1-rt)))
|
|
(s2-sx
|
|
(map
|
|
(fn (x) (pl-walk-deep x))
|
|
(pl-prolog-list-to-sx s2-rt))))
|
|
(let
|
|
((s2-only (filter (fn (x) (not (some (fn (y) (pl-struct-eq? x y)) s1-sx))) s2-sx)))
|
|
(let
|
|
((union-lst (append s1-sx s2-only)))
|
|
(pl-solve-eq!
|
|
res-rt
|
|
(pl-list-to-prolog union-lst)
|
|
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))
|
|
((and (pl-compound? g) (= (pl-fun g) "term_to_atom") (= (len (pl-args g)) 2))
|
|
(pl-solve-term-to-atom!
|
|
(nth (pl-args g) 0)
|
|
(nth (pl-args g) 1)
|
|
trail
|
|
k))
|
|
((and (pl-compound? g) (= (pl-fun g) "term_string") (= (len (pl-args g)) 2))
|
|
(pl-solve-term-to-atom!
|
|
(nth (pl-args g) 0)
|
|
(nth (pl-args g) 1)
|
|
trail
|
|
k))
|
|
((and (pl-compound? g) (= (pl-fun g) "with_output_to") (= (len (pl-args g)) 2))
|
|
(pl-solve-with-output-to!
|
|
db
|
|
(nth (pl-args g) 0)
|
|
(nth (pl-args g) 1)
|
|
trail
|
|
cut-box
|
|
k))
|
|
((and (pl-compound? g) (= (pl-fun g) "writeln") (= (len (pl-args g)) 1))
|
|
(pl-solve-writeln! (nth (pl-args g) 0) k))
|
|
((and (pl-compound? g) (= (pl-fun g) "format") (= (len (pl-args g)) 1))
|
|
(pl-solve-format-1! (nth (pl-args g) 0) k))
|
|
((and (pl-compound? g) (= (pl-fun g) "format") (= (len (pl-args g)) 2))
|
|
(pl-solve-format-2!
|
|
db
|
|
(nth (pl-args g) 0)
|
|
(nth (pl-args g) 1)
|
|
trail
|
|
k))
|
|
((and (pl-compound? g) (= (pl-fun g) "sub_atom") (= (len (pl-args g)) 5))
|
|
(let
|
|
((atom-term (pl-walk-deep (nth (pl-args g) 0))))
|
|
(if
|
|
(pl-atom? atom-term)
|
|
(let
|
|
((s (pl-atom-name atom-term))
|
|
(total-len (len (pl-atom-name atom-term))))
|
|
(pl-sub-atom-loop!
|
|
s
|
|
total-len
|
|
0
|
|
0
|
|
(pl-walk (nth (pl-args g) 1))
|
|
(pl-walk (nth (pl-args g) 2))
|
|
(pl-walk (nth (pl-args g) 3))
|
|
(pl-walk (nth (pl-args g) 4))
|
|
trail
|
|
k))
|
|
false)))
|
|
((and (pl-compound? g) (= (pl-fun g) "aggregate_all") (= (len (pl-args g)) 3))
|
|
(pl-solve-aggregate-all!
|
|
db
|
|
(pl-walk (nth (pl-args g) 0))
|
|
(pl-walk (nth (pl-args g) 1))
|
|
(pl-walk (nth (pl-args g) 2))
|
|
trail
|
|
k))
|
|
((and (pl-compound? g) (= (pl-fun g) "term_variables") (= (len (pl-args g)) 2))
|
|
(let
|
|
((term (pl-walk (nth (pl-args g) 0)))
|
|
(vars-arg (pl-walk (nth (pl-args g) 1))))
|
|
(let
|
|
((result (pl-collect-vars term (list))))
|
|
(let
|
|
((var-list (nth result 1)))
|
|
(let
|
|
((prolog-vars (pl-list-to-prolog var-list)))
|
|
(if (pl-unify! vars-arg prolog-vars trail) (k) false))))))
|
|
((and (pl-compound? g) (= (pl-fun g) "predsort") (= (len (pl-args g)) 3))
|
|
(let
|
|
((pred (pl-walk (nth (pl-args g) 0)))
|
|
(list-arg (pl-walk (nth (pl-args g) 1)))
|
|
(result-arg (pl-walk (nth (pl-args g) 2))))
|
|
(let
|
|
((items (pl-prolog-list-to-sx (pl-walk-deep list-arg))))
|
|
(let
|
|
((sorted (pl-predsort-build! db pred items trail)))
|
|
(if
|
|
sorted
|
|
(let
|
|
((prolog-sorted (pl-list-to-prolog sorted)))
|
|
(if (pl-unify! result-arg prolog-sorted trail) (k) false))
|
|
false)))))
|
|
(true (pl-solve-user! db g trail cut-box k))))))
|
|
|
|
(define
|
|
pl-solve-or!
|
|
(fn
|
|
(db a b trail cut-box k)
|
|
(cond
|
|
((and (pl-compound? a) (= (pl-fun a) "->") (= (len (pl-args a)) 2))
|
|
(pl-solve-if-then-else!
|
|
db
|
|
(first (pl-args a))
|
|
(nth (pl-args a) 1)
|
|
b
|
|
trail
|
|
cut-box
|
|
k))
|
|
(true
|
|
(let
|
|
((mark (pl-trail-mark trail)))
|
|
(let
|
|
((r (pl-solve! db a trail cut-box k)))
|
|
(cond
|
|
(r true)
|
|
((dict-get cut-box :cut) false)
|
|
(true
|
|
(begin
|
|
(pl-trail-undo-to! trail mark)
|
|
(pl-solve! db b trail cut-box k))))))))))
|
|
|
|
(define
|
|
pl-solve-if-then-else!
|
|
(fn
|
|
(db cond-goal then-goal else-goal trail cut-box k)
|
|
(let
|
|
((mark (pl-trail-mark trail)))
|
|
(let
|
|
((local-cb {:cut false}))
|
|
(let
|
|
((found {:val false}))
|
|
(pl-solve!
|
|
db
|
|
cond-goal
|
|
trail
|
|
local-cb
|
|
(fn () (begin (dict-set! found :val true) true)))
|
|
(cond
|
|
((dict-get found :val) (pl-solve! db then-goal trail cut-box k))
|
|
(true
|
|
(begin
|
|
(pl-trail-undo-to! trail mark)
|
|
(pl-solve! db else-goal trail cut-box k)))))))))
|
|
|
|
(define pl-output-buffer "")
|
|
|
|
(define pl-output-clear! (fn () (set! pl-output-buffer "")))
|
|
|
|
(define
|
|
pl-output-write!
|
|
(fn (s) (begin (set! pl-output-buffer (str pl-output-buffer s)) nil)))
|
|
|
|
(define
|
|
pl-format-args
|
|
(fn
|
|
(args)
|
|
(cond
|
|
((empty? args) "")
|
|
((= (len args) 1) (pl-format-term (first args)))
|
|
(true
|
|
(str
|
|
(pl-format-term (first args))
|
|
", "
|
|
(pl-format-args (rest args)))))))
|
|
|
|
(define
|
|
pl-format-term
|
|
(fn
|
|
(t)
|
|
(let
|
|
((w (pl-walk-deep t)))
|
|
(cond
|
|
((pl-var? w) (str "_" (pl-var-id w)))
|
|
((pl-atom? w) (pl-atom-name w))
|
|
((pl-num? w) (str (pl-num-val w)))
|
|
((pl-str? w) (pl-str-val w))
|
|
((pl-compound? w)
|
|
(str (pl-fun w) "(" (pl-format-args (pl-args w)) ")"))
|
|
(true (str w))))))
|
|
|
|
(define
|
|
pl-eval-arith
|
|
(fn
|
|
(t)
|
|
(let
|
|
((w (pl-walk-deep t)))
|
|
(cond
|
|
((pl-num? w) (pl-num-val w))
|
|
((pl-compound? w)
|
|
(let
|
|
((f (pl-fun w)) (args (pl-args w)))
|
|
(cond
|
|
((and (= f "+") (= (len args) 2))
|
|
(+
|
|
(pl-eval-arith (first args))
|
|
(pl-eval-arith (nth args 1))))
|
|
((and (= f "-") (= (len args) 2))
|
|
(-
|
|
(pl-eval-arith (first args))
|
|
(pl-eval-arith (nth args 1))))
|
|
((and (= f "-") (= (len args) 1))
|
|
(- 0 (pl-eval-arith (first args))))
|
|
((and (= f "*") (= (len args) 2))
|
|
(*
|
|
(pl-eval-arith (first args))
|
|
(pl-eval-arith (nth args 1))))
|
|
((and (= f "/") (= (len args) 2))
|
|
(/
|
|
(pl-eval-arith (first args))
|
|
(pl-eval-arith (nth args 1))))
|
|
((and (= f "mod") (= (len args) 2))
|
|
(mod
|
|
(pl-eval-arith (first args))
|
|
(pl-eval-arith (nth args 1))))
|
|
((and (= f "abs") (= (len args) 1))
|
|
(let
|
|
((v (pl-eval-arith (first args))))
|
|
(cond ((< v 0) (- 0 v)) (true v))))
|
|
((and (= f "max") (= (len args) 2))
|
|
(let
|
|
((va (pl-eval-arith (first args)))
|
|
(vb (pl-eval-arith (nth args 1))))
|
|
(cond ((> va vb) va) (true vb))))
|
|
((and (= f "min") (= (len args) 2))
|
|
(let
|
|
((va (pl-eval-arith (first args)))
|
|
(vb (pl-eval-arith (nth args 1))))
|
|
(cond ((< va vb) va) (true vb))))
|
|
((and (= f "floor") (= (len args) 1))
|
|
(floor (pl-eval-arith (first args))))
|
|
((and (= f "ceiling") (= (len args) 1))
|
|
(ceil (pl-eval-arith (first args))))
|
|
((and (= f "truncate") (= (len args) 1))
|
|
(truncate (pl-eval-arith (first args))))
|
|
((and (= f "round") (= (len args) 1))
|
|
(round (pl-eval-arith (first args))))
|
|
((and (= f "sqrt") (= (len args) 1))
|
|
(sqrt (pl-eval-arith (first args))))
|
|
((and (= f "sign") (= (len args) 1))
|
|
(let
|
|
((v (pl-eval-arith (first args))))
|
|
(cond ((< v 0) -1) ((> v 0) 1) (true 0))))
|
|
((and (= f "integer") (= (len args) 1))
|
|
(truncate (pl-eval-arith (first args))))
|
|
((and (= f "float") (= (len args) 1))
|
|
(pl-eval-arith (first args)))
|
|
((and (= f "float_integer_part") (= (len args) 1))
|
|
(truncate (pl-eval-arith (first args))))
|
|
((and (= f "float_fractional_part") (= (len args) 1))
|
|
(let
|
|
((v (pl-eval-arith (first args))))
|
|
(- v (truncate v))))
|
|
((and (= f "**") (= (len args) 2))
|
|
(pow
|
|
(pl-eval-arith (first args))
|
|
(pl-eval-arith (nth args 1))))
|
|
((and (= f "^") (= (len args) 2))
|
|
(pow
|
|
(pl-eval-arith (first args))
|
|
(pl-eval-arith (nth args 1))))
|
|
((and (= f "pow") (= (len args) 2))
|
|
(pow
|
|
(pl-eval-arith (first args))
|
|
(pl-eval-arith (nth args 1))))
|
|
(true 0))))
|
|
(true 0)))))
|
|
|
|
(define
|
|
pl-solve-not-eq!
|
|
(fn
|
|
(a b trail k)
|
|
(let
|
|
((mark (pl-trail-mark trail)))
|
|
(let
|
|
((unified (pl-unify! a b trail)))
|
|
(begin
|
|
(pl-trail-undo-to! trail mark)
|
|
(cond (unified false) (true (k))))))))
|
|
|
|
(define
|
|
pl-solve-eq!
|
|
(fn
|
|
(a b trail k)
|
|
(let
|
|
((mark (pl-trail-mark trail)))
|
|
(cond
|
|
((pl-unify! a b trail)
|
|
(let
|
|
((r (k)))
|
|
(cond
|
|
(r true)
|
|
(true (begin (pl-trail-undo-to! trail mark) false)))))
|
|
(true (begin (pl-trail-undo-to! trail mark) false))))))
|
|
|
|
(define
|
|
pl-solve-user!
|
|
(fn
|
|
(db goal trail outer-cut-box k)
|
|
(let
|
|
((inner-cut-box {:cut false}))
|
|
(let
|
|
((outer-was-cut (dict-get outer-cut-box :cut)))
|
|
(let
|
|
((compiled (when (dict-has? db :compiled) (dict-get db :compiled))))
|
|
(if
|
|
(and compiled (dict-has? compiled (pl-goal-key goal)))
|
|
(pl-try-compiled-clauses!
|
|
db
|
|
goal
|
|
trail
|
|
(dict-get compiled (pl-goal-key goal))
|
|
outer-cut-box
|
|
outer-was-cut
|
|
inner-cut-box
|
|
k)
|
|
(pl-try-clauses!
|
|
db
|
|
goal
|
|
trail
|
|
(pl-db-lookup-goal db goal)
|
|
outer-cut-box
|
|
outer-was-cut
|
|
inner-cut-box
|
|
k)))))))
|
|
|
|
(define
|
|
pl-try-clauses!
|
|
(fn
|
|
(db goal trail clauses outer-cut-box outer-was-cut inner-cut-box k)
|
|
(cond
|
|
((empty? clauses) false)
|
|
(true
|
|
(let
|
|
((mark (pl-trail-mark trail)))
|
|
(let
|
|
((clause (pl-instantiate-fresh (first clauses))))
|
|
(let
|
|
((head (nth clause 1)) (body (nth clause 2)))
|
|
(cond
|
|
((pl-unify! goal head trail)
|
|
(let
|
|
((r (pl-solve! db body trail inner-cut-box k)))
|
|
(cond
|
|
(r true)
|
|
((dict-get inner-cut-box :cut)
|
|
(begin (pl-trail-undo-to! trail mark) false))
|
|
((and (not outer-was-cut) (dict-get outer-cut-box :cut))
|
|
(begin (pl-trail-undo-to! trail mark) false))
|
|
(true
|
|
(begin
|
|
(pl-trail-undo-to! trail mark)
|
|
(pl-try-clauses!
|
|
db
|
|
goal
|
|
trail
|
|
(rest clauses)
|
|
outer-cut-box
|
|
outer-was-cut
|
|
inner-cut-box
|
|
k))))))
|
|
(true
|
|
(begin
|
|
(pl-trail-undo-to! trail mark)
|
|
(pl-try-clauses!
|
|
db
|
|
goal
|
|
trail
|
|
(rest clauses)
|
|
outer-cut-box
|
|
outer-was-cut
|
|
inner-cut-box
|
|
k)))))))))))
|
|
|
|
(define
|
|
pl-solve-once!
|
|
(fn (db goal trail) (pl-solve! db goal trail {:cut false} (fn () true))))
|
|
|
|
(define
|
|
pl-solve-count!
|
|
(fn
|
|
(db goal trail)
|
|
(let
|
|
((box {:n 0}))
|
|
(pl-solve!
|
|
db
|
|
goal
|
|
trail
|
|
{:cut false}
|
|
(fn () (begin (dict-set! box :n (+ (dict-get box :n) 1)) false)))
|
|
(dict-get box :n))))
|