Added p61-p65.

Pascal J. Bourguignon [2011-01-07 07:20]
Added p61-p65.
Filename
draw-tree.lisp
figure-p64.png
figure-p65.png
figure-p66.png
figure-p67.png
index.html
p58.lisp
p61.lisp
p61a.lisp
p62.lisp
p62a.lisp
p63.lisp
p64.lisp
p65.lisp
diff --git a/draw-tree.lisp b/draw-tree.lisp
index acc60ce..a3092b5 100644
--- a/draw-tree.lisp
+++ b/draw-tree.lisp
@@ -1,5 +1,9 @@
 ;;;; -*- coding:utf-8 -*-

+(asdf:oos 'asdf:load-op :com.informatimago.common-lisp.cesarum)
+(asdf:oos 'asdf:load-op :com.informatimago.common-lisp.picture)
+
+
 ;; ─ ━ │ ┃ ┄ ┅ ┆ ┇ ┈ ┉ ┊ ┋ ┌ ┍ ┎ ┏ ┐ ┑ ┒ ┓ └ ┕ ┖ ┗ ┘ ┙ ┚ ┛ ├ ┝ ┞ ┟ ┠ ┡
 ;; ┢ ┣ ┤ ┥ ┦ ┧ ┨ ┩ ┪ ┫ ┬ ┭ ┮ ┯ ┰ ┱ ┲ ┳ ┴ ┵ ┶ ┷ ┸ ┹ ┺ ┻ ┼ ┽ ┾ ┿ ╀ ╁ ╂ ╃
 ;; ╄ ╅ ╆ ╇ ╈ ╉ ╊ ╋ ╌ ╍ ╎ ╏ ═ ║ ╒ ╓ ╔ ╕ ╖ ╗ ╘ ╙ ╚ ╛ ╜ ╝ ╞ ╟ ╠ ╡ ╢ ╣ ╤ ╥
diff --git a/figure-p64.png b/figure-p64.png
new file mode 100644
index 0000000..7bc6547
Binary files /dev/null and b/figure-p64.png differ
diff --git a/figure-p65.png b/figure-p65.png
new file mode 100644
index 0000000..430fc3e
Binary files /dev/null and b/figure-p65.png differ
diff --git a/figure-p66.png b/figure-p66.png
new file mode 100644
index 0000000..dc05307
Binary files /dev/null and b/figure-p66.png differ
diff --git a/figure-p67.png b/figure-p67.png
new file mode 100644
index 0000000..ac053bf
Binary files /dev/null and b/figure-p67.png differ
diff --git a/index.html b/index.html
index 808506c..3991219 100644
--- a/index.html
+++ b/index.html
@@ -8,7 +8,8 @@

 <p>Here are solutions to the
 <a href="http://www.ic.unicamp.br/~meidanis/courses/mc336/2006s2/funcional/L-99_Ninety-Nine_Lisp_Problems.html">
-L-99: Nintey-Nine Lisp Problems</a>, (which themselves are derived from a list of prolog problems).</p>
+L-99: Nintey-Nine Lisp Problems</a>, (which themselves are derived from
+<a href="http://www.scribd.com/doc/18339544/99-prolog-problems">a list of prolog problems</a>).</p>

 <h2>Working with lists</h2>
 <ul>
@@ -126,7 +127,6 @@ L-99: Nintey-Nine Lisp Problems</a>, (which themselves are derived from a list o
 <!--
 grep -n 'TO BE DONE' *.lisp
 p38.lisp:11:;; TO BE DONE.
-


 P59 (**) Construct height-balanced binary trees
@@ -157,69 +157,6 @@ P60 (**) Construct height-balanced binary trees with a given number of nodes

     Find out how many height-balanced trees exist for N = 15.

-P61 (*) Count the leaves of a binary tree
-    A leaf is a node with no successors. Write a predicate count-leaves/2 to count them.
-
-    % count-leaves(T,N) :- the binary tree T has N leaves
-
-P61A (*) Collect the leaves of a binary tree in a list
-    A leaf is a node with no successors. Write a predicate leaves/2 to collect them in a list.
-
-    % leaves(T,S) :- S is the list of all leaves of the binary tree T
-
-P62 (*) Collect the internal nodes of a binary tree in a list
-    An internal node of a binary tree has either one or two non-empty successors. Write a predicate internals/2 to collect them in a list.
-
-    % internals(T,S) :- S is the list of internal nodes of the binary tree T.
-
-P62B (*) Collect the nodes at a given level in a list
-    A node of a binary tree is at level N if the path from the root to the node has length N-1. The root node is at level 1. Write a predicate atlevel/3 to collect all nodes at a given level in a list.
-
-    % atlevel(T,L,S) :- S is the list of nodes of the binary tree T at level L
-
-    Using atlevel/3 it is easy to construct a predicate levelorder/2 which creates the level-order sequence of the nodes. However, there are more efficient ways to do that.
-
-P63 (**) Construct a complete binary tree
-    A complete binary tree with height H is defined as follows: The levels 1,2,3,...,H-1 contain the maximum number of nodes (i.e 2**(i-1) at the level i, note that we start counting the levels from 1 at the root). In level H, which
-    may contain less than the maximum possible number of nodes, all the nodes are "left-adjusted". This means that in a levelorder tree traversal all internal nodes come first, the leaves come second, and empty successors (the nil's
-    which are not really nodes!) come last.
-
-    Particularly, complete binary trees are used as data structures (or addressing schemes) for heaps.
-
-    We can assign an address number to each node in a complete binary tree by enumerating the nodes in levelorder, starting at the root with number 1. In doing so, we realize that for every node X with address A the following property
-    holds: The address of X's left and right successors are 2*A and 2*A+1, respectively, supposed the successors do exist. This fact can be used to elegantly construct a complete binary tree structure. Write a predicate
-    complete-binary-tree/2 with the following specification:
-
-    % complete-binary-tree(N,T) :- T is a complete binary tree with N nodes. (+,?)
-
-    Test your predicate in an appropriate way.
-
-P64 (**) Layout a binary tree (1)
-    Given a binary tree as the usual Prolog term t(X,L,R) (or nil). As a preparation for drawing the tree, a layout algorithm is required to determine the position of each node in a rectangular grid. Several layout methods are
-    conceivable, one of them is shown in the illustration below.
-
-    [p64]
-    In this layout strategy, the position of a node v is obtained by the following two rules:
-
-      □ x(v) is equal to the position of the node v in the inorder sequence
-      □ y(v) is equal to the depth of the node v in the tree
-
-    In order to store the position of the nodes, we extend the Prolog term representing a node (and its successors) as follows:
-
-    % nil represents the empty tree (as usual)
-    % t(W,X,Y,L,R) represents a (non-empty) binary tree with root W "positioned" at (X,Y), and subtrees L and R
-
-    Write a predicate layout-binary-tree/2 with the following specification:
-
-    % layout-binary-tree(T,PT) :- PT is the "positioned" binary tree obtained from the binary tree T. (+,?)
-
-    Test your predicate in an appropriate way.
-
-P65 (**) Layout a binary tree (2)
-    [p65]
-    An alternative layout method is depicted in the illustration opposite. Find out the rules and write the corresponding Prolog predicate. Hint: On a given level, the horizontal distance between neighboring nodes is constant.
-
-    Use the same conventions as in problem P64 and test your predicate in an appropriate way.

 P66 (***) Layout a binary tree (3)
                                                                                                                                                                                                                                    [p66]
diff --git a/p58.lisp b/p58.lisp
index e0d5cf7..2814ec4 100644
--- a/p58.lisp
+++ b/p58.lisp
@@ -18,9 +18,16 @@ P58 (**) Generate-and-test paradigm

 (load "p54a")
 (load "p55")
+(load "p56")
 (load "p57")
+
 (load "memoize")
 (use-package :org.tfeb.hax.memoize)
+(import 'alexandria:nconcf)
+
+(load "draw-tree") ; to dump trees in nice ASCII-ART.
+
+

 (defun generate-balanced-binary-trees-of-height (height next-label)
   ;; When next-label is a constant function,
@@ -54,6 +61,18 @@ P58 (**) Generate-and-test paradigm
                           h-1))
                 h-2))))))

