Implementing Haskell's Test.SmallCheck.Series in Common Lisp using Screamer

small-check-series.lisp

;; -*- mode: lisp; -*- ;; (ql:quickload "screamer")

(in-package :screamer-user)

;; SmallCheck and Lazy SmallCheck - automatic exhaustive testing for small values
;; https://www.cs.york.ac.uk/fp/smallcheck/smallcheck.pdf

(defun an-integer-upto-depth (depth)
  (either
    0
    (let ((x (an-integer-between 1 depth)))
      (either
        x
        (- x)))))

;; ghci> import Test.SmallCheck.Series
;; ghci> list 0 series :: [Int]
;; [0]
;; ghci> list 1 series :: [Int]
;; [0,1,-1]
;; ghci> list 2 series :: [Int]
;; [0,1,-1,2,-2]
;; ghci> list 3 series :: [Int]
;; [0,1,-1,2,-2,3,-3]
(assert (equal '(0) (all-values (an-integer-upto-depth 0))))
(assert (equal '(0 1 -1) (all-values (an-integer-upto-depth 1))))
(assert (equal '(0 1 -1 2 -2) (all-values (an-integer-upto-depth 2))))
(assert (equal '(0 1 -1 2 -2 3 -3) (all-values (an-integer-upto-depth 3))))

(defun a-boolean-upto-depth (depth)
  (if (zerop depth)
      (fail)
      (either t nil)))

;; ghci> list 0 series :: [Bool]
;; []
;; ghci> list 1 series :: [Bool]
;; [True,False]
;; ghci> list 2 series :: [Bool]
;; [True,False]
;; ghci> list 3 series :: [Bool]
;; [True,False]
(assert (equal '() (all-values (a-boolean-upto-depth 0))))
(assert (equal '(t nil) (all-values (a-boolean-upto-depth 1))))
(assert (equal '(t nil) (all-values (a-boolean-upto-depth 2))))
(assert (equal '(t nil) (all-values (a-boolean-upto-depth 3))))

(defun a-cons-upto-depth (depth &optional car-fn cdr-fn)
  (if (zerop depth)
      (fail)
      (let ((a (funcall-nondeterministic car-fn (1- depth)))
            (b (funcall-nondeterministic cdr-fn (1- depth))))
        (cons a b))))

(defun a-list-upto-depth (depth &optional elt-fn)
  (case depth
    (0 (fail))
    (1 nil)
    (t (either
         nil
         (cons (funcall-nondeterministic elt-fn (1- depth))
               (a-list-upto-depth (1- depth) elt-fn))))))

;; ghci> list 0 series :: [[Bool]]
;; []
;; ghci> list 1 series :: [[Bool]]
;; [[]]
;; ghci> list 2 series :: [[Bool]]
;; [[],[True],[False]]
;; ghci> list 3 series :: [[Bool]]
;; [[],[True],[False],[True,True],[False,True],[True,False],[False,False]]
(assert (equal '() (all-values (a-list-upto-depth 0 #'a-boolean-upto-depth))))
(assert (equal '(nil) (all-values (a-list-upto-depth 1 #'a-boolean-upto-depth))))
(assert (equal '(nil (t) (nil)) (all-values (a-list-upto-depth 2 #'a-boolean-upto-depth))))
(assert (equal '(NIL (T) (T T) (T NIL) (NIL) (NIL T) (NIL NIL))
               (all-values (a-list-upto-depth 3 #'a-boolean-upto-depth))))

;; ghci> map length (map (\d -> (list d series :: [[Bool]])) [0..12])
;; [0,1,3,7,15,31,63,127,255,511,1023,2047,4095]
(assert (equal '(0 1 3 7 15 31 63 127 255 511 1023 2047 4095)
               (all-values
                 (let ((depth (an-integer-between 0 12)))
                   (length (all-values (a-list-upto-depth depth #'a-boolean-upto-depth)))))))

;; ghci> map length (map (\d -> (list d series :: [[Int]])) [0..6])
;; [0,1,4,21,148,1333,14664]
(assert (equal '(0 1 4 21 148 1333 14664)
               (all-values
                 (let ((depth (an-integer-between 0 6)))
                   (length (all-values (a-list-upto-depth depth #'an-integer-upto-depth)))))))

;; ghci> map length (map (\d -> (list d series :: [[[Int]]])) [0..5])
;; [0,1,2,9,190,28121]
(assert (equal '(0 1 2 9 190 28121)
               (all-values
                 (let ((depth (an-integer-between 0 5)))
                   (length (all-values (a-list-upto-depth
                                        depth
                                        (lambda (depth)
                                          (a-list-upto-depth depth #'an-integer-upto-depth)))))))))