Peter Norvig's unifier in Clojure, take 2

gistfile1.txt

(ns
  #^{:doc "CL original by Peter Norvig, initial version in Clojure by Kevin Livingston. See http://groups.google.com/group/clojure/browse_thread/thread/996ecadf98328c6b#"}
  unifier.core
  (:use [clojure.contrib
         [def :only (defvar defalias)]
         [core :only (seqable?)]])
  (:require [clojure
             [walk :as walk]
             [zip :as zip]]))

(defn variable?
  "Is x a variable (a symbol beginning with '?')?"
  [x]
  (and (symbol? x) (= (first (name x)) \?)))

(defalias compound? seqable?)

(defvar *occurs-check* true "Perform the occurs check?")

(declare unify-variable occurs?)

(defn unify
  "Attempt to unify x and y with the given bindings (if any)."
  ([x y] (unify x y {}))
  ([x y bs]
     (cond
      (not bs)      nil
      (= x y)       bs
      (variable? x) (unify-variable x y bs)
      (variable? y) (unify-variable y x bs)
      (every? compound? [x y])
      (unify (rest x) (rest y)
             (unify (first x) (first y) bs))
      :else nil)))

(defmacro cond-let
  [& clauses]
  (when clauses
    `(~(if (vector? (first clauses))
         'if-let
         'if)
      ~(first clauses)
      ~(if (next clauses)
         (second clauses)
         (throw (IllegalArgumentException.
                 "cond-let requires an even number of forms")))
      (cond-let ~@(nnext clauses)))))

(defn unify-variable
  "Unify the variable v with x."
  [v x bs]
  (cond-let
   [vb (bs v)]                     (unify vb x bs)
   [vx (and (variable? x) (bs x))] (unify v vx bs)
   (and *occurs-check* (occurs? v x bs)) nil
   :else (assoc bs v x)))

(defn resolve-steps
  [v bs]
  (loop [v v steps [v]]
    (if-let [vv (bs v)]
      (if (variable? vv)
        (recur vv (conj steps vv))
        (conj steps vv))
      (conj steps (bs v)))))

(defn resolve-variable
  "Resolve v to its value in bs (nil if none)."
  [v bs]
  (loop [v v]
    (if-let [vv (bs v)]
      (if (variable? vv)
        (recur vv)
        vv))))

(defn resolve-variable*
  "Resolve v to its value in bs (last var in the chain if none)."
  [v bs]
  (loop [v v]
    (if-let [vv (bs v)]
      (if (and (variable? vv)
               (find bs vv))
        (recur vv)
        vv))))

(defn resolves-to?
  "Does v resolve to x with the given bindings?"
  [v x bs]
  (let [vv (resolve-variable v bs)]
    (= vv x)))

#_
(defn occurs?
  "Does v occur anywhere inside x?"
  ([v x bs] (occurs? v x bs []))
  ([v x bs to-do]
     (cond
      (= v x) true
      (and (variable? x) (find bs x)) (recur v (bs x) bs to-do)
      (compound? x)  (recur v (first x) bs (conj to-do (rest x)))
      (empty? to-do) false
      :else          (recur v (peek to-do) bs (pop to-do)))))

(defn compound-zip
  [root]
  (zip/zipper seqable? seq (fn [_ cs] cs) root))

(defn occurs?
  "Does v occur anywhere inside x?"
  [v x bs]
  (loop [z (compound-zip [x])]
    (let [current (zip/node z)]
      (cond (zip/end? z) false
            (= v current) true
            (and (variable? current)
                 (find bs current))
            (recur (zip/next (zip/insert-right z (bs current))))
            (zip/end? z) false
            :else        (recur (zip/next z))))))

(defn simplify-bindings
  [bs]
  (into {} (map (fn [[k v]]
                  [k (loop [v v]
                       (if (variable? v)
                         (recur (bs v))
                         v))])
                bs)))

(defn subst
  [x bs]
  (let [bs (simplify-bindings bs)]
    (walk/prewalk #(if (variable? %) (bs %) %) x)))

(defn subst*
  [x bs]
  (walk/prewalk #(if (variable? %) (resolve-variable % bs) %) x))

(defn subst-memo
  [x bs]
  (let [memo (atom {})]
    (walk/prewalk
     (fn [item]
       (if (variable? item)
         (cond (find @memo item) (@memo item)
               (find bs item)    (let [v (resolve-variable* item bs)]
                                   (swap! memo assoc item v)
                                   v)
               :else             item)
         item))
     x)))