git.fiddlerwoaroof.com
binary-tree.lisp
4aa3793c
 (defpackage :fwoar.binary-tree
   (:use :cl )
   (:export ))
 (in-package :fwoar.binary-tree)
 
 (fw.lu:defclass+ bt ()
   ((left :initarg :left :accessor left)
    (value :initarg :value :accessor value)
    (right :initarg :right :accessor right)))
 (defmethod print-object ((o bt) s)
   (format s "[~s < ~s > ~s]"
           (left o)
           (value o)
           (right o)))
 
 (defgeneric visit (client tree))
 (defun visit-in-order (client tree)
   (let ((left (left tree))
         (right (right tree)))
     (when left
       (visit-in-order client (left tree)))
     (visit client tree)
     (when right
       (visit-in-order client (right tree))))
   tree)
 
 (fw.lu:defclass+ counter ()
   ((value :initform 0 :accessor value)))
 (defmethod visit ((client counter) tree)
   (setf (value tree)
         (value client))
   (incf (value client)))
 
 (fw.lu:defclass+ stragglers ()
   ((elts :initarg :elts :accessor elts)))
 (defmethod visit ((client stragglers) tree)
   (declare (optimize (debug 3)))
   (fw.lu:with-accessors* (elts) client
     (when (and elts (null (left tree)))
       (let ((n-l (pop elts))
             (n-r (pop elts)))
         (setf (left tree) (bt nil n-l nil))
         (when n-r
           (setf (right tree) (bt nil n-r nil)))))))
 
 (defmethod visit ((client (eql :print)) tree)
   (fresh-line)
   (prin1 (value tree))
   (princ #\tab)
   (prin1 tree)
   (terpri))
 
 (defun dense-tree (levels cur)
   (if (null cur)
       (let ((layer (loop repeat (expt 2 (1- levels)) collect (bt nil nil nil))))
         (dense-tree (1- levels)
                     layer))
       (if (> levels 0)
           (dense-tree (1- levels)
                       (loop for (l r) on cur by #'cddr
                             collect (bt l nil r)))
           (car cur))))
 
 (defun complete-bt-of-size (n)
   (let* ((l2_n (log n 2))
          (height (ceiling l2_n))
          (max-node-count (1- (expt 2 height)))
          (full-bt-size (1- (expt 2 (1- height))))
          (leftovers (- n full-bt-size)))
     (values height max-node-count full-bt-size leftovers)))