a lot of genericization and updates
This commit is contained in:
parent
035a7a2f10
commit
363425b39b
@ -2,11 +2,10 @@ module Instructions.CharInstructions where
|
||||
|
||||
import Data.Char
|
||||
import State
|
||||
import Data.List (uncons)
|
||||
-- import Instructions.GenericInstructions
|
||||
import Instructions.StringInstructions (wschars)
|
||||
import Instructions.GenericInstructions
|
||||
|
||||
intToAscii :: (Integral a) => a -> Char
|
||||
intToAscii :: Integral a => a -> Char
|
||||
intToAscii val = chr (abs (fromIntegral val) `mod` 128)
|
||||
|
||||
instructionCharConcat :: State -> State
|
||||
@ -14,26 +13,13 @@ instructionCharConcat state@(State {_char = c1 : c2 : cs, _string = ss}) = state
|
||||
instructionCharConcat state = state
|
||||
|
||||
instructionCharFromFirstChar :: State -> State
|
||||
instructionCharFromFirstChar state@(State {_char = cs, _string = s1 : ss}) =
|
||||
case uncons s1 of
|
||||
Nothing -> state
|
||||
Just (x,_) -> state {_char = x : cs, _string = ss}
|
||||
instructionCharFromFirstChar state = state
|
||||
instructionCharFromFirstChar state = instructionVectorFirst state char string
|
||||
|
||||
instructionCharFromLastChar :: State -> State
|
||||
instructionCharFromLastChar state@(State {_char = cs, _string = s1 : ss}) =
|
||||
if not $ null s1
|
||||
then state {_char = last s1 : cs, _string = ss}
|
||||
else state
|
||||
instructionCharFromLastChar state = state
|
||||
instructionCharFromLastChar state = instructionVectorLast state char string
|
||||
|
||||
instructionCharFromNthChar :: State -> State
|
||||
instructionCharFromNthChar state@(State {_char = cs, _string = s1 : ss, _int = i1 : is}) =
|
||||
let
|
||||
index = abs i1 `mod` length s1
|
||||
in
|
||||
state{_char = s1 !! index : cs, _string = ss, _int = is}
|
||||
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}
|
||||
|
||||
@ -20,6 +20,15 @@ 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)
|
||||
|
||||
findSubA :: forall a. Eq a => [a] -> [a] -> Int
|
||||
findSubA fullA subA
|
||||
| length fullA < length subA = -1
|
||||
@ -62,13 +71,16 @@ 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
|
||||
|
||||
-- This head error should never happen
|
||||
instructionDup :: State -> Lens' State [a] -> State
|
||||
instructionDup state accessor =
|
||||
case uncons (view accessor state) of
|
||||
@ -83,26 +95,24 @@ instructionPop state accessor = state & accessor .~ drop 1 (view accessor 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 :: State -> Lens' State [a] -> State
|
||||
instructionDupN :: forall a. State -> Lens' State [a] -> State
|
||||
instructionDupN state accessor =
|
||||
if notEmptyStack state accessor
|
||||
then
|
||||
case uncons (view int state) of
|
||||
Just (i1,_) -> instructionDupNHelper i1 accessor (instructionPop state int)
|
||||
_ -> state
|
||||
else state
|
||||
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 -> Lens' State [a] -> State -> State
|
||||
instructionDupNHelper count internalAccessor internalState =
|
||||
if count > 1 && notEmptyStack internalState int
|
||||
then instructionDupNHelper (count - 1) internalAccessor (instructionDup internalState accessor)
|
||||
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 =
|
||||
if (length . take 2 $ view accessor state) == 2
|
||||
then state & accessor .~ swapper (view accessor state)
|
||||
else state
|
||||
state & accessor .~ swapper (view accessor state)
|
||||
where
|
||||
swapper :: [a] -> [a]
|
||||
swapper (x1 : x2 : xs) = x2 : x1 : xs
|
||||
@ -113,9 +123,7 @@ instructionSwap state accessor =
|
||||
-- an instruction later. Template haskell seems very complicated tho.
|
||||
instructionRot :: State -> Lens' State [a] -> State
|
||||
instructionRot state accessor =
|
||||
if (length . take 3 $ view accessor state) == 3
|
||||
then state & accessor .~ rotator (view accessor state)
|
||||
else state
|
||||
state & accessor .~ rotator (view accessor state)
|
||||
where
|
||||
rotator :: [a] -> [a]
|
||||
rotator (x1 : x2 : x3 : xs) = x3 : x1 : x2 : xs
|
||||
@ -126,20 +134,17 @@ instructionFlush state accessor = state & accessor .~ []
|
||||
|
||||
instructionEq :: forall a. Eq a => State -> Lens' State [a] -> State
|
||||
instructionEq state accessor =
|
||||
if length stackTop == 2
|
||||
-- then state & bool .~ (head stackTop == stackTop !! 1) : view bool state & accessor .~ drop 2 (view accessor state)
|
||||
then
|
||||
case uncons stackTop of
|
||||
Nothing -> state
|
||||
Just (x1, x2 : _) -> state & bool .~ (x1 == x2) : view bool state & accessor .~ drop 2 (view accessor state)
|
||||
Just _ -> state
|
||||
else state
|
||||
case uncons stackTop of
|
||||
Nothing -> state
|
||||
Just (x1, x2 : _) -> state & bool .~ (x1 == x2) : view bool state & accessor .~ drop 2 (view accessor state)
|
||||
Just _ -> state
|
||||
where
|
||||
stackTop :: [a]
|
||||
stackTop = take 2 $ view accessor state
|
||||
|
||||
instructionStackDepth :: State -> Lens' State [a] -> State
|
||||
instructionStackDepth state accessor = state & int .~ (length (view accessor state) : view int state)
|
||||
-- instructionStackDepth state accessor = state & int .~ (length (view accessor state) : view int state)
|
||||
instructionStackDepth state@(State {_int = is}) accessor = state{_int = length (view accessor state) : is}
|
||||
|
||||
-- Will have a non-generic definition for the int stack
|
||||
instructionYankDup :: State -> Lens' State [a] -> State
|
||||
@ -190,3 +195,116 @@ instructionConcat state accessor =
|
||||
-- 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
|
||||
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
|
||||
|
||||
|
||||
@ -94,12 +94,12 @@ instructionStringInsertChar state@(State {_string = s1 : ss, _char = c1 : cs, _i
|
||||
instructionStringInsertChar state = state
|
||||
|
||||
instructionStringContainsChar :: State -> State
|
||||
instructionStringContainsChar state@(State {_string = s1 : ss, _char = c1 : cs, _bool = bs}) = state{_string = ss, _char = cs, _bool = (findSubA s1 [c1] /= -1) : bs}
|
||||
instructionStringContainsChar state = state
|
||||
-- instructionStringContainsChar state@(State {_string = s1 : ss, _char = c1 : cs, _bool = bs}) = state{_string = ss, _char = cs, _bool = (findSubA s1 [c1] /= -1) : bs}
|
||||
-- instructionStringContainsChar state = state
|
||||
instructionStringContainsChar state = instructionVectorContains state char string
|
||||
|
||||
instructionStringIndexOfChar :: State -> State
|
||||
instructionStringIndexOfChar state@(State {_string = s1 : ss, _char = c1 : cs, _int = is}) = state{_string = ss, _char = cs, _int = findSubA s1 [c1] : is}
|
||||
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}
|
||||
@ -130,35 +130,26 @@ instructionStringRemoveAllChar state@(State {_string = s1 : ss, _char = c1 : cs}
|
||||
instructionStringRemoveAllChar state = state
|
||||
|
||||
instructionStringOccurrencesOfChar :: State -> State
|
||||
instructionStringOccurrencesOfChar state@(State {_string = s1 : ss, _char = c1 : cs, _int = is}) = state{_string = ss, _char = cs, _int = amtOccurences s1 [c1] : is}
|
||||
instructionStringOccurrencesOfChar state = state
|
||||
instructionStringOccurrencesOfChar state = instructionVectorOccurrencesOf state char string
|
||||
|
||||
instructionStringReverse :: State -> State
|
||||
instructionStringReverse state@(State {_string = s1 : ss}) = state{_string = reverse s1 : ss}
|
||||
instructionStringReverse state = state
|
||||
instructionStringReverse state = instructionReverse state string
|
||||
|
||||
instructionStringHead :: State -> State
|
||||
instructionStringHead state@(State {_string = s1 : ss, _int = i1 : is}) = state{_string = take (absNum i1 s1) s1 : ss, _int = is}
|
||||
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@(State {_string = s1 : ss, _char = c1 : cs}) = state{_string = (c1 : s1) : ss, _char = cs}
|
||||
instructionStringAppendChar state = state
|
||||
instructionStringAppendChar state = instructionConj state char string
|
||||
|
||||
instructionStringRest :: State -> State
|
||||
instructionStringRest state@(State {_string = s1 : ss}) = state{_string = drop 1 s1 : ss}
|
||||
instructionStringRest state = state
|
||||
instructionStringRest state = instructionRest state string
|
||||
|
||||
instructionStringButLast :: State -> State
|
||||
instructionStringButLast state@(State {_string = s1 : ss}) =
|
||||
if not $ null s1
|
||||
then state{_string = init s1 : ss}
|
||||
else state
|
||||
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}
|
||||
@ -169,11 +160,10 @@ instructionStringButLastN state@(State {_string = s1 : ss, _int = i1 : is}) = st
|
||||
instructionStringButLastN state = state
|
||||
|
||||
instructionStringLength :: State -> State
|
||||
instructionStringLength state@(State {_string = s1 : ss, _int = is}) = state{_string = ss, _int = length s1 : is}
|
||||
instructionStringLength state = state
|
||||
instructionStringLength state = instructionLength state string
|
||||
|
||||
instructionStringMakeEmpty :: State -> State
|
||||
instructionStringMakeEmpty state@(State {_string = ss}) = state{_string = "" : ss}
|
||||
instructionStringMakeEmpty state = instructionVectorMakeEmpty state string
|
||||
|
||||
instructionStringIsEmptyString :: State -> State
|
||||
instructionStringIsEmptyString state@(State {_string = s1 : ss, _bool = bs}) = state{_string = ss, _bool = null s1 : bs}
|
||||
@ -184,8 +174,9 @@ instructionStringRemoveNth state@(State {_string = s1 : ss, _int = i1 : is}) = s
|
||||
instructionStringRemoveNth state = state
|
||||
|
||||
instructionStringSetNth :: State -> State
|
||||
instructionStringSetNth state@(State {_string = s1 : ss, _char = c1 : cs, _int = i1 : is}) = state{_string = replaceAt (absNum i1 s1) c1 s1 : ss, _char = cs, _int = is}
|
||||
instructionStringSetNth state = state
|
||||
-- instructionStringSetNth state@(State {_string = s1 : ss, _char = c1 : cs, _int = i1 : is}) = state{_string = replaceAt (absNum i1 s1) c1 s1 : ss, _char = cs, _int = is}
|
||||
-- instructionStringSetNth state = state
|
||||
instructionStringSetNth state = instructionVectorSetNth state char string
|
||||
|
||||
instructionStringStripWhitespace :: State -> State
|
||||
instructionStringStripWhitespace state@(State {_string = s1 : ss}) = state{_string = strip s1 : ss}
|
||||
|
||||
@ -5,3 +5,51 @@ import State
|
||||
|
||||
instructionIntVectorConcat :: State -> State
|
||||
instructionIntVectorConcat state = instructionConcat state intVector
|
||||
|
||||
instructionIntVectorConj :: State -> State
|
||||
instructionIntVectorConj state = instructionConj state int intVector
|
||||
|
||||
instructionIntVectorTakeN :: State -> State
|
||||
instructionIntVectorTakeN state = instructionTakeN state intVector
|
||||
|
||||
instructionIntVectorSubVector :: State -> State
|
||||
instructionIntVectorSubVector state = instructionSubVector state intVector
|
||||
|
||||
instructionIntVectorFirst :: State -> State
|
||||
instructionIntVectorFirst state = instructionVectorFirst state int intVector
|
||||
|
||||
instructionIntVectorLast :: State -> State
|
||||
instructionIntVectorLast state = instructionVectorLast state int intVector
|
||||
|
||||
instructionIntVectorNth :: State -> State
|
||||
instructionIntVectorNth state = instructionVectorNth state int intVector
|
||||
|
||||
instructionIntVectorRest :: State -> State
|
||||
instructionIntVectorRest state = instructionRest state intVector
|
||||
|
||||
instructionIntVectorButLast :: State -> State
|
||||
instructionIntVectorButLast state = instructionButLast state intVector
|
||||
|
||||
instructionIntVectorLength :: State -> State
|
||||
instructionIntVectorLength state = instructionLength state intVector
|
||||
|
||||
instructionIntVectorReverse :: State -> State
|
||||
instructionIntVectorReverse state = instructionReverse state intVector
|
||||
|
||||
instructionIntVectorPushAll :: State -> State
|
||||
instructionIntVectorPushAll state = instructionPushAll state int intVector
|
||||
|
||||
instructionIntVectorMakeEmpty :: State -> State
|
||||
instructionIntVectorMakeEmpty state = instructionVectorMakeEmpty state intVector
|
||||
|
||||
instructionIntVectorIsEmpty :: State -> State
|
||||
instructionIntVectorIsEmpty state = instructionVectorIsEmpty state intVector
|
||||
|
||||
instructionIntVectorIndexOf :: State -> State
|
||||
instructionIntVectorIndexOf state = instructionVectorIndexOf state int intVector
|
||||
|
||||
instructionIntVectorOccurrencesOf :: State -> State
|
||||
instructionIntVectorOccurrencesOf state = instructionVectorOccurrencesOf state int intVector
|
||||
|
||||
instructionIntVectorSetNth :: State -> State
|
||||
instructionIntVectorSetNth state = instructionVectorSetNth state int intVector
|
||||
|
||||
30
src/LearnLens.hs
Normal file
30
src/LearnLens.hs
Normal file
@ -0,0 +1,30 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module LearnLens where
|
||||
|
||||
import Control.Lens hiding (element)
|
||||
import Control.Lens.TH
|
||||
|
||||
data Atom = Atom {_element :: String, _point :: Point} deriving (Show)
|
||||
|
||||
data Point = Point {_x :: Double, _Y :: Double} deriving (Show)
|
||||
|
||||
$(makeLenses ''Atom)
|
||||
$(makeLenses ''Point)
|
||||
|
||||
myAtom :: Atom
|
||||
myAtom = Atom "climberite" (Point 4.0 3.2)
|
||||
|
||||
shiftAtom :: Atom -> Atom
|
||||
shiftAtom = over (point . x) (+ 1)
|
||||
|
||||
data Molecule = Molecule {_atoms :: [Atom]} deriving (Show)
|
||||
|
||||
$(makeLenses ''Molecule)
|
||||
|
||||
shiftMolecule :: Molecule -> Molecule
|
||||
shiftMolecule = over (atoms . traverse . point . x) (+ 1)
|
||||
|
||||
-- Example without template haskell
|
||||
defPoint :: Lens' Atom Point
|
||||
defPoint = lens _point (\atom newPoint -> atom {_point = newPoint})
|
||||
@ -1,5 +1,3 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Push where
|
||||
|
||||
import Control.Lens
|
||||
|
||||
37
test/Main.hs
37
test/Main.hs
@ -11,9 +11,8 @@ import State
|
||||
|
||||
-- import Debug.Trace
|
||||
|
||||
-- @TODO: Finish int and float tests
|
||||
|
||||
-- TODO: Need a function that can compare states.
|
||||
-- May look at quickCheck later
|
||||
|
||||
intTestFunc :: String -> [Int] -> [Gene] -> State -> IO ()
|
||||
intTestFunc name goal genome startState =
|
||||
@ -61,7 +60,8 @@ main = do
|
||||
intTestFunc "instructionIntMod" [3] [GeneInt 13, GeneInt 5, StateFunc instructionIntMod] emptyState
|
||||
intTestFunc "instructionIntPop" [2] [GeneInt 2, GeneInt 0, StateFunc instructionIntPop] emptyState
|
||||
intTestFunc "instructionIntDup" [3, 3, 2] [GeneInt 2, GeneInt 3, StateFunc instructionIntDup] emptyState
|
||||
intTestFunc "instructionIntDupN" [2, 2, 2] [GeneInt 2, GeneInt 3, StateFunc instructionIntDupN] emptyState
|
||||
intTestFunc "instructionIntDupN3" [2, 2, 2] [GeneInt 2, GeneInt 3, StateFunc instructionIntDupN] emptyState
|
||||
intTestFunc "instructionIntDupN-1" [0] [GeneInt 0, GeneInt 2, GeneInt (-1), StateFunc instructionIntDupN] emptyState
|
||||
intTestFunc "instructionIntSwap" [2, 0, 3] [GeneInt 3, GeneInt 2, GeneInt 0, StateFunc instructionIntSwap] emptyState
|
||||
intTestFunc "instructionIntSwapFail" [1] [GeneInt 1, StateFunc instructionIntSwap] emptyState
|
||||
intTestFunc "instructionIntRot" [1, 3, 2] [GeneInt 1, GeneInt 2, GeneInt 3, StateFunc instructionIntRot] emptyState
|
||||
@ -96,8 +96,10 @@ main = do
|
||||
floatTestFunc "instructionFloatYankDup" [1.1, 4.4, 3.3, 2.2, 1.1] [GeneInt 3, GeneFloat 1.1, GeneFloat 2.2, GeneFloat 3.3, GeneFloat 4.4, StateFunc instructionFloatYankDup] emptyState
|
||||
floatTestFunc "instructionFloatShove" [3.3, 2.2, 4.4, 1.1] [GeneInt 3, GeneFloat 1.1, GeneFloat 2.2, GeneFloat 3.3, GeneFloat 4.4, StateFunc instructionFloatShove] emptyState
|
||||
floatTestFunc "instructionFloatShoveDup" [4.4, 3.3, 2.2, 4.4, 1.1] [GeneInt 3, GeneFloat 1.1, GeneFloat 2.2, GeneFloat 3.3, GeneFloat 4.4, StateFunc instructionFloatShoveDup] emptyState
|
||||
|
||||
-- Bool tests
|
||||
floatTestFunc "instructionFloatDupNonEmpty" [4.4, 4.4, 3.3] [GeneFloat 3.3, GeneFloat 4.4, StateFunc instructionFloatDup] emptyState
|
||||
floatTestFunc "instructionFloatDupEmpty" [] [StateFunc instructionFloatDup] emptyState
|
||||
floatTestFunc "instructionFloatDupN3" [4.4, 4.4, 4.4, 3.3] [GeneFloat 3.3, GeneFloat 4.4, GeneInt 3, StateFunc instructionFloatDupN] emptyState
|
||||
floatTestFunc "instructionFloatDupN-1" [3.3] [GeneFloat 3.3, GeneFloat 4.4, GeneInt (-1), StateFunc instructionFloatDupN] emptyState
|
||||
boolTestFunc "instructionIntEqTrue" [True] [GeneInt 3, GeneInt 3, StateFunc instructionIntEq] emptyState
|
||||
boolTestFunc "instructionIntEqFalse" [False] [GeneInt 3, GeneInt 5, StateFunc instructionIntEq] emptyState
|
||||
boolTestFunc "instructionIntEqFail" [] [GeneInt 3, StateFunc instructionIntEq] emptyState
|
||||
@ -256,3 +258,28 @@ main = do
|
||||
|
||||
-- vector int instructions
|
||||
intVectorTestFunc "instructionIntVectorConcat" [[4, 5, 6, 1, 2, 3]] [GeneIntVector [1, 2, 3], GeneIntVector [4, 5, 6], StateFunc instructionIntVectorConcat] emptyState
|
||||
intVectorTestFunc "instructionIntVectorConj" [[99, 1, 2, 3]] [GeneIntVector [1, 2, 3], GeneInt 99, StateFunc instructionIntVectorConj] emptyState
|
||||
intVectorTestFunc "instructionIntTakeN" [[1, 2], [6, 7, 8]] [GeneIntVector [6, 7, 8], GeneIntVector [1, 2, 3], GeneInt 2, StateFunc instructionIntVectorTakeN] emptyState
|
||||
intVectorTestFunc "instructionIntVectorSubVector" [[1, 2, 3]] [GeneIntVector [0, 1, 2, 3, 4, 5], GeneInt 3, GeneInt 1, StateFunc instructionIntVectorSubVector] emptyState
|
||||
intTestFunc "instructionIntVectorFirst" [1] [GeneIntVector [1,2,3,4,5], StateFunc instructionIntVectorFirst] emptyState
|
||||
intTestFunc "instructionIntVectorLast" [5] [GeneIntVector [1,2,3,4,5], StateFunc instructionIntVectorLast] emptyState
|
||||
intTestFunc "instructionIntVectorNthInBounds" [2] [GeneIntVector [1,2,3,4,5], GeneInt 1, StateFunc instructionIntVectorNth] emptyState
|
||||
intTestFunc "instructionIntVectorNthOverflow" [2] [GeneIntVector [1,2,3,4,5], GeneInt 6, StateFunc instructionIntVectorNth] emptyState
|
||||
intVectorTestFunc "instructionIntVectorRestFull" [[2,3,4,5]] [GeneIntVector [1,2,3,4,5], StateFunc instructionIntVectorRest] emptyState
|
||||
intVectorTestFunc "instructionIntVectorRestEmpty" [[]] [GeneIntVector [], StateFunc instructionIntVectorRest] emptyState
|
||||
intVectorTestFunc "instructionIntVectorButLastFull" [[1,2,3,4]] [GeneIntVector [1,2,3,4,5], StateFunc instructionIntVectorButLast] emptyState
|
||||
intVectorTestFunc "instructionIntVectorButLastEmpty" [[]] [GeneIntVector [], StateFunc instructionIntVectorButLast] emptyState
|
||||
intTestFunc "instructionIntVectorLength3" [3] [GeneIntVector [1,2,3], StateFunc instructionIntVectorLength] emptyState
|
||||
intTestFunc "instructionIntVectorLength0" [0] [GeneIntVector [], StateFunc instructionIntVectorLength] emptyState
|
||||
intVectorTestFunc "instructionIntVectorReverse" [[4,3,2,1]] [GeneIntVector [1,2,3,4], StateFunc instructionIntVectorReverse] emptyState
|
||||
intTestFunc "instructionIntVectorPushAllFull" [1,2,3,4,99] [GeneIntVector [1,2,3,4], GeneInt 99, StateFunc instructionIntVectorPushAll] emptyState
|
||||
intTestFunc "instructionIntVectorPushAllEmpty" [99] [GeneIntVector [], GeneInt 99, StateFunc instructionIntVectorPushAll] emptyState
|
||||
intVectorTestFunc "instructionIntVectorMakeEmpty" [[]] [StateFunc instructionIntVectorMakeEmpty] emptyState
|
||||
boolTestFunc "instructionIntVectorIsEmptyTrue" [True] [GeneIntVector [], StateFunc instructionIntVectorIsEmpty] emptyState
|
||||
boolTestFunc "instructionIntVectorIsEmptyFalse" [False] [GeneIntVector [1,2,3,4], StateFunc instructionIntVectorIsEmpty] emptyState
|
||||
intTestFunc "instructionIntVectorIndexOf1" [1] [GeneIntVector [1,2,3,4,5], GeneInt 2, StateFunc instructionIntVectorIndexOf] emptyState
|
||||
intTestFunc "instructionIntVectorIndexOfFail" [-1] [GeneIntVector [], GeneInt 2, StateFunc instructionIntVectorIndexOf] emptyState
|
||||
intTestFunc "instructionIntVectorOccurrencesOf2" [2] [GeneIntVector [1,2,3,4,2,6,7], GeneInt 2, StateFunc instructionIntVectorOccurrencesOf] emptyState
|
||||
intTestFunc "instructionIntVectorOccurrencesOf0" [0] [GeneIntVector [1,2,3,4,2,6,7], GeneInt 0, StateFunc instructionIntVectorOccurrencesOf] emptyState
|
||||
intVectorTestFunc "instructionIntVectorSetNth3" [[0,1,2,99,4,5]] [GeneIntVector [0,1,2,3,4,5], GeneInt 99, GeneInt 3, StateFunc instructionIntVectorSetNth] emptyState
|
||||
intVectorTestFunc "instructionIntVectorSetNth9" [[0,1,2,99,4,5]] [GeneIntVector [0,1,2,3,4,5], GeneInt 99, GeneInt 9, StateFunc instructionIntVectorSetNth] emptyState
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user