(module dlist racket
  (provide dlist dl-insert dl-insert-right dl-remove for/dlist)
  
  (require (for-syntax racket))
  
  (define (dl-print dl p write?)
    (let ((print (if write? write display)))
      (display #\( p)
      (let loop ((l dl))
        (print (_dl-val l) p)
        (let ((right (_dl-right l)))
          (if (eq? right dl)
              (display #\) p)
              (begin (display " " p) (loop right)) )))))

  (define (dl-sequence l)
    (if (dl-empty? l)
        (make-do-sequence (lambda () (values #f #f #f (lambda (lk) #f) #f #f)))
        (let ((last (_dl-left l)))
          (make-do-sequence
           (lambda () ; val    next  start        last?
             (values _dl-val _dl-right l #f #f (lambda (lk v) (not (eq? lk last)))) )))))
  
  ;;; link
  (define-struct _dl (left val right) #:mutable
    #:property prop:custom-write dl-print
    #:property prop:sequence dl-sequence
    ) ; end link

  (define (dlh-print dlh p write?)    
    (dl-print (_dlh-link dlh) p write?))

  (define (dlh-sequence l)
    (let ((h (_dlh-link l)))
      (make-do-sequence
       (lambda () ; val    next       start        last?
         (values _dl-val _dl-right (_dl-right h) (lambda (lk) (not (eq? lk h))) #f #f) ))))
  
  ;;; list handle
  (struct _dlh (link) #:mutable
    #:property prop:custom-write dlh-print
    #:property prop:sequence dlh-sequence
    ) ; end handle
  
  (define (dl-empty)
    (_dl #f #f #f))
  
  (define (dlh-empty)
    (_dlh (dl-empty)))
  
  (define (dl-empty? l)
    (not (_dl-left l)))

  (define (dl-one-element? l)
    (eq? l (_dl-left l)))
  
  (define (dlh-empty? l)
    (dl-empty? (_dlh-link l)))
    
;  (define (dlist a b c)
 ;   (shared ((la (_dl #f a lb))
  ;           (lb (_dl la b lc))
   ;          (lc (_dl lb c #f)) )
    ;  la))
  
  (define-syntax (dlist stx)
    (syntax-case stx ()
      ((_) #'(dl-empty))
      ((_ a b ...)
       (let* ((temps (generate-temporaries #'(a b ...))) (links `(,(last temps) ,@temps ,(first temps))))
         #`(shared
               #,(let loop ((ret '()) (links links) (vals (syntax->list #'(a b ...))))
                   (if (empty? vals) (reverse ret)
                       (loop (cons #`(#,(cadr links) (make-_dl #,(car links) #,(car vals) #,(caddr links))) ret)
                             (cdr links) (cdr vals) )))
             #,(cadr links))))))

  (define-syntax-rule (dlisth a b ...) (_dlh (dlist #f a b ...)))    
  
  (define-syntax-rule (_dl-insert val link link-next new-link set-link-next! set-link-prev!)
    (if (dl-empty? link) (dlist val)
        (let* ((next (link-next link)) (new (new-link link val next)))
          (set-link-next! link new)
          (and next (set-link-prev! next new))
          new)))
  
  (define (dl-insert-right v l)
    (_dl-insert v l _dl-right _dl set-_dl-right! set-_dl-left!))
  
  (define (dl-insert v l)
    (let-syntax ((dl (syntax-rules () ((_ r v l) (_dl l v r)))))
      (_dl-insert v l _dl-left dl set-_dl-left! set-_dl-right!)))

  (define-syntax-rule (_dlh-insert v l insert)
    (let ((h (_dlh-link l)))
      (if h
          (insert v h)
          (set-_dlh-link! l (dlist v)) )))
    
  (define (dlh-insert-front v l)
    (_dlh-insert v l dl-insert-right))
  
  (define (dlh-insert-back v l)
    (_dlh-insert v l dl-insert))
  
  (define (dl-remove link (ret #f))
    (if (or (dl-empty? link) (dl-one-element? link))
        (dl-empty)
        (let ((l (_dl-left link)) (r (_dl-right link)))
          (set-_dl-right! l r)
          (set-_dl-left! r l)
          (if ret l r))))
  
  (define (dl-reverse link)
    (if (dl-empty? link) (dl-empty)
        (let ((left (_dl-left link)) (right (_dl-right link)))
          (set-_dl-right! link left)
          (set-_dl-left! link right)
          (let loop ((lft link) (lnk right))
            (if (eq? lnk link) left
                (let ((rght (_dl-right lnk)))
                  (set-_dl-right! lnk lft)
                  (set-_dl-left! lnk rght)
                  (loop lnk rght)))))))
  
;  (define (dlh-reverse l)
          
  (define-syntax-rule (for/dlist clauses body ... val)
    (_dl-right (for/fold ((ret (dl-empty))) clauses (dl-insert-right val ret))))
  
  ) ; end module