utils.lisp

   1 (in-package :trees)
   2
   3 (defun for-each (func tree forwardp)
   4   (let ((iter (make-iterator tree :forwardp forwardp)))
   5     (declare (type function iter))
   6     (loop (multiple-value-bind (node morep) (funcall iter)
   7             (unless morep (return-from for-each (values)))
   8             (funcall func (datum node))))))
   9
  10 (defun tree-for-each (func tree)
  11   (for-each func tree t))
  12
  13 (defun reverse-tree-for-each (func tree)
  14   (for-each func tree nil))
  15
  16 ;;; We implement this directly in terms of iterators, rather than
  17 ;;; re-using TREE-FOR-EACH, so that we can provide for GO tags in the
  18 ;;; body of the loop, similarly to DO/DOTIMES/DOLIST.
  19 (defmacro dotree ((obj-var tree-var &optional return-value) &body body)
  20   (let ((node (gensym))
  21         (iter (gensym))
  22         (tree (gensym)))
  23   `(let* ((,tree ,tree-var)
  24           (,iter (make-iterator ,tree :forwardp t)))
  25      (declare (type function ,iter))
  26      (do ((,node (funcall ,iter) (funcall ,iter)))
  27          ((null ,node) ,return-value)
  28        (let ((,obj-var (datum ,node)))
  29          (tagbody
  30             ,@body))))))
  31
  32 #||
  33 (defmacro do-tree-range ((obj-var tree-var
  34                                   &key (type :key)
  35                                   (lower nil)
  36                                   (upper nil)) &body body)
  37   (macrolet ((invalid-type (type)
  38                `(error "Invalid :type supplied to DO-TREE-RANGE: ~A" ,type)))
  39     (let* ((node (gensym))
  40            (tree (gensym))
  41            (current (gensym))
  42            (stack (gensym))
  43            (iterator (gensym))
  44            (morep (gensym))
  45            (name (gensym))
  46            (last (gensym))
  47            (lower-exp (if lower
  48                           (cond
  49                             ((eq type :key)
  50                              `(upper-bound-node-with-path ,lower ,tree t))
  51                             ((eq type :index)
  52                              `(select-node-with-path ,tree ,lower))
  53                             (t (invalid-type type)))
  54                           (cond
  55                             ((or (eq type :key) (eq type :index))
  56                              `(minimum-node ,tree-var (root ,tree)))
  57                             (t (invalid-type type)))))
  58            (upper-exp (if upper
  59                           (cond
  60                             ((eq type :key)
  61                              `(upper-bound-node ,upper ,tree))
  62                             ((eq type :index)
  63                              `(select-node ,tree ,upper))
  64                             (t (invalid-type type)))
  65                           (cond
  66                             ((or (eq type :key) (eq type :index)) nil)
  67                             (t (invalid-type type))))))
  68       `(let ((,tree ,tree-var))
  69          (multiple-value-bind (,current ,stack) ,lower-exp
  70            (loop named ,name
  71               with ,iterator = (make-iterator ,tree :forwardp t
  72                                               :current ,current
  73                                               :stack ,stack)
  74               with ,last = ,upper-exp
  75               do (multiple-value-bind (,node ,morep) (funcall ,iterator)
  76                    (when (or (not ,morep)
  77                              (eq ,node ,last))
  78                      (return-from ,name))
  79                    (let ((,obj-var (datum ,node)))
  80                      (tagbody
  81                         ,@body)))))))))
  82
  83 ;;; FIXME: FROM-END isn't necessarily very intuitive here.  find out
  84 ;;; how regular CL sequence functions treat it (especially with indices)
  85 ;;; and rewrite the macro to match.
  86 (defmacro with-tree-iterator ((iter tree &key
  87                                     (from-end nil) (type :key) (start nil))
  88                               &body body)
  89   "Like WITH-HASH-TABLE-ITERATOR; ITER is a name defined via MACROLET
  90 and TREE is a form evaluated to produce a tree.  Successive calls to ITER
  91 return the items in the tree, one by one.
  92
  93  (ITER) two values.  The first is a boolean that is true if an object from
  94 the tree is returned; the second is an object stored in the tree.
  95
  96 TYPE can be either :KEY or :INDEX and defines how to interpret START.  If
  97 TYPE is :KEY and START is specified, then START is taken to be some key of
  98 the tree from which iteration should begin.  If no such key exists, then
  99 the next greatest key is chosen as the starting point.  If TYPE is :INDEX,
 100 and START is specified, then START is taken to be an index passed to
 101 SELECT-NODE to determine from what object iteration should begin.
 102
 103 If START is not specified, iteration begins from the minimum node of TREE.
 104
 105 FROM-END is currently broken and should not be used."
 106   (let ((treesym (gensym))
 107         (n-iter (gensym)))
 108     `(let ((,n-iter
 109             (let* ((,treesym ,tree)
 110                    (node ,(cond
 111                            ((eq type :key)
 112                             (if start
 113                                 `(lower-bound-node ,start ,treesym)
 114                                 `(minimum-node ,treesym (root-node ,treesym))))
 115                            ((eq type :index)
 116                             (if start
 117                                 `(select-node ,start ,treesym)
 118                                 `(minimum-node ,treesym (root-node ,treesym)))))))
 119               (labels ((,iter ()
 120                          (multiple-value-prog1
 121                              (values (not (null-node-p node ,treesym))
 122                                      (datum node))
 123                            (setf node (tree-successor node)))))
 124                 #',iter))))
 125        (macrolet ((,iter () '(funcall ,n-iter)))
 126          ,@body))))
 127 ||#
 128
 129 (defun reduce (tree function
 130                     &key key
 131                     (initial-value nil valuep)
 132                     (from-end nil))
 133   (let ((accum (if valuep
 134                    initial-value
 135                    (funcall function))))
 136     (flet ((left-reducer (object)
 137              (setf accum (funcall function accum (if key
 138                                                      (funcall key object)
 139                                                      object))))
 140            (right-reducer (object)
 141              (setf accum (funcall function (if key
 142                                                (funcall key object)
 143                                                object) accum))))
 144       (declare (dynamic-extent #'left-reducer #'right-reducer))
 145       (if from-end
 146           (reverse-tree-for-each #'right-reducer tree)
 147           (tree-for-each #'left-reducer tree))
 148       accum)))
 149
 150 (defun position (key tree &key from-end)
 151   (multiple-value-bind (node stack item-key) (find-insertion-point tree key)
 152     (declare (ignore item-key))
 153     (if (null node)
 154         node
 155         (loop with position = (1- (rank node))
 156            for entry in stack
 157            unless (eq (cdr entry) 'left)
 158            do (incf position (rank (car entry)))
 159            finally (return
 160                      (if from-end
 161                          (- (size tree) position)
 162                          position))))))