cursor.scm - holymoly - A tor enabled gopher client written in CHICKEN scheme
 (HTM) git clone git://vernunftzentrum.de/holymoly.git
 (DIR) Log
 (DIR) Files
 (DIR) Refs
 (DIR) README
 (DIR) LICENSE
       ---
       cursor.scm (2700B)
       ---
            1 (module cursor
            2 
            3 (cursor->list
            4  next-cursor!
            5  prev-cursor!
            6  empty-cursor?
            7  current-cursor
            8  list->cursor
            9  add-to-tail
           10  add-to-head)
           11 
           12 (import (chicken base) (chicken format) scheme srfi-1)
           13 
           14 (define-record cursor prev current next)
           15 
           16 (define-record-printer cursor
           17   (lambda (c p)
           18     (fprintf p
           19              "#<cursor (~a ->~a<- ~a)>"
           20              (reverse (cursor-prev c))
           21              (cursor-current c)
           22              (cursor-next c))))
           23 
           24 (define empty-element (gensym 'cursor))
           25 
           26 (define (next-cursor! c)
           27   (cond
           28    ((empty-cursor? c)
           29     (error "Cursor empty"))
           30    ((and (null? (cursor-next c))
           31          (null? (cursor-prev c)))
           32     (cursor-current c))
           33    ((null? (cursor-next c))
           34     (let* ((old-cur (cursor-current c))
           35            (new-next (reverse (cons old-cur (cursor-prev c)))))
           36       (cursor-current-set! c (car new-next))
           37       (cursor-next-set! c (cdr new-next))
           38       (cursor-prev-set! c '())))
           39    (else
           40     (cursor-prev-set! c (cons (cursor-current c) (cursor-prev c)))
           41     (cursor-current-set! c (car (cursor-next c)))
           42     (cursor-next-set! c (cdr (cursor-next c)))))
           43   (cursor-current c))
           44 
           45 (define (prev-cursor! c)
           46   (cond
           47    ((empty-cursor? c)
           48     (error "Cursor empty"))
           49    ((and (null? (cursor-next c))
           50          (null? (cursor-prev c)))
           51     (cursor-current c))
           52    ((null? (cursor-prev c))
           53     (let* ((old-cur (cursor-current c))
           54            (new-prev (reverse (cons old-cur (cursor-next c)))))
           55       (cursor-current-set! c (car new-prev))
           56       (cursor-prev-set! c (cdr new-prev))
           57       (cursor-next-set! c '())))
           58    (else
           59     (cursor-next-set! c (cons (cursor-current c) (cursor-next c)))
           60     (cursor-current-set! c (car (cursor-prev c)))
           61     (cursor-prev-set! c (cdr (cursor-prev c)))))
           62   (cursor-current c))
           63 
           64 (define (current-cursor c)
           65   (when (empty-cursor? c)
           66     (error "Cursor empty"))
           67   (cursor-current c))
           68 
           69 (define (list->cursor lst)
           70   (unless (list? lst)
           71     (error "not a list" lst))
           72   (if (null? lst)
           73       (make-cursor '() empty-element '())
           74       (make-cursor '() (car lst) (cdr lst))))
           75 
           76 (define (cursor->list c)
           77   (append (reverse (cursor-prev c))
           78           (list (cursor-current c))
           79           (cursor-next c)))
           80 
           81 (define (empty-cursor? c)
           82   (and (null? (cursor-prev c))
           83        (null? (cursor-next c))
           84        (eq? empty-element (cursor-current c))))
           85 
           86 (define (add-to-head c elem)
           87   (cond ((empty-cursor? c)
           88          (cursor-current-set! c elem))
           89         (else
           90          (cursor-prev-set! c
           91                            (append-reverse (cursor-prev c) (list elem))))))
           92 
           93 (define (add-to-tail c elem)
           94   (cond ((empty-cursor? c)
           95          (cursor-current-set! c elem))
           96         (else
           97          (cursor-next-set! c
           98                            (append (cursor-next c) (list elem))))))
           99 
          100 )