1;;; 2;;; srfi-146 - mappings 3;;; 4;;; Copyright (c) 2017-2020 Shiro Kawai <shiro@acm.org> 5;;; 6;;; Redistribution and use in source and binary forms, with or without 7;;; modification, are permitted provided that the following conditions 8;;; are met: 9;;; 10;;; 1. Redistributions of source code must retain the above copyright 11;;; notice, this list of conditions and the following disclaimer. 12;;; 13;;; 2. Redistributions in binary form must reproduce the above copyright 14;;; notice, this list of conditions and the following disclaimer in the 15;;; documentation and/or other materials provided with the distribution. 16;;; 17;;; 3. Neither the name of the authors nor the names of its contributors 18;;; may be used to endorse or promote products derived from this 19;;; software without specific prior written permission. 20;;; 21;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 27;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 28;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 29;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 30;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32;;; 33 34(define-module srfi-146 35 (export mapping mapping-unfold mapping/ordered mapping-unfold/ordered 36 mapping? mapping-contains? mapping-empty? mapping-disjoint? 37 mapping-ref mapping-ref/default 38 mapping-key-comparator 39 40 mapping-set mapping-set! 41 mapping-adjoin mapping-adjoin! 42 mapping-replace mapping-replace! 43 mapping-delete mapping-delete! 44 mapping-delete-all mapping-delete-all! 45 mapping-intern mapping-intern! 46 mapping-update mapping-update! 47 mapping-update/default mapping-update!/default 48 mapping-pop mapping-pop! 49 mapping-search mapping-search! 50 mapping-size mapping-find mapping-count 51 mapping-any? mapping-every? 52 mapping-keys mapping-values mapping-entries 53 mapping-map mapping-map->list mapping-for-each mapping-fold 54 mapping-filter mapping-filter! mapping-remove mapping-remove! 55 mapping-partition mapping-partition! 56 mapping-copy mapping->alist alist->mapping alist->mapping! 57 alist->mapping/ordered alist->mapping/ordered! 58 59 mapping=? mapping<? mapping>? mapping<=? mapping>=? 60 mapping-union mapping-intersection mapping-difference mapping-xor 61 mapping-union! mapping-intersection! mapping-difference! mapping-xor! 62 make-mapping-comparator 63 mapping-comparator 64 mapping-min-key mapping-max-key 65 mapping-min-value mapping-max-value 66 mapping-key-predecessor mapping-key-successor 67 mapping-range= mapping-range< mapping-range> 68 mapping-range<= mapping-range>= 69 mapping-range=! mapping-range<! mapping-range>! 70 mapping-range<=! mapping-range>=! 71 mapping-split 72 mapping-catenate mapping-catenate! 73 mapping-map/monotone mapping-map/monotone! 74 mapping-fold/reverse 75 76 ;; builtin 77 comparator?)) 78(select-module srfi-146) 79 80;; We provide <tree-map> as mapping. 81(define <mapping> <tree-map>) 82(define (mapping? m) (is-a? m <mapping>)) 83 84(define-syntax dopairs 85 (syntax-rules () 86 [(_ [k v lis] body ...) 87 (let1 lis lis 88 (do ([xs lis (cddr xs)]) 89 [(null? xs)] 90 (when (null? (cdr xs)) 91 (error "mapping kv-list isn't even:" lis)) 92 (let ([k (car xs)] 93 [v (cadr xs)]) 94 body ...)))])) 95 96(define (mapping comparator . args) 97 (assume-type comparator <comparator>) 98 (rlet1 m (make-tree-map comparator) 99 (dopairs [k v args] (tree-map-adjoin! m k v)))) 100 101(define (mapping-unfold p f g seed comparator) 102 (assume-type comparator <comparator>) 103 (rlet1 m (make-tree-map comparator) 104 (do ([seed seed (g seed)]) 105 [(p seed) m] 106 (receive (k v) (f seed) 107 (tree-map-adjoin! m k v))))) 108 109;; We don't take advantage of, neither check, the ordered keys. 110(define mapping/ordered mapping) 111(define mapping-unfold/ordered mapping-unfold) 112 113(define (mapping-empty? m) (tree-map-empty? m)) 114(define (mapping-contains? m key) (tree-map-exists? m key)) 115(define (mapping-disjoint? m1 m2) 116 (assume-type m1 <mapping>) 117 (assume-type m2 <mapping>) 118 (tree-map-seek m1 (^[k _] (tree-map-exists? m2 k)) 119 (^[r k v] #f) 120 (^[] #t))) 121 122(define %unique (list #f)) 123 124(define (mapping-ref m key 125 :optional 126 (failure #f) 127 (success identity)) 128 (assume-type m <mapping>) 129 (if failure 130 (let1 v (tree-map-get m key %unique) 131 (if (eq? v %unique) 132 (failure) 133 (success v))) 134 (success (tree-map-get m key)))) ;let tree-map-get handle failure 135 136(define (mapping-ref/default m key default) 137 (assume-type m <mapping>) 138 (tree-map-get m key default)) 139 140(define (mapping-key-comparator m) (tree-map-comparator m)) 141 142(define (mapping-set m . args) 143 (if (null? args) 144 (begin 145 (assume-type m <mapping>) 146 m) ;shortcut 147 (apply mapping-set! (mapping-copy m) args))) 148 149(define (mapping-set! m . args) 150 (assume-type m <mapping>) 151 (dopairs [k v args] (tree-map-put! m k v)) 152 m) 153 154(define (mapping-adjoin m . args) 155 (if (null? args) 156 (begin 157 (assume-type m <mapping>) 158 m) ;shortcut 159 (apply mapping-adjoin! (tree-map-copy m) args))) 160 161(define (mapping-adjoin! m . args) 162 (assume-type m <mapping>) 163 (dopairs [k v args] (tree-map-adjoin! m k v)) 164 m) 165 166(define (mapping-replace m k v) 167 (assume-type m <mapping>) 168 (if (tree-map-exists? m k) 169 (mapping-replace! (tree-map-copy m) k v) 170 m)) 171 172(define (mapping-replace! m k v) 173 (assume-type m <mapping>) 174 (tree-map-replace! m k v) 175 m) 176 177(define (mapping-delete m . keys) (mapping-delete-all m keys)) 178(define (mapping-delete! m . keys) (mapping-delete-all! m keys)) 179 180(define (mapping-delete-all m keys) 181 (assume-type m <mapping>) 182 ;; We delay copy until we actually modify the map. 183 (fold (^[k t] 184 (if (tree-map-exists? t k) 185 (rlet1 t (if (eq? t m) (tree-map-copy m) t) 186 (tree-map-delete! t k)) 187 t)) 188 m keys)) 189 190(define (mapping-delete-all! m keys) 191 (assume-type m <mapping>) 192 (dolist [k keys] (tree-map-delete! m k)) 193 m) 194 195(define (mapping-intern m k newval) 196 (assume-type m <mapping>) 197 (let1 v (tree-map-get m k %unique) 198 (if (eq? v %unique) 199 (let ([t (tree-map-copy m)] 200 [v (newval)]) 201 (tree-map-put! t k v) 202 (values t v)) 203 (values m v)))) 204 205(define (mapping-intern! m k newval) 206 (assume-type m <mapping>) 207 (let1 v (tree-map-get m k %unique) 208 (if (eq? v %unique) 209 (let1 v (newval) 210 (tree-map-put! m k v) 211 (values m v)) 212 (values m v)))) 213 214(define (mapping-update m k updater 215 :optional 216 (failure (^[] (errorf "~s doesn't have a key ~s" m k))) 217 (success identity)) 218 (assume-type m <mapping>) 219 ;; We delay copy until we actually modify the map. 220 (let* ([v (tree-map-get m k %unique)] 221 [v1 (if (eq? v %unique) 222 (updater (failure)) 223 (updater (success v)))]) 224 (if (eq? v v1) 225 m ; no action needed 226 (rlet1 t (tree-map-copy m) 227 (tree-map-put! t k v1))))) 228 229(define (mapping-update! m k updater 230 :optional 231 (failure (^[] (errorf "~s doesn't have a key ~s" m k))) 232 (success identity)) 233 (assume-type m <mapping>) 234 (let* ([v (tree-map-get m k %unique)] 235 [v1 (if (eq? v %unique) 236 (updater (failure)) 237 (updater (success v)))]) 238 (tree-map-put! m k v1)) 239 m) 240 241(define (mapping-update/default m k updater default) 242 (mapping-update m k updater (lambda () default))) 243 244(define (mapping-update!/default m k updater default) 245 (mapping-update! m k updater (lambda () default))) 246 247(define (mapping-pop! m 248 :optional 249 (failure (^[] (error "can't pop from an empty map")))) 250 (assume-type m <mapping>) 251 (if-let1 p (tree-map-pop-min! m) 252 (values m (car p) (cdr p)) 253 (failure))) 254 255(define (mapping-pop m 256 :optional 257 (failure (^[] (error "can't pop from an empty map")))) 258 (assume-type m <mapping>) 259 (if (tree-map-empty? m) 260 (failure) ;avoid unnecessary copying 261 (mapping-pop! (mapping-copy m)))) 262 263(define (mapping-search m k failure success) 264 (assume-type m <mapping>) 265 (let1 v (tree-map-get m k %unique) 266 (if (eq? v %unique) 267 (failure (^[v o] (let1 m (tree-map-copy m) ;insert 268 (tree-map-put! m k v) 269 (values m o))) 270 (^[o] (values m o))) ;ignore 271 (success k v 272 (^[k v o] (let1 m (tree-map-copy m) ;update 273 (tree-map-put! m k v) 274 (values m o))) 275 (^[o] (let1 m (tree-map-copy m) ;remove 276 (tree-map-delete! m k) 277 (values m o))))))) 278 279(define (mapping-search! m k failure success) 280 (assume-type m <mapping>) 281 (let1 v (tree-map-get m k %unique) 282 (if (eq? v %unique) 283 (failure (^[v o] (tree-map-put! m k v) (values m o)) ;insert 284 (^[o] (values m o))) ;ignore 285 (success v 286 (^[k v o] (tree-map-put! m k v) (values m o)) ;update 287 (^[o] (tree-map-delete! m k) (values m o)))))) ;remove 288 289(define (mapping-size m) 290 (assume-type m <mapping>) 291 (tree-map-num-entries m)) 292 293(define (mapping-find pred m failure) 294 (assume-type m <mapping>) 295 (tree-map-seek m pred (^[r k v] (values k v)) failure)) 296 297(define (mapping-count pred m) 298 (assume-type m <mapping>) 299 (tree-map-fold m (^[k v c] (if (pred k v) (+ 1 c) c)) 0)) 300 301(define (mapping-any? pred m) 302 (assume-type m <mapping>) 303 (tree-map-seek m pred (^[r k v] #t) (^[] #f))) 304 305(define (mapping-every? pred m) 306 (assume-type m <mapping>) 307 (tree-map-seek m (^[k v] (not (pred k v))) (^[r k v] #f) (^[] #t))) 308 309(define (mapping-keys m) (tree-map-keys m)) 310(define (mapping-values m) (tree-map-values m)) 311 312(define (mapping-entries m) 313 (values (tree-map-keys m) (tree-map-values m))) 314 315(define (mapping-map proc cmpr m) 316 (assume-type m <mapping>) 317 (assume-type cmpr <comparator>) 318 (rlet1 r (make-tree-map cmpr) 319 (tree-map-for-each m (^[k v] (receive [k v] (proc k v) 320 (tree-map-put! r k v)))))) 321 322(define (mapping-for-each proc m) 323 (assume-type m <mapping>) 324 (tree-map-for-each m proc)) 325 326(define (mapping-fold kons knil m) 327 (assume-type m <mapping>) 328 (tree-map-fold m kons knil)) 329 330(define (mapping-map->list proc m) 331 (assume-type m <mapping>) 332 (tree-map-map m proc)) 333 334(define (mapping-filter pred m) 335 (assume-type m <mapping>) 336 (rlet1 r (make-tree-map (tree-map-comparator m)) 337 (tree-map-for-each m (^[k v] (when (pred k v) 338 (tree-map-put! r k v)))))) 339 340(define (mapping-filter! pred m) 341 (assume-type m <mapping>) 342 (tree-map-for-each m (^[k v] (unless (pred k v) 343 (tree-map-delete! m k))))) 344 345(define (mapping-remove pred m) 346 (assume-type m <mapping>) 347 (rlet1 r (make-tree-map (tree-map-comparator m)) 348 (tree-map-for-each m (^[k v] (unless (pred k v) 349 (tree-map-put! r k v)))))) 350 351(define (mapping-remove! pred m) 352 (assume-type m <mapping>) 353 (tree-map-for-each m (^[k v] (when (pred k v) 354 (tree-map-delete! m k))))) 355 356(define (mapping-partition pred m) 357 (assume-type m <mapping>) 358 (let ([f (make-tree-map (tree-map-comparator m))] 359 [r (make-tree-map (tree-map-comparator m))]) 360 (tree-map-for-each m (^[k v] (if (pred k v) 361 (tree-map-put! f k v) 362 (tree-map-put! r k v)))) 363 (values f r))) 364 365(define (mapping-partition! pred m) 366 (assume-type m <mapping>) 367 (let1 r (make-tree-map (tree-map-comparator m)) 368 (tree-map-for-each m (^[k v] (unless (pred k v) 369 (tree-map-delete! m k) 370 (tree-map-put! r k v)))) 371 (values m r))) 372 373(define (mapping-copy m) 374 (assume-type m <mapping>) 375 (tree-map-copy m)) 376 377(define (mapping->alist m) 378 (assume-type m <mapping>) 379 (tree-map-fold-right m acons '())) 380 381(define (alist->mapping cmpr alist) 382 (assume-type cmpr <comparator>) 383 (rlet1 m (make-tree-map cmpr) 384 (dolist [p alist] 385 (tree-map-adjoin! m (car p) (cdr p))))) 386 387(define (alist->mapping! m alist) 388 (assume-type m <mapping>) 389 (dolist [p alist] 390 (tree-map-adjoin! m (car p) (cdr p))) 391 m) 392 393;; we don't take advantage of, neither check, ordered keys 394(define alist->mapping/ordered alist->mapping) 395(define alist->mapping/ordered! alist->mapping!) 396 397(define (%mapping-cmp v=? pred ms) 398 (let loop ([ms ms]) 399 (cond [(null? (cdr ms)) #t] 400 [(tree-map-compare-as-sets (car ms) (cadr ms) v=? #f) 401 => (^r (and (pred r) (loop (cdr ms))))] 402 [else #f]))) 403 404(define-syntax define-mapping-cmp 405 (syntax-rules () 406 [(_ name op) 407 (define (name vcmp m . more) 408 (assume-type vcmp <comparator>) 409 (%mapping-cmp (comparator-equality-predicate vcmp) 410 (^[x] (op x 0)) 411 (cons m more)))])) 412 413(define-mapping-cmp mapping=? =) 414(define-mapping-cmp mapping<? <) 415(define-mapping-cmp mapping<=? <=) 416(define-mapping-cmp mapping>? >) 417(define-mapping-cmp mapping>=? >=) 418 419(define (%union-2! m1 m2) 420 (tree-map-for-each m2 (^[k v] (tree-map-adjoin! m1 k v))) 421 m1) 422 423(define (mapping-union! m1 . more) 424 (if (null? more) 425 m1 426 (apply mapping-union! (%union-2! m1 (car more)) (cdr more)))) 427 428(define (mapping-union m1 . more) 429 (apply mapping-union! (mapping-copy m1) more)) 430 431(define (%intersection-2! m1 m2) 432 (tree-map-for-each m1 (^[k v] (unless (tree-map-get m2 k #f) 433 (tree-map-delete! m1 k)))) 434 m1) 435 436(define (mapping-intersection! m1 . more) 437 (if (null? more) 438 m1 439 (apply mapping-intersection! (%intersection-2! m1 (car more)) (cdr more)))) 440 441(define (mapping-intersection m1 . more) 442 (apply mapping-intersection! (mapping-copy m1) more)) 443 444(define (%difference-2! m1 m2) 445 (tree-map-for-each m2 (^[k v] (tree-map-delete! m1 k))) 446 m1) 447 448(define (mapping-difference! m1 . more) 449 (let loop ([m1 m1] [more more]) 450 (if (null? more) 451 m1 452 (loop (%difference-2! m1 (car more)) (cdr more))))) 453 454(define (mapping-difference m1 . more) 455 (apply mapping-difference! (mapping-copy m1) more)) 456 457(define (mapping-xor! m1 m2) 458 (tree-map-for-each m2 (^[k v] (if (tree-map-get m1 k #f) 459 (tree-map-delete! m1 k) 460 (tree-map-put! m1 k v)))) 461 m1) 462 463(define (mapping-xor m1 m2) 464 (mapping-xor! (mapping-copy m1) m2)) 465 466(define (mapping-min-key m) 467 (assume-type m <mapping>) 468 (if-let1 p (tree-map-min m) 469 (car p) 470 (error "Can't get min key from an empty map:" m))) 471 472(define (mapping-max-key m) 473 (assume-type m <mapping>) 474 (if-let1 p (tree-map-max m) 475 (car p) 476 (error "Can't get min key from an empty map:" m))) 477 478(define (mapping-min-value m) 479 (assume-type m <mapping>) 480 (if-let1 p (tree-map-min m) 481 (cdr p) 482 (error "Can't get min key from an empty map:" m))) 483 484(define (mapping-max-value m) 485 (assume-type m <mapping>) 486 (if-let1 p (tree-map-max m) 487 (cdr p) 488 (error "Can't get min key from an empty map:" m))) 489 490(define (mapping-key-predecessor m probe failure) 491 (assume-type m <mapping>) 492 (receive [k v] (tree-map-predecessor m probe %unique) 493 (if (eq? k %unique) 494 (failure) 495 k))) 496 497(define (mapping-key-successor m probe failure) 498 (assume-type m <mapping>) 499 (receive [k v] (tree-map-successor m probe %unique) 500 (if (eq? k %unique) 501 (failure) 502 k))) 503 504(define-syntax define-mapping-range 505 (syntax-rules () 506 [(_ name! name op) 507 (begin 508 (define (name! m probe) 509 (assume-type m <mapping>) 510 (let1 cmpr (tree-map-comparator m) 511 ($ tree-map-for-each m 512 (^[k v] (unless (op (comparator-compare cmpr k probe) 0) 513 (tree-map-delete! m k))))) 514 m) 515 (define (name m probe) 516 (name! (mapping-copy m) probe)))])) 517 518(define-mapping-range mapping-range=! mapping-range= =) 519(define-mapping-range mapping-range<! mapping-range< <) 520(define-mapping-range mapping-range<=! mapping-range<= <=) 521(define-mapping-range mapping-range>! mapping-range> >) 522(define-mapping-range mapping-range>=! mapping-range>= >=) 523 524(define (mapping-split m probe) 525 (assume-type m <mapping>) 526 ;; no more efficient than calling each one 527 (values (mapping-range< m probe) 528 (mapping-range<= m probe) 529 (mapping-range= m probe) 530 (mapping-range>= m probe) 531 (mapping-range> m probe))) 532 533(define (%mapping-catenate! cmpr m1 key val m2 reuse?) 534 (define (too-small key m) 535 (errorf "Catenating key ~s is too small for ~s" key m)) 536 (define (too-large key m) 537 (errorf "Catenating key ~s is too large for ~s" key m)) 538 (cond [(and reuse? (equal? cmpr (tree-map-comparator m1))) 539 ;; Reuse m1 540 (when (and (not (tree-map-empty? m1)) 541 (>= (comparator-compare cmpr (car (tree-map-max m1)) key) 0)) 542 (too-small key m1)) 543 (tree-map-put! m1 key val) 544 ($ tree-map-for-each m2 545 (^[k v] 546 (when (<= (comparator-compare cmpr k key) 0) 547 (too-large key m2)) 548 (tree-map-put! m1 k v))) 549 m1] 550 [(and reuse? (equal? cmpr (tree-map-comparator m2))) 551 ;; Reuse m2 552 (when (and (not (tree-map-empty? m2)) 553 (<= (comparator-compare cmpr (car (tree-map-max m2)) key) 0)) 554 (too-large key m2)) 555 (tree-map-put! m2 key val) 556 ($ tree-map-for-each m1 557 (^[k v] 558 (when (>= (comparator-compare cmpr k key) 0) 559 (too-small key m1)) 560 (tree-map-put! m2 k v))) 561 m2] 562 [else 563 (rlet1 m (make-tree-map cmpr) 564 (tree-map-put! m key val) 565 ($ tree-map-for-each m1 566 (^[k v] 567 (when (>= (comparator-compare cmpr k key) 0) 568 (too-small key m1)) 569 (tree-map-put! m k v))) 570 ($ tree-map-for-each m2 571 (^[k v] 572 (when (<= (comparator-compare cmpr k key) 0) 573 (too-large key m2)) 574 (tree-map-put! m k v))))])) 575 576(define (mapping-catenate cmpr m1 key val m2) 577 (%mapping-catenate! cmpr m1 key val m2 #f)) 578(define (mapping-catenate! cmpr m1 key val m2) 579 (%mapping-catenate! cmpr m1 key val m2 #t)) 580 581;; We don't take advantage of monotone 582(define (mapping-map/monotone! proc cmpr m) 583 (mapping-map proc cmpr m)) 584(define (mapping-map/monotone proc cmpr m) 585 (mapping-map proc cmpr m)) 586 587(define (mapping-fold/reverse kons knil m) 588 (tree-map-fold-right m kons knil)) 589 590(define (make-mapping-comparator value-cmpr) 591 (define (compare a b) 592 (tree-map-compare-as-sequences a b value-cmpr)) 593 (make-comparator/compare mapping? #t compare #f)) 594 595(define mapping-comparator (make-mapping-comparator default-comparator)) 596