Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding srfi 146

Browse source
This commit is contained in:
Alex Shinn 2020-05-26 13:57:06 +09:00
parent fb079b2bda
commit 3a117b27aa
4 changed files with 1866 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

68
lib/srfi/146.sld Normal file
View file

@ -0,0 +1,68 @@
;; Copyright (C) Marc Nieper-Wißkirchen (2016). All Rights Reserved.
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.
(define-library (srfi 146)
(export mapping mapping-unfold
mapping/ordered mapping-unfold/ordered
mapping? mapping-contains? mapping-empty? mapping-disjoint?
mapping-ref mapping-ref/default mapping-key-comparator
mapping-adjoin mapping-adjoin!
mapping-set mapping-set!
mapping-replace mapping-replace!
mapping-delete mapping-delete! mapping-delete-all mapping-delete-all!
mapping-intern mapping-intern!
mapping-update mapping-update! mapping-update/default mapping-update!/default
mapping-pop mapping-pop!
mapping-search mapping-search!
mapping-size mapping-find mapping-count mapping-any? mapping-every?
mapping-keys mapping-values mapping-entries
mapping-map mapping-map->list mapping-for-each mapping-fold
mapping-filter mapping-filter!
mapping-remove mapping-remove!
mapping-partition mapping-partition!
mapping-copy mapping->alist alist->mapping alist->mapping!
alist->mapping/ordered alist->mapping/ordered!
mapping=? mapping<? mapping>? mapping<=? mapping>=?
mapping-union mapping-intersection mapping-difference mapping-xor
mapping-union! mapping-intersection! mapping-difference! mapping-xor!
make-mapping-comparator
mapping-comparator
mapping-min-key mapping-max-key
mapping-min-value mapping-max-value
mapping-key-predecessor mapping-key-successor
mapping-range= mapping-range< mapping-range> mapping-range<= mapping-range>=
mapping-range=! mapping-range<! mapping-range>! mapping-range<=! mapping-range>=!
mapping-split
mapping-catenate mapping-catenate!
mapping-map/monotone mapping-map/monotone!
mapping-fold/reverse
comparator?)
(import (scheme base)
(scheme case-lambda)
(srfi 1)
(srfi 2)
(srfi 8)
(srfi 121)
(srfi 128)
(srfi 145))
(include "146/rbtree.scm"
"146/mapping.scm"))

833
lib/srfi/146/mapping.scm Normal file
View file

