a lot of changes, Int -> Integer, Float -> Double, ERCs, plushy testing, ...

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

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

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

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
+  if increment (fromIntegral i0) (fromIntegral 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}
+    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 =

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
+  if increment (fromIntegral i0) (fromIntegral i1) /= 0
-    then state {_exec = e1 : Block [GeneInt (i1 + increment i0 i1), GeneInt i0, StateFunc (instructionExecDoRange, "instructionExecDoRange"), e1] : es, _int = i1 : is}
+    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

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
 

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

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
 

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)
+  ]

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 :: Gene -> Integer
-blockLength (Block bxs) = length bxs
+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 :: Gene -> Gene -> Integer
-countDiscrepancy (Block xs) (Block ys) = sum [if uncurry (==) tup then 0 else 1 | tup <- zip xs ys] + abs (length xs - length ys)
+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
 

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
-instructionParameterLoad state@(State {_parameter = (p : _)}) = case p of
+-- instructionParameterLoad state@(State {_parameter = (p : _)}) = case p of
-  (GeneInt val) -> state & int .~ val : view int state
+--   (GeneInt val) -> state & int .~ val : view int state
-  (GeneFloat val) -> state & float .~ val : view float state
+--   (GeneFloat val) -> state & float .~ val : view float state
-  (GeneBool val) -> state & bool .~ val : view bool state
+--   (GeneBool val) -> state & bool .~ val : view bool state
-  (GeneString val) -> state & string .~ val : view string state
+--   (GeneString val) -> state & string .~ val : view string state
-  (GeneChar val) -> state & char .~ val : view char state
+--   (GeneChar val) -> state & char .~ val : view char state
-  (GeneVectorInt val) -> state & vectorInt .~ val : view vectorInt state
+--   (GeneVectorInt val) -> state & vectorInt .~ val : view vectorInt state
-  (GeneVectorFloat val) -> state & vectorFloat .~ val : view vectorFloat state
+--   (GeneVectorFloat val) -> state & vectorFloat .~ val : view vectorFloat state
-  (GeneVectorBool val) -> state & vectorBool .~ val : view vectorBool state
+--   (GeneVectorBool val) -> state & vectorBool .~ val : view vectorBool state
-  (GeneVectorString val) -> state & vectorString .~ val : view vectorString state
+--   (GeneVectorString val) -> state & vectorString .~ val : view vectorString state
-  (GeneVectorChar val) -> state & vectorChar .~ val : view vectorChar state
+--   (GeneVectorChar val) -> state & vectorChar .~ val : view vectorChar state
-  (StateFunc _) -> undefined
+--   (StateFunc _) -> undefined
-  (PlaceInput _) -> undefined
+--   (PlaceInput _) -> undefined
-  Close -> undefined
+--   Close -> undefined
-  (Block xs) -> state & exec .~ xs <> view exec state
+--   (Block xs) -> state & exec .~ xs <> view exec state
-instructionParameterLoad state = 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

src/HushGP/PushTests.hs

@@ -1,10 +1,10 @@
 module HushGP.PushTests
-  ( module HushGP.PushTests.GenericTests,
+  -- ( module HushGP.PushTests.GenericTests,
-    module HushGP.PushTests.IntTests,
+    -- module HushGP.PushTests.IntTests,
-    module HushGP.PushTests.UtilTests,
+    -- module HushGP.PushTests.UtilTests,
-  )
+  -- )
 where
 
-import HushGP.PushTests.GenericTests
+-- import HushGP.PushTests.GenericTests
-import HushGP.PushTests.IntTests
+-- import HushGP.PushTests.IntTests
-import HushGP.PushTests.UtilTests
+-- import HushGP.PushTests.UtilTests

src/HushGP/PushTests/GenericTests.hs

@@ -1,120 +1,103 @@
 module HushGP.PushTests.GenericTests where
 
