From: Pascal Bourguignon
Subject: Handling circular lists
Date: 
Message-ID: <87slzz3v6l.fsf@thalassa.informatimago.com>
While the dolist-checking-circular macro I previously posted do indeed
detect an circular list, it stops as soon as it does it, so the body
won't have the opportunity to process all the elements in the circular
list.

Instead here is a clist-from-list function that studies a list that is
either a proper list or a circular list (dotted list are not processed
but it could be added) and builds a structure keeping meta information
about the list.  This can then be used to walk the elements of the
circular list once, or to otherwise process the circular list.



(defun make-circular (list) (setf (cdr (last list)) list) list)
(setf *print-circle* t)


(defmacro dolist-checking-circular ((var list &optional result &body circular)
                                    &body body)
  (let ((current (gensym)) (forward (gensym)))
    `(loop for ,current = ,list          then (cdr ,current)
           for ,forward = (cdr ,current) then (cddr ,forward)
           while ,current
           do (if (eq ,forward ,current)
                (return
                 (let ((,var (car ,current)))
                   ,@circular))
                (let ((,var (car ,current)))
                  ,@body))
           finally (return ,result))))


(defparameter *tests*
  (list (list 1 2 3 4 5 6)
        (make-circular (list 1))
        (make-circular (list 1 2 3 4 5 6))
        (make-circular (list 1 2 3 4 5 6 7))
        (append '(a)             (make-circular (list 1)))
        (append '(a b c d e f g) (make-circular (list 1)))
        (append '(a b c d e f g) (make-circular (list 1 2 3 4 5 6)))
        (append '(a b c d e f g) (make-circular (list 1 2 3 4 5)))
        (append '(a b c d e f g) (make-circular (list 1 2 3 4)))
        (append '(a b c d e f)   (make-circular (list 1 2 3 4 5 6)))
        (append '(a b c d e f)   (make-circular (list 1 2 3 4 5)))
        (append '(a b c d e)     (make-circular (list 1 2 3 4 5)))))


(defun test-dolist-checking-circular ()
  (dolist (test *tests*)
    (print test) (terpri)
    (dolist-checking-circular (item test
                                    :not-circular
                                    (princ "Oops: circular!")(terpri)
                                    :circular)
      (prin1 item)(princ " "))
    (terpri)(terpri)))



(defun position-of-cons (cons list &key (start 0) (end nil) (test (function eq))
                              (key (function identity)))
  (loop for current = (nthcdr start list) then (cdr current)
        for index from start
        while (and (if end (and current (< index end)) current)
                   (not (funcall test cons (funcall key current))))
        finally (return (if (if end (and current (< index end)) current)
                          index
                          nil))))


(defun test-position-of-cons ()
  (dolist (test *tests*)
    (terpri)
    (dotimes (i 25)
      (format t "~:[  -~;~:*~3D~]" (position-of-cons (nthcdr i test) test)))))



(defstruct clist 
  prefix-head
  prefix-tail
  prefix-length
  circle-tail
  circle-length)
;; (zerop prefix-length) <=> (and (null prefix-head) (null prefix-tail))
;; (zerop circle-length) <=> (and (null circle-head) (null circle-tail))


(defun clist-circular-p (clist)
  (plusp (clist-circle-length clist)))


(defun clist-count (clist)
  (+ (clist-prefix-length clist) (clist-circle-length clist)))


(defun clist-length (clist)
  (if (zerop (clist-circle-length clist))
    (clist-prefix-length clist)
    :+infinity))


(defun clist-circle-head (clist)
  (cdr (clist-circle-tail clist)))
        

(defun clist-from-list (list)
  (loop
   with table   = (make-hash-table)
   with head    = (gensym "head")
   for previous = head then cursor
   for cursor   = list then (cdr cursor)
   for count from 0
   while cursor
   do
   (let ((circle (gethash cursor table)))
     (cond
      ((null circle)
       (setf (gethash cursor table) previous))
      ((eq head circle)                 ; no prefix
       (return
        (make-clist :prefix-head   nil
                    :prefix-tail   nil
                    :prefix-length 0
                    :circle-tail   previous
                    :circle-length (1+ (position-of-cons previous cursor)))))
      (t
       (return
        (make-clist :prefix-head   list
                    :prefix-tail   circle
                    :prefix-length (1+ (position-of-cons circle list))
                    :circle-tail   previous
                    :circle-length (1+ (position-of-cons previous cursor)))))))
   finally (return (make-clist :prefix-head   list
                               :prefix-tail   previous
                               :prefix-length (length list)
                               :circle-length 0))))
                                                         
                   
(defun test-clist-from-list ()
  (dolist (test *tests*)
    (terpri)
    (print (clist-from-list test))))


(defmacro doclist ((var clist &optional result) &body body)
  "
DO:     Iterate over each element in the clist once.
"
  (let ((list (gensym "list")) (current (gensym "current")))
    `(loop with ,list = ,clist
           repeat (clist-count ,list)
           for ,current = (or (clist-prefix-head ,list)
                              (clist-circle-head ,list)) then (cdr ,current)
           do (let ((,var (car ,current)))
                ,@body)
           finally (return ,result))))


(defun clist-elements (clist)
  (let ((result '()))
    (doclist (item clist (nreverse result)) (push item result))))



-- 
__Pascal Bourguignon__                     http://www.informatimago.com/

In a World without Walls and Fences, 
who needs Windows and Gates?