diff --git a/src/GP.hs b/src/GP.hs deleted file mode 100644 index 3b0f83a..0000000 --- a/src/GP.hs +++ /dev/null @@ -1,3 +0,0 @@ -module GP where - --- import Debug.Trace (trace, traceStack) diff --git a/src/Instructions.hs b/src/Instructions.hs deleted file mode 100644 index c9d3e46..0000000 --- a/src/Instructions.hs +++ /dev/null @@ -1,504 +0,0 @@ -module Instructions - ( module Instructions.GenericInstructions, - module Instructions.IntInstructions, - module Instructions.FloatInstructions, - module Instructions.StringInstructions, - module Instructions.CharInstructions, - module Instructions.CodeInstructions, - module Instructions.ExecInstructions, - module Instructions.LogicalInstructions, - module Instructions.VectorIntInstructions, - module Instructions.VectorFloatInstructions, - module Instructions.VectorStringInstructions, - module Instructions.VectorLogicalInstructions, - module Instructions.VectorCharInstructions, - allIntInstructions, - allFloatInstructions, - allBoolInstructions, - allCharInstructions, - allCodeInstructions, - allExecInstructions, - allStringInstructions, - allVectorIntInstructions, - allVectorFloatInstructions, - allVectorCharInstructions, - allVectorStringInstructions, - allVectorBoolInstructions, - allInstructions - ) -where - -import Instructions.CharInstructions -import Instructions.CodeInstructions -import Instructions.ExecInstructions -import Instructions.FloatInstructions -import Instructions.GenericInstructions -import Instructions.IntInstructions -import Instructions.LogicalInstructions -import Instructions.StringInstructions -import Instructions.VectorCharInstructions -import Instructions.VectorFloatInstructions -import Instructions.VectorIntInstructions -import Instructions.VectorLogicalInstructions -import Instructions.VectorStringInstructions -import 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/Instructions/CharInstructions.hs b/src/Instructions/CharInstructions.hs deleted file mode 100644 index 29fcdd9..0000000 --- a/src/Instructions/CharInstructions.hs +++ /dev/null @@ -1,89 +0,0 @@ -module Instructions.CharInstructions where - -import Data.Char -import State -import Instructions.StringInstructions (wschars) -import 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/Instructions/CodeInstructions.hs b/src/Instructions/CodeInstructions.hs deleted file mode 100644 index 654673e..0000000 --- a/src/Instructions/CodeInstructions.hs +++ /dev/null @@ -1,310 +0,0 @@ -module Instructions.CodeInstructions where - -import Data.List (elemIndex) -import State -import Instructions.GenericInstructions -import 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/Instructions/ExecInstructions.hs b/src/Instructions/ExecInstructions.hs deleted file mode 100644 index c0ab519..0000000 --- a/src/Instructions/ExecInstructions.hs +++ /dev/null @@ -1,106 +0,0 @@ -module Instructions.ExecInstructions where - -import State -import Instructions.IntInstructions -import 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/Instructions/FloatInstructions.hs b/src/Instructions/FloatInstructions.hs deleted file mode 100644 index d8d89fa..0000000 --- a/src/Instructions/FloatInstructions.hs +++ /dev/null @@ -1,116 +0,0 @@ -module Instructions.FloatInstructions where - -import Data.Fixed (mod') -import Instructions.GenericInstructions -import 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/Instructions/GenericInstructions.hs b/src/Instructions/GenericInstructions.hs deleted file mode 100644 index 8a60233..0000000 --- a/src/Instructions/GenericInstructions.hs +++ /dev/null @@ -1,348 +0,0 @@ -module Instructions.GenericInstructions where - -import Control.Lens -import 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/Instructions/IntInstructions.hs b/src/Instructions/IntInstructions.hs deleted file mode 100644 index c8a40a0..0000000 --- a/src/Instructions/IntInstructions.hs +++ /dev/null @@ -1,104 +0,0 @@ -module Instructions.IntInstructions where - -import State -import 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/Instructions/LogicalInstructions.hs b/src/Instructions/LogicalInstructions.hs deleted file mode 100644 index a10e96f..0000000 --- a/src/Instructions/LogicalInstructions.hs +++ /dev/null @@ -1,79 +0,0 @@ -module Instructions.LogicalInstructions where - -import State -import 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/Instructions/StringInstructions.hs b/src/Instructions/StringInstructions.hs deleted file mode 100644 index 88b2344..0000000 --- a/src/Instructions/StringInstructions.hs +++ /dev/null @@ -1,231 +0,0 @@ -module Instructions.StringInstructions where - -import State -import 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/Instructions/VectorCharInstructions.hs b/src/Instructions/VectorCharInstructions.hs deleted file mode 100644 index 7467163..0000000 --- a/src/Instructions/VectorCharInstructions.hs +++ /dev/null @@ -1,106 +0,0 @@ -module Instructions.VectorCharInstructions where - -import State -import 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/Instructions/VectorFloatInstructions.hs b/src/Instructions/VectorFloatInstructions.hs deleted file mode 100644 index 18dabc9..0000000 --- a/src/Instructions/VectorFloatInstructions.hs +++ /dev/null @@ -1,106 +0,0 @@ -module Instructions.VectorFloatInstructions where - -import State -import 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/Instructions/VectorIntInstructions.hs b/src/Instructions/VectorIntInstructions.hs deleted file mode 100644 index bb135ff..0000000 --- a/src/Instructions/VectorIntInstructions.hs +++ /dev/null @@ -1,106 +0,0 @@ -module Instructions.VectorIntInstructions where - -import Instructions.GenericInstructions -import 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/Instructions/VectorLogicalInstructions.hs b/src/Instructions/VectorLogicalInstructions.hs deleted file mode 100644 index 35d7add..0000000 --- a/src/Instructions/VectorLogicalInstructions.hs +++ /dev/null @@ -1,106 +0,0 @@ -module Instructions.VectorLogicalInstructions where - -import State -import 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/Instructions/VectorStringInstructions.hs b/src/Instructions/VectorStringInstructions.hs deleted file mode 100644 index def670a..0000000 --- a/src/Instructions/VectorStringInstructions.hs +++ /dev/null @@ -1,106 +0,0 @@ -module Instructions.VectorStringInstructions where - -import State -import 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/Push.hs b/src/Push.hs deleted file mode 100644 index 44c6bc8..0000000 --- a/src/Push.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Push where - -import Control.Lens -import Data.Map qualified as Map -import 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/PushTests.hs b/src/PushTests.hs deleted file mode 100644 index 571b27f..0000000 --- a/src/PushTests.hs +++ /dev/null @@ -1,10 +0,0 @@ -module PushTests - ( module PushTests.GenericTests, - module PushTests.IntTests, - module PushTests.UtilTests, - ) -where - -import PushTests.GenericTests -import PushTests.IntTests -import PushTests.UtilTests diff --git a/src/PushTests/GenericTests.hs b/src/PushTests/GenericTests.hs deleted file mode 100644 index 5a8dded..0000000 --- a/src/PushTests/GenericTests.hs +++ /dev/null @@ -1,129 +0,0 @@ -module PushTests.GenericTests where - -import State -import Control.Lens -import Debug.Trace -import Test.QuickCheck -import 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/PushTests/IntTests.hs b/src/PushTests/IntTests.hs deleted file mode 100644 index 07432f1..0000000 --- a/src/PushTests/IntTests.hs +++ /dev/null @@ -1,84 +0,0 @@ -module PushTests.IntTests where - -import State -import Instructions.IntInstructions -import 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/PushTests/UtilTests.hs b/src/PushTests/UtilTests.hs deleted file mode 100644 index 07b49da..0000000 --- a/src/PushTests/UtilTests.hs +++ /dev/null @@ -1,36 +0,0 @@ -module PushTests.UtilTests where - -import 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/State.hs b/src/State.hs deleted file mode 100644 index cfd4071..0000000 --- a/src/State.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} - -module 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)