Pascal J. Bourguignon [2011-01-07 07:20]
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 ;;;;
