#-(and) "

Apply the generate-and-test paradigm to construct all symmetric,
completely balanced binary trees with a given number of
nodes. Example:

* sym-cbal-trees(5,Ts).

Ts = [t(x, t(x, nil, t(x, nil, nil)), t(x, t(x, nil, nil), nil)),
t(x, t(x, t(x, nil, nil), nil), t(x, nil, t(x, nil, nil)))]

How many such trees are there with 57 nodes? Investigate about how
many solutions there are for a given number of nodes? What if the
number is even? Write an appropriate predicate.
"

(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,
;; 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))))))

(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.
(case number-of-nodes
(0 (list (make-empty-binary-tree)))
(1 (list (make-binary-tree :label (funcall next-label))))
(otherwise
(let ((subtrees (loop
:with subtrees = (make-array number-of-nodes)
:for i :from 0 :below number-of-nodes
:do (setf (aref subtrees i) (generate-binary-trees-of-nodes i next-label))
:finally (return subtrees))))
(loop
:for left :from 0 :below number-of-nodes
:for right = (- number-of-nodes left 1)
:nconc (mapcan (lambda (left-subtree)
(mapcar (lambda (right-subtree)
(make-binary-tree :label (funcall next-label)
:left left-subtree
:right right-subtree))
(aref subtrees right)))
(aref subtrees left)))))))

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

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

┌─── nil
╔═╧═╗
┌───╢ 2 ║
│   ╚═╤═╝
╔═╧═╗   └─── nil
┌───╢ 3 ║
│   ╚═╤═╝
╔═╧═╗   └─── nil
╢ 5 ║
╚═╤═╝
└─── nil

┌─── nil
╔═╧═╗
┌───╢ 4 ║
│   ╚═╤═╝   ┌─── nil
│     │   ╔═╧═╗
│     └───╢ 2 ║
│         ╚═╤═╝
│           └─── nil
╔═╧═╗
╢ 6 ║
╚═╤═╝
└─── nil

┌─── nil
╔═╧═╗
┌───╢ 1 ║
│   ╚═╤═╝
╔═╧═╗   └─── nil
╢ 7 ║
╚═╤═╝   ┌─── nil
│   ╔═╧═╗
└───╢ 1 ║
╚═╤═╝
└─── nil

┌─── nil
╔═╧═╗
╢ 8 ║
╚═╤═╝
│           ┌─── nil
│         ╔═╧═╗
│     ┌───╢ 2 ║
│     │   ╚═╤═╝
│   ╔═╧═╗   └─── nil
└───╢ 3 ║
╚═╤═╝
└─── nil

┌─── nil
╔═╧═╗
╢ 9 ║
╚═╤═╝   ┌─── nil
│   ╔═╧═╗
└───╢ 4 ║
╚═╤═╝   ┌─── nil
│   ╔═╧═╗
└───╢ 2 ║
╚═╤═╝
└─── nil

)
"

;; (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 5))
(

┌─── nil
╔═╧═╗
┌───╢ X ║
│   ╚═╤═╝   ┌─── nil
│     │   ╔═╧═╗
│     └───╢ X ║
│         ╚═╤═╝
│           └─── nil
╔═╧═╗
╢ X ║
╚═╤═╝
│           ┌─── nil
│         ╔═╧═╗
│     ┌───╢ X ║
│     │   ╚═╤═╝
│   ╔═╧═╗   └─── nil
└───╢ X ║
╚═╤═╝
└─── nil

┌─── nil
╔═╧═╗
┌───╢ X ║
│   ╚═╤═╝
╔═╧═╗   └─── nil
┌───╢ X ║
│   ╚═╤═╝
╔═╧═╗   └─── nil
╢ X ║
╚═╤═╝   ┌─── nil
│   ╔═╧═╗
└───╢ X ║
╚═╤═╝   ┌─── nil
│   ╔═╧═╗
└───╢ X ║
╚═╤═╝
└─── nil

)
CL-USER>

"

(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 ;;;;
ViewGit