ikarus/scheme/tests/sorting.ss

107 lines
2.8 KiB
Scheme
Raw Normal View History

(library (tests sorting)
(export test-sorting)
(import (ikarus))
(define (permutations ls)
(define (rem* ls)
(cond
[(null? ls) '()]
[else
(cons (cdr ls)
(map
(lambda (a) (cons (car ls) a))
(rem* (cdr ls))))]))
(cond
[(null? ls) '(())]
[else
(apply append
(map
(lambda (x a*)
(map (lambda (a) (cons x a)) a*))
ls
(map permutations (rem* ls))))]))
(define (test-permutations)
(define (fact n)
(if (zero? n)
1
(* n (fact (- n 1)))))
(define (test ls)
(let ([p* (permutations ls)])
(printf "Testing ~s permutations of ~s\n"
(length p*) ls)
(unless (= (length p*) (fact (length ls)))
(error 'test-permutations "incorrect number of permutations"))
(let f ([p* p*])
(unless (null? p*)
(let ([p (car p*)])
(when (member p (cdr p*))
(error 'test-permutations "duplicate" p))
(f (cdr p*)))))))
(test '())
(test '(1))
(test '(1 2))
(test '(1 2 3))
(test '(1 2 3 4))
(test '(1 2 3 4 5))
(test '(1 2 3 4 5 6)))
(define (test-vector-sort)
(define (test ls)
(let ([v1 (list->vector ls)]
[p* (map list->vector (permutations ls))])
(printf "Testing vector-sort for all ~s permutations of ~s\n"
(length p*) v1)
(for-each
(lambda (p)
(let* ([copy (list->vector (vector->list p))]
[sv (vector-sort < p)])
(unless (equal? copy p)
(error 'test-vector-sort "vector was mutated"))
(unless (equal? v1 sv)
(error 'test-vector-sort "failed" p sv))))
p*)))
(test '())
(test '(1))
(test '(1 2))
(test '(1 2 3))
(test '(1 2 3 4))
(test '(1 2 3 4 5))
(test '(1 2 3 4 5 6))
(test '(1 2 3 4 5 6 7))
(test '(1 2 3 4 5 6 7 8)))
(define (test-list-sort)
(define (test ls)
(let ([p* (permutations ls)])
(printf "Testing list-sort for all ~s permutations of ~s\n"
(length p*) ls)
(for-each
(lambda (p)
(let* ([copy (map values p)]
[sv (list-sort < p)])
(unless (equal? copy p)
(error 'test-list-sort "list was changed"))
(unless (equal? ls sv)
(error 'test-list-sort "failed" p sv))))
p*)))
(test '())
(test '(1))
(test '(1 2))
(test '(1 2 3))
(test '(1 2 3 4))
(test '(1 2 3 4 5))
(test '(1 2 3 4 5 6))
(test '(1 2 3 4 5 6 7))
(test '(1 2 3 4 5 6 7 8)))
(define (test-sorting)
(test-permutations)
(test-vector-sort)
(test-list-sort)))