;; -*- coding:utf-8 -*-
;; 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 64)
	  (srfi 128)
	  (srfi 146))
  (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-equal "mapping-ref: key found"
	  2
	  (mapping-ref mapping1 'b))

	(test-equal "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-equal "mapping-ref: with success procedure"
	  (* 2 2)
	  (mapping-ref mapping1 'b (lambda () #f) (lambda (x) (* x x))))

	(test-equal "mapping-ref/default: key found"
	  3
	  (mapping-ref/default mapping1 'c 42))

	(test-equal "mapping-ref/default: key not found"
	  42
	  (mapping-ref/default mapping1 'd 42))

	(test-equal "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-equal "mapping-adjoin: key already in mapping"
	  3
	  (mapping-ref mapping5 'c))

	(test-equal "mapping-adjoin: key set earlier"
	  4
	  (mapping-ref mapping5 'd))
	
	(test-equal "mapping-set: key already in mapping"
	  4
	  (mapping-ref mapping2 'c))

	(test-equal "mapping-set: key set earlier"
	  5
	  (mapping-ref mapping2 'd))

	(test-equal "mapping-replace: key not in mapping"
	  #f
	  (mapping-ref/default (mapping-replace mapping1 'd 4) 'd #f))

	(test-equal "mapping-replace: key in mapping"
	  6
	  (mapping-ref (mapping-replace mapping1 'c 6) 'c))

	(test-equal "mapping-delete"
	  42
	  (mapping-ref/default (mapping-delete mapping1 'b) 'b 42))

	(test-equal "mapping-delete-all"
	  42
	  (mapping-ref/default (mapping-delete-all mapping1 '(a b)) 'b 42))
       
	(test-equal "mapping-intern: key in mapping"
	  (list mapping1 2)
	  (receive result
	      (mapping-intern mapping1 'b (lambda () (error "should not have been invoked")))
	    result))

	(test-equal "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-equal "mapping-update"
	  4
	  (mapping-ref mapping3 'b))

	(test-equal "mapping-update/default"
	  16
	  (mapping-ref mapping4 'd))

	(test-equal "mapping-pop: empty mapping"
	  'empty
	  (mapping-pop mapping0 (lambda () 'empty)))

	(test-equal "mapping-pop: non-empty mapping"
	  (list 2 'a 1)
	  (receive (mapping key value)
	      (mapping-pop mapping1)
	    (list (mapping-size mapping) key value)))

        (test-equal
         '("success updated"
           "failure ignored"
           ((0 . "zero") (1 . "one") (2 . "two [seen]") (3 . "three")
            (4 . "four") (5 . "five")))
         (let ((m1 (mapping (make-default-comparator)
                            1 "one"
                            3 "three"
                            0 "zero"
                            4 "four"
                            2 "two"
                            5 "five")))
           (define (f/ignore insert ignore)
             (ignore "failure ignored"))
           (define (s/update key val update remove)
             (update key
                     (string-append val " [seen]")
                     "success updated"))
           (let*-values (((m2 v2) (mapping-search m1 2 f/ignore s/update))
                         ((m3 v3) (mapping-search m2 42 f/ignore s/update)))
             (list v2 v3 (mapping->alist m3))))))

      (test-group "The whole mapping"
	(define mapping0 (mapping comparator))
	(define mapping1 (mapping comparator 'a 1 'b 2 'c 3))

	(test-equal "mapping-size: empty mapping"
	  0
	  (mapping-size mapping0))

	(test-equal "mapping-size: non-empty mapping"
	  3
	  (mapping-size mapping1))

	(test-equal "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-equal "mapping-find: not found in mapping"
	  (list 42)
	  (receive result
	      (mapping-find (lambda (key value)
			  (eq? key 'd))
			mapping1
			(lambda ()
			  42))
	    result))

	(test-equal "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-equal "mapping-keys"
	  3
	  (length (mapping-keys mapping1)))

	(test-equal "mapping-values"
	  6
	  (fold + 0 (mapping-values mapping1)))

	(test-equal "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-equal "mapping-map"
	  20
	  (mapping-ref mapping2 "b"))

	(test-equal "mapping-for-each"
	  6
	  (let ((counter 0))
	    (mapping-for-each (lambda (key value)
			    (set! counter (+ counter value)))
			  mapping1)
	    counter))

	(test-equal "mapping-fold"
	  6
	  (mapping-fold (lambda (key value acc)
		      (+ value acc))
		    0
		    mapping1))

	(test-equal "mapping-map->list"
	  (+ (* 1 1) (* 2 2) (* 3 3))
	  (fold + 0 (mapping-map->list (lambda (key value)
				     (* value value))
				   mapping1)))

	(test-equal "mapping-filter"
	  2
	  (mapping-size (mapping-filter (lambda (key value)
				  (<= value 2))
				mapping1)))

	(test-equal "mapping-remove"
	  1
	  (mapping-size (mapping-remove (lambda (key value)
				  (<= value 2))
				mapping1)))

	(test-equal "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-equal "mapping-copy: same size"
	    3
	    (mapping-size (mapping-copy mapping1)))

	  (test-equal "mapping-copy: same comparator"
	    comparator
	    (mapping-key-comparator (mapping-copy mapping1)))

	  (test-equal "mapping->alist"
	    (cons 'b 2)
	    (assq 'b (mapping->alist mapping1)))
	  
	  (test-equal "alist->mapping"
	    2
	    (mapping-ref mapping2 'b)
	    )

	  (test-equal "alist->mapping!: new key"
	    4
	    (mapping-ref mapping3 'd))

	  (test-equal "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-equal "mapping-union: new association"
	    4
	    (mapping-ref (mapping-union mapping1 mapping2) 'd))

	  (test-equal "mapping-union: existing association"
	    3
	    (mapping-ref (mapping-union mapping1 mapping4) 'c))
	  
	  (test-equal "mapping-union: three mappings"
	    6
	    (mapping-size (mapping-union mapping1 mapping2 mapping6)))
	  
	  (test-equal "mapping-intersection: existing association"
	    3
	    (mapping-ref (mapping-intersection mapping1 mapping4) 'c))

	  (test-equal "mapping-intersection: removed association"
	    42
	    (mapping-ref/default (mapping-intersection mapping1 mapping5) 'b 42))

	  (test-equal "mapping-difference"
	    2
	    (mapping-size (mapping-difference mapping2 mapping6)))

	  (test-equal "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-equal "mapping-min-key"
	    '(a a a a)
	    (map mapping-min-key (list mapping1 mapping2 mapping3 mapping4)))

	  (test-equal "mapping-max-key"
	    '(c d e f)
	    (map mapping-max-key (list mapping1 mapping2 mapping3 mapping4)))
	  
	  (test-equal "mapping-min-value"
	    '(1 1 1 1)
	    (map mapping-min-value (list mapping1 mapping2 mapping3 mapping4)))

	  (test-equal "mapping-max-value"
	    '(3 4 5 6)
	    (map mapping-max-value (list mapping1 mapping2 mapping3 mapping4)))

	  (test-equal "mapping-key-predecessor"
	    '(c d d d)
	    (map (lambda (mapping)
		   (mapping-key-predecessor mapping 'e (lambda () #f)))
		 (list mapping1 mapping2 mapping3 mapping4)))

	  (test-equal "mapping-key-successor"
	    '(#f #f e e)
	    (map (lambda (mapping)
		   (mapping-key-successor mapping 'd (lambda () #f)))
		 (list mapping1 mapping2 mapping3 mapping4)))

	  (test-equal "mapping-range=: contained"
	    '(4)
	    (mapping-values (mapping-range= mapping4 'd)))

	  (test-equal "mapping-range=: not contained"
	    '()
	    (mapping-values (mapping-range= mapping4 'z)))

	  (test-equal "mapping-range<"
	    '(1 2 3)
	    (mapping-values (mapping-range< mapping4 'd)))

	  (test-equal "mapping-range<="
	    '(1 2 3 4)
	    (mapping-values (mapping-range<= mapping4 'd)))

	  (test-equal "mapping-range>"
	    '(5 6)
	    (mapping-values (mapping-range> mapping4 'd)))

	  (test-equal "mapping-range>="
	    '(4 5 6)
	    (mapping-values (mapping-range>= mapping4 'd)))

	  (test-equal "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-equal "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-equal "mapping-map/monotone"
	    '((1 . 1) (2 . 4) (3 . 9))
	    (mapping->alist
	     (mapping-map/monotone (lambda (key value)
				     (values value (* value value)))
				   comparator
				   mapping1)))

	  (test-equal "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-equal "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))))