-import HushGP.State
+-- import HushGP.State
-import Control.Lens
+-- import Control.Lens
--- import Debug.Trace
+-- -- import Debug.Trace
-import Test.QuickCheck
+-- import Test.QuickCheck
--- import HushGP.Instructions.GenericInstructions
+-- -- import HushGP.Instructions.GenericInstructions
 
--- The naming scheme:
+-- -- 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
+-- -- 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
+-- --   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.
+-- -- 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
+-- --   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]
+-- -- 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
+-- -- 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 :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> (a -> a -> a) -> State -> Property
-aaa1Test accessor instruction transformation state =
+-- aaa1Test accessor instruction transformation state =
-  case (uncons (view accessor state), uncons (view accessor $ instruction state)) of
+--   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
+--     (Just (origx1, origx2 : _), Just (modx1, _)) -> transformation origx2 origx1 === modx1 .&&. length (view accessor state) === length (view accessor $ instruction state) + 1
-    _ -> state === instruction state
+--     _ -> state === instruction state
 
-aa1Test :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> (a -> a) -> State -> Property
+-- aa1Test :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> (a -> a) -> State -> Property
-aa1Test accessor instruction transformation state =
+-- aa1Test accessor instruction transformation state =
-  case (uncons (view accessor state), uncons (view accessor $ instruction state)) of
+--   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)
+--     (Just (origx1, _), Just (modx1, _)) -> transformation origx1 === modx1 .&&. length (view accessor state) === length (view accessor $ instruction state)
-    _ -> state === instruction state
+--     _ -> state === instruction state
 
-ab1Test :: (Show b, Eq b) => Lens' State [a] -> Lens' State [b] -> (State -> State) -> (a -> b) -> State -> Property
+-- ab1Test :: (Show b, Eq b) => Lens' State [a] -> Lens' State [b] -> (State -> State) -> (a -> b) -> State -> Property
-ab1Test accessorFrom accessorTo instruction transformation state =
+-- ab1Test accessorFrom accessorTo instruction transformation state =
-  case (uncons (view accessorTo $ instruction state), uncons (view accessorFrom state)) of
+--   case (uncons (view accessorTo $ instruction state), uncons (view accessorFrom state)) of
-    (Just (t1, _), Just (f1, _)) -> 
+--     (Just (t1, _), Just (f1, _)) -> 
-      t1 === transformation f1 .&&. 
+--       t1 === transformation f1 .&&. 
-      length (view accessorTo $ instruction state) === length (view accessorTo state) + 1 .&&.
+--       length (view accessorTo $ instruction state) === length (view accessorTo state) + 1 .&&.
-      length (view accessorFrom $ instruction state) === length (view accessorFrom state) - 1 
+--       length (view accessorFrom $ instruction state) === length (view accessorFrom state) - 1 
-    _ -> state === instruction state
+--     _ -> state === instruction state
 
-aab2Test :: (Show b, Eq b) => Lens' State [a] -> Lens' State [b] -> (State -> State) -> (a -> a -> b) -> State -> Property
+-- aab2Test :: (Show b, Eq b) => Lens' State [a] -> Lens' State [b] -> (State -> State) -> (a -> a -> b) -> State -> Property
-aab2Test accessorFrom accessorTo instruction transformation state =
+-- aab2Test accessorFrom accessorTo instruction transformation state =
-  case (uncons (view accessorTo $ instruction state), uncons (view accessorFrom state)) of
+--   case (uncons (view accessorTo $ instruction state), uncons (view accessorFrom state)) of
-    (Just (t1, _), Just (f1, f2 : _)) ->
+--     (Just (t1, _), Just (f1, f2 : _)) ->
-      t1 === transformation f1 f2 .&&. 
+--       t1 === transformation f1 f2 .&&. 
-      length (view accessorTo $ instruction state) == length (view accessorTo state) + 1 .&&.
+--       length (view accessorTo $ instruction state) == length (view accessorTo state) + 1 .&&.
-      length (view accessorFrom $ instruction state) == length (view accessorFrom state) - 2       
+--       length (view accessorFrom $ instruction state) == length (view accessorFrom state) - 2       
-    _ -> state === instruction state
+--     _ -> state === instruction state
 
