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?