From ae87aded751568bd3d88afed22b6e5f1ef569f75 Mon Sep 17 00:00:00 2001
From: "Pascal J. Bourguignon"
Date: Wed, 12 Jan 2011 16:34:12 +0100
Subject: [PATCH 1/4] Added grammar parameter to functions generating function
names so that different grammars with nonterminals named the same don't
collide.

rdp.lisp  40 +++++++++++++++++++++++
1 file changed, 23 insertions(+), 17 deletions()
diff git a/rdp.lisp b/rdp.lisp
index a4c539c..8157d5f 100644
 a/rdp.lisp
+++ b/rdp.lisp
@@ 14,6 +14,10 @@
;;;;AUTHORS
;;;; Pascal Bourguignon
;;;;MODIFICATIONS
+;;;; 20110112 Added grammar parameter to functions
+;;;; generating function names so that different
+;;;; grammars with nonterminals named the same
+;;;; don't collide.
;;;; 20060909 Created
;;;;BUGS
;;;;
@@ 32,7 +36,7 @@
;;;;LEGAL
;;;; GPL
;;;;
;;;; Copyright Pascal Bourguignon 2006  2006
+;;;; Copyright Pascal Bourguignon 2006  2011
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU General Public License
@@ 181,7 +185,7 @@ TODO: We could also flatten sequences without action, or even sequences with
(computeallnonterminals ,g)
,g))))
 ,(genboilerplate targetlanguage)