-popTest :: (Show a) => Lens' State [a] -> (State -> State) -> State -> Property
+-- popTest :: (Show a) => Lens' State [a] -> (State -> State) -> State -> Property
-popTest accessor instruction state = 
+-- popTest accessor instruction state = 
-  if null $ view accessor state 
+--   if null $ view accessor state 
-  then state === instruction state 
+--   then state === instruction state 
-  else length (view accessor $ instruction state) === length (view accessor state) - 1
+--   else length (view accessor $ instruction state) === length (view accessor state) - 1
 
-dupTest :: (Eq a, Show a) => Lens' State [a] -> (State -> State) -> State -> Property
+-- dupTest :: (Eq a, Show a) => Lens' State [a] -> (State -> State) -> State -> Property
-dupTest accessor instruction state =
+-- dupTest accessor instruction state =
-  case uncons (view accessor state) of
+--   case uncons (view accessor state) of
-    Just (origx1, _) ->
+--     Just (origx1, _) ->
-      case uncons (view accessor $ instruction state) of
+--       case uncons (view accessor $ instruction state) of
-        Just (modx1, modx2 : _) ->
+--         Just (modx1, modx2 : _) ->
-          origx1 === modx1 .&&. origx1 === modx2 .&&. length (view accessor $ instruction state) === length (view accessor state) + 1
+--           origx1 === modx1 .&&. origx1 === modx2 .&&. length (view accessor $ instruction state) === length (view accessor state) + 1
-        _ -> state === instruction state
+--         _ -> state === instruction state
-    _ -> state === instruction state
+--     _ -> state === instruction state
     
--- How to test the int stack in particular?
+-- -- How to test the int stack in particular?
-dupTestN :: (Eq a, Show a) => Lens' State [a] -> (State -> State) -> State -> Property
+-- dupTestN :: (Eq a, Show a) => Lens' State [a] -> (State -> State) -> State -> Property
-dupTestN accessor instruction state =
+-- dupTestN accessor instruction state =
-  case uncons (view int state) of
+--   case uncons (view int state) of
-    Just (i1, is) ->
+--     Just (i1, is) ->
-      let amt = max i1 0 in
+--       let amt = max i1 0 in
-      case uncons (view accessor state{_int = is}) of
+--       case uncons (view accessor state{_int = is}) of
-        Just (origx1, _) ->
+--         Just (origx1, _) ->
-          conjoin (map (origx1 ===) (take amt (view accessor $ instruction state))) .&&.
+--           conjoin (map (origx1 ===) (take amt (view accessor $ instruction state))) .&&.
-          length (view accessor $ instruction state) === (length (view accessor state{_int = is}) + amt - 1)
+--           length (view accessor $ instruction state) === (length (view accessor state{_int = is}) + amt - 1)
-        _ -> state === instruction state
+--         _ -> state === instruction state
-    _ -> state === instruction state
+--     _ -> state === instruction state
 
-swapTest :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> State -> Property
+-- swapTest :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> State -> Property
-swapTest accessor instruction state =
+-- swapTest accessor instruction state =
-  case (uncons (view accessor state), uncons (view accessor $ instruction state)) of
+--   case (uncons (view accessor state), uncons (view accessor $ instruction state)) of
-    (Just (origx1, origx2 : _), Just (modx1, modx2 : _)) -> origx1 === modx2 .&&. origx2 === modx1
+--     (Just (origx1, origx2 : _), Just (modx1, modx2 : _)) -> origx1 === modx2 .&&. origx2 === modx1
-    _ -> state === instruction state
+--     _ -> state === instruction state
 
