chibi-scheme/lib/srfi/146/mapping.scm

;; 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)