diff options
Diffstat (limited to 'wttree-test.scm')
| -rwxr-xr-x | wttree-test.scm | 232 |
1 files changed, 232 insertions, 0 deletions
diff --git a/wttree-test.scm b/wttree-test.scm new file mode 100755 index 0000000..117e365 --- /dev/null +++ b/wttree-test.scm @@ -0,0 +1,232 @@ +;; +;; Copyright (C) 2010 Kazu Yamamoto +;; +;; Permission to use, copy, modify, and/or distribute this software for +;; any purpose with or without fee is hereby granted, provided that the +;; above copyright notice and this permission notice appear in all +;; copies. +;; +;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL +;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE +;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL +;; DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR +;; PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +;; TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +;; PERFORMANCE OF THIS SOFTWARE. + +;; +;; This code is to test "wttree.scm". Test cases are automatically +;; generated and properties are tested. +;; + +;; +;; Preamble +;; + +(require 'wt-tree) +(require 'srfi-1) +(require 'random) +(require 'format) +(require 'sort) + +(define (sort1 lst) + (sort lst <)) + +;; +;; Utilities for wt-tree +;; + +(define (random-alist n) + (zip (random-list n))) + +(define integer-scale 10) + +(define (random-list n) + (let ((range (* n integer-scale))) + (list-tabulate n + (lambda (dummy) + (random range))))) + +(define (from-alist al) + (alist->wt-tree number-wt-type al)) + +(define (to-list tree) + (wt-tree/fold (lambda (k v l) (cons k l)) '() tree)) + +(define (uniq x) + (define (func y z) + (if (and (not (null? z)) (equal? y (car z))) + z + (cons y z))) + (fold-right func () x)) + +;; +;; Engine +;; + +(define number-of-range 10) + +(define (ladder i) + (let* ((unit (quotient number-of-tests number-of-range)) + (size (* unit (+ (quotient i unit) 1)))) + size)) + +(define (try-test lst i) + (let* ((func (car lst)) + (syms (cdr lst)) + (size (ladder i)) + (args (map (type-to-data size) syms))) + (if (apply func args) + #t + args))) + +(define (type-to-data size) + (lambda (type) + (cond + ((eq? type 'alist) + (random-alist size)) + ((eq? type 'ulist) + (uniq (sort1 (random-list size)))) + ((eq? type 'int) + (random size)) + (else + (error "Unknown type: " type))))) + +;; +;; property tests +;; + +(define (prop-alist->wt-tree alst) + (wt-tree/valid? (from-alist alst))) + +(define (prop-wt-tree/index ulst) + (let* ((alst (zip ulst ulst)) + (tree (from-alist alst)) + (idx (quotient (length alst) 2))) + (equal? (wt-tree/index tree idx) (list-ref ulst idx)))) + +(define (prop-wt-tree/fold alst) + (let* ((model (uniq (sort1 (map car alst)))) + (tree (from-alist alst)) + (this (to-list tree))) + (equal? model this))) + +(define (prop-wt-tree/add alst k v) + (wt-tree/valid? (wt-tree/add (from-alist alst) k v))) + +(define (prop-wt-tree/delete alst) + (let* ((tree (from-alist alst)) + (len (length alst)) + (k (car (list-ref alst (quotient len 2))))) + (wt-tree/valid? (wt-tree/delete tree k)))) + +(define (prop-wt-tree/delete-min alst) + (wt-tree/valid? (wt-tree/delete-min (from-alist alst)))) + +(define (prop-wt-tree/lookup alst) + (let* ((tree (from-alist alst)) + (len (length alst)) + (k (car (list-ref alst (quotient len 2))))) + (eq? (wt-tree/lookup tree k #f) '()))) + +(define (prop-wt-tree/add-lookup alst k v) + (let ((tree (wt-tree/add (from-alist alst) k v))) + (eq? (wt-tree/lookup tree k #f) v))) + +(define (prop-wt-tree/union alst1 alst2) + (let ((t1 (from-alist alst1)) + (t2 (from-alist alst2))) + (wt-tree/valid? (wt-tree/union t1 t2)))) + +(define (prop-wt-tree/union-merge alst1 alst2) + (let ((t1 (from-alist alst1)) + (t2 (from-alist alst2))) + (wt-tree/valid? (wt-tree/union-merge + t1 t2 (lambda (key datum-1 datum-2) datum-1))))) + +(define (prop-wt-tree/union-model alst1 alst2) + (let* ((l1 (uniq (sort1 (map car alst1)))) + (l2 (uniq (sort1 (map car alst2)))) + (model (sort1 (lset-union eq? l1 l2))) + (t1 (from-alist alst1)) + (t2 (from-alist alst2)) + (this (sort1 (to-list (wt-tree/union t1 t2))))) + (equal? model this))) + +(define (prop-wt-tree/intersection alst1 alst2) + (let ((t1 (from-alist alst1)) + (t2 (from-alist alst2))) + (wt-tree/valid? (wt-tree/intersection t1 t2)))) + +(define (prop-wt-tree/intersection-model alst1 alst2) + (let* ((l1 (uniq (sort1 (map car alst1)))) + (l2 (uniq (sort1 (map car alst2)))) + (model (sort1 (lset-intersection eq? l1 l2))) + (t1 (from-alist alst1)) + (t2 (from-alist alst2)) + (this (sort1 (to-list (wt-tree/intersection t1 t2))))) + (equal? model this))) + +(define (prop-wt-tree/difference alst1 alst2) + (let ((t1 (from-alist alst1)) + (t2 (from-alist alst2))) + (wt-tree/valid? (wt-tree/difference t1 t2)))) + +(define (prop-wt-tree/difference-model alst1 alst2) + (let* ((l1 (uniq (sort1 (map car alst1)))) + (l2 (uniq (sort1 (map car alst2)))) + (model (sort1 (lset-difference eq? l1 l2))) + (t1 (from-alist alst1)) + (t2 (from-alist alst2)) + (this (sort1 (to-list (wt-tree/difference t1 t2))))) + (equal? model this))) + +;; +;; test db +;; + +(define test-alist + (list + (list "alist->wt-tree" prop-alist->wt-tree 'alist) + (list "wt-tree/index" prop-wt-tree/index 'ulist) + (list "wt-tree/fold" prop-wt-tree/fold 'alist) + (list "wt-tree/add" prop-wt-tree/add 'alist 'int 'int) + (list "wt-tree/delete" prop-wt-tree/delete 'alist) + (list "wt-tree/delete-min" prop-wt-tree/delete-min 'alist) + (list "wt-tree/lookup" prop-wt-tree/lookup 'alist) + (list "wt-tree/add-lookup" prop-wt-tree/add-lookup 'alist 'int 'int) + (list "wt-tree/union" prop-wt-tree/union 'alist 'alist) + (list "wt-tree/union-merge" prop-wt-tree/union-merge 'alist 'alist) + (list "wt-tree/union-model" prop-wt-tree/union-model 'alist 'alist) + (list "wt-tree/intersection" prop-wt-tree/intersection 'alist 'alist) + (list "wt-tree/intersection-model" prop-wt-tree/intersection-model 'alist 'alist) + (list "wt-tree/difference" prop-wt-tree/difference 'alist 'alist) + (list "wt-tree/difference-model" prop-wt-tree/difference-model 'alist 'alist))) + +;; +;; main +;; + +(define number-of-tests 300) + +(define (run-test prop) + (let ((tag (car prop)) + (test (cdr prop))) + (format #t "~a: testing ~d cases... " tag number-of-tests) + (force-output) + (let loop ((i 0)) + (cond + ((>= i number-of-tests) + (display "PASS\n") + (force-output)) + (else + (let ((ret (try-test test i))) + (cond + ((eq? ret #t) + (loop (+ 1 i))) + (else + (display "FAIL\n") + (format #t "~d/~d: ~a\n" i number-of-tests ret))))))))) + +(for-each run-test test-alist) |