;      ____ dpt-node   arv-node ____
;     |    |                   |    |
;  ---|    |-------------------|    |----------
;     |____|       edge        |____|
;
; Every edge have a dpt-node and arv-nodes.
;
; dpt-node stands for deperture node.
; arv-node stands for arrival node.
;
; format of graph:
; {:node
;  [[nid type attr*]
;   [nid type attr*]
;   ...
;  ]
;  :edge
;  [[eid [dpt-nid term-no.] [arv-nid term-no.]]
;   [eid [dpt-nid term-no.] [arv-nid term-no.]]
;   ...
;   ]}
;
; nid stands for node-id
; eid stands for edge-id

(ns src.graph)
(use '[clojure.set :only (union)])
(import '(java.util Random))
(alias 'cl 'clojure.core)
(alias 'gr 'src.graph)

(require 'clojure.contrib.combinatorics)
(alias 'cm 'clojure.contrib.combinatorics)

(require 'src.unify-matcher) (alias 'um 'src.unify-matcher)
(require 'src.utils)         (alias 'ut 'src.utils)

(use '[clojure.contrib.str-utils :only (str-join)])

(defstruct graph :next-id :nodes :edges)
(defn new-graph [] (struct graph 0 [] []))

(defn in?        [[_ type]] (= type 'in))
(defn out?       [[_ type]] (= type 'out))
(defn in-or-out? [[_ type]] ('#{in out} type))

; gr/map
(defn map [gr f & colls]
  (loop [gr gr colls colls acc []]
    (if (some empty? colls)
      (cons gr acc)
      (let [[gr retval] (apply f gr (cl/map first colls))]
        (recur gr (cl/map rest colls) (conj acc retval))
        ))))

(defn transpose [colls]
  (apply cl/map (fn [& args] (seq args)) colls))

(defn new-ids [gr & prefixes]
  (cons (assoc gr :next-id (+ (:next-id gr) (count prefixes)))
        (cl/map #(symbol (str %1 '- %2))
                prefixes
                (iterate #(+ % 1) (:next-id gr))
                )))

(defn add-conns [n-or-e gr & xs]
  (assoc gr
         n-or-e (apply conj (n-or-e gr) xs)))

(defn add-nodes [gr & xs] (apply add-conns :nodes gr xs))
(defn add-edges [gr & xs] (apply add-conns :edges gr xs))

(defn input [gr name]
  (let [[gr nid] (new-ids gr 'n)]
    [(add-nodes gr [nid 'in name])
     [nid 0]
     ]))

(defn inputs [gr & names]
  (gr/map gr input names))

(defn output [gr [dpt-term name]]
  (let [[gr eid nid] (new-ids gr 'e 'n)]
    [(add-edges (add-nodes gr [nid 'out name])
                [eid dpt-term [nid 0]])
     nil]))

(defn outputs [gr & pairs]
  (first (gr/map gr output pairs)))

(defn const1 [gr]
  (let [[gr eid nid] (new-ids gr 'e 'n)]
    [(add-nodes gr [nid 'const1])
     [nid 0]
     ]))

(defn const0 [gr]
  (let [[gr eid nid] (new-ids gr 'e 'n)]
    [(add-nodes gr [nid 'const0])
     [nid 0]
     ]))

(defn not1 [gr i]
  (let [[gr eid nid] (new-ids gr 'e 'n)]
    [(add-edges (add-nodes gr [nid 'not1])
                [eid i [nid 0]])
     [nid 0]
     ]))

(defn add-2in1-node [type gr i0 i1]
  (let [[gr eid0 eid1 nid] (new-ids gr 'e 'e 'n)]
    [(add-edges (add-nodes gr [nid type])
                [eid0 i0 [nid 0]]
                [eid1 i1 [nid 1]])
     [nid 0]
     ]))

(defn add-nin1-node [fn2 type0in gr ins]
  (letfn [(rec [gr ins]
            (cond (= (count ins) 0)
                  (let [[gr nid] (new-ids gr 'n)]
                       [(add-nodes gr [nid type0in])
                        [nid 'const1]
                        ])
                  (= (count ins) 1) [gr (first ins)]
                  (= (count ins) 2) (apply fn2 gr ins)
                  :else
                  (let [[gr o0] (apply fn2 gr (take 2 ins))]
                    (recur gr (cons o0 (drop 2 ins)))
                    )))]
    (rec gr ins)))

(defn and2 [gr i0 i1] (add-2in1-node 'and2 gr i0 i1))
(defn andn [gr & ins] (add-nin1-node and2 'const1 gr ins))
(defn or2 [gr i0 i1] (add-2in1-node 'or2 gr i0 i1))
(defn orn [gr & ins] (add-nin1-node or2 'const0 gr ins))

; e.g.) When the table of half adder is given,
;  ;   a b   s cout
;  '(((0 0) (0 0))
;    ((1 0) (1 0))
;    ((0 1) (1 0))
;    ((1 1) (0 1)))
;   this is half adder.
;
; the following graph is generated.
;  b --+---------------------------+-------+----X
;      |  |\                       |       |
;      +--| >o-----+-------+-------|-------|----X
;         |/       |       |       |       |
;  a --+-----------|-----+-|-------|-----+-|----X
;      |  |\       |     | |       |     | |
;      +--| >o---+-|-----|-|-----+-|-----|-|----X
;         |/     | |     | |     | |     | |
;               _|_|_   _|_|_   _|_|_   _|_|_
;              |     | |     | |     | |     |
;              |     | |     | |     | |     |
;               \___/   \___/   \___/   \___/
;                 |       |       |       |      __
;                 |       |       |       |     \  \
;                 |       |       |       +------|  |---- cout
;                 |       |       |       |     /__/
;                 |       |       |       |      __
;                 |       |       +-------------\  \
;                 |       |       |       |      |  |---- s
;                 |       +---------------------/__/
;                 |       |       |       |
;                 X       X       X       X
(defn truth-table [gr table in-eids]
  (let [[gr & in-invs] (gr/map gr not1 in-eids)
        [gr & and-deps] (gr/map gr
                          (fn [gr in-comb]
                            (apply andn gr
                              (cl/map (fn [in-val in-eid in-inv]
                                        (if (= in-val 1) in-eid in-inv))
                                      in-comb
                                      in-eids
                                      in-invs)))
                          (cl/map first table))]
    (gr/map gr
            (fn [gr1 dep-vals]
              (apply orn gr1
                     (remove #(= % nil)
                             (cl/map (fn [dep-val and-dep]
                                       (if (= dep-val 1) and-dep))
                                     dep-vals and-deps))))
            (transpose (cl/map #(nth % 1) table))
            )))

(defn all-dpt-terms [gr]
  (mapcat (fn [[nid type]]
            (cl/map (fn [term-no] [nid term-no])
                    (cond (= type 'out)       []
                          :else               [0]
                          )))
          (:nodes gr)
          ))

(defn pick-dpt-terms [gr idxs]
  (let [terms (all-dpt-terms gr)]
    (cl/map #(nth terms (mod % (count terms)))
            idxs)))

(let [nodes [{:f and2   :n-arv 2}
             {:f or2    :n-arv 2}
             {:f not1   :n-arv 1}
             {:f const1 :n-arv 0}
             {:f const0 :n-arv 0}]]
  (defn random-graph-pre [rand-strm n-in n-out n-node]
    (let [[gr & _] (apply inputs (new-graph) (range n-in))]
      (loop [gr gr i n-node rs rand-strm]
        (if (<= i 0)
          ; adds output ports
          (apply outputs gr
                 (cl/map vector
                         (pick-dpt-terms gr (take n-out rs))
                         (iterate inc 0)))
          ; adds a functions node
          (let [{f :f n-arv :n-arv} (nth nodes (mod (first rs) (count nodes)))
                rs (rest rs)
                term-idxs (take n-arv rs)
                rs (drop n-arv rs)]
            (recur (first (apply f gr
                                 (pick-dpt-terms gr term-idxs)))
                   (dec i) rs
                   )))))))

(defn remove-unrefered-conns [gr]
  (letfn [(gr-count [gr] [(count (:nodes gr))
                          (count (:edges gr))])
          (remove1 [gr]
            (let [; removes unrefered nodes
                  refered-nids (set (cl/map (fn [[_ [nid _] _]] nid)
                                            (:edges gr)))
                  refered-nodes (filter #(or (in-or-out? %)
                                             (refered-nids (nth % 0)))
                                        (:nodes gr))
                  ; removes unrefered edges
                  nids (set (cl/map (fn [[nid _]] nid)
                                    refered-nodes))
                  refered-edges (filter (fn [[_ _ [nid _]]] (nids nid))
                                        (:edges gr)
                                        )]
              (assoc (assoc gr :nodes refered-nodes)
                     :edges refered-edges)))]
    (loop [prev-count (gr-count gr) gr (remove1 gr)]
      (if (= (gr-count gr) prev-count)
        gr
        (recur (gr-count gr) (remove1 gr))
        ))))

(defn random-graph [rand-strm n-in n-out n-node]
  (remove-unrefered-conns
    (random-graph-pre rand-strm n-in n-out n-node)))

; Determines the order for calculation.
; Nodes do not have value.
; Edges have value.
;    _                          __
; c |_|------------------------\  \   e-9    _
;    _            __            |  |--------|_| z
; b |_|----------\  \     +----/__/n-8
;    _            |  |----+
; a |_|----------/__/n-5
;
;  {:next-id 11
;   :nodes '[[n-0 in a]
;            [n-1 in b]
;            [n-2 in c]
;            [n-5 or2]
;            [n-8 or2]
;            [n-10 out z]
;            ]
;   :edges '[[e-3 [n-0 0] [n-5 0]]
;            [e-4 [n-1 0] [n-5 1]]
;            [e-6 [n-5 0] [n-8 0]]
;            [e-7 [n-2 0] [n-8 1]]
;            [e-9 [n-8 0] [n-10 0]]
;            ]}
;
; [e-9 [or2 0] e-6 e-7] [e-6 [or2 0] e-3 e-4]
; [e-3 [in a]] [e-4 [in b]] [e-7 [in c]]
;
(defn dependency [gr eid]
  (letfn [(find1 [eid]
            (let [[_ [nid term] _] (first (filter #(= eid (first %))
                                                  (:edges gr)))
                  [_ type & attr] (if nid
                                    (first (filter #(= nid (first %))
                                                   (:nodes gr))))
                  func (cond (not type) nil
                             ('#{in out} type) [type (first attr)]
                             :else [type term])
                  args (if nid
                         (cl/map first
                                 (sort-by (fn [[_ _ [_ x]]] x)
                                          (filter (fn [[_ _ [x _]]] (= x nid))
                                                  (:edges gr)
                                                  ))))]
              (if func
                (concat [eid func] args)
                )))
            (rec [eid]
              (let [found (find1 eid)]
                (if found
                  (cons found
                        (mapcat rec (drop 2 found))
                        ))))]
    (rec eid)))

(defn calc-and2 [[i0 i1]]
  (cond (= i0 0)                [0]
        (= i1 0)                [0]
        (and (= i0 1) (= i1 1)) [1]
        :else                   [:x]))

(defn calc-or2 [[i0 i1]]
  (cond (= i0 1)                [1]
        (= i1 1)                [1]
        (and (= i0 0) (= i1 0)) [0]
        :else                   [:x]))

(defn calc-not1 [[i]]
  (cond (= i 0) [1]
        (= i 1) [0]
        :else   [:x]))

(defn calc-const0 [vec] [0])
(defn calc-const1 [vec] [1])

(defn calc1 [ntype vec]
  (case ntype
    and2   (calc-and2 vec)
    or2    (calc-or2  vec)
    not1   (calc-not1 vec)
    const0 (calc-const0 vec)
    const1 (calc-const1 vec)
    ))

(defn calc-along-dependency [dep in-vals]
  (loop [dep (reverse dep) calcd {}]
    (if (empty? dep)
      calcd
      (let [[target [type attr] & args] (first dep)]
        (recur (rest dep)
               (merge calcd
                      {target (if (= type 'in)
                                (in-vals attr)
                                (nth (calc1 type (cl/map calcd args))
                                     attr))}))))))

(defn calc [gr in-vals]
  (let [o-port-nodes (filter out? (:nodes gr))
        o-names (cl/map #(nth % 2) o-port-nodes)
        o-eids (cl/map #(first (first (filter (fn [[eid _ [nid _]]]
                                                (= nid (first %)))
                                              (:edges gr))))
                       o-port-nodes)
        calcd (calc-along-dependency
                (mapcat (partial dependency gr) o-eids)
                in-vals)]
    (zipmap o-names (cl/map calcd o-eids))))

(defn calc-all [gr]
  (let [comp-ids (fn [x y]
                   (case (and (number? x) (number? y)) (compare x y)
                         :else (compare (str x) (str y))))
        in-port-ids (sort comp-ids
                          (cl/map #(nth % 2)
                                  (filter in? (:nodes gr))))]
    (cl/map (fn [in-vals]
              (cl/map #(nth % 1)
                      (sort comp-ids
                            (calc gr (zipmap in-port-ids in-vals))
                            )))
            (cl/map reverse
                    (cm/selections [0 1] (count in-port-ids))
                    ))))


;; search tree example when;
;;  (match1 [en0 en1 en2 en3]
;;          [ptn0 ptn1 ptn2])
;;
;; ptn0  en0                     en1                     en2  ...
;;        |                       |                       |
;;        +-------+-------+       +-------+-------+       +-- ...
;;        |       |       |       |       |       |       |
;; ptn1  en1     en2     en3     en0     en2     en3     en0
;;        |       |       |       |       |       |       |
;;        +---+   +---+   +---+   +---+   +---+   +---+   +-- ...
;;        |   |   |   |   |   |   |   |   |   |   |   |   |
;; ptn2  en2 en3 en1 en3 en1 en2 en2 en3 en0 en3 en0 en2 en1  ...
;;
;(defn match-permutation
;  ([entries ptn] (match-permutation entries ptn {}))
;  ([entries ptn bind]
;    (if (< (count entries) (count ptn))
;      nil
;      (remove #(= % um/fail)
;              (cl/map #(um/unify ptn % bind)
;                      (mapcat cm/permutations
;                              (cm/combinations entries (count ptn))
;                              ))))))
;
;(defn match1 [gr ptn-n ptn-e]
;  (let [n-binds (match-permutation (:nodes gr) ptn-n)]
;    (first (mapcat #(match-permutation (:edges gr) ptn-e %)
;                   n-binds))))

(defn random-diff-val [rs n acc] ; rs: random stream
  (cond (<= n 0) acc
        (some #(= % (first rs)) acc) (recur (rest rs) n acc)
        :else (recur (rest rs) (dec n) (conj acc (first rs)))
        ))

(defn match1 [rs gr ptn-n ptn-e] ; rs: random stream
  (let [picked-nodes-strm
        (cl/map (fn [rand-strm]
                  (cl/map (fn [i] (nth (:nodes gr) i))
                          (random-diff-val rand-strm (count ptn-n) [])
                          ))
                (cl/map (fn [seed]
                          (cl/map (fn [val] (mod val (count (:nodes gr))))
                                  (ut/lfsr32 seed)))
                        rs))
        picked-edges-strm
        (cl/map (fn [rand-strm]
                  (cl/map (fn [i] (nth (:edges gr) i))
                          (random-diff-val rand-strm (count ptn-e) [])
                          ))
                (cl/map (fn [seed]
                          (cl/map (fn [val] (mod val (count (:edges gr))))
                                  (ut/lfsr32 seed)))
                        (drop (mod (first rs) 100) rs)
                        ))]
    (first (remove #(= % um/fail)
                   (take 100
                     (cl/map (fn [picked-nodes picked-edges]
                               (um/unify ptn-e picked-edges
                                         (um/unify ptn-n picked-nodes {})))
                             picked-nodes-strm picked-edges-strm
                             ))))))

; An example of replace pattern
;
;      _    be3   ____    be5         _
; bt1 |_|--------|    |--------------|_| bt6
;      _         | ha |
; bt0 |_|--------|____|--------X
;           be2    bn4
;                       |
;      _    ae3   __an4 v
; bt1 |_|--------|  \                 _
;      _         |   |---------------|_| bt6
; bt0 |_|--------|__/      ae5
;           ae2
;
; before pattern
; :nodes [?bn4 ha]
; :edges [?be2 ?bt0     [?bn4 0]]
;        [?be3 ?bt1     [?bn4 1]]
;        [?be5 [?bn4 1] ?bt6    ]
;
; after pattern
; :nodes [?an4 and2]
; :edges [?ae2 ?bt0     [?an4 0]]
;        [?be3 ?bt1     [?an4 1]]
;        [?be5 [?an4 0] ?bt6    ]
;
; The replace pattern above was applied the graph below;
;
;      _   e-5    ____n-6       e-8         __n-12
; cin |_|--------|    |---------------------\  \          _n-15
; n-2  _         | ha |         ____         |  |--------|_| cout
;   b |_|--------|____|--------|    |-------/__/   e-13
; n-1  _   e-4           e-7   | ha | e-11                _
;   a |_|----------------------|____|--------------------|_| s
; n-0      e-3                  n-9         e-10           n-14
;
; matching result;
;  {?bn4 n-6, ?be2 e-6, ?bt0 [n-1 0], ?be3 e-5, ?bt1 [n-2 0],
;   ?be5 e-8, ?bt6 [n-12 1]}
;
; replacing result;
; :nodes
;  [n-0  in  a   ]
;  [n-1  in  b   ]
;  [n-2  in  cin ]
;  [n-6  ha      ] ; matches, but will not removed
;  [n-9  ha      ]
;  [n-12 or2     ]
;  [n-14 out s   ]
;  [n-15 out cout]
;  [n-16 and2    ]
; :edges
;  [e-3  [n-0  0] [n-9  0]]
;  [e-4  [n-1  0] [n-6  0]] ; matches, but will not removed
;  [e-5  [n-2  0] [n-6  1]] ; matches, but will not removed
;  [e-7  [n-6  0] [n-9  1]]
;- [e-8  [n-6  1] [n-12 1]] ; matches, will removed
;  [e-10 [n-9  0] [n-14 0]]
;  [e-11 [n-9  1] [n-12 0]]
;  [e-13 [n-12 0] [n-15 0]]
;+ [e-17 [n-1  0] [n-16 0]]
;+ [e-18 [n-1  1] [n-16 1]]
;+ [e-19 [n-16 0] [n-12 1]]
(defn cut [gr cut-eids]
  (assoc gr :edges
         (remove #(cut-eids (first %)) (:edges gr))
         ))

(defn connect [{nodes :nodes edges :edges :as gr} bind aft]
  (let [unassigneds (remove #(contains? bind %) (um/vars-in aft))
        [gr & ids] (apply new-ids gr (cl/map (fn [_] 'x) unassigneds))
        hs (merge (zipmap unassigneds ids) bind)]
    (assoc (assoc gr :nodes
                  (concat nodes (um/subst-tree hs (:nodes aft))))
           :edges
           (concat edges (um/subst-tree hs (:edges aft)))
           )))

;(defn replace1 [gr ptn]
(defn replace [rs gr ptn] ; rs : random stream
  (let [bind (match1 rs gr
                     (:nodes (:bfr ptn))
                     (:edges (:bfr ptn)))]
    (if (nil? bind)
      gr
      (remove-unrefered-conns
        (connect (cut gr (set (cl/map bind (:cut ptn))))
                 bind (:aft ptn))))))

; gr/replace
; If (:bft ptn) and (:aft ptn) have equivalent topology,
; this function drops into infinite loop.
; Thus the argument max-iter was prepared.
;(defn replace [gr ptn & [max-iter]]
;  (letfn [(rec [gr i]
;            (let [replaced (replace1 gr ptn)]
;              (if (or (nil? replaced)
;                      (and max-iter
;                           (>= i max-iter)))
;                gr
;                (recur replaced (inc i)))))]
;    (rec gr 0)))

(defn sublis [map tree]
  (let [new (get map tree)]
    (if new
      new
      (if (and (coll? tree)
               (not (empty? tree)))
        (cons (sublis map (first tree))
              (sublis map (rest tree)))
        tree))))

(defn gr-to-bfr-ptn-nodes [gr]
  (cl/map #(if (in-or-out? %)
             [(symbol (str "?c" (str-join "-" (rest %))))
              (symbol (str "?*c" (str-join "-" (rest %))))
              ]
             [(symbol (str "?b" (first %)))
              (nth % 1)
              ])
          (remove out? (:nodes gr))
          ))

(defn gr-to-aft-ptn-nodes [gr]
  (cl/map (fn [[nid & rest]]
            [(symbol (str "?a" nid)) (first rest)])
          (remove in-or-out? (:nodes gr))
          ))

(defn gr-to-ptn-edges [gr prefix]
  (let [ports (zipmap (cl/map first
                              (filter in-or-out? (:nodes gr)))
                      (cl/map rest
                              (filter in-or-out? (:nodes gr))
                              ))
        term-to-ptn (fn [[term-nid term-no]]
                      (let [port (ports term-nid)]
                        (if port
                          [(symbol (str "?c" (str-join "-" port)))
                           (symbol (str "?c" (str-join "-" port) "-0"))
                          ]
                          [(symbol (str prefix term-nid))
                           term-no
                           ])))]
    (cl/map (fn [[eid & conn]]
              (cons (symbol (str prefix eid))
                    (cl/map term-to-ptn conn)))
            (:edges gr)
            )))

(defn gr-to-bfr-ptn-edges [gr]
  (gr-to-ptn-edges gr "?b"))
(defn gr-to-aft-ptn-edges [gr]
  (gr-to-ptn-edges gr "?a"))

(defn gr-to-ptn-cut [gr]
  (let [outs (set (cl/map first (filter out? (:nodes gr))))]
    (cl/map #(symbol (str "?b" (first %)))
            (filter (fn [[_ _ [arv-nid _]]] (outs arv-nid))
                    (:edges gr)
                    ))))

(defn gr-to-replace-ptn [gr-bfr gr-aft]
  {:bfr {:nodes (gr-to-bfr-ptn-nodes gr-bfr)
         :edges (gr-to-bfr-ptn-edges gr-bfr)}
   :cut (gr-to-ptn-cut gr-bfr)
   :aft {:nodes (gr-to-aft-ptn-nodes gr-aft)
         :edges (gr-to-aft-ptn-edges gr-aft)
         }})