+(memoize-function 'generate-balanced-binary-trees-of-height)
+
+
+
+
+;; The following function generates all the binary trees with a given
+;; number of nodes.  Even when memoized, this function is still O(e^n).
+;;
+;; It can be used to filter the wanted trees, but only with a number
+;; of node much less than 57: for 17 nodes it takes on the order of
+;; 10 minutes, much more for 18 nodes.
+
 (defun generate-binary-trees-of-nodes (number-of-nodes next-label)
   ;; When next-label is a constant function,
   ;; generate-binary-trees-of-nodes could be memoized.
@@ -77,15 +96,30 @@ P58 (**) Generate-and-test paradigm
                                    (aref subtrees right)))
                          (aref subtrees left)))))))

-(memoize-function 'generate-balanced-binary-trees-of-height)
 (memoize-function 'generate-binary-trees-of-nodes)

+(defun sym-cbal-trees (n)
+  (remove-if-not (lambda (tree)
+                   (and (binary-tree-symetric-p tree)
+                        (binary-tree-balanced-p tree)))
+                 (generate-binary-trees-of-nodes n (constantly 'x))))
+
+
+
+

-(load "draw-tree")
 #-(and)
 (mapcar 'draw-tree
         (generate-binary-trees-of-nodes 5 (let ((n 0)) (lambda () (incf n)))))

+#-(and)
+(progn
+  (defparameter *box*  *ascii-box*)
+  (defparameter *line* *ascii-line*))
+(progn
+  (defparameter *box*  *unicode-box*)
+  (defparameter *line* *unicode-line*))
+
 #-(and) "
 CL-USER> (mapcar 'draw-tree
                  (generate-binary-trees-of-nodes 3 (let ((n 0)) (lambda () (incf n)))))
@@ -167,169 +201,212 @@ CL-USER> (mapcar 'draw-tree
 "


-(defun sym-cbal-trees (n)
-  (remove-if-not (lambda (tree)
-                   (and (binary-tree-symetric-p tree)
-                        (binary-tree-balanced-p tree)))
-                 (generate-binary-trees-of-nodes n (constantly 'x))))
+;; (loop for i below 18 collect (cons i  (length (generate-binary-trees-of-nodes i (constantly 'x)))))
+;; ((0 . 1)
+;;  (1 . 1)
+;;  (2 . 2)
+;;  (3 . 5)
+;;  (4 . 14)
+;;  (5 . 42)
+;;  (6 . 132)
+;;  (7 . 429)
+;;  (8 . 1430)
+;;  (9 . 4862)
+;;  (10 . 16796)
+;;  (11 . 58786)
+;;  (12 . 208012)
+;;  (13 . 742900)
+;;  (14 . 2674440)
+;;  (15 . 9694845)
+;;  (16 . 35357670)
+;;  (17 . 129644790))
+
+
+

 #-(and)"

-CL-USER> (mapcar 'draw-tree (sym-cbal-trees 7))
-(
-        ┌─── nil
-      ╔═╧═╗
-  ┌───╢ X ║
-  │   ╚═╤═╝   ┌─── nil
-  │     │   ╔═╧═╗
-  │     └───╢ X ║
-  │         ╚═╤═╝   ┌─── nil
-  │           │   ╔═╧═╗
-  │           └───╢ X ║
-  │               ╚═╤═╝
-  │                 └─── nil
-  │
-╔═╧═╗
-╢ X ║
-╚═╤═╝
-  │
-  │                 ┌─── nil
-  │               ╔═╧═╗
-  │           ┌───╢ X ║
-  │           │   ╚═╤═╝
-  │         ╔═╧═╗   └─── nil
-  │     ┌───╢ X ║
-  │     │   ╚═╤═╝
-  │   ╔═╧═╗   └─── nil
-  └───╢ X ║
-      ╚═╤═╝
-        └─── nil
-
-
-
-        ┌─── nil
-      ╔═╧═╗
-  ┌───╢ X ║
-  │   ╚═╤═╝
-  │     │           ┌─── nil
-  │     │         ╔═╧═╗
-  │     │     ┌───╢ X ║
-  │     │     │   ╚═╤═╝
-  │     │   ╔═╧═╗   └─── nil
-  │     └───╢ X ║
-  │         ╚═╤═╝
-  │           └─── nil
-╔═╧═╗
-╢ X ║
-╚═╤═╝
-  │           ┌─── nil
-  │         ╔═╧═╗
-  │     ┌───╢ X ║
-  │     │   ╚═╤═╝   ┌─── nil
-  │     │     │   ╔═╧═╗
-  │     │     └───╢ X ║
-  │     │         ╚═╤═╝
-  │     │           └─── nil
-  │   ╔═╧═╗
-  └───╢ X ║
-      ╚═╤═╝
-        └─── nil
-

+CL-USER> (mapcar 'draw-tree (sym-cbal-trees 5))
+(
+
+        ┌─── nil
+      ╔═╧═╗
+  ┌───╢ X ║
+  │   ╚═╤═╝   ┌─── nil
+  │     │   ╔═╧═╗
+  │     └───╢ X ║
+  │         ╚═╤═╝
+  │           └─── nil
+╔═╧═╗
+╢ X ║
+╚═╤═╝
+  │           ┌─── nil
+  │         ╔═╧═╗
+  │     ┌───╢ X ║
+  │     │   ╚═╤═╝
+  │   ╔═╧═╗   └─── nil
+  └───╢ X ║
+      ╚═╤═╝
+        └─── nil
+
+
+
+
+
+              ┌─── nil
+            ╔═╧═╗
+        ┌───╢ X ║
+        │   ╚═╤═╝
+      ╔═╧═╗   └─── nil
+  ┌───╢ X ║
+  │   ╚═╤═╝
+╔═╧═╗   └─── nil
+╢ X ║
+╚═╤═╝   ┌─── nil
+  │   ╔═╧═╗
+  └───╢ X ║
+      ╚═╤═╝   ┌─── nil
+        │   ╔═╧═╗
+        └───╢ X ║
+            ╚═╤═╝
+              └─── nil
+

-
-              ┌─── nil
-            ╔═╧═╗
-        ┌───╢ X ║
-        │   ╚═╤═╝
-      ╔═╧═╗   └─── nil
-  ┌───╢ X ║
-  │   ╚═╤═╝   ┌─── nil
-  │     │   ╔═╧═╗
-  │     └───╢ X ║
-  │         ╚═╤═╝
-  │           └─── nil
-╔═╧═╗
-╢ X ║
-╚═╤═╝
-  │           ┌─── nil
-  │         ╔═╧═╗
-  │     ┌───╢ X ║
-  │     │   ╚═╤═╝
-  │   ╔═╧═╗   └─── nil
-  └───╢ X ║
-      ╚═╤═╝   ┌─── nil
-        │   ╔═╧═╗
-        └───╢ X ║
-            ╚═╤═╝
-              └─── nil
-
-
-
-
-
-              ┌─── nil
-            ╔═╧═╗
-        ┌───╢ X ║
-        │   ╚═╤═╝   ┌─── nil
-        │     │   ╔═╧═╗
-        │     └───╢ X ║
-        │         ╚═╤═╝
-        │           └─── nil
-      ╔═╧═╗
-  ┌───╢ X ║
-  │   ╚═╤═╝
-╔═╧═╗   └─── nil
-╢ X ║
-╚═╤═╝   ┌─── nil
-  │   ╔═╧═╗
-  └───╢ X ║
-      ╚═╤═╝
-        │           ┌─── nil
-        │         ╔═╧═╗
-        │     ┌───╢ X ║
-        │     │   ╚═╤═╝
-        │   ╔═╧═╗   └─── nil
-        └───╢ X ║
-            ╚═╤═╝
-              └─── nil
-
-
-
-
-
-
-                    ┌─── nil
-                  ╔═╧═╗
-              ┌───╢ X ║
-              │   ╚═╤═╝
-            ╔═╧═╗   └─── nil
-        ┌───╢ X ║
-        │   ╚═╤═╝
-      ╔═╧═╗   └─── nil
-  ┌───╢ X ║
-  │   ╚═╤═╝
-╔═╧═╗   └─── nil
-╢ X ║
-╚═╤═╝   ┌─── nil
-  │   ╔═╧═╗
-  └───╢ X ║
-      ╚═╤═╝   ┌─── nil
-        │   ╔═╧═╗
-        └───╢ X ║
-            ╚═╤═╝   ┌─── nil
-              │   ╔═╧═╗
-              └───╢ X ║
-                  ╚═╤═╝
-                    └─── nil
-
-
-
 )
 CL-USER>

 "
-;; (length (sym-cbal-trees 57))
+
+
+
+
+(defun generate-balanced-binary-trees-of-height (height next-label)
+  ;; When next-label is a constant function,
+  ;; generate-balanced-binary-trees-of-height could be memoized.
+  (case height
+    (0 (list (make-empty-binary-tree)))
+    (1 (list (make-binary-tree :label (funcall next-label))))
+    (otherwise
+     (let ((h-2 (generate-balanced-binary-trees-of-height (- height 2) next-label))
+           (h-1 (generate-balanced-binary-trees-of-height (- height 1) next-label)))
+       (nconc
+        (mapcan (lambda (left)
+                  (mapcar (lambda (right)
+                            (make-binary-tree :label (funcall next-label)
+                                              :left left
+                                              :right right))
+                          h-1))
+                h-1)
+        (mapcan (lambda (left)
+                  (mapcar (lambda (right)
+                            (make-binary-tree :label (funcall next-label)
+                                              :left left
+                                              :right right))
+                          h-1))
+                h-2)
+        (mapcan (lambda (right)
+                  (mapcar (lambda (left)
+                            (make-binary-tree :label (funcall next-label)
+                                              :left left
+                                              :right right))
+                          h-1))
+                h-2))))))
+
+
+
+(defun safe-aref (vector index)
+  (and (<= 0 index (1- (length vector))) (aref vector index)))
+
+(declaim (inline safe-aref))
+
+
+ (defun generate-balanced-binary-trees-of-nodes (number-of-nodes next-label)
+  "Returns all the balanced binary trees that have NUMBER-OF-NODES nodes,
+in an vector indexed by the height.
+"
+  ;; When next-label is a constant function,
+  ;; generate-balanced-binary-trees-of-nodes could be memoized.
+  (case number-of-nodes
+    (0 (vector (list (make-empty-binary-tree))))
+    (1 (vector '() (list (make-binary-tree :label (funcall next-label)))))
+    (otherwise
+
+     ;; First we get the balanced binary trees with all the number of
+     ;; nodes from 0 to (1- number-of-nodes).
+     ;;
+     ;; Then we will combine two of them each such that the sums of
+     ;; number of nodes (plus one for the root) is number-of-nodes,
+     ;; but taking care of the balancing.
+
+     (let ((subtrees (loop
+                        :with subtrees = (make-array number-of-nodes)
+                        :for i :from 0 :below number-of-nodes
+                        :do (setf (aref subtrees i)
+                                  (generate-balanced-binary-trees-of-nodes i next-label))
+                        :finally (return subtrees)))
+           ;; The results will be collected in this vector:
+           (byheight (make-array (1+ number-of-nodes) :initial-element '())))
+       (loop
+          :for left :from 0 :below number-of-nodes
+          :for right = (- number-of-nodes left 1)
+
+          :for left-byheight  = (aref subtrees left)
+          :for right-byheight = (aref subtrees right)
+
+          :do (assert (= (+ left right 1) number-of-nodes))
+
+          ;; Note, we could be smarter here, since given a number of
+          ;; nodes, there are minimum and maximum heights of tree you
+          ;; can build with them.  For now, we just loop over the
+          ;; heights, and check each time the existance of the
+          ;; subtrees:
+
+          :do (loop
+                 :for left-height    :from 0
+                 :for left-subtrees  :across left-byheight
+                 :when left-subtrees
+                 ;; Find right-subtrees of about the same height as
+                 ;; the left ones, and compute their cross product:
+                 :do (let ((above (safe-aref right-byheight (1+ left-height)))
+                           (level (safe-aref right-byheight     left-height))
+                           (below (safe-aref right-byheight (1- left-height))))
+                       (when (< (+ left-height 2) (length byheight))
+                         (nconcf (aref byheight (+ left-height 2))
+                                 (mapcan (lambda (right-subtree)
+                                           (mapcar (lambda (left-subtree)
+                                                     (make-binary-tree :label (funcall next-label)
+                                                                       :left left-subtree
+                                                                       :right right-subtree))
+                                                   left-subtrees))
+                                         above)))
+                       (nconcf (aref byheight (+ left-height 1))
+                                (mapcan (lambda (right-subtree)
+                                          (mapcar (lambda (left-subtree)
+                                                    (make-binary-tree :label (funcall next-label)
+                                                                      :left left-subtree
+                                                                      :right right-subtree))
+                                                  left-subtrees))
+                                        (append level below))))))
+       byheight))))
+
+(memoize-function 'generate-balanced-binary-trees-of-nodes)
+
+;; (map nil (lambda (l) (print l) (mapcar (lambda (n) (princ (draw-tree n)) (terpri)) l))
+;;      (generate-balanced-binary-trees-of-nodes 4 (constantly 'x)))
+
+(defun sym-cbal-trees (n)
+  (remove-if-not (lambda (tree)
+                   (and (binary-tree-symetric-p tree)
+                        (binary-tree-balanced-p tree)))
+                 (coerce
+                  (reduce (function nconc)
+                          (generate-balanced-binary-trees-of-nodes n (constantly 'x)))
+                  'list)))
+
+;; (loop :for i :below 58  :collect (time (cons i (length (sym-cbal-trees i)))))
+
+


 ;;;; THE END ;;;;
diff --git a/p61.lisp b/p61.lisp
new file mode 100644
index 0000000..d0ad38f
--- /dev/null
+++ b/p61.lisp
@@ -0,0 +1,48 @@
+#-(and) "
+
+P61 (*) Count the leaves of a binary tree
+    A leaf is a node with no successors. Write a predicate count-leaves/2 to count them.
+
+    % count-leaves(T,N) :- the binary tree T has N leaves
+
+"
+
+(load "p54a")
+(load "p55")
+(load "p56")
+(load "p57")
+
+
+(defun binary-tree-leaf-p (node)
+  (and (binary-tree-p node)
+       (binary-tree-empty-p (binary-tree-left  node))
+       (binary-tree-empty-p (binary-tree-right node))))
+
+
+;; Simple recursive solution:
+
+(defun count-leaves (tree)
+  (cond
+    ((binary-tree-empty-p tree)  0)
+    ((binary-tree-leaf-p  tree)  1)
+    (t (+ (count-leaves (binary-tree-left  tree))
+          (count-leaves (binary-tree-right tree))))))
+
+
+;; For very deep trees, here is a solution avoiding stack use:
+
+(defun count-leaves (tree)
+  (if (binary-tree-empty-p tree)
+      0
+      (loop
+         :with stack = (list tree)
+         :for node = (pop stack) :then (if (binary-tree-empty-p (binary-tree-left node))
+                                           (pop stack)
+                                           (binary-tree-left node))
+         :while node
+         :unless (binary-tree-empty-p (binary-tree-right node))
+         :do (push (binary-tree-right node) stack)
+         :when (binary-tree-leaf-p node) :count 1)))
+
+
+;;;; THE END ;;;;
diff --git a/p61a.lisp b/p61a.lisp
new file mode 100644
index 0000000..32a4ff1
--- /dev/null
+++ b/p61a.lisp
@@ -0,0 +1,100 @@
+#-(and) "
+
+
+P61A (*) Collect the leaves of a binary tree in a list
+    A leaf is a node with no successors. Write a predicate leaves/2 to collect them in a list.
+
+    % leaves(T,S) :- S is the list of all leaves of the binary tree T
+
+"
+
+(load "p61")
+
+
+;; Simple recursive solution:
+
+(defun collect-leaves (tree)
+  (cond
+    ((binary-tree-empty-p tree)  '())
+    ((binary-tree-leaf-p  tree)  (list tree))
+    (t (append (collect-leaves (binary-tree-left  tree))
+               (collect-leaves (binary-tree-right tree))))))
+
+
+;; For very deep trees, here is a solution avoiding stack use:
+
+(defun collect-leaves (tree)
+  (if (binary-tree-empty-p tree)
+      '()
+      (loop
+         :with stack = (list tree)
+         :for node = (pop stack) :then (if (binary-tree-empty-p (binary-tree-left node))
+                                           (pop stack)
+                                           (binary-tree-left node))
+         :while node
+         :unless (binary-tree-empty-p (binary-tree-right node))
+         :do (push (binary-tree-right node) stack)
+         :when (binary-tree-leaf-p node) :collect node)))
+
+
+
+;; Doesn't the comparison of p61 and p61a make cry?
+;; Here is a parameterized simple recursive solution:
+
+(defun reduce-tree (fun-node fun-leaf tree &key empty-tree-value)
+  (cond
+    ((binary-tree-empty-p tree)  empty-tree-value)
+    ((binary-tree-leaf-p  tree)  (funcall fun-leaf tree))
+    (t (funcall fun-node
+                tree
+                (reduce-tree fun-node fun-leaf (binary-tree-left  tree)
+                             :empty-tree-value empty-tree-value)
+                (reduce-tree fun-node fun-leaf (binary-tree-right tree)
+                             :empty-tree-value empty-tree-value)))))
+
+(defun count-leaves (tree)
+  (reduce-tree (lambda (node left right) (declare (ignore node)) (+ left right))
+               (lambda (leaf)            (declare (ignore leaf)) 1)
+               tree
+               :empty-tree-value 0))
+
+(defun collect-leaves (tree)
+  (reduce-tree (lambda (node left right) (declare (ignore node)) (append left right))
+               (function list)
+               tree
+               :empty-tree-value '()))
+
+
+;; And similarly, for very deep trees, here is a parameterized
+;; solution avoiding stack use:
+
+(defun reduce-leaves-of-tree (fun-leaf tree &key initial-value)
+  (if (binary-tree-empty-p tree)
+      initial-value
+      (loop
+         :with result = initial-value
+         :with stack = (list tree)
+         :for node = (pop stack) :then (if (binary-tree-empty-p (binary-tree-left node))
+                                           (pop stack)
+                                           (binary-tree-left node))
+         :while node
+         :unless (binary-tree-empty-p (binary-tree-right node))
+         :do (push (binary-tree-right node) stack)
+         :when (binary-tree-leaf-p node)
+         :do (setf result (funcall fun-leaf node result))
+         :finally (return result))))
+
+
+(defun count-leaves (tree)
+  (reduce-leaves-of-tree (lambda (leaf result) (+ 1 result)) tree :initial-value 0))
+
+
+(defun collect-leaves (tree)
+  (reverse (reduce-leaves-of-tree (function cons) tree :initial-value '())))
+
+
+;; By the way, notice how the initial recursive solution leads to a
+;; more general reduce-tree function.
+
+
+;;;; THE END ;;;;
diff --git a/p62.lisp b/p62.lisp
new file mode 100644
index 0000000..5a69282
--- /dev/null
+++ b/p62.lisp
@@ -0,0 +1,21 @@
+#-(and) "
+
+P62 (*) Collect the internal nodes of a binary tree in a list
+
+    An internal node of a binary tree has either one or two non-empty
+    successors. Write a predicate internals/2 to collect them in a
+    list.
+
+    % internals(T,S) :- S is the list of internal nodes of the binary tree T.
+"
+
+(load "p61a")
+
+;; Simple (trivial!) solution using reduce-tree defined in p61a:
+
+(defun collect-internal-nodes (tree)
+  (reduce-tree (lambda (node left right) (cons node (append left right)))
+               (constantly '()) tree :empty-tree-value '()))
+
+;;;; THE END ;;;;
+
diff --git a/p62a.lisp b/p62a.lisp
new file mode 100644
index 0000000..1faca1a
--- /dev/null
+++ b/p62a.lisp
@@ -0,0 +1,35 @@
+#-(and) "
+
+P62B (*) Collect the nodes at a given level in a list
+
+    A node of a binary tree is at level N if the path from the root to
+    the node has length N-1. The root node is at level 1. Write a
+    predicate atlevel/3 to collect all nodes at a given level in a
+    list.
+
+    % atlevel(T,L,S) :- S is the list of nodes of the binary tree T at level L
+
+    Using atlevel/3 it is easy to construct a predicate levelorder/2
+    which creates the level-order sequence of the nodes. However,
+    there are more efficient ways to do that.
+"
+
+;; Simple recursive solution:
+
+;; Notice the above definition use a 1-based index for the level.
+;; As always, this is a bad choice, hence the use of (= 1 level) instead of (zerop level).
+;; http://www.cs.utexas.edu/users/EWD/ewd08xx/EWD831.PDF
+
+
+(defun collect-nodes-at-level (tree level)
+  (cond
+    ((binary-tree-empty-p tree) '())
+    ((= 1 level)             (list tree))
+    (t  (append (collect-nodes-at-level (binary-tree-left  tree) (1- level))
+                (collect-nodes-at-level (binary-tree-right tree) (1- level))))))
+
+;; Note: nconc could be used instead of append, since all the lists
+;;       returned by collect-nodes-at-level are newly allocated lists.
+
+
+;;;; THE END ;;;;
diff --git a/p63.lisp b/p63.lisp
new file mode 100644
index 0000000..fd14a73
--- /dev/null
+++ b/p63.lisp
@@ -0,0 +1,50 @@
+#-(and) "
+
+P63 (**) Construct a complete binary tree
+
+    A complete binary tree with height H is defined as follows: The
+    levels 1,2,3,...,H-1 contain the maximum number of nodes (i.e
+    2**(i-1) at the level i, note that we start counting the levels
+    from 1 at the root). In level H, which may contain less than the
+    maximum possible number of nodes, all the nodes are
+    \"left-adjusted\". This means that in a levelorder tree traversal
+    all internal nodes come first, the leaves come second, and empty
+    successors (the nil's which are not really nodes!) come last.
+
+    Particularly, complete binary trees are used as data structures
+    (or addressing schemes) for heaps.
+
+    We can assign an address number to each node in a complete binary
+    tree by enumerating the nodes in levelorder, starting at the root
+    with number 1. In doing so, we realize that for every node X with
+    address A the following property holds: The address of X's left
+    and right successors are 2*A and 2*A+1, respectively, supposed the
+    successors do exist. This fact can be used to elegantly construct
+    a complete binary tree structure. Write a predicate
+    complete-binary-tree/2 with the following specification:
+
+    % complete-binary-tree(N,T) :- T is a complete binary tree with N nodes. (+,?)
+
+    Test your predicate in an appropriate way.
+
+"
+(load "p54a")
+
+(defun complete-binary-tree-upto (a n)
+  (make-binary-tree :label a
+                    :left  (if (<= (* 2 a) n)
+                               (complete-binary-tree-upto (* 2 a) n)
+                               (make-empty-binary-tree))
+                    :right (if (<= (1+ (* 2 a)) n)
+                               (complete-binary-tree-upto (1+ (* 2 a)) n)
+                               (make-empty-binary-tree))))
+
+
+(defun complete-binary-tree (n)
+  (complete-binary-tree-upto 1 n))
+
+
+;; (loop :for n :to 7 :do (princ (draw-tree (complete-binary-tree n))))
+
+
+;;;; THE END ;;;;
diff --git a/p64.lisp b/p64.lisp
new file mode 100644
index 0000000..fdadf63
--- /dev/null
+++ b/p64.lisp
@@ -0,0 +1,117 @@
+#-(and) "
+
+P64 (**) Layout a binary tree (1)
+
+    Given a binary tree as the usual Prolog term t(X,L,R) (or nil). As
+    a preparation for drawing the tree, a layout algorithm is required
+    to determine the position of each node in a rectangular
+    grid. Several layout methods are conceivable, one of them is shown
+    in the illustration below.
+
+    [p64]
+    In this layout strategy, the position of a node v is obtained by the following two rules:
+
+      □ x(v) is equal to the position of the node v in the inorder sequence
+      □ y(v) is equal to the depth of the node v in the tree
+
+    In order to store the position of the nodes, we extend the Prolog
+    term representing a node (and its successors) as follows:
+
+    % nil represents the empty tree (as usual)
+    % t(W,X,Y,L,R) represents a (non-empty) binary tree with root W
+    %  \"positioned\" at (X,Y), and subtrees L and R
+
+    Write a predicate layout-binary-tree/2 with the following specification:
+
+    % layout-binary-tree(T,PT) :- PT is the \"positioned\" binary tree
+    % obtained from the binary tree T. (+,?)
+
+    Test your predicate in an appropriate way.
+"
+
+(load "p54a")
+
+
+;; To add the coordinate, we create a new structure, which inherits
+;; from the binary-tree structure, so we can reuse that abstraction.
+;; However, including structures will make the new fields added at the
+;; end of it.  The order of the fields should be immaterial (only that
+;; we don't use true structures, but lists, so the new fields are
+;; added at the end of the lists, compared to the included list
+;; structures).
+
+(defstruct (layout-binary-tree (:include binary-tree)
+                               (:type list))
+  x y)
+
+
+
+(defun binary-tree-to-layout-binary-tree (tree)
+  "
+Return a layout-binary-tree homologue to node.
+"
+  (if (binary-tree-empty-p tree)
+      (make-empty-binary-tree)
+      (make-layout-binary-tree
+       :label (binary-tree-label tree)
+       :left  (binary-tree-to-layout-binary-tree (binary-tree-left  tree))
+       :right (binary-tree-to-layout-binary-tree (binary-tree-right tree)))))
+
+
+;; To layout the binary tree, we will do it in two steps.   First we
+;; make the layout tree, and setting the y field to the depth of each
+;; node.  Then we execute a infix walk of the new tree updating the x
+;; field of each node.
+
+(defun layout-node-depth (node depth)
+  "
+Return a layout-binary-tree homologue to node, with the ordinates of
+each node set to their depth.
+"
+  (if (binary-tree-empty-p node)
+      (make-empty-binary-tree)
+      (make-layout-binary-tree
+       :label (binary-tree-label node)
+       :y depth
+       :left  (layout-node-depth (binary-tree-left  node) (1+ depth))
+       :right (layout-node-depth (binary-tree-right node) (1+ depth)))))
+
+
+
+;; Note, incf is a prefix increment, it returns the new-value.
+;; Therefore it is easier to start with the predecessor of the first
+;; value, and to finally return the last value used.  One could define
+;; a postfix increment operator to easily write the code using the
+;; other convention.
+
+(defun layout-node-abscissa/inorder (node abscissa)
+  "
+Sets the abscissa of each node in the subtree NODE to a sequence of
+values starting from (1+ ABSCISSA) for the left-most node.
+Returns the last abscissa used.
+"
+  (cond
+    ((binary-tree-empty-p (binary-tree-left node))
+     (setf (layout-binary-tree-x node) (incf abscissa)))
+    ((binary-tree-empty-p (binary-tree-right node))
+     (setf (layout-binary-tree-x node)
+           (layout-node-abscissa/inorder (binary-tree-left node)
+                                         abscissa)))
+    (t
+     (layout-node-abscissa/inorder (binary-tree-right node)
+                                   (1+ (setf (layout-binary-tree-x node)
+                                             (layout-node-abscissa/inorder (binary-tree-left node)
+                                                                           abscissa)))))))
+
+(defun layout-binary-tree/inorder/depth (tree)
+  ""
+  (let ((lobt (layout-node-depth tree 0)))
+    (layout-node-abscissa/inorder lobt 0) ; starts from 1; use -1 to start from 0.
+    lobt))
+
+
+;; (layout-binary-tree/inorder/depth  (complete-binary-tree 5))
+
+
+;;;; THE END ;;;;
+
diff --git a/p65.lisp b/p65.lisp
new file mode 100644
index 0000000..0f340f7
--- /dev/null
+++ b/p65.lisp
@@ -0,0 +1,54 @@
+#+(and) "
+P65 (**) Layout a binary tree (2)
+    [p65]
+
+    An alternative layout method is depicted in the illustration
+    opposite. Find out the rules and write the corresponding Prolog
+    predicate. Hint: On a given level, the horizontal distance between
+    neighboring nodes is constant.
+
+    Use the same conventions as in problem P64 and test your predicate in an appropriate way.
+
+"
+
+(defun binary-tree-height (tree)
+  (if (binary-tree-empty-p tree)
+      0
+      (+ 1 (max (binary-tree-height (binary-tree-left tree))
+                (binary-tree-height (binary-tree-right tree))))))
+
+(defun binary-tree-count-leftmosts (tree)
+  (if (binary-tree-empty-p tree)
+      0
+      (+ 1 (binary-tree-count-leftmosts (binary-tree-left tree)))))
+
+
+(defun layout-node-p65 (node abscissa depth height)
+  "
+The abscissa of the NODE is given by ABSCISSA, and the ordinate by DEPTH.
+The abscissa of the children is offset by (expt 2 height).
+"
+  (setf (layout-binary-tree-x node) abscissa
+        (layout-binary-tree-y node) depth)
+  (let ((offset (expt 2 height)))
+    (unless (binary-tree-empty-p (binary-tree-left node))
+      (layout-node-p65 (binary-tree-left node)
+                       (- abscissa offset)
+                       (1+ depth)
+                       (1- height)))
+    (unless (binary-tree-empty-p (binary-tree-right node))
+      (layout-node-p65 (binary-tree-right node)
+                       (+ abscissa offset)
+                       (1+ depth)
+                       (1- height))))
+  node)
+
+
+(defun layout-binary-tree-p65 (tree)
+  (let ((height (binary-tree-height tree)))
+    (layout-node-p65 (binary-tree-to-layout-binary-tree tree)
+                     (expt 2  height)
+                     0
+                     height)))
+
+;;;; THE END ;;;;
ViewGit