Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
Peter Norvig's unifier in Clojure, take 2
#^{:doc "CL original by Peter Norvig, initial version in Clojure by Kevin Livingston. See"}
(: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 '?')?"
(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]
(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))
~(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]
[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)
(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)
(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]
(= 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
(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
(into {} (map (fn [[k v]]
[k (loop [v v]
(if (variable? v)
(recur (bs v))
(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 {})]
(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)
:else item)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment