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