Ensifer/scheme/enf.scm

; enf.scm -- pure Scheme enfilade reference
(define (make-enfilade) (vector 'enfilade '() '()))
(define (enfilade-children e) (vector-ref e 1))
(define (enfilade-values e) (vector-ref e 2))
(define (set-enfilade-children! e x) (vector-set! e 1 x))
(define (set-enfilade-values! e x) (vector-set! e 2 x))

(define (assoc-number k xs)
  (cond ((null? xs) #f)
        ((= k (caar xs)) (car xs))
        (else (assoc-number k (cdr xs)))))

(define (alist-put xs k v)
  (let ((p (assoc-number k xs)))
    (if p (begin (set-cdr! p v) xs) (cons (cons k v) xs))))

(define (alist-remove xs k)
  (cond ((null? xs) '())
        ((= k (caar xs)) (cdr xs))
        (else (cons (car xs) (alist-remove (cdr xs) k)))))

(define (insert-number n xs)
  (cond ((null? xs) (list n))
        ((<= n (car xs)) (cons n xs))
        (else (cons (car xs) (insert-number n (cdr xs))))))

(define (sort-numbers xs)
  (if (null? xs) '()
      (insert-number (car xs) (sort-numbers (cdr xs)))))

(define (unique-numbers xs)
  (cond ((null? xs) '())
        ((and (pair? (cdr xs)) (= (car xs) (cadr xs)))
         (unique-numbers (cdr xs)))
        (else (cons (car xs) (unique-numbers (cdr xs))))))

(define (tumbler-parse s)
  (if (= (string-length s) 0) '()
      (let loop ((i 0) (start 0) (out '()))
        (if (= i (string-length s))
            (reverse (cons (string->number (substring s start i)) out))
            (if (char=? (string-ref s i) #\.)
                (loop (+ i 1) (+ i 1)
                      (cons (string->number (substring s start i)) out))
                (loop (+ i 1) start out))))))

(define (tumbler->list t)
  (cond ((string? t) (tumbler-parse t))
        ((list? t) t)
        (else (error 'wrong-type-arg "tumbler must be a string or list"))))

(define (tumbler-compare a b)
  (let loop ((a (tumbler->list a)) (b (tumbler->list b)))
    (cond ((and (null? a) (null? b)) 0)
          ((null? a) -1)
          ((null? b) 1)
          ((< (car a) (car b)) -1)
          ((> (car a) (car b)) 1)
          (else (loop (cdr a) (cdr b))))))

(define (enfilade-get e key)
  (let ((v (assoc-number key (enfilade-values e)))
        (c (assoc-number key (enfilade-children e))))
    (append (if v (list (cdr v)) '())
            (if c (enfilade-get-range (cdr c)) '()))))

(define (enfilade-get-by-tumbler e t)
  (let loop ((node e) (parts (tumbler->list t)))
    (cond ((null? parts) (enfilade-get-range node))
          ((null? (cdr parts)) (enfilade-get node (car parts)))
          (else
           (let ((c (assoc-number (car parts) (enfilade-children node))))
             (if c (loop (cdr c) (cdr parts)) '()))))))

(define (enfilade-put-data e t datum)
  (let ((parts (tumbler->list t)))
    (if (null? parts) (error 'out-of-range "empty tumbler"))
    (let loop ((node e) (parts parts))
      (if (null? (cdr parts))
          (set-enfilade-values!
           node (alist-put (enfilade-values node) (car parts) datum))
          (let* ((k (car parts))
                 (p (assoc-number k (enfilade-children node)))
                 (child (if p (cdr p) (make-enfilade))))
            (if (not p)
                (set-enfilade-children!
                 node (alist-put (enfilade-children node) k child)))
            (loop child (cdr parts)))))
    datum))

(define (enfilade-empty? e)
  (and (null? (enfilade-children e)) (null? (enfilade-values e))))

(define (enfilade-remove e t)
  (let ((parts (tumbler->list t)))
    (if (null? parts) #f
        (let remove-at ((node e) (parts parts))
          (let ((k (car parts)))
            (if (null? (cdr parts))
                (if (assoc-number k (enfilade-values node))
                    (begin
                      (set-enfilade-values!
                       node (alist-remove (enfilade-values node) k))
                      #t)
                    #f)
                (let ((p (assoc-number k (enfilade-children node))))
                  (if (not p) #f
                      (let* ((child (cdr p))
                             (removed (remove-at child (cdr parts))))
                        (if (and removed (enfilade-empty? child))
                            (set-enfilade-children!
                             node (alist-remove (enfilade-children node) k)))
                        removed)))))))))

(define (enfilade-keys e)
  (unique-numbers
   (sort-numbers
    (append (map car (enfilade-values e))
            (map car (enfilade-children e))))))

(define (enfilade-get-range e . bounds)
  (let ((start (if (null? bounds) #f (car bounds)))
        (end (if (or (null? bounds) (null? (cdr bounds))) #f (cadr bounds))))
    (let loop ((ks (enfilade-keys e)) (out '()))
      (if (null? ks) out
          (let ((k (car ks)))
            (loop (cdr ks)
                  (if (and (or (not start) (>= k start))
                           (or (not end) (<= k end)))
                      (append out (enfilade-get e k))
                      out)))))))

; Example:
; (define e (make-enfilade))
; (enfilade-put-data e "1.2.3" 42)
; (enfilade-put-data e "1.2.4" 43)
; (enfilade-get-by-tumbler e "1.2") ; => (42 43)