@ -0,0 +1,833 @@
;; Copyright (C) Marc Nieper-Wißkirchen (2016, 2017). All Rights
;; Reserved.
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.
;;; New types
(define-record-type <mapping>
(%make-mapping comparator tree)
mapping?
(comparator mapping-key-comparator)
(tree mapping-tree))
(define (make-empty-mapping comparator)
(assume (comparator? comparator))
(%make-mapping comparator (make-tree)))
;;; Exported procedures
;; Constructors
(define (mapping comparator . args)
(assume (comparator? comparator))
(mapping-unfold null?
(lambda (args)
(values (car args)
(cadr args)))
cddr
args
comparator))
(define (mapping-unfold stop? mapper successor seed comparator)
(assume (procedure? stop?))
(assume (procedure? mapper))
(assume (procedure? successor))
(assume (comparator? comparator))
(let loop ((mapping (make-empty-mapping comparator))
(seed seed))
(if (stop? seed)
mapping
(receive (key value)
(mapper seed)
(loop (mapping-adjoin mapping key value)
(successor seed))))))
(define mapping/ordered mapping)
(define mapping-unfold/ordered mapping-unfold)
;; Predicates
(define (mapping-empty? mapping)
(assume (mapping? mapping))
(not (mapping-any? (lambda (key value) #t) mapping)))
(define (mapping-contains? mapping key)
(assume (mapping? mapping))
(call/cc
(lambda (return)
(mapping-search mapping
key
(lambda (insert ignore)
(return #f))
(lambda (key value update remove)
(return #t))))))
(define (mapping-disjoint? mapping1 mapping2)
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(call/cc
(lambda (return)
(mapping-for-each (lambda (key value)
(when (mapping-contains? mapping2 key)
(return #f)))
mapping1)
#t)))
;; Accessors
(define mapping-ref
(case-lambda
((mapping key)
(assume (mapping? mapping))
(mapping-ref mapping key (lambda ()
(error "mapping-ref: key not in mapping" key))))
((mapping key failure)
(assume (mapping? mapping))
(assume (procedure? failure))
(mapping-ref mapping key failure (lambda (value)
value)))
((mapping key failure success)
(assume (mapping? mapping))
(assume (procedure? failure))
(assume (procedure? success))
((call/cc
(lambda (return-thunk)
(mapping-search mapping
key
(lambda (insert ignore)
(return-thunk failure))
(lambda (key value update remove)
(return-thunk (lambda () (success value)))))))))))
(define (mapping-ref/default mapping key default)
(assume (mapping? mapping))
(mapping-ref mapping key (lambda () default)))
;; Updaters
(define (mapping-adjoin mapping . args)
(assume (mapping? mapping))
(let loop ((args args)
(mapping mapping))
(if (null? args)
mapping
(receive (mapping value)
(mapping-intern mapping (car args) (lambda () (cadr args)))
(loop (cddr args) mapping)))))
(define mapping-adjoin! mapping-adjoin)
(define (mapping-set mapping . args)
(assume (mapping? mapping))
(let loop ((args args)
(mapping mapping))
(if (null? args)
mapping
(receive (mapping)
(mapping-update mapping (car args) (lambda (value) (cadr args)) (lambda () #f))
(loop (cddr args)
mapping)))))
(define mapping-set! mapping-set)
(define (mapping-replace mapping key value)
(assume (mapping? mapping))
(receive (mapping obj)
(mapping-search mapping
key
(lambda (insert ignore)
(ignore #f))
(lambda (old-key old-value update remove)
(update key value #f)))
mapping))
(define mapping-replace! mapping-replace)
(define (mapping-delete mapping . keys)
(assume (mapping? mapping))
(mapping-delete-all mapping keys))
(define mapping-delete! mapping-delete)
(define (mapping-delete-all mapping keys)
(assume (mapping? mapping))
(assume (list? keys))
(fold (lambda (key mapping)
(receive (mapping obj)
(mapping-search mapping
key
(lambda (insert ignore)
(ignore #f))
(lambda (old-key old-value update remove)
(remove #f)))
mapping))
mapping keys))
(define mapping-delete-all! mapping-delete-all)
(define (mapping-intern mapping key failure)
(assume (mapping? mapping))
(assume (procedure? failure))
(call/cc
(lambda (return)
(mapping-search mapping
key
(lambda (insert ignore)
(receive (value)
(failure)
(insert value value)))
(lambda (old-key old-value update remove)
(return mapping old-value))))))
(define mapping-intern! mapping-intern)
(define mapping-update
(case-lambda
((mapping key updater)
(mapping-update mapping key updater (lambda ()
(error "mapping-update: key not found in mapping" key))))
((mapping key updater failure)
(mapping-update mapping key updater failure (lambda (value)
value)))
((mapping key updater failure success)
(assume (mapping? mapping))
(assume (procedure? updater))
(assume (procedure? failure))
(assume (procedure? success))
(receive (mapping obj)
(mapping-search mapping
key
(lambda (insert ignore)
(insert (updater (failure)) #f))
(lambda (old-key old-value update remove)
(update key (updater (success old-value)) #f)))
mapping))))
(define mapping-update! mapping-update)
(define (mapping-update/default mapping key updater default)
(mapping-update mapping key updater (lambda () default)))
(define mapping-update!/default mapping-update/default)
(define mapping-pop
(case-lambda
((mapping)
(mapping-pop mapping (lambda ()
(error "mapping-pop: mapping has no association"))))
((mapping failure)
(assume (mapping? mapping))
(assume (procedure? failure))
((call/cc
(lambda (return-thunk)
(receive (key value)
(mapping-find (lambda (key value) #t) mapping (lambda () (return-thunk failure)))
(lambda ()
(values (mapping-delete mapping key) key value)))))))))
(define mapping-pop! mapping-pop)
(define (mapping-search mapping key failure success)
(assume (mapping? mapping))
(assume (procedure? failure))
(assume (procedure? success))
(call/cc
(lambda (return)
(let*-values
(((comparator)
(mapping-key-comparator mapping))
((tree obj)
(tree-search comparator
(mapping-tree mapping)
key
(lambda (insert ignore)
(failure (lambda (value obj)
(insert key value obj))
(lambda (obj)
(return mapping obj))))
success)))
(values (%make-mapping comparator tree)
obj)))))
(define mapping-search! mapping-search)
;; The whole mapping
(define (mapping-size mapping)
(assume (mapping? mapping))
(mapping-count (lambda (key value)
#t)
mapping))
(define (mapping-find predicate mapping failure)
(assume (procedure? predicate))
(assume (mapping? mapping))
(assume (procedure? failure))
(call/cc
(lambda (return)
(mapping-for-each (lambda (key value)
(when (predicate key value)
(return key value)))
mapping)
(failure))))
(define (mapping-count predicate mapping)
(assume (procedure? predicate))
(assume (mapping? mapping))
(mapping-fold (lambda (key value count)
(if (predicate key value)
(+ 1 count)
count))
0 mapping))
(define (mapping-any? predicate mapping)
(assume (procedure? predicate))
(assume (mapping? mapping))
(call/cc
(lambda (return)
(mapping-for-each (lambda (key value)
(when (predicate key value)
(return #t)))
mapping)
#f)))
(define (mapping-every? predicate mapping)
(assume (procedure? predicate))
(assume (mapping? mapping))
(not (mapping-any? (lambda (key value)
(not (predicate key value)))
mapping)))
(define (mapping-keys mapping)
(assume (mapping? mapping))
(mapping-fold/reverse (lambda (key value keys)
(cons key keys))
'() mapping))
(define (mapping-values mapping)
(assume (mapping? mapping))
(mapping-fold/reverse (lambda (key value values)
(cons value values))
'() mapping))
(define (mapping-entries mapping)
(assume (mapping? mapping))
(values (mapping-keys mapping)
(mapping-values mapping)))
;; Mapping and folding
(define (mapping-map proc comparator mapping)
(assume (procedure? proc))
(assume (comparator? comparator))
(assume (mapping? mapping))
(mapping-fold (lambda (key value mapping)
(receive (key value)
(proc key value)
(mapping-set mapping key value)))
(make-empty-mapping comparator)
mapping))
(define (mapping-for-each proc mapping)
(assume (procedure? proc))
(assume (mapping? mapping))
(tree-for-each proc (mapping-tree mapping)))
(define (mapping-fold proc acc mapping)
(assume (procedure? proc))
(assume (mapping? mapping))
(tree-fold proc acc (mapping-tree mapping)))
(define (mapping-map->list proc mapping)
(assume (procedure? proc))
(assume (mapping? mapping))
(mapping-fold/reverse (lambda (key value lst)
(cons (proc key value) lst))
'()
mapping))
(define (mapping-filter predicate mapping)
(assume (procedure? predicate))
(assume (mapping? mapping))
(mapping-fold (lambda (key value mapping)
(if (predicate key value)
(mapping-set mapping key value)
mapping))
(make-empty-mapping (mapping-key-comparator mapping))
mapping))
(define mapping-filter! mapping-filter)
(define (mapping-remove predicate mapping)
(assume (procedure? predicate))
(assume (mapping? mapping))
(mapping-filter (lambda (key value)
(not (predicate key value)))
mapping))
(define mapping-remove! mapping-remove)
(define (mapping-partition predicate mapping)
(assume (procedure? predicate))
(assume (mapping? mapping))
(values (mapping-filter predicate mapping)
(mapping-remove predicate mapping)))
(define mapping-partition! mapping-partition)
;; Copying and conversion
(define (mapping-copy mapping)
(assume (mapping? mapping))
mapping)
(define (mapping->alist mapping)
(assume (mapping? mapping))
(reverse
(mapping-fold (lambda (key value alist)
(cons (cons key value) alist))
'() mapping)))
(define (alist->mapping comparator alist)
(assume (comparator? comparator))
(assume (list? alist))
(mapping-unfold null?
(lambda (alist)
(let ((key (caar alist))
(value (cdar alist)))
(values key value)))
cdr
alist
comparator))
(define (alist->mapping! mapping alist)
(assume (mapping? mapping))
(assume (list? alist))
(fold (lambda (association mapping)
(let ((key (car association))
(value (cdr association)))
(mapping-set mapping key value)))
mapping
alist))
(define alist->mapping/ordered alist->mapping)
(define alist->mapping/ordered! alist->mapping!)
;; Submappings
(define mapping=?
(case-lambda
((comparator mapping)
(assume (mapping? mapping))
#t)
((comparator mapping1 mapping2) (%mapping=? comparator mapping1 mapping2))
((comparator mapping1 mapping2 . mappings)
(and (%mapping=? comparator mapping1 mapping2)
(apply mapping=? comparator mapping2 mappings)))))
(define (%mapping=? comparator mapping1 mapping2)
(and (eq? (mapping-key-comparator mapping1) (mapping-key-comparator mapping2))
(%mapping<=? comparator mapping1 mapping2)
(%mapping<=? comparator mapping2 mapping1)))
(define mapping<=?
(case-lambda
((comparator mapping)
(assume (mapping? mapping))
#t)
((comparator mapping1 mapping2)
(assume (comparator? comparator))
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(%mapping<=? comparator mapping1 mapping2))
((comparator mapping1 mapping2 . mappings)
(assume (comparator? comparator))
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(and (%mapping<=? comparator mapping1 mapping2)
(apply mapping<=? comparator mapping2 mappings)))))
(define (%mapping<=? comparator mapping1 mapping2)
(assume (comparator? comparator))
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(let ((less? (comparator-ordering-predicate (mapping-key-comparator mapping1)))
(equality-predicate (comparator-equality-predicate comparator))
(gen1 (tree-generator (mapping-tree mapping1)))
(gen2 (tree-generator (mapping-tree mapping2))))
(let loop ((item1 (gen1))
(item2 (gen2)))
(cond
((eof-object? item1)
#t)
((eof-object? item2)
#f)
(else
(let ((key1 (car item1)) (value1 (cadr item1))
(key2 (car item2)) (value2 (cadr item2)))
(cond
((less? key1 key2)
#f)
((less? key2 key1)
(loop item1 (gen2)))
((equality-predicate value1 value2)
(loop (gen1) (gen2)))
(else
#f))))))))
(define mapping>?
(case-lambda
((comparator mapping)
(assume (mapping? mapping))
#t)
((comparator mapping1 mapping2)
(assume (comparator? comparator))
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(%mapping>? comparator mapping1 mapping2))
((comparator mapping1 mapping2 . mappings)
(assume (comparator? comparator))
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(and (%mapping>? comparator mapping1 mapping2)
(apply mapping>? comparator mapping2 mappings)))))
(define (%mapping>? comparator mapping1 mapping2)
(assume (comparator? comparator))
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(not (%mapping<=? comparator mapping1 mapping2)))
(define mapping<?
(case-lambda
((comparator mapping)
(assume (mapping? mapping))
#t)
((comparator mapping1 mapping2)
(assume (comparator? comparator))
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(%mapping<? comparator mapping1 mapping2))
((comparator mapping1 mapping2 . mappings)
(assume (comparator? comparator))
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(and (%mapping<? comparator mapping1 mapping2)
(apply mapping<? comparator mapping2 mappings)))))
(define (%mapping<? comparator mapping1 mapping2)
(assume (comparator? comparator))
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(%mapping>? comparator mapping2 mapping1))
(define mapping>=?
(case-lambda
((comparator mapping)
(assume (mapping? mapping))
#t)
((comparator mapping1 mapping2)
(assume (comparator? comparator))
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(%mapping>=? comparator mapping1 mapping2))
((comparator mapping1 mapping2 . mappings)
(assume (comparator? comparator))
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(and (%mapping>=? comparator mapping1 mapping2)
(apply mapping>=? comparator mapping2 mappings)))))
(define (%mapping>=? comparator mapping1 mapping2)
(assume (comparator? comparator))
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(not (%mapping<? comparator mapping1 mapping2)))
;; Set theory operations
(define (%mapping-union mapping1 mapping2)
(mapping-fold (lambda (key2 value2 mapping)
(receive (mapping obj)
(mapping-search mapping
key2
(lambda (insert ignore)
(insert value2 #f))
(lambda (key1 value1 update remove)
(update key1 value1 #f)))
mapping))
mapping1 mapping2))
(define (%mapping-intersection mapping1 mapping2)
(mapping-filter (lambda (key1 value1)
(mapping-contains? mapping2 key1))
mapping1))
(define (%mapping-difference mapping1 mapping2)
(mapping-fold (lambda (key2 value2 mapping)
(receive (mapping obj)
(mapping-search mapping
key2
(lambda (insert ignore)
(ignore #f))
(lambda (key1 value1 update remove)
(remove #f)))
mapping))
mapping1 mapping2))
(define (%mapping-xor mapping1 mapping2)
(mapping-fold (lambda (key2 value2 mapping)
(receive (mapping obj)
(mapping-search mapping
key2
(lambda (insert ignore)
(insert value2 #f))
(lambda (key1 value1 update remove)
(remove #f)))
mapping))
mapping1 mapping2))
(define mapping-union
(case-lambda
((mapping)
(assume (mapping? mapping))
mapping)
((mapping1 mapping2)
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(%mapping-union mapping1 mapping2))
((mapping1 mapping2 . mappings)
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(apply mapping-union (%mapping-union mapping1 mapping2) mappings))))
(define mapping-union! mapping-union)
(define mapping-intersection
(case-lambda
((mapping)
(assume (mapping? mapping))
mapping)
((mapping1 mapping2)
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(%mapping-intersection mapping1 mapping2))
((mapping1 mapping2 . mappings)
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(apply mapping-intersection (%mapping-intersection mapping1 mapping2) mappings))))
(define mapping-intersection! mapping-intersection)
(define mapping-difference
(case-lambda
((mapping)
(assume (mapping? mapping))
mapping)
((mapping1 mapping2)
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(%mapping-difference mapping1 mapping2))
((mapping1 mapping2 . mappings)
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(apply mapping-difference (%mapping-difference mapping1 mapping2) mappings))))
(define mapping-difference! mapping-difference)
(define mapping-xor
(case-lambda
((mapping)
(assume (mapping? mapping))
mapping)
((mapping1 mapping2)
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(%mapping-xor mapping1 mapping2))
((mapping1 mapping2 . mappings)
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(apply mapping-xor (%mapping-xor mapping1 mapping2) mappings))))
(define mapping-xor! mapping-xor)
;; Additional procedures for mappings with ordererd keys
(define (mapping-min-key mapping)
(assume (mapping? mapping))
(call/cc
(lambda (return)
(mapping-fold (lambda (key value acc)
(return key))
#f mapping)
(error "mapping-min-key: empty map"))))
(define (mapping-max-key mapping)
(assume (mapping? mapping))
(call/cc
(lambda (return)
(mapping-fold/reverse (lambda (key value acc)
(return key))
#f mapping)
(error "mapping-max-key: empty map"))))
(define (mapping-min-value mapping)
(assume (mapping? mapping))
(call/cc
(lambda (return)
(mapping-fold (lambda (key value acc)
(return value))
#f mapping)
(error "mapping-min-value: empty map"))))
(define (mapping-max-value mapping)
(assume (mapping? mapping))
(call/cc
(lambda (return)
(mapping-fold/reverse (lambda (key value acc)
(return value))
#f mapping)
(error "mapping-max-value: empty map"))))
(define (mapping-key-predecessor mapping obj failure)
(assume (mapping? mapping))
(assume (procedure? failure))
(tree-key-predecessor (mapping-key-comparator mapping) (mapping-tree mapping) obj failure))
(define (mapping-key-successor mapping obj failure)
(assume (mapping? mapping))
(assume (procedure? failure))
(tree-key-successor (mapping-key-comparator mapping) (mapping-tree mapping) obj failure))
(define (mapping-range= mapping obj)
(assume (mapping? mapping))
(let ((comparator (mapping-key-comparator mapping)))
(receive (tree< tree<= tree= tree>= tree>)
(tree-split comparator (mapping-tree mapping) obj)
(%make-mapping comparator tree=))))
(define (mapping-range< mapping obj)
(assume (mapping? mapping))
(let ((comparator (mapping-key-comparator mapping)))
(receive (tree< tree<= tree= tree>= tree>)
(tree-split comparator (mapping-tree mapping) obj)
(%make-mapping comparator tree<))))
(define (mapping-range<= mapping obj)
(assume (mapping? mapping))
(let ((comparator (mapping-key-comparator mapping)))
(receive (tree< tree<= tree= tree>= tree>)
(tree-split comparator (mapping-tree mapping) obj)
(%make-mapping comparator tree<=))))
(define (mapping-range> mapping obj)
(assume (mapping? mapping))
(let ((comparator (mapping-key-comparator mapping)))
(receive (tree< tree<= tree= tree>= tree>)
(tree-split comparator (mapping-tree mapping) obj)
(%make-mapping comparator tree>))))
(define (mapping-range>= mapping obj)
(assume (mapping? mapping))
(assume (mapping? mapping))
(let ((comparator (mapping-key-comparator mapping)))
(receive (tree< tree<= tree= tree>= tree>)
(tree-split comparator (mapping-tree mapping) obj)
(%make-mapping comparator tree>=))))
(define mapping-range=! mapping-range=)
(define mapping-range<! mapping-range<)
(define mapping-range>! mapping-range>)
(define mapping-range<=! mapping-range<=)
(define mapping-range>=! mapping-range>=)
(define (mapping-split mapping obj)
(assume (mapping? mapping))
(let ((comparator (mapping-key-comparator mapping)))
(receive (tree< tree<= tree= tree>= tree>)
(tree-split comparator (mapping-tree mapping) obj)
(values (%make-mapping comparator tree<)
(%make-mapping comparator tree<=)
(%make-mapping comparator tree=)
(%make-mapping comparator tree>=)
(%make-mapping comparator tree>)))))
(define (mapping-catenate comparator mapping1 pivot-key pivot-value mapping2)
(assume (comparator? comparator))
(assume (mapping? mapping1))
(assume (mapping? mapping2))
(%make-mapping comparator (tree-catenate (mapping-tree mapping1)
pivot-key
pivot-value
(mapping-tree mapping2))))
(define mapping-catenate! mapping-catenate)
(define (mapping-map/monotone proc comparator mapping)
(assume (procedure? proc))
(assume (comparator? comparator))
(assume (mapping? mapping))
(%make-mapping comparator (tree-map proc (mapping-tree mapping))))
(define mapping-map/monotone! mapping-map/monotone)
(define (mapping-fold/reverse proc acc mapping)
(assume (procedure? proc))
(assume (mapping? mapping))
(tree-fold/reverse proc acc (mapping-tree mapping)))
;; Comparators
(define (mapping-equality comparator)
(assume (comparator? comparator))
(lambda (mapping1 mapping2)
(mapping=? comparator mapping1 mapping2)))
(define (mapping-ordering comparator)
(assume (comparator? comparator))
(let ((value-equality (comparator-equality-predicate comparator))
(value-ordering (comparator-ordering-predicate comparator)))
(lambda (mapping1 mapping2)
(let* ((key-comparator (mapping-key-comparator mapping1))
(equality (comparator-equality-predicate key-comparator))
(ordering (comparator-ordering-predicate key-comparator))
(gen1 (tree-generator (mapping-tree mapping1)))
(gen2 (tree-generator (mapping-tree mapping2))))
(let loop ()
(let ((item1 (gen1)) (item2 (gen2)))
(cond
((eof-object? item1)
(not (eof-object? item2)))
((eof-object? item2)
#f)
(else
(let ((key1 (car item1)) (value1 (cadr item1))
(key2 (car item2)) (value2 (cadr item2)))
(cond
((equality key1 key2)
(if (value-equality value1 value2)
(loop)
(value-ordering value1 value2)))
(else
(ordering key1 key2))))))))))))
(define (make-mapping-comparator comparator)
(make-comparator mapping? (mapping-equality comparator) (mapping-ordering comparator) #f))
(define mapping-comparator (make-mapping-comparator (make-default-comparator)))
(comparator-register-default! mapping-comparator)

439
lib/srfi/146/rbtree.scm Normal file
View file

@ -0,0 +1,439 @@
;; Copyright (C) Marc Nieper-Wißkirchen (2016). All Rights Reserved.
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.
;; Concrete data types
(define (make-item key value) (vector key value))
(define (item-key item) (vector-ref item 0))
(define (item-value item) (vector-ref item 1))
(define (node color left item right) (vector color left item right))
(define (color node) (vector-ref node 0))
(define (left node) (vector-ref node 1))
(define (item node) (vector-ref node 2))
(define (right node) (vector-ref node 3))
(define (key node) (item-key (item node)))
(define (value node) (item-value (item node)))
(define (red left item right) (node 'red left item right))
(define (black left item right)
(node 'black left item right))
(define (black-leaf) (black #f #f #f))
(define (white left item right)
(node 'white left item right))
(define (white-leaf) (white #f #f #f))
(define (red? node) (eq? (color node) 'red))
(define (black? node) (eq? (color node) 'black))
(define (white? node) (eq? (color node) 'white))
;;; Tree matcher macros
(define-syntax tree-match
(syntax-rules ()
((tree-match tree (pattern . expression*) ...)
(compile-patterns (expression* ...) tree () (pattern ...)))))
(define-syntax compile-patterns
(syntax-rules ()
((compile-patterns (expression* ...) tree (clauses ...) ())
(call-with-current-continuation
(lambda (return)
(or (and-let* clauses
(call-with-values
(lambda () . expression*)
return))
...
(error "tree does not match any pattern" tree)))))
((compile-patterns e tree clauses* (pattern . pattern*))
(compile-pattern tree pattern
(add-pattern e tree clauses* pattern*)))))
(define-syntax add-pattern
(syntax-rules ()
((add-pattern e tree (clauses ...) pattern* new-clauses)
(compile-patterns e tree (clauses ... new-clauses) pattern*))))
(define-syntax compile-pattern
(syntax-rules (_ and red? black? white? ? node red black white)
((compile-pattern tree (red? x) (k ...))
(k ... (((red? tree)) (x tree))))
((compile-pattern tree (black? x) (k ...))
(k ... (((black? tree)) (x tree))))
((compile-pattern tree (white? x) (k ...))
(k ... (((white? tree)) (x tree))))
((compile-pattern tree (black) (k ...))
(k ... (((black? tree)) ((not (item tree))))))
((compile-pattern tree (white) (k ...))
(k ... (((white? tree)) ((not (item tree))))))
((compile-pattern tree (and pt ...) k*)
(compile-subpatterns () ((t pt) ...)
(compile-and-pattern tree t k*)))
((compile-pattern tree (node pc pa px pb) k*)
(compile-subpatterns () ((c pc) (a pa) (x px) (b pb))
(compile-node-pattern tree c a x b k*)))
((compile-pattern tree (red pa px pb) k*)
(compile-subpatterns () ((a pa) (x px) (b pb))
(compile-color-pattern red? tree a x b k*)))
((compile-pattern tree (black pa px pb) k*)
(compile-subpatterns () ((a pa) (x px) (b pb))
(compile-color-pattern black? tree a x b k*)))
((compile-pattern tree (white pa px pb) k*)
(compile-subpatterns () ((a pa) (x px) (b pb))
(compile-color-pattern white? tree a x b k*)))
((compile-pattern tree _ (k ...))
(k ... ()))
((compile-pattern tree x (k ...))
(k ... ((x tree))))))
(define-syntax compile-and-pattern
(syntax-rules ()
((compile-and-pattern tree t (k ...) clauses)
(k ... ((t tree) . clauses)))))
(define-syntax compile-node-pattern
(syntax-rules ()
((compile-node-pattern tree c a x b (k ...) clauses)
(k ... (((item tree))
(c (color tree))
(a (left tree))
(x (item tree))
(b (right tree)) . clauses)))))
(define-syntax compile-color-pattern
(syntax-rules ()
((compile-color-pattern pred? tree a x b (k ...) clauses)
(k ... (((item tree))
((pred? tree))
(a (left tree))
(x (item tree))
(b (right tree)) . clauses)))))
(define-syntax compile-subpatterns
(syntax-rules ()
((compile-subpatterns clauses () (k ...))
(k ... clauses))
((compile-subpatterns clauses ((tree pattern) . rest) k*)
(compile-pattern tree pattern (add-subpattern clauses rest k*)))))
(define-syntax add-subpattern
(syntax-rules ()
((add-subpattern (clause ...) rest k* clauses)
(compile-subpatterns (clause ... . clauses) rest k*))))
;;; Tree recolouring procedures
(define (blacken tree)
(tree-match tree
((red a x b)
(black a x b))
(t t)))
(define (redden tree)
(tree-match tree
((black (black? a) x (black? b))
(red a x b))
(t t)))
(define (white->black tree)
(tree-match tree
((white)
(black-leaf))
((white a x b)
(black a x b))))
;;; Exported identifiers
(define (make-tree) (black-leaf))
(define (tree-fold proc seed tree)
(let loop ((acc seed) (tree tree))
(tree-match tree
((black)
acc)
((node _ a x b)
(let*
((acc (loop acc a))
(acc (proc (item-key x) (item-value x) acc))
(acc (loop acc b)))
acc)))))
(define (tree-fold/reverse proc seed tree)
(let loop ((acc seed) (tree tree))
(tree-match tree
((black)
acc)
((node _ a x b)
(let*
((acc (loop acc b))
(acc (proc (item-key x) (item-value x) acc))
(acc (loop acc a)))
acc)))))
(define (tree-for-each proc tree)
(tree-fold (lambda (key value acc)
(proc key value))
#f tree))
(define (tree-generator tree)
(make-coroutine-generator
(lambda (yield)
(tree-for-each (lambda item (yield item)) tree))))
(define (identity obj) obj)
(define (tree-search comparator tree obj failure success)
(receive (tree ret op)
(let search ((tree (redden tree)))
(tree-match tree
((black)
(failure
;; insert
(lambda (new-key new-value ret)
(values (red (black-leaf) (make-item new-key new-value) (black-leaf))
ret
balance))
;; ignore
(lambda (ret)
(values (black-leaf) ret identity))))
((and t (node c a x b))
(let ((key (item-key x)))
(comparator-if<=> comparator obj key
(receive (a ret op) (search a)
(values (op (node c a x b)) ret op))
(success
key
(item-value x)
;; update
(lambda (new-key new-value ret)
(values (node c a (make-item new-key new-value) b)
ret
identity))
;; remove
(lambda (ret)
(values
(tree-match t
((red (black) x (black))
(black-leaf))
((black (red a x b) _ (black))
(black a x b))
((black (black) _ (black))
(white-leaf))
(_
(receive (x b) (min+delete b)
(rotate (node c a x b)))))
ret
rotate)))
(receive (b ret op) (search b)
(values (op (node c a x b)) ret op)))))))
(values (blacken tree) ret)))
(define (tree-key-successor comparator tree obj failure)
(let loop ((return failure) (tree tree))
(tree-match tree
((black)
(return))
((node _ a x b)
(let ((key (item-key x)))
(comparator-if<=> comparator key obj
(loop return b)
(loop return b)
(loop (lambda () key) a)))))))
(define (tree-key-predecessor comparator tree obj failure)
(let loop ((return failure) (tree tree))
(tree-match tree
((black)
(return))
((node _ a x b)
(let ((key (item-key x)))
(comparator-if<=> comparator key obj
(loop (lambda () key) b)
(loop return a)
(loop return a)))))))
(define (tree-map proc tree)
(let loop ((tree tree))
(tree-match tree
((black)
(black-leaf))
((node c a x b)
(receive (key value)
(proc (item-key x) (item-value x))
(node c (loop a) (make-item key value) (loop b)))))))
(define (tree-catenate tree1 pivot-key pivot-value tree2)
(let ((pivot (make-item pivot-key pivot-value))
(height1 (black-height tree1))
(height2 (black-height tree2)))
(cond
((= height1 height2)
(black tree1 pivot tree2))
((< height1 height2)
(blacken
(let loop ((tree tree2) (depth (- height2 height1)))
(if (zero? depth)
(balance (red tree1 pivot tree))
(balance
(node (color tree) (loop (left tree) (- depth 1)) (item tree) (right tree)))))))
(else
(blacken
(let loop ((tree tree1) (depth (- height1 height2)))
(if (zero? depth)
(balance (red tree pivot tree2))
(balance
(node (color tree) (left tree) (item tree) (loop (right tree) (- depth 1)))))))))))
(define (tree-split comparator tree obj)
(let loop ((tree1 (black-leaf))
(tree2 (black-leaf))
(pivot1 #f)
(pivot2 #f)
(tree tree))
(tree-match tree
((black)
(let ((tree1 (catenate-left tree1 pivot1 (black-leaf)))
(tree2 (catenate-right (black-leaf) pivot2 tree2)))
(values tree1 tree1 (black-leaf) tree2 tree2)))
((node _ a x b)
(comparator-if<=> comparator obj (item-key x)
(loop tree1
(catenate-right (blacken b) pivot2 tree2)
pivot1
x
(blacken a))
(let* ((tree1 (catenate-left tree1 pivot1 (blacken a)))
(tree1+ (catenate-left tree1 x (black-leaf)))
(tree2 (catenate-right (blacken b) pivot2 tree2))
(tree2+ (catenate-right (black-leaf) x tree2)))
(values tree1
tree1+
(black (black-leaf) x (black-leaf))
tree2+
tree2))
(loop (catenate-left tree1 pivot1 (blacken a))
tree2
x
pivot2
(blacken b)))))))
(define (catenate-left tree1 item tree2)
(if item
(tree-catenate tree1 (item-key item) (item-value item) tree2)
tree2))
(define (catenate-right tree1 item tree2)
(if item
(tree-catenate tree1 (item-key item) (item-value item) tree2)
tree1))
(define (black-height tree)
(let loop ((tree tree))
(tree-match tree
((black)
0)
((node red a x b)
(loop b))
((node black a x b)
(+ 1 (loop b))))))
(define (left-tree tree depth)
(let loop ((parent #f) (tree tree) (depth depth))
(if (zero? depth)
(values parent tree)
(loop tree (left tree) (- depth 1)))))
(define (right-tree tree depth)
(let loop ((parent #f) (tree tree) (depth depth))
(if (zero? depth)
(values parent tree)
(loop tree (right tree) (- depth 1)))))
;;; Helper procedures for deleting and balancing
(define (min+delete tree)
(tree-match tree
((red (black) x (black))
(values x (black-leaf)))
((black (black) x (black))
(values x (white-leaf)))
((black (black) x (red a y b))
(values x (black a y b)))
((node c a x b)
(receive (v a) (min+delete a)
(values v (rotate (node c a x b)))))))
(define (balance tree)
(tree-match tree
((black (red (red a x b) y c) z d)
(red (black a x b) y (black c z d)))
((black (red a x (red b y c)) z d)
(red (black a x b) y (black c z d)))
((black a x (red (red b y c) z d))
(red (black a x b) y (black c z d)))
((black a x (red b y (red c z d)))
(red (black a x b) y (black c z d)))
((white (red a x (red b y c)) z d)
(black (black a x b) y (black c z d)))
((white a x (red (red b y c) z d))
(black (black a x b) y (black c z d)))
(t t)))
(define (rotate tree)
(tree-match tree
((red (white? a+x+b) y (black c z d))
(balance (black (red (white->black a+x+b) y c) z d)))
((red (black a x b) y (white? c+z+d))
(balance (black a x (red b y (white->black c+z+d)))))
((black (white? a+x+b) y (black c z d))
(balance (white (red (white->black a+x+b) y c) z d)))
((black (black a x b) y (white? c+z+d))
(balance (white a x (red b y (white->black c+z+d)))))
((black (white? a+w+b) x (red (black c y d) z e))
(black (balance (black (red (white->black a+w+b) x c) y d)) z e))
((black (red a w (black b x c)) y (white? d+z+e))
(black a w (balance (black b x (red c y (white->black d+z+e))))))
(t t)))
;; Local Variables:
;; eval: (put 'tree-match 'scheme-indent-function 1)
;; End:

526
lib/srfi/146/test.sld Normal file
View file

@ -0,0 +1,526 @@
;; Copyright (C) Marc Nieper-Wißkirchen (2016, 2017). All Rights
;; Reserved.
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and/or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.
(define-library (srfi 146 test)
(export run-tests)
(import (scheme base)
(srfi 1)
(srfi 8)
(srfi 128)
(srfi 146)
(chibi test))
(begin
(define (run-tests)
(test-begin "SRFI 146")
(test-group "Predicates"
(define mapping0 (mapping comparator))
(define mapping1 (mapping comparator 'a 1 'b 2 'c 3))
(define mapping2 (mapping comparator 'c 1 'd 2 'e 3))
(define mapping3 (mapping comparator 'd 1 'e 2 'f 3))
(test-assert "mapping?: a mapping"
(mapping? (mapping comparator)))
(test-assert "mapping?: not a mapping"
(not (mapping? (list 1 2 3))))
(test-assert "mapping-empty?: empty mapping"
(mapping-empty? mapping0))
(test-assert "mapping-empty?: non-empty mapping"
(not (mapping-empty? mapping1)))
(test-assert "mapping-contains?: containing"
(mapping-contains? mapping1 'b))
(test-assert "mapping-contains?: not containing"
(not (mapping-contains? mapping1 '2)))
(test-assert "mapping-disjoint?: disjoint"
(mapping-disjoint? mapping1 mapping3))
(test-assert "mapping-disjoint?: not disjoint"
(not (mapping-disjoint? mapping1 mapping2))))
(test-group "Accessors"
(define mapping1 (mapping comparator 'a 1 'b 2 'c 3))
(test "mapping-ref: key found"
2
(mapping-ref mapping1 'b))
(test "mapping-ref: key not found/with failure"
42
(mapping-ref mapping1 'd (lambda () 42)))
(test-error "mapping-ref: key not found/without failure"
(mapping-ref mapping1 'd))
(test "mapping-ref: with success procedure"
(* 2 2)
(mapping-ref mapping1 'b (lambda () #f) (lambda (x) (* x x))))
(test "mapping-ref/default: key found"
3
(mapping-ref/default mapping1 'c 42))
(test "mapping-ref/default: key not found"
42
(mapping-ref/default mapping1 'd 42))
(test "mapping-key-comparator"
comparator
(mapping-key-comparator mapping1)))
(test-group "Updaters"
(define mapping1 (mapping comparator 'a 1 'b 2 'c 3))
(define mapping2 (mapping-set mapping1 'c 4 'd 4 'd 5))
(define mapping3 (mapping-update mapping1 'b (lambda (x) (* x x))))
(define mapping4 (mapping-update/default mapping1 'd (lambda (x) (* x x)) 4))
(define mapping5 (mapping-adjoin mapping1 'c 4 'd 4 'd 5))
(define mapping0 (mapping comparator))
(test "mapping-adjoin: key already in mapping"
3
(mapping-ref mapping5 'c))
(test "mapping-adjoin: key set earlier"
4
(mapping-ref mapping5 'd))
(test "mapping-set: key already in mapping"
4
(mapping-ref mapping2 'c))
(test "mapping-set: key set earlier"
5
(mapping-ref mapping2 'd))
(test "mapping-replace: key not in mapping"
#f
(mapping-ref/default (mapping-replace mapping1 'd 4) 'd #f))
(test "mapping-replace: key in mapping"
6
(mapping-ref (mapping-replace mapping1 'c 6) 'c))
(test "mapping-delete"
42
(mapping-ref/default (mapping-delete mapping1 'b) 'b 42))
(test "mapping-delete-all"
42
(mapping-ref/default (mapping-delete-all mapping1 '(a b)) 'b 42))
(test "mapping-intern: key in mapping"
(list mapping1 2)
(receive result
(mapping-intern mapping1 'b (lambda () (error "should not have been invoked")))
result))
(test "mapping-intern: key not in mapping"
(list 42 42)
(receive (mapping value)
(mapping-intern mapping1 'd (lambda () 42))
(list value (mapping-ref mapping 'd))))
(test "mapping-update"
4
(mapping-ref mapping3 'b))
(test "mapping-update/default"
16
(mapping-ref mapping4 'd))
(test "mapping-pop: empty mapping"
'empty
(mapping-pop mapping0 (lambda () 'empty)))
(test "mapping-pop: non-empty mapping"
(list 2 'a 1)
(receive (mapping key value)
(mapping-pop mapping1)
(list (mapping-size mapping) key value))))
(test-group "The whole mapping"
(define mapping0 (mapping comparator))
(define mapping1 (mapping comparator 'a 1 'b 2 'c 3))
(test "mapping-size: empty mapping"
0
(mapping-size mapping0))
(test "mapping-size: non-empty mapping"
3
(mapping-size mapping1))
(test "mapping-find: found in mapping"
(list 'b 2)
(receive result
(mapping-find (lambda (key value)
(and (eq? key 'b)
(= value 2)))
mapping1
(lambda () (error "should not have been called")))
result))
(test "mapping-find: not found in mapping"
(list 42)
(receive result
(mapping-find (lambda (key value)
(eq? key 'd))
mapping1
(lambda ()
42))
result))
(test "mapping-count"
2
(mapping-count (lambda (key value)
(>= value 2))
mapping1))
(test-assert "mapping-any?: found"
(mapping-any? (lambda (key value)
(= value 3))
mapping1))
(test-assert "mapping-any?: not found"
(not (mapping-any? (lambda (key value)
(= value 4))
mapping1)))
(test-assert "mapping-every?: true"
(mapping-every? (lambda (key value)
(<= value 3))
mapping1))
(test-assert "mapping-every?: false"
(not (mapping-every? (lambda (key value)
(<= value 2))
mapping1)))
(test "mapping-keys"
3
(length (mapping-keys mapping1)))
(test "mapping-values"
6
(fold + 0 (mapping-values mapping1)))
(test "mapping-entries"
(list 3 6)
(receive (keys values)
(mapping-entries mapping1)
(list (length keys) (fold + 0 values)))))
(test-group "Mapping and folding"
(define mapping1 (mapping comparator 'a 1 'b 2 'c 3))
(define mapping2 (mapping-map (lambda (key value)
(values (symbol->string key)
(* 10 value)))
comparator
mapping1))
(test "mapping-map"
20
(mapping-ref mapping2 "b"))
(test "mapping-for-each"
6
(let ((counter 0))
(mapping-for-each (lambda (key value)
(set! counter (+ counter value)))
mapping1)
counter))
(test "mapping-fold"
6
(mapping-fold (lambda (key value acc)
(+ value acc))
0
mapping1))
(test "mapping-map->list"
(+ (* 1 1) (* 2 2) (* 3 3))
(fold + 0 (mapping-map->list (lambda (key value)
(* value value))
mapping1)))
(test "mapping-filter"
2
(mapping-size (mapping-filter (lambda (key value)
(<= value 2))
mapping1)))
(test "mapping-remove"
1
(mapping-size (mapping-remove (lambda (key value)
(<= value 2))
mapping1)))
(test "mapping-partition"
(list 1 2)
(receive result
(mapping-partition (lambda (key value)
(eq? 'b key))
mapping1)
(map mapping-size result)))
(test-group "Copying and conversion"
(define mapping1 (mapping comparator 'a 1 'b 2 'c 3))
(define mapping2 (alist->mapping comparator '((a . 1) (b . 2) (c . 3))))
(define mapping3 (alist->mapping! (mapping-copy mapping1) '((d . 4) '(c . 5))))
(test "mapping-copy: same size"
3
(mapping-size (mapping-copy mapping1)))
(test "mapping-copy: same comparator"
comparator
(mapping-key-comparator (mapping-copy mapping1)))
(test "mapping->alist"
(cons 'b 2)
(assq 'b (mapping->alist mapping1)))
(test "alist->mapping"
2
(mapping-ref mapping2 'b)
)
(test "alist->mapping!: new key"
4
(mapping-ref mapping3 'd))
(test "alist->mapping!: existing key"
3
(mapping-ref mapping3 'c)))
(test-group "Submappings"
(define mapping1 (mapping comparator 'a 1 'b 2 'c 3))
(define mapping2 (mapping comparator 'a 1 'b 2 'c 3))
(define mapping3 (mapping comparator 'a 1 'c 3))
(define mapping4 (mapping comparator 'a 1 'c 3 'd 4))
(define mapping5 (mapping comparator 'a 1 'b 2 'c 6))
(define mapping6 (mapping (make-comparator (comparator-type-test-predicate comparator)
(comparator-equality-predicate comparator)
(comparator-ordering-predicate comparator)
(comparator-hash-function comparator))
'a 1 'b 2 'c 3))
(test-assert "mapping=?: equal mappings"
(mapping=? comparator mapping1 mapping2))
(test-assert "mapping=?: unequal mappings"
(not (mapping=? comparator mapping1 mapping4)))
(test-assert "mapping=?: different comparators"
(not (mapping=? comparator mapping1 mapping6)))
(test-assert "mapping<?: proper subset"
(mapping<? comparator mapping3 mapping1))
(test-assert "mapping<?: improper subset"
(not (mapping<? comparator mapping3 mapping1 mapping2)))
(test-assert "mapping>?: proper superset"
(mapping>? comparator mapping2 mapping3))
(test-assert "mapping>?: improper superset"
(not (mapping>? comparator mapping1 mapping2 mapping3)))
(test-assert "mapping<=?: subset"
(mapping<=? comparator mapping3 mapping2 mapping1))
(test-assert "mapping<=?: non-matching values"
(not (mapping<=? comparator mapping3 mapping5)))
(test-assert "mapping<=?: not a subset"
(not (mapping<=? comparator mapping2 mapping4)))
(test-assert "mapping>=?: superset"
(mapping>=? comparator mapping4 mapping3))
(test-assert "mapping>=?: not a superset"
(not (mapping>=? comparator mapping5 mapping3))))
(test-group "Set theory operations"
(define mapping1 (mapping comparator 'a 1 'b 2 'c 3))
(define mapping2 (mapping comparator 'a 1 'b 2 'd 4))
(define mapping3 (mapping comparator 'a 1 'b 2))
(define mapping4 (mapping comparator 'a 1 'b 2 'c 4))
(define mapping5 (mapping comparator 'a 1 'c 3))
(define mapping6 (mapping comparator 'd 4 'e 5 'f 6))
(test "mapping-union: new association"
4
(mapping-ref (mapping-union mapping1 mapping2) 'd))
(test "mapping-union: existing association"
3
(mapping-ref (mapping-union mapping1 mapping4) 'c))
(test "mapping-union: three mappings"
6
(mapping-size (mapping-union mapping1 mapping2 mapping6)))
(test "mapping-intersection: existing association"
3
(mapping-ref (mapping-intersection mapping1 mapping4) 'c))
(test "mapping-intersection: removed association"
42
(mapping-ref/default (mapping-intersection mapping1 mapping5) 'b 42))
(test "mapping-difference"
2
(mapping-size (mapping-difference mapping2 mapping6)))
(test "mapping-xor"
4
(mapping-size (mapping-xor mapping2 mapping6))))
(test-group "Additional procedures for mappings with ordered keys"
(define mapping1 (mapping comparator 'a 1 'b 2 'c 3))
(define mapping2 (mapping comparator 'a 1 'b 2 'c 3 'd 4))
(define mapping3 (mapping comparator 'a 1 'b 2 'c 3 'd 4 'e 5))
(define mapping4 (mapping comparator 'a 1 'b 2 'c 3 'd 4 'e 5 'f 6))
(define mapping5 (mapping comparator 'f 6 'g 7 'h 8))
(test "mapping-min-key"
'(a a a a)
(map mapping-min-key (list mapping1 mapping2 mapping3 mapping4)))
(test "mapping-max-key"
'(c d e f)
(map mapping-max-key (list mapping1 mapping2 mapping3 mapping4)))
(test "mapping-min-value"
'(1 1 1 1)
(map mapping-min-value (list mapping1 mapping2 mapping3 mapping4)))
(test "mapping-max-value"
'(3 4 5 6)
(map mapping-max-value (list mapping1 mapping2 mapping3 mapping4)))
(test "mapping-key-predecessor"
'(c d d d)
(map (lambda (mapping)
(mapping-key-predecessor mapping 'e (lambda () #f)))
(list mapping1 mapping2 mapping3 mapping4)))
(test "mapping-key-successor"
'(#f #f e e)
(map (lambda (mapping)
(mapping-key-successor mapping 'd (lambda () #f)))
(list mapping1 mapping2 mapping3 mapping4)))
(test "mapping-range=: contained"
'(4)
(mapping-values (mapping-range= mapping4 'd)))
(test "mapping-range=: not contained"
'()
(mapping-values (mapping-range= mapping4 'z)))
(test "mapping-range<"
'(1 2 3)
(mapping-values (mapping-range< mapping4 'd)))
(test "mapping-range<="
'(1 2 3 4)
(mapping-values (mapping-range<= mapping4 'd)))
(test "mapping-range>"
'(5 6)
(mapping-values (mapping-range> mapping4 'd)))
(test "mapping-range>="
'(4 5 6)
(mapping-values (mapping-range>= mapping4 'd)))
(test "mapping-split"
'((1 2 3) (1 2 3 4) (4) (4 5 6) (5 6))
(receive mappings
(mapping-split mapping4 'd)
(map mapping-values mappings)))
(test "mapping-catenate"
'((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6) (g . 7) (h . 8))
(mapping->alist (mapping-catenate comparator mapping2 'e 5 mapping5)))
(test "mapping-map/monotone"
'((1 . 1) (2 . 4) (3 . 9))
(mapping->alist
(mapping-map/monotone (lambda (key value)
(values value (* value value)))
comparator
mapping1)))
(test "mapping-fold/reverse"
'(1 2 3)
(mapping-fold/reverse (lambda (key value acc)
(cons value acc))
'() mapping1)))
(test-group "Comparators"
(define mapping1 (mapping comparator 'a 1 'b 2 'c 3))
(define mapping2 (mapping comparator 'a 1 'b 2 'c 3))
(define mapping3 (mapping comparator 'a 1 'b 2))
(define mapping4 (mapping comparator 'a 1 'b 2 'c 4))
(define mapping5 (mapping comparator 'a 1 'c 3))
(define mapping0 (mapping comparator mapping1 "a" mapping2 "b" mapping3 "c" mapping4 "d" mapping5 "e"))
(test-assert "mapping-comparator"
(comparator? mapping-comparator))
(test "mapping-keyed mapping"
(list "a" "a" "c" "d" "e")
(list (mapping-ref mapping0 mapping1)
(mapping-ref mapping0 mapping2)
(mapping-ref mapping0 mapping3)
(mapping-ref mapping0 mapping4)
(mapping-ref mapping0 mapping5)))
(test-group "Ordering comparators"
(test-assert "=?: equal mappings"
(=? comparator mapping1 mapping2))
(test-assert "=?: unequal mappings"
(not (=? comparator mapping1 mapping4)))
(test-assert "<?: case 1"
(<? comparator mapping3 mapping4))
(test-assert "<?: case 2"
(<? comparator mapping1 mapping4))
(test-assert "<?: case 3"
(<? comparator mapping1 mapping5)))))
(test-end "SRFI 146"))
(define comparator (make-default-comparator))))