+ ,(genboilerplate targetlanguage grammar)
,(generatescanner targetlanguage grammar)
,@(mapcar (lambda (nonterminal)
(generatentparser targetlanguage grammar nonterminal))
@@ 199,7 +203,7 @@ TODO: We could also flatten sequences without action, or even sequences with
(computeallterminals grammar)
(computeallnonterminals grammar)
(eval `(progn
 ,(genboilerplate targetlanguage)
+ ,(genboilerplate targetlanguage grammar)
,(generatescanner targetlanguage grammar)
,@(mapcar (lambda (nonterminal)
(generatentparser targetlanguage grammar nonterminal))
@@ 380,7 +384,8 @@ in the grammar."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generator  LISP
(defmethod genboilerplate ((target (eql :lisp)))
+(defmethod genboilerplate ((target (eql :lisp)) (grammar grammar))
+ (declare (ignore grammar))
`(progn
(defstruct scanner
@@ 409,8 +414,8 @@ in the grammar."
(format nil "^[~{~C~}]\\+" '(#\space #\newline #\tab)))))
(defmethod genscannerfunctionname ((target (eql :lisp)) grammarname)
 (intern (format nil "SCAN~A" grammarname)))
+(defmethod genscannerfunctionname ((target (eql :lisp)) (grammar grammar))
+ (intern (format nil "~:@(SCAN~A~)" (grammarname grammar))))
(defmethod generatescanner ((target (eql :lisp)) grammar)
#clisp (error "This generator uses the clisp specific package REGEXP
@@ 428,7 +433,7 @@ Please, update it use whatever regexp package is available in ~A"
(grammarallterminals grammar))
(function >) :key (function length))))))
`(defun
 ,(genscannerfunctionname target (grammarname grammar))
+ ,(genscannerfunctionname target grammar)
(scanner)
(let ((match (regexp:match *spaces*
(scannersource scanner)
@@ 462,8 +467,8 @@ Please, update it use whatever regexp package is available in ~A"
(scannerposition scanner))))))))
(defmethod genparsefunctionname ((target (eql :lisp)) nonterminal)
 (intern (format nil "PARSE~A" nonterminal)))
+(defmethod genparsefunctionname ((target (eql :lisp)) (grammar grammar) nonterminal)
+ (intern (format nil "~:@(~A/PARSE~A~)" (grammarname grammar) nonterminal)))
(defmethod geninfirsts ((target (eql :lisp)) firsts)
(if (null (cdr firsts))
@@ 471,14 +476,14 @@ Please, update it use whatever regexp package is available in ~A"
`(member (scannercurrenttoken scanner) ',firsts
:test (function wordequal))))
(defmethod genparsingstatement ((target (eql :lisp)) grammar item)
+(defmethod genparsingstatement ((target (eql :lisp)) (grammar grammar) item)
(if (atom item)
(if (terminalp grammar item)
`(accept scanner ',item)
(let* ((firsts (firstrhs grammar item))
(emptyp (member nil firsts)))
`(,(if emptyp 'when 'if) ,(geninfirsts target (remove nil firsts))
 (,(genparsefunctionname target item) scanner)
+ (,(genparsefunctionname target grammar item) scanner)
,@(unless emptyp
'((error "Unexpected token ~S"
(scannercurrenttoken scanner)))))))
@@ 509,21 +514,22 @@ Please, update it use whatever regexp package is available in ~A"
(cdr item)))))))
(defmethod generatentparser ((target (eql :lisp)) grammar nonterminal)
 `(defun ,(genparsefunctionname target nonterminal) (scanner)
+(defmethod generatentparser ((target (eql :lisp)) (grammar grammar) nonterminal)
+ `(defun ,(genparsefunctionname target grammar nonterminal) (scanner)
,(genparsingstatement target grammar (findrule grammar nonterminal))))
(defmethod generateparser ((target (eql :lisp)) grammar)
(let ((scannerfunction
 (genscannerfunctionname target (grammarname grammar))))
 `(defun ,(genparsefunctionname target (grammarname grammar))
+ (genscannerfunctionname target grammar)))
+ `(defun ; ,(genparsefunctionname target grammar (grammarname grammar))
+ ,(intern (format nil "~:@(PARSE~A~)" (grammarname grammar)))
(source)
(let ((scanner (makescanner :source source
:function (function ,scannerfunction))))
(,scannerfunction scanner)
 (prog1 (,(genparsefunctionname target
 (grammarstart grammar)) scanner)
+ (prog1 (,(genparsefunctionname target grammar (grammarstart grammar))
+ scanner)
(unless (scannerendofsource scanner)
(error "End of source NOT reached.")))))))

2.1.4
From 4d3c19fa977602c9f1465d02c63f37e2ad068ba1 Mon Sep 17 00:00:00 2001
From: "Pascal J. Bourguignon"
Date: Wed, 12 Jan 2011 16:34:26 +0100
Subject: [PATCH 2/4] Added up to p73.lisp.

index.html  55 
p70.lisp  89 ++++++++++++++++++++++
p70b.lisp  145 +++++++++++++++++++++++++++++++++++
p70c.lisp  142 +++++++++++++++++++++++++++++++++++
p71.lisp  30 ++++++++
p72.lisp  39 ++++++++++
p73.lisp  249 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7 files changed, 694 insertions(+), 55 deletions()
create mode 100644 p70.lisp
create mode 100644 p70b.lisp
create mode 100644 p70c.lisp
create mode 100644 p71.lisp
create mode 100644 p72.lisp
create mode 100644 p73.lisp
diff git a/index.html b/index.html
index 5c4aeb7..01d415a 100644
 a/index.html
+++ b/index.html
@@ 194,62 +194,7 @@ P60 (**) Construct heightbalanced binary trees with a given number of nodes
Find out how many heightbalanced trees exist for N = 15.
Multiway Trees
A multiway tree is composed of a root element and a (possibly empty) set of successors which are multiway trees themselves. A multiway tree is never empty. The set of successor trees is sometimes called a forest.

[p70]

In Prolog we represent a multiway tree by a term t(X,F), where X denotes the root node and F denotes the forest of successor trees (a Prolog list). The example tree depicted opposite is therefore represented by the following Prolog
term:

T = t(a,[t(f,[t(g,[])]),t(c,[]),t(b,[t(d,[]),t(e,[])])])

P70B (*) Check whether a given term represents a multiway tree
 Write a predicate istree/1 which succeeds if and only if its argument is a Prolog term representing a multiway tree.
 Example:
 * istree(t(a,[t(f,[t(g,[])]),t(c,[]),t(b,[t(d,[]),t(e,[])])])).
 Yes

P70C (*) Count the nodes of a multiway tree
 Write a predicate nnodes/1 which counts the nodes of a given multiway tree.
 Example:
 * nnodes(t(a,[t(f,[])]),N).
 N = 2

 Write another version of the predicate that allows for a flow pattern (o,i).

P70 (**) Tree construction from a node string
 [p70]
 We suppose that the nodes of a multiway tree contain single characters. In the depthfirst order sequence of its nodes, a special character ^ has been inserted whenever, during the tree traversal, the move is a backtrack to the
 previous level.

 By this rule, the tree in the figure opposite is represented as: afg^^c^bd^e^^^

 Define the syntax of the string and write a predicate tree(String,Tree) to construct the Tree when the String is given. Work with atoms (instead of strings). Make your predicate work in both directions.

P71 (*) Determine the internal path length of a tree
 We define the internal path length of a multiway tree as the total sum of the path lengths from the root to all nodes of the tree. By this definition, the tree in the figure of problem P70 has an internal path length of 9. Write a
 predicate ipl(Tree,IPL) for the flow pattern (+,).

P72 (*) Construct the bottomup order sequence of the tree nodes
 Write a predicate bottomup(Tree,Seq) which constructs the bottomup sequence of the nodes of the multiway tree Tree. Seq should be a Prolog list. What happens if you run your predicate backwords?

P73 (**) Lisplike tree representation
 There is a particular notation for multiway trees in Lisp. Lisp is a prominent functional programming language, which is used primarily for artificial intelligence problems. As such it is one of the main competitors of Prolog. In
 Lisp almost everything is a list, just as in Prolog everything is a term.

 The following pictures show how multiway tree structures are represented in Lisp.
 [p73]
 Note that in the "lispy" notation a node with successors (children) in the tree is always the first element in a list, followed by its children. The "lispy" representation of a multiway tree is a sequence of atoms and parentheses '
 (' and ')', which we shall collectively call "tokens". We can represent this sequence of tokens as a Prolog list; e.g. the lispy expression (a (b c)) could be represented as the Prolog list ['(', a, '(', b, c, ')', ')']. Write a
 predicate treeltl(T,LTL) which constructs the "lispy token list" LTL if the tree is given as term T in the usual Prolog notation.

 Example:
 * treeltl(t(a,[t(b,[]),t(c,[])]),LTL).
 LTL = ['(', a, '(', b, c, ')', ')']

 As a second, even more interesting exercise try to rewrite treeltl/2 in a way that the inverse conversion is also possible: Given the list LTL, construct the Prolog tree T. Use difference lists.
Graphs
diff git a/p70.lisp b/p70.lisp
new file mode 100644
index 0000000..546cd3e
 /dev/null
+++ b/p70.lisp
@@ 0,0 +1,89 @@
+#(and) "
+
+P70 (**) Tree construction from a node string
+
+ We suppose that the nodes of a multiway tree contain single
+ characters. In the depthfirst order sequence of its nodes, a
+ special character ^ has been inserted whenever, during the tree
+ traversal, the move is a backtrack to the previous level.
+
+ By this rule, the tree in the figure opposite is represented as:
+ afg^^c^bd^e^^^
+
+ a
+ /\
+ /  \
+ f c b
+  / \
+ g d e
+
+ Define the syntax of the string and write a predicate
+ tree(String,Tree) to construct the Tree when the String is
+ given. Work with atoms (instead of strings). Make your predicate
+ work in both directions.
+"
+
+(load "p70c")
+(load "rdp")
+
+;; Solution: in lisp, we write two function, to parse and to generate.
+;; Again parsing and generating are trivial, using a parser generator:
+
+(defgrammar multiwaytreestring
+ :terminals ((label "[^^]")) ; one char, not ^
+ :start tree
+ :rules ((> tree
+ (opt node)
+ :action (if (null $1)
+ (makeemptymultiwaytree)
+ $1)) ; it's identity, but makeemptymultiwaytree
+ ; could be defined otherwise.
+ (> node
+ label (rep node) "^"
+ :action (makemultiwaytree :label (readfromstring (second $1))
+ :children $2))))
+
+;; (PARSEMULTIWAYTREESTRING "afg^^c^bd^e^^^")
+;; > #S(MULTIWAYTREE
+;; :LABEL A
+;; :CHILDREN (#S(MULTIWAYTREE
+;; :LABEL F
+;; :CHILDREN (#S(MULTIWAYTREE
+;; :LABEL G
+;; :CHILDREN NIL)))
+;; #S(MULTIWAYTREE
+;; :LABEL C
+;; :CHILDREN NIL)
+;; #S(MULTIWAYTREE
+;; :LABEL B
+;; :CHILDREN (#S(MULTIWAYTREE
+;; :LABEL D
+;; :CHILDREN NIL)
+;; #S(MULTIWAYTREE
+;; :LABEL E
+;; :CHILDREN NIL)))))
+;;
+;; (PARSEMULTIWAYTREESTRING "")
+;; > NIL
+
+
+(defun multiwaytreefromstring (string)
+ (PARSEMULTIWAYTREESTRING string))
+
+
+;; and walking the tree:
+
+(defun multiwaytreetostring (tree)
+ (cond ((emptymultiwaytreep tree) "")
+ ((nonemptymultiwaytreep tree)
+ (format nil "~A~{~A~}^"
+ (multiwaytreelabel tree)
+ (mapcar (function multiwaytreetostring)
+ (multiwaytreechildren tree))))
+ (t (error "Not a multiwaytree ~S" tree))))
+
+
+;; (multiwaytreetostring #S(MULTIWAYTREE :LABEL A :CHILDREN (#S(MULTIWAYTREE :LABEL F :CHILDREN (#S(MULTIWAYTREE :LABEL G :CHILDREN NIL))) #S(MULTIWAYTREE :LABEL C :CHILDREN NIL) #S(MULTIWAYTREE :LABEL B :CHILDREN (#S(MULTIWAYTREE :LABEL D :CHILDREN NIL) #S(MULTIWAYTREE :LABEL E :CHILDREN NIL))))))
+;; > "AFG^^C^BD^E^^^"
+
+;;;; THE END ;;;;
diff git a/p70b.lisp b/p70b.lisp
new file mode 100644
index 0000000..169b998
 /dev/null
+++ b/p70b.lisp
@@ 0,0 +1,145 @@
+#(and) "
+
+Multiway Trees
+
+A multiway tree is composed of a root element and a (possibly empty)
+set of successors which are multiway trees themselves. A multiway tree
+is never empty. The set of successor trees is sometimes called a
+forest.
+
+[p70]
+
+In Prolog we represent a multiway tree by a term t(X,F), where X
+denotes the root node and F denotes the forest of successor trees (a
+Prolog list). The example tree depicted opposite is therefore
+represented by the following Prolog term:
+
+T = t(a,[t(f,[t(g,[])]),t(c,[]),t(b,[t(d,[]),t(e,[])])])
+
+
+"
+
+;; In lisp we could represent a multiway tree in multiple ways.
+;; Let's just abstract it away using defstruct.
+
+
+(defstruct (multiwaytree
+ (:predicate nonemptymultiwaytreep))
+
+ label
+ children)
+
+;; Again, if lists are wanted instead of structures, (:type list) can
+;; be used; if vectors, then (:type vector). In both cases, if the
+;; list or vector must start with the symbol MULTIWAYTREE, the :named
+;; option can be added.
+
+
+(defun makeemptymultiwaytree ()
+ 'nil)
+(defun emptymultiwaytreep (tree)
+ (null tree))
+
+(defun multiwaytreep (tree)
+ (or (emptymultiwaytreep tree)
+ (nonemptymultiwaytreep tree)))
+
+
+
+#(and) "
+
+P70B (*) Check whether a given term represents a multiway tree
+
+ Write a predicate istree/1 which succeeds if and only if its
+ argument is a Prolog term representing a multiway tree.
+
+ Example:
+ * istree(t(a,[t(f,[t(g,[])]),t(c,[]),t(b,[t(d,[]),t(e,[])])])).
+ Yes
+"
+
+;; Badass solution:
+
+(defun istree (tree)
+ (multiwaytreep tree))
+
+
+;; In practice, nothing more than the badass solution is needed. For
+;; the exercise, we may check that the children are multiway trees
+;; too.
+
+(defun istree (tree)
+ (cond
+ ((emptymultiwaytreep tree) t)
+ ((nonemptymultiwaytreep tree)
+ (every (function istree) (multiwaytreechildren tree)))))
+
+
+;; Actually, in presence of circular structures, the above istree may
+;; not terminate. Since those exercices are boring, we'll implement
+;; an istree that checks for circular structures too:
+
+
+(defun istree (tree)
+ (let ((nodes (makehashtable)))
+ (labels ((multiwaynodep (node)
+ (cond
+ ((emptymultiwaytreep node) t)
+ ((not (nonemptymultiwaytreep node))
+ (returnfrom istree (values nil :nontree node))) ; short circuit exit
+ ((gethash node nodes)
+ (returnfrom istree (values nil :circular node))) ; short circuit exit
+ (t
+ (setf (gethash node nodes) t)
+ (every (function multiwaynodep) (multiwaytreechildren node))))))
+ (multiwaynodep tree))))
+
+
+(let* ((child (makemultiwaytree :label 'child))
+ (root (makemultiwaytree :label 'root :children (list child))))
+ (setf (multiwaytreechildren child) (list root))
+ (assert (equal (list nil :circular root) (multiplevaluelist (istree root)))))
+
+(let* ((child (makemultiwaytree :label 'child :children '(a b c)))
+ (root (makemultiwaytree :label 'root :children (list child))))
+ (assert (equal '(nil :nontree a) (multiplevaluelist (istree root)))))
+
+(let* ((child (makemultiwaytree
+ :label 'child
+ :children (list (makemultiwaytree :label 'a)
+ (makemultiwaytree :label 'b)
+ (makemultiwaytree :label 'c))))
+ (root (makemultiwaytree :label 'root :children (list child))))
+ (assert (istree root)))
+
+
+;; Notice that CL provides for each structure a printer function
+;; producing a readable form of the structure:
+;;
+;; (let* ((child (makemultiwaytree
+;; :label 'child
+;; :children (list (makemultiwaytree :label 'a)
+;; (makemultiwaytree :label 'b)
+;; (makemultiwaytree :label 'c))))
+;; (root (makemultiwaytree :label 'root :children (list child))))
+;; root)
+;; > #S(MULTIWAYTREE
+;; :LABEL ROOT
+;; :CHILDREN (#S(MULTIWAYTREE
+;; :LABEL CHILD
+;; :CHILDREN (#S(MULTIWAYTREE :LABEL A :CHILDREN NIL)
+;; #S(MULTIWAYTREE :LABEL B :CHILDREN NIL)
+;; #S(MULTIWAYTREE :LABEL C :CHILDREN NIL)))))
+;;
+;;
+;;
+;; So we can also write literal multiwaytrees as:
+;;
+;; #S(multiwaytree :label example :children (#S(multiwaytree :label a) #S(multiwaytree :label b)))
+;; > #S(MULTIWAYTREE :LABEL EXAMPLE
+;; :CHILDREN (#S(MULTIWAYTREE :LABEL A :CHILDREN NIL)
+;; #S(MULTIWAYTREE :LABEL B :CHILDREN NIL)))
+
+
+;;;; END ;;;;
+
diff git a/p70c.lisp b/p70c.lisp
new file mode 100644
index 0000000..e679608
 /dev/null
+++ b/p70c.lisp
@@ 0,0 +1,142 @@
+#(and) "
+
+P70C (*) Count the nodes of a multiway tree
+
+ Write a predicate nnodes/1 which counts the nodes of a given multiway tree.
+ Example:
+ * nnodes(t(a,[t(f,[])]),N).
+ N = 2
+
+ Write another version of the predicate that allows for a flow pattern (o,i).
+
+"
+(load "p70b")
+
+
+(defun multiwaytreecountnodes (tree)
+ (cond
+ ((emptymultiwaytreep tree)
+ 0)
+ ((nonemptymultiwaytreep tree)
+ (+ 1 (reduce (function multiwaytreecountnodes)
+ (multiwaytreechildren tree))))
+ (t
+ (error "Not a multiway tree: ~S" tree))))
+
+
+
+
+;; The other version of the prolog predicate generates all the trees
+;; that have the given number of nodes.
+
+
+(defun change (n)
+ (cons (list n)
+ (loop
+ :for i :from 1 :below n
+ :for subchanges = (change i)
+ :nconc (mapcar (lambda (subchange)
+ (cons ( n i) subchange))
+ subchanges))))
+
+(defun crossproduct (sets)
+ "
+SETS is a list of lists.
+Returns a list containing each one element taken from each lists in SETS.
+"
+ (cond
+ ((endp sets) '())
+ ((endp (rest sets)) (mapcar (function list) (first sets)))
+ (t (mapcan (lambda (crosses)
+ (mapcan (lambda (item)
+ (list (cons item crosses)))
+ (first sets)))
+ (crossproduct (rest sets))))))
+
+;; (crossproduct '())
+;; (crossproduct '((a1 a2) (b1 b2)))
+;; (crossproduct '((a1 a2) (b1 b2 b3) (c1 c2)))
+
+
+;; Notice that we consider that the order of the children matters,
+;; but the identity of the children does not.
+;;
+;; So a node with two children, the first of 2 nodes, and the other of
+;; 1 node, will be different from a node with two children, the first
+;; of 1 node and the other of 2 nodes.
+
+(defun generatemultiwaytreeswithnodes (nodecount nextlabel)
+ "Return a list of multiwaytrees with NODECOUNT nodes."
+ (case nodecount
+ ((0) (list (makeemptymultiwaytree)))
+ ((1) (list (makemultiwaytree :label (funcall nextlabel))))
+ (otherwise
+ (loop
+ :with subtrees = (coerce
+ (loop
+ :for remainingcount :below nodecount
+ :collect (generatemultiwaytreeswithnodes remainingcount nextlabel))
+ 'vector)
+ :for change :in (change (1 nodecount))
+ :nconc (mapcar (lambda (children)
+ (makemultiwaytree
+ :label (funcall nextlabel)
+ :children children))
+ (crossproduct (mapcar (lambda (childrencount) (aref subtrees childrencount))
+ change)))))))
+
+
+;; (generatemultiwaytreeswithnodes 4 (let ((n 0)) (lambda () (incf n))))
+;; >
+;; (#S(MULTIWAYTREE
+;; :LABEL 9
+;; :CHILDREN (#S(MULTIWAYTREE
+;; :LABEL 7
+;; :CHILDREN (#S(MULTIWAYTREE
+;; :LABEL 6
+;; :CHILDREN (#S(MULTIWAYTREE
+;; :LABEL 5
+;; :CHILDREN NIL)))))))
+;; #S(MULTIWAYTREE
+;; :LABEL 10
+;; :CHILDREN (#S(MULTIWAYTREE
+;; :LABEL 8
+;; :CHILDREN (#S(MULTIWAYTREE
+;; :LABEL 4
+;; :CHILDREN NIL)
+;; #S(MULTIWAYTREE
+;; :LABEL 4
+;; :CHILDREN NIL)))))
+;; #S(MULTIWAYTREE
+;; :LABEL 11
+;; :CHILDREN (#S(MULTIWAYTREE
+;; :LABEL 3
+;; :CHILDREN (#S(MULTIWAYTREE
+;; :LABEL 2
+;; :CHILDREN NIL)))
+;; #S(MULTIWAYTREE
+;; :LABEL 1
+;; :CHILDREN NIL)))
+;; #S(MULTIWAYTREE
+;; :LABEL 12
+;; :CHILDREN (#S(MULTIWAYTREE
+;; :LABEL 1
+;; :CHILDREN NIL)
+;; #S(MULTIWAYTREE
+;; :LABEL 3
+;; :CHILDREN (#S(MULTIWAYTREE
+;; :LABEL 2
+;; :CHILDREN NIL)))))
+;; #S(MULTIWAYTREE
+;; :LABEL 13
+;; :CHILDREN (#S(MULTIWAYTREE
+;; :LABEL 1
+;; :CHILDREN NIL)
+;; #S(MULTIWAYTREE
+;; :LABEL 1
+;; :CHILDREN NIL)
+;; #S(MULTIWAYTREE
+;; :LABEL 1
+;; :CHILDREN NIL))))
+
+;;;; THE END ;;;;
diff git a/p71.lisp b/p71.lisp
new file mode 100644
index 0000000..6416477
 /dev/null
+++ b/p71.lisp
@@ 0,0 +1,30 @@
+#(and) "
+
+P71 (*) Determine the internal path length of a tree
+
+ We define the internal path length of a multiway tree as the total
+ sum of the path lengths from the root to all nodes of the tree. By
+ this definition, the tree in the figure of problem P70 has an
+ internal path length of 9. Write a predicate ipl(Tree,IPL) for the
+ flow pattern (+,).
+
+"
+
+;; A simple direct recursive solution:
+
+(defun multiwaytreetotalpathlength (tree sofar)
+ "
+SOFAR is the length of path from the root to TREE.
+Returns the total length of path from the root to each nodes of TREE.
+"
+ (reduce (function +)
+ (multiwaytreechildren tree)
+ :key (lambda (node) (multiwaytreetotalpathlength node (1+ sofar)))
+ :initialvalue sofar))
+
+(defun ipl (tree)
+ (multiwaytreetotalpathlength tree 0))
+
+(assert (= 9 (ipl (parsemultiwaytreestring "AFG^^C^BD^E^^^"))))
+
+;;;; THE END ;;;;
diff git a/p72.lisp b/p72.lisp
new file mode 100644
index 0000000..7698d9d
 /dev/null
+++ b/p72.lisp
@@ 0,0 +1,39 @@
+#(and) "
+
+P72 (*) Construct the bottomup order sequence of the tree nodes
+
+ Write a predicate bottomup(Tree,Seq) which constructs the
+ bottomup sequence of the nodes of the multiway tree Tree. Seq
+ should be a Prolog list. What happens if you run your predicate
+ backwords?
+"
+
+;; "Bottomup order sequence of tree nodes" is an idiosyncrasy
+;; (google for it, there's no definition!).
+;; Perhaps it means postfix order.
+;; Right, it's the postfix order. The prolog solution gives:
+;; ? bottom_up(t(a,[t(f,[t(g,[])]),t(c,[]),t(b,[t(d,[]),t(e,[])])]),L).
+;; L = [g, f, c, d, e, b, a].
+
+
+(defun multiwaytreepostfixorder (tree)
+ "
+Returns a list of node labels in the postfix order.
+"
+ (reduce (function nconc)
+ (multiwaytreechildren tree)
+ :key (function multiwaytreepostfixorder)
+ :initialvalue (list (multiwaytreelabel tree))
+ :fromend t))
+;; :fromend is needed so that the initialvalue is placed on the right.
+;; It also proves beneficial since then the lists are walked only once per level.
+
+;; (multiwaytreepostfixorder (parsemultiwaytreestring "AFG^^C^BD^E^^^"))
+;; > (G F C D E B A)
+
+
+(defun bottomup (tree)
+ (multiwaytreepostfixorder tree))
+
+
+;;;; THE END ;;;;
diff git a/p73.lisp b/p73.lisp
new file mode 100644
index 0000000..e76c9ea
 /dev/null
+++ b/p73.lisp
@@ 0,0 +1,249 @@
+#(and) "
+
+P73 (**) Lisplike tree representation
+
+ There is a particular notation for multiway trees in Lisp. Lisp is
+ a prominent functional programming language, which is used
+ primarily for artificial intelligence problems. As such it is one
+ of the main competitors of Prolog. In Lisp almost everything is a
+ list, just as in Prolog everything is a term.
+
+ The following pictures show how multiway tree structures are
+ represented in Lisp.
+
+ Note that in the \"lispy\" notation a node with successors (children)
+ in the tree is always the first element in a list, followed by its
+ children. The \"lispy\" representation of a multiway tree is a
+ sequence of atoms and parentheses ' (' and ')', which we shall
+ collectively call \"tokens\". We can represent this sequence of
+ tokens as a Prolog list; e.g. the lispy expression (a (b c)) could
+ be represented as the Prolog list ['(', a, '(', b, c, ')',
+ ')']. Write a predicate treeltl(T,LTL) which constructs the
+ \"lispy token list\" LTL if the tree is given as term T in the usual
+ Prolog notation.
+
+ Example:
+ * treeltl(t(a,[t(b,[]),t(c,[])]),LTL).
+ LTL = ['(', a, '(', b, c, ')', ')']
+
+ As a second, even more interesting exercise try to rewrite
+ treeltl/2 in a way that the inverse conversion is also possible:
+ Given the list LTL, construct the Prolog tree T. Use difference
+ lists.
+
+"
+(load "rdp")
+(usepackage :com.informatimago.rdp)
+(load "p70")
+
+"
+Again there are several problem with the problem statement.
+
+In lisp, there are no parentheses. Only cons cells and atoms. The
+lisp expression (a (b c)) doesn't represent a sequence of symbols and
+parentheses, but a structure made of cons cells and symbols:
+
+ ++
+  (a (b c)) 
+  
+  +++ +++ 
+   *  * > * NIL 
+  +++ +++ 
+    
+  v v 
+  ++ +++ +++ 
+   A   *  * > * NIL 
+  ++ +++ +++ 
+    
+  v v 
+  ++ ++ 
+   B   C  
+  ++ ++ 
+ ++
+
+
+The correct representation of such a structure in prolog would be:
+
+ [a,[b,c]]
+
+and not the proposed:
+
+ ['(', a, '(', b, c, ')', ')']
+
+A textual representation of that structure would be a STRING, not a
+list of characters:
+
+ \"(a (b c))\"
+
+we can build a list of characters as an intermediate representation of
+the string, but it is not too useful. It would not be done usually in
+lisp programs.
+
+On the other hand, when writing a parser, it would be possible to
+separate the lexer from the parser, having the lexer generate a list
+of tokens to be passed to the parser.
+
+
+
+Notice also that if the problem was to produce the multiwaytree as a
+sexp where each node is represented by a list containing the label as
+first element, and a sublist containing the children as second
+element, then we would just have to give the (:type list) option to
+the defstruct to have it represent the trees that way! But the syntax
+defined above specifies the irregularty that leaf nodes are
+represented by the mere label of the leaf, instead of a list with the
+label and an empty list of children.
+
+"
+
+;; Badass solution:
+
+(defstruct (multiwaytree
+ (:type list))
+ label
+ children)
+
+;; (parsemultiwaytreestring "AFG^^C^BD^E^^^")
+;; > (A ((F ((G NIL))) (C NIL) (B ((D NIL) (E NIL)))))
+
+
+
+;; Let's generate the lisp sexp with the leaves reprensted by their
+;; labels. This doesn't need that the multiway trees be represented a
+;; lists, since we keep using the functional abstraction.
+
+(defun processleaves (tree)
+ (cond
+ ((emptymultiwaytreep tree) tree)
+ ((endp (multiwaytreechildren tree)) (multiwaytreelabel tree))
+ (t (cons (multiwaytreelabel tree)
+ (mapcar (function processleaves)
+ (multiwaytreechildren tree))))))
+
+(assert (equal (processleaves (parsemultiwaytreestring "AFG^^C^BD^E^^^"))
+ '(A (F G) C (B D E))))
+
+;; Badass solution, using lisp sexps to generate first the string,
+;; then the wanted list:
+
+
+(defun myprin1tostring (object)
+ (let ((*printcircle* nil)
+ (*printcase* :upcase)
+ (*printreadably* nil)
+ (*printpretty* nil)
+ (*printbase* 10.)
+ (*printradix* nil)
+ (*printlevel* nil)
+ (*printlength* nil)
+ (*printlines* nil))
+ (prin1tostring object)))
+
+(defun treeltl (tree)
+ ;; How unfunny is that!
+ (coerce (remove #\space (myprin1tostring (processleaves tree))) 'list))
+
+
+(assert (equal (treeltl (parsemultiwaytreestring "AFG^^C^BD^E^^^"))
+ '(#\( #\A #\( #\F #\G #\) #\C #\( #\B #\D #\E #\) #\))))
+
+
+;; We could also make the nonparenthesis characters back into symbols:
+
+(defun treeltl (tree)
+ (map 'list
+ (lambda (ch)
+ (if (alphanumericp ch)
+ (intern (string ch))
+ ch))
+ (remove #\space (myprin1tostring (processleaves tree)))))
+
+(assert (equal (treeltl (parsemultiwaytreestring "AFG^^C^BD^E^^^"))
+ '(#\( A #\( F G #\) C #\( B D E #\) #\))))
+
+
+;; Finally we could also repeat again and again the same tree walking
+;; and generation of the list:
+
+
+(defun treeltl (tree)
+ (cond
+ ((emptymultiwaytreep tree) "") ; should occur only when root is empty.
+ ((endp (multiwaytreechildren tree))
+ (list (multiwaytreelabel tree)))
+ (t (nconc
+ (list #\( (multiwaytreelabel tree))
+ (mapcan (function treeltl)
+ (multiwaytreechildren tree))
+ (list #\))))))
+
+
+(assert (equal (treeltl (parsemultiwaytreestring "AFG^^C^BD^E^^^"))
+ '(#\( A #\( F G #\) C #\( B D E #\) #\))))
+
+
+;; Now, for the inverse function, parsing the list could be done
+;; directly; we'd have to provide a pseudolexer to replace the lexer
+;; that scans source strings. For a simple solution we will just
+;; convert the list into a string and let the generated scanner do its
+;; work:
+
+
+(defgrammar multiwaytreeparenthesizedstring
+ :terminals ((label "[^^]")) ; one char, not ^
+ :start tree
+ :rules ((> tree
+ (opt (alt parnode leaf))
+ :action (if (null $1)
+ (makeemptymultiwaytree)
+ $1))
+ ; it's identity, but makeemptymultiwaytree
+ ; could be defined otherwise.
+ (> parnode
+ "(" label (rep tree) ")"
+ :action (makemultiwaytree :label (readfromstring (second $2))
+ :children $3))
+ (> leaf
+ label
+ :action (makemultiwaytree :label (readfromstring (second $1))))))
+
+(defun ltltree (ltl)
+ (parsemultiwaytreeparenthesizedstring
+ (format nil "~{~A~}" ltl)))
+
+(assert (equal (ltltree '(#\( A #\( F G #\) C #\( B D E #\) #\)))
+ (parsemultiwaytreestring "AFG^^C^BD^E^^^")))
+
+
+
+
+;; Another solution would be to use the lisp reader, since the list
+;; should contain well balanced parentheses, and then convert the
+;; obtained sexp into a tree. Notice how much simplier this is, to
+;; process simple grammar sufficiently similar to sexps: there's no
+;; need to involve the complexities of a parser generator.
+
+(defun multiwaytreefromsexp (node)
+ (cond
+ ((null node) (makeemptymultiwaytree))
+ ((atom node) (makemultiwaytree :label node)) ; a leaf
+ (t (destructuringbind (label &rest children) node
+ (makemultiwaytree :label label
+ :children (mapcar (function multiwaytreefromsexp)
+ children))))))
+
+(defun ltltree (ltl)
+ (multiwaytreefromsexp (let ((*readeval* nil)
+ (*readbase* 10.)
+ (*readtable* (copyreadtable nil)))
+ (readfromstring (format nil "~{ ~A ~}" ltl)))
+ ;; we get a list such as (A (F G) C (B D E))
+ ))
+
+(assert (equal (ltltree '(#\( A #\( F G #\) C #\( B D E #\) #\)))
+ (parsemultiwaytreestring "AFG^^C^BD^E^^^")))
+
+
+;;;; THE END ;;;;
+
+

2.1.4
From 53cafc45945021c90e5e14a99127d2df60b7196b Mon Sep 17 00:00:00 2001
From: "Pascal J. Bourguignon"
Date: Wed, 8 Jun 2011 03:35:33 +0200
Subject: [PATCH 3/4] Updated p80 and p37. Added Makefile.

Makefile  6 +
compileall.lisp  17 ++
index.html  82 
p37.lisp  3 +
p80.lisp  562 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
5 files changed, 587 insertions(+), 83 deletions()
create mode 100644 Makefile
create mode 100644 p80.lisp
diff git a/Makefile b/Makefile
new file mode 100644
index 0000000..9567d4a
 /dev/null
+++ b/Makefile
@@ 0,0 +1,6 @@
+LISP=clisp ansi E utf8
+all:
+ $(LISP) compileall.lisp
+clean:
+ rm f *.lib *.fas *.fasl *.x86f
+
diff git a/compileall.lisp b/compileall.lisp
index 6fac660..e4c9aca 100644
 a/compileall.lisp
+++ b/compileall.lisp
@@ 53,5 +53,22 @@
"p56.lisp"
"p57.lisp"
"drawtree.lisp" "p58.lisp"
+ "p61.lisp"
+ "p61a.lisp"
+ "p62.lisp"
+ "p62a.lisp"
+ "p63.lisp"
+ "p64.lisp"
+ "p65.lisp"
+ "p66.lisp"
+ "p67.lisp"
+ "p68.lisp"
+ "p69.lisp"
+ "p70b.lisp"
+ "p70c.lisp"
+ "p70.lisp"
+ "p71.lisp"
+ "p72.lisp"
+ "p73.lisp"
))
(load (compilefile src)))
diff git a/index.html b/index.html
index 01d415a..67fae1a 100644
 a/index.html
+++ b/index.html
@@ 194,88 +194,6 @@ P60 (**) Construct heightbalanced binary trees with a given number of nodes
Find out how many heightbalanced trees exist for N = 15.


Graphs

A graph is defined as a set of nodes and a set of edges, where each edge is a pair of nodes.

There are several ways to represent graphs in Prolog. One method is to represent each edge separately as one clause (fact). In this form, the graph depicted below is represented as the following predicate:
[graph1]

edge(h,g).
edge(k,f).
edge(f,b).
...

We call this edgeclause form. Obviously, isolated nodes cannot be represented. Another method is to represent the whole graph as one data object. According to the definition of the graph as a pair of two sets (nodes and edges), we may
use the following Prolog term to represent the example graph:

graph([b,c,d,f,g,h,k],[e(b,c),e(b,f),e(c,f),e(f,k),e(g,h)])

We call this graphterm form. Note, that the lists are kept sorted, they are really sets, without duplicated elements. Each edge appears only once in the edge list; i.e. an edge from a node x to another node y is represented as e(x,y),
the term e(y,x) is not present. The graphterm form is our default representation. In SWIProlog there are predefined predicates to work with sets.

A third representation method is to associate with each node the set of nodes that are adjacent to that node. We call this the adjacencylist form. In our example:

[n(b,[c,f]), n(c,[b,f]), n(d,[]), n(f,[b,c,k]), ...]

The representations we introduced so far are Prolog terms and therefore well suited for automated processing, but their syntax is not very userfriendly. Typing the terms by hand is cumbersome and errorprone. We can define a more
compact and "humanfriendly" notation as follows: A graph is represented by a list of atoms and terms of the type XY (i.e. functor '' and arity 2). The atoms stand for isolated nodes, the XY terms describe edges. If an X appears as
an endpoint of an edge, it is automatically defined as a node. Our example could be written as:

[bc, fc, gh, d, fb, kf, hg]

We call this the humanfriendly form. As the example shows, the list does not have to be sorted and may even contain the same edge multiple times. Notice the isolated node d. (Actually, isolated nodes do not even have to be atoms in
the Prolog sense, they can be compound terms, as in d(3.75,blue) instead of d in the example).

[graph2]
When the edges are directed we call them arcs. These are represented by ordered pairs. Such a graph is called directed graph. To represent a directed graph, the forms discussed above are slightly modified. The example graph opposite is
represented as follows:

Arcclause form
 arc(s,u).
 arc(u,r).
 ...

Graphterm form
 digraph([r,s,t,u,v],[a(s,r),a(s,u),a(u,r),a(u,s),a(v,u)])

Adjacencylist form
 [n(r,[]),n(s,[r,u]),n(t,[]),n(u,[r]),n(v,[u])]
 Note that the adjacencylist does not have the information on whether it is a graph or a digraph.

Humanfriendly form
 [s > r, t, u > r, s > u, u > s, v > u]

Finally, graphs and digraphs may have additional information attached to nodes and edges (arcs). For the nodes, this is no problem, as we can easily replace the single character identifiers with arbitrary compound terms, such as city
('London',4711). On the other hand, for edges we have to extend our notation. Graphs with additional information attached to edges are called labelled graphs.

[graph3]

Arcclause form
 arc(m,q,7).
 arc(p,q,9).
 arc(p,m,5).

Graphterm form
 digraph([k,m,p,q],[a(m,p,7),a(p,m,5),a(p,q,9)])

Adjacencylist form
 [n(k,[]),n(m,[q/7]),n(p,[m/5,q/9]),n(q,[])]
 Notice how the edge information has been packed into a term with functor '/' and arity 2, together with the corresponding node.

Humanfriendly form
 [p>q/9, m>q/7, k, p>m/5]

The notation for labelled graphs can also be used for socalled multigraphs, where more than one edge (or arc) are allowed between two given nodes.

P80 (***) Conversions
 Write predicates to convert between the different graph representations. With these predicates, all representations are equivalent; i.e. for the following problems you can always pick freely the most convenient form. The reason
 this problem is rated (***) is not because it's particularly difficult, but because it's a lot of work to deal with all the special cases.

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.
P82 (*) Cycle from a given node
Write a predicate cycle(G,A,P) to find a closed path (cycle) P starting at a given node A in the graph G. The predicate should return all cycles via backtracking.
diff git a/p37.lisp b/p37.lisp
index 6b1bc24..52ba793 100644
 a/p37.lisp
+++ b/p37.lisp
@@ 14,13 +14,14 @@ P37 (**) Calculate Euler's totient function phi(m) (improved).
Note that a ** b stands for the b'th power of a.
"
+;;; https://secure.wikimedia.org/wikipedia/en/wiki/Euler%27s_totient_function#Computing_Euler.27s_function
(defun phi (m)
;; (p1  1) * p1 ** (m1  1)
;; + (p2  1) * p2 ** (m2  1)
;; + (p3  1) * p3 ** (m3  1)
;; + ...
 (reduce (function +)
+ (reduce (function *)
(mapcar (lambda (item)
(destructuringbind (pi mi) item
(* (1 pi) (expt pi (1 mi)))))
diff git a/p80.lisp b/p80.lisp
new file mode 100644
index 0000000..29e60ed
 /dev/null
+++ b/p80.lisp
@@ 0,0 +1,562 @@
+#(and) "
+
+Graphs
+
+A graph is defined as a set of nodes and a set of edges, where each
+edge is a pair of nodes.
+
+There are several ways to represent graphs in Prolog. One method is to
+represent each edge separately as one clause (fact). In this form, the
+graph depicted below is represented as the following predicate:
+
+[graph1]
+
+edge(h,g).
+edge(k,f).
+edge(f,b).
+...
+
+We call this edgeclause form. Obviously, isolated nodes cannot be
+represented. Another method is to represent the whole graph as one
+data object. According to the definition of the graph as a pair of two
+sets (nodes and edges), we may use the following Prolog term to
+represent the example graph:
+
+graph([b,c,d,f,g,h,k],[e(b,c),e(b,f),e(c,f),e(f,k),e(g,h)])
+
+We call this graphterm form. Note, that the lists are kept sorted,
+they are really sets, without duplicated elements. Each edge appears
+only once in the edge list; i.e. an edge from a node x to another node
+y is represented as e(x,y), the term e(y,x) is not present. The
+graphterm form is our default representation. In SWIProlog there are
+predefined predicates to work with sets.
+
+A third representation method is to associate with each node the set
+of nodes that are adjacent to that node. We call this the
+adjacencylist form. In our example:
+
+[n(b,[c,f]), n(c,[b,f]), n(d,[]), n(f,[b,c,k]), ...]
+
+The representations we introduced so far are Prolog terms and
+therefore well suited for automated processing, but their syntax is
+not very userfriendly. Typing the terms by hand is cumbersome and
+errorprone. We can define a more compact and \"humanfriendly\"
+notation as follows: A graph is represented by a list of atoms and
+terms of the type XY (i.e. functor '' and arity 2). The atoms stand
+for isolated nodes, the XY terms describe edges. If an X appears as
+an endpoint of an edge, it is automatically defined as a node. Our
+example could be written as:
+
+[bc, fc, gh, d, fb, kf, hg]
+
+We call this the humanfriendly form. As the example shows, the list
+does not have to be sorted and may even contain the same edge multiple
+times. Notice the isolated node d. (Actually, isolated nodes do not
+even have to be atoms in the Prolog sense, they can be compound terms,
+as in d(3.75,blue) instead of d in the example).
+
+[graph2]
+
+When the edges are directed we call them arcs. These are represented
+by ordered pairs. Such a graph is called directed graph. To represent
+a directed graph, the forms discussed above are slightly modified. The
+example graph opposite is represented as follows:
+
+Arcclause form
+ arc(s,u).
+ arc(u,r).
+ ...
+
+Graphterm form
+ digraph([r,s,t,u,v],[a(s,r),a(s,u),a(u,r),a(u,s),a(v,u)])
+
+Adjacencylist form
+ [n(r,[]),n(s,[r,u]),n(t,[]),n(u,[r]),n(v,[u])]
+
+ Note that the adjacencylist does not have the information on
+ whether it is a graph or a digraph.
+
+Humanfriendly form
+
+ [s > r, t, u > r, s > u, u > s, v > u]
+
+Finally, graphs and digraphs may have additional information attached
+to nodes and edges (arcs). For the nodes, this is no problem, as we
+can easily replace the single character identifiers with arbitrary
+compound terms, such as city ('London',4711). On the other hand, for
+edges we have to extend our notation. Graphs with additional
+information attached to edges are called labelled graphs.
+
+[graph3]
+
+Arcclause form
+ arc(m,q,7).
+ arc(p,q,9).
+ arc(p,m,5).
+
+Graphterm form
+ digraph([k,m,p,q],[a(m,p,7),a(p,m,5),a(p,q,9)])
+
+Adjacencylist form
+ [n(k,[]),n(m,[q/7]),n(p,[m/5,q/9]),n(q,[])]
+
+ Notice how the edge information has been packed into a term with
+ functor '/' and arity 2, together with the corresponding node.
+
+Humanfriendly form
+ [p>q/9, m>q/7, k, p>m/5]
+
+The notation for labelled graphs can also be used for socalled
+multigraphs, where more than one edge (or arc) are allowed between
+two given nodes.
+"
+
+
+
+#(and) "
+
+P80 (***) Conversions
+
+ Write predicates to convert between the different graph
+ representations. With these predicates, all representations are
+ equivalent; i.e. for the following problems you can always pick
+ freely the most convenient form. The reason this problem is rated
+ (***) is not because it's particularly difficult, but because it's
+ a lot of work to deal with all the special cases.
+
+"
+
+
+
+#(and) "
+
+A similar set of representations are possible in lisp too. As always,
+hiding the representation behind an abstraction will allow to
+implement generic algorithms, and to change the representation at
+will. We may even design an abstraction allowing to change the
+representation on the fly, eg. between two phases of a processing, to
+provide better algorithmic complexities.
+
+To easily write and print graphs, we'll use a sexp which must be a
+list containing either isolated nodes (noncons objects), or lists of
+two or more elements (fromnode tonode [:key value ...]) representing
+each edge or arc.
+
+We could easily write a function to map more sugary sexp syntax to
+this form, or even a reader macro parsing a syntax with all the
+intricacy wanted, but it's hardly worth the pain.
+
+We'll also allow property lists to store any kind of attributes to the
+arcs or edges.
+"
+
+
+;;; Graph classes
+
+(defclass graph ()
+ ((representation :initarg :representation
+ :documentation "The actual representation of the graph."))
+ (:documentation "
+This abstract class represents a graph, and is the superclass of a
+directedgraph and undirectedgraph that can be represented in several
+ways.
+"))
+
+(defmethod printobject ((self graph) stream)
+ (printunreadableobject (self stream :identity t :type t)
+ (let ((repname (classname (classof (slotvalue self 'representation)))))
+ (format stream "as a~:[~;n~] ~A" (find (char (string repname) 0) "AEIOUY") repname))
+ (format stream " with ~A node~:*~P and ~A edge~:*~P"
+ (length (nodes self)) (length (edges self))))
+ self)
+
+(defclass undirectedgraph (graph)
+ ()
+ (:documentation "
+Undirected graphs can have only representations with edges.
+"))
+
+
+(defclass attributes ()
+ ((propertylist :initform '()
+ :accessor propertylist :initarg :propertylist
+ :accessor properties :initarg :properties)))
+
+
+(defclass edge (attributes)
+ ((nodes :accessor edgenodes :initarg :nodes))
+ (:documentation "
+An undirected edge. The order of the two nodes in the edgenodes list
+is irrelevant.
+"))
+
+
+(defclass directedgraph (graph)
+ ()
+ (:documentation "
+Undirected graphs can have only representations with arcs.
+"))
+
+(defclass arc (attributes)
+ ((from :accessor arcfrom :initarg :from)
+ (to :accessor arcto :initarg :to))
+ (:documentation "
+A directed arc, from the FROM node to the TO node.
+Note: the API allow for unidrected
+"))
+
+
+
+(defclass graphrepresentation ()
+ ()
+ (:documentation "An abstract graph representation."))
+
+(defclass undirectedgraphrepresentation ()
+ ()
+ (:documentation "An abstract undirected graph representation."))
+
+(defclass directedgraphrepresentation ()
+ ()
+ (:documentation "An abstract directed graph representation."))
+
+
+
+;;; Generic functions
+;; We define here the fundamental operations for graph
+;; representations, as generic functions. A method is defined on
+;; graph, that just forwards the call to the graph representation.
+
+(defgeneric nodes (gr)
+ (:documentation "Returns the list of nodes in the graph or graph representation")
+ (:method ((g graph)) (nodes (slotvalue g 'representation))))
+
+(defgeneric addnode (gr node)
+ (:documentation "Adds a new node to the graph or graph representation.
+Return NODE.")
+ (:method ((g graph) node) (addnode (slotvalue g 'representation) node)))
+
+(defgeneric removenode (gr node)
+ (:documentation "
+If NODE is a node of the graph or graph representation, then remove
+it, as well as all arcs connecting it. Return NODE.")
+ (:method ((g graph) node) (removenode (slotvalue g 'representation) node)))
+
+
+
+(defgeneric edges (gr)
+ (:documentation "
+Returns the list of edges in the undirected graph or graph
+representation.")
+ (:method ((g undirectedgraph)) (edges (slotvalue g 'representation))))
+
+(defgeneric addedgebetweennodes (gr from to &key &allowotherkeys)
+ ;; Notice we leave ADDEDGE to name a generic function of two arguments: (gr edge)
+ ;; Optional key arguments may be defined for additionnal
+ ;; initializers for edges (such as weights, etc).
+ (:documentation "
+Adds a new edge the graph or graph representation, between the FROM
+and the TO node. If the graph or graph representation is undirected,
+then two arcs are added, from FROM to TO and from TO to FROM. If
+either FROM or TO is not a node of GR, then it's added before.
+Return the new EDGE.")
+ (:method ((g undirectedgraph) from to &rest args &key &allowotherkeys)
+ (apply (function addedgebetweennodes) (slotvalue g 'representation) from to args)))
+
+(defgeneric removeedge (gr edge)
+ (:documentation "
+If EDGE is an edge of the graph or graph representation,then remove it.
+Return EDGE.")
+ (:method ((g undirectedgraph) edge) (removeedge (slotvalue g 'representation) edge)))
+
+
+
+(defgeneric arcs (gr)
+ (:documentation "Returns the list of arcs in the graph or graph representation.
+If the graph or graph representation is undirected, then each edge produces two arcs.")
+ (:method ((g directedgraph))
+ (arcs (slotvalue g 'representation)))
+ (:method ((g undirectedgraph))
+ (mapcan (lambda (edge)
+ (destructuringbind (left right) (edgenodes edge)
+ (list (makeinstance 'arc :from left :to right :properties (properties edge))
+ (makeinstance 'arc :from right :to left :properties (properties edge)))))
+ (edges (slotvalue g 'representation)))))
+
+(defgeneric addarcbetweennodes (gr from to &key &allowotherkeys)
+ ;; Notice we leave ADDARC to name a generic function of two arguments: (gr arc)
+ ;; Optional key arguments may be defined for additionnal
+ ;; initializers for arcs (such as weights, etc).
+ (:documentation "
+Adds a new arc the graph or graph representation, between the FROM
+and the TO node. If either FROM or TO is not a node of GR,
+then it's added before. Return the new ARC.")
+ (:method ((g directedgraph) from to &rest args &key &allowotherkeys)
+ (apply (function addarcbetweennodes) (slotvalue g 'representation) from to args)))
+
+(defgeneric removearc (gr arc)
+ (:documentation "
+If ARC is an arc of the graph or graph representation,then remove it.
+The nodes are not changed. Return ARC.")
+ (:method ((g directedgraph) node) (removearc (slotvalue g 'representation) arc)))
+
+
+
+
+(defgeneric tosexp (object)
+ (:documentation "
+Returns a sexp representing the graph.
+The sexp should be accepted by the method FROMSEXP
+of the same graph class.
+"))
+
+(defgeneric fromsexp (object sexp)
+ (:documentation "
+Replaces the graph nodes and edges with the data from the given SEXP.
+Returns GR.
+"))
+
+
+
+
+(defun nodesandlinkstosexp (nodes links)
+ (flet ((nodesfromlinks (links)
+ (mapcan (lambda (link) (list (first link) (second link))) links)))
+ (append (setdifference nodes (nodesfromlinks links)) links)))
+
+(defmethod tosexp ((self edge))
+ (concatenate 'list (edgenodes self) (properties self)))
+
+(defmethod tosexp ((self arc))
+ (concatenate 'list (list (arcfrom self) (arcto self)) (properties self)))
+
+(defmethod tosexp ((g directedgraph))
+ (nodesandlinkstosexp (nodes g) (mapcar (function tosexp) (arcs g))))
+
+(defmethod tosexp ((g undirectedgraph))
+ (nodesandlinkstosexp (nodes g) (mapcar (function tosexp) (edges g))))
+
+
+
+(defmethod clearrepresentation ((g graph))
+ (setf (slotvalue g 'representation) (makeinstance (classof (slotvalue g 'representation)))))
+
+(defmethod parsegraphsexp ((g graph) sexp addlink)
+ (let ((rep (clearrepresentation g)))
+ (loop
+ :for item :in sexp
+ :do (if (consp item)
+ (apply addlink rep item)
+ (addnode rep item))
+ :finally (return rep))))
+
+(defmethod fromsexp ((g undirectedgraph) sexp)
+ (setf (slotvalue g 'representation)
+ (parsegraphsexp g sexp (function addedgebetweennodes)))
+ g)
+
+(defmethod fromsexp ((g directedgraph) sexp)
+ (setf (slotvalue g 'representation)
+ (parsegraphsexp g sexp (function addarcbetweennodes)))
+ g)
+
+
+
+;; We'd want to
+;; (definemodifymacro deletef (element list) delete)
+;; but the order of the argument is not consistent.
+
+(defmacro deletef (item sequenceplace &rest args &key key test testnot)
+ (declare (ignore key test testnot))
+ (multiplevaluebind (vars vals storevars writerform readerform)
+ (getsetfexpansion sequenceplace)
+ `(let* (,@(mapcar (function list) vars vals)
+ (,(car storevars) ,readerform))
+ (when (cdr storevars)
+ (error "Cannot DELETE from a place with multiple values."))
+ (setf ,(car storevars) (delete ,item ,(car storevars) ,@args))
+ ,writerform)))
+
+
+
+
+;;; Edge list representation
+;;; In this representation we only keep a list of links.
+
+(defclass edgelistrepresentation (undirectedgraphrepresentation)
+ ((edges :accessor edges :initarg :edges :initform '())))
+
+(defmethod addedgebetweennodes ((gr edgelistrepresentation) from to &rest properties &key &allowotherkeys)
+ (let ((edge (makeinstance 'edge
+ :nodes (list from to)
+ :properties properties)))
+ (push edge (edges gr))
+ edge))
+
+(defmethod removeedge ((gr edgelistrepresentation) edge)
+ (deletef edge (edges gr))
+ edge)
+
+(defmethod nodes ((gr edgelistrepresentation))
+ (deleteduplicates (loop
+ :for edge :in (edges gr)
+ :for nodes = (edgenodes edge)
+ :collect (first nodes) :collect (second nodes))))
+
+(defmethod addnode ((gr edgelistrepresentation) node)
+ (error "Cannot add isolated nodes to a graph represented by a list of edges."))
+
+(defmethod removenode ((gr edgelistrepresentation) node)
+ (setf (edges gr) (deleteif (lambda (edge) (member node (edgenodes edge))) (edges gr)))
+ node)
+
+
+
+;;; Edge list and nodes representation
+;;; In this representation in addition to the list of edge, we
+;;; maintain a list of nodes, so we may have isolated nodes too.
+
+(defclass edgeandnodelistrepresentation (edgelistrepresentation)
+ ((nodes :accessor nodes :initarg :nodes :initform '())))
+
+(defmethod addedgebetweennodes ((gr edgeandnodelistrepresentation) from to &key &allowotherkeys)
+ (addnode gr from)
+ (addnode gr to)
+ (callnextmethod))
+
+(defmethod addnode ((gr edgeandnodelistrepresentation) node)
+ (pushnew node (nodes gr))
+ node)
+
+(defmethod removenode ((gr edgeandnodelistrepresentation) node)
+ (remove node (nodes gr))
+ (callnextmethod))
+
+
+
+
+;;; adjacency list representation
+;;; In this representation, we have a hashtable mapping from nodes to
+;;; lists of attributed links to nodes. This allow for directed graphs.
+;;; Notice that each node is present in the hashtable as a key, so
+;;; isolated nodes are easily represented.
+
+(defclass link (attributes)
+ ((node :accessor linknode :initarg :node)))
+
+(defclass adjacencylistrepresentation (directedgraphrepresentation)
+ ((adjacencylist :initform (makehashtable)
+ :reader adjacencylist)))
+
+
+(defmethod nodes ((gr adjacencylistrepresentation))
+ (let ((nodes '()))
+ (maphash (lambda (from adjacents)
+ (declare (ignore adjacents))
+ (push from nodes))
+ (adjacencylist gr))
+ nodes))
+
+(defmethod addnode ((gr adjacencylistrepresentation) node)
+ (unless (gethash node (adjacencylist gr))
+ (setf (gethash node (adjacencylist gr)) '()))
+ node)
+
+(defmethod removenode ((gr adjacencylistrepresentation) node)
+ (let ((al (adjacencylist gr)))
+ (when (remhash node al)
+ (maphash (lambda (from adjacents)
+ ;; I assume it's faster to call (setf gethash)
+ ;; than to call member or find.
+ (setf (gethash from al) (delete node adjacents :key (function linknode))))
+ al)))
+ node)
+
+
+(defmethod arcs ((gr adjacencylistrepresentation))
+ (let ((arcs '()))
+ (maphash (lambda (from adjacents)
+ (setf arcs (nconc (mapcar (lambda (to)
+ (makeinstance 'arc
+ :from from
+ :to (linknode to)
+ :properties (copylist (properties to))))
+ adjacents)
+ arcs)))
+ (adjacencylist gr))
+ arcs))
+
+(defmethod addarcbetweennodes ((gr adjacencylistrepresentation) from to &rest properties &key &allowotherkeys)
+ (addnode gr from)
+ (addnode gr to)
+ (pushnew (makeinstance 'link :node to :properties properties) (gethash from (adjacencylist gr)))
+ (makeinstance 'arc
+ :from from
+ :to to
+ :properties (copylist properties)))
+
+(defmethod removearc ((gr adjacencylistrepresentation) arc)
+ (deletef to (gethash (arcfrom arc) (adjacencylist gr)))
+ arc)
+
+
+
+;;;
+
+(defun makeedgegraph (data)
+ (fromsexp (makeinstance 'undirectedgraph
+ :representation (makeinstance 'edgelistrepresentation))
+ data))
+
+(defun makeedgeandnodegraph (data)
+ (fromsexp (makeinstance 'undirectedgraph
+ :representation (makeinstance 'edgeandnodelistrepresentation))
+ data))
+
+(defun makeadjacencylistgraph (data)
+ (fromsexp (makeinstance 'directedgraph
+ :representation (makeinstance 'adjacencylistrepresentation))
+ data))
+
+
+(defun setequalp (a b)
+ (and (subsetp a b :test (function equal))
+ (subsetp b a :test (function equal))))
+
+(defun test/tosexp ()
+ (dolist (test '(()
+ (a b c)
+ ((a b) (b c))
+ ((b c) (f c) (g h) d (f b) (k f) (h g))
+ ((s r) t (u r) (s u) (u s) (v u))
+ ((p q :weight 9) (m q :weight 7) k (p m :weight 5))))
+ (assert (setequalp test (tosexp (makeedgeandnodegraph test))))
+ (assert (setequalp test (tosexp (makeadjacencylistgraph test)))))
+ (dolist (test '(()
+ ((a b) (b c))
+ ((b c) (f c) (g h) (f b) (k f) (h g))
+ ((s r) (u r) (s u) (u s) (v u))
+ ((p q :weight 9) (m q :weight 7) (p m :weight 5))))
+ (assert (setequalp test (tosexp (makeedgegraph test)))))
+ :success)
+
+;; (test/tosexp)
+
+
+;; Converting from one graph representation to another can be realized with:
+;; (make...graph (tosexp originalgraph))
+;; or use copyfrom to replace the contents of the current graph with
+;; those of the other graph:
+
+(defmethod copyfrom ((g graph) (other graph))
+ "Make G a graph equal to OTHER"
+ (clearrepresentation)
+ ;; Just out of lazyness, we go thru sexps.
+ (fromsexp (slotvalue g 'representation) (tosexp other))
+ ;; if a faster conversion is required, we could get (nodes other)
+ ;; and (edges other) or (arcs other) and loop of them to add them to
+ ;; the target graph.
+ g)
+
+
+;;; THE END ;;;
+

2.1.4
From db6fb90aeac76c4b8319034a7ba4530eb5a106f0 Mon Sep 17 00:00:00 2001
From: "Pascal J. Bourguignon"
Date: Tue, 19 Jul 2011 21:34:50 +0200
Subject: [PATCH 4/4] Added a few methods.

p80.lisp  67 ++++++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 50 insertions(+), 17 deletions()
diff git a/p80.lisp b/p80.lisp
index 29e60ed..6bfc8d7 100644
 a/p80.lisp
+++ b/p80.lisp
@@ 190,6 +190,11 @@ An undirected edge. The order of the two nodes in the edgenodes list
is irrelevant.
"))
+(defgeneric edgeswithnode (graph node)
+ (:documentation "Returns a list of the edges in GRAPH associating the given NODE.")
+ (:method ((g graph) node) (edgeswithnode (slotvalue g 'representation) node)))
+
+
(defclass directedgraph (graph)
()
@@ 206,6 +211,20 @@ Note: the API allow for unidrected
"))
+(defgeneric arcsfromnode (graph node)
+ (:documentation "Returns a list of the arcs in GRAPH from the NODE.
+\(the adjacency list).")
+ (:method ((g graph) node) (arcsfromnode (slotvalue g 'representation) node)))
+
+(defgeneric arcstonode (graph node)
+ (:documentation "Returns a list of the arcs in GRAPH to the NODE.")
+ (:method ((g graph) node) (arcstonode (slotvalue g 'representation) node)))
+
+
+
+
+
+
(defclass graphrepresentation ()
()
@@ 270,6 +289,7 @@ Return EDGE.")
+
(defgeneric arcs (gr)
(:documentation "Returns the list of arcs in the graph or graph representation.
If the graph or graph representation is undirected, then each edge produces two arcs.")
@@ 297,9 +317,7 @@ then it's added before. Return the new ARC.")
(:documentation "
If ARC is an arc of the graph or graph representation,then remove it.
The nodes are not changed. Return ARC.")
 (:method ((g directedgraph) node) (removearc (slotvalue g 'representation) arc)))


+ (:method ((g directedgraph) arc) (removearc (slotvalue g 'representation) arc)))
(defgeneric tosexp (object)
@@ 369,10 +387,10 @@ Returns GR.
(declare (ignore key test testnot))
(multiplevaluebind (vars vals storevars writerform readerform)
(getsetfexpansion sequenceplace)
+ (when (cdr storevars)
+ (error "Cannot DELETE from a place with multiple values."))
`(let* (,@(mapcar (function list) vars vals)
(,(car storevars) ,readerform))
 (when (cdr storevars)
 (error "Cannot DELETE from a place with multiple values."))
(setf ,(car storevars) (delete ,item ,(car storevars) ,@args))
,writerform)))
@@ 403,12 +421,15 @@ Returns GR.
:collect (first nodes) :collect (second nodes))))
(defmethod addnode ((gr edgelistrepresentation) node)
+ (declare (ignore gr node))
(error "Cannot add isolated nodes to a graph represented by a list of edges."))
(defmethod removenode ((gr edgelistrepresentation) node)
(setf (edges gr) (deleteif (lambda (edge) (member node (edgenodes edge))) (edges gr)))
node)
+(defmethod edgeswithnode ((gr edgelistrepresentation) node)
+ (removeifnot (lambda (edge) (member node (edgenodes edge))) (edges gr)))
;;; Edge list and nodes representation
@@ 472,16 +493,19 @@ Returns GR.
node)
+(defun makeadjacencylistarcsfrom (from)
+ (lambda (to)
+ (makeinstance 'arc
+ :from from
+ :to (linknode to)
+ :properties (copylist (properties to)))))
+
+
(defmethod arcs ((gr adjacencylistrepresentation))
(let ((arcs '()))
(maphash (lambda (from adjacents)
 (setf arcs (nconc (mapcar (lambda (to)
 (makeinstance 'arc
 :from from
 :to (linknode to)
 :properties (copylist (properties to))))
 adjacents)
 arcs)))
+ (setf arcs (nconc (mapcar (makeadjacencylistarcsfrom from)
+ adjacents) arcs)))
(adjacencylist gr))
arcs))
@@ 495,10 +519,20 @@ Returns GR.
:properties (copylist properties)))
(defmethod removearc ((gr adjacencylistrepresentation) arc)
 (deletef to (gethash (arcfrom arc) (adjacencylist gr)))
+ (deletef arc (gethash (arcfrom arc) (adjacencylist gr)))
arc)
+(defmethod arcsfromnode ((gr adjacencylistrepresentation) from)
+ (mapcar (makeadjacencylistarcsfrom from)
+ (gethash from (adjacencylist gr))))
+(defmethod arcstonode ((gr adjacencylistrepresentation) to)
+ (let ((arcs '()))
+ (maphash (lambda (from adjacents)
+ (when (member to adjacents)
+ (setf arcs (nconc (funcall (makeadjacencylistarcsfrom from) to) arcs))))
+ (adjacencylist gr))
+ arcs))
;;;
@@ 549,14 +583,13 @@ Returns GR.
(defmethod copyfrom ((g graph) (other graph))
"Make G a graph equal to OTHER"
 (clearrepresentation)
+ (clearrepresentation g)
;; Just out of lazyness, we go thru sexps.
(fromsexp (slotvalue g 'representation) (tosexp other))
;; if a faster conversion is required, we could get (nodes other)
 ;; and (edges other) or (arcs other) and loop of them to add them to
+ ;; and (edges other) or (arcs other) and loop on them to add them to
;; the target graph.
g)
;;; THE END ;;;

+;;;; THE END ;;;;

2.1.4