#-(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 coordinates, 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.
"
  (when (binary-tree-left node)
    (setf abscissa (layout-node-abscissa/inorder (binary-tree-left node) abscissa)))
  (setf (layout-binary-tree-x node) (incf abscissa))
  (when (binary-tree-right node)
    (setf abscissa (layout-node-abscissa/inorder (binary-tree-right node) abscissa)))
  abscissa)


(defun layout-binary-tree-p64 (tree)
  (let ((lobt (layout-node-depth tree 1)))
    (layout-node-abscissa/inorder lobt 0) ; starts from 1; use -1 to start from 0.
    lobt))



(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)
                 (3 (6 NIL NIL 5 3) (7 NIL NIL 7 3) 6 2)
                 4 1)))

(assert (equal (layout-binary-tree-p64   (construct '(n k c a h g e m u p s q) (function string<)))
               '(N (K (C (A NIL NIL 1 4)
                       (H (G (E NIL NIL 3 6)
                             NIL 4 5)
                          NIL 5 4)
                       2 3)
                    (M NIL NIL 7 3)
                    6 2)
                 (U (P NIL
                       (S (Q NIL NIL 10 5)
                          NIL 11 4)
                       9 3)
                    NIL 12 2)
                 8 1)))

(assert (equal (layout-binary-tree-p64   (construct '(n k c a e d g m u p q) (function string<)))
               '(N (K (C (A NIL NIL 1 4)
                       (E (D NIL NIL 3 5)
                          (G NIL NIL 5 5)
                          4 4)
                       2 3)
                    (M NIL NIL 7 3)
                    6 2)
                 (U (P NIL
                       (Q NIL NIL 10 4)
                       9 3)
                    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 ;;;;
ViewGit