Added laid out tree drawing function, and implemented p66.

Pascal J. Bourguignon [2011-01-10 09:12]
Added laid out tree drawing function, and implemented p66.
Filename
index.html
p54a.lisp
p64.lisp
p65.lisp
p66.lisp
diff --git a/index.html b/index.html
index 3991219..545db32 100644
--- a/index.html
+++ b/index.html
@@ -158,15 +158,6 @@ P60 (**) Construct height-balanced binary trees with a given number of nodes
     Find out how many height-balanced trees exist for N = 15.


-P66 (***) Layout a binary tree (3)
-                                                                                                                                                                                                                                   [p66]
-    Yet another layout strategy is shown in the illustration opposite. The method yields a very compact layout while maintaining a certain symmetry in every node. Find out the rules and write the corresponding Prolog predicate. Hint:
-    Consider the horizontal distance between a node and its successor nodes. How tight can you pack together two subtrees to construct the combined binary tree?
-
-    Use the same conventions as in problem P64 and P65 and test your predicate in an appropriate way. Note: This is a difficult problem. Don't give up too early!
-
-    Which layout do you like most?
-
 P67 (**) A string representation of binary trees
     [p67]

diff --git a/p54a.lisp b/p54a.lisp
index e86c567..bc91b0f 100644
--- a/p54a.lisp
+++ b/p54a.lisp
@@ -62,6 +62,13 @@ P54A (*) Check whether a given term represents a binary tree
 ;; (binary-tree-p (binary-tree-from-sexp '(a (b (d nil nil) (e nil nil)) (c nil nil))))


+(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))))))
+
+


 (defparameter *tree-0* 'nil)
diff --git a/p64.lisp b/p64.lisp
index 02e1498..00da85f 100644
--- a/p64.lisp
+++ b/p64.lisp
@@ -105,6 +105,49 @@ Returns the last abscissa used.



+(defun binary-tree-rightmost-node (tree)
+  (unless (binary-tree-empty-p tree)
+    (if (binary-tree-empty-p (binary-tree-right tree))
+        tree
+        (binary-tree-rightmost-node (binary-tree-right tree)))))
+
+
+(defun draw-laid-out-node (node picture)
+  (let* ((label  (princ-to-string (binary-tree-label node)))
+         (lab    (case (length label)
+                   ((0) " . ")
+                   ((1) (format nil " ~A " label))
+                   ((2) (format nil " ~A"  label))
+                   ((3) label)
+                   (otherwise (subseq label 0 3))))
+         (height (com.informatimago.common-lisp.picture.picture:height picture))
+         (2x     (* 2 (layout-binary-tree-x node)))
+         (2y     (- height (* 2 (layout-binary-tree-y node)))))
+    (com.informatimago.common-lisp.picture.picture:draw-string
+     picture (1- 2x) 2y lab)
+    (when (binary-tree-left node)
+      (com.informatimago.common-lisp.picture.picture:draw-string
+       picture (1- 2x) (1- 2y) "/")
+      (draw-laid-out-node (binary-tree-left node) picture))
+    (when (binary-tree-right node)
+      (com.informatimago.common-lisp.picture.picture:draw-string
+       picture (1+ 2x) (1- 2y) "\\")
+      (draw-laid-out-node (binary-tree-right node) picture))
+    picture))
+
+
+(defun draw-laid-out-tree (tree)
+  (let* ((height    (* 2 (binary-tree-height tree)))
+         (rightmost (binary-tree-rightmost-node tree))
+         (width     (* 4 (1+ (layout-binary-tree-x rightmost))))
+         ;;   N
+         ;;  / \
+         ;; K   U
+         (picture   (make-instance 'com.informatimago.common-lisp.picture.picture:picture
+                        :width width :height height)))
+    (draw-laid-out-node tree picture)))
+
+
 (assert (equal (layout-binary-tree-p64  (complete-binary-tree 7))
                '(1
                  (2 (4 NIL NIL 1 3) (5 NIL NIL 3 3) 2 2)
@@ -140,5 +183,43 @@ Returns the last abscissa used.
                     NIL 11 2)
                  8 1)))