-rotTest :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> State -> Property
+-- rotTest :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> State -> Property
-rotTest accessor instruction state =
+-- rotTest accessor instruction state =
-  case (uncons (view accessor state), uncons (view accessor $ instruction state)) of
+--   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)
+--     (Just (origx1, origx2 : origx3 : _), Just (modx1, modx2 : modx3 : _)) -> (origx1, origx2, origx3) === (modx2, modx3, modx1)
-    _ -> state === instruction state
+--     _ -> state === instruction state
 
-flushTest :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> State -> Property
+-- flushTest :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> State -> Property
-flushTest accessor instruction state =
+-- flushTest accessor instruction state =
-  property $ null $ view accessor $ instruction state
+--   property $ null $ view accessor $ instruction state
 
-stackDepthTest :: (Show a) => Lens' State [a] -> (State -> State) -> State -> Property
+-- stackDepthTest :: (Show a) => Lens' State [a] -> (State -> State) -> State -> Property
-stackDepthTest accessor instruction state =
+-- stackDepthTest accessor instruction state =
-  case uncons (view int $ instruction state) of
+--   case uncons (view int $ instruction state) of
-    Just (x1, _) -> x1 === length (view accessor state)
+--     Just (x1, _) -> x1 === length (view accessor state)
-    _ -> state === instruction state
+--     _ -> state === instruction state
 
-yankTest :: forall a. (Show a, Eq a) => Lens' State [a] -> (State -> State) -> State -> Property
+-- yankTest :: forall a. (Show a, Eq a) => Lens' State [a] -> (State -> State) -> State -> Property
-yankTest accessor instruction state@(State {_int = i1 : is}) =
+-- yankTest accessor instruction state@(State {_int = i1 : is}) =
-  let
-    myIndex :: Int
-    myIndex = max 0 (min i1 (length (view accessor state{_int = is}) - 1))
-    item :: a
-    item = view accessor state{_int = is} !! myIndex
-  in
-  case (uncons (view accessor $ instruction state), uncons is) of
-    (Just (x1, _), Just (_, _)) -> x1 === item
-    _ -> state === instruction state
-  -- .&&.  -- unsure how to get this functional
-  -- length (view accessor state{_int = is}) === length (view accessor $ instruction state)
-yankTest _ instruction state = state === instruction state
-
--- Might just make this a unit test
--- Come back to this later
--- yankDupTest :: forall a. (Show a, Eq a) => Lens' State [a] -> (State -> State) -> State -> Property
--- yankDupTest accessor instruction state@(State {_int = i1 : is}) =
 --   let
 --     myIndex :: Int
 --     myIndex = max 0 (min i1 (length (view accessor state{_int = is}) - 1))
@@ -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

src/HushGP/PushTests/IntTests.hs

@@ -1,84 +1,84 @@
 module HushGP.PushTests.IntTests where
 
-import HushGP.State
+-- import HushGP.State
-import HushGP.Instructions.IntInstructions
+-- import HushGP.Instructions.IntInstructions
-import HushGP.PushTests.GenericTests
+-- import HushGP.PushTests.GenericTests
--- import Control.Lens hiding (uncons)
+-- -- import Control.Lens hiding (uncons)
-import Test.QuickCheck
+-- import Test.QuickCheck
 
-prop_IntAdd :: State -> Property
+-- prop_IntAdd :: State -> Property
-prop_IntAdd = aaa1Test int instructionIntAdd (+)
+-- prop_IntAdd = aaa1Test int instructionIntAdd (+)
 
-prop_IntSub :: State -> Property
+-- prop_IntSub :: State -> Property
-prop_IntSub = aaa1Test int instructionIntSub (-)
+-- prop_IntSub = aaa1Test int instructionIntSub (-)
 
-prop_IntMul :: State -> Property
+-- prop_IntMul :: State -> Property
-prop_IntMul = aaa1Test int instructionIntMul (*)
+-- prop_IntMul = aaa1Test int instructionIntMul (*)
 
-prop_IntDiv :: State -> Property
+-- prop_IntDiv :: State -> Property
-prop_IntDiv state@(State {_int = 0 : _}) = state === instructionIntDiv state
+-- prop_IntDiv state@(State {_int = 0 : _}) = state === instructionIntDiv state
-prop_IntDiv state = aaa1Test int instructionIntDiv div state
+-- prop_IntDiv state = aaa1Test int instructionIntDiv div state
 
