external/lift.darcs/_darcs/pristine/test/test-prototypes.lisp

   1 (in-package #:lift)
   2
   3 (deftestsuite test-case-generation () ())
   4 (deftestsuite test-case-generation-simple (test-case-generation) ())
   5
   6 ;;; ---------------------------------------------------------------------------
   7 ;;; test-process-cases-form
   8 ;;; ---------------------------------------------------------------------------
   9
  10 (deftestsuite test-process-cases-form () ())
  11 (deftestsuite test-vars-from-assignment (test-process-cases-form) ())
  12
  13 (addtest (test-vars-from-assignment)
  14   test-1
  15   (ensure-same (vars-from-assignment '((:B ((A . 1) (B . 3)) ((A . 2) (B . 4)))))
  16                '(a b)))
  17
  18 (addtest (test-vars-from-assignment)
  19   test-2
  20   (ensure-same (vars-from-assignment (list '(c '(a b)) '(d (list 'x 'y))))
  21                '(c d)))
  22
  23 (addtest (test-vars-from-assignment)
  24   test-3
  25   (ensure-same (vars-from-assignment '((:B ((A . 1) (B . 3)) ((A . 2) (B . 4)))
  26                                        (:B ((C . A) (D . X)) ((C . B) (D . Y)))))
  27                '((a b) (c d))))
  28
  29 ;;; ---------------------------------------------------------------------------
  30
  31 (deftestsuite test-values-from-assignment (test-process-cases-form) ())
  32
  33 (addtest (test-values-from-assignment)
  34   test-1
  35   (ensure-same (values-from-assignment '((:B ((A . 1) (B . 3)) ((A . 2) (B . 4)))))
  36                '((1 2) (3 4))))
  37
  38 (addtest (test-values-from-assignment)
  39   test-2
  40   (ensure-same (values-from-assignment (list '(c '(a b)) '(d (list 'x 'y))))
  41                '((a b) (x y))))
  42
  43 (addtest (test-values-from-assignment)
  44   test-3
  45   (ensure-same (values-from-assignment '((:B ((A . 1) (B . 3)) ((A . 2) (B . 4)))
  46                                          (:B ((C . A) (D . X)) ((C . B) (D . Y)))))
  47                '((1 2) (3 4) (a b) (x y))))
  48
  49 ;;; ---------------------------------------------------------------------------
  50
  51 (deftestsuite test-standardize-cases-form (test-process-cases-form)
  52   ())
  53
  54 (addtest (test-standardize-cases-form)
  55   test-1
  56   (ensure-same
  57    (standardize-cases-form '((q '(a b))))
  58    '(:cross (q '(a b)))))
  59
  60 ;;; ---------------------------------------------------------------------------
  61
  62 (addtest (test-standardize-cases-form)
  63   test-2
  64   (ensure-same
  65    (standardize-cases-form '((:map (a '(1 2 3 4 5)) (b '(9 8 7 6 5)))))
  66    '(:map (a '(1 2 3 4 5)) (b '(9 8 7 6 5)))))
  67
  68 ;;; ---------------------------------------------------------------------------
  69
  70 (addtest (test-standardize-cases-form)
  71   test-3
  72   (ensure-same
  73    (standardize-cases-form '((q '(a b)) (b '(1 2))))
  74    '(:cross (q '(a b)) (b '(1 2)))))
  75
  76 ;;; ---------------------------------------------------------------------------
  77
  78 (addtest (test-process-cases-form)
  79   test-map-0
  80   (ensure-same
  81    (process-cases-form :map '(c '(a b)))
  82    '(:b ((c . a)) ((c . b)))
  83    :test 'equal))
  84
  85 ;;; ---------------------------------------------------------------------------
  86
  87 (addtest (test-process-cases-form)
  88   test-map1
  89   (ensure-same
  90    (process-cases-form :map '(c '(a b)) '(d (list 'x 'y)))
  91    '(:b ((c . a) (d . x)) ((c . b) (d . y)))
  92    :test 'equal))
  93
  94 (addtest (test-process-cases-form)
  95   test-map2-a
  96   (ensure-same
  97    (process-cases-form :map
  98                        (process-cases-form :map '(a '(1 2)) '(b '(3 4)))
  99                        (process-cases-form :map '(c '(a b)) '(d '(x y))))
 100    '(:b ((a . 1) (b . 3) (c . a) (d . x))
 101      ((a . 2) (b . 4) (c . b) (d . y)))
 102    :test 'equal))
 103
 104 (addtest (test-process-cases-form)
 105   test-map2-a
 106   (ensure-same
 107    (process-cases-form :map
 108                        '(:b ((a . 1) (b . 3)) ((a . 2) (b . 4)))
 109                        '(:b ((c . a) (d . x)) ((c . b) (d . y))))
 110    '(:b ((a . 1) (b . 3) (c . a) (d . x))
 111      ((a . 2) (b . 4) (c . b) (d . y)))
 112    :test 'equal))
 113
 114 (addtest (test-process-cases-form)
 115   test-cross-0
 116   (ensure-same
 117    (process-cases-form :cross '(c '(a b)))
 118    '(:b ((c . a)) ((c . b)))
 119    :test 'equal))
 120
 121 (addtest (test-process-cases-form)
 122   test-cross-1
 123   (ensure-same
 124    (process-cases-form :cross '(c '(a b)) '(d (list 'x 'y)))
 125    '(:b
 126      ((c . a) (d . x))
 127      ((c . a) (d . y))
 128      ((c . b) (d . x))
 129      ((c . b) (d . y)))
 130    :test 'equal))
 131
 132 (addtest (test-process-cases-form)
 133   test-cross-b
 134   (ensure-same
 135    (process-cases-form :cross
 136                        '(:b ((a . 1) (b . 3)) ((a . 2) (b . 4)))
 137                        '(:b ((c . a) (d . x)) ((c . b) (d . y))))
 138    '(:B
 139      ((A . 1) (B . 3) (C . A) (D . X)) ((A . 1) (B . 3) (C . A) (D . Y))
 140      ((A . 1) (B . 3) (C . B) (D . X)) ((A . 1) (B . 3) (C . B) (D . Y))
 141      ((A . 1) (B . 4) (C . A) (D . X)) ((A . 1) (B . 4) (C . A) (D . Y))
 142      ((A . 1) (B . 4) (C . B) (D . X)) ((A . 1) (B . 4) (C . B) (D . Y))
 143      ((A . 2) (B . 3) (C . A) (D . X)) ((A . 2) (B . 3) (C . A) (D . Y))
 144      ((A . 2) (B . 3) (C . B) (D . X)) ((A . 2) (B . 3) (C . B) (D . Y))
 145      ((A . 2) (B . 4) (C . A) (D . X)) ((A . 2) (B . 4) (C . A) (D . Y))
 146      ((A . 2) (B . 4) (C . B) (D . X)) ((A . 2) (B . 4) (C . B) (D . Y)))
 147    :test 'equal))
 148
 149 (addtest (test-process-cases-form)
 150   test-cross-a
 151   (ensure-same
 152    (process-cases-form :cross
 153                        (process-cases-form :map '(a '(1 2)) '(b '(3 4)))
 154                        (process-cases-form :map '(c '(a b)) '(d '(x y))))
 155    '(:B
 156      ((A . 1) (B . 3) (C . A) (D . X)) ((A . 1) (B . 3) (C . A) (D . Y))
 157      ((A . 1) (B . 3) (C . B) (D . X)) ((A . 1) (B . 3) (C . B) (D . Y))
 158      ((A . 1) (B . 4) (C . A) (D . X)) ((A . 1) (B . 4) (C . A) (D . Y))
 159      ((A . 1) (B . 4) (C . B) (D . X)) ((A . 1) (B . 4) (C . B) (D . Y))
 160      ((A . 2) (B . 3) (C . A) (D . X)) ((A . 2) (B . 3) (C . A) (D . Y))
 161      ((A . 2) (B . 3) (C . B) (D . X)) ((A . 2) (B . 3) (C . B) (D . Y))
 162      ((A . 2) (B . 4) (C . A) (D . X)) ((A . 2) (B . 4) (C . A) (D . Y))
 163      ((A . 2) (B . 4) (C . B) (D . X)) ((A . 2) (B . 4) (C . B) (D . Y)))
 164    :test 'equal))
 165
 166
 167 ;;; ---------------------------------------------------------------------------
 168 ;;; some simple "real" tests
 169 ;;; ---------------------------------------------------------------------------
 170
 171 (deftestsuite test-addition ()
 172   (a b)
 173   (:cases (:map (a '(1 2 3 4 5))
 174                 (b '(9 8 7 6 5))))
 175   (:test ((ensure-same (+ a b) 10 :test '=))))
 176
 177 (deftestsuite test-addition ()
 178   (a b)
 179   (:cases (a '(1 2 3 4 5))
 180           (b '(9 8 7 6 5)))
 181   (:test ((ensure-same (+ a b) (+ b a) :test '=))))
 182
 183 ;;; ---------------------------------------------------------------------------
 184 ;;;
 185 ;;; ---------------------------------------------------------------------------
 186
 187 (deftestsuite test-case-generation-simple-helper ()
 188   (a)
 189   (:cases (a '(1 2 3)))
 190   (:test (test-1 (push a *test-scratchpad*))))
 191
 192 (addtest (test-case-generation-simple)
 193   single-var-three-cases
 194   (let ((tr (run-test (test-case-generation-simple-helper) test-1)))
 195     (ensure-same (length (tests-run tr)) 3)
 196     (ensure-same *test-scratchpad* '(3 2 1))))
 197
 198 ;;; ---------------------------------------------------------------------------
 199
 200 (deftestsuite test-case-generation-simple-helper-2 (test-case-generation-simple-helper)
 201   (b)
 202   (:cases (b '(4 5)))
 203   (:test (test-1 (push a *test-scratchpad*)
 204                  (push b *test-scratchpad*))))
 205
 206 (addtest (test-case-generation-simple)
 207   single-var-with-superclass
 208   (let ((tr (run-test (test-case-generation-simple-helper-2) test-1)))
 209     (ensure-same (length (tests-run tr)) 6)
 210     (ensure-same *test-scratchpad* '(1 4 1 5 2 4 2 5 3 4 3 5))))
 211
 212 ;;; ---------------------------------------------------------------------------
 213
 214 (deftestsuite test-case-generation-simple-helper-3 ()
 215   (a b)
 216   (:cases (a '(1 2 3))
 217           (b '(4 5)))
 218   (:test (test-1 (push (list a b) *test-scratchpad*))))
 219
 220 (addtest (test-case-generation-simple)
 221   two-vars-cross-product
 222   (let ((tr (run-test (test-case-generation-simple-helper-3) test-1)))
 223     (ensure-same (length (tests-run tr)) 6)
 224     (ensure-same *test-scratchpad* '((1 4) (1 5) (2 4) (2 5) (3 4) (3 5)))))
 225
 226 ;;; ---------------------------------------------------------------------------
 227
 228 (deftestsuite test-case-generation-simple-helper-4 ()
 229   (a b)
 230   (:cases (:map (a (1 2 3))
 231                 (b (4 5 6))))
 232   (:test (test-1 (push (list a b) *test-scratchpad*))))
 233
 234 (addtest (test-case-generation-simple)
 235   two-vars-mapping
 236   (let ((tr (run-test (test-case-generation-simple-helper) test-1)))
 237     (ensure-same (length (tests-run tr)) 3)
 238     (ensure-same *test-scratchpad* '(3 2 1))))
 239
 240 ;;; ---------------------------------------------------------------------------
 241
 242 (defun random-integers (count)
 243   (loop repeat count collect
 244         (variates:integer-random variates:*random-generator* -9 10)))
 245
 246 (deftestsuite test-case-generation-simple-helper-5 ()
 247   (a b)
 248   (:cases (a (random-integers 3))
 249           (b (random-integers 2)))
 250   (:test (test-1 (push (list a b) *test-scratchpad*))))
 251
 252 (addtest (test-case-generation-simple)
 253   two-vars-cross-product-run-time
 254   (let ((tr (run-test (test-case-generation-simple-helper-5) test-1)))
 255     (ensure-same (length (tests-run tr)) 6)))
 256
 257 ;;; ---------------------------------------------------------------------------
 258 ;;;
 259 ;;; ---------------------------------------------------------------------------
 260
 261 (deftestsuite test-case-generation-helper-1 ()
 262   (a)
 263   (:cases (a :exemplars-of fixnum))
 264   (:test (test-1 (push (list a) *test-scratchpad*))))
 265
 266 ;;; ---------------------------------------------------------------------------
 267
 268 (deftestsuite test-case-generation-helper-2 ()
 269   (a)
 270   (:cases (a :samples-from standard-normal))
 271   (:test (test-1 (push (list a) *test-scratchpad*))))
 272
 273 ;;; ---------------------------------------------------------------------------
 274
 275 (deftestsuite test-case-generation-helper-3 ()
 276   (a)
 277   (:cases (a :samples-from fixnum))
 278   (:test (test-1 (push (list a) *test-scratchpad*))))