From e9679801fed32c3a67fee349ce345b784ec9f386 Mon Sep 17 00:00:00 2001
From: "Pascal J. Bourguignon"
Date: Thu, 9 Feb 2012 00:29:52 +0100
Subject: [PATCH] Moved in constraints.lisp from rdp.
---
common-lisp/cesarum/constraints.lisp | 440 +++++++++++++++++++++++++++++++++++
1 file changed, 440 insertions(+)
create mode 100644 common-lisp/cesarum/constraints.lisp
diff --git a/common-lisp/cesarum/constraints.lisp b/common-lisp/cesarum/constraints.lisp
new file mode 100644
index 0000000..7720861
--- /dev/null
+++ b/common-lisp/cesarum/constraints.lisp
@@ -0,0 +1,440 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE: constraints.lisp
+;;;;LANGUAGE: Common-Lisp
+;;;;SYSTEM: Common-Lisp
+;;;;USER-INTERFACE: NONE
+;;;;DESCRIPTION
+;;;;
+;;;; A little constraint solver.
+;;;;
+;;;; Given a graph of nodes, and a propagate function that
+;;;; propagates constraints from node to nodes, the solver
+;;;; propagates the constraints until no change occurs.
+;;;;
+;;;; It computes the strongly connected components, and performs a
+;;;; topological sort of the condensed graph to minimalize the
+;;;; number of calls to propagate.
+;;;;
+;;;;
+;;;;AUTHORS
+;;;; Pascal J. Bourguignon
+;;;;MODIFICATIONS
+;;;; 2011-07-31 Created.
+;;;;BUGS
+;;;;LEGAL
+;;;; GPL
+;;;;
+;;;; Copyright Pascal J. Bourguignon 2011 - 2011
+;;;;
+;;;; This program is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU General Public License
+;;;; as published by the Free Software Foundation; either version
+;;;; 2 of the License, or (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be
+;;;; useful, but WITHOUT ANY WARRANTY; without even the implied
+;;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;;; PURPOSE. See the GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public
+;;;; License along with this program; if not, write to the Free
+;;;; Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+;;;;**************************************************************************
+
+(defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.CONSTRAINTS"
+ (:use "COMMON-LISP"
+ "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.DICTIONARY"
+ "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY")
+ (:export "SOLVE-CONSTRAINTS")
+ (:documentation "
+
+"))
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.CONSTRAINTS")
+
+
+
+;;;
+;;; Tarjan's Strongly Connected Components Algorithm.
+;;;
+
+(defun make-graph (edges)
+ ;; We represent the graph as a dictionnary mapping FROM nodes to
+ ;; their adjacency list.
+ (loop
+ :with graph = (make-dictionary 'adaptating-dictionary)
+ :for (from to) :in edges
+ :do (progn
+ (push to (dictionary-get graph from '()))
+ (setf (dictionary-get graph to) (dictionary-get graph to '())))
+ :finally (return graph)))
+
+(defun graph-nodes (graph)
+ "RETURN: The list of nodes in the GRAPH"
+ (let ((nodes '()))
+ (dictionary-map (lambda (k v) (declare (ignore v)) (push k nodes)) graph)
+ nodes))
+
+(defun graph-adjacency-list (graph node)
+ "RETURN: The list of successors of NODE in the GRAPH."
+ (dictionary-get graph node))
+
+
+
+
+(defparameter *germany*
+ (make-graph (mapcan (lambda (edge) (list edge (reverse edge)))
+ '((frankfurt mannheim)
+ (frankfurt wuerzburg)
+ (frankfurt kassel)
+ (stuttgart nuemberg)
+ (mannheim karlsruhe)
+ (wuerzburg erfurt)
+ (wuerzburg nuemberg)
+ (kassel muenchen)
+ (karlsruhe augsburg)
+ (augsburg muenchen)
+ (nuemberg muenchen)))))
+
+
+
+(defun breadth-first-search (graph root goal &key (test 'eql) key)
+ "
+DO: Implement the Breadth First Search algorithm on the given
+ GRAPH, starting from the ROOT node, until the GOAL is reached.
+ The GOAL is compared with the TEST function to the value of
+ the KEY function applied to the nodes. (Default for KEY is
+ IDENTITY).
+RETURN: The goal node.
+COMPLEXITY: Time: O(|V|+|E|), Space: O(|V|)
+"
+ (breadth-first-search-if graph
+ root
+ (lambda (node) (funcall test node goal))
+ :key key))
+
+
+(defun breadth-first-search-if (graph root predicate &key key)
+ "
+DO: Implement the Breadth First Search algorithm on the given
+ GRAPH, starting from the ROOT node, until the PREDICATE
+ applied on the value of the KEY function applied to the node
+ returns true. (Default for KEY is IDENTITY).
+RETURN: The goal node.
+COMPLEXITY: Time: O(|V|+|E|), Space: O(|V|)
+"
+ (let ((key (or key (function identity)))
+ (head '())
+ (tail '())
+ (marks (make-hash-table)))
+ (flet ((enqueue (node) (if (null head)
+ (setf head (list node)
+ tail head)
+ (setf (cdr tail) (list node)
+ tail (cdr tail))))
+ (dequeue () (cond
+ ((null head) nil)
+ ((eql head tail) (prog1 (car head)
+ (setf head nil
+ tail nil)))
+ (t (pop head))))
+ (empty () (null head))
+ (stop (node) (funcall predicate (funcall key node)))
+ (mark (node) (setf (gethash node marks) t))
+ (markedp (node) (gethash node marks)))
+ (declare (inline enqueue dequeue empty stop mark markedp))
+ (enqueue root)
+ (mark root)
+ (loop :until (empty) :do
+ (let ((v (dequeue)))
+ (when (stop v)
+ (return-from breadth-first-search-if v))
+ (loop :for w :in (graph-adjacency-list graph v) :do
+ (unless (markedp w)
+ (enqueue w)
+ (mark w))))))))
+
+
+(defun depth-first-search (graph root goal &key (test 'eql) key)
+ "
+DO: Implement the Depth First Search algorithm on the given
+ GRAPH, starting from the ROOT node, until the GOAL is reached.
+ The GOAL is compared with the TEST function to the value of
+ the KEY function applied to the nodes. (Default for KEY is
+ IDENTITY).
+RETURN: The goal node.
+COMPLEXITY: Time: O(|V|+|E|), Space: O(|V|+|E|)
+"
+ (depth-first-search-if graph
+ root
+ (lambda (node) (funcall test node goal))
+ :key key))
+
+
+(defun depth-first-search-if (graph root predicate &key key)
+ "
+DO: Implement the Depth First Search algorithm on the given
+ GRAPH, starting from the ROOT node, until the PREDICATE
+ applied on the value of the KEY function applied to the node
+ returns true. (Default for KEY is IDENTITY).
+RETURN: The goal node.
+COMPLEXITY: Time: O(|V|+|E|), Space: O(|V|+|E|)
+"
+ (let ((key (or key (function identity)))
+ (q '())
+ (marks (make-hash-table)))
+ (flet ((stop (node) (funcall predicate (funcall key node)))
+ (mark (node) (setf (gethash node marks) t))
+ (markedp (node) (gethash node marks)))
+ (declare (inline stop mark markedp))
+ (push root q)
+ (mark root)
+ (loop :while q :do
+ (let ((v (pop q)))
+ (when (stop v)
+ (return-from depth-first-search-if v))
+ (loop :for w :in (graph-adjacency-list graph v) :do
+ (unless (markedp w)
+ (push w q)
+ (mark w))))))))
+
+
+
+
+
+(defstruct (node (:constructor make-node))
+ label index lowlink)
+
+(defun tarjan-strongly-connected-components (graph)
+ "
+DO: Implement Tarjan's Strongly Connected Components Algorithm.
+RETURN: A set of strongly connected components = sets of nodes.
+"
+ ;; Uses the NODE structure, and applies GRAPH-NODES and
+ ;; GRAPH-ADJACENCY-LIST to GRAPH to get the list of vertices, and
+ ;; the adjacency list of a vertex of the GRAPH.
+ (let ((index 0)
+ (nodes (make-dictionary 'adaptating-dictionary
+ :contents (mapcan (lambda (label)
+ (list label (make-node :label label)))
+ (graph-nodes graph))))
+ (stack '())
+ (strongly-connected-components '()))
+ (labels ((node (label) (dictionary-get nodes label))
+ (strong-connect (node)
+ ;; Set the depth index for v to the smallest unused index
+ (setf (node-lowlink node) (setf (node-index node) index))
+ (incf index)
+ (push node stack)
+ ;; Consider successors of v
+ (loop
+ :for successor-label :in (graph-adjacency-list graph (node-label node))
+ :for successor = (node successor-label)
+ :do (cond
+ ((null (node-index successor))
+ ;; Successor w has not yet been visited; recurse on it
+ (strong-connect successor)
+ (setf (node-lowlink node) (min (node-lowlink node) (node-lowlink successor))))
+ ((member successor stack)
+ ;; Successor w is in stack S and hence in the current SCC
+ (setf (node-lowlink node) (min (node-lowlink node) (node-index successor))))))
+ ;; If v is a root node, pop the stack and generate an SCC
+ (when (= (node-lowlink node) (node-index node))
+ (push (loop
+ :for successor = (pop stack)
+ :collect (node-label successor)
+ :until (eql successor node))
+ strongly-connected-components))))
+ (dictionary-map (lambda (label node)
+ (declare (ignore label))
+ (unless (node-index node)
+ (strong-connect node)))
+ nodes)
+ strongly-connected-components)))
+
+
+
+#-(and)"
+algorithm tarjan is
+ input: graph G = (V, E)
+ output: set of strongly connected components (sets of vertices)
+
+ index := 0
+ S := empty
+ for each v in V do
+ if (v.index is undefined)
+ strongconnect(v)
+ end if
+ repeat
+
+ function strongconnect(v)
+ // Set the depth index for v to the smallest unused index
+ v.index := index
+ v.lowlink := index
+ index := index + 1
+ S.push(v)
+
+ // Consider successors of v
+ for each (v, w) in E do
+ if (w.index is undefined) then
+ // Successor w has not yet been visited; recurse on it
+ strongconnect(w)
+ v.lowlink := min(v.lowlink, w.lowlink)
+ else if (w is in S) then
+ // Successor w is in stack S and hence in the current SCC
+ v.lowlink := min(v.lowlink, w.index)
+ end if
+ end for
+
+ // If v is a root node, pop the stack and generate an SCC
+ if (v.lowlink = v.index) then
+ start a new strongly connected component
+ repeat
+ w := S.pop()
+ add w to current strongly connected component
+ until (w = v)
+ output the current strongly connected component
+ end if
+ end function
+
+"
+
+
+
+(defun condensate (graph)
+ "
+DO: Given a GRAPH, find the strongly connected components in the
+ graph, and replace them with single nodes to obtain a DAG.
+RETURN: The DAG, and an a-list mapping new names (uninterned symbols)
+ to strongly connected subgraphs.
+"
+ ;; (condensate graph) --> dag; alist of (new-name . strongly-connected-component)
+ ;; The DAG and the STRONGLY-CONNECTED-COMPONENT are given as list of edges (from to).
+ (let* ((components (tarjan-strongly-connected-components graph))
+ (old-new (make-hash-table))
+ (new-old '()))
+ (values
+ (nconc
+ (mapcan (lambda (from)
+ (mapcar (lambda (to)
+ (list (gethash from old-new from)
+ (gethash to old-new to)))
+ (graph-adjacency-list graph from)))
+ (mapcar (lambda (component)
+ (if (null (rest component))
+ (first component)
+ (let ((new (make-symbol (format nil "~{~A~^/~}" component))))
+ (push (cons new component) new-old)
+ (dolist (old component)
+ (setf (gethash old old-new) new))
+ new)))
+ components))
+ (delete-duplicates
+ (mapcan (lambda (entry)
+ (let ((component (car entry)))
+ (mapcan (lambda (from)
+ (mapcan (lambda (to)
+ (let ((new-to (gethash to old-new to)))
+ (if (eql new-to component)
+ '()
+ (list (list component new-to)))))
+ (graph-adjacency-list graph from)))
+ (cdr entry))))
+ new-old)
+ :test (function equal)))
+ (mapcar (lambda (entry)
+ (let ((component (car entry)))
+ (list component
+ (cdr entry)
+ (mapcan (lambda (from)
+ (mapcar (lambda (to) (list from to))
+ (graph-adjacency-list graph from)))
+ (cdr entry)))))
+ new-old))))
+
+#-(and)
+(defun compute-closure (fun set)
+ "
+FUN: set --> P(set)
+ x |--> { y }
+RETURN: The closure of fun on the set.
+NOTE: Not a lisp closure!
+EXAMPLE: (compute-closure (lambda (x) (list (mod (* x 2) 5))) '(1)) --> (2 4 3 1)
+NOTE: This version avoids calling FUN twice with the same argument.
+"
+ (loop
+ :for follows = (delete-duplicates (mapcan fun set))
+ :then (delete-duplicates (append (mapcan fun newbies) follows))
+ :for newbies = (set-difference follows set)
+ :while newbies
+ :do (setf set (append newbies set))
+ :finally (return set)))
+
+
+(defun topological-sort (nodes lessp)
+ "
+RETURN: A list of NODES sorted topologically according to
+ the partial order function LESSP.
+ If there are cycles (discounting reflexivity),
+ then the list returned won't contain all the NODES.
+"
+ (loop
+ :with sorted = '()
+ :with incoming = (map 'vector (lambda (to)
+ (loop
+ :for from :in nodes
+ :when (and (not (eq from to))
+ (funcall lessp from to))
+ :sum 1))
+ nodes)
+ :with q = (loop
+ :for node :in nodes
+ :for inco :across incoming
+ :when (zerop inco)
+ :collect node)
+ :while q
+ :do (let ((n (pop q)))
+ (push n sorted)
+ (loop
+ :for m :in nodes
+ :for i :from 0
+ :do (when (and (and (not (eq n m))
+ (funcall lessp n m))
+ (zerop (decf (aref incoming i))))
+ (push m q))))
+ :finally (return (nreverse sorted))))
+
+
+(defun solve-constraints (edges propagate)
+ "
+DO: Calls PROPAGATE on each edge until PROPAGATE returns NIL
+ for all arcs.
+EDGES: A list of edges (from to).
+ The nodes FROM and EDGE must be comparable with EQL.
+PROPAGATE: A function taking the nodes FROM and TO of an edge as argument,
+ and returning whether changes occured.
+"
+ (let ((graph (make-graph edges)))
+ (multiple-value-bind (dag-edges components) (condensate graph)
+ (let ((plan (topological-sort
+ (delete-duplicates (mapcan (function copy-list) dag-edges))
+ (lambda (a b) (member (list a b) dag-edges :test (function equal))))))
+ (flet ((close-constraint-cycle (component)
+ (loop
+ :with edges = (third component)
+ :for changed = nil
+ :do (loop
+ :for (from to) :in edges
+ :do (when (funcall propagate from to)
+ (setf changed t)))
+ :while changed)))
+ (dolist (from plan (values))
+ (let ((component (assoc from components)))
+ (if component
+ (close-constraint-cycle component)
+ (dolist (to (graph-adjacency-list graph from))
+ (funcall propagate from to))))))))))
+
+
+;;;; THE END ;;;;
--
2.1.4