Yet Another Programming Challenge

Given a (cons) binary tree which may contain circularities/shared structure,
make a copy of it while preserving the circularities/shared structures.
For those not familiar with the Lisp, the definition of these terms are as follows:
Cons - a structure which contains 2 fields, we can call them car/cdr or first/rest (think of them as pointers/references)
Either field can either point to an atom (any other kind of object besides a cons), or other conses.
shared/structure circularity means that the same cons(pointer/reference) or even atoms may be reused,
for example, the binary tree could have a leaf pointing to the start of the tree itself,
or both the car and cdr of a cons could point to the same place.
Trying to just copy such trees recursively without taking proper care would either put you
in an infinite loop or destroy the shared structure (creating unique objects where there was a single reference)
Solutions in other languages besides Lisp are fine, however in statically typed languaged like C,
you may have to use an union with tag bits or something of that sort to be able to distinguish between atoms and conses.

I decided to use hashtables to detect shared structures and duplicate it, but my initial idea was terrible!


;(declaim (optimize (debug 3) (safety 3) (speed 1)))
;(setf *print-circle* t)

(defmacro with-gensyms (names &body body)
  `(let ,(loop for name in names collect `(,name ',(gensym (string name)))) ,@body))

(macrolet ((make-with-frob (name container-name binding-pair binding-form)
             (with-gensyms (bindings body x)
               `(defmacro ,name (,bindings ,container-name &body ,body)
                  `(symbol-macrolet
                       ,(mapcar #'(lambda (,x)
                                    (destructuring-bind ,binding-pair ,x ,binding-form))
                                ,bindings)
                     ,@,body)))))   
  (make-with-frob with-hash-keys hash-table (var key) `(,var (gethash ,key ,hash-table)))
  (make-with-frob with-array-indexes array (var index) `(,var (aref ,array ,index))))
 
(defstruct box value)
(defun box (value) (make-box :value value))
(defun value (box) (box-value box))

