(defstruct (tree-methods)
  empty-p leaf-p label children
  make-empty make-leaf make-tree)

(defmacro define-tree-function (name arguments)
  `(defun ,name ,arguments
     (funcall (,(intern (format nil "TREE-METHODS-~A"
                                (if (string= "TREE-" name :end2 5)
                                    (subseq (string name) 5)
                                    name)))
               *default-tree-interpretation*)
              ,@arguments)))

(define-tree-function tree-empty-p    (node))
(define-tree-function tree-leaf-p     (node))
(define-tree-function tree-label      (node))
(define-tree-function tree-children   (node))
(define-tree-function tree-make-empty ())
(define-tree-function tree-make-leaf  (label))
(define-tree-function tree-make-tree  (label children))


(defparameter *labelless-nary-tree*
  (make-tree-methods
   :empty-p    (function null)
   :leaf-p     (function atom)
   :label      (constantly nil)
   :children   (lambda (node) node)
   :make-empty (constantly nil)
   :make-leaf  (function identity)
   :make-tree  (lambda (label children)
                 (declare (ignore label))
                 children)))

(defparameter *default-tree-interpretation*  *labelless-nary-tree*)

(defun depth (tree)
  (cond
    ((tree-empty-p tree) 0)
    ((tree-leaf-p  tree) 1)
    (t (1+ (reduce (function max) (tree-children tree)
                   :key (function depth) :initial-value 0)))))

(depth (tree-make-empty))    ; -> 0
(depth (tree-make-leaf 'a))  ; -> 1
(depth (tree-make-tree nil (list (tree-make-leaf 'a) (tree-make-leaf 'b) (tree-make-leaf 'c)))) ; -> 2
(depth (tree-make-tree nil (list (tree-make-leaf 'a) (tree-make-tree nil (list (tree-make-leaf 'b))) (tree-make-leaf 'c)))) ; -> 3


(defun flatten-before-deepest (tree)
  (case (depth tree)
    ((0 1 2)     tree)
    ((3)         (tree-make-tree (tree-label tree)
                                 (mapcan (lambda (child)
                                           (if (tree-leaf-p child)
                                               (list child)
                                               (copy-list (tree-children child))))
                                         (tree-children tree))))
    (otherwise  (tree-make-tree (tree-label tree)
                                (mapcar (lambda (child)
                                          (flatten-before-deepest child))
                                        (tree-children tree))))))

(flatten-before-deepest (tree-make-tree nil (list (tree-make-leaf 'a) (tree-make-tree nil (list (tree-make-leaf 'b))) (tree-make-leaf 'c))))
;; -> (a b c)

(flatten-before-deepest
 ;; (a (b (c) d) e ((f g) h i) j)
 (tree-make-tree nil (list (tree-make-leaf 'a)
                           (tree-make-tree nil (list (tree-make-leaf 'b)
                                                     (tree-make-tree nil (list (tree-make-leaf 'c)))
                                                     (tree-make-leaf 'd)))
                           (tree-make-leaf 'e)
                           (tree-make-tree nil (list (tree-make-tree nil (list (tree-make-leaf 'f)
                                                                               (tree-make-leaf 'g)))
                                                     (tree-make-leaf 'h)
                                                     (tree-make-leaf 'i)))
                           (tree-make-leaf 'j))))
;; --> (a (b c d) e (f g h i) j)