-prop_IntMod :: State -> Property
+-- prop_IntMod :: State -> Property
-prop_IntMod state@(State {_int = 0 : _}) = state === instructionIntMod state
+-- prop_IntMod state@(State {_int = 0 : _}) = state === instructionIntMod state
-prop_IntMod state = aaa1Test int instructionIntMod mod state
+-- prop_IntMod state = aaa1Test int instructionIntMod mod state
 
-prop_IntFromFloat :: State -> Property
+-- prop_IntFromFloat :: State -> Property
-prop_IntFromFloat = ab1Test float int instructionIntFromFloat floor
+-- prop_IntFromFloat = ab1Test float int instructionIntFromFloat floor
 
-prop_IntFromBool :: State -> Property
+-- prop_IntFromBool :: State -> Property
-prop_IntFromBool = ab1Test bool int instructionIntFromBool (\x -> if x then 1 else 0)
+-- prop_IntFromBool = ab1Test bool int instructionIntFromBool (\x -> if x then 1 else 0)
 
-prop_IntMin :: State -> Property
+-- prop_IntMin :: State -> Property
-prop_IntMin = aaa1Test int instructionIntMin min
+-- prop_IntMin = aaa1Test int instructionIntMin min
 
-prop_IntMax :: State -> Property
+-- prop_IntMax :: State -> Property
-prop_IntMax = aaa1Test int instructionIntMax max
+-- prop_IntMax = aaa1Test int instructionIntMax max
 
-prop_IntInc :: State -> Property
+-- prop_IntInc :: State -> Property
-prop_IntInc = aa1Test int instructionIntInc (+1)
+-- prop_IntInc = aa1Test int instructionIntInc (+1)
 
-prop_IntDec :: State -> Property
+-- prop_IntDec :: State -> Property
-prop_IntDec = aa1Test int instructionIntDec (\x -> x - 1)
+-- prop_IntDec = aa1Test int instructionIntDec (\x -> x - 1)
 
-prop_IntLT :: State -> Property
+-- prop_IntLT :: State -> Property
-prop_IntLT = aab2Test int bool instructionIntLT (<)
+-- prop_IntLT = aab2Test int bool instructionIntLT (<)
 
-prop_IntGT :: State -> Property
+-- prop_IntGT :: State -> Property
-prop_IntGT = aab2Test int bool instructionIntGT (>)
+-- prop_IntGT = aab2Test int bool instructionIntGT (>)
 
-prop_IntLTE :: State -> Property
+-- prop_IntLTE :: State -> Property
-prop_IntLTE = aab2Test int bool instructionIntLTE (<=)
+-- prop_IntLTE = aab2Test int bool instructionIntLTE (<=)
 
-prop_IntGTE :: State -> Property
+-- prop_IntGTE :: State -> Property
-prop_IntGTE = aab2Test int bool instructionIntGTE (>=)
+-- prop_IntGTE = aab2Test int bool instructionIntGTE (>=)
 
-prop_IntDup :: State -> Property
+-- prop_IntDup :: State -> Property
-prop_IntDup = dupTest int instructionIntDup
+-- prop_IntDup = dupTest int instructionIntDup
 
-prop_IntPop :: State -> Property
+-- prop_IntPop :: State -> Property
-prop_IntPop = popTest int instructionIntPop
+-- prop_IntPop = popTest int instructionIntPop
 
-prop_IntDupN :: State -> Property
+-- prop_IntDupN :: State -> Property
-prop_IntDupN = dupTestN int instructionIntDupN
+-- prop_IntDupN = dupTestN int instructionIntDupN
 
-prop_IntSwap :: State -> Property
+-- prop_IntSwap :: State -> Property
-prop_IntSwap = swapTest int instructionIntSwap
+-- prop_IntSwap = swapTest int instructionIntSwap
 
