diff --git a/HushGP.cabal b/HushGP.cabal index 6752025..93e70dd 100644 --- a/HushGP.cabal +++ b/HushGP.cabal @@ -120,4 +120,6 @@ test-suite HushGP-test build-depends: base, HushGP, - QuickCheck + QuickCheck, + lens + diff --git a/src/Instructions.hs b/src/Instructions.hs index 9856818..d93d695 100644 --- a/src/Instructions.hs +++ b/src/Instructions.hs @@ -1,30 +1,30 @@ -module Instructions ( - module Instructions.GenericInstructions, - module Instructions.IntInstructions, - module Instructions.FloatInstructions, - module Instructions.StringInstructions, - module Instructions.CharInstructions, - module Instructions.CodeInstructions, - module Instructions.ExecInstructions, - module Instructions.LogicalInstructions, - module Instructions.VectorIntInstructions, - module Instructions.VectorFloatInstructions, - module Instructions.VectorStringInstructions, - module Instructions.VectorLogicalInstructions, - module Instructions.VectorCharInstructions -) +module Instructions + ( module Instructions.GenericInstructions, + module Instructions.IntInstructions, + module Instructions.FloatInstructions, + module Instructions.StringInstructions, + module Instructions.CharInstructions, + module Instructions.CodeInstructions, + module Instructions.ExecInstructions, + module Instructions.LogicalInstructions, + module Instructions.VectorIntInstructions, + module Instructions.VectorFloatInstructions, + module Instructions.VectorStringInstructions, + module Instructions.VectorLogicalInstructions, + module Instructions.VectorCharInstructions, + ) where -import Instructions.GenericInstructions -import Instructions.IntInstructions -import Instructions.FloatInstructions -import Instructions.StringInstructions import Instructions.CharInstructions import Instructions.CodeInstructions import Instructions.ExecInstructions +import Instructions.FloatInstructions +import Instructions.GenericInstructions +import Instructions.IntInstructions import Instructions.LogicalInstructions -import Instructions.VectorIntInstructions -import Instructions.VectorFloatInstructions -import Instructions.VectorStringInstructions -import Instructions.VectorLogicalInstructions +import Instructions.StringInstructions import Instructions.VectorCharInstructions +import Instructions.VectorFloatInstructions +import Instructions.VectorIntInstructions +import Instructions.VectorLogicalInstructions +import Instructions.VectorStringInstructions diff --git a/src/LearnQuickCheck.hs b/src/LearnQuickCheck.hs index f015789..44ce1f8 100644 --- a/src/LearnQuickCheck.hs +++ b/src/LearnQuickCheck.hs @@ -2,11 +2,11 @@ module LearnQuickCheck where -- https://jesper.sikanda.be/posts/quickcheck-intro.html -import Test.QuickCheck -import Data.List (sort) import Control.Monad +import Data.List (sort) +import Test.QuickCheck -qsort :: Ord a => [a] -> [a] +qsort :: (Ord a) => [a] -> [a] qsort = sort distance :: Int -> Int -> Int @@ -27,8 +27,8 @@ bad_distance x y = y - x prop_dist_symmetric_fail :: Int -> Int -> Bool prop_dist_symmetric_fail x y = bad_distance x y == bad_distance y x -sorted :: Ord a => [a] -> Bool -sorted (x:y:ys) = x <= y && sorted (y:ys) +sorted :: (Ord a) => [a] -> Bool +sorted (x : y : ys) = x <= y && sorted (y : ys) sorted _ = True prop_sorted :: [Int] -> Bool @@ -37,13 +37,15 @@ prop_sorted xs = sorted xs -- roundtrip property insert :: Int -> [Int] -> [Int] insert x [] = [x] -insert x (y:ys) | x <= y = x:y:ys - | otherwise = y:insert x ys +insert x (y : ys) + | x <= y = x : y : ys + | otherwise = y : insert x ys delete :: Int -> [Int] -> [Int] delete x [] = [] -delete x (y:ys) | x == y = ys - | otherwise = y:delete x ys +delete x (y : ys) + | x == y = ys + | otherwise = y : delete x ys prop_insert_delete :: [Int] -> Int -> Bool prop_insert_delete xs x = delete x (insert x xs) == xs @@ -53,24 +55,24 @@ prop_qsort_sort :: [Int] -> Bool prop_qsort_sort xs = qsort xs == sort xs -- can test this in ghci with verboseCheck -prop_qsort_sort' :: Ord a => [a] -> Bool +prop_qsort_sort' :: (Ord a) => [a] -> Bool prop_qsort_sort' xs = qsort xs == sort xs -- Algebraic Laws -vAdd :: (Int, Int) -> (Int, Int) -> (Int, Int) +vAdd :: (Int, Int) -> (Int, Int) -> (Int, Int) vAdd tup0 tup1 = (fst tup0 + fst tup1, snd tup0 + snd tup1) -prop_vAdd_commutative :: (Int,Int) -> (Int,Int) -> Bool +prop_vAdd_commutative :: (Int, Int) -> (Int, Int) -> Bool prop_vAdd_commutative v w = vAdd v w == vAdd w v -prop_vAdd_associative :: (Int,Int) -> (Int,Int) -> (Int,Int) -> Bool +prop_vAdd_associative :: (Int, Int) -> (Int, Int) -> (Int, Int) -> Bool prop_vAdd_associative u v w = vAdd (vAdd u v) w == vAdd u (vAdd v w) -prop_vAdd_neutral_left :: (Int,Int) -> Bool -prop_vAdd_neutral_left u = vAdd (0,0) u == u +prop_vAdd_neutral_left :: (Int, Int) -> Bool +prop_vAdd_neutral_left u = vAdd (0, 0) u == u -prop_vAdd_neutral_right :: (Int,Int) -> Bool -prop_vAdd_neutral_right u = vAdd u (0,0) == u +prop_vAdd_neutral_right :: (Int, Int) -> Bool +prop_vAdd_neutral_right u = vAdd u (0, 0) == u prop_qsort_idempotent :: [Int] -> Bool prop_qsort_idempotent xs = qsort (qsort xs) == qsort xs @@ -80,7 +82,7 @@ prop_qsort_idempotent xs = qsort (qsort xs) == qsort xs -- prop_replicate n x i = replicate n x !! i == x prop_replicate :: Int -> Int -> Int -> Property -prop_replicate n x i = +prop_replicate n x i = (i >= 0 && i < n) ==> replicate n (x :: Int) !! i == x prop_insert_sorted :: Int -> [Int] -> Property @@ -92,23 +94,22 @@ prop_insert_sorted' x = forAll orderedList (\xs -> sorted (insert x xs)) -- Testing properties of functions prop_filter :: Fun Int Bool -> [Int] -> Property -prop_filter p xs = - -- Filter elements not satisfying p. - let ys = [ x | x <- xs , applyFun p x ] - -- If any elements are left... - in ys /= [] ==> - -- ...generate a random index i... - forAll (choose (0,length ys-1)) - -- ...and test if p (ys!!i) holds. - (\i -> applyFun p (ys!!i)) - - +prop_filter p xs = + -- Filter elements not satisfying p. + let ys = [x | x <- xs, applyFun p x] + in -- If any elements are left... + ys /= [] ==> + -- ...generate a random index i... + forAll + (choose (0, length ys - 1)) + -- ...and test if p (ys!!i) holds. + (\i -> applyFun p (ys !! i)) prop_bananas :: Fun String Int -> Bool -prop_bananas f = - applyFun f "banana" == applyFun f "monkey" || - applyFun f "banana" == applyFun f "elephant" || - applyFun f "monkey" == applyFun f "elephant" +prop_bananas f = + applyFun f "banana" == applyFun f "monkey" + || applyFun f "banana" == applyFun f "elephant" + || applyFun f "monkey" == applyFun f "elephant" -- main :: IO () -- main = do @@ -167,22 +168,25 @@ instance Arbitrary Point where x <- arbitrary -- y <- arbitrary -- return $ Pt x y - -- could do + -- 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 + 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 + +-- list <- arbitrary +-- return $ Set list -- sample $ (arbitrary :: Gen (Set Int)) diff --git a/src/Push.hs b/src/Push.hs index 035453f..d7755c8 100644 --- a/src/Push.hs +++ b/src/Push.hs @@ -64,7 +64,7 @@ interpretExec state@(State {_exec = e : es}) = (StateFunc func) -> interpretExec $ func state {_exec = es} (Block block) -> interpretExec (state {_exec = block ++ es}) (PlaceInput val) -> interpretExec (state {_exec = (view input state Map.! val) : es}) - Close -> undefined -- This should be removed later. Will be converted to Blocks in the Plushy -> Exec stack process + Close -> undefined -- This should be removed later. Will be converted to Blocks in the Plushy -> Exec stack process interpretExec state = state -- Need to make interpretExec strict, right? diff --git a/src/State.hs b/src/State.hs index 242008e..6cb3b08 100644 --- a/src/State.hs +++ b/src/State.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE TemplateHaskell, DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} module State where import Control.Lens hiding (elements) import Data.Map qualified as Map -import Test.QuickCheck import GHC.Generics +import Test.QuickCheck -- The exec stack must store heterogenous types, -- and we must be able to detect that type at runtime. @@ -26,7 +27,7 @@ data Gene | PlaceInput String | Close | Block [Gene] - deriving Generic + deriving (Generic) instance Eq Gene where GeneInt x == GeneInt y = x == y @@ -64,22 +65,23 @@ instance Show Gene where 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 - ] + 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], @@ -120,7 +122,8 @@ instance Arbitrary State where arbParameter <- arbitrary -- arbInput <- arbitrary State arbExec arbCode arbInt arbFloat arbBool arbString arbChar arbVectorInt arbVectorFloat arbVectorBool arbVectorString arbVectorChar arbParameter <$> arbitrary - -- Thanks hlint lol + +-- Thanks hlint lol instance CoArbitrary State