compiler.clj

(def *rels* 
   '{same [((X X))]
     dings [(([:bla :bla]))]
     append [( ([] X X) ) ( ([:cons X Y] Z [:cons X A]) (append Y Z A))]
     mann [((:klaus)) ((:karl)) ((X) (vater X Y))]
     vater[((:hans :karl))]
     number[((:null)) (([:succ N]) (anumber N))]
     anumber[((N) (number N))]
     weg [((:wildeck :eisenach))  ((:eisenach :leipzig)) ((:eisenach :erfurt))
	  ((:erfurt :nordhausen)) ((:halle :leipzig))    ((:leipzig :berlin))]
     pfad [((A B) (weg A B))
	   ((A B) (weg A C) (pfad C B))]})

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

(declare match)

(defn match1
  "match one place"
  [map a b]
    (cond (= a b)             map
          (symbol? a)          (conj map [a b])
	  (symbol? b)          (conj map [b a])
	  (every? seq? [a b])    (match map a b)
	  (every? vector? [a b]) (match map a b)))

(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 sym-replace [test fun struct]
    (cond (vector? struct) (vec (map (partial sym-replace test fun) struct))
	  (seq? struct)  (map (partial sym-replace test fun) struct)
	  (test struct) (fun struct)
	  :else struct))

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

(defn value2
  ([name map]
   (let [v3 (fn v3 [name map]
		(let [v (value name map)]
		  (cond (seq? v) (sym-replace variable? #(v3 % map) v)
			(vector? v) (vec (sym-replace variable? #(v3 % map) v))
			:else v)))]
     (v3 name map)))
  ([name map uniq returnkeys]
   (let [v3 (fn v3 [name map]
		(let [v (value name map)]
		  (cond (seq? v) (sym-replace variable? #(v3 % map) v)
			(vector? v) (vec (sym-replace variable? #(v3 % map) v))
			(returnkeys v) v
			(symbol? v) (symbol (str v uniq))
			:else v)))]
     (v3 name map))))

(declare *args* *bindings* *returnkeys* *pref*)

(defn compile-rule [branch]
  (let [vars-here (filter variable? (tree-seq coll? identity branch))
	gensyms (into {} (for [sym vars-here] [sym (gensym sym)]))
	[h & conds] (sym-replace gensyms #(list 'quote (gensyms %)) branch)]
    `(when-let [newbindings# (match {} ~*args* (list ~@h))]
	 (for [map# (-> [newbindings#] ~@conds)]
	   (let [map# (into ~*bindings* map#)]
	     (into ~*bindings* (for [k# ~*returnkeys*] (when (map# k#) [k# (value2 k# map# ~*pref* ~*returnkeys*)]))))))))

(defn compile-rules  [rule]
  (let [[branch & rest] rule]
    (when branch
      `(lazy-cons
	~(compile-rule branch)
	~(compile-rules rest)))))

(defn compile-rel [rule]
  (binding [*args* (gensym 'args) *pref* (gensym 'PREF)
	    *bindings* (gensym 'bindings) *returnkeys* (gensym 'returnkeys)]
    `(fn [bindings# & args#]
	 (let [~*pref* (gensym)]
	   (for [~*bindings* bindings# 
		 results# (let [~*args* (map (fn [x#] (value2 x# ~*bindings*)) args#)
				~*returnkeys* (set (filter variable? (tree-seq coll? identity args#)))]
			    ~(compile-rules rule))
		 result# results#
		 :when result#] result#)))))

(defn compile-rels [rules]
   `(do
      `(declare ~@(keys rules))
      ~@(for [[key value] rules]
	  `(def ~key ~(compile-rel value)))))

(eval (compile-rels *rels*))