suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add more operations to fxmap

Browse Source 
original commit: 304cc0adc4dc881dea4d17695b73bf345da07dca
This commit is contained in:
Gustavo Massaccesi 2017-10-07 20:07:05 -03:00
parent 1a5f731752
commit b2f9a3e11f
1 changed files with 201 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

248
s/fxmap.ss
View File

@ -1,3 +1,18 @@
;;; fxmap.ss
;;; Copyright 1984-2017 Cisco Systems, Inc.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
;; Based on Okasaki and Gill's "Fast Mergeable Integer Maps" (1998).
(module fxmap
@ -8,23 +23,29 @@
fxmap-ref
fxmap-set
fxmap-remove
fxmap-merge
fxmap-remove/base
fxmap-reset/base
fxmap-advance/base
fxmap-for-each
fxmap-for-each/diff
fxmap-changes
;; internals
$branch? make-$branch $branch-prefix $branch-mask $branch-left $branch-right
$leaf? make-$leaf $leaf-key $leaf-val
$empty?)
; $branch? make-$branch $branch-prefix $branch-mask $branch-left $branch-right
; $leaf? make-$leaf $leaf-key $leaf-val
; $empty? make-$empty
)
;; record types
(define-record-type $branch
[fields prefix mask left right]
[nongenerative #{$branch pfv8jpsat5jrk6vq7vclc3ntg-0}]
[fields prefix mask left right count changes]
[nongenerative #{$branch pfv8jpsat5jrk6vq7vclc3ntg-1}]
[sealed #t])
(define-record-type $leaf
[fields key val]
[nongenerative #{$leaf pfv8jq2dzw50ox4f6vqm1ff5v-0}]
[fields key val changes]
[nongenerative #{$leaf pfv8jq2dzw50ox4f6vqm1ff5v-1}]
[sealed #t])
(define-record-type $empty
@ -42,69 +63,93 @@
($leaf? x)
($empty? x)))
;; count & empty
;; count, changes & empty
(define (fxmap-count d)
(let loop ([d d] [n 0])
(cond [($branch? d)
(let ([nl (loop ($branch-left d) n)])
(loop ($branch-right d) nl))]
[($leaf? d) (fx1+ n)]
[else n])))
(cond
[($branch? d)
($branch-count d)]
[($leaf? d) 1]
[else 0]))
(define (fxmap-changes d)
(cond
[($branch? d)
($branch-changes d)]
[($leaf? d)
($leaf-changes d)]
[else 0]))
(define fxmap-empty? $empty?)
;; ref
(define (fxmap-ref/leaf d key)
(cond
[($branch? d)
(let-branch ([(p m l r) d])
(cond
[(fx<= key p)
(fxmap-ref/leaf l key)]
[else
(fxmap-ref/leaf r key)]))]
[($leaf? d)
(if (fx= key ($leaf-key d))
d
#f)]
[else
#f]))
(define (fxmap-ref d key default)
(cond [($branch? d)
(if (fx<= key ($branch-prefix d))
(fxmap-ref ($branch-left d) key default)
(fxmap-ref ($branch-right d) key default))]
(let ([d (fxmap-ref/leaf d key)])
(if d
($leaf-val d)
default)))
[($leaf? d)
(if (fx= key ($leaf-key d))
($leaf-val d)
default)]
[else
default]))
(define (fxmap-ref/changes d key)
(let ([d (fxmap-ref/leaf d key)])
(if d
($leaf-changes d)
0)))
;; set
(define (fxmap-set d key val)
(define (fxmap-set/changes d key val changes)
(cond
[($branch? d)
(let ([p ($branch-prefix d)]
[m ($branch-mask d)])
(let-branch ([(p m l r) d])
(cond
[(nomatch? key p m)
(join key (make-$leaf key val) p d)]
(join key (make-$leaf key val (or changes 1)) p d)]
[(fx<= key p)
(br p m (fxmap-set ($branch-left d) key val) ($branch-right d))]
(br p m (fxmap-set/changes l key val changes) r)]
[else
(br p m ($branch-left d) (fxmap-set ($branch-right d) key val))]))]
(br p m l (fxmap-set/changes r key val changes))]))]
[($leaf? d)
(let ([k ($leaf-key d)])
(if (fx= key k)
(make-$leaf key val)
(join key (make-$leaf key val) k d)))]
(make-$leaf key val (or changes (fx+ ($leaf-changes d) 1)))
(join key (make-$leaf key val (or changes 1)) k d)))]
[else
(make-$leaf key val)]))
(make-$leaf key val (or changes 1))]))
(define (fxmap-set d key val)
(fxmap-set/changes d key val #f))
;; remove
(define (fxmap-remove d key)
(cond
[($branch? d)
(let ([p ($branch-prefix d)]
[m ($branch-mask d)])
(let-branch ([(p m l r) d])
(cond
[(nomatch? key p m) d]
[(fx<= key p) (br* p m (fxmap-remove ($branch-left d) key) ($branch-right d))]
[else (br* p m ($branch-left d) (fxmap-remove ($branch-right d) key))]))]
[(fx<= key p) (br* p m (fxmap-remove l key) r)]
[else (br* p m l (fxmap-remove r key))]))]
[($leaf? d)
(if (fx= key ($leaf-key d))
@ -114,6 +159,83 @@
[else
empty-fxmap]))
(define (fxmap-remove/base d key base)
; Remove key from d, but try to reuse the branches from base when possible
; instead of creating new ones.
; TODO: This assumes that all the keys in base are in d too.
; Perhaps this restriction can be removed.
(cond
[($branch? base)
(cond
[($branch? d)
(let-branch ([(p0 m0 l0 r0) base]
[(p m l r) d])
(let ([sub-base (cond
[(fx< m0 m) base]
[(fx<= key p0) l0]
[else r0])])
(cond
[(nomatch? key p m)
d]
[(fx<= key p)
(br*/base p m (fxmap-remove/base l key sub-base) r base)]
[else
(br*/base p m l (fxmap-remove/base r key sub-base) base)])))]
[($leaf? d)
(if (fx= key ($leaf-key d))
empty-fxmap
d)]
[else
empty-fxmap])]
[else
(fxmap-remove d key)]))
;; reset and advance
(define (fxmap-reset/base d key base)
; Reset key in d to the value it has in base, but try to reuse the branches
; from base when possible instead of creating new ones.
; TODO: This assumes that all the keys in base are in d too.
; Perhaps this restriction can be removed.
(cond
[($branch? d)
(let-branch ([(p m l r) d])
(let ([sub-base (cond
[($branch? base)
(let-branch ([(p0 m0 l0 r0) base])
(cond
[(fx< m0 m) base]
[(fx<= key p0) l0]
[else r0]))]
[else base])])
(cond
[(nomatch? key p m)
d]
[(fx<= key p)
(br*/base p m (fxmap-reset/base l key sub-base) r base)]
[else
(br*/base p m l (fxmap-reset/base r key sub-base) base)])))]
[(and ($leaf? d)
(fx= key ($leaf-key d))
($leaf? base)
(fx= key ($leaf-key base)))
base]
[else
(error 'fxmap-reset/base "")]))
(define (fxmap-advance/base d key base)
(let ([changes (fx+ (fxmap-ref/changes base key) 1)]
[l (fxmap-ref/leaf d key)])
(if l
(if (fx= changes ($leaf-changes l))
d
(fxmap-set/changes d key ($leaf-val l) changes))
(error 'fxmap-advance/base ""))))
;; set and remove utilities
(define-syntax define-syntax-rule
@ -123,13 +245,25 @@
(syntax-rules ()
[(_ arg ...) e ...]))]))
(define br make-$branch)
(define (br p m l r)
(make-$branch p m l r
(fx+ (fxmap-count l) (fxmap-count r))
(fx+ (fxmap-changes l) (fxmap-changes r))))
(define (br* p m l r)
(cond [($empty? r) l]
[($empty? l) r]
[else (br p m l r)]))
(define (br*/base p m l r base)
(cond [($empty? r) l]
[($empty? l) r]
[(and ($branch? base)
(eq? l ($branch-left base))
(eq? r ($branch-right base)))
base]
[else (br p m l r)]))
(define (join p0 d0 p1 d1)
(let ([m (branching-bit p0 p1)])
(if (fx<= p0 p1)
@ -173,8 +307,8 @@
[($branch? d1)
(cond
[($branch? d2)
(let-branch
([(p1 m1 l1 r1) d1] [(p2 m2 l2 r2) d2])
(let-branch ([(p1 m1 l1 r1) d1]
[(p2 m2 l2 r2) d2])
(cond
[(fx> m1 m2) (cond
[(nomatch? p2 p1 m1) (join* p1 (g1 d1) p2 (g2 d2))]
@ -195,8 +329,7 @@
(id d1)]
[($branch? d1)
(let-branch
([(p1 m1 l1 r1) d1])
(let-branch ([(p1 m1 l1 r1) d1])
(cond [(nomatch? k2 p1 m1) (join* p1 (g1 d1) k2 (g2 d2))]
[(fx<= k2 p1) (bin p1 m1 (merge0 l1) (g1 r1))]
[else (bin p1 m1 (g1 l1) (merge0 r1))]))]
@ -220,8 +353,7 @@
(id d1)]
[($branch? d2)
(let-branch
([(p2 m2 l2 r2) d2])
(let-branch ([(p2 m2 l2 r2) d2])
(cond [(nomatch? k1 p2 m2) (join* k1 (g1 d1) p2 (g2 d2))]
[(fx<= k1 p2) (bin p2 m2 (merge0 l2) (g2 r2))]
[else (bin p2 m2 (g2 l2) (merge0 r2))]))]
@ -244,4 +376,26 @@
[m ($branch-mask d)] ...
[l ($branch-left d)] ...
[r ($branch-right d)] ...)
exp ...)])))
exp ...)]))
(define (fxmap-for-each g1 d1)
(cond
[($branch? d1)
(fxmap-for-each g1 ($branch-left d1))
(fxmap-for-each g1 ($branch-right d1))]
[($leaf? d1)
(g1 ($leaf-key d1) ($leaf-val d1))]
[else ; ($empty? d1)
(void)])
(void))
(define (fxmap-for-each/diff f g1 g2 d1 d2)
(fxmap-merge (lambda (prefix mask left right) (make-$empty))
(lambda (x y) (f ($leaf-key x) ($leaf-val x) ($leaf-val y)) (make-$empty))
(lambda (x) (make-$empty))
(lambda (x) (fxmap-for-each g1 x) (make-$empty))
(lambda (x) (fxmap-for-each g2 x) (make-$empty))
d1
d2)
(void))
)