; R91922034 Hung-Te Lin
; AI Project 1
;
; Part I & Part II together
;
; Please use (setq K n) and (setq GRAPH '(n (m n) ...))
; Then (clique-1) and (clique-2) to see the results.
;
;(setq K 4)
;(setq GRAPH (list 8 '(1 3) '(1 4) '(1 5) '(1 7) '(2 4) '(2 5) '(2 7) '(2 8) '(3 8) '(4 6) '(4 7) '(5 6) '(5 7) '(5 8) '(7 8) ) )

; =========================================================================================
; basic utility functions
; =========================================================================================
(defun edge-1 (e)
  "return the first part of an edge"
  (car e))

(defun edge-2 (e)
  "return the second part of an edge"
  (cadr e))

(defun node-in-edge-p (n e)
  "predicate: given node in given edge?"
  (or (equal (edge-1 e) n) (equal (edge-2 e) n)))
; (node-in-edge-p '2 '(1 2))

(defun formal-edge (e)
  "return edge in formal (from less to more) format"
  (if (< (edge-1 e) (edge-2 e))
      e
    (list (edge-2 e) (edge-1 e))))

(defun combination (n l)
  "return all n-combination of list l"
  (cond
   ((<= n 0) nil)
   ((null l) nil)
   ((= n 1) (mapcar 'list l))
   (t
    (append ; append [car+left, left]
     (mapcar (lambda (x) (cons (car l) x)) (combination (1- n) (cdr l)))
     (combination n (cdr l))))))
;(combination -1 '(1 2 3 4))

(defun edge-in-graph-p (e g)
  "predicate: given edge in given graph?"
  (if (> (apply '+ (mapcar
                    (lambda (e2)
                      (if (equal (formal-edge e) (formal-edge e2))
                          1 0)) g))
         0) t nil))
;(edge-in-graph-p '(1 3) EDGES)

(defun range (r)
  "generate interger list from 0 .. i"
  (if (= r 0) (list r)
    (cons r (range (- r 1)))))
; (range 3)

(defun graph-range (g)
  "flat the graph to something like 'range'."
  (if (null g) nil (union (list (caar g)) (union (cadr g) (graph-range (cdr g))))))

(defun print-clique (c)
  " print a clique in good flavor. now orderd."
  (print (sort c '<)))

(defun msg-nosolution ()
  (print "Sorry, no solution found")
  nil)

; =========================================================================================
; algo-oriented utility functions
; =========================================================================================
(defun remove-node-edges (node l)
  " remove a specified node from given edges "
  (cond
   ((null l) nil)
   ((node-in-edge-p node (car l))
    (remove-node-edges node (cdr l)))
   (t (cons (car l) (remove-node-edges node (cdr l))))))
; (remove-node-edges '8 EDGES)

(defun get-related-nodes (n l)
  " get those nodes related to this node "
  (let ((e (car l)))
    (cond
     ((null e) nil)
     ((equal (edge-1 e) n) (cons (edge-2 e) (get-related-nodes n (cdr l))))
     ((equal (edge-2 e) n) (cons (edge-1 e) (get-related-nodes n (cdr l))))
     (t (get-related-nodes n (cdr l))))))
;(get-related-nodes '8 EDGES)

(defun get-node-edges-count (n l)
  " how many edges are related to node n? "
  (apply '+ (mapcar
             (lambda (e)
               (if (node-in-edge-p n e)
                   1 0)) l)))

(defun get-node-edges-ordered-table (g)
  " get an order list of [node,edge count] list"
  (sort
   (mapcar (lambda (x) (cons x (get-node-edges-count x g))) (graph-range g))
   (lambda (x y) (> (cdr x) (cdr y)))))

(defun graph-ordered-range (g)
  " get a ordered list, like graph-range but ordered"
  (mapcar 'car (get-node-edges-ordered-table g)))

(defun constraint-k (k ns l)
  "constraint propergation on k-clique: check and remove ns nodes"
  (let ((n (car ns)) (nn (cdr ns)))
    (cond ((null ns) l)
          ((null l) l)
          ((< (get-node-edges-count n l) (- k 1))
           " we have to remove n!"
           (constraint-k k (union nn (get-related-nodes n l))
                         (remove-node-edges n l)))
          (t (constraint-k k nn l)))))
; (constraint-k 4 (range 5) EDGES)

(defun clique-add-node-p (c n g)
  "can i add node 'n' to clique 'c' by graph 'g'?"
  (if (= (apply '+
                (mapcar (lambda (nx)
                          (if (edge-in-graph-p (list n nx) g) 1 0)) c))
         (length c))
      t
    nil))
;(clique-add-node-p '(1) 3 EDGES)

(defun generate-clique-edges (c)
  "generate and return all the edges for clique c"
  (cond ((null c) nil)
        (t (append (mapcar (lambda (x) (list (car c) x)) (cdr c))
                   (generate-clique-edges (cdr c))))))
;(generate-clique-edges '(1 2 3 4))

(defun clique-p (c)
  "is c a clique of g?"
  (if (> (apply '+
                (mapcar (lambda (n)
                          (if (edge-in-graph-p n g)
                              0 1))
                        (generate-clique-edges c))) 0)
      nil   t))
;(clique-p '(1 2 3) '((1 2) (1 3) (2 3)))

; =========================================================================================
; search functions
; =========================================================================================
(defun clique-dfs (k c ns g)
  "depth-first search on k-clique"
;  c: current clique, ns: available nodes list, g: the graph, solves: found solves
;  this is a little complicated because i put extra code for output control
  (let ((n (car ns))(nn (cdr ns)))
    (if (null ns)
        nil
      (cond ((clique-add-node-p c n g)
             (let ((new-clique (sort (union c (list n)) '<)))
               (cond ((>= (length new-clique) k)
                                        ; we found another solve?
                      (setf found-solves
                            (union (list new-clique) found-solves :test #'equal))
                      (cond ((> (length found-solves) found-solves-count)
                                        ; now sure this is another solve
                             (print-clique new-clique)
                             (setf found-solves-count (length found-solves))))))
               (if (>= found-solves-count max-solve-count)
                                        ; can we stop now?
                   found-solves
                 (let ((r (clique-dfs k new-clique nn g)))
                   (if (null r)
                       (clique-dfs k c nn g)
                     r)))))
            (t (clique-dfs k c nn g))))))

(defun clique-replace-one (ns avail-nodes)
  " try to use any of the avail-nodes to find clique... who used this? @_@"
  (some (lambda (x) (clique-p (cons x ns))) avail-nodes))

(defun clique-match-set (k ns avail-nodes)
  "given node set ns, try to find (length ns)-clique in g. avail-nodes are those can be replaced"
  ; due to some issue, you must check [all ns] and [none of ns] before.
  ; flow: generate xns to replace, and map by (combination length-xns avail-nodes)
  (let ((nodes-set (combination (- k (length ns)) avail-nodes)))
    (cond ((null ns) nil)
          ((and (=(length ns) k) (clique-p ns)) (print-clique ns) t)
          ((null nodes-set) nil)
          ((some (lambda (x)
                   (clique-match-set k (append x ns)
                                     (set-difference avail-nodes x)))
                 nodes-set) t)
          (t (clique-match-set k (cdr ns) avail-nodes)))))
;(princ (clique-match-set 4 '(1 2 3) '((1 2)(2 3)(3 1)(1 4)(1 5)) '(7 5 4 8)))

; =========================================================================================
; Solvers
; =========================================================================================
(defun clique-1 (&optional (max-solves 1))
  "k-clique, solver part 1"
;  "start:         a clique in g"
;  "initial state: empty clique"
;  "goal state:    a clique of size larger than or equal to K, else nil"
  (setq max-solve-count max-solves)
  (setq found-solves '())
  (setq found-solves-count 0)
  (print '(Initializing and constraint checking))
  (let ((g (constraint-k K (range (car GRAPH)) (cdr GRAPH))))
    (clique-dfs k '() (graph-ordered-range g) g)
    (print '============================================)
    (cond ((> (length found-solves) 0)
           (print "Total Solutions Found:")
           (print found-solves) t)
          (t (msg-nosolution)))))

(defun clique-2 (&optional (max-solves 1))
  "k-clique, solver part 2"
;    State: a set of vertices of size K in G  
;    Initial state: an arbitrary set of vertices of size K 
;    Successor function: (this is your job) 
;    Goal state: a clique of size larger than or equal to K
  (print '(Initializing and constraint checking))
  (let ((NODES (car GRAPH)) (gr (constraint-k K (range (car GRAPH)) (cdr GRAPH))))
    (setq g gr)
                                        ; edge-array is a count of (id . count)
    (setq edge-array (get-node-edges-ordered-table g))
    (print '============================================)
    (cond ((< (length edge-array) k)
           (msg-nosolution))
          (t
           (setq k-head (mapcar 'car (subseq edge-array 0 k)))
           (setq k-avail (mapcar 'car (subseq edge-array k)))
           (cond
            ; 1st check: already clique?
            ((clique-p k-head) (print-clique k-head) t)
            ; 2nd check: change partial elements, print in clique-match-set
            ((some
              (lambda (x)
                (clique-match-set k (set-difference k-head (list x)) k-avail))
              k-head))
            ; 3rd check: all changed
            ((some
              (lambda (x)
                (cond ((clique-p x) (print-clique x) t)
                      (t nil)))
              (combination k k-avail)))
            (t
             (msg-nosolution)))))))