diff --git a/HushGP.cabal b/HushGP.cabal index f24e378..fa30da6 100644 --- a/HushGP.cabal +++ b/HushGP.cabal @@ -35,27 +35,27 @@ library import: warnings -- Modules exported by the library. - exposed-modules: Push - , GP - , State - , Instructions - , Instructions.IntInstructions - , Instructions.ExecInstructions - , Instructions.FloatInstructions - , Instructions.GenericInstructions - , Instructions.LogicalInstructions - , Instructions.CodeInstructions - , Instructions.StringInstructions - , Instructions.CharInstructions - , Instructions.VectorIntInstructions - , Instructions.VectorFloatInstructions - , Instructions.VectorStringInstructions - , Instructions.VectorLogicalInstructions - , Instructions.VectorCharInstructions - , PushTests - , PushTests.IntTests - , PushTests.GenericTests - , PushTests.UtilTests + exposed-modules: HushGP.Push + , HushGP.GP + , HushGP.State + , HushGP.Instructions + , HushGP.Instructions.IntInstructions + , HushGP.Instructions.ExecInstructions + , HushGP.Instructions.FloatInstructions + , HushGP.Instructions.GenericInstructions + , HushGP.Instructions.BoolInstructions + , HushGP.Instructions.CodeInstructions + , HushGP.Instructions.StringInstructions + , HushGP.Instructions.CharInstructions + , HushGP.Instructions.VectorIntInstructions + , HushGP.Instructions.VectorFloatInstructions + , HushGP.Instructions.VectorStringInstructions + , HushGP.Instructions.VectorBoolInstructions + , HushGP.Instructions.VectorCharInstructions + , HushGP.PushTests + , HushGP.PushTests.IntTests + , HushGP.PushTests.GenericTests + , HushGP.PushTests.UtilTests -- Modules included in this library but not exported. -- other-modules: diff --git a/TODO.md b/TODO.md index f3b61eb..7ca127c 100644 --- a/TODO.md +++ b/TODO.md @@ -8,7 +8,7 @@ - [ ] Implement Linear Algebra functions as specified in the previous papers - [ ] Add a function to sort a vector forward and backwards - [ ] Disambiguate isEmpty and stackIsEmpty -- [ ] Rename Logical to Bool +- [X] Rename Logical to Bool - [x] Make int yank, shove, yankdup, and shovedup generic ## PushGP TODO diff --git a/src/HushGP/GP.hs b/src/HushGP/GP.hs new file mode 100644 index 0000000..d2be570 --- /dev/null +++ b/src/HushGP/GP.hs @@ -0,0 +1,3 @@ +module HushGP.GP where + +-- import Debug.Trace (trace, traceStack) diff --git a/src/HushGP/Instructions.hs b/src/HushGP/Instructions.hs new file mode 100644 index 0000000..a296aeb --- /dev/null +++ b/src/HushGP/Instructions.hs @@ -0,0 +1,504 @@ +module HushGP.Instructions + ( module HushGP.Instructions.GenericInstructions, + module HushGP.Instructions.IntInstructions, + module HushGP.Instructions.FloatInstructions, + module HushGP.Instructions.StringInstructions, + module HushGP.Instructions.CharInstructions, + module HushGP.Instructions.CodeInstructions, + module HushGP.Instructions.ExecInstructions, + module HushGP.Instructions.BoolInstructions, + module HushGP.Instructions.VectorIntInstructions, + module HushGP.Instructions.VectorFloatInstructions, + module HushGP.Instructions.VectorStringInstructions, + module HushGP.Instructions.VectorBoolInstructions, + module HushGP.Instructions.VectorCharInstructions, + allIntInstructions, + allFloatInstructions, + allBoolInstructions, + allCharInstructions, + allCodeInstructions, + allExecInstructions, + allStringInstructions, + allVectorIntInstructions, + allVectorFloatInstructions, + allVectorCharInstructions, + allVectorStringInstructions, + allVectorBoolInstructions, + allInstructions + ) +where + +import HushGP.Instructions.CharInstructions +import HushGP.Instructions.CodeInstructions +import HushGP.Instructions.ExecInstructions +import HushGP.Instructions.FloatInstructions +import HushGP.Instructions.GenericInstructions +import HushGP.Instructions.IntInstructions +import HushGP.Instructions.BoolInstructions +import HushGP.Instructions.StringInstructions +import HushGP.Instructions.VectorCharInstructions +import HushGP.Instructions.VectorFloatInstructions +import HushGP.Instructions.VectorIntInstructions +import HushGP.Instructions.VectorBoolInstructions +import HushGP.Instructions.VectorStringInstructions +import HushGP.State + +allIntInstructions :: [Gene] +allIntInstructions = map StateFunc [ + (instructionIntFromFloat, "instructionIntFromFloat"), + (instructionIntFromBool, "instructionIntFromBool"), + (instructionIntAdd, "instructionIntAdd"), + (instructionIntSub, "instructionIntSub"), + (instructionIntMul, "instructionIntMul"), + (instructionIntDiv, "instructionIntDiv"), + (instructionIntMod, "instructionIntMod"), + (instructionIntMin, "instructionIntMin"), + (instructionIntMax, "instructionIntMax"), + (instructionIntInc, "instructionIntInc"), + (instructionIntDec, "instructionIntDec"), + (instructionIntLT, "instructionIntLT"), + (instructionIntGT, "instructionIntGT"), + (instructionIntLTE, "instructionIntLTE"), + (instructionIntGTE, "instructionIntGTE"), + (instructionIntDup, "instructionIntDup"), + (instructionIntPop, "instructionIntPop"), + (instructionIntDupN, "instructionIntDupN"), + (instructionIntSwap, "instructionIntSwap"), + (instructionIntRot, "instructionIntRot"), + (instructionIntFlush, "instructionIntFlush"), + (instructionIntEq, "instructionIntEq"), + (instructionIntYank, "instructionIntYank"), + (instructionIntYankDup, "instructionIntYankDup"), + (instructionIntShove, "instructionIntShove"), + (instructionIntIsEmpty, "instructionIntIsEmpty") + ] + +allFloatInstructions :: [Gene] +allFloatInstructions = map StateFunc [ + (instructionFloatFromInt, "instructionFloatFromInt"), + (instructionFloatFromBool, "instructionFloatFromBool"), + (instructionFloatAdd, "instructionFloatAdd"), + (instructionFloatSub, "instructionFloatSub"), + (instructionFloatMul, "instructionFloatMul"), + (instructionFloatDiv, "instructionFloatDiv"), + (instructionFloatMod, "instructionFloatMod"), + (instructionFloatMin, "instructionFloatMin"), + (instructionFloatMax, "instructionFloatMax"), + (instructionFloatInc, "instructionFloatInc"), + (instructionFloatDec, "instructionFloatDec"), + (instructionFloatLT, "instructionFloatLT"), + (instructionFloatGT, "instructionFloatGT"), + (instructionFloatLTE, "instructionFloatLTE"), + (instructionFloatGTE, "instructionFloatGTE"), + (instructionFloatDup, "instructionFloatDup"), + (instructionFloatPop, "instructionFloatPop"), + (instructionFloatDupN, "instructionFloatDupN"), + (instructionFloatSwap, "instructionFloatSwap"), + (instructionFloatRot, "instructionFloatRot"), + (instructionFloatFlush, "instructionFloatFlush"), + (instructionFloatEq, "instructionFloatEq"), + (instructionFloatYank, "instructionFloatYank"), + (instructionFloatYankDup, "instructionFloatYankDup"), + (instructionFloatShove, "instructionFloatShove"), + (instructionFloatIsEmpty, "instructionFloatIsEmpty") + ] + +allBoolInstructions :: [Gene] +allBoolInstructions = map StateFunc [ + (instructionBoolFromInt, "instructionBoolFromInt"), + (instructionBoolFromFloat, "instructionBoolFromFloat"), + (instructionBoolAnd, "instructionBoolAnd"), + (instructionBoolInvertFirstThenAnd, "instructionBoolInvertFirstThenAnd"), + (instructionBoolInvertSecondThenAnd, "instructionBoolInvertSecondThenAnd"), + (instructionBoolOr, "instructionBoolOr"), + (instructionBoolXor, "instructionBoolXor"), + (instructionBoolPop, "instructionBoolPop"), + (instructionBoolDup, "instructionBoolDup"), + (instructionBoolDupN, "instructionBoolDupN"), + (instructionBoolSwap, "instructionBoolSwap"), + (instructionBoolRot, "instructionBoolRot"), + (instructionBoolFlush, "instructionBoolFlush"), + (instructionBoolEq, "instructionBoolEq"), + (instructionBoolStackDepth, "instructionBoolStackDepth"), + (instructionBoolYank, "instructionBoolYank"), + (instructionBoolYankDup, "instructionBoolYankDup"), + (instructionBoolShove, "instructionBoolShove"), + (instructionBoolShoveDup, "instructionBoolShoveDup"), + (instructionBoolIsEmpty, "instructionBoolIsEmpty") + ] + +allCharInstructions :: [Gene] +allCharInstructions = map StateFunc [ + (instructionCharConcat, "instructionCharConcat"), + (instructionCharFromFirstChar, "instructionCharFromFirstChar"), + (instructionCharFromLastChar, "instructionCharFromLastChar"), + (instructionCharFromNthChar, "instructionCharFromNthChar"), + (instructionCharIsWhitespace, "instructionCharIsWhitespace"), + (instructionCharIsLetter, "instructionCharIsLetter"), + (instructionCharIsDigit, "instructionCharIsDigit"), + (instructionCharFromBool, "instructionCharFromBool"), + (instructionCharFromAsciiInt, "instructionCharFromAsciiInt"), + (instructionCharFromAsciiFloat, "instructionCharFromAsciiFloat"), + (instructionCharsFromString, "instructionCharsFromString"), + (instructionCharPop, "instructionCharPop"), + (instructionCharDup, "instructionCharDup"), + (instructionCharDupN, "instructionCharDupN"), + (instructionCharSwap, "instructionCharSwap"), + (instructionCharRot, "instructionCharRot"), + (instructionCharFlush, "instructionCharFlush"), + (instructionCharEq, "instructionCharEq"), + (instructionCharStackDepth, "instructionCharStackDepth"), + (instructionCharYank, "instructionCharYank"), + (instructionCharYankDup, "instructionCharYankDup"), + (instructionCharShove, "instructionCharShove"), + (instructionCharShoveDup, "instructionCharShoveDup"), + (instructionCharIsEmpty, "instructionCharIsEmpty") + ] + +allCodeInstructions :: [Gene] +allCodeInstructions = map StateFunc [ + (instructionCodePop, "instructionCodePop"), + (instructionCodeIsCodeBlock, "instructionCodeIsCodeBlock"), + (instructionCodeIsSingular, "instructionCodeIsSingular"), + (instructionCodeLength, "instructionCodeLength"), + (instructionCodeFirst, "instructionCodeFirst"), + (instructionCodeLast, "instructionCodeLast"), + (instructionCodeTail, "instructionCodeTail"), + (instructionCodeInit, "instructionCodeInit"), + (instructionCodeWrap, "instructionCodeWrap"), + (instructionCodeList, "instructionCodeList"), + (instructionCodeCombine, "instructionCodeCombine"), + (instructionCodeDo, "instructionCodeDo"), + (instructionCodeDoDup, "instructionCodeDoDup"), + (instructionCodeDoThenPop, "instructionCodeDoThenPop"), + (instructionCodeDoRange, "instructionCodeDoRange"), + (instructionCodeDoCount, "instructionCodeDoCount"), + (instructionCodeDoTimes, "instructionCodeDoTimes"), + (instructionCodeIf, "instructionCodeIf"), + (instructionCodeWhen, "instructionCodeWhen"), + (instructionCodeMember, "instructionCodeMember"), + (instructionCodeN, "instructionCodeN"), + (instructionMakeEmptyCodeBlock, "instructionMakeEmptyCodeBlock"), + (instructionIsEmptyCodeBlock, "instructionIsEmptyCodeBlock"), + (instructionCodeSize, "instructionCodeSize"), + (instructionCodeExtract, "instructionCodeExtract"), + (instructionCodeInsert, "instructionCodeInsert"), + (instructionCodeFirstPosition, "instructionCodeFirstPosition"), + (instructionCodeReverse, "instructionCodeReverse"), + (instructionCodeDup, "instructionCodeDup"), + (instructionCodeDupN, "instructionCodeDupN"), + (instructionCodeDup, "instructionCodeDup"), + (instructionCodeDupN, "instructionCodeDupN"), + (instructionCodeSwap, "instructionCodeSwap"), + (instructionCodeRot, "instructionCodeRot"), + (instructionCodeFlush, "instructionCodeFlush"), + (instructionCodeEq, "instructionCodeEq"), + (instructionCodeStackDepth, "instructionCodeStackDepth"), + (instructionCodeYank, "instructionCodeYank"), + (instructionCodeYankDup, "instructionCodeYankDup"), + (instructionCodeShove, "instructionCodeShove"), + (instructionCodeShoveDup, "instructionCodeShoveDup"), + (instructionCodeStackIsEmpty, "instructionCodeStackIsEmpty"), + (instructionCodeFromBool, "instructionCodeFromBool"), + (instructionCodeFromInt, "instructionCodeFromInt"), + (instructionCodeFromChar, "instructionCodeFromChar"), + (instructionCodeFromFloat, "instructionCodeFromFloat"), + (instructionCodeFromString, "instructionCodeFromString"), + (instructionCodeFromVectorInt, "instructionCodeFromVectorInt"), + (instructionCodeFromVectorFloat, "instructionCodeFromVectorFloat"), + (instructionCodeFromVectorString, "instructionCodeFromVectorString"), + (instructionCodeFromVectorBool, "instructionCodeFromVectorBool"), + (instructionCodeFromVectorChar, "instructionCodeFromVectorChar"), + (instructionCodeFromExec, "instructionCodeFromExec") + ] + +allExecInstructions :: [Gene] +allExecInstructions = map StateFunc [ + (instructionExecIf, "instructionExecIf"), + (instructionExecDup, "instructionExecDup"), + (instructionExecDupN, "instructionExecDupN"), + (instructionExecPop, "instructionExecPop"), + (instructionExecSwap, "instructionExecSwap"), + (instructionExecRot, "instructionExecRot"), + (instructionExecFlush, "instructionExecFlush"), + (instructionExecEq, "instructionExecEq"), + (instructionExecStackDepth, "instructionExecStackDepth"), + (instructionExecYank, "instructionExecYank"), + (instructionExecYankDup, "instructionExecYankDup"), + (instructionExecShove, "instructionExecShove"), + (instructionExecShoveDup, "instructionExecShoveDup"), + (instructionExecIsEmpty, "instructionExecIsEmpty"), + (instructionExecDoRange, "instructionExecDoRange"), + (instructionExecDoCount, "instructionExecDoCount"), + (instructionExecDoTimes, "instructionExecDoTimes"), + (instructionExecWhile, "instructionExecWhile"), + (instructionExecDoWhile, "instructionExecDoWhile"), + (instructionExecWhen, "instructionExecWhen") + ] + +allStringInstructions :: [Gene] +allStringInstructions = map StateFunc [ + (instructionStringConcat, "instructionStringConcat"), + (instructionStringSwap, "instructionStringSwap"), + (instructionStringInsertString, "instructionStringInsertString"), + (instructionStringFromFirstChar, "instructionStringFromFirstChar"), + (instructionStringFromLastChar, "instructionStringFromLastChar"), + (instructionStringFromNthChar, "instructionStringFromNthChar"), + (instructionStringIndexOfString, "instructionStringIndexOfString"), + (instructionStringContainsString, "instructionStringContainsString"), + (instructionStringSplitOnString, "instructionStringSplitOnString"), + (instructionStringReplaceFirstString, "instructionStringReplaceFirstString"), + (instructionStringReplaceNString, "instructionStringReplaceNString"), + (instructionStringReplaceAllString, "instructionStringReplaceAllString"), + (instructionStringRemoveFirstString, "instructionStringRemoveFirstString"), + (instructionStringRemoveNString, "instructionStringRemoveNString"), + (instructionStringRemoveAllString, "instructionStringRemoveAllString"), + (instructionStringOccurrencesOfString, "instructionStringOccurrencesOfString"), + (instructionStringInsertChar, "instructionStringInsertChar"), + (instructionStringContainsChar, "instructionStringContainsChar"), + (instructionStringIndexOfChar, "instructionStringIndexOfChar"), + (instructionStringSplitOnChar, "instructionStringSplitOnChar"), + (instructionStringReplaceFirstChar, "instructionStringReplaceFirstChar"), + (instructionStringReplaceNChar, "instructionStringReplaceNChar"), + (instructionStringReplaceAllChar, "instructionStringReplaceAllChar"), + (instructionStringRemoveFirstChar, "instructionStringRemoveFirstChar"), + (instructionStringRemoveNChar, "instructionStringRemoveNChar"), + (instructionStringRemoveAllChar, "instructionStringRemoveAllChar"), + (instructionStringOccurrencesOfChar, "instructionStringOccurrencesOfChar"), + (instructionStringReverse, "instructionStringReverse"), + (instructionStringHead, "instructionStringHead"), + (instructionStringTail, "instructionStringTail"), + (instructionStringAppendChar, "instructionStringAppendChar"), + (instructionStringRest, "instructionStringRest"), + (instructionStringButLast, "instructionStringButLast"), + (instructionStringDrop, "instructionStringDrop"), + (instructionStringButLastN, "instructionStringButLastN"), + (instructionStringLength, "instructionStringLength"), + (instructionStringMakeEmpty, "instructionStringMakeEmpty"), + (instructionStringIsEmptyString, "instructionStringIsEmptyString"), + (instructionStringRemoveNth, "instructionStringRemoveNth"), + (instructionStringSetNth, "instructionStringSetNth"), + (instructionStringStripWhitespace, "instructionStringStripWhitespace"), + (instructionStringFromBool, "instructionStringFromBool"), + (instructionStringFromInt, "instructionStringFromInt"), + (instructionStringFromFloat, "instructionStringFromFloat"), + (instructionStringFromChar, "instructionStringFromChar"), + (instructionStringPop, "instructionStringPop"), + (instructionStringDup, "instructionStringDup"), + (instructionStringDupN, "instructionStringDupN"), + (instructionStringSwap, "instructionStringSwap"), + (instructionStringRot, "instructionStringRot"), + (instructionStringFlush, "instructionStringFlush"), + (instructionStringEq, "instructionStringEq"), + (instructionStringStackDepth, "instructionStringStackDepth"), + (instructionStringYank, "instructionStringYank"), + (instructionStringYankDup, "instructionStringYankDup"), + (instructionStringShove, "instructionStringShove"), + (instructionStringShoveDup, "instructionStringShoveDup"), + (instructionStringIsEmpty, "instructionStringIsEmpty") + ] + +allVectorIntInstructions :: [Gene] +allVectorIntInstructions = map StateFunc [ + (instructionVectorIntConcat, "instructionVectorIntConcat"), + (instructionVectorIntConj, "instructionVectorIntConj"), + (instructionVectorIntTakeN, "instructionVectorIntTakeN"), + (instructionVectorIntSubVector, "instructionVectorIntSubVector"), + (instructionVectorIntFirst, "instructionVectorIntFirst"), + (instructionVectorIntLast, "instructionVectorIntLast"), + (instructionVectorIntNth, "instructionVectorIntNth"), + (instructionVectorIntRest, "instructionVectorIntRest"), + (instructionVectorIntButLast, "instructionVectorIntButLast"), + (instructionVectorIntLength, "instructionVectorIntLength"), + (instructionVectorIntReverse, "instructionVectorIntReverse"), + (instructionVectorIntPushAll, "instructionVectorIntPushAll"), + (instructionVectorIntMakeEmpty, "instructionVectorIntMakeEmpty"), + (instructionVectorIntIsEmpty, "instructionVectorIntIsEmpty"), + (instructionVectorIntIndexOf, "instructionVectorIntIndexOf"), + (instructionVectorIntOccurrencesOf, "instructionVectorIntOccurrencesOf"), + (instructionVectorIntSetNth, "instructionVectorIntSetNth"), + (instructionVectorIntReplace, "instructionVectorIntReplace"), + (instructionVectorIntReplaceFirst, "instructionVectorIntReplaceFirst"), + (instructionVectorIntRemove, "instructionVectorIntRemove"), + (instructionVectorIntIterate, "instructionVectorIntIterate"), + (instructionVectorIntPop, "instructionVectorIntPop"), + (instructionVectorIntDup, "instructionVectorIntDup"), + (instructionVectorIntDupN, "instructionVectorIntDupN"), + (instructionVectorIntSwap, "instructionVectorIntSwap"), + (instructionVectorIntRot, "instructionVectorIntRot"), + (instructionVectorIntFlush, "instructionVectorIntFlush"), + (instructionVectorIntEq, "instructionVectorIntEq"), + (instructionVectorIntStackDepth, "instructionVectorIntStackDepth"), + (instructionVectorIntYank, "instructionVectorIntYank"), + (instructionVectorIntYankDup, "instructionVectorIntYankDup"), + (instructionVectorIntShove, "instructionVectorIntShove"), + (instructionVectorIntShoveDup, "instructionVectorIntShoveDup"), + (instructionVectorIntStackIsEmpty, "instructionVectorIntStackIsEmpty") + ] + +allVectorFloatInstructions :: [Gene] +allVectorFloatInstructions = map StateFunc [ + (instructionVectorFloatConcat, "instructionVectorFloatConcat"), + (instructionVectorFloatConj, "instructionVectorFloatConj"), + (instructionVectorFloatTakeN, "instructionVectorFloatTakeN"), + (instructionVectorFloatSubVector, "instructionVectorFloatSubVector"), + (instructionVectorFloatFirst, "instructionVectorFloatFirst"), + (instructionVectorFloatLast, "instructionVectorFloatLast"), + (instructionVectorFloatNth, "instructionVectorFloatNth"), + (instructionVectorFloatRest, "instructionVectorFloatRest"), + (instructionVectorFloatButLast, "instructionVectorFloatButLast"), + (instructionVectorFloatLength, "instructionVectorFloatLength"), + (instructionVectorFloatReverse, "instructionVectorFloatReverse"), + (instructionVectorFloatPushAll, "instructionVectorFloatPushAll"), + (instructionVectorFloatMakeEmpty, "instructionVectorFloatMakeEmpty"), + (instructionVectorFloatIsEmpty, "instructionVectorFloatIsEmpty"), + (instructionVectorFloatIndexOf, "instructionVectorFloatIndexOf"), + (instructionVectorFloatOccurrencesOf, "instructionVectorFloatOccurrencesOf"), + (instructionVectorFloatSetNth, "instructionVectorFloatSetNth"), + (instructionVectorFloatReplace, "instructionVectorFloatReplace"), + (instructionVectorFloatReplaceFirst, "instructionVectorFloatReplaceFirst"), + (instructionVectorFloatRemove, "instructionVectorFloatRemove"), + (instructionVectorFloatIterate, "instructionVectorFloatIterate"), + (instructionVectorFloatPop, "instructionVectorFloatPop"), + (instructionVectorFloatDup, "instructionVectorFloatDup"), + (instructionVectorFloatDupN, "instructionVectorFloatDupN"), + (instructionVectorFloatSwap, "instructionVectorFloatSwap"), + (instructionVectorFloatRot, "instructionVectorFloatRot"), + (instructionVectorFloatFlush, "instructionVectorFloatFlush"), + (instructionVectorFloatEq, "instructionVectorFloatEq"), + (instructionVectorFloatStackDepth, "instructionVectorFloatStackDepth"), + (instructionVectorFloatYank, "instructionVectorFloatYank"), + (instructionVectorFloatYankDup, "instructionVectorFloatYankDup"), + (instructionVectorFloatShove, "instructionVectorFloatShove"), + (instructionVectorFloatShoveDup, "instructionVectorFloatShoveDup"), + (instructionVectorFloatStackIsEmpty, "instructionVectorFloatStackIsEmpty") + ] + +allVectorCharInstructions :: [Gene] +allVectorCharInstructions = map StateFunc [ + (instructionVectorCharConcat, "instructionVectorCharConcat"), + (instructionVectorCharConj, "instructionVectorCharConj"), + (instructionVectorCharTakeN, "instructionVectorCharTakeN"), + (instructionVectorCharSubVector, "instructionVectorCharSubVector"), + (instructionVectorCharFirst, "instructionVectorCharFirst"), + (instructionVectorCharLast, "instructionVectorCharLast"), + (instructionVectorCharNth, "instructionVectorCharNth"), + (instructionVectorCharRest, "instructionVectorCharRest"), + (instructionVectorCharButLast, "instructionVectorCharButLast"), + (instructionVectorCharLength, "instructionVectorCharLength"), + (instructionVectorCharReverse, "instructionVectorCharReverse"), + (instructionVectorCharPushAll, "instructionVectorCharPushAll"), + (instructionVectorCharMakeEmpty, "instructionVectorCharMakeEmpty"), + (instructionVectorCharIsEmpty, "instructionVectorCharIsEmpty"), + (instructionVectorCharIndexOf, "instructionVectorCharIndexOf"), + (instructionVectorCharOccurrencesOf, "instructionVectorCharOccurrencesOf"), + (instructionVectorCharSetNth, "instructionVectorCharSetNth"), + (instructionVectorCharReplace, "instructionVectorCharReplace"), + (instructionVectorCharReplaceFirst, "instructionVectorCharReplaceFirst"), + (instructionVectorCharRemove, "instructionVectorCharRemove"), + (instructionVectorCharIterate, "instructionVectorCharIterate"), + (instructionVectorCharPop, "instructionVectorCharPop"), + (instructionVectorCharDup, "instructionVectorCharDup"), + (instructionVectorCharDupN, "instructionVectorCharDupN"), + (instructionVectorCharSwap, "instructionVectorCharSwap"), + (instructionVectorCharRot, "instructionVectorCharRot"), + (instructionVectorCharFlush, "instructionVectorCharFlush"), + (instructionVectorCharEq, "instructionVectorCharEq"), + (instructionVectorCharStackDepth, "instructionVectorCharStackDepth"), + (instructionVectorCharYank, "instructionVectorCharYank"), + (instructionVectorCharYankDup, "instructionVectorCharYankDup"), + (instructionVectorCharShove, "instructionVectorCharShove"), + (instructionVectorCharShoveDup, "instructionVectorCharShoveDup"), + (instructionVectorCharStackIsEmpty, "instructionVectorCharStackIsEmpty") + ] + +allVectorStringInstructions :: [Gene] +allVectorStringInstructions = map StateFunc [ + (instructionVectorStringConcat, "instructionVectorStringConcat"), + (instructionVectorStringConj, "instructionVectorStringConj"), + (instructionVectorStringTakeN, "instructionVectorStringTakeN"), + (instructionVectorStringSubVector, "instructionVectorStringSubVector"), + (instructionVectorStringFirst, "instructionVectorStringFirst"), + (instructionVectorStringLast, "instructionVectorStringLast"), + (instructionVectorStringNth, "instructionVectorStringNth"), + (instructionVectorStringRest, "instructionVectorStringRest"), + (instructionVectorStringButLast, "instructionVectorStringButLast"), + (instructionVectorStringLength, "instructionVectorStringLength"), + (instructionVectorStringReverse, "instructionVectorStringReverse"), + (instructionVectorStringPushAll, "instructionVectorStringPushAll"), + (instructionVectorStringMakeEmpty, "instructionVectorStringMakeEmpty"), + (instructionVectorStringIsEmpty, "instructionVectorStringIsEmpty"), + (instructionVectorStringIndexOf, "instructionVectorStringIndexOf"), + (instructionVectorStringOccurrencesOf, "instructionVectorStringOccurrencesOf"), + (instructionVectorStringSetNth, "instructionVectorStringSetNth"), + (instructionVectorStringReplace, "instructionVectorStringReplace"), + (instructionVectorStringReplaceFirst, "instructionVectorStringReplaceFirst"), + (instructionVectorStringRemove, "instructionVectorStringRemove"), + (instructionVectorStringIterate, "instructionVectorStringIterate"), + (instructionVectorStringPop, "instructionVectorStringPop"), + (instructionVectorStringDup, "instructionVectorStringDup"), + (instructionVectorStringDupN, "instructionVectorStringDupN"), + (instructionVectorStringSwap, "instructionVectorStringSwap"), + (instructionVectorStringRot, "instructionVectorStringRot"), + (instructionVectorStringFlush, "instructionVectorStringFlush"), + (instructionVectorStringEq, "instructionVectorStringEq"), + (instructionVectorStringStackDepth, "instructionVectorStringStackDepth"), + (instructionVectorStringYank, "instructionVectorStringYank"), + (instructionVectorStringYankDup, "instructionVectorStringYankDup"), + (instructionVectorStringShove, "instructionVectorStringShove"), + (instructionVectorStringShoveDup, "instructionVectorStringShoveDup"), + (instructionVectorStringStackIsEmpty, "instructionVectorStringStackIsEmpty") + ] + +allVectorBoolInstructions :: [Gene] +allVectorBoolInstructions = map StateFunc [ + (instructionVectorBoolConcat, "instructionVectorBoolConcat"), + (instructionVectorBoolConj, "instructionVectorBoolConj"), + (instructionVectorBoolTakeN, "instructionVectorBoolTakeN"), + (instructionVectorBoolSubVector, "instructionVectorBoolSubVector"), + (instructionVectorBoolFirst, "instructionVectorBoolFirst"), + (instructionVectorBoolLast, "instructionVectorBoolLast"), + (instructionVectorBoolNth, "instructionVectorBoolNth"), + (instructionVectorBoolRest, "instructionVectorBoolRest"), + (instructionVectorBoolButLast, "instructionVectorBoolButLast"), + (instructionVectorBoolLength, "instructionVectorBoolLength"), + (instructionVectorBoolReverse, "instructionVectorBoolReverse"), + (instructionVectorBoolPushAll, "instructionVectorBoolPushAll"), + (instructionVectorBoolMakeEmpty, "instructionVectorBoolMakeEmpty"), + (instructionVectorBoolIsEmpty, "instructionVectorBoolIsEmpty"), + (instructionVectorBoolIndexOf, "instructionVectorBoolIndexOf"), + (instructionVectorBoolOccurrencesOf, "instructionVectorBoolOccurrencesOf"), + (instructionVectorBoolSetNth, "instructionVectorBoolSetNth"), + (instructionVectorBoolReplace, "instructionVectorBoolReplace"), + (instructionVectorBoolReplaceFirst, "instructionVectorBoolReplaceFirst"), + (instructionVectorBoolRemove, "instructionVectorBoolRemove"), + (instructionVectorBoolIterate, "instructionVectorBoolIterate"), + (instructionVectorBoolPop, "instructionVectorBoolPop"), + (instructionVectorBoolDup, "instructionVectorBoolDup"), + (instructionVectorBoolDupN, "instructionVectorBoolDupN"), + (instructionVectorBoolSwap, "instructionVectorBoolSwap"), + (instructionVectorBoolRot, "instructionVectorBoolRot"), + (instructionVectorBoolFlush, "instructionVectorBoolFlush"), + (instructionVectorBoolEq, "instructionVectorBoolEq"), + (instructionVectorBoolStackDepth, "instructionVectorBoolStackDepth"), + (instructionVectorBoolYank, "instructionVectorBoolYank"), + (instructionVectorBoolYankDup, "instructionVectorBoolYankDup"), + (instructionVectorBoolShove, "instructionVectorBoolShove"), + (instructionVectorBoolShoveDup, "instructionVectorBoolShoveDup"), + (instructionVectorBoolStackIsEmpty, "instructionVectorBoolStackIsEmpty") + ] + +allInstructions :: [Gene] +allInstructions = + allIntInstructions <> + allFloatInstructions <> + allBoolInstructions <> + allCharInstructions <> + allCodeInstructions <> + allExecInstructions <> + allStringInstructions <> + allVectorIntInstructions <> + allVectorFloatInstructions <> + allVectorCharInstructions <> + allVectorStringInstructions <> + allVectorBoolInstructions diff --git a/src/HushGP/Instructions/BoolInstructions.hs b/src/HushGP/Instructions/BoolInstructions.hs new file mode 100644 index 0000000..5689349 --- /dev/null +++ b/src/HushGP/Instructions/BoolInstructions.hs @@ -0,0 +1,79 @@ +module HushGP.Instructions.BoolInstructions where + +import HushGP.State +import HushGP.Instructions.GenericInstructions + +instructionBoolFromInt :: State -> State +instructionBoolFromInt state@(State {_int = (i : is), _bool = bs}) = state {_int = is, _bool = (i /= 0) : bs} +instructionBoolFromInt state = state + +instructionBoolFromFloat :: State -> State +instructionBoolFromFloat state@(State {_float = (f : fs), _bool = bs}) = state {_float = fs, _bool = (f /= 0) : bs} +instructionBoolFromFloat state = state + +boolTemplate :: (Bool -> Bool -> Bool) -> State -> State +boolTemplate func state@(State {_bool = (b1 : b2 : bs)}) = state {_bool = func b1 b2 : bs} +boolTemplate _ state = state + +instructionBoolAnd :: State -> State +instructionBoolAnd = boolTemplate (&&) + +instructionBoolInvertFirstThenAnd :: State -> State +instructionBoolInvertFirstThenAnd state@(State {_bool = (b1 : bs)}) = boolTemplate (&&) state {_bool = not b1 : bs} +instructionBoolInvertFirstThenAnd state = state + +instructionBoolInvertSecondThenAnd :: State -> State +instructionBoolInvertSecondThenAnd state@(State {_bool = (b1 : b2 : bs)}) = boolTemplate (&&) state {_bool = b1 : not b2 : bs} +instructionBoolInvertSecondThenAnd state = state + +instructionBoolOr :: State -> State +instructionBoolOr = boolTemplate (||) + +-- no builtin haskell xor moment +xor :: Bool -> Bool -> Bool +xor b1 b2 + | b1 && not b2 = True + | not b1 && b2 = True + | otherwise = False + +instructionBoolXor :: State -> State +instructionBoolXor = boolTemplate xor + +instructionBoolPop :: State -> State +instructionBoolPop state = instructionPop state bool + +instructionBoolDup :: State -> State +instructionBoolDup state = instructionDup state bool + +instructionBoolDupN :: State -> State +instructionBoolDupN state = instructionDupN state bool + +instructionBoolSwap :: State -> State +instructionBoolSwap state = instructionSwap state bool + +instructionBoolRot :: State -> State +instructionBoolRot state = instructionRot state bool + +instructionBoolFlush :: State -> State +instructionBoolFlush state = instructionFlush state bool + +instructionBoolEq :: State -> State +instructionBoolEq state = instructionEq state bool + +instructionBoolStackDepth :: State -> State +instructionBoolStackDepth state = instructionStackDepth state bool + +instructionBoolYank :: State -> State +instructionBoolYank state = instructionYank state bool + +instructionBoolYankDup :: State -> State +instructionBoolYankDup state = instructionYankDup state bool + +instructionBoolShove :: State -> State +instructionBoolShove state = instructionShove state bool + +instructionBoolShoveDup :: State -> State +instructionBoolShoveDup state = instructionShoveDup state bool + +instructionBoolIsEmpty :: State -> State +instructionBoolIsEmpty state = instructionIsEmpty state bool diff --git a/src/HushGP/Instructions/CharInstructions.hs b/src/HushGP/Instructions/CharInstructions.hs new file mode 100644 index 0000000..3150ba3 --- /dev/null +++ b/src/HushGP/Instructions/CharInstructions.hs @@ -0,0 +1,89 @@ +module HushGP.Instructions.CharInstructions where + +import Data.Char +import HushGP.State +import HushGP.Instructions.StringInstructions (wschars) +import HushGP.Instructions.GenericInstructions + +intToAscii :: Integral a => a -> Char +intToAscii val = chr (abs (fromIntegral val) `mod` 128) + +instructionCharConcat :: State -> State +instructionCharConcat state@(State {_char = c1 : c2 : cs, _string = ss}) = state{_char = cs, _string = [c1, c2] : ss} +instructionCharConcat state = state + +instructionCharFromFirstChar :: State -> State +instructionCharFromFirstChar state = instructionVectorFirst state char string + +instructionCharFromLastChar :: State -> State +instructionCharFromLastChar state = instructionVectorLast state char string + +instructionCharFromNthChar :: State -> State +instructionCharFromNthChar state = instructionVectorNth state char string + +instructionCharIsWhitespace :: State -> State +instructionCharIsWhitespace state@(State {_char = c1 : cs, _bool = bs}) = state{_char = cs, _bool = (c1 `elem` wschars) : bs} +instructionCharIsWhitespace state = state + +instructionCharIsLetter :: State -> State +instructionCharIsLetter state@(State {_char = c1 : cs, _bool = bs}) = state{_char = cs, _bool = isAlpha c1 : bs} +instructionCharIsLetter state = state + +instructionCharIsDigit :: State -> State +instructionCharIsDigit state@(State {_char = c1 : cs, _bool = bs}) = state{_char = cs, _bool = isDigit c1 : bs} +instructionCharIsDigit state = state + +instructionCharFromBool :: State -> State +instructionCharFromBool state@(State {_char = cs, _bool = b1 : bs}) = state{_char = (if b1 then 'T' else 'F') : cs, _bool = bs} +instructionCharFromBool state = state + +instructionCharFromAsciiInt :: State -> State +instructionCharFromAsciiInt state@(State {_char = cs, _int = i1 : is}) = state{_char = intToAscii i1 : cs, _int = is} +instructionCharFromAsciiInt state = state + +instructionCharFromAsciiFloat :: State -> State +instructionCharFromAsciiFloat state@(State {_char = cs, _float = f1 : fs}) = state{_char = intToAscii @Integer (floor f1) : cs, _float = fs} +instructionCharFromAsciiFloat state = state + +instructionCharsFromString :: State -> State +instructionCharsFromString state@(State {_char = cs, _string = s1 : ss}) = state{_char = s1 <> cs, _string = ss} +instructionCharsFromString state = state + +instructionCharPop :: State -> State +instructionCharPop state = instructionPop state char + +instructionCharDup :: State -> State +instructionCharDup state = instructionDup state char + +instructionCharDupN :: State -> State +instructionCharDupN state = instructionDupN state char + +instructionCharSwap :: State -> State +instructionCharSwap state = instructionSwap state char + +instructionCharRot :: State -> State +instructionCharRot state = instructionRot state char + +instructionCharFlush :: State -> State +instructionCharFlush state = instructionFlush state char + +instructionCharEq :: State -> State +instructionCharEq state = instructionEq state char + +instructionCharStackDepth :: State -> State +instructionCharStackDepth state = instructionStackDepth state char + +instructionCharYank :: State -> State +instructionCharYank state = instructionYank state char + +instructionCharYankDup :: State -> State +instructionCharYankDup state = instructionYankDup state char + +instructionCharIsEmpty :: State -> State +instructionCharIsEmpty state = instructionIsEmpty state char + +instructionCharShove :: State -> State +instructionCharShove state = instructionShove state char + +instructionCharShoveDup :: State -> State +instructionCharShoveDup state = instructionShoveDup state char diff --git a/src/HushGP/Instructions/CodeInstructions.hs b/src/HushGP/Instructions/CodeInstructions.hs new file mode 100644 index 0000000..f7f069c --- /dev/null +++ b/src/HushGP/Instructions/CodeInstructions.hs @@ -0,0 +1,310 @@ +module HushGP.Instructions.CodeInstructions where + +import Data.List (elemIndex) +import HushGP.State +import HushGP.Instructions.GenericInstructions +import HushGP.Instructions.IntInstructions +-- import Debug.Trace + +isBlock :: Gene -> Bool +isBlock (Block _) = True +isBlock _ = False + +blockLength :: Gene -> Int +blockLength (Block xs) = length xs +blockLength _ = 1 + +blockIsNull :: Gene -> Bool +blockIsNull (Block xs) = null xs +blockIsNull _ = False + +-- I think I can abstract the boilerplate base case check for a lot of these +-- with a different function + +-- empty Blocks are a thing but that shouldn't really matter +extractFirstFromBlock :: Gene -> Gene +extractFirstFromBlock (Block (x : _)) = x +extractFirstFromBlock gene = gene + +extractLastFromBlock :: Gene -> Gene +extractLastFromBlock (Block []) = Block [] +extractLastFromBlock (Block xs) = last xs +extractLastFromBlock gene = gene + +extractInitFromBlock :: Gene -> Gene +extractInitFromBlock (Block []) = Block [] +extractInitFromBlock (Block xs) = Block (init xs) +extractInitFromBlock gene = gene + +extractTailFromBlock :: Gene -> Gene +extractTailFromBlock (Block xs) = Block (drop 1 xs) +extractTailFromBlock gene = gene + +-- This function took at least 3 hours to program. +codeAtPoint :: [Gene] -> Int -> Gene +codeAtPoint (gene : _) 0 = gene +codeAtPoint [] _ = Block [] -- Should only happen if an empty block is last Gene in the list of Genes +codeAtPoint ((Block nestedGenes) : genes) index = codeAtPoint (nestedGenes <> genes) (index - 1) +codeAtPoint (_ : genes) index = codeAtPoint genes (index - 1) + +codeInsertAtPoint :: [Gene] -> Gene -> Int -> [Gene] +codeInsertAtPoint oldGenes gene 0 = gene : oldGenes +codeInsertAtPoint [] gene _ = [gene] -- This shouldn't happen (lol) +codeInsertAtPoint ((Block genes) : oldGenes) gene index = Block (codeInsertAtPoint genes gene (index - 1)) : oldGenes +codeInsertAtPoint (oldGene : oldGenes) gene index = oldGene : codeInsertAtPoint oldGenes gene (index - 1) + +-- This one functions differently than pysh. +-- I like this one because it preserves ordering in the second case +codeCombine :: Gene -> Gene -> Gene +codeCombine (Block xs) (Block ys) = Block (xs <> ys) +codeCombine (Block xs) ygene = Block (xs <> [ygene]) +codeCombine xgene (Block ys) = Block (xgene : ys) +codeCombine xgene ygene = Block [xgene, ygene] + +codeMember :: Gene -> Gene -> Bool +codeMember (Block _) (Block _) = False -- Can't compare two lists with `elem` +codeMember (Block xs) ygene = ygene `elem` xs +codeMember _ _ = False + +codeRecursiveSize :: Gene -> Int +codeRecursiveSize (Block xs) = sum [codeRecursiveSize x + if isBlock x then 1 else 0 | x <- xs] +codeRecursiveSize _ = 1 + +instructionCodePop :: State -> State +instructionCodePop state = instructionPop state code + +instructionCodeIsCodeBlock :: State -> State +instructionCodeIsCodeBlock state@(State {_code = (c : cs), _bool = bs}) = state {_code = cs, _bool = isBlock c : bs} +instructionCodeIsCodeBlock state = state + +instructionCodeIsSingular :: State -> State +instructionCodeIsSingular state@(State {_code = (c : cs), _bool = bs}) = state {_code = cs, _bool = not (isBlock c) : bs} +instructionCodeIsSingular state = state + +instructionCodeLength :: State -> State +instructionCodeLength state@(State {_code = (c : cs), _int = is}) = state {_code = cs, _int = blockLength c : is} +instructionCodeLength state = state + +instructionCodeFirst :: State -> State +instructionCodeFirst state@(State {_code = (c : cs)}) = state {_code = extractFirstFromBlock c : cs} +instructionCodeFirst state = state + +instructionCodeLast :: State -> State +instructionCodeLast state@(State {_code = (c : cs)}) = state {_code = extractLastFromBlock c : cs} +instructionCodeLast state = state + +-- https://erp12.github.io/pyshgp/html/core_instructions.html#code-rest +instructionCodeTail :: State -> State +instructionCodeTail state@(State {_code = (c : cs)}) = state {_code = extractTailFromBlock c : cs} +instructionCodeTail state = state + +-- https://erp12.github.io/pyshgp/html/core_instructions.html#code-but-last +instructionCodeInit :: State -> State +instructionCodeInit state@(State {_code = (c : cs)}) = state {_code = extractInitFromBlock c : cs} +instructionCodeInit state = state + +instructionCodeWrap :: State -> State +instructionCodeWrap state@(State {_code = (c : cs)}) = state {_code = Block [c] : cs} +instructionCodeWrap state = state + +instructionCodeList :: State -> State +instructionCodeList state@(State {_code = (c1 : c2 : cs)}) = state {_code = Block [c1, c2] : cs} +instructionCodeList state = state + +instructionCodeCombine :: State -> State +instructionCodeCombine state@(State {_code = (c1 : c2 : cs)}) = state {_code = codeCombine c1 c2 : cs} +instructionCodeCombine state = state + +instructionCodeDo :: State -> State +instructionCodeDo state@(State {_code = (c1 : cs), _exec = es}) = state {_code = cs, _exec = c1: es} +instructionCodeDo state = state + +instructionCodeDoDup :: State -> State +instructionCodeDoDup state@(State {_code = (c1 : cs), _exec = es}) = state {_code = c1 : cs, _exec = c1 : es} +instructionCodeDoDup state = state + +-- https://erp12.github.io/pyshgp/html/core_instructions.html#code-do-then-pop +instructionCodeDoThenPop :: State -> State +instructionCodeDoThenPop state@(State {_code = c1 : _, _exec = es}) = state {_exec = c1 : StateFunc (instructionCodePop, "instructionCodePop") : es} +instructionCodeDoThenPop state = state + +codeFromExec :: Gene +codeFromExec = StateFunc (instructionCodeFromExec, "instructionCodeFromExec") + +codeDoRange :: Gene +codeDoRange = StateFunc (instructionCodeDoRange, "instructionCodeDoRange") + +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, codeFromExec, c1, codeDoRange] : es, _int = i1 : is, _code = cs} + else state {_exec = c1: es, _int = i1 : is, _code = cs} + where + increment :: Int -> Int -> Int + increment destIdx currentIdx + | currentIdx < destIdx = 1 + | currentIdx > destIdx = -1 + | otherwise = 0 +instructionCodeDoRange state = state + +instructionCodeDoCount :: State -> State +instructionCodeDoCount state@(State {_code = (c : cs), _int = (i : is), _exec = es}) = + if i < 1 + then state + else state {_code = cs, _int = is, _exec = Block [GeneInt 0, GeneInt $ i - 1, codeFromExec, c, codeDoRange] : es} +instructionCodeDoCount state = state + +instructionCodeDoTimes :: State -> State +instructionCodeDoTimes state@(State {_code = (c : cs), _int = (i : is), _exec = es}) = + if i < 1 + then state + else state {_code = cs, _int = is, _exec = Block [GeneInt 0, GeneInt $ i - 1, codeFromExec, Block [StateFunc (instructionIntPop, "instructionIntPop"), c], codeDoRange] : es} +instructionCodeDoTimes state = state + +instructionCodeIf :: State -> State +instructionCodeIf state@(State {_code = (c1 : c2 : cs), _bool = (b1 : bs), _exec = es}) = state{_code = cs, _bool = bs, _exec = (if b1 then c1 else c2) : es} +instructionCodeIf state = state + +instructionCodeWhen :: State -> State +instructionCodeWhen state@(State {_code = (c1 : cs), _bool = (b1 : bs), _exec = es}) = state{_code = cs, _bool = bs, _exec = if b1 then c1 : es else es} +instructionCodeWhen state = state + +instructionCodeMember :: State -> State +instructionCodeMember state@(State {_code = (c1 : c2 : cs), _bool = bs}) = state{_code = cs, _bool = codeMember c1 c2 : bs} +instructionCodeMember state = state + +-- This one doesn't count the recursive Blocks while instructionCodeExtract does +-- https://erp12.github.io/pyshgp/html/core_instructions.html#code-nth +instructionCodeN :: State -> State +instructionCodeN state@(State {_code = ((Block c1) : cs), _int = (i1 : is)}) = + if not $ null c1 + then state {_code = c1 !! index : cs, _int = is} + else state + where + index :: Int + index = abs i1 `mod` length c1 +instructionCodeN state@(State {_code = (c1 : cs), _int = _ : is}) = state {_code = c1 : cs, _int = is} +instructionCodeN state = state + +instructionMakeEmptyCodeBlock :: State -> State +instructionMakeEmptyCodeBlock state@(State {_code = cs}) = state {_code = Block [] : cs} + +instructionIsEmptyCodeBlock :: State -> State +instructionIsEmptyCodeBlock state@(State {_code = Block c1 : cs, _bool = bs}) = state{_code = cs, _bool = null c1 : bs} +instructionIsEmptyCodeBlock state@(State {_bool = bs}) = state{_bool = False : bs} + +instructionCodeSize :: State -> State +instructionCodeSize state@(State {_code = c1 : cs, _int = is}) = state{_code = cs, _int = codeRecursiveSize c1 : is} +instructionCodeSize state = state + +-- There's a bug for this instruction in pysh where the last item in the +-- top level Block isn't counted, and if passed 0, then the entire codeblock is returned. +-- I designed this function differently so 0 returns the 0th element, and the last item +-- in the codeblock can be returned. +instructionCodeExtract :: State -> State +instructionCodeExtract state@(State {_code = (block@(Block c1) : cs), _int = i1 : is}) = + let + index = abs i1 `mod` codeRecursiveSize block + in + state{_code = codeAtPoint c1 index : cs, _int = is} +instructionCodeExtract state@(State {_code = cs, _int = _ : is}) = state{_code = cs, _int = is} +instructionCodeExtract state = state + +instructionCodeInsert :: State -> State +instructionCodeInsert state@(State {_code = (block@(Block c1) : c2 : cs), _int = i1 : is}) = + let + index = abs i1 `mod` codeRecursiveSize block + in + state{_code = Block (codeInsertAtPoint c1 c2 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} +instructionCodeInsert state = state + +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} + where + -- This is really not gonna be good for StateFunc + positionElem :: [Gene] -> Gene -> Int + positionElem genes gene = + case elemIndex gene genes of + Nothing -> -1 + Just x -> x +instructionCodeFirstPosition state@(State {_code = c1 : c2 : cs, _int = is}) = state {_code = cs, _int = (if c1 == c2 then 0 else -1) : is} +instructionCodeFirstPosition state = state + +instructionCodeReverse :: State -> State +instructionCodeReverse state@(State {_code = (Block c1) : cs}) = state {_code = Block (reverse c1) : cs} +instructionCodeReverse state = state + +instructionCodeDup :: State -> State +instructionCodeDup state = instructionDup state code + +instructionCodeDupN :: State -> State +instructionCodeDupN state = instructionDupN state code + +instructionCodeSwap :: State -> State +instructionCodeSwap state = instructionSwap state code + +instructionCodeRot :: State -> State +instructionCodeRot state = instructionRot state code + +instructionCodeFlush :: State -> State +instructionCodeFlush state = instructionFlush state code + +instructionCodeEq :: State -> State +instructionCodeEq state = instructionEq state code + +instructionCodeStackDepth :: State -> State +instructionCodeStackDepth state = instructionStackDepth state code + +instructionCodeYank :: State -> State +instructionCodeYank state = instructionYank state code + +instructionCodeYankDup :: State -> State +instructionCodeYankDup state = instructionYankDup state code + +instructionCodeStackIsEmpty :: State -> State +instructionCodeStackIsEmpty state = instructionIsEmpty state code + +instructionCodeShove :: State -> State +instructionCodeShove state = instructionShove state code + +instructionCodeShoveDup :: State -> State +instructionCodeShoveDup state = instructionShoveDup state code + +instructionCodeFromBool :: State -> State +instructionCodeFromBool state = instructionCodeFrom state bool GeneBool + +instructionCodeFromInt :: State -> State +instructionCodeFromInt state = instructionCodeFrom state int GeneInt + +instructionCodeFromChar :: State -> State +instructionCodeFromChar state = instructionCodeFrom state char GeneChar + +instructionCodeFromFloat :: State -> State +instructionCodeFromFloat state = instructionCodeFrom state float GeneFloat + +instructionCodeFromString :: State -> State +instructionCodeFromString state = instructionCodeFrom state string GeneString + +instructionCodeFromVectorInt :: State -> State +instructionCodeFromVectorInt state = instructionCodeFrom state vectorInt GeneVectorInt + +instructionCodeFromVectorFloat :: State -> State +instructionCodeFromVectorFloat state = instructionCodeFrom state vectorFloat GeneVectorFloat + +instructionCodeFromVectorString :: State -> State +instructionCodeFromVectorString state = instructionCodeFrom state vectorString GeneVectorString + +instructionCodeFromVectorBool :: State -> State +instructionCodeFromVectorBool state = instructionCodeFrom state vectorBool GeneVectorBool + +instructionCodeFromVectorChar :: State -> State +instructionCodeFromVectorChar state = instructionCodeFrom state vectorChar GeneVectorChar + +instructionCodeFromExec :: State -> State +instructionCodeFromExec state = instructionCodeFrom state exec id diff --git a/src/HushGP/Instructions/ExecInstructions.hs b/src/HushGP/Instructions/ExecInstructions.hs new file mode 100644 index 0000000..4b77aa7 --- /dev/null +++ b/src/HushGP/Instructions/ExecInstructions.hs @@ -0,0 +1,106 @@ +module HushGP.Instructions.ExecInstructions where + +import HushGP.State +import HushGP.Instructions.IntInstructions +import HushGP.Instructions.GenericInstructions + +instructionExecIf :: State -> State +instructionExecIf state@(State {_exec = (e1 : e2 : es), _bool = (b : bs)}) = + if b + then state {_exec = e1 : es, _bool = bs} + else state {_exec = e2 : es, _bool = bs} +instructionExecIf state = state + +instructionExecDup :: State -> State +instructionExecDup state = instructionDup state exec + +instructionExecDupN :: State -> State +instructionExecDupN state = instructionDupN state exec + +instructionExecPop :: State -> State +instructionExecPop state = instructionPop state exec + +instructionExecSwap :: State -> State +instructionExecSwap state = instructionSwap state exec + +instructionExecRot :: State -> State +instructionExecRot state = instructionRot state exec + +instructionExecFlush :: State -> State +instructionExecFlush state = instructionFlush state exec + +instructionExecEq :: State -> State +instructionExecEq state = instructionEq state exec + +instructionExecStackDepth :: State -> State +instructionExecStackDepth state = instructionStackDepth state exec + +instructionExecYank :: State -> State +instructionExecYank state = instructionYank state exec + +instructionExecYankDup :: State -> State +instructionExecYankDup state = instructionYankDup state exec + +instructionExecShove :: State -> State +instructionExecShove state = instructionShove state exec + +instructionExecShoveDup :: State -> State +instructionExecShoveDup state = instructionShoveDup state exec + +instructionExecIsEmpty :: State -> State +instructionExecIsEmpty state = instructionIsEmpty state exec + +execDoRange :: Gene +execDoRange = StateFunc (instructionExecDoRange, "instructionExecDoRange") + +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, execDoRange, e1] : es, _int = i1 : is} + else state {_exec = e1 : es, _int = i1 : is} + where + increment :: Int -> Int -> Int + increment destIdx currentIdx + | currentIdx < destIdx = 1 + | currentIdx > destIdx = -1 + | otherwise = 0 +instructionExecDoRange state = state + +instructionExecDoCount :: State -> State +instructionExecDoCount state@(State {_exec = (e : es), _int = (i : is)}) = + if i < 1 + then state + else state {_exec = Block [GeneInt 0, GeneInt $ i - 1, execDoRange, e] : es, _int = is} +instructionExecDoCount state = state + +instructionExecDoTimes :: State -> State +instructionExecDoTimes state@(State {_exec = (e : es), _int = (i : is)}) = + if i < 1 + then state + else state {_exec = Block [GeneInt 0, GeneInt $ i - 1, execDoRange, Block [StateFunc (instructionIntPop, "instructionIntPop"), e]] : es, _int = is} +instructionExecDoTimes state = state + +execWhile :: Gene +execWhile = StateFunc (instructionExecWhile, "instructionExecWhile") + +instructionExecWhile :: State -> State +instructionExecWhile state@(State {_exec = (_ : es), _bool = []}) = + state {_exec = es} +instructionExecWhile state@(State {_exec = alles@(e : es), _bool = (b : bs)}) = + if b + then state {_exec = e : execWhile : alles, _bool = bs} + else state {_exec = es} +instructionExecWhile state = state + +instructionExecDoWhile :: State -> State +instructionExecDoWhile state@(State {_exec = alles@(e : _)}) = + state {_exec = e : execWhile : alles} +instructionExecDoWhile state = state + +-- Eats the _boolean no matter what +instructionExecWhen :: State -> State +instructionExecWhen state@(State {_exec = (_ : es), _bool = (b : bs)}) = + if not b + then state {_exec = es, _bool = bs} + else state {_bool = bs} +instructionExecWhen state = state diff --git a/src/HushGP/Instructions/FloatInstructions.hs b/src/HushGP/Instructions/FloatInstructions.hs new file mode 100644 index 0000000..a9eb409 --- /dev/null +++ b/src/HushGP/Instructions/FloatInstructions.hs @@ -0,0 +1,116 @@ +module HushGP.Instructions.FloatInstructions where + +import Data.Fixed (mod') +import HushGP.Instructions.GenericInstructions +import HushGP.State + +instructionFloatFromInt :: State -> State +instructionFloatFromInt state@(State {_float = fs, _int = (i : is)}) = state {_float = (fromIntegral i :: Float) : fs, _int = is} +instructionFloatFromInt state = state + +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 + +instructionFloatAdd :: State -> State +instructionFloatAdd state@(State {_float = (f1 : f2 : fs)}) = state {_float = f2 + f1 : fs} +instructionFloatAdd state = state + +instructionFloatSub :: State -> State +instructionFloatSub state@(State {_float = (f1 : f2 : fs)}) = state {_float = f2 - f1 : fs} +instructionFloatSub state = state + +instructionFloatMul :: State -> State +instructionFloatMul state@(State {_float = (f1 : f2 : fs)}) = state {_float = f2 * f1 : fs} +instructionFloatMul state = state + +instructionFloatDiv :: State -> State +instructionFloatDiv state@(State {_float = (f1 : f2 : fs)}) = state {_float = if f1 /= 0 then f2 / f1 : fs else f1 : f2 : fs} +instructionFloatDiv state = state + +instructionFloatMod :: State -> State +instructionFloatMod state@(State {_float = (f1 : f2 : fs)}) = state {_float = if f1 /= 0 then f2 `mod'` f1 : fs else f1 : f2 : fs} +instructionFloatMod state = state + +instructionFloatMin :: State -> State +instructionFloatMin state@(State {_float = (f1 : f2 : fs)}) = state {_float = min f1 f2 : fs} +instructionFloatMin state = state + +instructionFloatMax :: State -> State +instructionFloatMax state@(State {_float = (f1 : f2 : fs)}) = state {_float = max f1 f2 : fs} +instructionFloatMax state = state + +instructionFloatInc :: State -> State +instructionFloatInc state@(State {_float = (f1 : fs)}) = state {_float = f1 + 1 : fs} +instructionFloatInc state = state + +instructionFloatDec :: State -> State +instructionFloatDec state@(State {_float = (f1 : fs)}) = state {_float = f1 - 1 : fs} +instructionFloatDec state = state + +instructionFloatLT :: State -> State +instructionFloatLT state@(State {_float = f1 : f2 : fs, _bool = bs}) = state {_float = fs, _bool = (f1 < f2) : bs} +instructionFloatLT state = state + +instructionFloatGT :: State -> State +instructionFloatGT state@(State {_float = f1 : f2 : fs, _bool = bs}) = state {_float = fs, _bool = (f1 > f2) : bs} +instructionFloatGT state = state + +instructionFloatLTE :: State -> State +instructionFloatLTE state@(State {_float = f1 : f2 : fs, _bool = bs}) = state {_float = fs, _bool = (f1 <= f2) : bs} +instructionFloatLTE state = state + +instructionFloatGTE :: State -> State +instructionFloatGTE state@(State {_float = f1 : f2 : fs, _bool = bs}) = state {_float = fs, _bool = (f1 >= f2) : bs} +instructionFloatGTE state = state + +instructionFloatPop :: State -> State +instructionFloatPop state = instructionPop state float + +instructionFloatDup :: State -> State +instructionFloatDup state = instructionDup state float + +instructionFloatDupN :: State -> State +instructionFloatDupN state = instructionDupN state float + +instructionFloatSwap :: State -> State +instructionFloatSwap state = instructionSwap state float + +instructionFloatRot :: State -> State +instructionFloatRot state = instructionRot state float + +instructionFloatFlush :: State -> State +instructionFloatFlush state = instructionFlush state float + +instructionFloatEq :: State -> State +instructionFloatEq state = instructionEq state float + +instructionFloatStackDepth :: State -> State +instructionFloatStackDepth state = instructionStackDepth state float + +instructionFloatYankDup :: State -> State +instructionFloatYankDup state = instructionYankDup state float + +instructionFloatYank :: State -> State +instructionFloatYank state = instructionYank state float + +instructionFloatShoveDup :: State -> State +instructionFloatShoveDup state = instructionShoveDup state float + +instructionFloatShove :: State -> State +instructionFloatShove state = instructionShove state float + +instructionFloatIsEmpty :: State -> State +instructionFloatIsEmpty state = instructionIsEmpty state float + +instructionFloatSin :: State -> State +instructionFloatSin state@(State {_float = f1 : fs}) = state {_float = sin f1 : fs} +instructionFloatSin state = state + +instructionFloatCos :: State -> State +instructionFloatCos state@(State {_float = f1 : fs}) = state {_float = cos f1 : fs} +instructionFloatCos state = state + +instructionFloatTan :: State -> State +instructionFloatTan state@(State {_float = f1 : fs}) = state {_float = tan f1 : fs} +instructionFloatTan state = state diff --git a/src/HushGP/Instructions/GenericInstructions.hs b/src/HushGP/Instructions/GenericInstructions.hs new file mode 100644 index 0000000..8c474ef --- /dev/null +++ b/src/HushGP/Instructions/GenericInstructions.hs @@ -0,0 +1,348 @@ +module HushGP.Instructions.GenericInstructions where + +import Control.Lens +import HushGP.State + +-- import Debug.Trace + +deleteAt :: Int -> [a] -> [a] +deleteAt idx xs = take idx xs <> drop 1 (drop idx xs) + +-- I could probably just combine these functions +combineTuple :: a -> ([a], [a]) -> [a] +combineTuple val tup = fst tup <> [val] <> snd tup + +combineTupleList :: [a] -> ([a], [a]) -> [a] +combineTupleList val tup = fst tup <> val <> snd tup + +insertAt :: Int -> a -> [a] -> [a] +insertAt idx val xs = combineTuple val (splitAt idx xs) + +replaceAt :: Int -> a -> [a] -> [a] +replaceAt idx val xs = deleteAt (idx + 1) (insertAt idx val xs) + +subList :: Int -> Int -> [a] -> [a] +subList idx0 idx1 xs = + let + (start, end) = if idx0 <= idx1 then (idx0, idx1) else (idx1, idx0) + adjStart = max 0 start + adjEnd = min end (length xs) + in + take adjEnd (drop adjStart xs) + +-- Maybe could've used Data.List.isSubsequenceOf :shrug: +findSubA :: forall a. Eq a => [a] -> [a] -> Int +findSubA fullA subA + | length fullA < length subA = -1 + | length fullA == length subA = if fullA == subA then 0 else -1 + | otherwise = findSubA' fullA subA 0 + where + findSubA' :: [a] -> [a] -> Int -> Int + findSubA' fA sA subIndex + | null fA = -1 + | length sA > length fA = -1 + | sA == take (length sA) fA = subIndex + | otherwise = findSubA' (drop 1 fA) sA (subIndex + 1) + +-- The int is the amount of olds to replace with new +-- Just chain findSubA calls lol +-- Nothing means replace all +-- May not be the most efficient method with the findSubA calls +replace :: Eq a => [a] -> [a] -> [a] -> Maybe Int -> [a] +replace fullA old new (Just amt) = + if findSubA fullA old /= -1 && amt > 0 + then replace (take (findSubA fullA old) fullA <> new <> drop (findSubA fullA old + length old) fullA) old new (Just $ amt - 1) + else fullA +replace fullA old new Nothing = + if findSubA fullA old /= -1 + then replace (take (findSubA fullA old) fullA <> new <> drop (findSubA fullA old + length old) fullA) old new Nothing + else fullA + +-- a rather inefficient search +amtOccurences :: forall a. Eq a => [a] -> [a] -> Int +amtOccurences fullA subA = amtOccurences' fullA subA 0 + where + amtOccurences' :: [a] -> [a] -> Int -> Int + amtOccurences' fA sA count = + if findSubA fA sA /= -1 + then amtOccurences' (replace fA sA mempty (Just 1)) sA (count + 1) + else count + +takeR :: Int -> [a] -> [a] +takeR amt fullA = drop (length fullA - amt) fullA + +dropR :: Int -> [a] -> [a] +dropR amt fullA = take (length fullA - amt) fullA + +safeInit :: [a] -> [a] +safeInit [] = [] +safeInit xs = init xs + +absNum :: Integral a => a -> [b] -> Int +absNum rawNum lst = abs (fromIntegral rawNum) `mod` length lst + +notEmptyStack :: State -> Lens' State [a] -> Bool +notEmptyStack state accessor = not . null $ view accessor state + +instructionDup :: State -> Lens' State [a] -> State +instructionDup state accessor = + case uncons (view accessor state) of + Nothing -> state + Just (x,_) -> state & accessor .~ x : view accessor state + +instructionPop :: State -> Lens' State [a] -> State +instructionPop state accessor = state & accessor .~ drop 1 (view accessor state) + +instructionIsEmpty :: State -> Lens' State [a] -> State +instructionIsEmpty state@(State {_bool = bs}) accessor = state{_bool = null (view accessor state) : bs} + +-- instructionPop :: State -> Lens' State [a] -> State +-- instructionPop state accessor = if notEmptyStack state accessor then instructionPop state accessor else state + +-- 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 state accessor = + case uncons (view int state) of + Just (i1,is) -> + case uncons (view accessor state{_int = is}) of + Just (a1,as) -> + instructionDupNHelper i1 a1 accessor (state{_int = is} & accessor .~ as) + _ -> state + _ -> state + where + instructionDupNHelper :: Int -> 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)) + else internalState + +instructionSwap :: State -> Lens' State [a] -> State +instructionSwap state accessor = + state & accessor .~ swapper (view accessor state) + where + swapper :: [a] -> [a] + swapper (x1 : x2 : xs) = x2 : x1 : xs + swapper xs = xs + +-- Rotates top 3 integers +-- We could use template haskell to rotate any number of these as +-- an instruction later. Template haskell seems very complicated tho. +instructionRot :: State -> Lens' State [a] -> State +instructionRot state accessor = + state & accessor .~ rotator (view accessor state) + where + rotator :: [a] -> [a] + rotator (x1 : x2 : x3 : xs) = x3 : x1 : x2 : xs + rotator xs = xs + +instructionFlush :: State -> Lens' State [a] -> State +instructionFlush state accessor = state & accessor .~ [] + +instructionEq :: forall a. Eq a => State -> Lens' State [a] -> State +instructionEq state accessor = + case uncons $ view accessor state of + Nothing -> state + Just (x1, x2 : _) -> droppedState & bool .~ (x1 == x2) : view bool droppedState + Just _ -> state + where + droppedState :: State + droppedState = state & accessor .~ drop 2 (view accessor state) + +instructionStackDepth :: State -> Lens' State [a] -> State +instructionStackDepth state@(State {_int = is}) accessor = state{_int = length (view accessor state) : is} + +instructionYankDup :: State -> Lens' State [a] -> State +instructionYankDup state@(State {_int = i : is}) accessor = + if notEmptyStack state accessor + then state{_int = is} & accessor .~ (view accessor state{_int = is} !! max 0 (min i (length (view accessor state{_int = is}) - 1))) : view accessor state{_int = is} + else state +instructionYankDup state _ = state + +instructionYank :: forall a. State -> Lens' State [a] -> State +instructionYank state@(State {_int = i : is}) accessor = + let + myIndex :: Int + myIndex = max 0 (min i (length (view accessor state{_int = is}) - 1)) + item :: a + item = view accessor state{_int = is} !! myIndex + deletedState :: State + deletedState = state{_int = is} & accessor .~ deleteAt myIndex (view accessor state{_int = is}) + in + if notEmptyStack state{_int = is} accessor then deletedState & accessor .~ item : view accessor deletedState else state +instructionYank state _ = state + +-- In pysh, instructionShoveDup and instructionShove behave differently when indexing in such a way that +-- the duplicated index matters whether or not it's present in the stack at the moment of calculation. +-- I'm not going to keep this behavior. Check out interpysh examples for how pysh handles it. +instructionShoveDup :: State -> Lens' State [a] -> State +instructionShoveDup state@(State {_int = i : is}) accessor = + case uncons (view accessor state{_int = is}) of + Just (x,_) -> state{_int = is} & accessor .~ combineTuple x (splitAt (max 0 (min i (length (view accessor state{_int = is}) - 1))) (view accessor state{_int = is})) + _ -> state +instructionShoveDup state _ = state + +instructionShove :: State -> Lens' State [a] -> State +instructionShove state accessor = instructionShoveDup state accessor & accessor .~ drop 1 (view accessor (instructionShoveDup state accessor)) + +-- not char generic +instructionConcat :: Semigroup a => State -> Lens' State [a] -> State +instructionConcat state accessor = + case uncons (view accessor state) of + Just (x1, x2:_) -> droppedState & accessor .~ (x1 <> x2) : view accessor droppedState + _ -> state + where + droppedState :: State + droppedState = state & accessor .~ drop 2 (view accessor state) + +-- evolve fodder??????????? +instructionNoOp :: State -> State +instructionNoOp state = state + +instructionConj :: State -> Lens' State [a] -> Lens' State [[a]] -> State +instructionConj state primAccessor vectorAccessor = + case (uncons (view primAccessor state), uncons (view vectorAccessor state)) of + (Just (p1,ps), Just (v1,vs)) -> state & primAccessor .~ ps & vectorAccessor .~ ((p1 : v1) : 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 +instructionTakeN state@(State {_int = i1 : is}) accessor = + case uncons (view accessor state) of + Just (v1, vs) -> state{_int = is} & accessor .~ (take (absNum i1 v1) v1 : vs) + _ -> state +instructionTakeN state _ = state + +instructionSubVector :: State -> Lens' State [[a]] -> State +instructionSubVector state@(State {_int = i1 : i2 : is}) accessor = + case uncons (view accessor state) of + Just (v1, vs) -> state{_int = is} & accessor .~ (subList i1 i2 v1 : vs) + _ -> state +instructionSubVector state _ = state + +instructionVectorFirst :: State -> Lens' State [a] -> Lens' State [[a]] -> State +instructionVectorFirst state primAccessor vectorAccessor = + case uncons (view vectorAccessor state) of + Just (v1, vs) -> + case uncons v1 of + Just (vp1, _) -> state & primAccessor .~ (vp1 : view primAccessor state) & vectorAccessor .~ vs + _ -> state + _ -> state + +instructionVectorLast :: State -> Lens' State [a] -> Lens' State [[a]] -> State +instructionVectorLast state primAccessor vectorAccessor = + case uncons (view vectorAccessor state) of + Just (v1, vs) -> + case uncons (drop (length v1 - 1) v1) of -- gonna keep this implementation over using last as this can't error + Just (vplast, _) -> state & primAccessor .~ (vplast : view primAccessor state) & vectorAccessor .~ vs + _ -> state + _ -> state + +instructionVectorNth :: State -> Lens' State [a] -> Lens' State [[a]] -> State +instructionVectorNth state@(State {_int = i1 : is}) primAccessor vectorAccessor = + case uncons (view vectorAccessor state) of + Just (v1, vs) -> state{_int = is} & primAccessor .~ (v1 !! absNum i1 v1 : view primAccessor state{_int = is}) & vectorAccessor .~ vs + _ -> state +instructionVectorNth state _ _ = state + +instructionRest :: State -> Lens' State [[a]] -> State +instructionRest state accessor = + case uncons (view accessor state) of + Just (v1, vs) -> state & accessor .~ (drop 1 v1 : vs) + _ -> state + +instructionButLast :: State -> Lens' State [[a]] -> State +instructionButLast state accessor = + case uncons (view accessor state) of + Just (v1, vs) -> state & accessor .~ (safeInit v1 : vs) + _ -> state + +instructionLength :: State -> Lens' State [[a]] -> State +instructionLength state@(State {_int = is}) accessor = + case uncons (view accessor state) of + Just (v1, vs) -> state{_int = length v1 : is} & accessor .~ vs + _ -> state + +instructionReverse :: State -> Lens' State [[a]] -> State +instructionReverse state accessor = + case uncons (view accessor state) of + Just (v1, vs) -> state & accessor .~ (reverse v1 : vs) + _ -> state + +instructionPushAll :: State -> Lens' State [a] -> Lens' State [[a]] -> State +instructionPushAll state primAccessor vectorAccessor = + case uncons (view vectorAccessor state) of + Just (v1, vs) -> state & vectorAccessor .~ vs & primAccessor .~ (v1 <> view primAccessor state) + _ -> state + +instructionVectorMakeEmpty :: State -> Lens' State [[a]] -> State +instructionVectorMakeEmpty state accessor = state & accessor .~ ([] : view accessor state) + +instructionVectorIsEmpty :: State -> Lens' State [[a]] -> State +instructionVectorIsEmpty state@(State {_bool = bs}) accessor = + case uncons (view accessor state) of + Just (v1, vs) -> state{_bool = null v1 : bs} & accessor .~ vs + _ -> state + +instructionVectorContains :: Eq a => State -> Lens' State [a] -> Lens' State [[a]] -> State +instructionVectorContains state@(State {_bool = bs}) primAccessor vectorAccessor = + case (uncons (view vectorAccessor state), uncons (view primAccessor state)) of + (Just (v1, vs), Just (p1, ps)) -> state{_bool = (findSubA v1 [p1] /= -1) : bs} & vectorAccessor .~ vs & primAccessor .~ ps + _ -> state + +-- I couldn't think of a better way of doing this +instructionVectorIndexOf :: Eq a => State -> Lens' State [a] -> Lens' State [[a]] -> State +instructionVectorIndexOf state primAccessor vectorAccessor = + 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)) + _ -> state + +instructionVectorOccurrencesOf :: Eq a => State -> Lens' State [a] -> Lens' State [[a]] -> State +instructionVectorOccurrencesOf state primAccessor vectorAccessor = + 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)) + _ -> 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 + (Just (v1, vs), Just (p1, ps)) -> state{_int = is} & vectorAccessor .~ (replaceAt (absNum i1 v1) p1 v1 : vs) & primAccessor .~ ps + _ -> state +instructionVectorSetNth state _ _ = state + +instructionVectorReplace :: Eq a => State -> Lens' State [a] -> Lens' State [[a]] -> State +instructionVectorReplace state primAccessor vectorAccessor = + case (uncons (view vectorAccessor state), uncons (view primAccessor state)) of + (Just (v1, vs), Just (p1, p2 : ps)) -> state & vectorAccessor .~ (replace v1 [p1] [p2] Nothing : vs) & primAccessor .~ ps + _ -> state + +instructionVectorReplaceFirst :: Eq a => State -> Lens' State [a] -> Lens' State [[a]] -> State +instructionVectorReplaceFirst state primAccessor vectorAccessor = + case (uncons (view vectorAccessor state), uncons (view primAccessor state)) of + (Just (v1, vs), Just (p1, p2 : ps)) -> state & vectorAccessor .~ (replace v1 [p1] [p2] (Just 1) : vs) & primAccessor .~ ps + _ -> state + +instructionVectorRemove :: Eq a => State -> Lens' State [a] -> Lens' State [[a]] -> State +instructionVectorRemove state primAccessor vectorAccessor = + case (uncons (view vectorAccessor state), uncons (view primAccessor state)) of + (Just (v1, vs), Just (p1, ps)) -> state & vectorAccessor .~ (replace v1 [p1] [] Nothing : vs) & primAccessor .~ ps + _ -> state + +instructionVectorIterate :: State -> Lens' State [a] -> Lens' State [[a]] -> ([a] -> Gene) -> (State -> State) -> String -> State +instructionVectorIterate state@(State {_exec = e1 : es}) primAccessor vectorAccessor vectorType typeIterateFunction typeIterateFunctionName = + case uncons (view vectorAccessor state) of + Just ([], vs) -> state{_exec = es} & vectorAccessor .~ vs + Just ([x], vs) -> state & primAccessor .~ (x : view primAccessor state) & vectorAccessor .~ vs + Just (v1, vs) -> + (case uncons v1 of + Just (nv1, nvs) -> state{_exec = e1 : vectorType nvs : StateFunc (typeIterateFunction, typeIterateFunctionName) : e1 : es} & primAccessor .~ (nv1 : view primAccessor state) & vectorAccessor .~ vs + _ -> state) -- This should never happen + _ -> state +instructionVectorIterate state _ _ _ _ _ = state + +instructionCodeFrom :: State -> Lens' State [a] -> (a -> Gene) -> State +instructionCodeFrom state@(State {_code = cs}) accessor geneType = + case uncons (view accessor state) of + Just (x, xs) -> state{_code = geneType x : cs} & accessor .~ xs + _ -> state diff --git a/src/HushGP/Instructions/IntInstructions.hs b/src/HushGP/Instructions/IntInstructions.hs new file mode 100644 index 0000000..55a3180 --- /dev/null +++ b/src/HushGP/Instructions/IntInstructions.hs @@ -0,0 +1,104 @@ +module HushGP.Instructions.IntInstructions where + +import HushGP.State +import HushGP.Instructions.GenericInstructions +-- import Debug.Trace + +instructionIntFromFloat :: State -> State +instructionIntFromFloat state@(State {_float = (f : fs), _int = is}) = state {_float = fs, _int = floor f : is} +instructionIntFromFloat state = state + +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 + +instructionIntAdd :: State -> State +instructionIntAdd state@(State {_int = (i1 : i2 : is)}) = state {_int = i2 + i1 : is} +instructionIntAdd state = state + +instructionIntSub :: State -> State +instructionIntSub state@(State {_int = (i1 : i2 : is)}) = state {_int = i2 - i1 : is} +instructionIntSub state = state + +instructionIntMul :: State -> State +instructionIntMul state@(State {_int = (i1 : i2 : is)}) = state {_int = i2 * i1 : is} +instructionIntMul state = state + +instructionIntDiv :: State -> State +instructionIntDiv state@(State {_int = (i1 : i2 : is)}) = state {_int = if i1 /= 0 then (i2 `div` i1) : is else i1 : i2 : is} +instructionIntDiv state = state + +instructionIntMod :: State -> State +instructionIntMod state@(State {_int = (i1 : i2 : is)}) = state {_int = if i1 /= 0 then (i2 `mod` i1) : is else i1 : i2 : is} +instructionIntMod state = state + +instructionIntMin :: State -> State +instructionIntMin state@(State {_int = (i1 : i2 : is)}) = state {_int = min i1 i2 : is} +instructionIntMin state = state + +instructionIntMax :: State -> State +instructionIntMax state@(State {_int = (i1 : i2 : is)}) = state {_int = max i1 i2 : is} +instructionIntMax state = state + +instructionIntInc :: State -> State +instructionIntInc state@(State {_int = (i1 : is)}) = state {_int = i1 + 1 : is} +instructionIntInc state = state + +instructionIntDec :: State -> State +instructionIntDec state@(State {_int = (i1 : is)}) = state {_int = i1 - 1 : is} +instructionIntDec state = state + +instructionIntLT :: State -> State +instructionIntLT state@(State {_int = i1 : i2 : is, _bool = bs}) = state {_int = is, _bool = (i1 < i2) : bs} +instructionIntLT state = state + +instructionIntGT :: State -> State +instructionIntGT state@(State {_int = i1 : i2 : is, _bool = bs}) = state {_int = is, _bool = (i1 > i2) : bs} +instructionIntGT state = state + +instructionIntLTE :: State -> State +instructionIntLTE state@(State {_int = i1 : i2 : is, _bool = bs}) = state {_int = is, _bool = (i1 <= i2) : bs} +instructionIntLTE state = state + +instructionIntGTE :: State -> State +instructionIntGTE state@(State {_int = i1 : i2 : is, _bool = bs}) = state {_int = is, _bool = (i1 >= i2) : bs} +instructionIntGTE state = state + +instructionIntDup :: State -> State +instructionIntDup state = instructionDup state int + +instructionIntPop :: State -> State +instructionIntPop state = instructionPop state int + +instructionIntDupN :: State -> State +instructionIntDupN state = instructionDupN state int + +instructionIntSwap :: State -> State +instructionIntSwap state = instructionSwap state int + +instructionIntRot :: State -> State +instructionIntRot state = instructionRot state int + +instructionIntFlush :: State -> State +instructionIntFlush state = instructionFlush state int + +instructionIntEq :: State -> State +instructionIntEq state = instructionEq state int + +instructionIntStackDepth :: State -> State +instructionIntStackDepth state = instructionStackDepth state int + +instructionIntYank :: State -> State +instructionIntYank state = instructionYank state int + +instructionIntYankDup :: State -> State +instructionIntYankDup state = instructionYankDup state int + +instructionIntShove :: State -> State +instructionIntShove state = instructionShove state int + +instructionIntShoveDup :: State -> State +instructionIntShoveDup state = instructionShoveDup state int + +instructionIntIsEmpty :: State -> State +instructionIntIsEmpty state = instructionIsEmpty state int diff --git a/src/HushGP/Instructions/StringInstructions.hs b/src/HushGP/Instructions/StringInstructions.hs new file mode 100644 index 0000000..d893027 --- /dev/null +++ b/src/HushGP/Instructions/StringInstructions.hs @@ -0,0 +1,231 @@ +module HushGP.Instructions.StringInstructions where + +import HushGP.State +import HushGP.Instructions.GenericInstructions +import Data.List.Split +import Control.Lens + +-- shamelessly stolen from https://hackage.haskell.org/package/MissingH-1.6.0.1/docs/src/Data.String.Utils.html#strip +wschars :: String +wschars = " \t\r\n" + +strip :: String -> String +strip = lstrip . rstrip + +lstrip :: String -> String +lstrip s = case s of + [] -> [] + (x:xs) -> if x `elem` wschars + then lstrip xs + else s + +-- this is a tad inefficient init +rstrip :: String -> String +rstrip = reverse . lstrip . reverse + +instructionStringConcat :: State -> State +instructionStringConcat state = instructionConcat state string + +instructionStringSwap :: State -> State +instructionStringSwap state = instructionSwap state string + +instructionStringInsertString :: State -> State +instructionStringInsertString state@(State{_string = s1 : s2 : ss, _int = i1 : is}) = state {_string = combineTupleList s2 (splitAt i1 s1) : ss, _int = is} +instructionStringInsertString state = state + +instructionStringFromFirstChar :: State -> State +instructionStringFromFirstChar state@(State {_string = (schar : _) : ss}) = state {_string = [schar] : ss} +instructionStringFromFirstChar state = state + +instructionStringFromLastChar :: State -> State +instructionStringFromLastChar state@(State {_string = s1 : ss}) = + if not $ null s1 + then state {_string = [last s1] : ss} + else state +instructionStringFromLastChar state = state + +instructionStringFromNthChar :: State -> State +instructionStringFromNthChar state@(State {_string = s1 : ss, _int = i1 : is}) = state{_string = [s1 !! absNum i1 s1] : ss, _int = is} +instructionStringFromNthChar state = state + +instructionStringIndexOfString :: State -> State +instructionStringIndexOfString state@(State {_string = s1 : s2 : ss, _int = is}) = state {_string = ss, _int = findSubA s1 s2 : is} +instructionStringIndexOfString state = state + +instructionStringContainsString :: State -> State +instructionStringContainsString state@(State {_string = s1 : s2 : ss, _bool = bs}) = state {_string = ss, _bool = (findSubA s1 s2 /= -1) : bs} +instructionStringContainsString state = state + +-- pysh reverses this. Check this for propeller +instructionStringSplitOnString :: State -> State +instructionStringSplitOnString state@(State {_string = s1 : s2 : ss}) = state {_string = reverse $ splitOn s2 s1 <> ss} +instructionStringSplitOnString state = state + +instructionStringReplaceFirstString :: State -> State +instructionStringReplaceFirstString state@(State {_string = s1 : s2 : s3 : ss}) = state {_string = replace s1 s2 s3 (Just 1) : ss} +instructionStringReplaceFirstString state = state + +instructionStringReplaceNString :: State -> State +instructionStringReplaceNString state@(State {_string = s1 : s2 : s3 : ss, _int = i1 : is}) = state{_string = replace s1 s2 s3 (Just i1) : ss, _int = is} +instructionStringReplaceNString state = state + +instructionStringReplaceAllString :: State -> State +instructionStringReplaceAllString state@(State {_string = s1 : s2 : s3 : ss}) = state{_string = replace s1 s2 s3 Nothing : ss} +instructionStringReplaceAllString state = state + +instructionStringRemoveFirstString :: State -> State +instructionStringRemoveFirstString state@(State {_string = s1 : s2 : ss}) = state{_string = replace s1 s2 "" (Just 1) : ss} +instructionStringRemoveFirstString state = state + +instructionStringRemoveNString :: State -> State +instructionStringRemoveNString state@(State {_string = s1 : s2 : ss, _int = i1 : is}) = state{_string = replace s1 s2 "" (Just i1) : ss, _int = is} +instructionStringRemoveNString state = state + +instructionStringRemoveAllString :: State -> State +instructionStringRemoveAllString state@(State {_string = s1 : s2 : ss}) = state{_string = replace s1 s2 "" Nothing : ss} +instructionStringRemoveAllString state = state + +instructionStringOccurrencesOfString :: State -> State +instructionStringOccurrencesOfString state@(State {_string = s1 : s2 : ss, _int = is}) = state{_string = ss, _int = amtOccurences s1 s2 : is} +instructionStringOccurrencesOfString state = state + +instructionStringInsertChar :: State -> State +instructionStringInsertChar state@(State {_string = s1 : ss, _char = c1 : cs, _int = i1 : is}) = state{_string = combineTuple c1 (splitAt i1 s1) : ss, _char = cs, _int = is} +instructionStringInsertChar state = state + +instructionStringContainsChar :: State -> State +instructionStringContainsChar state = instructionVectorContains state char string + +instructionStringIndexOfChar :: State -> State +instructionStringIndexOfChar state = instructionVectorIndexOf state char string + +instructionStringSplitOnChar :: State -> State +instructionStringSplitOnChar state@(State {_string = s1 : ss, _char = c1 : cs}) = state {_string = reverse $ splitOn [c1] s1 <> ss, _char = cs} +instructionStringSplitOnChar state = state + +instructionStringReplaceFirstChar :: State -> State +instructionStringReplaceFirstChar state = instructionVectorReplaceFirst state char string + +instructionStringReplaceNChar :: State -> State +instructionStringReplaceNChar state@(State {_string = s1 : ss, _char = c1 : c2 : cs, _int = i1 : is}) = state{_string = replace s1 [c1] [c2] (Just i1) : ss, _char = cs, _int = is} +instructionStringReplaceNChar state = state + +instructionStringReplaceAllChar :: State -> State +instructionStringReplaceAllChar state = instructionVectorReplace state char string + +instructionStringRemoveFirstChar :: State -> State +instructionStringRemoveFirstChar state@(State {_string = s1 : ss, _char = c1 : cs}) = state {_string = replace s1 [c1] "" (Just 1) : ss, _char = cs} +instructionStringRemoveFirstChar state = state + +instructionStringRemoveNChar :: State -> State +instructionStringRemoveNChar state@(State {_string = s1 : ss, _char = c1 : cs, _int = i1 : is}) = state{_string = replace s1 [c1] "" (Just i1) : ss, _char = cs, _int = is} +instructionStringRemoveNChar state = state + +instructionStringRemoveAllChar :: State -> State +instructionStringRemoveAllChar state = instructionVectorRemove state char string + +instructionStringOccurrencesOfChar :: State -> State +instructionStringOccurrencesOfChar state = instructionVectorOccurrencesOf state char string + +instructionStringReverse :: State -> State +instructionStringReverse state = instructionReverse state string + +instructionStringHead :: State -> State +instructionStringHead state = instructionTakeN state string + +instructionStringTail :: State -> State +instructionStringTail state@(State {_string = s1 : ss, _int = i1 : is}) = state{_string = takeR (absNum i1 s1) s1 : ss, _int = is} +instructionStringTail state = state + +instructionStringAppendChar :: State -> State +instructionStringAppendChar state = instructionConj state char string + +instructionStringRest :: State -> State +instructionStringRest state = instructionRest state string + +instructionStringButLast :: State -> State +instructionStringButLast state = instructionButLast state string + +instructionStringDrop :: State -> State +instructionStringDrop state@(State {_string = s1 : ss, _int = i1 : is}) = state{_string = drop (absNum i1 s1) s1 : ss, _int = is} +instructionStringDrop state = state + +instructionStringButLastN :: State -> State +instructionStringButLastN state@(State {_string = s1 : ss, _int = i1 : is}) = state{_string = dropR (absNum i1 s1) s1 : ss, _int = is} +instructionStringButLastN state = state + +instructionStringLength :: State -> State +instructionStringLength state = instructionLength state string + +instructionStringMakeEmpty :: State -> State +instructionStringMakeEmpty state = instructionVectorMakeEmpty state string + +instructionStringIsEmptyString :: State -> State +instructionStringIsEmptyString state@(State {_string = s1 : ss, _bool = bs}) = state{_string = ss, _bool = null s1 : bs} +instructionStringIsEmptyString state = state + +instructionStringRemoveNth :: State -> State +instructionStringRemoveNth state@(State {_string = s1 : ss, _int = i1 : is}) = state{_string = deleteAt (absNum i1 s1) s1 : ss, _int = is} +instructionStringRemoveNth state = state + +instructionStringSetNth :: State -> State +instructionStringSetNth state = instructionVectorSetNth state char string + +instructionStringStripWhitespace :: State -> State +instructionStringStripWhitespace state@(State {_string = s1 : ss}) = state{_string = strip s1 : ss} +instructionStringStripWhitespace state = state + +instructionStringFromLens :: Show a => State -> Lens' State [a] -> State +instructionStringFromLens state@(State {_string = ss}) accessor = + case uncons (view accessor state) of + Nothing -> state + Just (x,_) -> state{_string = show x : ss} + +instructionStringFromBool :: State -> State +instructionStringFromBool state = instructionStringFromLens state bool + +instructionStringFromInt :: State -> State +instructionStringFromInt state = instructionStringFromLens state int + +instructionStringFromFloat :: State -> State +instructionStringFromFloat state = instructionStringFromLens state float + +instructionStringFromChar :: State -> State +instructionStringFromChar state@(State {_string = ss, _char = c1 : cs}) = state{_string = [c1] : ss, _char = cs} +instructionStringFromChar state = state + +instructionStringPop :: State -> State +instructionStringPop state = instructionPop state string + +instructionStringDup :: State -> State +instructionStringDup state = instructionDup state string + +instructionStringDupN :: State -> State +instructionStringDupN state = instructionDupN state string + +instructionStringRot :: State -> State +instructionStringRot state = instructionRot state string + +instructionStringFlush :: State -> State +instructionStringFlush state = instructionFlush state string + +instructionStringEq :: State -> State +instructionStringEq state = instructionEq state string + +instructionStringStackDepth :: State -> State +instructionStringStackDepth state = instructionStackDepth state string + +instructionStringYank :: State -> State +instructionStringYank state = instructionYank state string + +instructionStringYankDup :: State -> State +instructionStringYankDup state = instructionYankDup state string + +instructionStringIsEmpty :: State -> State +instructionStringIsEmpty state = instructionIsEmpty state string + +instructionStringShove :: State -> State +instructionStringShove state = instructionShove state string + +instructionStringShoveDup :: State -> State +instructionStringShoveDup state = instructionShoveDup state string diff --git a/src/HushGP/Instructions/VectorBoolInstructions.hs b/src/HushGP/Instructions/VectorBoolInstructions.hs new file mode 100644 index 0000000..6f226c1 --- /dev/null +++ b/src/HushGP/Instructions/VectorBoolInstructions.hs @@ -0,0 +1,106 @@ +module HushGP.Instructions.VectorBoolInstructions where + +import HushGP.State +import HushGP.Instructions.GenericInstructions + +instructionVectorBoolConcat :: State -> State +instructionVectorBoolConcat state = instructionConcat state vectorBool + +instructionVectorBoolConj :: State -> State +instructionVectorBoolConj state = instructionConj state bool vectorBool + +instructionVectorBoolTakeN :: State -> State +instructionVectorBoolTakeN state = instructionTakeN state vectorBool + +instructionVectorBoolSubVector :: State -> State +instructionVectorBoolSubVector state = instructionSubVector state vectorBool + +instructionVectorBoolFirst :: State -> State +instructionVectorBoolFirst state = instructionVectorFirst state bool vectorBool + +instructionVectorBoolLast :: State -> State +instructionVectorBoolLast state = instructionVectorLast state bool vectorBool + +instructionVectorBoolNth :: State -> State +instructionVectorBoolNth state = instructionVectorNth state bool vectorBool + +instructionVectorBoolRest :: State -> State +instructionVectorBoolRest state = instructionRest state vectorBool + +instructionVectorBoolButLast :: State -> State +instructionVectorBoolButLast state = instructionButLast state vectorBool + +instructionVectorBoolLength :: State -> State +instructionVectorBoolLength state = instructionLength state vectorBool + +instructionVectorBoolReverse :: State -> State +instructionVectorBoolReverse state = instructionReverse state vectorBool + +instructionVectorBoolPushAll :: State -> State +instructionVectorBoolPushAll state = instructionPushAll state bool vectorBool + +instructionVectorBoolMakeEmpty :: State -> State +instructionVectorBoolMakeEmpty state = instructionVectorMakeEmpty state vectorBool + +instructionVectorBoolIsEmpty :: State -> State +instructionVectorBoolIsEmpty state = instructionVectorIsEmpty state vectorBool + +instructionVectorBoolIndexOf :: State -> State +instructionVectorBoolIndexOf state = instructionVectorIndexOf state bool vectorBool + +instructionVectorBoolOccurrencesOf :: State -> State +instructionVectorBoolOccurrencesOf state = instructionVectorOccurrencesOf state bool vectorBool + +instructionVectorBoolSetNth :: State -> State +instructionVectorBoolSetNth state = instructionVectorSetNth state bool vectorBool + +instructionVectorBoolReplace :: State -> State +instructionVectorBoolReplace state = instructionVectorReplace state bool vectorBool + +instructionVectorBoolReplaceFirst :: State -> State +instructionVectorBoolReplaceFirst state = instructionVectorReplaceFirst state bool vectorBool + +instructionVectorBoolRemove :: State -> State +instructionVectorBoolRemove state = instructionVectorRemove state bool vectorBool + +instructionVectorBoolIterate :: State -> State +instructionVectorBoolIterate state = instructionVectorIterate state bool vectorBool GeneVectorBool instructionVectorBoolIterate "instructionVectorBoolIterate" + +instructionVectorBoolPop :: State -> State +instructionVectorBoolPop state = instructionPop state vectorBool + +instructionVectorBoolDup :: State -> State +instructionVectorBoolDup state = instructionDup state vectorBool + +instructionVectorBoolDupN :: State -> State +instructionVectorBoolDupN state = instructionDupN state vectorBool + +instructionVectorBoolSwap :: State -> State +instructionVectorBoolSwap state = instructionSwap state vectorBool + +instructionVectorBoolRot :: State -> State +instructionVectorBoolRot state = instructionRot state vectorBool + +instructionVectorBoolFlush :: State -> State +instructionVectorBoolFlush state = instructionFlush state vectorBool + +instructionVectorBoolEq :: State -> State +instructionVectorBoolEq state = instructionEq state vectorBool + +instructionVectorBoolStackDepth :: State -> State +instructionVectorBoolStackDepth state = instructionStackDepth state vectorBool + +instructionVectorBoolYank :: State -> State +instructionVectorBoolYank state = instructionYank state vectorBool + +instructionVectorBoolYankDup :: State -> State +instructionVectorBoolYankDup state = instructionYankDup state vectorBool + +instructionVectorBoolStackIsEmpty :: State -> State +instructionVectorBoolStackIsEmpty state = instructionIsEmpty state vectorBool + +instructionVectorBoolShove :: State -> State +instructionVectorBoolShove state = instructionShove state vectorBool + +instructionVectorBoolShoveDup :: State -> State +instructionVectorBoolShoveDup state = instructionShoveDup state vectorBool diff --git a/src/HushGP/Instructions/VectorCharInstructions.hs b/src/HushGP/Instructions/VectorCharInstructions.hs new file mode 100644 index 0000000..12b083e --- /dev/null +++ b/src/HushGP/Instructions/VectorCharInstructions.hs @@ -0,0 +1,106 @@ +module HushGP.Instructions.VectorCharInstructions where + +import HushGP.State +import HushGP.Instructions.GenericInstructions + +instructionVectorCharConcat :: State -> State +instructionVectorCharConcat state = instructionConcat state vectorChar + +instructionVectorCharConj :: State -> State +instructionVectorCharConj state = instructionConj state char vectorChar + +instructionVectorCharTakeN :: State -> State +instructionVectorCharTakeN state = instructionTakeN state vectorChar + +instructionVectorCharSubVector :: State -> State +instructionVectorCharSubVector state = instructionSubVector state vectorChar + +instructionVectorCharFirst :: State -> State +instructionVectorCharFirst state = instructionVectorFirst state char vectorChar + +instructionVectorCharLast :: State -> State +instructionVectorCharLast state = instructionVectorLast state char vectorChar + +instructionVectorCharNth :: State -> State +instructionVectorCharNth state = instructionVectorNth state char vectorChar + +instructionVectorCharRest :: State -> State +instructionVectorCharRest state = instructionRest state vectorChar + +instructionVectorCharButLast :: State -> State +instructionVectorCharButLast state = instructionButLast state vectorChar + +instructionVectorCharLength :: State -> State +instructionVectorCharLength state = instructionLength state vectorChar + +instructionVectorCharReverse :: State -> State +instructionVectorCharReverse state = instructionReverse state vectorChar + +instructionVectorCharPushAll :: State -> State +instructionVectorCharPushAll state = instructionPushAll state char vectorChar + +instructionVectorCharMakeEmpty :: State -> State +instructionVectorCharMakeEmpty state = instructionVectorMakeEmpty state vectorChar + +instructionVectorCharIsEmpty :: State -> State +instructionVectorCharIsEmpty state = instructionVectorIsEmpty state vectorChar + +instructionVectorCharIndexOf :: State -> State +instructionVectorCharIndexOf state = instructionVectorIndexOf state char vectorChar + +instructionVectorCharOccurrencesOf :: State -> State +instructionVectorCharOccurrencesOf state = instructionVectorOccurrencesOf state char vectorChar + +instructionVectorCharSetNth :: State -> State +instructionVectorCharSetNth state = instructionVectorSetNth state char vectorChar + +instructionVectorCharReplace :: State -> State +instructionVectorCharReplace state = instructionVectorReplace state char vectorChar + +instructionVectorCharReplaceFirst :: State -> State +instructionVectorCharReplaceFirst state = instructionVectorReplaceFirst state char vectorChar + +instructionVectorCharRemove :: State -> State +instructionVectorCharRemove state = instructionVectorRemove state char vectorChar + +instructionVectorCharIterate :: State -> State +instructionVectorCharIterate state = instructionVectorIterate state char vectorChar GeneVectorChar instructionVectorCharIterate "instructionVectorCharIterate" + +instructionVectorCharPop :: State -> State +instructionVectorCharPop state = instructionPop state vectorChar + +instructionVectorCharDup :: State -> State +instructionVectorCharDup state = instructionDup state vectorChar + +instructionVectorCharDupN :: State -> State +instructionVectorCharDupN state = instructionDupN state vectorChar + +instructionVectorCharSwap :: State -> State +instructionVectorCharSwap state = instructionSwap state vectorChar + +instructionVectorCharRot :: State -> State +instructionVectorCharRot state = instructionRot state vectorChar + +instructionVectorCharFlush :: State -> State +instructionVectorCharFlush state = instructionFlush state vectorChar + +instructionVectorCharEq :: State -> State +instructionVectorCharEq state = instructionEq state vectorChar + +instructionVectorCharStackDepth :: State -> State +instructionVectorCharStackDepth state = instructionStackDepth state vectorChar + +instructionVectorCharYank :: State -> State +instructionVectorCharYank state = instructionYank state vectorChar + +instructionVectorCharYankDup :: State -> State +instructionVectorCharYankDup state = instructionYankDup state vectorChar + +instructionVectorCharStackIsEmpty :: State -> State +instructionVectorCharStackIsEmpty state = instructionIsEmpty state vectorChar + +instructionVectorCharShove :: State -> State +instructionVectorCharShove state = instructionShove state vectorChar + +instructionVectorCharShoveDup :: State -> State +instructionVectorCharShoveDup state = instructionShoveDup state vectorChar diff --git a/src/HushGP/Instructions/VectorFloatInstructions.hs b/src/HushGP/Instructions/VectorFloatInstructions.hs new file mode 100644 index 0000000..3f21566 --- /dev/null +++ b/src/HushGP/Instructions/VectorFloatInstructions.hs @@ -0,0 +1,106 @@ +module HushGP.Instructions.VectorFloatInstructions where + +import HushGP.State +import HushGP.Instructions.GenericInstructions + +instructionVectorFloatConcat :: State -> State +instructionVectorFloatConcat state = instructionConcat state vectorFloat + +instructionVectorFloatConj :: State -> State +instructionVectorFloatConj state = instructionConj state float vectorFloat + +instructionVectorFloatTakeN :: State -> State +instructionVectorFloatTakeN state = instructionTakeN state vectorFloat + +instructionVectorFloatSubVector :: State -> State +instructionVectorFloatSubVector state = instructionSubVector state vectorFloat + +instructionVectorFloatFirst :: State -> State +instructionVectorFloatFirst state = instructionVectorFirst state float vectorFloat + +instructionVectorFloatLast :: State -> State +instructionVectorFloatLast state = instructionVectorLast state float vectorFloat + +instructionVectorFloatNth :: State -> State +instructionVectorFloatNth state = instructionVectorNth state float vectorFloat + +instructionVectorFloatRest :: State -> State +instructionVectorFloatRest state = instructionRest state vectorFloat + +instructionVectorFloatButLast :: State -> State +instructionVectorFloatButLast state = instructionButLast state vectorFloat + +instructionVectorFloatLength :: State -> State +instructionVectorFloatLength state = instructionLength state vectorFloat + +instructionVectorFloatReverse :: State -> State +instructionVectorFloatReverse state = instructionReverse state vectorFloat + +instructionVectorFloatPushAll :: State -> State +instructionVectorFloatPushAll state = instructionPushAll state float vectorFloat + +instructionVectorFloatMakeEmpty :: State -> State +instructionVectorFloatMakeEmpty state = instructionVectorMakeEmpty state vectorFloat + +instructionVectorFloatIsEmpty :: State -> State +instructionVectorFloatIsEmpty state = instructionVectorIsEmpty state vectorFloat + +instructionVectorFloatIndexOf :: State -> State +instructionVectorFloatIndexOf state = instructionVectorIndexOf state float vectorFloat + +instructionVectorFloatOccurrencesOf :: State -> State +instructionVectorFloatOccurrencesOf state = instructionVectorOccurrencesOf state float vectorFloat + +instructionVectorFloatSetNth :: State -> State +instructionVectorFloatSetNth state = instructionVectorSetNth state float vectorFloat + +instructionVectorFloatReplace :: State -> State +instructionVectorFloatReplace state = instructionVectorReplace state float vectorFloat + +instructionVectorFloatReplaceFirst :: State -> State +instructionVectorFloatReplaceFirst state = instructionVectorReplaceFirst state float vectorFloat + +instructionVectorFloatRemove :: State -> State +instructionVectorFloatRemove state = instructionVectorRemove state float vectorFloat + +instructionVectorFloatIterate :: State -> State +instructionVectorFloatIterate state = instructionVectorIterate state float vectorFloat GeneVectorFloat instructionVectorFloatIterate "instructionVectorFloatIterate" + +instructionVectorFloatPop :: State -> State +instructionVectorFloatPop state = instructionPop state vectorFloat + +instructionVectorFloatDup :: State -> State +instructionVectorFloatDup state = instructionDup state vectorFloat + +instructionVectorFloatDupN :: State -> State +instructionVectorFloatDupN state = instructionDupN state vectorFloat + +instructionVectorFloatSwap :: State -> State +instructionVectorFloatSwap state = instructionSwap state vectorFloat + +instructionVectorFloatRot :: State -> State +instructionVectorFloatRot state = instructionRot state vectorFloat + +instructionVectorFloatFlush :: State -> State +instructionVectorFloatFlush state = instructionFlush state vectorFloat + +instructionVectorFloatEq :: State -> State +instructionVectorFloatEq state = instructionEq state vectorFloat + +instructionVectorFloatStackDepth :: State -> State +instructionVectorFloatStackDepth state = instructionStackDepth state vectorFloat + +instructionVectorFloatYank :: State -> State +instructionVectorFloatYank state = instructionYank state vectorFloat + +instructionVectorFloatYankDup :: State -> State +instructionVectorFloatYankDup state = instructionYankDup state vectorFloat + +instructionVectorFloatStackIsEmpty :: State -> State +instructionVectorFloatStackIsEmpty state = instructionIsEmpty state vectorFloat + +instructionVectorFloatShove :: State -> State +instructionVectorFloatShove state = instructionShove state vectorFloat + +instructionVectorFloatShoveDup :: State -> State +instructionVectorFloatShoveDup state = instructionShoveDup state vectorFloat diff --git a/src/HushGP/Instructions/VectorIntInstructions.hs b/src/HushGP/Instructions/VectorIntInstructions.hs new file mode 100644 index 0000000..1bac705 --- /dev/null +++ b/src/HushGP/Instructions/VectorIntInstructions.hs @@ -0,0 +1,106 @@ +module HushGP.Instructions.VectorIntInstructions where + +import HushGP.Instructions.GenericInstructions +import HushGP.State + +instructionVectorIntConcat :: State -> State +instructionVectorIntConcat state = instructionConcat state vectorInt + +instructionVectorIntConj :: State -> State +instructionVectorIntConj state = instructionConj state int vectorInt + +instructionVectorIntTakeN :: State -> State +instructionVectorIntTakeN state = instructionTakeN state vectorInt + +instructionVectorIntSubVector :: State -> State +instructionVectorIntSubVector state = instructionSubVector state vectorInt + +instructionVectorIntFirst :: State -> State +instructionVectorIntFirst state = instructionVectorFirst state int vectorInt + +instructionVectorIntLast :: State -> State +instructionVectorIntLast state = instructionVectorLast state int vectorInt + +instructionVectorIntNth :: State -> State +instructionVectorIntNth state = instructionVectorNth state int vectorInt + +instructionVectorIntRest :: State -> State +instructionVectorIntRest state = instructionRest state vectorInt + +instructionVectorIntButLast :: State -> State +instructionVectorIntButLast state = instructionButLast state vectorInt + +instructionVectorIntLength :: State -> State +instructionVectorIntLength state = instructionLength state vectorInt + +instructionVectorIntReverse :: State -> State +instructionVectorIntReverse state = instructionReverse state vectorInt + +instructionVectorIntPushAll :: State -> State +instructionVectorIntPushAll state = instructionPushAll state int vectorInt + +instructionVectorIntMakeEmpty :: State -> State +instructionVectorIntMakeEmpty state = instructionVectorMakeEmpty state vectorInt + +instructionVectorIntIsEmpty :: State -> State +instructionVectorIntIsEmpty state = instructionVectorIsEmpty state vectorInt + +instructionVectorIntIndexOf :: State -> State +instructionVectorIntIndexOf state = instructionVectorIndexOf state int vectorInt + +instructionVectorIntOccurrencesOf :: State -> State +instructionVectorIntOccurrencesOf state = instructionVectorOccurrencesOf state int vectorInt + +instructionVectorIntSetNth :: State -> State +instructionVectorIntSetNth state = instructionVectorSetNth state int vectorInt + +instructionVectorIntReplace :: State -> State +instructionVectorIntReplace state = instructionVectorReplace state int vectorInt + +instructionVectorIntReplaceFirst :: State -> State +instructionVectorIntReplaceFirst state = instructionVectorReplaceFirst state int vectorInt + +instructionVectorIntRemove :: State -> State +instructionVectorIntRemove state = instructionVectorRemove state int vectorInt + +instructionVectorIntIterate :: State -> State +instructionVectorIntIterate state = instructionVectorIterate state int vectorInt GeneVectorInt instructionVectorIntIterate "instructionVectorIntIterate" + +instructionVectorIntPop :: State -> State +instructionVectorIntPop state = instructionPop state vectorChar + +instructionVectorIntDup :: State -> State +instructionVectorIntDup state = instructionDup state vectorChar + +instructionVectorIntDupN :: State -> State +instructionVectorIntDupN state = instructionDupN state vectorChar + +instructionVectorIntSwap :: State -> State +instructionVectorIntSwap state = instructionSwap state vectorChar + +instructionVectorIntRot :: State -> State +instructionVectorIntRot state = instructionRot state vectorChar + +instructionVectorIntFlush :: State -> State +instructionVectorIntFlush state = instructionFlush state vectorChar + +instructionVectorIntEq :: State -> State +instructionVectorIntEq state = instructionEq state vectorChar + +instructionVectorIntStackDepth :: State -> State +instructionVectorIntStackDepth state = instructionStackDepth state vectorChar + +instructionVectorIntYank :: State -> State +instructionVectorIntYank state = instructionYank state vectorChar + +instructionVectorIntYankDup :: State -> State +instructionVectorIntYankDup state = instructionYankDup state vectorChar + +instructionVectorIntStackIsEmpty :: State -> State +instructionVectorIntStackIsEmpty state = instructionIsEmpty state vectorChar + +instructionVectorIntShove :: State -> State +instructionVectorIntShove state = instructionShove state vectorChar + +instructionVectorIntShoveDup :: State -> State +instructionVectorIntShoveDup state = instructionShoveDup state vectorChar diff --git a/src/HushGP/Instructions/VectorStringInstructions.hs b/src/HushGP/Instructions/VectorStringInstructions.hs new file mode 100644 index 0000000..39d0b69 --- /dev/null +++ b/src/HushGP/Instructions/VectorStringInstructions.hs @@ -0,0 +1,106 @@ +module HushGP.Instructions.VectorStringInstructions where + +import HushGP.State +import HushGP.Instructions.GenericInstructions + +instructionVectorStringConcat :: State -> State +instructionVectorStringConcat state = instructionConcat state vectorString + +instructionVectorStringConj :: State -> State +instructionVectorStringConj state = instructionConj state string vectorString + +instructionVectorStringTakeN :: State -> State +instructionVectorStringTakeN state = instructionTakeN state vectorString + +instructionVectorStringSubVector :: State -> State +instructionVectorStringSubVector state = instructionSubVector state vectorString + +instructionVectorStringFirst :: State -> State +instructionVectorStringFirst state = instructionVectorFirst state string vectorString + +instructionVectorStringLast :: State -> State +instructionVectorStringLast state = instructionVectorLast state string vectorString + +instructionVectorStringNth :: State -> State +instructionVectorStringNth state = instructionVectorNth state string vectorString + +instructionVectorStringRest :: State -> State +instructionVectorStringRest state = instructionRest state vectorString + +instructionVectorStringButLast :: State -> State +instructionVectorStringButLast state = instructionButLast state vectorString + +instructionVectorStringLength :: State -> State +instructionVectorStringLength state = instructionLength state vectorString + +instructionVectorStringReverse :: State -> State +instructionVectorStringReverse state = instructionReverse state vectorString + +instructionVectorStringPushAll :: State -> State +instructionVectorStringPushAll state = instructionPushAll state string vectorString + +instructionVectorStringMakeEmpty :: State -> State +instructionVectorStringMakeEmpty state = instructionVectorMakeEmpty state vectorString + +instructionVectorStringIsEmpty :: State -> State +instructionVectorStringIsEmpty state = instructionVectorIsEmpty state vectorString + +instructionVectorStringIndexOf :: State -> State +instructionVectorStringIndexOf state = instructionVectorIndexOf state string vectorString + +instructionVectorStringOccurrencesOf :: State -> State +instructionVectorStringOccurrencesOf state = instructionVectorOccurrencesOf state string vectorString + +instructionVectorStringSetNth :: State -> State +instructionVectorStringSetNth state = instructionVectorSetNth state string vectorString + +instructionVectorStringReplace :: State -> State +instructionVectorStringReplace state = instructionVectorReplace state string vectorString + +instructionVectorStringReplaceFirst :: State -> State +instructionVectorStringReplaceFirst state = instructionVectorReplaceFirst state string vectorString + +instructionVectorStringRemove :: State -> State +instructionVectorStringRemove state = instructionVectorRemove state string vectorString + +instructionVectorStringIterate :: State -> State +instructionVectorStringIterate state = instructionVectorIterate state string vectorString GeneVectorString instructionVectorStringIterate "instructionVectorStringIterate" + +instructionVectorStringPop :: State -> State +instructionVectorStringPop state = instructionPop state vectorString + +instructionVectorStringDup :: State -> State +instructionVectorStringDup state = instructionDup state vectorString + +instructionVectorStringDupN :: State -> State +instructionVectorStringDupN state = instructionDupN state vectorString + +instructionVectorStringSwap :: State -> State +instructionVectorStringSwap state = instructionSwap state vectorString + +instructionVectorStringRot :: State -> State +instructionVectorStringRot state = instructionRot state vectorString + +instructionVectorStringFlush :: State -> State +instructionVectorStringFlush state = instructionFlush state vectorString + +instructionVectorStringEq :: State -> State +instructionVectorStringEq state = instructionEq state vectorString + +instructionVectorStringStackDepth :: State -> State +instructionVectorStringStackDepth state = instructionStackDepth state vectorString + +instructionVectorStringYank :: State -> State +instructionVectorStringYank state = instructionYank state vectorString + +instructionVectorStringYankDup :: State -> State +instructionVectorStringYankDup state = instructionYankDup state vectorString + +instructionVectorStringStackIsEmpty :: State -> State +instructionVectorStringStackIsEmpty state = instructionIsEmpty state vectorString + +instructionVectorStringShove :: State -> State +instructionVectorStringShove state = instructionShove state vectorString + +instructionVectorStringShoveDup :: State -> State +instructionVectorStringShoveDup state = instructionShoveDup state vectorString diff --git a/src/HushGP/Push.hs b/src/HushGP/Push.hs new file mode 100644 index 0000000..1c9b75f --- /dev/null +++ b/src/HushGP/Push.hs @@ -0,0 +1,86 @@ +module HushGP.Push where + +import Control.Lens +import Data.Map qualified as Map +import HushGP.State + +-- import Debug.Trace (trace, traceStack) + +-- Each core func should be: (State -> State -> State) +-- but each core function can use abstract helper functions. +-- That is more efficient than checking length. +-- 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. +-- 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 + +-- Loads a genome into the exec stack +loadProgram :: [Gene] -> State -> State +loadProgram newstack state = state & exec .~ newstack + +-- Takes a Push state, and generates the next push state via: +-- If the first item on the EXEC stack is a single instruction +-- then pop it and execute it. +-- Else if the first item on the EXEC stack is a literal +-- then pop it and push it onto the appropriate stack. +-- Else (the first item must be a list) pop it and push all of the +-- items that it contains back onto the EXEC stack individually, +-- in reverse order (so that the item that was first in the list +-- ends up on top). +-- The empty-stack safety of interpretExec on empty stacks depends on the functions it calls. +interpretExec :: State -> State +interpretExec state@(State {_exec = e : es}) = + case e of + (GeneInt val) -> interpretExec (state & exec .~ es & int .~ val : view int state) + (GeneFloat val) -> interpretExec (state & exec .~ es & float .~ val : view float state) + (GeneBool val) -> interpretExec (state & exec .~ es & bool .~ val : view bool state) + (GeneString val) -> interpretExec (state & exec .~ es & string .~ val : view string state) + (GeneChar val) -> interpretExec (state & exec .~ es & char .~ val : view char state) + (GeneVectorInt val) -> interpretExec (state & exec .~ es & vectorInt .~ val : view vectorInt state) + (GeneVectorFloat val) -> interpretExec (state & exec .~ es & vectorFloat .~ val : view vectorFloat state) + (GeneVectorBool val) -> interpretExec (state & exec .~ es & vectorBool .~ val : view vectorBool state) + (GeneVectorString val) -> interpretExec (state & exec .~ es & vectorString .~ val : view vectorString state) + (GeneVectorChar val) -> interpretExec (state & exec .~ es & vectorChar .~ val : view vectorChar state) + (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 +interpretExec state = state + +-- interpretOneStep :: State -> State +-- interpretOneStep state@(State {_exec = e : es}) = +-- case e of +-- (GeneInt val) -> state & exec .~ es & int .~ val : view int state +-- (GeneFloat val) -> state & exec .~ es & float .~ val : view float state +-- (GeneBool val) -> state & exec .~ es & bool .~ val : view bool state +-- (GeneString val) -> state & exec .~ es & string .~ val : view string state +-- (GeneChar val) -> state & exec .~ es & char .~ val : view char state +-- (GeneVectorInt val) -> state & exec .~ es & vectorInt .~ val : view vectorInt state +-- (GeneVectorFloat val) -> state & exec .~ es & vectorFloat .~ val : view vectorFloat state +-- (GeneVectorBool val) -> state & exec .~ es & vectorBool .~ val : view vectorBool state +-- (GeneVectorString val) -> state & exec .~ es & vectorString .~ val : view vectorString state +-- (GeneVectorChar val) -> state & exec .~ es & vectorChar .~ val : view vectorChar state +-- (StateFunc (func, _)) -> func state {_exec = es} +-- (Block block) -> (state {_exec = block ++ es}) +-- (PlaceInput val) -> (state {_exec = (view input state Map.! val) : es}) +-- Close -> undefined +-- interpretOneStep state = state +-- Need to make interpretExec strict, right? diff --git a/src/HushGP/PushTests.hs b/src/HushGP/PushTests.hs new file mode 100644 index 0000000..24f356e --- /dev/null +++ b/src/HushGP/PushTests.hs @@ -0,0 +1,10 @@ +module HushGP.PushTests + ( 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 diff --git a/src/HushGP/PushTests/GenericTests.hs b/src/HushGP/PushTests/GenericTests.hs new file mode 100644 index 0000000..807af7b --- /dev/null +++ b/src/HushGP/PushTests/GenericTests.hs @@ -0,0 +1,129 @@ +module HushGP.PushTests.GenericTests where + +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 + +-- 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 + +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 + +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 + +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 + +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 + +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 + +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}) = +-- let +-- myIndex :: Int +-- myIndex = max 0 (min i1 (length (view accessor state{_int = is}) - 1)) +-- item :: a +-- item = view accessor state{_int = is} !! myIndex +-- in +-- case (uncons (view accessor $ instruction state), uncons is) of +-- (Just (x1, xs), Just (_, _)) -> x1 === item .&&. (x1 : xs) !! === item +-- _ -> state === instruction state +-- yankDupTest _ instruction state = state === instruction state + +-- shoveTest diff --git a/src/HushGP/PushTests/IntTests.hs b/src/HushGP/PushTests/IntTests.hs new file mode 100644 index 0000000..acd1cdd --- /dev/null +++ b/src/HushGP/PushTests/IntTests.hs @@ -0,0 +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 + +prop_IntAdd :: State -> Property +prop_IntAdd = aaa1Test int instructionIntAdd (+) + +prop_IntSub :: State -> Property +prop_IntSub = aaa1Test int instructionIntSub (-) + +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_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_IntFromProperty :: State -> Property +prop_IntFromProperty = ab1Test bool int instructionIntFromBool (\x -> if x then 1 else 0) + +prop_IntMin :: State -> Property +prop_IntMin = aaa1Test int instructionIntMin min + +prop_IntMax :: State -> Property +prop_IntMax = aaa1Test int instructionIntMax max + +prop_IntInc :: State -> Property +prop_IntInc = aa1Test int instructionIntInc (+1) + +prop_IntDec :: State -> Property +prop_IntDec = aa1Test int instructionIntDec (\x -> x - 1) + +prop_IntLT :: State -> Property +prop_IntLT = aab2Test int bool instructionIntLT (<) + +prop_IntGT :: State -> Property +prop_IntGT = aab2Test int bool instructionIntGT (>) + +prop_IntLTE :: State -> Property +prop_IntLTE = aab2Test int bool instructionIntLTE (<=) + +prop_IntGTE :: State -> Property +prop_IntGTE = aab2Test int bool instructionIntGTE (>=) + +prop_IntDup :: State -> Property +prop_IntDup = dupTest int instructionIntDup + +prop_IntPop :: State -> Property +prop_IntPop = popTest int instructionIntPop + +prop_IntDupN :: State -> Property +prop_IntDupN = dupTestN int instructionIntDupN + +prop_IntSwap :: State -> Property +prop_IntSwap = swapTest int instructionIntSwap + +prop_IntRot :: State -> Property +prop_IntRot = rotTest int instructionIntRot + +prop_IntFlush :: State -> Property +prop_IntFlush = flushTest int instructionIntFlush + +prop_IntEq :: State -> Property +prop_IntEq = aab2Test int bool instructionIntEq (==) + +prop_IntStackDepth :: State -> Property +prop_IntStackDepth = stackDepthTest int instructionIntStackDepth + +prop_IntYank :: State -> Property +prop_IntYank = yankTest int instructionIntYank + +-- prop_IntYankDup :: State -> Property +-- prop_IntYankDup = yankDupTest int instructionIntYankDup diff --git a/src/HushGP/PushTests/UtilTests.hs b/src/HushGP/PushTests/UtilTests.hs new file mode 100644 index 0000000..ea2ce60 --- /dev/null +++ b/src/HushGP/PushTests/UtilTests.hs @@ -0,0 +1,36 @@ +module HushGP.PushTests.UtilTests where + +import HushGP.Instructions.GenericInstructions +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_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 + +-- 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_SubList :: Int -> Int -> [Int] -> Property +-- prop_SubList idx0 idx1 lst = + -- idx diff --git a/src/HushGP/State.hs b/src/HushGP/State.hs new file mode 100644 index 0000000..acccbc2 --- /dev/null +++ b/src/HushGP/State.hs @@ -0,0 +1,166 @@ +{-# 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 + +-- 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 + | GeneBool Bool + | GeneString String + | GeneChar Char + | GeneVectorInt [Int] + | GeneVectorFloat [Float] + | GeneVectorBool [Bool] + | GeneVectorString [String] + | GeneVectorChar [Char] + | StateFunc (State -> State, String) -- The string stores the name of the function + | PlaceInput String + | Close + | Block [Gene] + deriving (Generic) + +instance Eq 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 + StateFunc (_, nameX) == StateFunc (_, nameY) = nameX == nameY + Block x == Block y = x == y + _ == _ = False + +instance Show Gene where + show (GeneInt x) = "Int: " <> show x + show (GeneFloat x) = "Float: " <> show x + show (GeneBool x) = "Bool: " <> show x + show (GeneString x) = "String: " <> x + show (GeneChar x) = "Char: " <> show x + show (StateFunc (_, funcName)) = "Func: " <> funcName + show (PlaceInput x) = "In: " <> show x + show (GeneVectorInt xs) = "Int Vec: " <> show xs + show (GeneVectorFloat xs) = "Float Vec: " <> show xs + show (GeneVectorBool xs) = "Bool Vec: " <> show xs + show (GeneVectorString xs) = "String Vec: " <> show xs + show (GeneVectorChar xs) = "Char Vec: " <> show xs + show Close = "Close" + 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 + ] + +data State = State + { _exec :: [Gene], + _code :: [Gene], + _int :: [Int], + _float :: [Float], + _bool :: [Bool], + _string :: [String], + _char :: [Char], + _vectorInt :: [[Int]], + _vectorFloat :: [[Float]], + _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 + +emptyState :: State +emptyState = + State + { _exec = [], + _code = [], + _int = [], + _float = [], + _bool = [], + _string = [], + _char = [], + _parameter = [], + _vectorInt = [], + _vectorFloat = [], + _vectorBool = [], + _vectorString = [], + _vectorChar = [], + _input = Map.empty + } + +exampleState :: State +exampleState = + State + { _exec = [], + _code = [], + _int = [32, 56], + _float = [3.23, 9.235], + _bool = [True, False], + _string = ["abc", "123"], + _char = ['d', 'e', 'f'], + _parameter = [], + _vectorInt = [[1, 2], [5, 6, 8]], + _vectorFloat = [[1.234, 9.21], [5.42, 6.221, 8.5493]], + _vectorBool = [[True, False], [False, False, True]], + _vectorString = [["this is a sentence", "this is also a sentence"], ["s0", "s1", "s2"]], + _vectorChar = [['z', 'x'], ['r', 'a', 't', 'l']], + _input = Map.empty + } + +-- This must stay at the end of the file. +-- Template haskell seems to be messing with GHC.Generics +$(makeLenses ''State)