;;; Soohyuck Chung, Szekit Ka, Joshua Taylor, Benjamin Wiegner
;;; Graph Theory -- Spring 2005


; (load "enumeration.lisp")


;; In lispworks, if we use lots of stack, we want it to 
;; automatically increase for us without user intervention
#+lispworks (setf system:*stack-overflow-behaviour* nil)

;; Lispworks has when-let, but CLISP doesn't.
(unless (fboundp 'when-let)
  (defmacro when-let ((var form) &body body)
    "bind a var to a the reslt of evaluating a form, 
and evaluate body only when form returns non-nil"
    `(let ((,var ,form))
       (when ,var
         ,@body))))


;; simple macro to simplify the
;; "if val in cache, val, else store val in cache, return val
;; construct
(defmacro cache-value (place form)
  "read the value at place, and only if it is not there,
evaluate form, and store form there"
  `(if ,place ,place
     (setf ,place ,form)))


;; some function-level caching from norvig (PAIP, p270)
(defun memo (fn &key test key)
  "Return a memo-function of fn."
  (let ((table (make-hash-table :test test)))
    #'(lambda (&rest args)
        (let ((k (funcall key args)))
          (multiple-value-bind (val found-p) (gethash k table)
            (if found-p val
              (setf (gethash k table) (apply fn args))))))))


(defun memoize (fn-name &key (key 'identity) (test 'equal))
  "Replace fn-name's global definition with a memoize version"
  (setf (symbol-function fn-name)
        (memo (symbol-function fn-name) :key key :test test)))
            

;; The Graph Structure is really little more than
;; a matrix (list of lists). Extra slots are only
;; for efficiency/convenience sake. Several accessors
;; are provided for thingslike graph order as well.
(defstruct graph
  (adjacency-matrix nil)
  (internal-order nil)
  (internal-g6-string nil)
  (internal-canonical-label nil)
  (internal-dreadnaut-string nil)
  (internal-graceful-labeling nil))


(defun graph-order (graph)
  "order of a graph, calculate the first time, return
cached value on subsequent calls"
  (cache-value
   (graph-internal-order graph)
   (length (graph-adjacency-matrix graph))))


(defun vertex-degree (vid graph)
  "what is the degree of vertex vid in graph?"
  (let ((go (graph-order graph))
        (am (graph-adjacency-matrix graph)))
    (unless (< vid go)
      (error "No vertex ~A in graph. Only ~a vertices in graph." vid go))
    (count t (elt am vid))))


(defun maximum-vertex-degree (graph)
  "what is the highest degree vertex in graph"
  (loop for i from 0 below (graph-order graph)
        maximize (vertex-degree i graph)))


(defun make-edgeless-graph (num-v)
  "make an edgeless graph with num-v vertices"
  (make-graph :adjacency-matrix
              (loop for x from 0 below num-v collecting
                    (loop for y from 0 below num-v collecting nil))))


(defun vertex-adjacency-vector (vid graph)
  "given the index of a vertex v, return a list of the
vertex indices to which v is adjacent"
  (let* ((am (graph-adjacency-matrix graph))
         (vm (elt am vid)))
    (loop for i from 0 below (length vm)
          when (elt vm i)
          collect i)))



;; read-graph, read-graph-from-frile, print-graph, and
;; graph-to-dreadnaut all deal with input and output of
;; graphs to other formats. read-graph, read-graph-from-file
;; and print-graph all assume the format that the group
;; decided upon, order, followed by an adjacency matrix
;; graph-to-dreadnaut uses a (conceptually) similar format
;; which is accepted by McKay's dreadnaut.
(defun read-graph (&optional (stream *standard-input*))
  "read a graph from a stream"
  (let ((order (read stream)))
    (make-graph 
     :adjacency-matrix 
     (loop for i from 0 below order
	   collecting (loop for j from 0 below order
			    collecting 
			    (not (zerop (read stream))))))))


(defun print-graph (graph &optional (stream *standard-output*))
  "print a graph to stream"
  (format stream "~A~%" (graph-order graph))
  (dolist (x (graph-adjacency-matrix graph))
    (dolist (y x)
      (format stream "~A " (if y 1 0)))
    (terpri stream)))


(defun read-graph-from-file (pathname)
  "read a graph from the file at pathname"
  (let ((of (open pathname)))
    (prog1 (read-graph of)
      (close of))))


(defun write-graph-to-file (graph pathname)
  "write a graph to a file at pathname"
  (let ((of (open pathname :direction :output)))
    (print-graph graph of)
    (close of)))


(defun graph-to-dreadnaut (graph &optional (stream *standard-output*))
  "print the graph in a format that dreadnaut can use"
  (adjacency-matrix-to-dreadnaut (graph-adjacency-matrix graph) stream))

   
(defun adjacency-matrix-to-dreadnaut (am &optional (stream *standard-output*))
  "given an adjacency matrix print it to the stream"
  (let ((go (length am)))
    (format stream "n~Ag~%" go)
    (dotimes (i go)
      (dotimes (j go)
        (when (elt (elt am j) i)
          (format stream " ~A"j)))
      (format stream ";~%"))))
  

;; as I use an adjacency matrix of Lisp booleans,
;; adjacency checking is simply indexing into the
;; matrix. Likewise, asserting adjacency is just
;; setting this value true, and making-unadjacent
;; is just null'ing this value
(defun adjacent? (x y graph)
  "are x and y adjacent in the graph"
  (elt (elt (graph-adjacency-matrix graph) y) x))


(defun make-adjacent (x y graph)
  "make x and y adjacent in graph"
  (when (eq x y)
    (error "Vertex ~A can not be made adjacent to itself" x))
  (setf (elt (elt (graph-adjacency-matrix graph) y) x) t
	(elt (elt (graph-adjacency-matrix graph) x) y) t))


(defun make-unadjacent (x y graph)
  "make x and y not adjacent in graph"
  (setf (elt (elt (graph-adjacency-matrix graph) y) x) nil
	(elt (elt (graph-adjacency-matrix graph) x) y) nil))


;; augment graph takes a graph, and a vertex number, and
;; returns a _new_ graph (not modifying the original) in
;; which a vertex has been added, adjacent only to v from
;; the original graph
(defun augment-graph (v graph)
  "add a new vertex adjacent to v in the graph"
  (let* ((am (graph-adjacency-matrix graph))
	 (go (graph-order graph))
	 (new-rows (loop for i from 0 below go
			 collecting (append (elt am i) (list nil))))
	 (newest-row (make-list (1+ go) :initial-element nil))
	 (new-graph (make-graph :adjacency-matrix `(,@new-rows ,newest-row))))
    (make-adjacent go v new-graph)
    new-graph))
;(memoize 'augment-graph)


(defun make-line-tree (order)
  "make the line tree of order ORDER"
  (let ((ng (make-graph :adjacency-matrix
                        (loop for i from 0 below order
                              collecting
                              (loop for j from 0 below order
                                    collecting nil)))))
    (dotimes (i (1- order))
      (make-adjacent i (1+ i) ng))
    ng))
;(memoize 'make-line-tree :test 'eql)


;; some seedlings (very small, simple trees) that may be
;; useful later on. At the least, the two vertex tree is
;; useful, as all others should be built from it.
(defparameter *one-vertex-tree*   (make-graph :adjacency-matrix '((nil))))
(defparameter *two-vertex-tree*   (augment-graph 0 *one-vertex-tree*))
(defparameter *three-vertex-tree* (augment-graph 1 *two-vertex-tree*))
(defparameter *four-vertex-line*  (augment-graph 2 *three-vertex-tree*))
(defparameter *four-vertex-tree*  (augment-graph 1 *three-vertex-tree*))


;; interfacing to dreadnaut / NAUTY / gtools is a little
;; ugly. We don't have enough need to justify linking in
;; the NAUTY libraries, but Lispworks pipes are a little
;; bad too, in that you can't close just one direction, so
;; use the "echo -e" kludge...
(defun get-dreadnaut-string (graph)
  "quick wrapper for dreadnaut string, use caching"
  (cache-value
   (graph-internal-dreadnaut-string graph)
   (get-dreadnaut-string-from-adj-matrix (graph-adjacency-matrix graph))))


(defun get-dreadnaut-string-from-adj-matrix (am)
  "make the matrix to a dreadnaut format string"
  (with-output-to-string (s)
    (adjacency-matrix-to-dreadnaut am s)))
(memoize 'get-dreadnaut-string-from-adj-matrix)


(defun get-graph6-string (graph)
  "get the graph6 format of a graph by sending it through dretog,
use caching in the graph"
  (cache-value
   (graph-internal-g6-string graph)
   (get-graph6-string-from-adj-matrix (graph-adjacency-matrix graph))))


;; good UNIX style, dretog only outputs the essential on
;; stdout, and the user stuff on stderr, so :error-output nil
;; means don't read that stuff
(defun get-graph6-string-from-adj-matrix (am)
  (let* ((ds (get-dreadnaut-string-from-adj-matrix am))
         (cl (format nil "echo -e '~A' | dretog 2>/dev/null" ds))
         (op #+lispworks (sys:open-pipe cl :direction :input :error-output nil)
             #+clisp     (ext:make-pipe-input-stream cl)))
    (prog1 (read-line op)
      (close op))))
(memoize 'get-graph6-string-from-adj-matrix)


(defun canonically-label-graph6 (g6-string)
  "return the label (as with labelg) for the graph6 format string"
  (let* ((cl (format nil "echo -e '~A' | labelg 2>/dev/null" g6-string))
         (op #+lispworks (sys:open-pipe cl :direction :input :error-output nil)
             #+clisp (ext:make-pipe-input-stream cl)))
    (prog1 (read-line op)
      (close op))))
(memoize 'canonically-label-graph6 :test #'equal)


(defun get-canonical-label (graph)
  "get the canonical label, use caching"
  (cache-value
   (graph-internal-canonical-label graph)
   (canonically-label-graph6 (get-graph6-string graph))))

     
;; now we can define graph-equal for two graphs
;; which shows if the unlabeled graphs are identical 
(defun graph-equal (g1 g2)
  "are graphs g1 g2 identical?"
  (string= (get-canonical-label g1)
           (get-canonical-label g2)))


;; this simply enumerates the ways of adding a single
;; edge between a new vertex and a vertex in the graph
(defun generate-all-augmentations (graph)
  "generate all augmentations of a graph, including identicals"
  (loop for v from 0 below (graph-order graph)
        collecting (augment-graph v graph)))


;; this enumerates the ways of adding a single edge
;; between a new vertex and a vertex in the graph,
;; and removes identical graphs via a call to NAUTY
(defun generate-all-unique-augmentations (graph)
  "generate all the unique augmentations of a graph"
  (remove-duplicates (generate-all-augmentations graph)
                     :test #'graph-equal))


(defun generate-augmentations-to-set (graph-set)
  "generate all the unique augmentations of each graph in graph-set
and then remove any identical graphs from the union of those results"
  (remove-duplicates
   (let ((res (generate-all-unique-augmentations (first graph-set))))
     (dolist (g (cdr graph-set) res)
       (nconc res (generate-all-unique-augmentations g))))
   :test #'graph-equal))


(defun generate-trees-of-order (n)
  "build all the trees by starting at the lowest level"
  (cond
   ((zerop n) nil)
   ((eq 1 n) (list *one-vertex-tree*))
   ((eq 2 n) (list *two-vertex-tree*))
   (t (generate-augmentations-to-set (generate-trees-of-order (1- n))))))
(memoize 'generate-trees-of-order :test 'equal)


(defun print-trees-of-order (n)
  "print the trees of order n"
  (prog1 nil 
    (mapcar #'(lambda (g)
		(terpri)
		(print-graph g))
	    (generate-trees-of-order n))))


;; graph union returns a new graph which is a union of the
;; provided graphs g1, g2, g3... Let k1 = |V(g1)|, k2 = |V(g2)|, ...
;; then v1, v2, vk1... of the resulting graph correspond to
;; v1, v2,...,vk of g1, vK1+1, vK1+2,...,vK1+K2 correspond to
;; the vertices of g2, etc.
(defun graph-union (&rest graphs)
  "return a new graph which is the union of the provided graphs"
  (let* ((orders (mapcar #'graph-order graphs))
         (total  (loop for o in orders summing o))
         (ng     (make-edgeless-graph total))
         (offset 0))
    (loop for g in graphs
          for o in orders
          finally (return ng) do
          (dotimes (x o)
            (dotimes (y o)
              (when (adjacent? x y g)
                (make-adjacent (+ offset x) (+ offset y) ng))))
          (incf offset o))))


(defun make-special-tree (num-paths path-length)
  "make our group's special tree, num-paths which are path-length
long, adjacent to an additional vertex z"
  (let* ((paths (loop for i from 0 below num-paths collecting (make-line-tree (1+ path-length))))
         (sg (apply #'graph-union (cons *one-vertex-tree* paths))))
    (dotimes (x num-paths)
      (make-adjacent 0 (1+ (* (1+ path-length) x)) sg))
    sg))

(defun print-special-tree (num-paths path-length)
  "print the special tree with num-paths and path-length"
  (print-graph (make-special-tree num-paths path-length)))


;; checking 'special treeness' is easy, but requires explanation:
;; in one of our special trees, the highest vertex degree will
;; correspond to the number of paths which were put into the
;; tree. (In the case of 2, other vertices may also have this
;; degree, but it is inconsequential.) The remaining vertices
;; then must fall into a number of 'line trees'. Thus, we can
;; determine the number of vertices in each path. With this
;; knowledge, we can construct the tree with the same parameters
;; using #'make-special-tree. Graph-equal can then compare these
;; trees, since, if the tree is a special tree, the canonical
;; labelings will be the same.
;; returns the nil or the
;;         values t, special-tree, num-paths, path-length
(defun is-special-tree? (tree)
  "is the tree of our special variety?"
  (let* ((num-paths (maximum-vertex-degree tree))
         (path-length (1- (/ (1- (graph-order tree)) num-paths))))
    (when (integerp path-length)
      (let ((stree (make-special-tree num-paths path-length)))
        (when (graph-equal stree tree)
          (values t stree num-paths path-length))))))


;; this actually only returns a graceful labeling
;; for our special tree format. Note, it also works
;; based on the way graphs are labeled in our method
;; of generating the special trees. There needs to some
;; way to project this back onto the original graph
(defun special-tree-graceful-labeling (&optional (graph (read-graph)))
  "get the graceful labeling of a tree"
  (multiple-value-bind (special? our-form num-paths path-length) (is-special-tree? graph)
    (declare (ignore our-form))
    (when special?
      (let* ((v-in-path (1+ path-length))
             (lab       (make-array `(,v-in-path ,num-paths)))
             (ret       (make-list (graph-order graph)))
             (counter 0)
             (max-num   (1- (graph-order graph)))
             (min-num   1))
        (dotimes (row v-in-path)
          (when (evenp row)
            (loop for col from 0 below num-paths 
                  for val = max-num then (- val v-in-path)
                  do (setf (aref lab row col) val)
                  finally (decf max-num)))
          (when (oddp row)
            (loop for col from 0 below num-paths
                  for val = min-num then (+ val v-in-path)
                  do (setf (aref lab row col) val)
                  finally (incf min-num))))
        (setf (nth 0 ret) 0)
        (dotimes (i num-paths ret)
          (dotimes (j v-in-path)
            (setf (nth (incf counter) ret) (aref lab j i))))))))


