;      ____ dep-node   arv-node ____
;     |    |                   |    |
;  ---|    |-------------------|    |----------
;     |____|          arv-edge |____| dep-edge
;
; Every node have arv-edges and dep-edges.
; Every edge have a dep-node and arv-nodes.
;
; arv-edge stands for arrival edge.
; dep-edge stands for deperture edge.
; dep-node stands for deperture node.
; arv-node stands for arrival node.
;
; format of graph:
;   ((arv-eid0 arv-eid1 ...)
;    (nid node-type attr ...)
;    (dep-eid0 dep-eid1 ...))
; format of an edge:
;   (eid dep-nid arv-nid*)
;
; nid stands for node-id
; eid stands for edge-id

; (load #P"utils")
; (load #P"parser")
; (load #P"unified-matcher")

(defpackage :graph-generator
  (:nicknames :ggen)
  (:use :cl :utils)
  (:export :input :output :not1 :andn :orn :*graph* :truth-table
           :nid-type :calc))
(in-package ggen)

(defstruct (graph (:type list))
  (next-num 0) body)

(defvar *graph* (make-graph))

(defun reset-graph ()
  (setq *graph* (make-graph)))

(defmacro with-graph (graph &body body)
  (let ((graph-bak (gensym)))
    `(let ((,graph-bak *graph*))
       (setq *graph* ,graph)
       (prog1
         (progn ,@body)
         (setq *graph* ,graph-bak)))))

(defun new-id (&optional str)
  (prog1
    (intern (concatenate 'string
              (if str str "ID") "-"
              (princ-to-string (graph-next-num *graph*))))
    (setq *graph*
          (make-graph :next-num (1+ (graph-next-num *graph*))
                      :body (graph-body *graph*)
                      ))))

(defun add-node-conn (node arv-eids dep-eids)
  (setq *graph*
        (make-graph
          :next-num (graph-next-num *graph*)
          :body (cons (list arv-eids
                            (append (list (car node)
                                          (nid-type (car node) :ggen))
                                    (cdr node))
                            dep-eids)
                      (graph-body *graph*))))
  'ok)

(defun input (name)
  (let ((new-dep-eid (new-id "E")))
    (add-node-conn (list (new-id "IN") name)
                   nil
                   (list new-dep-eid))
    new-dep-eid))

(defun output (arv-eid name)
  (add-node-conn (list (new-id "OUT") name)
                 (list arv-eid)
                 nil)
  nil)

(defun not1 (arv-eid)
  (let ((new-dep-eid (new-id "E")))
    (add-node-conn (list (new-id "NOT1"))
                   (list arv-eid)
                   (list new-dep-eid))
    new-dep-eid))

(defun andn (&rest arv-eids)
  (let ((new-dep-eid (new-id "E")))
    (add-node-conn (list (new-id "ANDN"))
                   arv-eids
                   (list new-dep-eid))
    new-dep-eid))

(defun orn (&rest arv-eids)
  (let ((new-dep-eid (new-id "E")))
    (add-node-conn (list (new-id "ORN"))
                   arv-eids
                   (list new-dep-eid))
    new-dep-eid))

(defun or2 (arv-eid0 arv-eid1)
  (let ((new-dep-eid (new-id "E")))
    (add-node-conn (list (new-id "OR2"))
                   (list arv-eid0 arv-eid1)
                   (list new-dep-eid))
    new-dep-eid))


; 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
(defun truth-table (table in-eids)
  (let* ((in-invs (mapcar #'not1 in-eids))
         (and-deps
          (mapcar (lambda (in-comb)
                    (apply #'andn 
                           (mapcar (lambda (in-val in-eid in-inv)
                                     (if (eql in-val 1) in-eid in-inv))
                                   in-comb
                                   in-eids
                                   in-invs)))
                  (mapcar #'car table))))
    (mapcar (lambda (dep-vals)
              (apply #'orn
                     (remove nil (mapcar (lambda (dep-val and-dep)
                                           (if (eql dep-val 1) and-dep))
                                         dep-vals and-deps))))
            (transpose (mapcar #'cadr table)))))

(defun nid-type (nid &optional package)
  (mvbind (l rest) (funcall (p:many-till (p:other p:eof)
                                         (p:char #\-))
                            (p:new (symbol-name nid)))
    (when (eql l p:fail) (error "Node type is illigal ~A" node))
    (if package
      (intern (coerce (butlast l) 'string) package)
      (intern (coerce (butlast l) 'string))
      )))

(defun node-type (node)
  (nid-type (car node)))

;(defun dep-nid (graph eid)
;  (cadr (assoc eid (graph-edges graph))))
;
;(defun dep-node (graph eid)
;  (assoc (dep-nid graph eid)
;         (graph-nodes graph)))
;
;(defun arv-nids (graph eid)
;  (cddr (assoc eid (graph-edges graph))))
;
;(defun arv-nodes (graph eid)
;  (mapcar (lambda (nid)
;            (assoc nid (graph-nodes graph)))
;          (arv-nids graph eid)))
;
;(defun dep-edges (graph nid)
;  (remove-if-not (lambda (edge)
;                   (eql (cadr edge) nid))
;                 (graph-edges graph)))
;
;(defun dep-eids (graph nid)
;  (mapcar #'car (dep-edges graph nid)))
;
;(defun arv-edges (graph nid)
;  (remove-if-not (lambda (edge)
;                   (member nid (cddr edge)))
;                 (graph-edges graph)))
;
;(defun arv-eids (graph nid)
;  (mapcar #'car (arv-edges graph nid)))

(defun remove-conn (graph nid)
  (make-graph :next-num (graph-next-num graph)
              :body (remove nid (graph-body graph)
                            :key #'caadr)))

(defun add-conn (graph arv-eids node dep-eids)
  (make-graph :next-num (graph-next-num graph)
              :body (cons (list arv-eids node dep-eids)
                          (graph-body graph))))

(defun new-id2 (graph &rest strs)
  (labels ((rec (num strs acc)
             (if (null strs)
               (values (nreverse acc)
                       (make-graph :next-num (graph-next-num graph)
                                   :body (graph-body graph)))
               (rec (1+ num)
                    (cdr strs)
                    (cons (intern (concatenate 'string
                                    (car strs) "-"
                                    (princ-to-string num)))
                          acc)))))
    (rec (graph-next-num graph) strs nil)))
                    

(defconstant fail (gensym "FAIL"))

; search tree example when;
;  (match1 #<gr :conn (cn0 cn1 cn2 cn3)>
;          (list ptn0 ptn1 ptn2))
;
; ptn0  cn0                     cn1                     cn2  ...
;        |                       |                       |
;        +-------+-------+       +-------+-------+       +-- ...
;        |       |       |       |       |       |       |
; ptn1  cn1     cn2     cn3     cn0     cn2     cn3     cn0
;        |       |       |       |       |       |       |
;        +---+   +---+   +---+   +---+   +---+   +---+   +-- ...
;        |   |   |   |   |   |   |   |   |   |   |   |   |
; ptn2  cn2 cn3 cn1 cn3 cn1 cn2 cn2 cn3 cn0 cn3 cn0 cn2 cn1  ...
;
(defun match1 (graph ptns)
  (labels
    ((rec (ptns conns bind conn-acc)
       (cond ; on right endpoint, matching is failed
             ((null conns) fail)

             ; on bottom, matching is succeeded
             ((null ptns) (values bind (nreverse conn-acc)))

             ; tried to match on node
             (t (let ((b1 (um:unify (car ptns) (car conns) bind)))
                  (if (eql b1 um:fail)
                    ; go rightward on search tree
                    (rec ptns (cdr conns) bind conn-acc)

                    ; go down on search tree
                    (mvbind (b2 ca) (rec (cdr ptns)
                                         (remove (caadr (car conns))
                                                 (graph-body graph)
                                                 :key #'caadr)
                                         b1
                                         (cons (car conns) conn-acc))
                      (if (eql b2 fail)
                        ; go to rightward on search tree
                        (rec ptns (cdr conns) bind conn-acc)

                        ; succeeded to match
                        (values b2 ca)))))))))
    (rec ptns (graph-body graph) nil nil)))


;                  orn__
;   _   arv-edge     \  \   dep-edge   _dst-node
;  |_|----------------|  |------------|_|
;                    /__/
;                 |
;                 |
;                 v
;   _                                  _
;  |_|--------------------------------|_|
;
(defun elim1-orn-1in (graph)
  (mvbind (bind conns)
          (match1 graph
                  '(((?i0) (?nid orn) (?m1))))
    (um:with-bind bind
      (make-graph
        :next-num (graph-next-num graph)
        :body (sublis (list (cons ?m1 ?i0))
                      (remove ?nid (graph-body graph)
                              :key #'caadr))))))

;   _              orn__
;  |_|---------------\  \   dep-edge   _dst-node
;   _   arv-edges     |  |------------|_|
;  |_|---------------/__/
;                 |
;                 |
;                 v
;   _              or2__
;  |_|---------------\  \   dep-edge   _dst-node
;   _   arv-edges     |  |------------|_|
;  |_|---------------/__/
;
(defun elim1-orn-2in (graph)
  (um:with-bind (match1 graph
                     '(((?i0 ?i1) (?nid orn) (?o2))))
    (mvbind (ids gr) (new-id2 graph "OR2")
      (chain-call gr
        (remove-conn ?nid)
        (add-conn `(,?i0 ,?i1)
                  `(,(car ids) or2)
                  `(,?o2))))))