-prop_IntRot :: State -> Property
+-- prop_IntRot :: State -> Property
-prop_IntRot = rotTest int instructionIntRot
+-- prop_IntRot = rotTest int instructionIntRot
 
-prop_IntFlush :: State -> Property
+-- prop_IntFlush :: State -> Property
-prop_IntFlush = flushTest int instructionIntFlush
+-- prop_IntFlush = flushTest int instructionIntFlush
 
-prop_IntEq :: State -> Property
+-- prop_IntEq :: State -> Property
-prop_IntEq = aab2Test int bool instructionIntEq (==)
+-- prop_IntEq = aab2Test int bool instructionIntEq (==)
 
-prop_IntStackDepth :: State -> Property
+-- prop_IntStackDepth :: State -> Property
-prop_IntStackDepth = stackDepthTest int instructionIntStackDepth
+-- prop_IntStackDepth = stackDepthTest int instructionIntStackDepth
 
-prop_IntYank :: State -> Property
+-- prop_IntYank :: State -> Property
-prop_IntYank = yankTest int instructionIntYank
+-- prop_IntYank = yankTest int instructionIntYank
 
--- prop_IntYankDup :: State -> Property
+-- -- prop_IntYankDup :: State -> Property
--- prop_IntYankDup = yankDupTest int instructionIntYankDup
+-- -- prop_IntYankDup = yankDupTest int instructionIntYankDup

src/HushGP/PushTests/UtilTests.hs

@@ -1,36 +1,36 @@
 module HushGP.PushTests.UtilTests where
 
-import HushGP.Instructions.Utility
+-- import HushGP.Instructions.Utility
-import Test.QuickCheck
+-- import Test.QuickCheck
 
-prop_DeleteAtTest :: Int -> [Int] -> Property
+-- prop_DeleteAtTest :: Int -> [Int] -> Property
-prop_DeleteAtTest idx lst =
+-- prop_DeleteAtTest idx lst =
-  idx >= 0 && idx < length lst ==>
+--   idx >= 0 && idx < length lst ==>
-  if null lst
+--   if null lst
-  then length lst === length (deleteAt idx lst)
+--   then length lst === length (deleteAt idx lst)
-  else length lst === length (deleteAt idx lst) + 1
+--   else length lst === length (deleteAt idx lst) + 1
 
-prop_CombineTupleTest :: Int -> ([Int], [Int]) -> Property
+-- prop_CombineTupleTest :: Int -> ([Int], [Int]) -> Property
-prop_CombineTupleTest val tup =
+-- prop_CombineTupleTest val tup =
-  length (fst tup) + length (snd tup) === length (combineTuple val tup) - 1
+--   length (fst tup) + length (snd tup) === length (combineTuple val tup) - 1
 
-prop_CombineTupleListTest :: [Int] -> ([Int], [Int]) -> Property
+-- prop_CombineTupleListTest :: [Int] -> ([Int], [Int]) -> Property
-prop_CombineTupleListTest lst tup =
+-- prop_CombineTupleListTest lst tup =
-  length (fst tup) + length (snd tup) === length (combineTupleList lst tup) - length lst
+--   length (fst tup) + length (snd tup) === length (combineTupleList lst tup) - length lst
 
--- Could use forAll to only generate valid tests
+-- -- Could use forAll to only generate valid tests
-prop_InsertAt :: Int -> Int -> [Int] -> Property
+-- prop_InsertAt :: Int -> Int -> [Int] -> Property
-prop_InsertAt idx val lst =
+-- prop_InsertAt idx val lst =
-  idx >= 0 && idx < length lst ==>
+--   idx >= 0 && idx < length lst ==>
-  length lst === length (insertAt idx val lst) - 1 .&&.
+--   length lst === length (insertAt idx val lst) - 1 .&&.
-  insertAt idx val lst !! idx === val
+--   insertAt idx val lst !! idx === val
 
