;; lib/guest/match.sx — pure pattern-match + unification kit.
;;
;; Shipped for miniKanren / Datalog / future logic-flavoured guests that
;; want immutable unification without writing it from scratch. The two
;; existing prolog/haskell engines stay as-is — porting them in place
;; risks the 746 tests they currently pass; consumers can migrate
;; gradually via the converters in lib/guest/ast.sx.
;;
;; Term shapes (canonical wire format)
;; -----------------------------------
;;   var          (:var NAME)            NAME a string
;;   constructor  (:ctor HEAD ARGS)      HEAD a string, ARGS a list of terms
;;   literal      number / string / boolean / nil
;;
;; Guests with their own shape pass adapter callbacks via the cfg arg —
;; see (unify-with cfg ...) and (match-pat-with cfg ...) below. The
;; default canonical entry points (unify / match-pat) use the wire shape.
;;
;; Substitution / env
;; ------------------
;; A substitution is a SX dict mapping VAR-NAME → term. There are no
;; trails, no mutation: each step either returns an extended dict or nil.
;;
;;   (empty-subst)                  → {}
;;   (walk term s)                  → term with top-level vars resolved
;;   (walk* term s)                 → term with all vars resolved (recursive)
;;   (extend name term s)           → s with NAME → term added
;;   (occurs? name term s)          → bool
;;
;; Unify (symmetric, miniKanren-flavour)
;; -------------------------------------
;;   (unify u v s)                  → extended subst or nil
;;   (unify-with cfg u v s)         → ditto, with adapter callbacks:
;;                                      :var? :var-name :ctor? :ctor-head
;;                                      :ctor-args :occurs-check?
;;
;; Match (asymmetric, haskell-flavour: pattern → value, vars only in pat)
;; ---------------------------------------------------------------------
;;   (match-pat pat val env)        → extended env or nil
;;   (match-pat-with cfg pat val env)

(define mk-var  (fn (name) (list :var name)))
(define mk-ctor (fn (head args) (list :ctor head args)))

(define is-var?    (fn (t) (and (list? t) (not (empty? t)) (= (first t) :var))))
(define is-ctor?   (fn (t) (and (list? t) (not (empty? t)) (= (first t) :ctor))))
(define var-name   (fn (t) (nth t 1)))
(define ctor-head  (fn (t) (nth t 1)))
(define ctor-args  (fn (t) (nth t 2)))

(define empty-subst (fn () {}))

(define
  walk
  (fn (t s)
    (if (and (is-var? t) (has-key? s (var-name t)))
      (walk (get s (var-name t)) s)
      t)))

(define
  walk*
  (fn (t s)
    (let ((w (walk t s)))
      (cond
        ((is-ctor? w)
          (mk-ctor (ctor-head w) (map (fn (a) (walk* a s)) (ctor-args w))))
        (:else w)))))

(define
  extend
  (fn (name term s)
    (assoc s name term)))

(define
  occurs?
  (fn (name term s)
    (let ((w (walk term s)))
      (cond
        ((is-var? w) (= (var-name w) name))
        ((is-ctor? w) (some (fn (a) (occurs? name a s)) (ctor-args w)))
        (:else false)))))

(define
  unify-with
  (fn (cfg u v s)
    (let ((var?-fn (get cfg :var?))
          (var-name-fn (get cfg :var-name))
          (ctor?-fn (get cfg :ctor?))
          (ctor-head-fn (get cfg :ctor-head))
          (ctor-args-fn (get cfg :ctor-args))
          (occurs?-on (get cfg :occurs-check?)))
      (let ((wu (walk-with cfg u s))
            (wv (walk-with cfg v s)))
        (cond
          ((and (var?-fn wu) (var?-fn wv) (= (var-name-fn wu) (var-name-fn wv))) s)
          ((var?-fn wu)
            (if (and occurs?-on (occurs-with cfg (var-name-fn wu) wv s))
              nil
              (extend (var-name-fn wu) wv s)))
          ((var?-fn wv)
            (if (and occurs?-on (occurs-with cfg (var-name-fn wv) wu s))
              nil
              (extend (var-name-fn wv) wu s)))
          ((and (ctor?-fn wu) (ctor?-fn wv))
            (if (= (ctor-head-fn wu) (ctor-head-fn wv))
              (unify-list-with
                cfg
                (ctor-args-fn wu)
                (ctor-args-fn wv)
                s)
              nil))
          (:else (if (= wu wv) s nil)))))))

(define
  walk-with
  (fn (cfg t s)
    (if (and ((get cfg :var?) t) (has-key? s ((get cfg :var-name) t)))
      (walk-with cfg (get s ((get cfg :var-name) t)) s)
      t)))

(define
  occurs-with
  (fn (cfg name term s)
    (let ((w (walk-with cfg term s)))
      (cond
        (((get cfg :var?) w) (= ((get cfg :var-name) w) name))
        (((get cfg :ctor?) w)
          (some (fn (a) (occurs-with cfg name a s)) ((get cfg :ctor-args) w)))
        (:else false)))))

(define
  unify-list-with
  (fn (cfg xs ys s)
    (cond
      ((and (empty? xs) (empty? ys)) s)
      ((or (empty? xs) (empty? ys)) nil)
      (:else
        (let ((s2 (unify-with cfg (first xs) (first ys) s)))
          (if (= s2 nil)
            nil
            (unify-list-with cfg (rest xs) (rest ys) s2)))))))

(define canonical-cfg
  {:var? is-var? :var-name var-name
   :ctor? is-ctor? :ctor-head ctor-head :ctor-args ctor-args
   :occurs-check? true})

(define unify (fn (u v s) (unify-with canonical-cfg u v s)))

;; Asymmetric pattern match (haskell-style): only patterns may contain vars;
;; values are concrete. On a var pattern, bind name to value.
(define
  match-pat-with
  (fn (cfg pat val env)
    (let ((var?-fn (get cfg :var?))
          (var-name-fn (get cfg :var-name))
          (ctor?-fn (get cfg :ctor?))
          (ctor-head-fn (get cfg :ctor-head))
          (ctor-args-fn (get cfg :ctor-args)))
      (cond
        ((var?-fn pat) (extend (var-name-fn pat) val env))
        ((and (ctor?-fn pat) (ctor?-fn val))
          (if (= (ctor-head-fn pat) (ctor-head-fn val))
            (match-list-pat-with
              cfg
              (ctor-args-fn pat)
              (ctor-args-fn val)
              env)
            nil))
        ((ctor?-fn pat) nil)
        (:else (if (= pat val) env nil))))))

(define
  match-list-pat-with
  (fn (cfg pats vals env)
    (cond
      ((and (empty? pats) (empty? vals)) env)
      ((or (empty? pats) (empty? vals)) nil)
      (:else
        (let ((env2 (match-pat-with cfg (first pats) (first vals) env)))
          (if (= env2 nil)
            nil
            (match-list-pat-with cfg (rest pats) (rest vals) env2)))))))

(define match-pat (fn (pat val env) (match-pat-with canonical-cfg pat val env)))