;   _              orn__
;  |_|---------------\  \
;   _   arv-edges     |  |
;  |_|----------------|  |  dep-edge   _dst-node
;   _                 |  |------------|_|
;  |_|----------------|  |
;   _                 |  |
;  |_|---------------/__/
;                 |
;                 |
;                 v
;   _             __or2
;  |_|-----------\  \
;   _             |  |---+    __orn
;  |_|-----------/__/    +---\  \
;   _                         |  |       _
;  |_|------------------------|  |------|_|
;   _                         |  |
;  |_|-----------------------/__/
;
(defun elim1-orn-many-in (graph)
  (um:with-bind (match1 graph
                        '(((?i0 ?i1 ?i2 . ?is) (?nid orn) (?o3))))
    (mvbind (ids gr) (new-id2 graph "OR2" "ORN" "E")
      (dbind (new-or2 new-orn eid) ids
        (chain-call gr
          (remove-conn ?nid)
          (add-conn (list ?i0 ?i1)
                    (list new-or2 'or2)
                    (list eid))
          (add-conn `(,eid ,?i2 ,@?is)
                    (list new-orn 'orn)
                    (list ?o3)))))))

(setf (get 'and2 'calc)
  (lambda (i0 i1)
    (cond ((eql i0 0) 0)
          ((eql i1 0) 0)
          ((and (eql i0 1) (eql i1 1)) 1)
          (t :x))))

(setf (get 'andn 'calc)
  (lambda (&rest args)
    (reduce (get 'and2 'calc) args
            :initial-value 1)))

(setf (get 'or2 'calc)
  (lambda (i0 i1)
    (cond ((eql i0 1) 1)
          ((eql i1 1) 1)
          ((and (eql i0 0) (eql i1 0)) 0)
          (t :x))))

(setf (get 'orn 'calc)
  (lambda (&rest args)
    (reduce (get 'or2 'calc) args
            :initial-value 0)))

(setf (get 'not1 'calc)
  (lambda (i)
    (cond ((eql i 0) 1)
          ((eql i 1) 0)
          (t :x))))

(defun calc (graph inport-vals)
  (let ((knowns (make-hash-table))
        (outports (remove-if-not
                    (lambda (record)
                      (eql (cadadr record) 'out))
                    (graph-body graph))))
    (labels
      ((solve1 (target-eid)
         (acond2 ((gethash target-eid knowns) it)
                 ((find-if (curry #'member target-eid)
                           (graph-body graph)
                           :key (curry #'nth 2))
                  (let ((retval (if (eql (cadadr it) 'in)
                                  (cdr (assoc (caddr (cadr it))
                                              inport-vals))
                                  (apply (get (cadadr it) 'calc)
                                         (mapcar #'solve1 (car it))))))
                    (setf (gethash target-eid knowns) retval)
                    retval))
                 (t :x))))
      (mapcar #'solve1 (mapcar #'caar outports))
      (mapcar (lambda (oport)
                (cons (caddr (cadr oport))
                      (gethash (caar oport) knowns)))
              outports))))

