From e40ef0ce62fa115024a7508e278662a6174acfb7 Mon Sep 17 00:00:00 2001 From: Rowan Torbitzky-Lane Date: Wed, 5 Feb 2025 01:03:24 -0600 Subject: [PATCH] more tests and many more togo --- HushGP.cabal | 1 + src/PushTests.hs | 2 ++ src/PushTests/GenericTests.hs | 43 +++++++++++++++++++++++++++++++++++ src/PushTests/IntTests.hs | 17 +++++++++++++- src/PushTests/UtilTests.hs | 36 +++++++++++++++++++++++++++++ 5 files changed, 98 insertions(+), 1 deletion(-) create mode 100644 src/PushTests/UtilTests.hs diff --git a/HushGP.cabal b/HushGP.cabal index 3a391a2..f24e378 100644 --- a/HushGP.cabal +++ b/HushGP.cabal @@ -55,6 +55,7 @@ library , PushTests , PushTests.IntTests , PushTests.GenericTests + , PushTests.UtilTests -- Modules included in this library but not exported. -- other-modules: diff --git a/src/PushTests.hs b/src/PushTests.hs index eca2dc5..571b27f 100644 --- a/src/PushTests.hs +++ b/src/PushTests.hs @@ -1,8 +1,10 @@ module PushTests ( module PushTests.GenericTests, module PushTests.IntTests, + module PushTests.UtilTests, ) where import PushTests.GenericTests import PushTests.IntTests +import PushTests.UtilTests diff --git a/src/PushTests/GenericTests.hs b/src/PushTests/GenericTests.hs index 2ec8820..5a8dded 100644 --- a/src/PushTests/GenericTests.hs +++ b/src/PushTests/GenericTests.hs @@ -4,6 +4,7 @@ import State import Control.Lens import Debug.Trace import Test.QuickCheck +import Instructions.GenericInstructions -- The naming scheme: -- the letters at the beginning represent what kind of transformation (the word I'm using for a basic function) to the states is happening @@ -84,3 +85,45 @@ rotTest accessor instruction state = case (uncons (view accessor state), uncons (view accessor $ instruction state)) of (Just (origx1, origx2 : origx3 : _), Just (modx1, modx2 : modx3 : _)) -> (origx1, origx2, origx3) === (modx2, modx3, modx1) _ -> state === instruction state + +flushTest :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> State -> Property +flushTest accessor instruction state = + property $ null $ view accessor $ instruction state + +stackDepthTest :: (Show a) => Lens' State [a] -> (State -> State) -> State -> Property +stackDepthTest accessor instruction state = + case uncons (view int $ instruction state) of + Just (x1, _) -> x1 === length (view accessor state) + _ -> state === instruction state + +yankTest :: forall a. (Show a, Eq a) => Lens' State [a] -> (State -> State) -> State -> Property +yankTest accessor instruction state@(State {_int = i1 : is}) = + let + myIndex :: Int + myIndex = max 0 (min i1 (length (view accessor state{_int = is}) - 1)) + item :: a + item = view accessor state{_int = is} !! myIndex + in + case (uncons (view accessor $ instruction state), uncons is) of + (Just (x1, _), Just (_, _)) -> x1 === item + _ -> state === instruction state + -- .&&. -- unsure how to get this functional + -- length (view accessor state{_int = is}) === length (view accessor $ instruction state) +yankTest _ instruction state = state === instruction state + +-- Might just make this a unit test +-- Come back to this later +-- yankDupTest :: forall a. (Show a, Eq a) => Lens' State [a] -> (State -> State) -> State -> Property +-- yankDupTest accessor instruction state@(State {_int = i1 : is}) = +-- let +-- myIndex :: Int +-- myIndex = max 0 (min i1 (length (view accessor state{_int = is}) - 1)) +-- item :: a +-- item = view accessor state{_int = is} !! myIndex +-- in +-- case (uncons (view accessor $ instruction state), uncons is) of +-- (Just (x1, xs), Just (_, _)) -> x1 === item .&&. (x1 : xs) !! === item +-- _ -> state === instruction state +-- yankDupTest _ instruction state = state === instruction state + +-- shoveTest diff --git a/src/PushTests/IntTests.hs b/src/PushTests/IntTests.hs index f0249dd..07432f1 100644 --- a/src/PushTests/IntTests.hs +++ b/src/PushTests/IntTests.hs @@ -3,7 +3,7 @@ module PushTests.IntTests where import State import Instructions.IntInstructions import PushTests.GenericTests -import Control.Lens hiding (uncons) +-- import Control.Lens hiding (uncons) import Test.QuickCheck prop_IntAdd :: State -> Property @@ -67,3 +67,18 @@ prop_IntSwap = swapTest int instructionIntSwap prop_IntRot :: State -> Property prop_IntRot = rotTest int instructionIntRot + +prop_IntFlush :: State -> Property +prop_IntFlush = flushTest int instructionIntFlush + +prop_IntEq :: State -> Property +prop_IntEq = aab2Test int bool instructionIntEq (==) + +prop_IntStackDepth :: State -> Property +prop_IntStackDepth = stackDepthTest int instructionIntStackDepth + +prop_IntYank :: State -> Property +prop_IntYank = yankTest int instructionIntYank + +-- prop_IntYankDup :: State -> Property +-- prop_IntYankDup = yankDupTest int instructionIntYankDup diff --git a/src/PushTests/UtilTests.hs b/src/PushTests/UtilTests.hs new file mode 100644 index 0000000..07b49da --- /dev/null +++ b/src/PushTests/UtilTests.hs @@ -0,0 +1,36 @@ +module PushTests.UtilTests where + +import Instructions.GenericInstructions +import Test.QuickCheck + +prop_DeleteAtTest :: Int -> [Int] -> Property +prop_DeleteAtTest idx lst = + idx >= 0 && idx < length lst ==> + if null lst + then length lst === length (deleteAt idx lst) + else length lst === length (deleteAt idx lst) + 1 + +prop_CombineTupleTest :: Int -> ([Int], [Int]) -> Property +prop_CombineTupleTest val tup = + length (fst tup) + length (snd tup) === length (combineTuple val tup) - 1 + +prop_CombineTupleListTest :: [Int] -> ([Int], [Int]) -> Property +prop_CombineTupleListTest lst tup = + length (fst tup) + length (snd tup) === length (combineTupleList lst tup) - length lst + +-- Could use forAll to only generate valid tests +prop_InsertAt :: Int -> Int -> [Int] -> Property +prop_InsertAt idx val lst = + idx >= 0 && idx < length lst ==> + length lst === length (insertAt idx val lst) - 1 .&&. + insertAt idx val lst !! idx === val + +prop_ReplaceAt :: Int -> Int -> [Int] -> Property +prop_ReplaceAt idx val lst = + idx >= 0 && idx < length lst ==> + length lst === length (replaceAt idx val lst) .&&. + replaceAt idx val lst !! idx === val + +-- prop_SubList :: Int -> Int -> [Int] -> Property +-- prop_SubList idx0 idx1 lst = + -- idx