a lot of changes, Int -> Integer, Float -> Double, ERCs, plushy testing, ...
This commit is contained in:
parent
5e08620a50
commit
915ec947f5
@ -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
|
||||
|
||||
6
TODO.md
6
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
|
||||
|
||||
80
src/HushGP/Genome.hs
Normal file
80
src/HushGP/Genome.hs
Normal file
@ -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
|
||||
@ -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 =
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
40
src/HushGP/Instructions/Opens.hs
Normal file
40
src/HushGP/Instructions/Opens.hs
Normal file
@ -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)
|
||||
]
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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'],
|
||||
|
||||
15
src/HushGP/Utility.hs
Normal file
15
src/HushGP/Utility.hs
Normal file
@ -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)
|
||||
Loading…
x
Reference in New Issue
Block a user