Compare commits

...

2 Commits

Author SHA1 Message Date
b37359a4f3 add tasty packages 2025-03-07 15:24:14 -06:00
c76d33f291 prepare for QuickCheck 2025-03-07 15:23:10 -06:00
3 changed files with 53 additions and 6 deletions

View File

@ -81,7 +81,7 @@ library
-- Other library packages from which modules are imported. -- Other library packages from which modules are imported.
build-depends: build-depends:
base, containers, lens, split, QuickCheck, regex-tdfa, template-haskell, random, parallel, random-shuffle, dsp, hmatrix, tasty base, containers, lens, split, regex-tdfa, template-haskell, random, parallel, random-shuffle, dsp, hmatrix, tasty, tasty-hunit, tasty-quickcheck
-- Directories containing source files. -- Directories containing source files.
hs-source-dirs: src hs-source-dirs: src

View File

@ -1,10 +1,10 @@
module HushGP.PushTests.IntTests where module HushGP.PushTests.IntTests where
-- import HushGP.State import HushGP.State
-- import HushGP.Instructions.IntInstructions import HushGP.Instructions.IntInstructions
-- import HushGP.PushTests.GenericTests -- import HushGP.PushTests.GenericTests
-- -- import Control.Lens hiding (uncons) -- -- import Control.Lens hiding (uncons)
-- import Test.QuickCheck import Test.Tasty
-- prop_IntAdd :: State -> Property -- prop_IntAdd :: State -> Property
-- prop_IntAdd = aaa1Test int instructionIntAdd (+) -- prop_IntAdd = aaa1Test int instructionIntAdd (+)

View File

@ -1,10 +1,12 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell, DeriveGeneric #-}
module HushGP.State where module HushGP.State where
import Control.Lens hiding (elements) import Control.Lens hiding (elements)
import Data.Map qualified as Map import Data.Map qualified as Map
import System.Random import System.Random
import Test.QuickCheck
import GHC.Generics
-- | The exec stack must store heterogenous types, -- | The exec stack must store heterogenous types,
-- and we must be able to detect that type at runtime. -- and we must be able to detect that type at runtime.
@ -42,6 +44,7 @@ data Gene
CrossoverPadding CrossoverPadding
| -- | This is used in best match crossover (bmx in PushArgs). | -- | This is used in best match crossover (bmx in PushArgs).
Gap Gap
deriving Generic
instance Eq Gene where instance Eq Gene where
GeneInt x == GeneInt y = x == y GeneInt x == GeneInt y = x == y
@ -155,6 +158,29 @@ instance Show Gene where
show CrossoverPadding = "Crossover Padding" show CrossoverPadding = "Crossover Padding"
show Gap = "Gap" show Gap = "Gap"
instance CoArbitrary StdGen where
coarbitrary _ gen = gen
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
]
-- | The structure that holds all of the values. -- | The structure that holds all of the values.
data State = State data State = State
{ _exec :: [Gene], { _exec :: [Gene],
@ -172,7 +198,28 @@ data State = State
_parameter :: [Gene], _parameter :: [Gene],
_input :: Map.Map Int Gene _input :: Map.Map Int Gene
} }
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord, Generic)
instance CoArbitrary State
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
emptyState :: State emptyState :: State
emptyState = emptyState =