;;;; -*- Mode: Lisp; Syntax: Common-Lisp -*- ;;;; Code from Paradigms of AI Programming ;;;; Copyright (c) 1991 Peter Norvig ;;;; File waltz.lisp: Line-labeling using Waltz filtering. (defstruct diagram "A diagram is a list of vertexes." vertexes) (defstruct (vertex (:print-function print-vertex)) (name nil :type atom) (type 'L :type (member L Y W T)) (neighbors nil :type list) ; of vertex (labelings nil :type list)) ; of lists of (member + - L R))))) (defun ambiguous-vertex-p (vertex) "A vertex is ambiguous if it has more than one labeling." (> (number-of-labelings vertex) 1)) (defun number-of-labelings (vertex) (length (vertex-labelings vertex))) (defun impossible-vertex-p (vertex) "A vertex is impossible if it has no labeling." (null (vertex-labelings vertex))) (defun impossible-diagram-p (diagram) "An impossible diagram is one with an impossible vertex." (some #'impossible-vertex-p (diagram-vertexes diagram))) (defun possible-labelings (vertex-type) "The list of possible labelings for a given vertex type." ;; In these labelings, R means an arrow pointing away from ;; the vertex, L means an arrow pointing towards it. (case vertex-type ((L) '((R L) (L R) (+ R) (L +) (- L) (R -))) ((Y) '((+ + +) (- - -) (L R -) (- L R) (R - L))) ((T) '((R L +) (R L -) (R L L) (R L R))) ((W) '((L R +) (- - +) (+ + -))))) (defun print-labelings (diagram) "Label the diagram by propagating constraints and then searching for solutions if necessary. Print results." (show-diagram diagram "~&The initial diagram is:") (every #'propagate-constraints (diagram-vertexes diagram)) (show-diagram diagram "~2&After constraint propagation the diagram is:") (let* ((solutions (if (impossible-diagram-p diagram) nil (search-solutions diagram))) (n (length solutions))) (unless (= n 1) (format t "~2&There are ~r solution~:p:" n) (mapc #'show-diagram solutions))) (values)) (defun propagate-constraints (vertex) "Reduce the labelings on vertex by considering neighbors. If we can reduce, propagate the constraints to each neighbor." ;; Return nil only when the constraints lead to an impossibility (let ((old-num (number-of-labelings vertex))) (setf (vertex-labelings vertex) (consistent-labelings vertex)) (unless (impossible-vertex-p vertex) (when (< (number-of-labelings vertex) old-num) (every #'propagate-constraints (vertex-neighbors vertex))) t))) (defun consistent-labelings (vertex) "Return the set of labelings that are consistent with neighbors." (let ((neighbor-labels (mapcar #'(lambda (neighbor) (labels-for neighbor vertex)) (vertex-neighbors vertex)))) ;; Eliminate labelings that don't have all lines consistent ;; with the corresponding line's label from the neighbor. ;; Account for the L-R mismatch with reverse-label. (find-all-if #'(lambda (labeling) (every #'member (mapcar #'reverse-label labeling) neighbor-labels)) (vertex-labelings vertex)))) (defun search-solutions (diagram) "Try all labelings for one ambiguous vertex, and propagate." ;; If there is no ambiguous vertex, return the diagram. ;; If there is one, make copies of the diagram trying each of ;; the possible labelings. Propagate constraints and append ;; all the solutions together. (let ((v (find-if #'ambiguous-vertex-p (diagram-vertexes diagram)))) (if (null v) (list diagram) (mapcan #'(lambda (v-labeling) (let* ((diagram2 (make-copy-diagram diagram)) (v2 (find-vertex (vertex-name v) diagram2))) (setf (vertex-labelings v2) (list v-labeling)) (if (propagate-constraints v2) (search-solutions diagram2) nil))) (vertex-labelings v))))) (defun labels-for (vertex from) "Return all the labels for the line going to vertex." (let ((pos (position from (vertex-neighbors vertex)))) (mapcar #'(lambda (labeling) (nth pos labeling)) (vertex-labelings vertex)))) (defun reverse-label (label) "Account for the fact that one vertex's right is another's left." (case label (L 'R) (R 'L) (otherwise label))) (defun find-vertex (name diagram) "Find the vertex in the given diagram with the given name." (find name (diagram-vertexes diagram) :key #'vertex-name)) (defun print-vertex (vertex stream depth) "Print a vertex in the short form." (declare (ignore depth)) (format stream "~a/~d" (vertex-name vertex) (number-of-labelings vertex)) vertex) (defun show-vertex (vertex &optional (stream t)) "Print a vertex in a long form, on a new line." (format stream "~& ~a ~d:" vertex (vertex-type vertex)) (mapc #'(lambda (neighbor labels) (format stream " ~a~a=[~{~a~}]" (vertex-name vertex) (vertex-name neighbor) labels)) (vertex-neighbors vertex) (matrix-transpose (vertex-labelings vertex))) (values)) (defun show-diagram (diagram &optional (title "~2&Diagram:") (stream t)) "Print a diagram in a long form. Include a title." (format stream title) (mapc #'show-vertex (diagram-vertexes diagram)) (let ((n (reduce #'* (mapcar #'number-of-labelings (diagram-vertexes diagram))))) (when (> n 1) (format stream "~&For ~:d interpretation~:p." n)) (values))) (defun matrix-transpose (matrix) "Turn a matrix on its side." (if matrix (apply #'mapcar #'list matrix))) (let ((diagrams (make-hash-table))) (defun diagram (name) "Get a fresh copy of the diagram with this name." (make-copy-diagram (gethash name diagrams))) (defun put-diagram (name diagram) "Store a diagram under a name." (setf (gethash name diagrams) diagram) name)) (defun construct-diagram (vertex-descriptors) "Build a new diagram from a set of vertex descriptor." (let ((diagram (make-diagram))) ;; Put in the vertexes (setf (diagram-vertexes diagram) (mapcar #'construct-vertex vertex-descriptors)) ;; Put in the neighbors for each vertex (dolist (v-d vertex-descriptors) (setf (vertex-neighbors (find-vertex (first v-d) diagram)) (mapcar #'(lambda (neighbor) (find-vertex neighbor diagram)) (v-d-neighbors v-d)))) diagram)) (defun construct-vertex (vertex-descriptor) "Build the vertex corresponding to the descriptor." ;; Descriptors are like: (x L y z) (make-vertex :name (first vertex-descriptor) :type (second vertex-descriptor) :labelings (possible-labelings (second vertex-descriptor)))) (defun v-d-neighbors (vertex-descriptor) "The neighboring vertex names in a vertex descriptor." (rest (rest vertex-descriptor))) (defun make-copy-diagram (diagram) "Make a copy of a diagram, preserving connectivity." (let* ((new (make-diagram :vertexes (mapcar #'copy-vertex (diagram-vertexes diagram))))) ;; Put in the neighbors for each vertex (dolist (v (diagram-vertexes new)) (setf (vertex-neighbors v) (mapcar #'(lambda (neighbor) (find-vertex (vertex-name neighbor) new)) (vertex-neighbors v)))) new)) (defun ground (diagram vertex-a vertex-b) "Attach the line between the two vertexes to the ground. That is, label the line with a -" (let* ((A (find-vertex vertex-a diagram)) (B (find-vertex vertex-b diagram)) (i (position B (vertex-neighbors A)))) (assert (not (null i))) (setf (vertex-labelings A) (find-all-if #'(lambda (l) (eq (nth i l) '-)) (vertex-labelings A))) diagram)) (defun find-labelings (diagram) "Return a list of all consistent labelings of the diagram." (every #'propagate-constraints (diagram-vertexes diagram)) (search-solutions diagram)) (defmacro defdiagram (name &rest vertex-descriptors) "Define a diagram. A copy can be gotten by (diagram name)." `(put-diagram ',name (construct-diagram (check-diagram ',vertex-descriptors)))) (defun check-diagram (vertex-descriptors) "Check if the diagram description appears consistent." (let ((errors 0)) (dolist (v-d vertex-descriptors) ;; v-d is like: (a Y b c d) (let ((A (first v-d)) (v-type (second v-d))) ;; Check that the number of neighbors is right for ;; the vertex type (and that the vertex type is legal) (when (/= (length (v-d-neighbors v-d)) (case v-type ((W Y T) 3) ((L) 2) (t -1))) (warn "Illegal type/neighbor combo: ~a" v-d) (incf errors)) ;; Check that each neighbor B is connected to ;; this vertex, A, exactly once (dolist (B (v-d-neighbors v-d)) (when (/= 1 (count-if #'(lambda (v-d2) (and (eql (first v-d2) B) (member A (v-d-neighbors v-d2)))) vertex-descriptors)) (warn "Inconsistent vertex: ~a-~a" A B) (incf errors))))) (when (> errors 0) (error "Inconsistent diagram. ~d total error~:p." errors))) vertex-descriptors)