quickcheck class implementations done

This commit is contained in:
Rowan Torbitzky-Lane 2025-01-31 23:50:07 -06:00
parent 125f137643
commit e5285e5c8f
4 changed files with 101 additions and 7 deletions

View File

@ -119,4 +119,5 @@ test-suite HushGP-test
-- Test dependencies.
build-depends:
base,
HushGP
HushGP,
QuickCheck

View File

@ -153,3 +153,38 @@ genCards = do
genListOf15Ints :: Gen [Int]
genListOf15Ints = resize 15 $ sized $ \n -> replicateM n arbitrary
-- Next section covers this. QuickCheck with custom data declarations
-- http://geekyplatypus.com/y-u-have-no-code-samples-quickcheck/
data Point = Pt Int Int
instance Show Point where
show (Pt x y) = "{" ++ show x ++ "," ++ show y ++ "}"
instance Arbitrary Point where
arbitrary = do
x <- arbitrary
-- y <- arbitrary
-- return $ Pt x y
-- could do
Pt x <$> arbitrary
data Set a = Set [a]
instance (Show a) => Show (Set a) where
show s = showSet s where
showSet (Set []) = "{}"
showSet (Set (x:xs)) = "{" <> show x <> showSubSet xs <> "}" where
showSubSet [] = ""
showSubSet (ix:ixs) = "," <> show ix <> showSubSet ixs
instance (Arbitrary a) => Arbitrary (Set a) where
arbitrary = do Set <$> arbitrary
-- list <- arbitrary
-- return $ Set list
-- sample $ (arbitrary :: Gen (Set Int))
-- This link also seems interesting
-- https://devtut.github.io/haskell/quickcheck.html

View File

@ -1,9 +1,11 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TemplateHaskell, DeriveGeneric #-}
module State where
import Control.Lens
import Control.Lens hiding (elements)
import Data.Map qualified as Map
import Test.QuickCheck
import GHC.Generics
-- The exec stack must store heterogenous types,
-- and we must be able to detect that type at runtime.
@ -24,6 +26,7 @@ data Gene
| PlaceInput String
| Close
| Block [Gene]
deriving Generic
instance Eq Gene where
GeneInt x == GeneInt y = x == y
@ -48,8 +51,8 @@ instance Show Gene where
show (GeneBool x) = "Bool: " <> show x
show (GeneString x) = "String: " <> x
show (GeneChar x) = "Char: " <> show x
show (StateFunc _) = "Func: unnamed"
show (PlaceInput x) = "In: " <> x
show (StateFunc x) = "Func: " <> show x
show (PlaceInput x) = "In: " <> show x
show (GeneVectorInt xs) = "Int Vec: " <> show xs
show (GeneVectorFloat xs) = "Float Vec: " <> show xs
show (GeneVectorBool xs) = "Bool Vec: " <> show xs
@ -58,6 +61,26 @@ instance Show Gene where
show Close = "Close"
show (Block xs) = "Block: " <> show xs
instance CoArbitrary Gene
instance Arbitrary Gene where
arbitrary = oneof [
GeneInt <$> arbitrary,
GeneFloat <$> arbitrary,
GeneBool <$> arbitrary,
GeneString <$> arbitrary,
GeneChar <$> arbitrary,
StateFunc <$> arbitrary,
PlaceInput <$> arbitrary,
GeneVectorInt <$> arbitrary,
GeneVectorFloat <$> arbitrary,
GeneVectorBool <$> arbitrary,
GeneVectorString <$> arbitrary,
GeneVectorChar <$> arbitrary,
Block <$> arbitrary,
return Close
]
data State = State
{ _exec :: [Gene],
_code :: [Gene],
@ -74,9 +97,32 @@ data State = State
_parameter :: [Gene],
_input :: Map.Map String Gene
}
deriving (Show, Eq)
deriving (Show, Eq, Generic)
$(makeLenses ''State)
-- This needs to be updated later
instance Show (State -> State) where
show _ = "unnamed"
instance Arbitrary State where
arbitrary = do
arbExec <- arbitrary
arbCode <- arbitrary
arbInt <- arbitrary
arbFloat <- arbitrary
arbBool <- arbitrary
arbString <- arbitrary
arbChar <- arbitrary
arbVectorInt <- arbitrary
arbVectorFloat <- arbitrary
arbVectorBool <- arbitrary
arbVectorString <- arbitrary
arbVectorChar <- arbitrary
arbParameter <- arbitrary
-- arbInput <- arbitrary
State arbExec arbCode arbInt arbFloat arbBool arbString arbChar arbVectorInt arbVectorFloat arbVectorBool arbVectorString arbVectorChar arbParameter <$> arbitrary
-- Thanks hlint lol
instance CoArbitrary State
emptyState :: State
emptyState =
@ -115,3 +161,7 @@ exampleState =
_vectorChar = [['z', 'x'], ['r', 'a', 't', 'l']],
_input = Map.empty
}
-- This must stay at the end of the file.
-- Template haskell seems to be messing with GHC.Generics
$(makeLenses ''State)

View File

@ -0,0 +1,8 @@
import State
import Test.QuickCheck
main :: IO ()
main = do
putStrLn "hello"