-prop_ReplaceAt :: Int -> Int -> [Int] -> Property
+-- prop_ReplaceAt :: Int -> Int -> [Int] -> Property
-prop_ReplaceAt idx val lst =
+-- prop_ReplaceAt idx val lst =
-  idx >= 0 && idx < length lst ==>
+--   idx >= 0 && idx < length lst ==>
-  length lst === length (replaceAt idx val lst) .&&.
+--   length lst === length (replaceAt idx val lst) .&&.
-  replaceAt idx val lst !! idx === val
+--   replaceAt idx val lst !! idx === val
 
--- prop_SubList :: Int -> Int -> [Int] -> Property
+-- -- prop_SubList :: Int -> Int -> [Int] -> Property
--- prop_SubList idx0 idx1 lst =
+-- -- prop_SubList idx0 idx1 lst =
-  -- idx
+--   -- idx

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 System.Random
-import Test.QuickCheck
 
--- | 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
+  = GeneInt Integer
-  | GeneFloat Float
+  | GeneFloat Double
   | GeneBool Bool
   | GeneString String
   | GeneChar Char
-  | GeneVectorInt [Int]
+  | GeneVectorInt [Integer]
-  | GeneVectorFloat [Float]
+  | 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
-
+  show (GeneIntERC x) = "Int ERC: " <> show x
-instance CoArbitrary Gene
+  show (GeneFloatERC x) = "Float ERC: " <> show x
-
+  show (GeneBoolERC x) = "Bool ERC: " <> show x
-instance Arbitrary Gene where
+  show (GeneStringERC x) = "String ERC: " <> show x
-  arbitrary =
+  show (GeneCharERC x) = "Char ERC: " <> show x
-    oneof
+  show (GeneVectorIntERC x) = "Int Vec ERC: " <> show x
-      [ GeneInt <$> arbitrary,
+  show (GeneVectorFloatERC x) = "Float Vec ERC: " <> show x
-        GeneFloat <$> arbitrary,
+  show (GeneVectorBoolERC x) = "Bool Vec ERC: " <> show x
-        GeneBool <$> arbitrary,
+  show (GeneVectorStringERC x) = "String Vec ERC: " <> show x
-        GeneString <$> arbitrary,
+  show (GeneVectorCharERC x) = "Char Vec ERC: " <> show x
-        GeneChar <$> arbitrary,
-        StateFunc <$> arbitrary,
-        PlaceInput <$> arbitrary,
-        GeneVectorInt <$> arbitrary,
-        GeneVectorFloat <$> arbitrary,
-        GeneVectorBool <$> arbitrary,
-        GeneVectorString <$> arbitrary,
-        GeneVectorChar <$> arbitrary,
-        Block <$> arbitrary,
-        return Close
-      ]
 
 -- | The structure that holds all of the values.
 data State = State
   { _exec :: [Gene],
     _code :: [Gene],
-    _int :: [Int],
+    _int :: [Integer],
-    _float :: [Float],
+    _float :: [Double],
     _bool :: [Bool],
     _string :: [String],
     _char :: [Char],
-    _vectorInt :: [[Int]],
+    _vectorInt :: [[Integer]],
-    _vectorFloat :: [[Float]],
+    _vectorFloat :: [[Double]],
     _vectorBool :: [[Bool]],
     _vectorString :: [[String]],
     _vectorChar :: [[Char]],
     _parameter :: [Gene],
     _input :: Map.Map String Gene
   }
-  deriving (Show, Eq, Generic)
+  deriving (Show, Eq, Ord)
-
-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
 
 emptyState :: State
 emptyState =
@@ -148,8 +184,8 @@ exampleState =
   State
     { _exec = [],
       _code = [],
-      _int = [32, 56],
+      _int = [32, 56, 88, 91],
-      _float = [3.23, 9.235],
+      _float = [3.23, 9.235, 5.3211, 8.0],
       _bool = [True, False],
       _string = ["abc", "123"],
       _char = ['d', 'e', 'f'],

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)