+;; (list
+;;  (draw-laid-out-tree (layout-binary-tree-p64 (complete-binary-tree 7)))
+;;  (draw-laid-out-tree (layout-binary-tree-p64 (construct '(n k c a e d g m u p q)   (function string<))))
+;;  (draw-laid-out-tree (layout-binary-tree-p64 (construct '(n k c a h g e m u p s q) (function string<)))))
+;;
+;; (
+;;         1
+;;        / \
+;;     2       3
+;;    / \     / \
+;;   4   5   6   7
+;;
+;;
+;;                 N
+;;                / \
+;;             K         U
+;;            / \       /
+;;     C         M   P
+;;    / \             \
+;;   A     E           Q
+;;        / \
+;;       D   G
+;;
+;;
+;;                 N
+;;                / \
+;;             K           U
+;;            / \         /
+;;     C         M   P
+;;    / \             \
+;;   A       H           S
+;;          /           /
+;;         G           Q
+;;        /
+;;       E
+;; )
+
+
 ;;;; THE END ;;;;

diff --git a/p65.lisp b/p65.lisp
index c7780e1..c6cff5d 100644
--- a/p65.lisp
+++ b/p65.lisp
@@ -24,11 +24,6 @@ P65 (**) Layout a binary tree (2)
 (load "p54a")


-(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)
@@ -80,5 +75,41 @@ The abscissa of the children is offset by (expt 2 height).
                     NIL 23 2) 15 1)))


+;; (list
+;;  (draw-laid-out-tree (layout-binary-tree-p65 (complete-binary-tree 7)))
+;;  (draw-laid-out-tree (layout-binary-tree-p65 (construct '(n k c a e d g m u p q)   (function string<))))
+;;  (draw-laid-out-tree (layout-binary-tree-p65 (construct '(n k c a h g e m u p s q) (function string<)))))
+;;
+;; (
+;;         1
+;;        / \
+;;     2       3
+;;    / \     / \
+;;   4   5   6   7
+;;
+;;
+;;                               N
+;;                              / \
+;;               K                               U
+;;              / \                             /
+;;       C               M               P
+;;      / \                               \
+;;   A       E                               Q
+;;          / \
+;;         D   G
+;;
+;;
+;;                                                           N
+;;                                                          / \
+;;                           K                                                               U
+;;                          / \                                                             /
+;;           C                               M                               P
+;;          / \                                                               \
+;;   A               H                                                               S
+;;                  /                                                               /
+;;               G                                                               Q
+;;              /
+;;             E
+;; )

 ;;;; THE END ;;;;
diff --git a/p66.lisp b/p66.lisp
new file mode 100644
index 0000000..da4930a
--- /dev/null
+++ b/p66.lisp
@@ -0,0 +1,228 @@
+#-(and) "
+
+P66 (***) Layout a binary tree (3)
+
+    Yet another layout strategy is shown in the illustration
+    opposite. The method yields a very compact layout while
+    maintaining a certain symmetry in every node. Find out the rules
+    and write the corresponding Prolog predicate. Hint:
+
+    Consider the horizontal distance between a node and its successor
+    nodes. How tight can you pack together two subtrees to construct
+    the combined binary tree?
+
+    Use the same conventions as in problem P64 and P65 and test your
+    predicate in an appropriate way. Note: This is a difficult
+    problem. Don't give up too early!
+
+    Which layout do you like most?
+
+"
+
+
+;; The rule seems to be that the ordinate is the depth of the node,
+;; and the abscissa of a node is offset from the parent by at least
+;; one unit, more to accumodate the width of the subtrees, with the
+;; constraint that two nodes (possibly of different subtrees) be
+;; spaced by two units.
+;;
+;; The abscissa of the leftmost node is fixed to 1,
+;; and the ordinate of the root is fixed to 1.
+;;
+;; height of the tree = depth of node + height of node.
+
+
+
+
+;; to let subtrees come as close the possible one to the other, we
+;; will keep the left and right offsets for all levels below the node.
+;; The offsets are kept in a list from the child down to the leaves,
+;; relative to the node abscissa.
+
+(defstruct (jagged-layout-binary-tree (:include layout-binary-tree)
+                                      (:type list))
+  left-offsets right-offsets)
+
+
+
+(defun jag-layout-binary-tree (tree depth)
+  "
+Builds a jagged-layout-binary-tree homologue to TREE, with offsets
+computed to let subtrees be as close as possible.
+"
+  (if (binary-tree-empty-p tree)
+      (make-empty-binary-tree)
+      (if (binary-tree-empty-p (binary-tree-left tree))
+          (if (binary-tree-empty-p (binary-tree-right tree))
+              ;; leaf
+              (make-jagged-layout-binary-tree
+               :label (binary-tree-label tree)
+               :x 0
+               :y depth
+               :left-offsets '()
+               :right-offsets '())
+              ;; only right child.
+              (let ((right (jag-layout-binary-tree (binary-tree-right tree) (1+ depth))))
+                (make-jagged-layout-binary-tree
+                 :label (binary-tree-label tree)
+                 :x 0
+                 :y depth
+                 :right right
+                 :left-offsets  (cons 1 (mapcar (function 1+) (jagged-layout-binary-tree-left-offsets  right)))
+                 :right-offsets (cons 1 (mapcar (function 1+) (jagged-layout-binary-tree-right-offsets right))))))
+          (if (binary-tree-empty-p (binary-tree-right tree))
+              ;; only left child.
+              (let ((left (jag-layout-binary-tree (binary-tree-left tree) (1+ depth))))
+                (make-jagged-layout-binary-tree
+                 :label (binary-tree-label tree)
+                 :x 0
+                 :y depth
+                 :left left
+                 :left-offsets  (cons -1 (mapcar (function 1-) (jagged-layout-binary-tree-left-offsets  left)))
+                 :right-offsets (cons -1 (mapcar (function 1-) (jagged-layout-binary-tree-right-offsets left)))))
+              ;; both left and right children.
+              (let* ((left  (jag-layout-binary-tree (binary-tree-left  tree) (1+ depth)))
+                     (right (jag-layout-binary-tree (binary-tree-right tree) (1+ depth)))
+                     ;; 0         0
+                     ;;  \       /
+                     ;; right 2 left
+                     (offset (/ (+ 2 (reduce (function max)
+                                             (mapcar (function -)
+                                                     (jagged-layout-binary-tree-right-offsets left)
+                                                     (jagged-layout-binary-tree-left-offsets  right))
+                                             :initial-value 0))
+                                2)))
+                (make-jagged-layout-binary-tree
+                 :label (binary-tree-label tree)
+                 :x 0
+                 :y depth
+                 :left left
+                 :right right
+                 :left-offsets  (cons (- offset) (mapcar (lambda (x) (- x offset))
+                                                         (jagged-layout-binary-tree-left-offsets  left)))
+                 :right-offsets (cons (+ offset) (mapcar (lambda (x) (+ x offset))
+                                                         (jagged-layout-binary-tree-right-offsets right)))))))))
+
+
+(defun jagged-layout-binary-tree-complete-layout (tree offset)
+  (unless (binary-tree-empty-p tree)
+    (incf (layout-binary-tree-x tree) offset)
+    (when (binary-tree-left tree)
+      (jagged-layout-binary-tree-complete-layout
+       (binary-tree-left tree)
+       (+ offset (car (jagged-layout-binary-tree-left-offsets  tree)))))
+    (when (binary-tree-right tree)
+      (jagged-layout-binary-tree-complete-layout
+       (binary-tree-right tree)
+       (+ offset (car (jagged-layout-binary-tree-right-offsets tree)))))
+    tree))
+
+
+
+(defun layout-binary-tree-p66 (tree)
+  (let ((jtree (jag-layout-binary-tree tree 1)))
+    (jagged-layout-binary-tree-complete-layout jtree (- (reduce (function min)
+                                                                (jagged-layout-binary-tree-left-offsets jtree))))
+    jtree))
+
+
+;; (list
+;;  (draw-laid-out-tree (layout-binary-tree-p66 (complete-binary-tree 7)))
+;;  (draw-laid-out-tree (layout-binary-tree-p66 (construct '(n k c a e d g m u p q)   (function string<))))
+;;  (draw-laid-out-tree (layout-binary-tree-p66 (construct '(n k c a h g e m u p s q) (function string<)))))
+;;
+;; (
+;;       1
+;;      / \
+;;   2       3
+;;  / \     / \
+;; 4   5   6   7
+;;
+;;
+;;         N
+;;        / \
+;;     K       U
+;;    / \     /
+;;   C   M   P
+;;  / \       \
+;; A   E       Q
+;;    / \
+;;   D   G
+;;
+;;
+;;         N
+;;        / \
+;;     K       U
+;;    / \     /
+;;   C   M   P
+;;  / \       \
+;; A   H       S
+;;    /       /
+;;   G       Q
+;;  /
+;; E
+;; )
+
+
+
+;; I prefer draw-tree, which uses nice unicode characters, and rotates
+;; the tree 90 degree so that it can draw wider trees.  :-)
+;;
+;; (draw-tree (construct '(n k c a h g e m u p s q) (function string<)))
+;;
+;;
+;;         ┌─── nil
+;;       ╔═╧═╗
+;;   ┌───╢ U ║
+;;   │   ╚═╤═╝
+;;   │     │           ┌─── nil
+;;   │     │         ╔═╧═╗
+;;   │     │     ┌───╢ S ║
+;;   │     │     │   ╚═╤═╝   ┌─── nil
+;;   │     │     │     │   ╔═╧═╗
+;;   │     │     │     └───╢ Q ║
+;;   │     │     │         ╚═╤═╝
+;;   │     │     │           └─── nil
+;;   │     │   ╔═╧═╗
+;;   │     └───╢ P ║
+;;   │         ╚═╤═╝
+;;   │           └─── nil
+;; ╔═╧═╗
+;; ╢ N ║
+;; ╚═╤═╝
+;;   │           ┌─── nil
+;;   │         ╔═╧═╗
+;;   │     ┌───╢ M ║
+;;   │     │   ╚═╤═╝
+;;   │   ╔═╧═╗   └─── nil
+;;   └───╢ K ║
+;;       ╚═╤═╝
+;;         │           ┌─── nil
+;;         │         ╔═╧═╗
+;;         │     ┌───╢ H ║
+;;         │     │   ╚═╤═╝   ┌─── nil
+;;         │     │     │   ╔═╧═╗
+;;         │     │     └───╢ G ║
+;;         │     │         ╚═╤═╝   ┌─── nil
+;;         │     │           │   ╔═╧═╗
+;;         │     │           └───╢ E ║
+;;         │     │               ╚═╤═╝
+;;         │     │                 └─── nil
+;;         │     │
+;;         │   ╔═╧═╗
+;;         └───╢ C ║
+;;             ╚═╤═╝   ┌─── nil
+;;               │   ╔═╧═╗
+;;               └───╢ A ║
+;;                   ╚═╤═╝
+;;                     └─── nil
+
+
+
+;; No, really p66 is nice a compact layout, but it has the problem
+;; that it doesn't accomodate wider labels (and neither do p64, and
+;; p65).  Since draw-tree draws the labels perpendicularly, it doesn't
+;; have any problem with longer labels .
+
+
+;;;; THE END ;;;;
ViewGit