From b47371a2fd2b5d8409e83536d67f9622f021ff63 Mon Sep 17 00:00:00 2001 From: Rowan Torbitzky-Lane Date: Thu, 6 Feb 2025 23:42:15 -0600 Subject: [PATCH] more changes/todo --- TODO.md | 10 +++- src/HushGP/Instructions.hs | 11 +++- src/HushGP/Instructions/CodeInstructions.hs | 56 ++++++++++++++++--- src/HushGP/Instructions/ExecInstructions.hs | 15 +++++ .../Instructions/GenericInstructions.hs | 16 ++++++ 5 files changed, 94 insertions(+), 14 deletions(-) diff --git a/TODO.md b/TODO.md index 7ca127c..58f96e6 100644 --- a/TODO.md +++ b/TODO.md @@ -4,12 +4,16 @@ - [ ] Make all vector functions applicable to string functions and vice versa - [ ] Implement all functions as seen in propeller -- [ ] Implement all functions as seen in the specification +- [X] Implement all functions as seen in the specification - [ ] Implement Linear Algebra functions as specified in the previous papers -- [ ] Add a function to sort a vector forward and backwards +- [X] Add a function to sort a vector forward and backwards - [ ] Disambiguate isEmpty and stackIsEmpty - [X] Rename Logical to Bool -- [x] Make int yank, shove, yankdup, and shovedup generic +- [X] Make int yank, shove, yankdup, and shovedup generic +- [ ] Write hackage documentation for each function +- [ ] Refactor all functions to take state as the final parameter +- [ ] Standardize the pattern matching parameters +- [ ] Write unit/quickcheck tests for all of the instructions ## PushGP TODO - [ ] Implement a Plushy genome translator diff --git a/src/HushGP/Instructions.hs b/src/HushGP/Instructions.hs index a296aeb..c912de3 100644 --- a/src/HushGP/Instructions.hs +++ b/src/HushGP/Instructions.hs @@ -209,7 +209,11 @@ allCodeInstructions = map StateFunc [ (instructionCodeFromVectorString, "instructionCodeFromVectorString"), (instructionCodeFromVectorBool, "instructionCodeFromVectorBool"), (instructionCodeFromVectorChar, "instructionCodeFromVectorChar"), - (instructionCodeFromExec, "instructionCodeFromExec") + (instructionCodeFromExec, "instructionCodeFromExec"), + (instructionCodeContainer, "instructionCodeContainer"), + (instructionCodeDiscrepancy, "instructionCodeDiscrepancy"), + (instructionCodeNoOp, "instructionCodeNoOp"), + (instructionCodeTailN, "instructionCodeTailN") ] allExecInstructions :: [Gene] @@ -233,7 +237,10 @@ allExecInstructions = map StateFunc [ (instructionExecDoTimes, "instructionExecDoTimes"), (instructionExecWhile, "instructionExecWhile"), (instructionExecDoWhile, "instructionExecDoWhile"), - (instructionExecWhen, "instructionExecWhen") + (instructionExecWhen, "instructionExecWhen"), + (instructionExecK, "instructionExecK"), + (instructionExecS, "instructionExecS"), + (instructionExecY, "instrucitonExecY") ] allStringInstructions :: [Gene] diff --git a/src/HushGP/Instructions/CodeInstructions.hs b/src/HushGP/Instructions/CodeInstructions.hs index f7f069c..0ce67b2 100644 --- a/src/HushGP/Instructions/CodeInstructions.hs +++ b/src/HushGP/Instructions/CodeInstructions.hs @@ -18,10 +18,25 @@ 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 +-- https://faculty.hampshire.edu/lspector/push3-description.html#Type +-- CODE.CONTAINER +findContainer :: Gene -> Gene -> Gene +findContainer (Block fullA) gene + | length fullA <= blockLength gene = Block [] + | gene `elem` fullA = Block [] -- Not allowed to be top level + | any isBlock fullA = findContainer' (filter isBlock fullA) gene + | otherwise = Block [] + where + findContainer' :: [Gene] -> Gene -> Gene + findContainer' [] _ = Block [] + findContainer' ((Block x) : xs) g = if g `elem` x then Block x else findContainer' xs g + findContainer' _ _ = Block [] -- This should never happen +findContainer _ _ = Block [] + +countDiscrepancy :: Gene -> Gene -> Int +countDiscrepancy (Block xs) (Block ys) = sum [if uncurry (==) tup then 0 else 1 | tup <- zip xs ys] + abs (length xs - length ys) +countDiscrepancy xgene ygene = if xgene == ygene then 1 else 0 --- empty Blocks are a thing but that shouldn't really matter extractFirstFromBlock :: Gene -> Gene extractFirstFromBlock (Block (x : _)) = x extractFirstFromBlock gene = gene @@ -38,9 +53,8 @@ extractInitFromBlock gene = gene extractTailFromBlock :: Gene -> Gene extractTailFromBlock (Block xs) = Block (drop 1 xs) -extractTailFromBlock gene = gene +extractTailFromBlock _ = Block [] --- 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 @@ -53,11 +67,9 @@ 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 (Block xs) ygene = Block (ygene : xs) codeCombine xgene (Block ys) = Block (xgene : ys) codeCombine xgene ygene = Block [xgene, ygene] @@ -85,6 +97,7 @@ instructionCodeLength :: State -> State instructionCodeLength state@(State {_code = (c : cs), _int = is}) = state {_code = cs, _int = blockLength c : is} instructionCodeLength state = state +-- CODE.CAR instructionCodeFirst :: State -> State instructionCodeFirst state@(State {_code = (c : cs)}) = state {_code = extractFirstFromBlock c : cs} instructionCodeFirst state = state @@ -93,11 +106,22 @@ instructionCodeLast :: State -> State instructionCodeLast state@(State {_code = (c : cs)}) = state {_code = extractLastFromBlock c : cs} instructionCodeLast state = state +-- CODE.CDR -- 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 +-- |Takes the tail of a block starting at an index determined by the int stack +-- https://faculty.hampshire.edu/lspector/push3-description.html#Type +-- This is the CODE.NTHCDR command +instructionCodeTailN :: State -> State +instructionCodeTailN state@(State {_code = Block bc : cs, _int = i : is}) = state {_code = Block (drop index bc) : cs, _int = is} + where + index :: Int + index = abs i `mod` length bc +instructionCodeTailN 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} @@ -116,7 +140,7 @@ instructionCodeCombine state@(State {_code = (c1 : c2 : cs)}) = state {_code = c instructionCodeCombine state = state instructionCodeDo :: State -> State -instructionCodeDo state@(State {_code = (c1 : cs), _exec = es}) = state {_code = cs, _exec = c1: es} +instructionCodeDo state@(State {_code = c1 : cs, _exec = es}) = state {_code = cs, _exec = c1 : es} instructionCodeDo state = state instructionCodeDoDup :: State -> State @@ -197,6 +221,9 @@ instructionCodeSize :: State -> State instructionCodeSize state@(State {_code = c1 : cs, _int = is}) = state{_code = cs, _int = codeRecursiveSize c1 : is} instructionCodeSize state = state +-- instructionCodeContainer :: State -> State +-- instructionCodeContainer + -- 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 @@ -308,3 +335,14 @@ instructionCodeFromVectorChar state = instructionCodeFrom state vectorChar GeneV instructionCodeFromExec :: State -> State instructionCodeFromExec state = instructionCodeFrom state exec id + +instructionCodeContainer :: State -> State +instructionCodeContainer state@(State {_code = c1 : c2 : cs}) = state {_code = findContainer c1 c2 : cs} +instructionCodeContainer state = state + +instructionCodeDiscrepancy :: State -> State +instructionCodeDiscrepancy state@(State {_code = c1 : c2 : cs, _int = is}) = state {_code = cs, _int = countDiscrepancy c1 c2 : is} +instructionCodeDiscrepancy state = state + +instructionCodeNoOp :: State -> State +instructionCodeNoOp state = state diff --git a/src/HushGP/Instructions/ExecInstructions.hs b/src/HushGP/Instructions/ExecInstructions.hs index 4b77aa7..d0fe1ad 100644 --- a/src/HushGP/Instructions/ExecInstructions.hs +++ b/src/HushGP/Instructions/ExecInstructions.hs @@ -104,3 +104,18 @@ instructionExecWhen state@(State {_exec = (_ : es), _bool = (b : bs)}) = then state {_exec = es, _bool = bs} else state {_bool = bs} instructionExecWhen state = state + +-- |The K combinator +instructionExecK :: State -> State +instructionExecK state@(State {_exec = e1 : _ : es}) = state{_exec = e1 : es} +instructionExecK state = state + +-- |The S combinator +instructionExecS :: State -> State +instructionExecS state@(State {_exec = e1 : e2 : e3 : es}) = state{_exec = e1 : e3 : Block [e2, e3] : es} +instructionExecS state = state + +-- |The Y combinator +instructionExecY :: State -> State +instructionExecY state@(State {_exec = e1 : es}) = state{_exec = e1 : Block [StateFunc (instructionExecY, "instructionExecY"), e1] : es} +instructionExecY state = state diff --git a/src/HushGP/Instructions/GenericInstructions.hs b/src/HushGP/Instructions/GenericInstructions.hs index 8c474ef..ffa79e7 100644 --- a/src/HushGP/Instructions/GenericInstructions.hs +++ b/src/HushGP/Instructions/GenericInstructions.hs @@ -2,6 +2,8 @@ module HushGP.Instructions.GenericInstructions where import Control.Lens import HushGP.State +import Data.List (sort, sortBy) +import Data.Ord -- import Debug.Trace @@ -346,3 +348,17 @@ instructionCodeFrom state@(State {_code = cs}) accessor geneType = case uncons (view accessor state) of Just (x, xs) -> state{_code = geneType x : cs} & accessor .~ xs _ -> state + +-- |A function that sorts the first vector for a vectorType +instructionVectorSort :: Ord a => Lens' State [[a]] -> State -> State +instructionVectorSort accessor state = + case uncons (view accessor state) of + Just (x, xs) -> state & accessor .~ (sort x : xs) + _ -> state + +-- |A function that sorts the first vector in reverse order for a vectorType +instructionVectorSortReverse :: Ord a => Lens' State [[a]] -> State -> State +instructionVectorSortReverse accessor state = + case uncons (view accessor state) of + Just (x, xs) -> state & accessor .~ (sortBy (comparing Data.Ord.Down) x : xs) + _ -> state