diff --git a/HushGP.cabal b/HushGP.cabal index 1d128fd..8e18df2 100644 --- a/HushGP.cabal +++ b/HushGP.cabal @@ -53,11 +53,14 @@ library , HushGP.Instructions.VectorBoolInstructions , HushGP.Instructions.VectorCharInstructions , HushGP.Instructions.Utility + , HushGP.Instructions.Opens , HushGP.PushTests , HushGP.PushTests.IntTests , HushGP.PushTests.GenericTests , HushGP.PushTests.UtilTests , HushGP.TH + , HushGP.Utility + , HushGP.Genome -- Modules included in this library but not exported. -- other-modules: @@ -67,7 +70,7 @@ library -- Other library packages from which modules are imported. build-depends: - base, containers, lens, split, QuickCheck, regex-tdfa, template-haskell + base, containers, lens, split, QuickCheck, regex-tdfa, template-haskell, random -- Directories containing source files. hs-source-dirs: src diff --git a/TODO.md b/TODO.md index 7d12fc9..52e81aa 100644 --- a/TODO.md +++ b/TODO.md @@ -24,10 +24,12 @@ - [ ] Need to make this reproducable too (Check pysh json files) - [ ] Implement silent and skip markers as well - [ ] Have close amt of 1,2, and 3 - - [ ] Need a random genome generator + - [X] Need a random genome generator - I'm only going to implement propeller's :specified version - Is the best according to the papers + - [ ] Need a NoOp that opens blocks - [ ] Add Memory - [ ] Add history stack(s), like a call stack - [ ] Implement interpreter options (could probably just place this into a map) -- [ ] Devise a good way to implement ERCs + - Should probably place this in a separate file +- [X] Devise a good way to implement ERCs diff --git a/src/HushGP/Genome.hs b/src/HushGP/Genome.hs new file mode 100644 index 0000000..e0442d6 --- /dev/null +++ b/src/HushGP/Genome.hs @@ -0,0 +1,80 @@ +module HushGP.Genome where + +import HushGP.State +import HushGP.Utility +import Data.Map qualified as Map +import Data.List +import Data.List.Split +import HushGP.Instructions.Opens + +-- |Makes a random plushy from variables in a passed argMap and +-- a passed list of instructions. +makeRandomPlushy :: Map.Map String String -> [Gene] -> IO [Gene] +makeRandomPlushy argMap = randomInstructions (read @Int (argMap Map.! "maxInitialPlushySize")) + +-- |A utility function to generate an amount based on an int rather than +-- from an argmap. +makeRandomPlushy' :: Int -> [Gene] -> IO [Gene] +makeRandomPlushy' = randomInstructions + +-- |Checks to see if a Gene is an (Open _) constructor. +isOpen :: Gene -> Bool +isOpen (Open _) = True +isOpen _ = False + +-- |Decrements the count of an (Open _) constructor. Acts as id +-- if the gene isn't an open. +decOpen :: Gene -> Gene +decOpen (Open n) = Open (n - 1) +decOpen gene = gene + +-- |Checks to see if the a list of genes with a single element is an opener. +isOpenerList :: [Gene] -> Bool +isOpenerList [instruction] = + case Map.lookup instruction instructionOpens of + Just _ -> True + _ -> False +isOpenerList _ = False + +-- |Gets the amount of blocks to open from a list of genes with a single element. +getOpenAmountList :: [Gene] -> Int +getOpenAmountList [instruction] = + case Map.lookup instruction instructionOpens of + Just amt -> amt + _ -> 0 +getOpenAmountList _ = 0 + +-- |Converts a plushy genome into a push genome. +plushyToPush :: [Gene] -> [Gene] +plushyToPush plushy = plushyToPush' (concatMap (\x -> if isOpenerList x then x <> [Open (getOpenAmountList x)] else x) (chunksOf 1 plushy)) [] + +-- |Internal function used to convert a plushy genome with opens in it into a push genome. +plushyToPush' :: [Gene] -> [Gene] -> [Gene] +plushyToPush' openPlushy push = + if null openPlushy + then + if any isOpen push + then plushyToPush' [Close] push + else push + else + if firstPlushy == Close + then + if any isOpen push + then plushyToPush' (drop 1 openPlushy) (if numOpen (push !! openIndex) == 1 then preOpen <> postOpen else preOpen <> postOpen <> [decOpen (Open (numOpen (push !! openIndex)))]) + else plushyToPush' (drop 1 openPlushy) push + else plushyToPush' (drop 1 openPlushy) (push <> [firstPlushy]) + where + firstPlushy :: Gene + firstPlushy = + case uncons openPlushy of + Just (g, _) -> g + _ -> error "This shouldn't happen" + postOpen :: [Gene] + postOpen = reverse (takeWhile (not . isOpen) (reverse push)) + openIndex :: Int + openIndex = length push - length postOpen - 1 + numOpen :: Gene -> Int + numOpen (Open n) = n + numOpen _ = 0 + preOpen :: [Gene] + preOpen = take openIndex push diff --git a/src/HushGP/Instructions/CodeInstructions.hs b/src/HushGP/Instructions/CodeInstructions.hs index 6454703..65b9b61 100644 --- a/src/HushGP/Instructions/CodeInstructions.hs +++ b/src/HushGP/Instructions/CodeInstructions.hs @@ -52,10 +52,10 @@ instructionCodeTail state = state -- https://faculty.hampshire.edu/lspector/push3-description.html#Type -- This is the CODE.NTHCDR command instructionCodeTailN :: State -> State -instructionCodeTailN state@(State {_code = Block bc : cs, _int = i : is}) = state {_code = Block (drop index bc) : cs, _int = is} +instructionCodeTailN state@(State {_code = Block bc : cs, _int = i1 : is}) = state {_code = Block (drop index bc) : cs, _int = is} where index :: Int - index = abs i `mod` length bc + index = fromIntegral (abs i1) `mod` length bc instructionCodeTailN state = state -- |If the top item on the code stack is a Block, takes the init of said Block and places the result on top of the code stack. @@ -101,8 +101,8 @@ instructionCodeDoThenPop state = state -- |Evaluates the top item on the code stack for each step along the range i to j. Both i and j are taken from the int stack. instructionCodeDoRange :: State -> State instructionCodeDoRange state@(State {_code = c1 : cs, _int = i0 : i1 : is, _exec = es}) = - if increment i0 i1 /= 0 - then state {_exec = c1 : Block [GeneInt (i1 + increment i0 i1), GeneInt i0, StateFunc (instructionCodeFromExec, "instructionCodeFromExec"), c1, StateFunc (instructionCodeDoRange, "instructionCodeDoRange")] : es, _int = i1 : is, _code = cs} + if increment (fromIntegral i0) (fromIntegral i1) /= 0 + then state {_exec = c1 : Block [GeneInt (i1 + toInteger (increment (fromIntegral i0) (fromIntegral i1))), GeneInt i0, StateFunc (instructionCodeFromExec, "instructionCodeFromExec"), c1, StateFunc (instructionCodeDoRange, "instructionCodeDoRange")] : es, _int = i1 : is, _code = cs} else state {_exec = c1: es, _int = i1 : is, _code = cs} where increment :: Int -> Int -> Int @@ -154,7 +154,7 @@ instructionCodeN state@(State {_code = (Block c1) : cs, _int = i1 : is}) = else state where index :: Int - index = abs i1 `mod` length c1 + index = fromIntegral (abs i1) `mod` length c1 instructionCodeN state@(State {_code = c1 : cs, _int = _ : is}) = state {_code = c1 : cs, _int = is} instructionCodeN state = state @@ -185,7 +185,7 @@ instructionCodeExtract state@(State {_code = block@(Block c1) : cs, _int = i1 : let index = abs i1 `mod` codeRecursiveSize block in - state{_code = codeAtPoint c1 index : cs, _int = is} + state{_code = codeAtPoint c1 (fromIntegral index) : cs, _int = is} instructionCodeExtract state@(State {_code = cs, _int = _ : is}) = state{_code = cs, _int = is} instructionCodeExtract state = state @@ -196,12 +196,12 @@ instructionCodeInsert state@(State {_code = block@(Block c1) : c2 : cs, _int = i let index = abs i1 `mod` codeRecursiveSize block in - state{_code = Block (codeInsertAtPoint c1 c2 index) : cs, _int = is} + state{_code = Block (codeInsertAtPoint c1 c2 (fromIntegral index)) : cs, _int = is} instructionCodeInsert state@(State {_code = c1 : c2 : cs, _int = i1 : is}) = let index = abs i1 `mod` codeRecursiveSize (Block [c1]) in - state{_code = Block (codeInsertAtPoint [c1] c2 index) : cs, _int = is} + state{_code = Block (codeInsertAtPoint [c1] c2 (fromIntegral index)) : cs, _int = is} instructionCodeInsert state = state -- |If the top code item is a Block that is empty, pushes 0 to the int stack if c2 is also an empty Block and -1 if not. @@ -209,7 +209,7 @@ instructionCodeInsert state = state -- If neither the top code item or second code item are Blocks, checks equality. If equal, pushes 1 to int stack, pushes 0 if not. instructionCodeFirstPosition :: State -> State instructionCodeFirstPosition state@(State {_code = (Block []) : c2 : cs, _int = is}) = state {_code = cs, _int = (if c2 == Block [] then 0 else -1) : is} -instructionCodeFirstPosition state@(State {_code = (Block c1) : c2 : cs, _int = is}) = state {_code = cs, _int = positionElem c1 c2 : is} +instructionCodeFirstPosition state@(State {_code = (Block c1) : c2 : cs, _int = is}) = state {_code = cs, _int = fromIntegral (positionElem c1 c2) : is} where positionElem :: [Gene] -> Gene -> Int positionElem genes gene = diff --git a/src/HushGP/Instructions/ExecInstructions.hs b/src/HushGP/Instructions/ExecInstructions.hs index 2c1d0a4..ef69261 100644 --- a/src/HushGP/Instructions/ExecInstructions.hs +++ b/src/HushGP/Instructions/ExecInstructions.hs @@ -76,8 +76,8 @@ instructionExecIsStackEmpty = instructionIsStackEmpty exec -- taken from the int stack. Differs from code_do_range only in the source of the code and the recursive call. instructionExecDoRange :: State -> State instructionExecDoRange state@(State {_exec = e1 : es, _int = i0 : i1 : is}) = - if increment i0 i1 /= 0 - then state {_exec = e1 : Block [GeneInt (i1 + increment i0 i1), GeneInt i0, StateFunc (instructionExecDoRange, "instructionExecDoRange"), e1] : es, _int = i1 : is} + if increment (fromIntegral i0) (fromIntegral i1) /= 0 + then state {_exec = e1 : Block [GeneInt (i1 + toInteger (increment (fromIntegral i0) (fromIntegral i1))), GeneInt i0, StateFunc (instructionExecDoRange, "instructionExecDoRange"), e1] : es, _int = i1 : is} else state {_exec = e1 : es, _int = i1 : is} where increment :: Int -> Int -> Int diff --git a/src/HushGP/Instructions/FloatInstructions.hs b/src/HushGP/Instructions/FloatInstructions.hs index 45a0c84..cbfd4b3 100644 --- a/src/HushGP/Instructions/FloatInstructions.hs +++ b/src/HushGP/Instructions/FloatInstructions.hs @@ -10,7 +10,7 @@ import HushGP.TH -- |Converts the top int to a float and pushes the result to the float stack. instructionFloatFromInt :: State -> State -instructionFloatFromInt state@(State {_float = fs, _int = i1 : is}) = state {_float = (fromIntegral i1 :: Float) : fs, _int = is} +instructionFloatFromInt state@(State {_float = fs, _int = i1 : is}) = state {_float = (fromIntegral i1 :: Double) : fs, _int = is} instructionFloatFromInt state = state -- |If the top bool True, pushes 1.0 to the float stack. Pushes 0.0 if False. @@ -20,14 +20,14 @@ instructionFloatFromBool state = state -- |Takes the top char and converts it to int representation. That int then gets casted to a float and pushed to the float stack. instructionFloatFromChar :: State -> State -instructionFloatFromChar state@(State {_char = c1 : cs, _float = fs}) = state {_char = cs, _float = (fromIntegral (ord c1) :: Float) : fs} +instructionFloatFromChar state@(State {_char = c1 : cs, _float = fs}) = state {_char = cs, _float = (fromIntegral (ord c1) :: Double) : fs} instructionFloatFromChar state = state -- |Reads the top string and converts it to a float if possible. If not, acts as a NoOp. instructionFloatFromString :: State -> State instructionFloatFromString state@(State {_string = s1 : ss, _float = fs}) = if all (\x -> isDigit x || x == '.') s1 && amtOccurences "." s1 <= 1 - then state{_string = ss, _float = read @Float s1 : fs} + then state{_string = ss, _float = read @Double s1 : fs} else state instructionFloatFromString state = state diff --git a/src/HushGP/Instructions/GenericInstructions.hs b/src/HushGP/Instructions/GenericInstructions.hs index c754252..5a557a5 100644 --- a/src/HushGP/Instructions/GenericInstructions.hs +++ b/src/HushGP/Instructions/GenericInstructions.hs @@ -35,7 +35,7 @@ instructionDupN accessor state = _ -> state _ -> state where - instructionDupNHelper :: Int -> a -> Lens' State [a] -> State -> State + instructionDupNHelper :: Integral b => b -> a -> Lens' State [a] -> State -> State instructionDupNHelper count instruction internalAccessor internalState = if count > 0 then instructionDupNHelper (count - 1) instruction internalAccessor (internalState & accessor .~ (instruction : view accessor internalState)) @@ -47,7 +47,7 @@ instructionDupItems :: Lens' State [a] -> State -> State instructionDupItems accessor state@(State {_int = i1 : is}) = if i1 <= 0 then state{_int = is} - else state{_int = is} & accessor .~ (take i1 (view accessor state{_int = is}) <> view accessor state{_int = is}) + else state{_int = is} & accessor .~ (take (fromIntegral i1) (view accessor state{_int = is}) <> view accessor state{_int = is}) instructionDupItems _ state = state -- |Swaps the top two instructions based on a lens @@ -88,14 +88,14 @@ instructionEq accessor state = -- |Calculates the stack depth based on a lens and pushes the result to the int stackk. instructionStackDepth :: Lens' State [a] -> State -> State -instructionStackDepth accessor state@(State {_int = is}) = state{_int = length (view accessor state) : is} +instructionStackDepth accessor state@(State {_int = is}) = state{_int = toInteger (length (view accessor state)) : is} -- |Copies an item from deep within a lens' stack to the top of the lens' stack based on -- the top int from the int stack. instructionYankDup :: Lens' State [a] -> State -> State instructionYankDup accessor state@(State {_int = i1 : is}) = if notEmptyStack accessor state - then state{_int = is} & accessor .~ (view accessor state{_int = is} !! max 0 (min i1 (length (view accessor state{_int = is}) - 1))) : view accessor state{_int = is} + then state{_int = is} & accessor .~ (view accessor state{_int = is} !! max 0 (min (fromIntegral i1) (length (view accessor state{_int = is}) - 1))) : view accessor state{_int = is} else state instructionYankDup _ state = state @@ -105,7 +105,7 @@ instructionYank :: forall a. Lens' State [a] -> State -> State instructionYank accessor state@(State {_int = i1 : is}) = let myIndex :: Int - myIndex = max 0 (min i1 (length (view accessor state{_int = is}) - 1)) + myIndex = max 0 (min (fromIntegral i1) (length (view accessor state{_int = is}) - 1)) item :: a item = view accessor state{_int = is} !! myIndex deletedState :: State @@ -122,7 +122,7 @@ instructionYank _ state = state instructionShoveDup :: Lens' State [a] -> State -> State instructionShoveDup accessor state@(State {_int = i1 : is}) = case uncons (view accessor state{_int = is}) of - Just (x,_) -> state{_int = is} & accessor .~ combineTuple x (splitAt (max 0 (min i1 (length (view accessor state{_int = is}) - 1))) (view accessor state{_int = is})) + Just (x,_) -> state{_int = is} & accessor .~ combineTuple x (splitAt (max 0 (min (fromIntegral i1) (length (view accessor state{_int = is}) - 1))) (view accessor state{_int = is})) _ -> state instructionShoveDup _ state = state @@ -182,7 +182,7 @@ instructionVectorTakeRN _ state = state instructionSubVector :: Lens' State [[a]] -> State -> State instructionSubVector accessor state@(State {_int = i1 : i2 : is}) = case uncons (view accessor state) of - Just (v1, vs) -> state{_int = is} & accessor .~ (subList i1 i2 v1 : vs) + Just (v1, vs) -> state{_int = is} & accessor .~ (subList (fromIntegral i1) (fromIntegral i2) v1 : vs) _ -> state instructionSubVector _ state = state @@ -301,7 +301,7 @@ instructionVectorDropR _ state = state instructionLength :: Lens' State [[a]] -> State -> State instructionLength accessor state@(State {_int = is}) = case uncons (view accessor state) of - Just (v1, vs) -> state{_int = length v1 : is} & accessor .~ vs + Just (v1, vs) -> state{_int = toInteger (length v1) : is} & accessor .~ vs _ -> state -- |Takes the top vector, reverses it, based on a lens. @@ -355,7 +355,7 @@ instructionVectorContainsVector accessor state@(State {_bool = bs}) = instructionVectorIndexOf :: Eq a => Lens' State [a] -> Lens' State [[a]] -> State -> State instructionVectorIndexOf primAccessor vectorAccessor state = case (uncons (view vectorAccessor state), uncons (view primAccessor state)) of - (Just (v1, vs), Just (p1, ps)) -> (state & vectorAccessor .~ vs & primAccessor .~ ps) & int .~ (findSubA v1 [p1] : view int (state & vectorAccessor .~ vs & primAccessor .~ ps)) + (Just (v1, vs), Just (p1, ps)) -> (state & vectorAccessor .~ vs & primAccessor .~ ps) & int .~ (toInteger (findSubA v1 [p1]) : view int (state & vectorAccessor .~ vs & primAccessor .~ ps)) _ -> state -- |Based on a vector lens and the two vectors on top of said stack. Searches and pushes the @@ -363,7 +363,7 @@ instructionVectorIndexOf primAccessor vectorAccessor state = instructionVectorIndexOfVector :: Eq a => Lens' State [[a]] -> State -> State instructionVectorIndexOfVector accessor state@(State {_int = is}) = case uncons (view accessor state) of - Just (v1, v2 : vs) -> state & accessor .~ vs & int .~ (findSubA v1 v2 : is) + Just (v1, v2 : vs) -> state & accessor .~ vs & int .~ (toInteger (findSubA v1 v2) : is) _ -> state -- |Based on two lenses, one of a primitive type and the next of a vector type, @@ -372,7 +372,7 @@ instructionVectorIndexOfVector accessor state@(State {_int = is}) = instructionVectorOccurrencesOf :: Eq a => Lens' State [a] -> Lens' State [[a]] -> State -> State instructionVectorOccurrencesOf primAccessor vectorAccessor state = case (uncons (view vectorAccessor state), uncons (view primAccessor state)) of - (Just (v1, vs), Just (p1, ps)) -> (state & vectorAccessor .~ vs & primAccessor .~ ps) & int .~ (amtOccurences v1 [p1] : view int (state & vectorAccessor .~ vs & primAccessor .~ ps)) + (Just (v1, vs), Just (p1, ps)) -> (state & vectorAccessor .~ vs & primAccessor .~ ps) & int .~ (toInteger (amtOccurences v1 [p1]) : view int (state & vectorAccessor .~ vs & primAccessor .~ ps)) _ -> state -- |Based on a vector lens and the top two vectors in said stack, @@ -381,7 +381,7 @@ instructionVectorOccurrencesOf primAccessor vectorAccessor state = instructionVectorOccurrencesOfVector :: Eq a => Lens' State [[a]] -> State -> State instructionVectorOccurrencesOfVector accessor state@(State {_int = is}) = case uncons (view accessor state) of - Just (v1, v2 : vs) -> state & accessor .~ vs & int .~ (amtOccurences v1 v2 : is) + Just (v1, v2 : vs) -> state & accessor .~ vs & int .~ (toInteger (amtOccurences v1 v2) : is) _ -> state -- |This function parses the primitives inside a vector type and pushes that vector split into @@ -435,7 +435,7 @@ instructionVectorReplace primAccessor vectorAccessor amt state = -- the primitive stack. The top of the primitive stack is the old value to be replaced. The second item -- in the primitive stack is the new value to replace the old one. N is pulled from the top of the int stack. instructionVectorReplaceN :: Eq a => Lens' State [a] -> Lens' State [[a]] -> State -> State -instructionVectorReplaceN primAccessor vectorAccessor state@(State {_int = i1 : is}) = instructionVectorReplace primAccessor vectorAccessor (Just i1) state{_int = is} +instructionVectorReplaceN primAccessor vectorAccessor state@(State {_int = i1 : is}) = instructionVectorReplace primAccessor vectorAccessor (Just (fromIntegral i1)) state{_int = is} instructionVectorReplaceN _ _ state = state -- |Based on a vector lens and the top three vectors on said stack. @@ -452,7 +452,7 @@ instructionVectorReplaceVector accessor amt state = -- Inside of the first vector, replaces the number of instances specified -- by the top of the int stack of the second vector with the third vector. instructionVectorReplaceVectorN :: Eq a => Lens' State [[a]] -> State -> State -instructionVectorReplaceVectorN accessor state@(State {_int = i1 : is}) = instructionVectorReplaceVector accessor (Just i1) state{_int = is} +instructionVectorReplaceVectorN accessor state@(State {_int = i1 : is}) = instructionVectorReplaceVector accessor (Just (fromIntegral i1)) state{_int = is} instructionVectorReplaceVectorN _ state = state -- |Based on two lenses, one of a primitive type and the next of a vector type, @@ -470,7 +470,7 @@ instructionVectorRemove primAccessor vectorAccessor amt state = -- item from the primitive stack equals a primitive inside of the vector stack. N is pulled -- from the top of the int stack. Not to be confused with instructionVectorRemoveNth. instructionVectorRemoveN :: Eq a => Lens' State [a] -> Lens' State [[a]] -> State -> State -instructionVectorRemoveN primAccessor vectorAccessor state@(State {_int = i1 : is}) = instructionVectorRemove primAccessor vectorAccessor (Just i1) state{_int = is} +instructionVectorRemoveN primAccessor vectorAccessor state@(State {_int = i1 : is}) = instructionVectorRemove primAccessor vectorAccessor (Just (fromIntegral i1)) state{_int = is} instructionVectorRemoveN _ _ state = state -- |Based on a vector lens. Removes the Nth index of the top vector of the passed @@ -496,7 +496,7 @@ instructionVectorRemoveVector accessor amt state = -- Inside of the first vector, removes the number of instances specified -- by the top of the int stack of the second vector. instructionVectorRemoveVectorN :: Eq a => Lens' State [[a]] -> State -> State -instructionVectorRemoveVectorN accessor state@(State {_int = i1 : is}) = instructionVectorRemoveVector accessor (Just i1) state{_int = is} +instructionVectorRemoveVectorN accessor state@(State {_int = i1 : is}) = instructionVectorRemoveVector accessor (Just (fromIntegral i1)) state{_int = is} instructionVectorRemoveVectorN _ state = state -- |Based on two lenses, one of a primitive type and the next of a vector type, @@ -542,7 +542,7 @@ instructionVectorSortReverse accessor state = instructionVectorInsert :: Lens' State [a] -> Lens' State [[a]] -> State -> State instructionVectorInsert primAccessor vectorAccessor state@(State {_int = i1 : is}) = case (uncons (view vectorAccessor state{_int = is}), uncons (view primAccessor state{_int = is})) of - (Just (v1, vs), Just (p1, ps)) -> state{_int = is} & primAccessor .~ ps & vectorAccessor .~ (combineTuple p1 (splitAt i1 v1) : vs) + (Just (v1, vs), Just (p1, ps)) -> state{_int = is} & primAccessor .~ ps & vectorAccessor .~ (combineTuple p1 (splitAt (fromIntegral i1) v1) : vs) _ -> state instructionVectorInsert _ _ state = state @@ -553,6 +553,6 @@ instructionVectorInsertVector :: Lens' State [[a]] -> State -> State instructionVectorInsertVector accessor state@(State {_int = i1 : is}) = case uncons (view accessor state) of Just (v1, v2 : vs) -> - state{_int = is} & accessor .~ (combineTupleList v2 (splitAt i1 v1) : vs) + state{_int = is} & accessor .~ (combineTupleList v2 (splitAt (fromIntegral i1) v1) : vs) _ -> state instructionVectorInsertVector _ state = state diff --git a/src/HushGP/Instructions/IntInstructions.hs b/src/HushGP/Instructions/IntInstructions.hs index 43e8877..5d49a6f 100644 --- a/src/HushGP/Instructions/IntInstructions.hs +++ b/src/HushGP/Instructions/IntInstructions.hs @@ -18,14 +18,14 @@ instructionIntFromBool state = state -- |Takes the top char and converts it to int representation. The result is pushed to the int stack. instructionIntFromChar :: State -> State -instructionIntFromChar state@(State {_char = c1 : cs, _int = is}) = state {_char = cs, _int = ord c1 : is} +instructionIntFromChar state@(State {_char = c1 : cs, _int = is}) = state {_char = cs, _int = fromIntegral (ord c1) : is} instructionIntFromChar state = state -- |Reads the top string and converts it to a int if possible. If not, acts as a NoOp. instructionIntFromString :: State -> State instructionIntFromString state@(State {_string = s1 : ss, _int = is}) = if all isDigit s1 - then state{_string = ss, _int = read @Int s1 : is} + then state{_string = ss, _int = read @Integer s1 : is} else state instructionIntFromString state = state diff --git a/src/HushGP/Instructions/Opens.hs b/src/HushGP/Instructions/Opens.hs new file mode 100644 index 0000000..d4334d5 --- /dev/null +++ b/src/HushGP/Instructions/Opens.hs @@ -0,0 +1,40 @@ +module HushGP.Instructions.Opens where + +import HushGP.State +import Data.Map qualified as Map +import HushGP.Instructions.ExecInstructions +import HushGP.Instructions.StringInstructions +import HushGP.Instructions.VectorIntInstructions +import HushGP.Instructions.VectorBoolInstructions +import HushGP.Instructions.VectorFloatInstructions +import HushGP.Instructions.VectorStringInstructions +import HushGP.Instructions.VectorCharInstructions + +-- |A Map that takes a Gene and returns how many Blocks it opens. +-- To be used in plushy conversion. +instructionOpens :: Map.Map Gene Int +instructionOpens = Map.fromList [ + (StateFunc (instructionExecIf, "instructionsExecIf"), 2), + (StateFunc (instructionExecDup, "instructionExecDup"), 1), + (StateFunc (instructionExecDupN, "instructionExecDupN"), 1), + (StateFunc (instructionExecPop, "instructionExecPop"), 1), + (StateFunc (instructionExecSwap, "instructionExecSwap"), 2), + (StateFunc (instructionExecRot, "instructionExecRot"), 3), + (StateFunc (instructionExecShove, "instructionExecShove"), 1), + (StateFunc (instructionExecShoveDup, "instructionExecShoveDup"), 1), + (StateFunc (instructionExecDoRange, "instructionExecDoRange"), 1), + (StateFunc (instructionExecDoCount, "instructionExecDoCount"), 1), + (StateFunc (instructionExecDoTimes, "instructionExecDoTimes"), 1), + (StateFunc (instructionExecWhile, "instructionExecWhile"), 1), + (StateFunc (instructionExecDoWhile, "instructionExecDoWhile"), 1), + (StateFunc (instructionExecWhen, "instructionExecWhen"), 1), + (StateFunc (instructionExecK, "instructionExecK"), 2), + (StateFunc (instructionExecS, "instructionExecS"), 3), + (StateFunc (instructionExecY, "instructionExecY"), 1), + (StateFunc (instructionStringIterate, "instructionStringIterate"), 1), + (StateFunc (instructionVectorIntIterate, "instructionVectorIntIterate"), 1), + (StateFunc (instructionVectorFloatIterate, "instructionVectorFloatIterate"), 1), + (StateFunc (instructionVectorStringIterate, "instructionVectorStringIterate"), 1), + (StateFunc (instructionVectorBoolIterate, "instructionVectorBoolIterate"), 1), + (StateFunc (instructionVectorCharIterate, "instructionVectorCharIterate"), 1) + ] diff --git a/src/HushGP/Instructions/Utility.hs b/src/HushGP/Instructions/Utility.hs index b58ebb7..bfbc8b6 100644 --- a/src/HushGP/Instructions/Utility.hs +++ b/src/HushGP/Instructions/Utility.hs @@ -135,8 +135,8 @@ isBlock _ = False -- |Utility function: Returns the length of the passed block. -- If the gene isn't a block, returns 1 -blockLength :: Gene -> Int -blockLength (Block bxs) = length bxs +blockLength :: Gene -> Integer +blockLength (Block bxs) = toInteger $ length bxs blockLength _ = 1 -- |Utility function: Returns true if the passed block is empty, false is not. @@ -150,7 +150,7 @@ blockIsNull _ = False -- CODE.CONTAINER findContainer :: Gene -> Gene -> Gene findContainer (Block fullA) gene - | length fullA <= blockLength gene = Block [] + | fromIntegral (length fullA) <= blockLength gene = Block [] | gene `elem` fullA = Block [] -- Not allowed to be top level | any isBlock fullA = findContainer' (filter isBlock fullA) gene | otherwise = Block [] @@ -162,8 +162,8 @@ findContainer (Block fullA) gene findContainer _ _ = Block [] -- |Utility Function: A helper function for instructionCodeDiscrepancy. The full description is there. -countDiscrepancy :: Gene -> Gene -> Int -countDiscrepancy (Block xs) (Block ys) = sum [if uncurry (==) tup then 0 else 1 | tup <- zip xs ys] + abs (length xs - length ys) +countDiscrepancy :: Gene -> Gene -> Integer +countDiscrepancy (Block xs) (Block ys) = sum [if uncurry (==) tup then 0 else 1 | tup <- zip xs ys] + abs (toInteger (length xs) - toInteger (length ys)) countDiscrepancy xgene ygene = if xgene == ygene then 1 else 0 -- |Utility Function: Extracts the first gene from a block. Returns itself if not a block @@ -220,7 +220,7 @@ codeMember (Block bxs) ygene = ygene `elem` bxs codeMember _ _ = False -- |Utility Function: Calculates the size of a Block including counting the nested Blocks recursively -codeRecursiveSize :: Gene -> Int +codeRecursiveSize :: Gene -> Integer codeRecursiveSize (Block bxs) = sum [codeRecursiveSize x + if isBlock x then 1 else 0 | x <- bxs] codeRecursiveSize _ = 1 diff --git a/src/HushGP/Push.hs b/src/HushGP/Push.hs index 342968e..a676ca0 100644 --- a/src/HushGP/Push.hs +++ b/src/HushGP/Push.hs @@ -12,25 +12,25 @@ import HushGP.State -- Everntually, this can be part of the apply func to state helpers, -- which should take the number and type of parameter they have. --- | This is one of the push genome functions itself, not infrastructure. +-- This is one of the push genome functions itself, not infrastructure. -- Optionally, split this off into independent functions -instructionParameterLoad :: State -> State -instructionParameterLoad state@(State {_parameter = (p : _)}) = case p of - (GeneInt val) -> state & int .~ val : view int state - (GeneFloat val) -> state & float .~ val : view float state - (GeneBool val) -> state & bool .~ val : view bool state - (GeneString val) -> state & string .~ val : view string state - (GeneChar val) -> state & char .~ val : view char state - (GeneVectorInt val) -> state & vectorInt .~ val : view vectorInt state - (GeneVectorFloat val) -> state & vectorFloat .~ val : view vectorFloat state - (GeneVectorBool val) -> state & vectorBool .~ val : view vectorBool state - (GeneVectorString val) -> state & vectorString .~ val : view vectorString state - (GeneVectorChar val) -> state & vectorChar .~ val : view vectorChar state - (StateFunc _) -> undefined - (PlaceInput _) -> undefined - Close -> undefined - (Block xs) -> state & exec .~ xs <> view exec state -instructionParameterLoad state = state +-- instructionParameterLoad :: State -> State +-- instructionParameterLoad state@(State {_parameter = (p : _)}) = case p of +-- (GeneInt val) -> state & int .~ val : view int state +-- (GeneFloat val) -> state & float .~ val : view float state +-- (GeneBool val) -> state & bool .~ val : view bool state +-- (GeneString val) -> state & string .~ val : view string state +-- (GeneChar val) -> state & char .~ val : view char state +-- (GeneVectorInt val) -> state & vectorInt .~ val : view vectorInt state +-- (GeneVectorFloat val) -> state & vectorFloat .~ val : view vectorFloat state +-- (GeneVectorBool val) -> state & vectorBool .~ val : view vectorBool state +-- (GeneVectorString val) -> state & vectorString .~ val : view vectorString state +-- (GeneVectorChar val) -> state & vectorChar .~ val : view vectorChar state +-- (StateFunc _) -> undefined +-- (PlaceInput _) -> undefined +-- Close -> undefined +-- (Block xs) -> state & exec .~ xs <> view exec state +-- instructionParameterLoad state = state -- | Loads a genome into the exec stack loadProgram :: [Gene] -> State -> State @@ -62,5 +62,16 @@ 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 + (GeneIntERC (val, _)) -> interpretExec (state & exec .~ es & int .~ val : view int state) + (GeneFloatERC (val, _)) -> interpretExec (state & exec .~ es & float .~ val : view float state) + (GeneBoolERC (val, _)) -> interpretExec (state & exec .~ es & bool .~ val : view bool state) + (GeneStringERC (val, _)) -> interpretExec (state & exec .~ es & string .~ val : view string state) + (GeneCharERC (val, _)) -> interpretExec (state & exec .~ es & char .~ val : view char state) + (GeneVectorIntERC (val, _)) -> interpretExec (state & exec .~ es & vectorInt .~ val : view vectorInt state) + (GeneVectorFloatERC (val, _)) -> interpretExec (state & exec .~ es & vectorFloat .~ val : view vectorFloat state) + (GeneVectorBoolERC (val, _)) -> interpretExec (state & exec .~ es & vectorBool .~ val : view vectorBool state) + (GeneVectorStringERC (val, _)) -> interpretExec (state & exec .~ es & vectorString .~ val : view vectorString state) + (GeneVectorCharERC (val, _)) -> interpretExec (state & exec .~ es & vectorChar .~ val : view vectorChar state) + Close -> undefined -- This should never happen. Will be converted to Blocks in the Plushy -> Exec stack process + (Open _) -> undefined -- This should also never happen. Should be converted in Plushy -> Exec stack process interpretExec state = state diff --git a/src/HushGP/PushTests.hs b/src/HushGP/PushTests.hs index 24f356e..72344ab 100644 --- a/src/HushGP/PushTests.hs +++ b/src/HushGP/PushTests.hs @@ -1,10 +1,10 @@ module HushGP.PushTests - ( module HushGP.PushTests.GenericTests, - module HushGP.PushTests.IntTests, - module HushGP.PushTests.UtilTests, - ) + -- ( module HushGP.PushTests.GenericTests, + -- module HushGP.PushTests.IntTests, + -- module HushGP.PushTests.UtilTests, + -- ) where -import HushGP.PushTests.GenericTests -import HushGP.PushTests.IntTests -import HushGP.PushTests.UtilTests +-- import HushGP.PushTests.GenericTests +-- import HushGP.PushTests.IntTests +-- import HushGP.PushTests.UtilTests diff --git a/src/HushGP/PushTests/GenericTests.hs b/src/HushGP/PushTests/GenericTests.hs index 807af7b..b726e54 100644 --- a/src/HushGP/PushTests/GenericTests.hs +++ b/src/HushGP/PushTests/GenericTests.hs @@ -1,120 +1,103 @@ module HushGP.PushTests.GenericTests where -import HushGP.State -import Control.Lens --- import Debug.Trace -import Test.QuickCheck --- import HushGP.Instructions.GenericInstructions +-- import HushGP.State +-- import Control.Lens +-- -- import Debug.Trace +-- import Test.QuickCheck +-- -- import HushGP.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 --- for example: the function aaa1Test relays this arg takes a transformation of two as and turns them into one a --- the numbers represent how many different stacks are used in the function. --- for example: the aaa1Test relays that it takes one stack as input. These stacks are passed in as Lens +-- -- 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 +-- -- for example: the function aaa1Test relays this arg takes a transformation of two as and turns them into one a +-- -- the numbers represent how many different stacks are used in the function. +-- -- for example: the aaa1Test relays that it takes one stack as input. These stacks are passed in as Lens --- We may be able to get rid of Lens entirely and use haskell's integrated accessors of type State -> [a] --- You can see what I'm talking about if you go into ghci and type: `:info _int` for example +-- -- We may be able to get rid of Lens entirely and use haskell's integrated accessors of type State -> [a] +-- -- You can see what I'm talking about if you go into ghci and type: `:info _int` for example -aaa1Test :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> (a -> a -> a) -> State -> Property -aaa1Test accessor instruction transformation state = - case (uncons (view accessor state), uncons (view accessor $ instruction state)) of - (Just (origx1, origx2 : _), Just (modx1, _)) -> transformation origx2 origx1 === modx1 .&&. length (view accessor state) === length (view accessor $ instruction state) + 1 - _ -> state === instruction state +-- aaa1Test :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> (a -> a -> a) -> State -> Property +-- aaa1Test accessor instruction transformation state = +-- case (uncons (view accessor state), uncons (view accessor $ instruction state)) of +-- (Just (origx1, origx2 : _), Just (modx1, _)) -> transformation origx2 origx1 === modx1 .&&. length (view accessor state) === length (view accessor $ instruction state) + 1 +-- _ -> state === instruction state -aa1Test :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> (a -> a) -> State -> Property -aa1Test accessor instruction transformation state = - case (uncons (view accessor state), uncons (view accessor $ instruction state)) of - (Just (origx1, _), Just (modx1, _)) -> transformation origx1 === modx1 .&&. length (view accessor state) === length (view accessor $ instruction state) - _ -> state === instruction state +-- aa1Test :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> (a -> a) -> State -> Property +-- aa1Test accessor instruction transformation state = +-- case (uncons (view accessor state), uncons (view accessor $ instruction state)) of +-- (Just (origx1, _), Just (modx1, _)) -> transformation origx1 === modx1 .&&. length (view accessor state) === length (view accessor $ instruction state) +-- _ -> state === instruction state -ab1Test :: (Show b, Eq b) => Lens' State [a] -> Lens' State [b] -> (State -> State) -> (a -> b) -> State -> Property -ab1Test accessorFrom accessorTo instruction transformation state = - case (uncons (view accessorTo $ instruction state), uncons (view accessorFrom state)) of - (Just (t1, _), Just (f1, _)) -> - t1 === transformation f1 .&&. - length (view accessorTo $ instruction state) === length (view accessorTo state) + 1 .&&. - length (view accessorFrom $ instruction state) === length (view accessorFrom state) - 1 - _ -> state === instruction state +-- ab1Test :: (Show b, Eq b) => Lens' State [a] -> Lens' State [b] -> (State -> State) -> (a -> b) -> State -> Property +-- ab1Test accessorFrom accessorTo instruction transformation state = +-- case (uncons (view accessorTo $ instruction state), uncons (view accessorFrom state)) of +-- (Just (t1, _), Just (f1, _)) -> +-- t1 === transformation f1 .&&. +-- length (view accessorTo $ instruction state) === length (view accessorTo state) + 1 .&&. +-- length (view accessorFrom $ instruction state) === length (view accessorFrom state) - 1 +-- _ -> state === instruction state -aab2Test :: (Show b, Eq b) => Lens' State [a] -> Lens' State [b] -> (State -> State) -> (a -> a -> b) -> State -> Property -aab2Test accessorFrom accessorTo instruction transformation state = - case (uncons (view accessorTo $ instruction state), uncons (view accessorFrom state)) of - (Just (t1, _), Just (f1, f2 : _)) -> - t1 === transformation f1 f2 .&&. - length (view accessorTo $ instruction state) == length (view accessorTo state) + 1 .&&. - length (view accessorFrom $ instruction state) == length (view accessorFrom state) - 2 - _ -> state === instruction state +-- aab2Test :: (Show b, Eq b) => Lens' State [a] -> Lens' State [b] -> (State -> State) -> (a -> a -> b) -> State -> Property +-- aab2Test accessorFrom accessorTo instruction transformation state = +-- case (uncons (view accessorTo $ instruction state), uncons (view accessorFrom state)) of +-- (Just (t1, _), Just (f1, f2 : _)) -> +-- t1 === transformation f1 f2 .&&. +-- length (view accessorTo $ instruction state) == length (view accessorTo state) + 1 .&&. +-- length (view accessorFrom $ instruction state) == length (view accessorFrom state) - 2 +-- _ -> state === instruction state -popTest :: (Show a) => Lens' State [a] -> (State -> State) -> State -> Property -popTest accessor instruction state = - if null $ view accessor state - then state === instruction state - else length (view accessor $ instruction state) === length (view accessor state) - 1 +-- popTest :: (Show a) => Lens' State [a] -> (State -> State) -> State -> Property +-- popTest accessor instruction state = +-- if null $ view accessor state +-- then state === instruction state +-- else length (view accessor $ instruction state) === length (view accessor state) - 1 -dupTest :: (Eq a, Show a) => Lens' State [a] -> (State -> State) -> State -> Property -dupTest accessor instruction state = - case uncons (view accessor state) of - Just (origx1, _) -> - case uncons (view accessor $ instruction state) of - Just (modx1, modx2 : _) -> - origx1 === modx1 .&&. origx1 === modx2 .&&. length (view accessor $ instruction state) === length (view accessor state) + 1 - _ -> state === instruction state - _ -> state === instruction state +-- dupTest :: (Eq a, Show a) => Lens' State [a] -> (State -> State) -> State -> Property +-- dupTest accessor instruction state = +-- case uncons (view accessor state) of +-- Just (origx1, _) -> +-- case uncons (view accessor $ instruction state) of +-- Just (modx1, modx2 : _) -> +-- origx1 === modx1 .&&. origx1 === modx2 .&&. length (view accessor $ instruction state) === length (view accessor state) + 1 +-- _ -> state === instruction state +-- _ -> state === instruction state --- How to test the int stack in particular? -dupTestN :: (Eq a, Show a) => Lens' State [a] -> (State -> State) -> State -> Property -dupTestN accessor instruction state = - case uncons (view int state) of - Just (i1, is) -> - let amt = max i1 0 in - case uncons (view accessor state{_int = is}) of - Just (origx1, _) -> - conjoin (map (origx1 ===) (take amt (view accessor $ instruction state))) .&&. - length (view accessor $ instruction state) === (length (view accessor state{_int = is}) + amt - 1) - _ -> state === instruction state - _ -> state === instruction state +-- -- How to test the int stack in particular? +-- dupTestN :: (Eq a, Show a) => Lens' State [a] -> (State -> State) -> State -> Property +-- dupTestN accessor instruction state = +-- case uncons (view int state) of +-- Just (i1, is) -> +-- let amt = max i1 0 in +-- case uncons (view accessor state{_int = is}) of +-- Just (origx1, _) -> +-- conjoin (map (origx1 ===) (take amt (view accessor $ instruction state))) .&&. +-- length (view accessor $ instruction state) === (length (view accessor state{_int = is}) + amt - 1) +-- _ -> state === instruction state +-- _ -> state === instruction state -swapTest :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> State -> Property -swapTest accessor instruction state = - case (uncons (view accessor state), uncons (view accessor $ instruction state)) of - (Just (origx1, origx2 : _), Just (modx1, modx2 : _)) -> origx1 === modx2 .&&. origx2 === modx1 - _ -> state === instruction state +-- swapTest :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> State -> Property +-- swapTest accessor instruction state = +-- case (uncons (view accessor state), uncons (view accessor $ instruction state)) of +-- (Just (origx1, origx2 : _), Just (modx1, modx2 : _)) -> origx1 === modx2 .&&. origx2 === modx1 +-- _ -> state === instruction state -rotTest :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> State -> Property -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 +-- rotTest :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> State -> Property +-- 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 +-- 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 +-- 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}) = +-- 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)) @@ -122,8 +105,25 @@ yankTest _ instruction state = state === instruction state -- 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 +-- (Just (x1, _), Just (_, _)) -> x1 === item -- _ -> state === instruction state --- yankDupTest _ instruction state = 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 --- shoveTest +-- -- 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/HushGP/PushTests/IntTests.hs b/src/HushGP/PushTests/IntTests.hs index caca9ee..605911b 100644 --- a/src/HushGP/PushTests/IntTests.hs +++ b/src/HushGP/PushTests/IntTests.hs @@ -1,84 +1,84 @@ module HushGP.PushTests.IntTests where -import HushGP.State -import HushGP.Instructions.IntInstructions -import HushGP.PushTests.GenericTests --- import Control.Lens hiding (uncons) -import Test.QuickCheck +-- import HushGP.State +-- import HushGP.Instructions.IntInstructions +-- import HushGP.PushTests.GenericTests +-- -- import Control.Lens hiding (uncons) +-- import Test.QuickCheck -prop_IntAdd :: State -> Property -prop_IntAdd = aaa1Test int instructionIntAdd (+) +-- prop_IntAdd :: State -> Property +-- prop_IntAdd = aaa1Test int instructionIntAdd (+) -prop_IntSub :: State -> Property -prop_IntSub = aaa1Test int instructionIntSub (-) +-- prop_IntSub :: State -> Property +-- prop_IntSub = aaa1Test int instructionIntSub (-) -prop_IntMul :: State -> Property -prop_IntMul = aaa1Test int instructionIntMul (*) +-- prop_IntMul :: State -> Property +-- prop_IntMul = aaa1Test int instructionIntMul (*) -prop_IntDiv :: State -> Property -prop_IntDiv state@(State {_int = 0 : _}) = state === instructionIntDiv state -prop_IntDiv state = aaa1Test int instructionIntDiv div state +-- prop_IntDiv :: State -> Property +-- prop_IntDiv state@(State {_int = 0 : _}) = state === instructionIntDiv state +-- prop_IntDiv state = aaa1Test int instructionIntDiv div state -prop_IntMod :: State -> Property -prop_IntMod state@(State {_int = 0 : _}) = state === instructionIntMod state -prop_IntMod state = aaa1Test int instructionIntMod mod state +-- prop_IntMod :: State -> Property +-- prop_IntMod state@(State {_int = 0 : _}) = state === instructionIntMod state +-- prop_IntMod state = aaa1Test int instructionIntMod mod state -prop_IntFromFloat :: State -> Property -prop_IntFromFloat = ab1Test float int instructionIntFromFloat floor +-- prop_IntFromFloat :: State -> Property +-- prop_IntFromFloat = ab1Test float int instructionIntFromFloat floor -prop_IntFromBool :: State -> Property -prop_IntFromBool = ab1Test bool int instructionIntFromBool (\x -> if x then 1 else 0) +-- prop_IntFromBool :: State -> Property +-- prop_IntFromBool = ab1Test bool int instructionIntFromBool (\x -> if x then 1 else 0) -prop_IntMin :: State -> Property -prop_IntMin = aaa1Test int instructionIntMin min +-- prop_IntMin :: State -> Property +-- prop_IntMin = aaa1Test int instructionIntMin min -prop_IntMax :: State -> Property -prop_IntMax = aaa1Test int instructionIntMax max +-- prop_IntMax :: State -> Property +-- prop_IntMax = aaa1Test int instructionIntMax max -prop_IntInc :: State -> Property -prop_IntInc = aa1Test int instructionIntInc (+1) +-- prop_IntInc :: State -> Property +-- prop_IntInc = aa1Test int instructionIntInc (+1) -prop_IntDec :: State -> Property -prop_IntDec = aa1Test int instructionIntDec (\x -> x - 1) +-- prop_IntDec :: State -> Property +-- prop_IntDec = aa1Test int instructionIntDec (\x -> x - 1) -prop_IntLT :: State -> Property -prop_IntLT = aab2Test int bool instructionIntLT (<) +-- prop_IntLT :: State -> Property +-- prop_IntLT = aab2Test int bool instructionIntLT (<) -prop_IntGT :: State -> Property -prop_IntGT = aab2Test int bool instructionIntGT (>) +-- prop_IntGT :: State -> Property +-- prop_IntGT = aab2Test int bool instructionIntGT (>) -prop_IntLTE :: State -> Property -prop_IntLTE = aab2Test int bool instructionIntLTE (<=) +-- prop_IntLTE :: State -> Property +-- prop_IntLTE = aab2Test int bool instructionIntLTE (<=) -prop_IntGTE :: State -> Property -prop_IntGTE = aab2Test int bool instructionIntGTE (>=) +-- prop_IntGTE :: State -> Property +-- prop_IntGTE = aab2Test int bool instructionIntGTE (>=) -prop_IntDup :: State -> Property -prop_IntDup = dupTest int instructionIntDup +-- prop_IntDup :: State -> Property +-- prop_IntDup = dupTest int instructionIntDup -prop_IntPop :: State -> Property -prop_IntPop = popTest int instructionIntPop +-- prop_IntPop :: State -> Property +-- prop_IntPop = popTest int instructionIntPop -prop_IntDupN :: State -> Property -prop_IntDupN = dupTestN int instructionIntDupN +-- prop_IntDupN :: State -> Property +-- prop_IntDupN = dupTestN int instructionIntDupN -prop_IntSwap :: State -> Property -prop_IntSwap = swapTest int instructionIntSwap +-- prop_IntSwap :: State -> Property +-- prop_IntSwap = swapTest int instructionIntSwap -prop_IntRot :: State -> Property -prop_IntRot = rotTest int instructionIntRot +-- prop_IntRot :: State -> Property +-- prop_IntRot = rotTest int instructionIntRot -prop_IntFlush :: State -> Property -prop_IntFlush = flushTest int instructionIntFlush +-- prop_IntFlush :: State -> Property +-- prop_IntFlush = flushTest int instructionIntFlush -prop_IntEq :: State -> Property -prop_IntEq = aab2Test int bool instructionIntEq (==) +-- prop_IntEq :: State -> Property +-- prop_IntEq = aab2Test int bool instructionIntEq (==) -prop_IntStackDepth :: State -> Property -prop_IntStackDepth = stackDepthTest int instructionIntStackDepth +-- prop_IntStackDepth :: State -> Property +-- prop_IntStackDepth = stackDepthTest int instructionIntStackDepth -prop_IntYank :: State -> Property -prop_IntYank = yankTest int instructionIntYank +-- prop_IntYank :: State -> Property +-- prop_IntYank = yankTest int instructionIntYank --- prop_IntYankDup :: State -> Property --- prop_IntYankDup = yankDupTest int instructionIntYankDup +-- -- prop_IntYankDup :: State -> Property +-- -- prop_IntYankDup = yankDupTest int instructionIntYankDup diff --git a/src/HushGP/PushTests/UtilTests.hs b/src/HushGP/PushTests/UtilTests.hs index 4422001..e0ca4e9 100644 --- a/src/HushGP/PushTests/UtilTests.hs +++ b/src/HushGP/PushTests/UtilTests.hs @@ -1,36 +1,36 @@ module HushGP.PushTests.UtilTests where -import HushGP.Instructions.Utility -import Test.QuickCheck +-- import HushGP.Instructions.Utility +-- 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_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_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 +-- 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 +-- -- 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_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 +-- -- prop_SubList :: Int -> Int -> [Int] -> Property +-- -- prop_SubList idx0 idx1 lst = +-- -- idx diff --git a/src/HushGP/State.hs b/src/HushGP/State.hs index 97f73ce..80dd2fa 100644 --- a/src/HushGP/State.hs +++ b/src/HushGP/State.hs @@ -1,33 +1,42 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} module HushGP.State where import Control.Lens hiding (elements) import Data.Map qualified as Map -import GHC.Generics -import Test.QuickCheck +import System.Random --- | 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. -- One solution is for the exec stack to be a list of [Gene]. -- The parameter stack could be singular [Gene] or multiple [atomic] types. data Gene - = GeneInt Int - | GeneFloat Float + = GeneInt Integer + | GeneFloat Double | GeneBool Bool | GeneString String | GeneChar Char - | GeneVectorInt [Int] - | GeneVectorFloat [Float] + | GeneVectorInt [Integer] + | GeneVectorFloat [Double] | GeneVectorBool [Bool] | GeneVectorString [String] | GeneVectorChar [Char] - | StateFunc (State -> State, String) -- The string stores the name of the function + -- |State -> State is the function itself. String stores the name of the function. + | StateFunc (State -> State, String) | PlaceInput String | Close + | Open Int | Block [Gene] - deriving (Generic) + | GeneIntERC (Integer, StdGen) + | GeneFloatERC (Double, StdGen) + | GeneBoolERC (Bool, StdGen) + | GeneStringERC (String, StdGen) + | GeneCharERC (Char, StdGen) + | GeneVectorIntERC ([Integer], StdGen) + | GeneVectorFloatERC ([Double], StdGen) + | GeneVectorBoolERC ([Bool], StdGen) + | GeneVectorStringERC ([String], StdGen) + | GeneVectorCharERC ([Char], StdGen) instance Eq Gene where GeneInt x == GeneInt y = x == y @@ -42,10 +51,69 @@ instance Eq Gene where GeneVectorString xs == GeneVectorString ys = xs == ys GeneVectorChar xs == GeneVectorChar ys = xs == ys Close == Close = True + Open x == Open y = x == y StateFunc (_, nameX) == StateFunc (_, nameY) = nameX == nameY Block x == Block y = x == y + GeneIntERC (x, _) == GeneIntERC (y, _) = x == y + GeneFloatERC (x, _) == GeneFloatERC (y, _) = x == y + GeneBoolERC (x, _) == GeneBoolERC (y, _) = x == y + GeneStringERC (x, _) == GeneStringERC (y, _) = x == y + GeneCharERC (x, _) == GeneCharERC (y, _) = x == y + GeneVectorIntERC (x, _) == GeneVectorIntERC (y, _) = x == y + GeneVectorFloatERC (x, _) == GeneVectorFloatERC (y, _) = x == y + GeneVectorBoolERC (x, _) == GeneVectorBoolERC (y, _) = x == y + GeneVectorStringERC (x, _) == GeneVectorStringERC (y, _) = x == y + GeneVectorCharERC (x, _) == GeneVectorCharERC (y, _) = x == y + GeneIntERC (x, _) == GeneInt y = x == y + GeneFloatERC (x, _) == GeneFloat y = x == y + GeneBoolERC (x, _) == GeneBool y = x == y + GeneStringERC (x, _) == GeneString y = x == y + GeneCharERC (x, _) == GeneChar y = x == y + GeneVectorIntERC (x, _) == GeneVectorInt y = x == y + GeneVectorFloatERC (x, _) == GeneVectorFloat y = x == y + GeneVectorBoolERC (x, _) == GeneVectorBool y = x == y + GeneVectorStringERC (x, _) == GeneVectorString y = x == y + GeneVectorCharERC (x, _) == GeneVectorChar y = x == y _ == _ = False +instance Ord Gene where + GeneInt x <= GeneInt y = x <= y + GeneFloat x <= GeneFloat y = x <= y + GeneBool x <= GeneBool y = x <= y + GeneString x <= GeneString y = x <= y + GeneChar x <= GeneChar y = x <= y + PlaceInput x <= PlaceInput y = x <= y + GeneVectorInt xs <= GeneVectorInt ys = xs <= ys + GeneVectorFloat xs <= GeneVectorFloat ys = xs <= ys + GeneVectorBool xs <= GeneVectorBool ys = xs <= ys + GeneVectorString xs <= GeneVectorString ys = xs <= ys + GeneVectorChar xs <= GeneVectorChar ys = xs <= ys + Close <= Close = True + Open x <= Open y = x <= y + StateFunc (_, nameX) <= StateFunc (_, nameY) = nameX <= nameY + Block x <= Block y = x <= y + GeneIntERC (x, _) <= GeneIntERC (y, _) = x <= y + GeneFloatERC (x, _) <= GeneFloatERC (y, _) = x <= y + GeneBoolERC (x, _) <= GeneBoolERC (y, _) = x <= y + GeneStringERC (x, _) <= GeneStringERC (y, _) = x <= y + GeneCharERC (x, _) <= GeneCharERC (y, _) = x <= y + GeneVectorIntERC (x, _) <= GeneVectorIntERC (y, _) = x <= y + GeneVectorFloatERC (x, _) <= GeneVectorFloatERC (y, _) = x <= y + GeneVectorBoolERC (x, _) <= GeneVectorBoolERC (y, _) = x <= y + GeneVectorStringERC (x, _) <= GeneVectorStringERC (y, _) = x <= y + GeneVectorCharERC (x, _) <= GeneVectorCharERC (y, _) = x <= y + GeneIntERC (x, _) <= GeneInt y = x <= y + GeneFloatERC (x, _) <= GeneFloat y = x <= y + GeneBoolERC (x, _) <= GeneBool y = x <= y + GeneStringERC (x, _) <= GeneString y = x <= y + GeneCharERC (x, _) <= GeneChar y = x <= y + GeneVectorIntERC (x, _) <= GeneVectorInt y = x <= y + GeneVectorFloatERC (x, _) <= GeneVectorFloat y = x <= y + GeneVectorBoolERC (x, _) <= GeneVectorBool y = x <= y + GeneVectorStringERC (x, _) <= GeneVectorString y = x <= y + GeneVectorCharERC (x, _) <= GeneVectorChar y = x <= y + _ <= _ = False + instance Show Gene where show (GeneInt x) = "Int: " <> show x show (GeneFloat x) = "Float: " <> show x @@ -60,69 +128,37 @@ instance Show Gene where show (GeneVectorString xs) = "String Vec: " <> show xs show (GeneVectorChar xs) = "Char Vec: " <> show xs show Close = "Close" + show (Open x) = "Open: " <> show x 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 - ] + show (GeneIntERC x) = "Int ERC: " <> show x + show (GeneFloatERC x) = "Float ERC: " <> show x + show (GeneBoolERC x) = "Bool ERC: " <> show x + show (GeneStringERC x) = "String ERC: " <> show x + show (GeneCharERC x) = "Char ERC: " <> show x + show (GeneVectorIntERC x) = "Int Vec ERC: " <> show x + show (GeneVectorFloatERC x) = "Float Vec ERC: " <> show x + show (GeneVectorBoolERC x) = "Bool Vec ERC: " <> show x + show (GeneVectorStringERC x) = "String Vec ERC: " <> show x + show (GeneVectorCharERC x) = "Char Vec ERC: " <> show x -- | The structure that holds all of the values. data State = State { _exec :: [Gene], _code :: [Gene], - _int :: [Int], - _float :: [Float], + _int :: [Integer], + _float :: [Double], _bool :: [Bool], _string :: [String], _char :: [Char], - _vectorInt :: [[Int]], - _vectorFloat :: [[Float]], + _vectorInt :: [[Integer]], + _vectorFloat :: [[Double]], _vectorBool :: [[Bool]], _vectorString :: [[String]], _vectorChar :: [[Char]], _parameter :: [Gene], _input :: Map.Map String Gene } - deriving (Show, Eq, Generic) - -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 + deriving (Show, Eq, Ord) emptyState :: State emptyState = @@ -148,8 +184,8 @@ exampleState = State { _exec = [], _code = [], - _int = [32, 56], - _float = [3.23, 9.235], + _int = [32, 56, 88, 91], + _float = [3.23, 9.235, 5.3211, 8.0], _bool = [True, False], _string = ["abc", "123"], _char = ['d', 'e', 'f'], diff --git a/src/HushGP/Utility.hs b/src/HushGP/Utility.hs new file mode 100644 index 0000000..3f2b525 --- /dev/null +++ b/src/HushGP/Utility.hs @@ -0,0 +1,15 @@ +module HushGP.Utility where + +import HushGP.State +import System.Random +import Control.Monad + +-- |Generates a single random instruction from a list of instructions. +randomInstruction :: [Gene] -> IO Gene +randomInstruction instructions = do + impureGen <- initStdGen + return $ instructions !! fst (uniformR (0, length instructions - 1) impureGen) + +-- |Generates a list of random instructions from a list of instructions passed in. +randomInstructions :: Int -> [Gene] -> IO [Gene] +randomInstructions amt instructions = replicateM amt (randomInstruction instructions)