home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / slib / wttest.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  5.0 KB  |  135 lines
  1. ;;  "wttrtst.scm" Test Weight balanced trees        -*-Scheme-*-
  2. ;;  Copyright (c) 1993-1994 Stephen Adams
  3. ;;
  4. ;;  Copyright (c) 1993-94 Massachusetts Institute of Technology
  5. ;;
  6. ;;  This material was developed by the Scheme project at the Massachusetts
  7. ;;  Institute of Technology, Department of Electrical Engineering and
  8. ;;  Computer Science.  Permission to copy this software, to redistribute
  9. ;;  it, and to use it for any purpose is granted, subject to the following
  10. ;;  restrictions and understandings.
  11. ;;
  12. ;;  1. Any copy made of this software must include this copyright notice
  13. ;;  in full.
  14. ;;
  15. ;;  2. Users of this software agree to make their best efforts (a) to
  16. ;;  return to the MIT Scheme project any improvements or extensions that
  17. ;;  they make, so that these may be included in future releases; and (b)
  18. ;;  to inform MIT of noteworthy uses of this software.
  19. ;;
  20. ;;  3. All materials developed as a consequence of the use of this
  21. ;;  software shall duly acknowledge such use, in accordance with the usual
  22. ;;  standards of acknowledging credit in academic research.
  23. ;;
  24. ;;  4. MIT has made no warrantee or representation that the operation of
  25. ;;  this software will be error-free, and MIT is under no obligation to
  26. ;;  provide any services, by way of maintenance, update, or otherwise.
  27. ;;
  28. ;;  5. In conjunction with products arising from the use of this material,
  29. ;;  there shall be no use of the name of the Massachusetts Institute of
  30. ;;  Technology nor of any adaptation thereof in any advertising,
  31. ;;  promotional, or sales literature without prior written consent from
  32. ;;  MIT in each case.
  33.  
  34. (require 'wt-tree)
  35.  
  36. ;;  Test code, using maps from digit strings to the numbers they represent.
  37.  
  38. (define (wt-test)
  39.  
  40.   (define (make-map lo hi step)
  41.     (let loop ((i lo) (map (make-wt-tree string-wt-type)))
  42.       (if (> i hi)
  43.           map
  44.           (loop (+ i step) (wt-tree/add map (number->string i) i)))))
  45.  
  46.   (define (wt-tree->alist t)
  47.     (wt-tree/fold (lambda (key datum rest) (cons (cons key datum) rest)) '() t))
  48.  
  49.   (define (try-all operation trees)
  50.     (map (lambda (t1)
  51.            (map (lambda (t2)
  52.                   (operation t1 t2))
  53.                 trees))
  54.          trees))
  55.  
  56.   (define (chunk tree)
  57.     (let ((size  (wt-tree/size tree)))
  58.       (if (< size 8)
  59.           size
  60.           (let* ((midpoint (if (even? size)
  61.                                (/ size 2)
  62.                                (/ (+ size 1) 2)))
  63.                  (fulcrum  (wt-tree/index tree midpoint)))
  64.             (list (chunk (wt-tree/split< tree fulcrum))
  65.                   (list fulcrum)
  66.                   (chunk (wt-tree/split> tree fulcrum)))))))
  67.  
  68.   (define (verify name result expected)
  69.     (newline)
  70.     (display "Test ") (display name)
  71.     (if (equal? result expected)
  72.         (begin
  73.           (display " passed"))
  74.         (begin
  75.           (display " unexpected result")
  76.           (newline)
  77.           (display "Expected: " expected)
  78.           (newline)
  79.           (display "Got:      " result))))
  80.  
  81.   (let ((t1 (make-map 0 99 2))          ; 0,2,4,...,98
  82.         (t2 (make-map 1 100 2))         ; 1,3,5,...,99
  83.         (t3 (make-map 0 100 3)))        ; 0,3,6,...,99
  84.  
  85.  
  86.     (verify 'alist (wt-tree->alist t3)  ;
  87.             '(("0" . 0) ("12" . 12) ("15" . 15) ("18" . 18) ("21" . 21)
  88.               ("24" . 24) ("27" . 27) ("3" . 3) ("30" . 30) ("33" . 33)
  89.               ("36" . 36) ("39" . 39) ("42" . 42) ("45" . 45) ("48" . 48)
  90.               ("51" . 51) ("54" . 54) ("57" . 57) ("6" . 6) ("60" . 60)
  91.               ("63" . 63) ("66" . 66) ("69" . 69) ("72" . 72) ("75" . 75)
  92.               ("78" . 78) ("81" . 81) ("84" . 84) ("87" . 87) ("9" . 9)
  93.               ("90" . 90) ("93" . 93) ("96" . 96) ("99" . 99)))
  94.  
  95.  
  96.     (verify 'union-sizes
  97.             (try-all (lambda (t1 t2) (wt-tree/size (wt-tree/union t1 t2)))
  98.                      (list t1 t2 t3))
  99.             '((50 100 67) (100 50 67) (67 67 34)))
  100.  
  101.     (verify 'difference-sizes
  102.             (try-all (lambda (t1 t2)
  103.                        (wt-tree/size (wt-tree/difference t1 t2)))
  104.                      (list t1 t2 t3))
  105.             '((0 50 33) (50 0 33) (17 17 0)))
  106.  
  107.     (verify 'intersection-sizes
  108.             (try-all (lambda (t1 t2)
  109.                        (wt-tree/size (wt-tree/intersection t1 t2)))
  110.                      (list t1 t2 t3))
  111.             '((50 0 17) (0 50 17) (17 17 34)))
  112.  
  113.     (verify 'equalities
  114.             (try-all (lambda (t1 t2)
  115.                        (wt-tree/set-equal? (wt-tree/difference t1 t2)
  116.                                            (wt-tree/difference t2 t1)))
  117.                      (list t1 t2 t3))
  118.             '((#t #f #f) (#f #t #f) (#f #f #t)))
  119.  
  120.     (verify 'indexing
  121.             (chunk (make-map 0 99 1))
  122.             '((((7 ("15") 5) ("20") (6 ("27") 4)) ("31")
  123.                ((6 ("38") 5) ("43") (6 ("5") 4)))
  124.               ("54")
  125.               (((7 ("61") 5) ("67") (6 ("73") 4)) ("78")
  126.                ((6 ("84") 5) ("9") (5 ("95") 4)))))
  127.     (newline)))
  128.  
  129. (wt-test)
  130.  
  131. ;;; Local Variables:
  132. ;;; eval: (put 'with-n-node 'scheme-indent-function 1)
  133. ;;; eval: (put 'with-n-node 'scheme-indent-hook 1)
  134. ;;; End:
  135.