; 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)))))))