;; 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-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)))))

(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)))))

;; ── Structural equality helper (for ==/2, \==/2, delete/3) ────────
(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))))

;; ── Flatten helper: collect all non-list leaves into SX list ───────
(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))))))

;; ── numlist helper: build SX list of ("num" i) for i in [lo..hi] ──
(define
  pl-numlist-build
  (fn
    (lo hi)
    (if
      (> lo hi)
      (list)
      (cons (list "num" lo) (pl-numlist-build (+ lo 1) hi)))))

;; ── atomic_list_concat helper: collect atom names / num vals ───────
(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))))

;; ── sum_list helper ────────────────────────────────────────────────
(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))))

;; ── max_list / min_list helpers ────────────────────────────────────
(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)))))

;; ── delete/3 helper: remove elements struct-equal to elem ──────────
(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))))

;; ── join string list with separator ────────────────────────────────
(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-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))
        (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))))
              (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)))
        (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))))