gistfile1.txt

(define-module data.ftree-map
  (use util.match)
  (use gauche.record)
  (use srfi-114)
  (export make-ftree-map ftree-map?
          ftree-map-empty?
          ftree-map-exists? ftree-map-get ftree-map-put)
  )
(select-module data.ftree-map)

;;
;; Internal implementation
;;
(define-record-type T #t #t color left elem right)
(define-record-type E #t #t)

(define *E* (make-E))

(define balance
  (match-lambda*
    [(or ('B ($ T 'R ($ T 'R a x b) y c) z d)
         ('B ($ T 'R a x ($ T 'R b y c)) z d)
         ('B a x ($ T 'R ($ T 'R b y c) z d))
         ('B a x ($ T 'R b y ($ T 'R c z d))))
     (make-T 'R (make-T 'B a x b) y (make-T 'B c z d))]
    [(color a x b)
     (make-T color a x b)]))

(define (get key tree cmpr)
  (and (not (E? tree))
       (match-let1 ($ T _ a p b) tree
         (if3 (comparator-compare cmpr key (car p))
              (get key a cmpr)
              p
              (get key b cmpr)))))

(define (insert key val tree cmpr)
  (define (ins tree)
    (if (E? tree)
      (make-T 'R *E* (cons key val) *E*)
      (match-let1 ($ T color a p b) tree
        (if3 (comparator-compare cmpr key (car p))
             (balance color (ins a) p b)
             (make-T color a (cons key val) b)
             (balance color a p (ins b))))))
  (match-let1 ($ T _ a p b) (ins tree)
    (make-T 'B a p b)))

;;
;; External interface
;;
(define-class <ftree-map> ()
  ((comparator :init-keyword :comparator)
   (tree :init-keyword :tree :init-form *E*)))

;; API
(define (ftree-map? x) (is-a? x <ftree-map>))

;; API
(define make-ftree-map
  (case-lambda
    [() (make-ftree-map default-comparator)]
    [(cmpr)
     (unless (comparator? cmpr)
       (error "comparator required, but got:" cmpr))
     (make <ftree-map> :comparator cmpr)]
    [(key=? key<?)
     (make-ftree-map (make-comparator #t key=?
                                      (^[a b]
                                        (cond [(key=? a b) 0]
                                              [(key<? a b) -1]
                                              [else 1]))
                                      #f))]))

;; API
(define (ftree-map-empty? ftree) (E? (~ ftree'tree)))

;; API
(define (ftree-map-exists? ftree key)
  (boolean (get key (~ ftree'tree) (~ ftree'comparator))))

;; API
(define (ftree-map-get ftree key :optional default)
  (if-let1 p (get key (~ ftree'tree) (~ ftree'comparator))
    (cdr p)
    (if (undefined? default)
      (errorf "No such key in a ftree-map ~s: ~s" ftree key)
      default)))

;; API
(define (ftree-map-put ftree key val)
  (make <ftree-map>
    :comparator (~ ftree'comparator)
    :tree (insert key val (~ ftree'tree) (~ ftree'comparator))))