Last active
December 28, 2023 21:49
-
-
Save kisp/61804c4e4b0c9a7c3177c55eddc787bc to your computer and use it in GitHub Desktop.
Implementing Haskell's Test.SmallCheck.Series in Common Lisp using Screamer
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;; -*- 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))))))))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment