diff --git a/TODO.md b/TODO.md index 58f96e6..79efdc2 100644 --- a/TODO.md +++ b/TODO.md @@ -3,7 +3,7 @@ ## Push Language TODO - [ ] Make all vector functions applicable to string functions and vice versa -- [ ] Implement all functions as seen in propeller +- [X] Implement all functions as seen in propeller - [X] Implement all functions as seen in the specification - [ ] Implement Linear Algebra functions as specified in the previous papers - [X] Add a function to sort a vector forward and backwards @@ -12,7 +12,7 @@ - [X] Make int yank, shove, yankdup, and shovedup generic - [ ] Write hackage documentation for each function - [ ] Refactor all functions to take state as the final parameter -- [ ] Standardize the pattern matching parameters +- [ ] Standardize the pattern matching parameter names, such as c1 : cs - [ ] Write unit/quickcheck tests for all of the instructions ## PushGP TODO diff --git a/src/HushGP/Instructions.hs b/src/HushGP/Instructions.hs index c912de3..53772dc 100644 --- a/src/HushGP/Instructions.hs +++ b/src/HushGP/Instructions.hs @@ -70,7 +70,10 @@ allIntInstructions = map StateFunc [ (instructionIntYank, "instructionIntYank"), (instructionIntYankDup, "instructionIntYankDup"), (instructionIntShove, "instructionIntShove"), - (instructionIntIsEmpty, "instructionIntIsEmpty") + (instructionIntIsEmpty, "instructionIntIsEmpty"), + (instructionIntFromChar, "instructionIntFromChar"), + (instructionIntFromString, "instructionIntFromString"), + (instructionIntDupItems, "instructionIntDupItems") ] allFloatInstructions :: [Gene] @@ -100,7 +103,10 @@ allFloatInstructions = map StateFunc [ (instructionFloatYank, "instructionFloatYank"), (instructionFloatYankDup, "instructionFloatYankDup"), (instructionFloatShove, "instructionFloatShove"), - (instructionFloatIsEmpty, "instructionFloatIsEmpty") + (instructionFloatIsEmpty, "instructionFloatIsEmpty"), + (instructionFloatFromChar, "instructionFloatFromChar"), + (instructionFloatFromString, "instructionFloatFromString"), + (instructionFloatDupItems, "instructionFloatDupItems") ] allBoolInstructions :: [Gene] @@ -124,7 +130,8 @@ allBoolInstructions = map StateFunc [ (instructionBoolYankDup, "instructionBoolYankDup"), (instructionBoolShove, "instructionBoolShove"), (instructionBoolShoveDup, "instructionBoolShoveDup"), - (instructionBoolIsEmpty, "instructionBoolIsEmpty") + (instructionBoolIsEmpty, "instructionBoolIsEmpty"), + (instructionBoolDupItems, "instructionBoolDupItems") ] allCharInstructions :: [Gene] @@ -152,7 +159,8 @@ allCharInstructions = map StateFunc [ (instructionCharYankDup, "instructionCharYankDup"), (instructionCharShove, "instructionCharShove"), (instructionCharShoveDup, "instructionCharShoveDup"), - (instructionCharIsEmpty, "instructionCharIsEmpty") + (instructionCharIsEmpty, "instructionCharIsEmpty"), + (instructionCharDupItems, "instructionCharDupItems") ] allCodeInstructions :: [Gene] @@ -213,7 +221,8 @@ allCodeInstructions = map StateFunc [ (instructionCodeContainer, "instructionCodeContainer"), (instructionCodeDiscrepancy, "instructionCodeDiscrepancy"), (instructionCodeNoOp, "instructionCodeNoOp"), - (instructionCodeTailN, "instructionCodeTailN") + (instructionCodeTailN, "instructionCodeTailN"), + (instructionCodeDupItems, "instructionCodeDupItems") ] allExecInstructions :: [Gene] @@ -240,7 +249,8 @@ allExecInstructions = map StateFunc [ (instructionExecWhen, "instructionExecWhen"), (instructionExecK, "instructionExecK"), (instructionExecS, "instructionExecS"), - (instructionExecY, "instrucitonExecY") + (instructionExecY, "instrucitonExecY"), + (instructionExecDupItems, "instructionExecDupItems") ] allStringInstructions :: [Gene] @@ -302,7 +312,11 @@ allStringInstructions = map StateFunc [ (instructionStringYankDup, "instructionStringYankDup"), (instructionStringShove, "instructionStringShove"), (instructionStringShoveDup, "instructionStringShoveDup"), - (instructionStringIsEmpty, "instructionStringIsEmpty") + (instructionStringIsEmpty, "instructionStringIsEmpty"), + (instructionStringSort, "instructionStringSort"), + (instructionStringSortReverse, "instructionStringSortReverse"), + (instructionStringDupItems, "instructionStringDupItems"), + (instructionStringParseToChar, "instructionStringParseToChar") ] allVectorIntInstructions :: [Gene] @@ -340,7 +354,10 @@ allVectorIntInstructions = map StateFunc [ (instructionVectorIntYankDup, "instructionVectorIntYankDup"), (instructionVectorIntShove, "instructionVectorIntShove"), (instructionVectorIntShoveDup, "instructionVectorIntShoveDup"), - (instructionVectorIntStackIsEmpty, "instructionVectorIntStackIsEmpty") + (instructionVectorIntStackIsEmpty, "instructionVectorIntStackIsEmpty"), + (instructionVectorIntSort, "instructionVectorIntSort"), + (instructionVectorIntSortReverse, "instructionVectorIntSortReverse"), + (instructionVectorIntDupItems, "instructionVectorIntDupItems") ] allVectorFloatInstructions :: [Gene] @@ -378,7 +395,10 @@ allVectorFloatInstructions = map StateFunc [ (instructionVectorFloatYankDup, "instructionVectorFloatYankDup"), (instructionVectorFloatShove, "instructionVectorFloatShove"), (instructionVectorFloatShoveDup, "instructionVectorFloatShoveDup"), - (instructionVectorFloatStackIsEmpty, "instructionVectorFloatStackIsEmpty") + (instructionVectorFloatStackIsEmpty, "instructionVectorFloatStackIsEmpty"), + (instructionVectorFloatSort, "instructionVectorFloatSort"), + (instructionVectorFloatSortReverse, "instructionVectorFloatSortReverse"), + (instructionVectorFloatDupItems, "instructionVectorFloatDupItems") ] allVectorCharInstructions :: [Gene] @@ -416,7 +436,10 @@ allVectorCharInstructions = map StateFunc [ (instructionVectorCharYankDup, "instructionVectorCharYankDup"), (instructionVectorCharShove, "instructionVectorCharShove"), (instructionVectorCharShoveDup, "instructionVectorCharShoveDup"), - (instructionVectorCharStackIsEmpty, "instructionVectorCharStackIsEmpty") + (instructionVectorCharStackIsEmpty, "instructionVectorCharStackIsEmpty"), + (instructionVectorCharSort, "instructionVectorCharSort"), + (instructionVectorCharSortReverse, "instructionVectorCharSortReverse"), + (instructionVectorCharDupItems, "instructionVectorCharDupItems") ] allVectorStringInstructions :: [Gene] @@ -454,7 +477,10 @@ allVectorStringInstructions = map StateFunc [ (instructionVectorStringYankDup, "instructionVectorStringYankDup"), (instructionVectorStringShove, "instructionVectorStringShove"), (instructionVectorStringShoveDup, "instructionVectorStringShoveDup"), - (instructionVectorStringStackIsEmpty, "instructionVectorStringStackIsEmpty") + (instructionVectorStringStackIsEmpty, "instructionVectorStringStackIsEmpty"), + (instructionVectorStringSort, "instructionVectorStringSort"), + (instructionVectorStringSortReverse, "instructionVectorStringSortReverse"), + (instructionVectorStringDupItems, "instructionVectorStringDupItems") ] allVectorBoolInstructions :: [Gene] @@ -492,7 +518,10 @@ allVectorBoolInstructions = map StateFunc [ (instructionVectorBoolYankDup, "instructionVectorBoolYankDup"), (instructionVectorBoolShove, "instructionVectorBoolShove"), (instructionVectorBoolShoveDup, "instructionVectorBoolShoveDup"), - (instructionVectorBoolStackIsEmpty, "instructionVectorBoolStackIsEmpty") + (instructionVectorBoolStackIsEmpty, "instructionVectorBoolStackIsEmpty"), + (instructionVectorBoolSort, "instructionVectorBoolSort"), + (instructionVectorBoolSortReverse, "instructionVectorBoolSortReverse"), + (instructionVectorBoolDupItems, "instructionVectorBoolDupItems") ] allInstructions :: [Gene] diff --git a/src/HushGP/Instructions/BoolInstructions.hs b/src/HushGP/Instructions/BoolInstructions.hs index 5689349..eff7e5a 100644 --- a/src/HushGP/Instructions/BoolInstructions.hs +++ b/src/HushGP/Instructions/BoolInstructions.hs @@ -77,3 +77,6 @@ instructionBoolShoveDup state = instructionShoveDup state bool instructionBoolIsEmpty :: State -> State instructionBoolIsEmpty state = instructionIsEmpty state bool + +instructionBoolDupItems :: State -> State +instructionBoolDupItems = instructionDupItems bool diff --git a/src/HushGP/Instructions/CharInstructions.hs b/src/HushGP/Instructions/CharInstructions.hs index 3150ba3..f2f4864 100644 --- a/src/HushGP/Instructions/CharInstructions.hs +++ b/src/HushGP/Instructions/CharInstructions.hs @@ -87,3 +87,6 @@ instructionCharShove state = instructionShove state char instructionCharShoveDup :: State -> State instructionCharShoveDup state = instructionShoveDup state char + +instructionCharDupItems :: State -> State +instructionCharDupItems = instructionDupItems char diff --git a/src/HushGP/Instructions/CodeInstructions.hs b/src/HushGP/Instructions/CodeInstructions.hs index 0ce67b2..2078992 100644 --- a/src/HushGP/Instructions/CodeInstructions.hs +++ b/src/HushGP/Instructions/CodeInstructions.hs @@ -346,3 +346,6 @@ instructionCodeDiscrepancy state = state instructionCodeNoOp :: State -> State instructionCodeNoOp state = state + +instructionCodeDupItems :: State -> State +instructionCodeDupItems = instructionDupItems code diff --git a/src/HushGP/Instructions/ExecInstructions.hs b/src/HushGP/Instructions/ExecInstructions.hs index d0fe1ad..e4ced54 100644 --- a/src/HushGP/Instructions/ExecInstructions.hs +++ b/src/HushGP/Instructions/ExecInstructions.hs @@ -119,3 +119,6 @@ instructionExecS state = state instructionExecY :: State -> State instructionExecY state@(State {_exec = e1 : es}) = state{_exec = e1 : Block [StateFunc (instructionExecY, "instructionExecY"), e1] : es} instructionExecY state = state + +instructionExecDupItems :: State -> State +instructionExecDupItems = instructionDupItems exec diff --git a/src/HushGP/Instructions/FloatInstructions.hs b/src/HushGP/Instructions/FloatInstructions.hs index a9eb409..6b27896 100644 --- a/src/HushGP/Instructions/FloatInstructions.hs +++ b/src/HushGP/Instructions/FloatInstructions.hs @@ -3,6 +3,7 @@ module HushGP.Instructions.FloatInstructions where import Data.Fixed (mod') import HushGP.Instructions.GenericInstructions import HushGP.State +import Data.Char instructionFloatFromInt :: State -> State instructionFloatFromInt state@(State {_float = fs, _int = (i : is)}) = state {_float = (fromIntegral i :: Float) : fs, _int = is} @@ -12,6 +13,17 @@ instructionFloatFromBool :: State -> State instructionFloatFromBool state@(State {_bool = (b : bs), _float = fs}) = state {_bool = bs, _float = (if b then 1.0 else 0.0) : fs} instructionFloatFromBool state = state +instructionFloatFromChar :: State -> State +instructionFloatFromChar state@(State {_char = c : cs, _float = fs}) = state {_char = cs, _float = (fromIntegral (ord c) :: Float) : fs} +instructionFloatFromChar state = state + +instructionFloatFromString :: State -> State +instructionFloatFromString state@(State {_string = s1 : ss, _float = fs}) = + if all isDigit s1 + then state{_string = ss, _float = read @Float s1 : fs} + else state +instructionFloatFromString state = state + instructionFloatAdd :: State -> State instructionFloatAdd state@(State {_float = (f1 : f2 : fs)}) = state {_float = f2 + f1 : fs} instructionFloatAdd state = state @@ -114,3 +126,6 @@ instructionFloatCos state = state instructionFloatTan :: State -> State instructionFloatTan state@(State {_float = f1 : fs}) = state {_float = tan f1 : fs} instructionFloatTan state = state + +instructionFloatDupItems :: State -> State +instructionFloatDupItems = instructionDupItems float diff --git a/src/HushGP/Instructions/GenericInstructions.hs b/src/HushGP/Instructions/GenericInstructions.hs index ffa79e7..cf6479c 100644 --- a/src/HushGP/Instructions/GenericInstructions.hs +++ b/src/HushGP/Instructions/GenericInstructions.hs @@ -4,6 +4,7 @@ import Control.Lens import HushGP.State import Data.List (sort, sortBy) import Data.Ord +import Data.List.Split -- import Debug.Trace @@ -103,7 +104,7 @@ instructionIsEmpty state@(State {_bool = bs}) accessor = state{_bool = null (vie -- I might be able to move some of the int stack error checking -- to the integer call. For now this may be a tad inefficient. -instructionDupN :: forall a. Show a => State -> Lens' State [a] -> State +instructionDupN :: forall a. State -> Lens' State [a] -> State instructionDupN state accessor = case uncons (view int state) of Just (i1,is) -> @@ -119,6 +120,15 @@ instructionDupN state accessor = then instructionDupNHelper (count - 1) instruction internalAccessor (internalState & accessor .~ (instruction : view accessor internalState)) else internalState +-- |Duplicates the top N items on a stack. If n <= 0 nothing happens +-- TODO: Will need to implement a max stack items at some point +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}) +instructionDupItems _ state = state + instructionSwap :: State -> Lens' State [a] -> State instructionSwap state accessor = state & accessor .~ swapper (view accessor state) @@ -207,6 +217,12 @@ instructionConj state primAccessor vectorAccessor = (Just (p1,ps), Just (v1,vs)) -> state & primAccessor .~ ps & vectorAccessor .~ ((p1 : v1) : vs) _ -> state +instructionConjEnd :: Lens' State [a] -> Lens' State [[a]] -> State -> State +instructionConjEnd primAccessor vectorAccessor state = + case (uncons (view primAccessor state), uncons (view vectorAccessor state)) of + (Just (p1,ps), Just (v1,vs)) -> state & primAccessor .~ ps & vectorAccessor .~ ((v1 <> [p1]) : vs) + _ -> state + -- v for vector, vs for vectorstack (also applicable to strings) -- Could abstract this unconsing even further in all functions below instructionTakeN :: State -> Lens' State [[a]] -> State @@ -306,6 +322,14 @@ instructionVectorOccurrencesOf state primAccessor vectorAccessor = (Just (v1, vs), Just (p1, ps)) -> (state & vectorAccessor .~ vs & primAccessor .~ ps) & int .~ (amtOccurences v1 [p1] : view int (state & vectorAccessor .~ vs & primAccessor .~ ps)) _ -> state +-- | This function parses the primitives of a vector type and pushes split up onto their +-- respective stack +instructionVectorParseToPrim :: Lens' State [[a]] -> State -> State +instructionVectorParseToPrim accessor state = + case uncons (view accessor state) of + Just (x1, xs) -> state & accessor .~ (chunksOf 1 x1 <> xs) + _ -> state + instructionVectorSetNth :: State -> Lens' State [a] -> Lens' State [[a]] -> State instructionVectorSetNth state@(State {_int = i1 : is}) primAccessor vectorAccessor = case (uncons (view vectorAccessor state{_int = is}), uncons (view primAccessor state{_int = is})) of diff --git a/src/HushGP/Instructions/IntInstructions.hs b/src/HushGP/Instructions/IntInstructions.hs index 55a3180..ea3877b 100644 --- a/src/HushGP/Instructions/IntInstructions.hs +++ b/src/HushGP/Instructions/IntInstructions.hs @@ -2,6 +2,7 @@ module HushGP.Instructions.IntInstructions where import HushGP.State import HushGP.Instructions.GenericInstructions +import Data.Char -- import Debug.Trace instructionIntFromFloat :: State -> State @@ -12,6 +13,17 @@ instructionIntFromBool :: State -> State instructionIntFromBool state@(State {_bool = (b : bs), _int = is}) = state {_bool = bs, _int = (if b then 1 else 0) : is} instructionIntFromBool state = state +instructionIntFromChar :: State -> State +instructionIntFromChar state@(State {_char = c : cs, _int = is}) = state {_char = cs, _int = ord c : is} +instructionIntFromChar state = state + +instructionIntFromString :: State -> State +instructionIntFromString state@(State {_string = s1 : ss, _int = is}) = + if all isDigit s1 + then state{_string = ss, _int = read @Int s1 : is} + else state +instructionIntFromString state = state + instructionIntAdd :: State -> State instructionIntAdd state@(State {_int = (i1 : i2 : is)}) = state {_int = i2 + i1 : is} instructionIntAdd state = state @@ -102,3 +114,6 @@ instructionIntShoveDup state = instructionShoveDup state int instructionIntIsEmpty :: State -> State instructionIntIsEmpty state = instructionIsEmpty state int + +instructionIntDupItems :: State -> State +instructionIntDupItems = instructionDupItems int diff --git a/src/HushGP/Instructions/StringInstructions.hs b/src/HushGP/Instructions/StringInstructions.hs index d893027..59d492a 100644 --- a/src/HushGP/Instructions/StringInstructions.hs +++ b/src/HushGP/Instructions/StringInstructions.hs @@ -140,6 +140,9 @@ instructionStringTail state = state instructionStringAppendChar :: State -> State instructionStringAppendChar state = instructionConj state char string +instructionStringConjEndChar :: State -> State +instructionStringConjEndChar = instructionConjEnd char string + instructionStringRest :: State -> State instructionStringRest state = instructionRest state string @@ -229,3 +232,15 @@ instructionStringShove state = instructionShove state string instructionStringShoveDup :: State -> State instructionStringShoveDup state = instructionShoveDup state string + +instructionStringSort :: State -> State +instructionStringSort = instructionVectorSort string + +instructionStringSortReverse :: State -> State +instructionStringSortReverse = instructionVectorSortReverse string + +instructionStringDupItems :: State -> State +instructionStringDupItems = instructionDupItems string + +instructionStringParseToChar :: State -> State +instructionStringParseToChar = instructionVectorParseToPrim string diff --git a/src/HushGP/Instructions/VectorBoolInstructions.hs b/src/HushGP/Instructions/VectorBoolInstructions.hs index 6f226c1..2a07ea2 100644 --- a/src/HushGP/Instructions/VectorBoolInstructions.hs +++ b/src/HushGP/Instructions/VectorBoolInstructions.hs @@ -104,3 +104,12 @@ instructionVectorBoolShove state = instructionShove state vectorBool instructionVectorBoolShoveDup :: State -> State instructionVectorBoolShoveDup state = instructionShoveDup state vectorBool + +instructionVectorBoolSort :: State -> State +instructionVectorBoolSort = instructionVectorSort vectorBool + +instructionVectorBoolSortReverse :: State -> State +instructionVectorBoolSortReverse = instructionVectorSortReverse vectorBool + +instructionVectorBoolDupItems :: State -> State +instructionVectorBoolDupItems = instructionDupItems vectorBool diff --git a/src/HushGP/Instructions/VectorCharInstructions.hs b/src/HushGP/Instructions/VectorCharInstructions.hs index 12b083e..b84fef7 100644 --- a/src/HushGP/Instructions/VectorCharInstructions.hs +++ b/src/HushGP/Instructions/VectorCharInstructions.hs @@ -104,3 +104,12 @@ instructionVectorCharShove state = instructionShove state vectorChar instructionVectorCharShoveDup :: State -> State instructionVectorCharShoveDup state = instructionShoveDup state vectorChar + +instructionVectorCharSort :: State -> State +instructionVectorCharSort = instructionVectorSort vectorChar + +instructionVectorCharSortReverse :: State -> State +instructionVectorCharSortReverse = instructionVectorSortReverse vectorChar + +instructionVectorCharDupItems :: State -> State +instructionVectorCharDupItems = instructionDupItems vectorChar diff --git a/src/HushGP/Instructions/VectorFloatInstructions.hs b/src/HushGP/Instructions/VectorFloatInstructions.hs index 3f21566..da7e0de 100644 --- a/src/HushGP/Instructions/VectorFloatInstructions.hs +++ b/src/HushGP/Instructions/VectorFloatInstructions.hs @@ -104,3 +104,12 @@ instructionVectorFloatShove state = instructionShove state vectorFloat instructionVectorFloatShoveDup :: State -> State instructionVectorFloatShoveDup state = instructionShoveDup state vectorFloat + +instructionVectorFloatSort :: State -> State +instructionVectorFloatSort = instructionVectorSort vectorFloat + +instructionVectorFloatSortReverse :: State -> State +instructionVectorFloatSortReverse = instructionVectorSortReverse vectorFloat + +instructionVectorFloatDupItems :: State -> State +instructionVectorFloatDupItems = instructionDupItems vectorFloat diff --git a/src/HushGP/Instructions/VectorIntInstructions.hs b/src/HushGP/Instructions/VectorIntInstructions.hs index 1bac705..6ce893f 100644 --- a/src/HushGP/Instructions/VectorIntInstructions.hs +++ b/src/HushGP/Instructions/VectorIntInstructions.hs @@ -104,3 +104,12 @@ instructionVectorIntShove state = instructionShove state vectorChar instructionVectorIntShoveDup :: State -> State instructionVectorIntShoveDup state = instructionShoveDup state vectorChar + +instructionVectorIntSort :: State -> State +instructionVectorIntSort = instructionVectorSort vectorInt + +instructionVectorIntSortReverse :: State -> State +instructionVectorIntSortReverse = instructionVectorSortReverse vectorInt + +instructionVectorIntDupItems :: State -> State +instructionVectorIntDupItems = instructionDupItems vectorInt diff --git a/src/HushGP/Instructions/VectorStringInstructions.hs b/src/HushGP/Instructions/VectorStringInstructions.hs index 39d0b69..0914d87 100644 --- a/src/HushGP/Instructions/VectorStringInstructions.hs +++ b/src/HushGP/Instructions/VectorStringInstructions.hs @@ -104,3 +104,12 @@ instructionVectorStringShove state = instructionShove state vectorString instructionVectorStringShoveDup :: State -> State instructionVectorStringShoveDup state = instructionShoveDup state vectorString + +instructionVectorStringSort :: State -> State +instructionVectorStringSort = instructionVectorSort vectorString + +instructionVectorStringSortReverse :: State -> State +instructionVectorStringSortReverse = instructionVectorSortReverse vectorString + +instructionVectorStringDupItems :: State -> State +instructionVectorStringDupItems = instructionDupItems vectorString