Top-down tree search & replace

Question

I'm having trouble coding a tree search & replace algorithm. The input tree contains arbitrarily nested data items--eg, tree = (1 (2 3 (4 (5)) 6)), where 1 is the root, and each level down is embedded in parentheses. So 1 is at level#1; 2, 3, 4, 6 are at level#2 (under 1), and 5 is at level#3 (under 4). The entire tree is structured such that the car of any list is always a data item, which can be followed by other data items or subtrees. The problem is to find a data item in the tree matching (#'equal in my specific case) an input item, and replace the existing old item with a given new subtree--eg, (exchange subtree olditem tree ...). The tree therefore grows with each replacement. However, the search must proceed top-down in the tree, exchanging only the first such olditem found, and then exit.

Some observations?: 1) For binary trees, the search order (top-down visitation) is normally called level-order, the other possible search orders being preorder, inorder, and postorder, but my trees are not necessarily binary. 2) Something like a breadth-first-search algorithm might work, but the nodes are selected by tree traversal, rather than being generated. 3) The standard "substitute" function works only for sequences, not trees. 4) The "subst" function works for trees, but seems to traverse in a depth-first manner replacing all matching items, and has no :count keyword (like "substitute" does) to stop after the first replacement.

Any help coding or even framing a good approach would be appreciated. (Also curious why common-lisp does not have more "tree" functions for both lists and vectors.)

Answer 1

Maybe I shouldn't be doing this, cause you are supposed to do your homework yourself, but it would take me longer to explain what to do, than to show it. Here is a breadth-first search and replace version:

(defun search-replace (item new-item lst)
  (when (listp lst)
    (let ((found-item (member item lst)))
      (if found-item
          (rplaca found-item new-item)
          (some #'(lambda (sublst) (search-replace item new-item sublst)) lst) ))))

This function is destructive, i.e., it will modify the original list, because it uses rplaca, and it won't return the resulting list (you can add it at the end). You can also add other nice features, such as a test function (equal or whichever you need). It will work also with lists whose car is a sublist (in your example it's always an atom). I hope it helps you get started.

Answer 2

@Leo. Like your concise solution--will have to study it for understanding. In the meantime here is another preliminary breadth-first search attempt:

(defun add-tree (newsubtree tree)
  (let ((queue (make-array 0 :adjustable t :fill-pointer t))
        (data (first newsubtree))
        (index 0))
    (vector-push-extend tree queue)
    (loop until (= index (fill-pointer queue))
        do (let ((current-node (elt queue index)))
             (incf index)
             (loop for child in (second current-node)
                 for i from 0
                 if (and (numberp child) (= child data))
                    do (setf (elt (second current-node) i) newsubtree)
                       (return-from add-tree tree)
                    else do (vector-push-extend child queue))))))

(add-tree '(2 (5 6)) '(0 ((1 (3 2 4)) 2)))
(0 ((1 (3 2 4)) (2 (5 6))))

Thanks for confirming my intuition that breadth-first was the way to approach this. (ps: this is not homework)

Answer 3

Here's a real breadth first search that actually does replace the shallowest leftmost occurrence. (Unfortunately @Leo's code, albeit slick, doesn't do that.)

For fun used a circular list as a queue:

(setf *print-circle* t)

(defun one-element-queue (item)
  (let ((link (list item)))
    (setf (cdr link) link)))

(defun enqueue (item &optional queue)
  (cond ((null queue) (one-element-queue item))
        (t (let ((new-link (cons item (cdr queue))))
             (setf (cdr queue) new-link)))))

(defun enqueue-all (items &optional queue)
  (dolist (item items queue) (setq queue (enqueue item queue))))

(defun dequeue (queue)
  (cond ((eq queue (cdr queue)) (values (car queue) nil))
        (t (let ((item (cadr queue)))
             (setf (cdr queue) (cddr queue))
             (values item queue)))))

(defun node-replace (new-item old-item node)
  (let ((position (position old-item node :test #'equal)))
    (when position (setf (nth position node) new-item))
    position))

(defun tree-replace (new-item old-item tree)
  (loop with queue = (enqueue tree) and node
        while queue
        do (multiple-value-setq (node queue) (dequeue queue))
        until (node-replace new-item old-item node)
        do (setq queue (enqueue-all (remove-if-not #'listp node) queue)))
  tree)

(setq tree '(1 ((5 ((41))) 3 (4 (5)) 5)))

(print (tree-replace 42 5 tree))