Changed the license to the AGPL3. Downcased all the lisp sources. Completed the READM...
[com-informatimago:com-informatimago.git] / common-lisp / cesarum / constraints.lisp
1 ;;;; -*- mode:lisp;coding:utf-8 -*-
2 ;;;;**************************************************************************
3 ;;;;FILE:               constraints.lisp
4 ;;;;LANGUAGE:           Common-Lisp
5 ;;;;SYSTEM:             Common-Lisp
6 ;;;;USER-INTERFACE:     NONE
7 ;;;;DESCRIPTION
8 ;;;;    
9 ;;;;    A little constraint solver.
10 ;;;;
11 ;;;;    Given a graph of nodes, and a propagate function that
12 ;;;;    propagates constraints from node to nodes, the solver
13 ;;;;    propagates the constraints until no change occurs.
14 ;;;;
15 ;;;;    It computes the strongly connected components, and performs a
16 ;;;;    topological sort of the condensed graph to minimalize the
17 ;;;;    number of calls to propagate.
18 ;;;;
19 ;;;;    
20 ;;;;AUTHORS
21 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
22 ;;;;MODIFICATIONS
23 ;;;;    2011-07-31 <PJB> Created.
24 ;;;;BUGS
25 ;;;;LEGAL
26 ;;;;    AGPL3
27 ;;;;    
28 ;;;;    Copyright Pascal J. Bourguignon 2011 - 2011
29 ;;;;    
30 ;;;;    This program is free software: you can redistribute it and/or modify
31 ;;;;    it under the terms of the GNU Affero General Public License as published by
32 ;;;;    the Free Software Foundation, either version 3 of the License, or
33 ;;;;    (at your option) any later version.
34 ;;;;    
35 ;;;;    This program is distributed in the hope that it will be useful,
36 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
37 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
38 ;;;;    GNU Affero General Public License for more details.
39 ;;;;    
40 ;;;;    You should have received a copy of the GNU Affero General Public License
41 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
42 ;;;;**************************************************************************
43
44 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.CONSTRAINTS"
45   (:use "COMMON-LISP"
46         "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.DICTIONARY"
47         "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY")
48   (:export "SOLVE-CONSTRAINTS")
49   (:documentation "
50
51 "))
52 (in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.CONSTRAINTS")
53
54
55
56 ;;;
57 ;;; Tarjan's Strongly Connected Components Algorithm.
58 ;;;
59
60 (defun make-graph (edges)
61   ;; We represent the graph as a dictionnary mapping FROM nodes to
62   ;; their adjacency list.
63   (loop
64      :with graph = (make-dictionary 'adaptating-dictionary)
65      :for (from to) :in edges
66      :do (progn
67            (push to (dictionary-get graph from '()))
68            (setf (dictionary-get graph to) (dictionary-get graph to '())))
69      :finally (return graph)))
70
71 (defun graph-nodes (graph)
72   "RETURN:   The list of nodes in the GRAPH"
73   (let ((nodes '()))
74     (dictionary-map (lambda (k v) (declare (ignore v)) (push k nodes)) graph)
75     nodes))
76
77 (defun graph-adjacency-list (graph node)
78   "RETURN:   The list of successors of NODE in the GRAPH."
79   (dictionary-get graph node))
80
81
82
83
84 (defparameter *germany*
85   (make-graph (mapcan (lambda (edge) (list edge (reverse edge)))
86                      '((frankfurt mannheim)
87                        (frankfurt wuerzburg)
88                        (frankfurt kassel)
89                        (stuttgart nuemberg)
90                        (mannheim karlsruhe)
91                        (wuerzburg erfurt)
92                        (wuerzburg nuemberg)
93                        (kassel muenchen)
94                        (karlsruhe augsburg)
95                        (augsburg muenchen)
96                        (nuemberg muenchen)))))
97
98
99
100 (defun breadth-first-search (graph root goal &key (test 'eql) key)
101   "
102 DO:     Implement the Breadth First Search algorithm on the given
103         GRAPH, starting from the ROOT node, until the GOAL is reached.
104         The GOAL is compared with the TEST function to the value of
105         the KEY function applied to the nodes. (Default for KEY is
106         IDENTITY).
107 RETURN: The goal node.
108 COMPLEXITY:  Time: O(|V|+|E|), Space: O(|V|)
109 "
110   (breadth-first-search-if graph
111                            root
112                            (lambda (node) (funcall test node goal))
113                            :key key))
114
115
116 (defun breadth-first-search-if (graph root predicate &key key)
117   "
118 DO:     Implement the Breadth First Search algorithm on the given
119         GRAPH, starting from the ROOT node, until the PREDICATE
120         applied on the value of the KEY function applied to the node
121         returns true.  (Default for KEY is IDENTITY).
122 RETURN: The goal node.
123 COMPLEXITY:  Time: O(|V|+|E|), Space: O(|V|)
124 "
125   (let ((key (or key (function identity)))
126         (head   '())
127         (tail   '())
128         (marks (make-hash-table)))
129     (flet ((enqueue (node) (if (null head)
130                                (setf head (list node)
131                                      tail head)
132                                (setf (cdr tail) (list node)
133                                      tail (cdr tail))))
134            (dequeue () (cond
135                          ((null head)     nil)
136                          ((eql head tail) (prog1 (car head)
137                                             (setf head nil
138                                                   tail nil)))
139                          (t               (pop head))))
140            (empty () (null head))
141            (stop (node) (funcall predicate (funcall key node)))
142            (mark (node) (setf (gethash node marks) t))
143            (markedp (node) (gethash node marks)))
144       (declare (inline enqueue dequeue empty stop mark markedp))
145       (enqueue root)
146       (mark root)
147       (loop :until (empty) :do
148          (let ((v (dequeue)))
149            (when (stop v)
150              (return-from breadth-first-search-if v))
151            (loop :for w :in (graph-adjacency-list graph v) :do
152               (unless (markedp w)
153                 (enqueue w)
154                 (mark w))))))))
155
156
157 (defun depth-first-search (graph root goal &key (test 'eql) key)
158     "
159 DO:     Implement the Depth First Search algorithm on the given
160         GRAPH, starting from the ROOT node, until the GOAL is reached.
161         The GOAL is compared with the TEST function to the value of
162         the KEY function applied to the nodes. (Default for KEY is
163         IDENTITY).
164 RETURN: The goal node.
165 COMPLEXITY:  Time: O(|V|+|E|), Space: O(|V|+|E|)
166 "
167   (depth-first-search-if graph
168                            root
169                            (lambda (node) (funcall test node goal))
170                            :key key))
171
172
173 (defun depth-first-search-if (graph root predicate &key key)
174     "
175 DO:     Implement the Depth First Search algorithm on the given
176         GRAPH, starting from the ROOT node, until the PREDICATE
177         applied on the value of the KEY function applied to the node
178         returns true.  (Default for KEY is IDENTITY).
179 RETURN: The goal node.
180 COMPLEXITY:  Time: O(|V|+|E|), Space: O(|V|+|E|)
181 "
182   (let ((key (or key (function identity)))
183         (q     '())
184         (marks (make-hash-table)))
185     (flet ((stop (node) (funcall predicate (funcall key node)))
186            (mark (node) (setf (gethash node marks) t))
187            (markedp (node) (gethash node marks)))
188       (declare (inline stop mark markedp))
189       (push root q)
190       (mark root)
191       (loop :while q :do
192          (let ((v (pop q)))
193            (when (stop v)
194              (return-from depth-first-search-if v))
195            (loop :for w :in (graph-adjacency-list graph v) :do
196               (unless (markedp w)
197                 (push w q)
198                 (mark w))))))))
199
200
201
202
203
204 (defstruct (node (:constructor make-node))
205   label index lowlink)
206
207 (defun tarjan-strongly-connected-components (graph)
208   "
209 DO:     Implement Tarjan's Strongly Connected Components Algorithm.
210 RETURN: A set of strongly connected components = sets of nodes.
211 "
212   ;; Uses the NODE structure, and applies GRAPH-NODES and
213   ;; GRAPH-ADJACENCY-LIST to GRAPH to get the list of vertices, and
214   ;; the adjacency list of a vertex of the GRAPH.
215   (let ((index 0)
216         (nodes (make-dictionary 'adaptating-dictionary
217                                 :contents (mapcan (lambda (label)
218                                                     (list label (make-node :label label)))
219                                                   (graph-nodes graph))))
220         (stack  '())
221         (strongly-connected-components '()))
222     (labels ((node (label) (dictionary-get nodes label))
223              (strong-connect (node)
224                ;; Set the depth index for v to the smallest unused index
225                (setf (node-lowlink node) (setf (node-index node) index))
226                (incf index)
227                (push node stack)
228                ;; Consider successors of v
229                (loop
230                   :for successor-label :in (graph-adjacency-list graph (node-label node))
231                   :for successor = (node successor-label)
232                   :do (cond
233                         ((null (node-index successor))
234                          ;; Successor w has not yet been visited; recurse on it
235                          (strong-connect successor)
236                          (setf (node-lowlink node) (min (node-lowlink node) (node-lowlink successor))))
237                         ((member successor stack)
238                          ;; Successor w is in stack S and hence in the current SCC
239                          (setf (node-lowlink node) (min (node-lowlink node) (node-index successor))))))
240                ;; If v is a root node, pop the stack and generate an SCC
241                (when (= (node-lowlink node) (node-index node))
242                  (push (loop
243                           :for successor = (pop stack)
244                           :collect (node-label successor)
245                           :until (eql successor node))
246                        strongly-connected-components))))
247       (dictionary-map (lambda (label node)
248                         (declare (ignore label))
249                         (unless (node-index node)
250                           (strong-connect node)))
251                       nodes)
252       strongly-connected-components)))
253
254
255
256 #-(and)"
257 algorithm tarjan is
258   input: graph G = (V, E)
259   output: set of strongly connected components (sets of vertices)
260
261   index := 0
262   S := empty
263   for each v in V do
264     if (v.index is undefined)
265       strongconnect(v)
266     end if
267   repeat
268
269   function strongconnect(v)
270     // Set the depth index for v to the smallest unused index
271     v.index := index
272     v.lowlink := index
273     index := index + 1
274     S.push(v)
275
276   // Consider successors of v
277     for each (v, w) in E do
278       if (w.index is undefined) then
279         // Successor w has not yet been visited; recurse on it
280         strongconnect(w)
281         v.lowlink := min(v.lowlink, w.lowlink)
282       else if (w is in S) then
283         // Successor w is in stack S and hence in the current SCC
284         v.lowlink := min(v.lowlink, w.index)
285       end if
286     end for
287
288     // If v is a root node, pop the stack and generate an SCC
289     if (v.lowlink = v.index) then
290       start a new strongly connected component
291       repeat
292         w := S.pop()
293         add w to current strongly connected component
294       until (w = v)
295       output the current strongly connected component
296     end if
297   end function
298
299 "
300
301
302
303 (defun condensate (graph)
304   "
305 DO:      Given a GRAPH, find the strongly connected components in the
306          graph, and replace them with single nodes to obtain a DAG.
307 RETURN:  The DAG, and an a-list mapping new names (uninterned symbols)
308          to strongly connected subgraphs.
309 "
310   ;; (condensate graph) --> dag; alist of (new-name . strongly-connected-component)
311   ;; The DAG and the STRONGLY-CONNECTED-COMPONENT are given as list of edges (from to).
312   (let* ((components (tarjan-strongly-connected-components graph))
313          (old-new    (make-hash-table))
314          (new-old    '()))
315     (values
316      (nconc
317       (mapcan (lambda (from)
318                 (mapcar (lambda (to)
319                           (list (gethash from old-new from)
320                                 (gethash to   old-new to)))
321                         (graph-adjacency-list graph from)))
322               (mapcar (lambda (component)
323                         (if (null (rest component))
324                             (first component)
325                             (let ((new (make-symbol (format nil "~{~A~^/~}" component))))
326                               (push (cons new component) new-old)
327                               (dolist (old component)
328                                 (setf (gethash old old-new) new))
329                               new)))
330                       components))
331       (delete-duplicates
332        (mapcan (lambda (entry)
333                  (let ((component (car entry)))
334                    (mapcan (lambda (from)
335                              (mapcan (lambda (to)
336                                        (let ((new-to (gethash to old-new to)))
337                                          (if (eql new-to component)
338                                              '()
339                                              (list (list component new-to)))))
340                                      (graph-adjacency-list graph from)))
341                            (cdr entry))))
342                new-old)
343        :test (function equal)))
344      (mapcar (lambda (entry)
345                (let ((component (car entry)))
346                  (list component
347                        (cdr entry)
348                        (mapcan (lambda (from)
349                                  (mapcar (lambda (to) (list from to))
350                                          (graph-adjacency-list graph from)))
351                                (cdr entry)))))
352              new-old))))
353
354 #-(and)
355 (defun compute-closure (fun set)
356   "
357 FUN:     set --> P(set)
358           x |--> { y }
359 RETURN:  The closure of fun on the set.
360 NOTE:    Not a lisp closure!
361 EXAMPLE: (compute-closure (lambda (x) (list (mod (* x 2) 5))) '(1)) --> (2 4 3 1)
362 NOTE:    This version avoids calling FUN twice with the same argument.
363 "
364   (loop
365      :for follows = (delete-duplicates (mapcan fun set))
366      :then (delete-duplicates (append (mapcan fun newbies) follows))
367      :for newbies = (set-difference follows set)
368      :while newbies
369      :do (setf set (append newbies set))
370      :finally (return set)))
371
372
373 (defun topological-sort (nodes lessp)
374   "
375 RETURN: A list of NODES sorted topologically according to 
376         the partial order function LESSP.
377         If there are cycles (discounting reflexivity), 
378         then the list returned won't contain all the NODES.
379 "
380   (loop
381      :with sorted = '()
382      :with incoming = (map 'vector (lambda (to)
383                                      (loop
384                                         :for from :in nodes
385                                         :when (and (not (eq from to))
386                                                    (funcall lessp from to))
387                                         :sum 1))
388                            nodes)
389      :with q = (loop
390                   :for node :in nodes
391                   :for inco :across incoming
392                   :when (zerop inco)
393                   :collect node) 
394      :while q
395      :do (let ((n (pop q)))
396            (push n sorted)
397            (loop
398               :for m :in nodes
399               :for i :from 0
400               :do (when (and (and (not (eq n m))
401                                   (funcall lessp n m))
402                              (zerop (decf (aref incoming i))))
403                     (push m q))))
404      :finally (return (nreverse sorted))))
405
406
407 (defun solve-constraints (edges propagate)
408   "
409 DO:         Calls PROPAGATE on each edge until PROPAGATE returns NIL
410             for all arcs.
411 EDGES:      A list of edges (from to).
412             The nodes FROM and EDGE must be comparable with EQL.
413 PROPAGATE:  A function taking the nodes FROM and TO of an edge as argument,
414             and returning whether changes occured.
415 "
416   (let ((graph (make-graph edges)))
417     (multiple-value-bind (dag-edges components) (condensate graph)
418       (let ((plan (topological-sort
419                    (delete-duplicates (mapcan (function copy-list) dag-edges))
420                    (lambda (a b) (member (list a b) dag-edges :test (function equal))))))
421         (flet ((close-constraint-cycle (component)
422                  (loop
423                     :with edges = (third component)
424                     :for changed = nil
425                     :do (loop
426                            :for (from to) :in edges
427                            :do (when (funcall propagate from to)
428                                  (setf changed t)))
429                     :while changed)))
430           (dolist (from plan (values))
431             (let ((component (assoc from components)))
432               (if component
433                   (close-constraint-cycle component)
434                   (dolist (to (graph-adjacency-list graph from))
435                     (funcall propagate from to))))))))))
436
437
438 ;;;; THE END ;;;;