gistfile1.clj

;utilities
(defn rec-replace [test fun struct]
  (let [struct (if (test struct) (fun struct) struct)]
    (if (seq? struct) (map (partial rec-replace test fun) struct) struct)))

(defn value [name map]
  (let [in-map (map name)] (if in-map (recur in-map map) name)))

(def *special-rules* {:number (fn [[num] map] 
				  (when (number? (value num map)) [map]))})
(def *rules* 
     (ref '{:append [(([] X X)) (((:cons H T) X (:cons H Y)) (:append T X Y))],
	  :member [((M (:cons M Foo))) ((M (:cons Foo R)) (:member M R))],
	  :unequal [((X X) (:cut) (:fail)) ((X Y))],
	  :same [((X X))], :true [(nil)], :cut [(nil)]}))

(defn variable?[v](and(symbol? v)
		      (let[initial(str(first(name v)))]
			(not=(.toLowerCase initial)initial))))

(declare match* prove-all)

;unification
(defn match1
  "match one place"
  [map a b]
  (let [av (value a map)
	bv (value b map)]
    (cond (= av bv)             map
          (variable? av)          (conj map [av b])
	  (variable? bv)          (conj map [bv a])
	  (every? seq? [av bv]) (match map av bv)
	  (every? vector? [av bv]) (match map av bv))))

(defn match
  "match lists of params"
  [map a b]
  (cond (= a b)	map
	(and (vector? a) (vector? b))
	(let [[ah & at] a
	      [bh & bt] b
	      map       (match1 map ah bh)]
	  (when map
	    (recur map at bt)))
        (and (seq? a) (seq? b))
	(let [[ah & at] a
	      [bh & bt] b
	      map       (match1 map ah bh)]
	  (when map
	    (recur map at bt)))))

(defn get-rules
  "rules for a predicate with variables uniquely renamed"
  [name]
  (for [rule (*rules* name)]
    (let [syms (set (filter variable? (tree-seq seq? identity rule)))
	  gensyms (into {} (for [sym syms] [sym (gensym sym)]))]
      (rec-replace variable? #(if (= % '_) (gensym) (gensyms %)) (seq rule)))))

(defn prove-backtrack 
  "try to derive a predicate with all possible rules"
  [unif-map [name & args]]
  (if-let [fun (*special-rules* name)]
      (fun args unif-map)
    (for [[params & subgoals] (get-rules name)
	  result (take-while #(not= % :cut)
			     (prove-all (match unif-map params args) subgoals))]
      result)))

(defn prove-all [unif-map goals]
  (when unif-map
    (if-let [[cond & rest] goals]
	(concat (for [unif-map (prove-backtrack unif-map cond)
		      result (prove-all unif-map rest)] result)
		(when (= cond [:cut]) [:cut]))
      [unif-map])))

;i/o
(defn vec->pllist
  "vectors are syntactic sugar for prolog-lists"
  [expr]
  (rec-replace vector?
      (fn [i] (let [[i [and rest]] (split-with #(not= % '&) i)]
		(reduce #(list :cons %2 %1) (or rest []) (reverse i)))) expr))

(defn pllist->vec [x]
  (if (= (first x) :cons)
    (let [[cons a b] x] (vec (concat [a] (cond (vector? b) b b ['& b]))))
    x))

(defn resolve-expr
  "Replace all vars with their unifications, also deep in structures in query result" 
  [sym unif-map]
  (let [sym (value sym unif-map)]
    (if (seq? sym) (pllist->vec (map #(resolve-expr % unif-map) sym)) sym)))

;input of rules
(defn newrule 
  "introduce a new rule into the prolog knowledge base" 
  [[name & param] & subgoals]
  (let [new-rule (conj (or (*rules* name) []) (vec->pllist (cons param subgoals)))]
    (alter *rules* conj [name new-rule])))

(defn group-by 
  "Applies f to each value in coll, splitting it each time f returns 
   a new value.  Returns a lazy seq of lazy seqs." 
  [f coll] 
    (if-let [s (seq coll)]
      (let [fv (f (first s)) 
            [a b] (split-with #(= fv (f %)) s)] 
        (lazy-cons a (group-by f b)))))

(defmacro prolog [& rules]
  `(dosync (doseq [rule# '~rules] (apply newrule rule#))))

(defmacro => [& rules]
  (cons `dosync (for [rule (group-by #(= '.  %) rules)
		  :when (not= '(.) rule)]
	      (let [[impl _ conds] (group-by #(not= :- %) rule)]
		`(newrule '~impl ~@(for [cond conds] `(quote ~cond)))))))

;Queries
(defn query
  "run a prolog-query and return only the relevant unifications"
  [goals]
  (let [goals (vec->pllist goals) ;parse lists
	query-vars (set (filter variable? (tree-seq seq? identity goals)))
	goals (rec-replace #{'_} gensym goals)]
    (for [map (prove-all {} goals)]
      (into {} (filter (fn [[a b]] (if (variable? b) (query-vars b) :t))
		       (for [key query-vars :when (map key)]
			 [key  (resolve-expr key map)]))))))

(defn intq 
  "run an ineracitve query" 
  [[h & t]]
  (if (seq h)
      (when ('#{yes Y y} (do (println h) (print "more? ") (flush) (read)))
	(recur t))
      (println (if h "Yes." "No."))))

(defmacro ?- [& goals]
  `(binding [*rules* @*rules*]
     (intq (query '~goals))))

;some tests
(?- (:same A [1 2 3]) (:same B [C & A]) (:same F [A & C]))
(?- (:append A B [1 2 3 4]) (:member 3 B))