[racket] doubly linked list lib

Are you planning to put this on PLaneT?

Vincent


At Wed, 31 Aug 2011 11:46:34 +0200,
Marijn wrote:
> 
> [1  <multipart/signed (7bit)>]
> [1.1  <multipart/mixed (7bit)>]
> [1.1.1  <text/plain; ISO-8859-1 (quoted-printable)>]
> Hi Laurent,
> 
> On 08/30/11 09:18, Laurent wrote:
> > Thank you very much for this nice intermediate solution, though I need
> > constant-time append, split, insert, remove, + pointers to items, etc.
> > Mutation does seem unavoidable, right.
> 
> I implemented a doubly-linked list, not so long ago, connected to a GUI
> that can insert and delete items and saw no way to make the list
> functional with multiple simultaneous editors in the GUI. The
> implementation is as a straightforward cyclical doubly-linked list. I
> toyed with the idea of having a separate handle object to represent the
> list versus just the nodes, and there are some rudiments of that left in
> the code, but in the end the user code uses a special 'top element to
> indicate where the cyclical list is supposed to start.
> 
> Good luck,
> 
> Marijn
> [1.1.2 dlist.rkt <text/plain (base64)>]
> (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) , at 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 
> [1.1.3 list-editor.rkt <text/plain; UTF-8 (quoted-printable)>]
> #lang racket/gui
> 
> ;(require dlist)
> (require "./dlist.rkt")
> 
> (define list-editor%
>   (class vertical-panel%
>     (init init-values parent)
>     (super-new (parent parent))
>     
>     (define widget-list (dlist 'top))
>     
>     (define (redisplay)
>       (send this change-children (lambda (l) (cdr (for/list ((w widget-list)) w)))))
>     
>     (define (insert-item val link)
>       (let* ((v (new vertical-panel% (parent this)))
>              (lk (dl-insert v link))
>              (ins (new button% (parent v) (label "insert")
>                        (callback (λ (b e)
>                                    (insert-item "1" lk) (redisplay) )) ) )
>              (h (new horizontal-pane% (parent v)))
>              (t (new text-field% (parent h) (label "") (init-value val)))
>              (del (new button% (parent h) (label "del")
>                        (callback (λ (b e) (dl-remove lk) (send this delete-child v))) )))
>         lk))
>     
> ;    (send this begin-container-sequence)
>     (for ((v init-values)) (insert-item v widget-list))
> ;    (send this end-container-sequence)
>     
>     (let* ((v (new vertical-panel% (parent this)))
>            (lk (dl-insert v widget-list)))
>       (new button% (parent v) (label "append")
>            (callback (λ (b e) (insert-item "1" lk) (redisplay))) ))
>    
>     )) ; end define class
> 
> (define root (new frame% (label "List Editor") (stretchable-height #f)))
>   
> (new list-editor% (parent root) (init-values '("1" "2" "3")))
> 
> (send root show #t)
> [1.2 OpenPGP digital signature <application/pgp-signature (7bit)>]
> 
> [2  <text/plain; us-ascii (7bit)>]
> _________________________________________________
>   For list-related administrative tasks:
>   http://lists.racket-lang.org/listinfo/users