Added up to p73.lisp.

Pascal J. Bourguignon [2011-01-12 15:34]
Added up to p73.lisp.
Filename
index.html
p70.lisp
p70b.lisp
p70c.lisp
p71.lisp
p72.lisp
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 height-balanced binary trees with a given number of nodes
     Find out how many height-balanced 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 depth-first 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 bottom-up order sequence of the tree nodes
-    Write a predicate bottom-up(Tree,Seq) which constructs the bottom-up sequence of the nodes of the multiway tree Tree. Seq should be a Prolog list. What happens if you run your predicate backwords?
-
-P73 (**) Lisp-like 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 tree-ltl(T,LTL) which constructs the "lispy token list" LTL if the tree is given as term T in the usual Prolog notation.
-
-    Example:
-    * tree-ltl(t(a,[t(b,[]),t(c,[])]),LTL).
-    LTL = ['(', a, '(', b, c, ')', ')']
-
-    As a second, even more interesting exercise try to rewrite tree-ltl/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 depth-first 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 multiway-tree-string
+    :terminals ((label   "[^^]")) ; one char, not ^
+    :start tree
+    :rules ((--> tree
+                 (opt node)
+                 :action (if (null $1)
+                             (make-empty-multiway-tree)
+                             $1)) ; it's identity, but make-empty-multiway-tree
+                                        ; could be defined otherwise.
+            (--> node
+                 label (rep node) "^"
+                 :action (make-multiway-tree :label (read-from-string (second $1))
+                                             :children $2))))
+
+;; (PARSE-MULTIWAY-TREE-STRING "afg^^c^bd^e^^^")
+;; --> #S(MULTIWAY-TREE
+;;        :LABEL A
+;;        :CHILDREN (#S(MULTIWAY-TREE
+;;                      :LABEL F
+;;                      :CHILDREN (#S(MULTIWAY-TREE
+;;                                    :LABEL G
+;;                                    :CHILDREN NIL)))
+;;                   #S(MULTIWAY-TREE
+;;                      :LABEL C
+;;                      :CHILDREN NIL)
+;;                   #S(MULTIWAY-TREE
+;;                      :LABEL B
+;;                      :CHILDREN (#S(MULTIWAY-TREE
+;;                                    :LABEL D
+;;                                    :CHILDREN NIL)
+;;                                 #S(MULTIWAY-TREE
+;;                                    :LABEL E
+;;                                    :CHILDREN NIL)))))
+;;
+;; (PARSE-MULTIWAY-TREE-STRING "")
+;; --> NIL
+
+
+(defun multiway-tree-from-string (string)
+  (PARSE-MULTIWAY-TREE-STRING string))
+
+
+;; and walking the tree:
+
+(defun multiway-tree-to-string (tree)
+  (cond ((empty-multiway-tree-p tree) "")
+        ((non-empty-multiway-tree-p tree)
+         (format nil "~A~{~A~}^"
+                 (multiway-tree-label tree)
+                 (mapcar (function multiway-tree-to-string)
+                         (multiway-tree-children tree))))
+        (t (error "Not a multiway-tree ~S" tree))))
+
+
+;; (multiway-tree-to-string #S(MULTIWAY-TREE :LABEL A :CHILDREN (#S(MULTIWAY-TREE :LABEL F :CHILDREN (#S(MULTIWAY-TREE :LABEL G :CHILDREN NIL))) #S(MULTIWAY-TREE :LABEL C :CHILDREN NIL) #S(MULTIWAY-TREE :LABEL B :CHILDREN (#S(MULTIWAY-TREE :LABEL D :CHILDREN NIL) #S(MULTIWAY-TREE :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 (multiway-tree
+             (:predicate non-empty-multiway-tree-p))
+
+  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 MULTIWAY-TREE, the :named
+;; option can be added.
+
+
+(defun make-empty-multiway-tree ()
+  'nil)
+(defun empty-multiway-tree-p (tree)
+  (null tree))
+
+(defun multiway-tree-p (tree)
+  (or (empty-multiway-tree-p tree)
+      (non-empty-multiway-tree-p 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)
+  (multiway-tree-p 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
+    ((empty-multiway-tree-p tree) t)
+    ((non-empty-multiway-tree-p tree)
+     (every (function istree) (multiway-tree-children 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 (make-hash-table)))
+    (labels ((multiway-node-p (node)
+               (cond
+                 ((empty-multiway-tree-p node)           t)
+                 ((not (non-empty-multiway-tree-p node))
+                  (return-from istree (values nil :non-tree node))) ; short circuit exit
+                 ((gethash node nodes)
+                  (return-from istree (values nil :circular node))) ; short circuit exit
+                 (t
+                  (setf (gethash node nodes) t)
+                  (every (function multiway-node-p) (multiway-tree-children node))))))
+      (multiway-node-p tree))))
+
+
+(let* ((child (make-multiway-tree :label 'child))
+       (root  (make-multiway-tree :label 'root :children (list child))))
+  (setf (multiway-tree-children child) (list root))
+  (assert (equal (list nil :circular root) (multiple-value-list (istree root)))))
+
+(let* ((child (make-multiway-tree :label 'child :children '(a b c)))
+       (root  (make-multiway-tree :label 'root :children (list child))))
+  (assert (equal '(nil :non-tree a) (multiple-value-list (istree root)))))
+
+(let* ((child (make-multiway-tree
+               :label 'child
+               :children (list (make-multiway-tree :label 'a)
+                               (make-multiway-tree :label 'b)
+                               (make-multiway-tree :label 'c))))
+       (root  (make-multiway-tree :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 (make-multiway-tree
+;;                :label 'child
+;;                :children (list (make-multiway-tree :label 'a)
+;;                                (make-multiway-tree :label 'b)
+;;                                (make-multiway-tree :label 'c))))
+;;        (root  (make-multiway-tree :label 'root :children (list child))))
+;;   root)
+;; --> #S(MULTIWAY-TREE
+;;        :LABEL ROOT
+;;        :CHILDREN (#S(MULTIWAY-TREE
+;;                      :LABEL CHILD
+;;                      :CHILDREN (#S(MULTIWAY-TREE :LABEL A :CHILDREN NIL)
+;;                                   #S(MULTIWAY-TREE :LABEL B :CHILDREN NIL)
+;;                                   #S(MULTIWAY-TREE :LABEL C :CHILDREN NIL)))))
+;;
+;;
+;;
+;; So we can also write literal multiway-trees as:
+;;
+;; #S(multiway-tree :label example :children (#S(multiway-tree :label a) #S(multiway-tree :label b)))
+;; --> #S(MULTIWAY-TREE :LABEL EXAMPLE
+;;                      :CHILDREN (#S(MULTIWAY-TREE :LABEL A :CHILDREN NIL)
+;;                                   #S(MULTIWAY-TREE :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 multiway-tree-count-nodes (tree)
+  (cond
+    ((empty-multiway-tree-p tree)
+     0)
+    ((non-empty-multiway-tree-p tree)
+     (+ 1 (reduce (function multiway-tree-count-nodes)
+                  (multiway-tree-children 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 cross-product (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)))
+               (cross-product (rest sets))))))
+
+;; (cross-product '())
+;; (cross-product '((a1 a2) (b1 b2)))
+;; (cross-product '((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 generate-multiway-trees-with-nodes (node-count next-label)
+  "Return a list of multiway-trees with NODE-COUNT nodes."
+  (case node-count
+    ((0) (list (make-empty-multiway-tree)))
+    ((1) (list (make-multiway-tree :label (funcall next-label))))
+    (otherwise
+     (loop
+        :with subtrees = (coerce
+                          (loop
+                             :for remaining-count :below node-count
+                             :collect (generate-multiway-trees-with-nodes remaining-count next-label))
+                          'vector)
+        :for change :in (change (1- node-count))
+        :nconc (mapcar (lambda (children)
+                         (make-multiway-tree
+                          :label (funcall next-label)
+                          :children children))
+                       (cross-product (mapcar (lambda (children-count) (aref subtrees children-count))
+                                              change)))))))
+
+
+;; (generate-multiway-trees-with-nodes 4 (let ((n 0)) (lambda () (incf n))))
+;; -->
+;; (#S(MULTIWAY-TREE
+;;     :LABEL 9
+;;     :CHILDREN (#S(MULTIWAY-TREE
+;;                   :LABEL 7
+;;                   :CHILDREN (#S(MULTIWAY-TREE
+;;                                 :LABEL 6
+;;                                 :CHILDREN (#S(MULTIWAY-TREE
+;;                                               :LABEL 5
+;;                                               :CHILDREN NIL)))))))
+;;    #S(MULTIWAY-TREE
+;;       :LABEL 10
+;;       :CHILDREN (#S(MULTIWAY-TREE
+;;                     :LABEL 8
+;;                     :CHILDREN (#S(MULTIWAY-TREE
+;;                                   :LABEL 4
+;;                                   :CHILDREN NIL)
+;;                                  #S(MULTIWAY-TREE
+;;                                     :LABEL 4
+;;                                     :CHILDREN NIL)))))
+;;    #S(MULTIWAY-TREE
+;;       :LABEL 11
+;;       :CHILDREN (#S(MULTIWAY-TREE
+;;                     :LABEL 3
+;;                     :CHILDREN (#S(MULTIWAY-TREE
+;;                                   :LABEL 2
+;;                                   :CHILDREN NIL)))
+;;                    #S(MULTIWAY-TREE
+;;                       :LABEL 1
+;;                       :CHILDREN NIL)))
+;;    #S(MULTIWAY-TREE
+;;       :LABEL 12
+;;       :CHILDREN (#S(MULTIWAY-TREE
+;;                     :LABEL 1
+;;                     :CHILDREN NIL)
+;;                    #S(MULTIWAY-TREE
+;;                       :LABEL 3
+;;                       :CHILDREN (#S(MULTIWAY-TREE
+;;                                     :LABEL 2
+;;                                     :CHILDREN NIL)))))
+;;    #S(MULTIWAY-TREE
+;;       :LABEL 13
+;;       :CHILDREN (#S(MULTIWAY-TREE
+;;                     :LABEL 1
+;;                     :CHILDREN NIL)
+;;                    #S(MULTIWAY-TREE
+;;                       :LABEL 1
+;;                       :CHILDREN NIL)
+;;                    #S(MULTIWAY-TREE
+;;                       :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 multiway-tree-total-path-length (tree so-far)
+  "
+SO-FAR 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 +)
+          (multiway-tree-children tree)
+          :key (lambda (node) (multiway-tree-total-path-length node (1+ so-far)))
+          :initial-value so-far))
+
+(defun ipl (tree)
+  (multiway-tree-total-path-length tree 0))
+
+(assert (= 9 (ipl (parse-multiway-tree-string "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 bottom-up order sequence of the tree nodes
+
+   Write a predicate bottom-up(Tree,Seq) which constructs the
+   bottom-up sequence of the nodes of the multiway tree Tree. Seq
+   should be a Prolog list. What happens if you run your predicate
+   backwords?
+"
+
+;; "Bottom-up 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 multiway-tree-postfix-order (tree)
+  "
+Returns a list of node labels in the postfix order.
+"
+  (reduce (function nconc)
+          (multiway-tree-children tree)
+          :key (function multiway-tree-postfix-order)
+          :initial-value (list (multiway-tree-label tree))
+          :from-end t))
+;; :from-end is needed so that the initial-value is placed on the right.
+;; It also proves beneficial since then the lists are walked only once per level.
+
+;; (multiway-tree-postfix-order (parse-multiway-tree-string "AFG^^C^BD^E^^^"))
+;; --> (G F C D E B A)
+
+
+(defun bottom-up (tree)
+  (multiway-tree-postfix-order 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 (**) Lisp-like 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 tree-ltl(T,LTL) which constructs the
+    \"lispy token list\" LTL if the tree is given as term T in the usual
+    Prolog notation.
+
+    Example:
+    * tree-ltl(t(a,[t(b,[]),t(c,[])]),LTL).
+    LTL = ['(', a, '(', b, c, ')', ')']
+
+    As a second, even more interesting exercise try to rewrite
+    tree-ltl/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")
+(use-package :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 multiway-tree 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 (multiway-tree
+             (:type list))
+  label
+  children)
+
+;; (parse-multiway-tree-string "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 process-leaves (tree)
+  (cond
+    ((empty-multiway-tree-p tree) tree)
+    ((endp (multiway-tree-children tree)) (multiway-tree-label tree))
+    (t (cons (multiway-tree-label tree)
+             (mapcar (function process-leaves)
+                     (multiway-tree-children tree))))))
+
+(assert (equal (process-leaves (parse-multiway-tree-string "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 my-prin1-to-string (object)
+  (let ((*print-circle*   nil)
+        (*print-case*     :upcase)
+        (*print-readably* nil)
+        (*print-pretty*   nil)
+        (*print-base*     10.)
+        (*print-radix*    nil)
+        (*print-level*    nil)
+        (*print-length*   nil)
+        (*print-lines*    nil))
+    (prin1-to-string object)))
+
+(defun tree-ltl (tree)
+  ;; How unfunny is that!
+  (coerce (remove #\space (my-prin1-to-string (process-leaves tree))) 'list))
+
+
+(assert (equal (tree-ltl (parse-multiway-tree-string "AFG^^C^BD^E^^^"))
+               '(#\( #\A #\( #\F #\G #\) #\C #\( #\B #\D #\E #\) #\))))
+
+
+;; We could also make the non-parenthesis characters back into symbols:
+
+(defun tree-ltl (tree)
+  (map 'list
+       (lambda (ch)
+         (if (alphanumericp ch)
+             (intern (string ch))
+             ch))
+       (remove #\space  (my-prin1-to-string (process-leaves tree)))))
+
+(assert (equal (tree-ltl (parse-multiway-tree-string "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 tree-ltl (tree)
+  (cond
+    ((empty-multiway-tree-p tree) "") ; should occur only when root is empty.
+    ((endp (multiway-tree-children tree))
+     (list (multiway-tree-label tree)))
+    (t (nconc
+        (list #\( (multiway-tree-label tree))
+        (mapcan (function tree-ltl)
+                (multiway-tree-children tree))
+        (list #\))))))
+
+
+(assert (equal (tree-ltl (parse-multiway-tree-string "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 pseudo-lexer 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 multiway-tree-parenthesized-string
+    :terminals ((label   "[^^]")) ; one char, not ^
+    :start tree
+    :rules ((--> tree
+                 (opt (alt par-node leaf))
+                 :action (if (null $1)
+                             (make-empty-multiway-tree)
+                             $1))
+                                        ; it's identity, but make-empty-multiway-tree
+                                        ; could be defined otherwise.
+            (--> par-node
+                 "(" label (rep tree) ")"
+                 :action (make-multiway-tree :label (read-from-string (second $2))
+                                             :children $3))
+            (--> leaf
+                 label
+                 :action (make-multiway-tree :label (read-from-string (second $1))))))
+
+(defun ltl-tree (ltl)
+  (parse-multiway-tree-parenthesized-string
+   (format nil "~{~A~}" ltl)))
+
+(assert (equal (ltl-tree '(#\( A #\( F G #\) C #\( B D E #\) #\)))
+               (parse-multiway-tree-string "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 multiway-tree-from-sexp (node)
+  (cond
+    ((null node) (make-empty-multiway-tree))
+    ((atom node) (make-multiway-tree :label node)) ; a leaf
+    (t (destructuring-bind (label &rest children) node
+         (make-multiway-tree :label label
+                             :children (mapcar (function multiway-tree-from-sexp)
+                                               children))))))
+
+(defun ltl-tree (ltl)
+  (multiway-tree-from-sexp (let ((*read-eval* nil)
+                                 (*read-base* 10.)
+                                 (*readtable* (copy-readtable nil)))
+                             (read-from-string (format nil "~{ ~A ~}" ltl)))
+                           ;; we get a list such as (A (F G) C (B D E))
+                           ))
+
+(assert (equal (ltl-tree '(#\( A #\( F G #\) C #\( B D E #\) #\)))
+               (parse-multiway-tree-string "AFG^^C^BD^E^^^")))
+
+
+;;;; THE END ;;;;
+
+
ViewGit