(defun make-reversed-hashtable (hashtable &rest args) 
  (let ((ht (apply #'make-hash-table args)))
    (maphash #'(lambda (key value) (setf (gethash value ht) key)) hashtable)
    ht))

(defun make-assoc-array (ht length)
  (let ((array (make-array length)))
    (maphash #'(lambda (hash value) (setf (aref array hash) value)) ht)
    array))

(defun copy-circular-tree (tree &optional (atom-copy-fun #'identity))
  "Copy a (cons) tree while preserving shared structure."
  (let ((cons-ht (make-hash-table :test #'eq))
        (data-ht (make-hash-table))
        reversed-data-ht
        data-assoc-array cons-array
        (index 0))
    (labels ((next-index () (prog1 index (incf index)))
             (fill-cons-ht (st)
               (let ((last-index index) 
                     al-value)
                 (with-hash-keys ((h st)) cons-ht
                   (cond
                     ((consp st)
                      (cond
                        (h (return-from fill-cons-ht h))
                        (t (setf h (next-index))                     
                           (destructuring-bind (car . cdr) st
                             (with-hash-keys ((left car) (right cdr)) cons-ht
                               (setf
                                al-value
                                (cons
                                 (if left left (fill-cons-ht car))
                                 (if right right (fill-cons-ht cdr)))))))))
                     (t (setf h (next-index)
                              al-value (box st))
                        last-index)))
                 (setf (gethash last-index data-ht) al-value)))            
             (initialize-cons-array (array)
               (let* ((length (length array))
                      (cons-array (make-array length)))
                 (dotimes (i length)
                   (setf
                    (aref cons-array i)                        
                    (etypecase (aref array i)
                      (cons (cons nil nil))
                      (box nil))))
                 cons-array))            
             (unbox-item (item)
               (with-hash-keys ((item-idx item)) reversed-data-ht
                 (with-array-indexes ((item-ref item-idx)) cons-array
                   (etypecase item
                     (cons                 
                      (destructuring-bind (car . cdr) item                       
                        (setf (car item-ref) (unbox-item car)
                              (cdr item-ref) (unbox-item cdr))
                        item-ref))
                     (box (setf item-ref (funcall atom-copy-fun (value item))))
                     (integer (aref cons-array item)))))))
      (fill-cons-ht tree)     
      (setf data-assoc-array (make-assoc-array data-ht index)
            reversed-data-ht (make-reversed-hashtable data-ht :test #'eq)
            cons-array (initialize-cons-array data-assoc-array))
      (unbox-item (aref data-assoc-array 0)))))

#|
(defparameter *a* '#1= (123 abc . #1#))
(defparameter *b* '#1= (a b c #2= (#1# #2# 3) #1# #2# . #1#))
(and (not (eq (copy-circular-tree *a*) *a*)) (not (eq (copy-circular-tree *b*) *b*)))
|#

This solution is quite convoluted, somewhat imperative and very wasteful(3 hash tables/2 arrays, even if they will be gc'ed early), but it works.
It's a completly terrible solution, even though somewhat flashy (macro-writing macros?!)
I'm ashamed I even wrote it before thinking the problem over. A lesson well learned,
One should always think the problem over before writing code.

After spending a few more minutes thinking, I came up with my second solution which is
much more efficient (only needs one hashtable), less wasteful and much smaller, it's still not the perfect solution:


(defun copy-circular-tree (tree &optional (atom-copy-fun #'identity))
  "Copy a cons tree while preserving shared structures."
  (let ((ht (make-hash-table :test #'eq)))
    (labels ((copy-rec (tree)
               (cond
                 ((consp tree)
                  (symbol-macrolet ((h (gethash tree ht)))
                    (unless h                                         
                      (destructuring-bind (car . cdr) tree
                        (setf h       (cons nil nil)
                              (car h) (copy-rec car)
                              (cdr h) (copy-rec cdr))))
                    h))
                 (t (funcall atom-copy-fun tree)))))
      (copy-rec tree))))

I hear there are even better solutions which don't involve the use of a coslty hash-table, I'm looking forward to how other /prog/riders will solve this!

following is my attempt at the solution as a valid FIOC program:

class Tree():
  left = None
  right = None
  def __init__(self, left, right):
    self.left = left
    self.right = right
  def copy(self):
    return Tree(self.left.copy() if isinstance(self.left, Tree) else self.left, self.right.copy() if isinstance(self.right, Tree) else self.right)

def CopyTree(tree):
  """A tree is an Acyclic graph therefore there can be no circularities/shared structure, no need to worry about that."""
  return tree.copy()

#example:
tree1 = Tree(Tree(1,2), 3)
print CopyTree(tree1).left.right

Copying trees without circularities can be easily done with (copy-tree tree) in CL. It's tricker if there are circularities/shared structures.

Lua (cons cell here is is a table with keys car and cdr).  In Lua strings and numbers are constants that aren't copied.  Also if a function argument isn't provided it is automatically nil.

function copyTree(t,newCells)
    if type(t) != "table" then return t end -- constant
    if newCells == nil then newCells = {} end
    local newCell = newCells[t]
    if newCell then return newCell end
    newCell = {}
    newCells[t] = newCell
    newCell.car = copyTree(t.car,newCells)
    newCell.cdr = copyTree(t.cdr,newCells)
    return newCell
end

(define (graph-copy g)
  (define marker (list 'marker))
  (define (graph-copy! g)
    (cond ((not (pair? g))
           g)
          ((eq? (car g) marker)
           (cadr g))
          (else       
           (let ((n (cons #f #f))
                 (a (car g))
                 (d (cdr g)))
             (set-car! g marker)
             (set-cdr! g (cons n (cons a d)))
             (set-car! n (graph-copy! a))
             (set-cdr! n (graph-copy! d))
             n))))
  (define (fixup! g)
    (cond
      ((and (pair? g) (eq? (car g) marker))
       (set-car! g (caddr g))
       (set-cdr! g (cdddr g))
       (fixup! (car g))
       (fixup! (cdr g)))))
  (let ((r (graph-copy! g)))
    (fixup! g)
    r))

; > (#%require scheme/shared)
; > (define x
;     (shared ((a (list 'a a b))
;              (b (list 'b b a)))
;       a))
; > (list (graph-copy x) x x)
; (#0=(a #0# #1=(b #1# #0#))
;  #2=(a #2# #3=(b #3# #2#))
;  #2#)