Implemented PATH.

Pascal J. Bourguignon [2012-01-31 21:30]
Implemented PATH.
Filename
p81.lisp
diff --git a/p81.lisp b/p81.lisp
new file mode 100644
index 0000000..d8959c3
--- /dev/null
+++ b/p81.lisp
@@ -0,0 +1,60 @@
+#-(and) "
+P81 (**) Path from one node to another one
+
+    Write a predicate path(G,A,B,P) to find an acyclic path P from
+    node A to node b in the graph G. The predicate should return all
+    paths via backtracking.
+"
+
+(load "p80.lisp")
+
+
+(defmethod path ((g graph) src dst)
+  "Return a list of all the paths going from SRC to DST.
+We don't include paths containing cycles, since there would be an
+infinite number of them… "
+  (labels ((walk (path)
+             (mapcan (lambda (arc)
+                       (cond
+                         ((eql (arc-to arc) dst)
+                          (list (cons dst path)))
+                         ((member (arc-to arc) path) ; cycle
+                          '())
+                         (t
+                          (walk (cons (arc-to arc) path)))))
+                     (arcs-from-node g (first path)))))
+    (mapcar 'reverse (walk (list src)))))
+
+
+;; (dolist (test '(
+;;                 (a c (a b c))
+;;                 (a c ((a b) (b c)))
+;;                 (b g ((b c) (f c) (g h) d (f b) (k f) (h g)))
+;;                 (s u ((s r) t (u r) (s u) (u s) (v u)))
+;;                 (p m ((p q :weight 9) (m q :weight 7) k (p m :weight 5))))
+;;          (terpri))
+;;   (print (list test (path (make-adjacency-list-graph (third test)) (first test) (second test)))))
+;;
+;; ((A C (A B C)) NIL)
+;; ((A C ((A B) (B C))) ((A B C)))
+;; ((B G ((B C) (F C) (G H) D (F B) (K F) (H G))) NIL)
+;; ((S U ((S R) T (U R) (S U) (U S) (V U))) ((S U)))
+;; ((P M ((P Q :WEIGHT 9) (M Q :WEIGHT 7) K (P M :WEIGHT 5))) ((P M)))
+;; NIL
+;;
+;;
+;; (dolist (test '((a c ((a b) (b c)))
+;;                 (b g ((b c) (f c) (g h) (f b) (k f) (h g)))
+;;                 (s u ((s r) (u r) (s u) (u s) (v u)))
+;;                 (p m ((p q :weight 9) (m q :weight 7) (p m :weight 5))))
+;;          (terpri))
+;;   (print (list test (path (make-edge-graph (third test)) (first test) (second test)))))
+;;
+;;
+;; ((A C ((A B) (B C))) ((A B C)))
+;; ((B G ((B C) (F C) (G H) (F B) (K F) (H G))) NIL)
+;; ((S U ((S R) (U R) (S U) (U S) (V U))) ((S U) (S U) (S R U)))
+;; ((P M ((P Q :WEIGHT 9) (M Q :WEIGHT 7) (P M :WEIGHT 5))) ((P M) (P Q M)))
+;; NIL
+
+;;;; THE END ;;;;
ViewGit