more changes/todo

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

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]

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

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

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