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) ,@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
_________________________________________________
For list-related administrative tasks:
http://lists.racket-lang.org/listinfo/users
