;;; Functional name maps
-;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
;;;
;;; This library is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
intmap-remove
intmap-ref
intmap-next
+ intmap-prev
+ intmap-fold
intmap-union
intmap-intersect))
(define-syntax-rule (define-inline name val)
(define-syntax name (identifier-syntax val)))
-(define-inline *branch-bits* 4)
+(define-inline *branch-bits* 5)
(define-inline *branch-size* (ash 1 *branch-bits*))
(define-inline *branch-mask* (1- *branch-size*))
;; Shouldn't be reached...
(else empty-intmap)))))
-(define (intmap-add bs i val meet)
+(define (meet-error old new)
+ (error "Multiple differing values and no meet procedure defined" old new))
+
+(define* (intmap-add bs i val #:optional (meet meet-error))
(define (adjoin i shift root)
(cond
((zero? shift)
(match bs
(($ <intmap> min shift root)
(cond
+ ((< i 0)
+ ;; The power-of-two spanning trick doesn't work across 0.
+ (error "Intmaps can only map non-negative integers." i))
((not val) (intmap-remove bs i))
((not root)
;; Add first element.
(define (intmap-ref bs i)
(match bs
(($ <intmap> min shift root)
- (and (<= min i) (< i (+ min (ash 1 shift)))
- (let ((i (- i min)))
- (let lp ((node root) (shift shift))
- (and node
- (if (= shift *branch-bits*)
- (vector-ref node (logand i *branch-mask*))
- (let* ((shift (- shift *branch-bits*))
- (idx (logand (ash i (- shift))
- *branch-mask*)))
- (lp (vector-ref node idx) shift))))))))))
+ (if (zero? shift)
+ (and (= i min) root)
+ (and (<= min i) (< i (+ min (ash 1 shift)))
+ (let ((i (- i min)))
+ (let lp ((node root) (shift shift))
+ (and node
+ (if (= shift *branch-bits*)
+ (vector-ref node (logand i *branch-mask*))
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift))
+ *branch-mask*)))
+ (lp (vector-ref node idx) shift)))))))))))
-(define (intmap-next bs i)
+(define* (intmap-next bs #:optional i)
(define (visit-branch node shift i)
(let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*)))
(and (< idx *branch-size*)
(let ((i (visit-node root shift i)))
(and i (+ min i))))))))
-(define (intmap-union a b meet)
+(define* (intmap-prev bs #:optional i)
+ (define (visit-branch node shift i)
+ (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*)))
+ (and (<= 0 idx)
+ (or (visit-node (vector-ref node idx) shift i)
+ (lp (1- (round-down i shift)) (1- idx))))))
+ (define (visit-node node shift i)
+ (and node
+ (if (zero? shift)
+ i
+ (visit-branch node (- shift *branch-bits*) i))))
+ (match bs
+ (($ <intmap> min shift root)
+ (let* ((i (if (and i (< i (+ min (ash 1 shift))))
+ (- i min)
+ (1- (ash 1 shift)))))
+ (and (<= 0 i)
+ (let ((i (visit-node root shift i)))
+ (and i (+ min i))))))))
+
+(define (intmap-fold f map seed)
+ (define (visit-branch node shift min seed)
+ (let ((shift (- shift *branch-bits*)))
+ (if (zero? shift)
+ (let lp ((i 0) (seed seed))
+ (if (< i *branch-size*)
+ (let ((elt (vector-ref node i)))
+ (lp (1+ i)
+ (if elt
+ (f (+ i min) elt seed)
+ seed)))
+ seed))
+ (let lp ((i 0) (seed seed))
+ (if (< i *branch-size*)
+ (let ((elt (vector-ref node i)))
+ (lp (1+ i)
+ (if elt
+ (visit-branch elt shift (+ min (ash i shift)) seed)
+ seed)))
+ seed)))))
+ (match map
+ (($ <intmap> min shift root)
+ (cond
+ ((not root) seed)
+ ((zero? shift) (f min root seed))
+ (else (visit-branch root shift min seed))))))
+
+(define* (intmap-union a b #:optional (meet meet-error))
;; Union A and B from index I; the result will be fresh.
(define (union-branches/fresh shift a b i fresh)
(let lp ((i 0))
((eq? root b-root) b)
(else (make-intmap a-min a-shift root)))))))))
-(define (intmap-intersect a b meet)
+(define* (intmap-intersect a b #:optional (meet meet-error))
;; Intersect A and B from index I; the result will be fresh.
(define (intersect-branches/fresh shift a b i fresh)
(let lp ((i 0))