pred.core.clj

(ns pred.core
  (:use pred.dispatch))
             
(defprotocol IMatrix
  (-display [m])
  (-specialize [m])
  (-score [m])
  (-subcol [m s e]))

(deftype Pred [f quote code _meta]
  clojure.lang.IObj
  (withMeta [_ new-meta]
    (Pred. f quote code new-meta))
  (meta [_] _meta)
  IMatrix
  (-display [this] (or (:sym _meta) quote)))

(deftype Any [_meta]
  clojure.lang.IObj
  (withMeta [_ new-meta]
    (Any. new-meta))
  (meta [_] _meta)
  IMatrix
  (-display [this] 
    '_))

(def any? #(= (type %) Any))
(def pred? #(= (type %) Pred))

(deftype Col [col idx _meta]
  clojure.lang.IObj
  (withMeta [_ new-meta]
    (Col. col idx new-meta))
  (meta [_] _meta)

  clojure.lang.Indexed
  (nth [_ i]
    (nth col i))
  (nth [_ i x]
    (nth col i x))

  clojure.lang.ISeq
  (first [_] (first col))
  (next [_]
    (if-let [nps (next col)]
      (Col. nps idx _meta)
      (Col. [] idx _meta)))
  (more [_]
    (if (empty? col)
      nil
      (Col. (rest col) idx _meta)))
  (seq [this] (seq col))
  (count [_] (count col))

  IMatrix
   (-subcol [m s e]
    (Col. (subvec col s e) idx _meta))
  (-display [this] (prn idx  '-  (mapv  -display col) '= (-score this)))
  (-score [this] (if (any? (first col)) -1 
    (apply + (map (comp {true 1 false 0} pred?) col)))))


(extend-type Object
    IMatrix
  (-display [this] this))

(extend-type nil
    IMatrix
  (-display [this] this))


(defn switch 
  ([p d s] (switch p d s 0))
  ([-p -def -spec indent]
    (if (or (empty? -spec) (any? -p)) 
      (do (prn 'LEAF )
        (@FN->QUOTE (first (:leafs (meta -def)))))
    (do 
      (prn [(-display -p)] (list 'if (list (.code -p) (.idx (first -spec)))))
      (list 'if (list (.code -p) (.idx (first -spec))) 

      (do (-display -spec)
           (let [res (-specialize -spec)]
            (if (sequential? res) (remove nil? res) res)))
      (if (empty? (first -def)) nil
        (do 
        (-display -def)
        (try (-specialize -def) (catch Exception e (prn 'ERR e))))))))))

(deftype Matrix [cols _meta]
  clojure.lang.IObj
  (withMeta [_ new-meta]
    (Matrix. cols new-meta))
  (meta [_] _meta)
    clojure.lang.Indexed
  (nth [_ i]
    (nth cols i))
  (nth [_ i x]
    (nth cols i x))

  clojure.lang.ISeq
  (first [_] (first cols))
  (next [_]
    (if-let [nps (next cols)]
      (Matrix. nps _meta)
      (Matrix. []  _meta)))
  (more [_]
    (if (empty? cols)
      nil
      (Matrix. (rest cols) _meta)))
  (seq [this] (seq cols))
  (count [_] (count cols))
  IMatrix
  (-display [this] 
    (prn ) (mapv -display cols))
  (-specialize [this ] 
    (let [sorted (reverse (sort-by -score cols))
          best (first sorted)
          bidx (.idx best)
          -default (Matrix. (mapv rest  sorted) (update-in _meta [:leafs] rest))
          -special (Matrix. (mapv 
            #(Col. [(first %)] (.idx %) {})
            (rest sorted)) _meta)]
          (switch (first best) -default -special)
          )))
 


(defn make-pred [f sym]
  (let [pq (@FN->QUOTE f)]
    (if pq
      (Pred. f pq pq {:sym sym})
      (Any. {}))))

(defn make-pred-matrix [data]
  (let [mx (mapv vec (keys data))
        leafs (vals data)
        row-counts (map count mx)
        width (first row-counts)
        height (count mx)
        wildcard (make-pred nil 0)
        pmeta (into {nil (make-pred nil 0)} 
          (map #(vector %1 (make-pred %1 %2))  
             (disj (set (flatten mx)) nil) 
              (map (comp symbol str) 
              "abcdefghijklmnopqrstuvwxyz")))
        cols (vec (for [x (range width)
                        :let [argidx (get (mapv (comp symbol str) 
                              (reverse  "abcdefghijklmnopqrstuvwxyz")) x)]]
                (Col. (vec (for [y (range height)]
                        (get pmeta 
                          (get (get mx y) x)) )) argidx {})))]
    (when (= 1 (count (set row-counts)))
      (Matrix. cols {:db pmeta :leafs (conj leafs nil) :count (count leafs)}))))

pred.dispatch.clj

(ns pred.dispatch
  (:require 
    [clojure.walk]
    [clojure.string]))

(def FN->QUOTE (atom {}))
(def HASH->FN (atom {}))
(def DISPATCHMAP (atom {}))
 
(defn CLEAN [] 
  (reset! DISPATCHMAP {})
  (reset! FN->QUOTE {})
  (reset! HASH->FN {}))

(defn iter-map [m f]
  (loop [kvs (seq m)]
    (if (empty? kvs) ::no-rule 
      (or (f (first kvs))
          (recur (rest kvs))))))

(defn search-variants [m args]
  (iter-map m
    (fn [[k v]] 
      ;TODO try catch
      (try
        (if (not (some #(or (false? %) (nil? %))  
        (map 
          #(if (nil? %1) true (%1 %2)) 
          k args)))
        ;dispatchee
        (apply v args))
        (catch Exception e (prn :ERR (map @FN->QUOTE k) args))))))


; walk simple compositions to allow equiv
 
(defn cast-from [form col] 
  (cond (vector? form) (vec col) :else col))

(defn -hashed-form [form]
  (cond (sequential? form)
        (cast-from form (map -hashed-form form))
        :else (hash form)))

(defmacro hashed-form [form]
  (let [res (-hashed-form form)] `(quote ~res)))
 



(defn unique-fn [f hashed quoted]
  (or (get @HASH->FN hashed)
    (do (swap! HASH->FN assoc hashed f)
        (swap! FN->QUOTE assoc f quoted) f)))

(defn reg-fn-quote [f q] (swap! FN->QUOTE assoc f q))


(defn humanize [data] (clojure.walk/postwalk #(if (fn? %) (get @FN->QUOTE % %) %) data))


(defn compile-inline [arity quoted-map] 
  (let [args (vec (take arity (repeatedly gensym)))]
  (list 'fn args
    (cons 'cond
      (mapcat 
        (fn [[k v]]
          (let [exp (remove nil? (map #(if-not (nil? %1) (list %1 %2)) k args))] 
            (list  
              (cond (empty? exp) true 
                    (= 1 (count exp)) (first exp)
                    :else (cons 'and exp))
              (cons v args)))) 
      quoted-map)))))


(defn invoke-pass [sym pass args]
  (if-let [domain (get-in @DISPATCHMAP [sym (count args) pass])]
    (search-variants domain args)))
  
(defmacro -declare [pass sym args & more]
  (let [[spec code] (if (map? (first more)) [(first more)(rest more)] [{} more])
        arity (count args) 
        ;arg vec can use meta predicates if Symbol,Keyword,String or Map
        meta-preds (map (comp :tag meta) args)
        ;pull ordered arg preds from spec map
        spec-preds (map spec args)
        preds (map #(or %1 %2) spec-preds meta-preds)
        non-meta-args (mapv #(with-meta % nil) args)]
    `(do 
      (let [userfn# (fn ~non-meta-args ~@code)] 
        (reg-fn-quote userfn# (quote (~'fn ~non-meta-args ~@code)))
      (swap! DISPATCHMAP update-in [(var ~sym) ~arity ~pass]
          (fn [m#] (conj (or m# {}) 
          ;{list of arg predicates (or nil), declared fn}
          {(map unique-fn 
            (list ~@preds) 
            (hashed-form ~preds) 
            (quote ~preds))
           userfn#} ))))

        (fn [& args#] 
          (invoke-pass (var ~sym) :rule args#)))))


 ;hack to extend rules from other ns's
(defmacro rule [sym args & more] 
  (if (re-find #".+\/.+" (str sym))
    `(-declare :rule ~sym ~args ~@more)
    `(def ~sym (-declare :rule ~sym ~args ~@more))))

pred.test.clj

(ns pred.test
  (:use [pred.dispatch pred.core]))
(def non-number? (non number?))

(rule maxim [a b] (max a b))
(rule maxim [^neg? a ^pos? b] b)
(rule maxim [^pos? a ^neg? b] a)
(rule maxim [^non-number? a b] b)
(rule maxim [a ^non-number? b] a)
(rule maxim [^non-number? a ^non-number? b] :numeric-err)

(def t (make-pred-matrix (identity (get-in @DISPATCHMAP [#'pred.test/maxim 2  :rule]))))
(-display t)
(-specialize t)

(def fizz? #(= 0 (mod % 3)))
(def buzz? #(= 0 (mod % 5)))
(def wozz? #(= 0 (mod % 7)))

(rule fizz [a b c] [a b c])
(rule fizz [^fizz? a b c] [:fizz b c])
(rule fizz [a ^fizz? b ^even? c] [a :fizz c])
(rule fizz [a ^wozz? b ^fizz? c] [a :woz :fizz])
(rule fizz [^buzz? a  b ^fizz? c] [a b :fizz])

(def t (make-pred-matrix (identity (get-in @DISPATCHMAP [#'pred.test/fizz 3  :rule]))))
(-display t)
(-specialize t)