(defun general-tree-graceful-labeling (&optional (graph (read-graph)))
  "return a graceful labeling for a given graph"
  (let* ((o (graph-order graph))
         (vids (loop for i from 0 below o collect i))
         (labs (make-list o :initial-element nil)))
    (block top-level
      (dolist (i vids)
        (setf (elt labs i) 0)
        (when-let (labeling (recursive-general-tree-graceful-labeling
                             graph labs (list i) (1- o)))
          (return-from top-level labeling))
        (setf (elt labs i) nil)))))


(defun recursive-general-tree-graceful-labeling (graph labs labeled-vertices max-diff)
  "the recursive portion of the general graceful labeling routine"
  (if (zerop max-diff) labs
    (block interior-loop
      (dolist (p labeled-vertices)
        (dolist (q (vertex-adjacency-vector p graph))
          (unless (elt labs q)            ; unless q is already labeled
            (let* ((p-label (elt labs p)) ; there are 2 possible assignments for q
                   (q-labels (list (- p-label max-diff)
                                   (+ p-label max-diff))))
              (dolist (q-label q-labels)  ; for each possible labeling of q
                (unless (or (< q-label 0) ; if it's an OK labeling, 
                            (>= q-label (graph-order graph))
                            (member q-label labs :test #'equal))
                  (setf (elt labs q) q-label)
                  (when-let (complete-labeling (recursive-general-tree-graceful-labeling   ; try labeling the rest of the graph
                                                graph labs                                 ; with q labeled
                                                (cons q labeled-vertices) (1- max-diff)))
                    (return-from interior-loop complete-labeling))
                  (setf (elt labs q) nil))))))))))