a lot of genericization and updates

This commit is contained in:
Rowan Torbitzky-Lane 2025-01-28 22:09:30 -06:00
parent 035a7a2f10
commit 363425b39b
7 changed files with 275 additions and 77 deletions

View File

@ -2,11 +2,10 @@ module Instructions.CharInstructions where
import Data.Char import Data.Char
import State import State
import Data.List (uncons)
-- import Instructions.GenericInstructions
import Instructions.StringInstructions (wschars) 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) intToAscii val = chr (abs (fromIntegral val) `mod` 128)
instructionCharConcat :: State -> State instructionCharConcat :: State -> State
@ -14,26 +13,13 @@ instructionCharConcat state@(State {_char = c1 : c2 : cs, _string = ss}) = state
instructionCharConcat state = state instructionCharConcat state = state
instructionCharFromFirstChar :: State -> State instructionCharFromFirstChar :: State -> State
instructionCharFromFirstChar state@(State {_char = cs, _string = s1 : ss}) = instructionCharFromFirstChar state = instructionVectorFirst state char string
case uncons s1 of
Nothing -> state
Just (x,_) -> state {_char = x : cs, _string = ss}
instructionCharFromFirstChar state = state
instructionCharFromLastChar :: State -> State instructionCharFromLastChar :: State -> State
instructionCharFromLastChar state@(State {_char = cs, _string = s1 : ss}) = instructionCharFromLastChar state = instructionVectorLast state char string
if not $ null s1
then state {_char = last s1 : cs, _string = ss}
else state
instructionCharFromLastChar state = state
instructionCharFromNthChar :: State -> State instructionCharFromNthChar :: State -> State
instructionCharFromNthChar state@(State {_char = cs, _string = s1 : ss, _int = i1 : is}) = instructionCharFromNthChar state = instructionVectorNth state char string
let
index = abs i1 `mod` length s1
in
state{_char = s1 !! index : cs, _string = ss, _int = is}
instructionCharFromNthChar state = state
instructionCharIsWhitespace :: State -> State instructionCharIsWhitespace :: State -> State
instructionCharIsWhitespace state@(State {_char = c1 : cs, _bool = bs}) = state{_char = cs, _bool = (c1 `elem` wschars) : bs} instructionCharIsWhitespace state@(State {_char = c1 : cs, _bool = bs}) = state{_char = cs, _bool = (c1 `elem` wschars) : bs}

View File

@ -20,6 +20,15 @@ insertAt idx val xs = combineTuple val (splitAt idx xs)
replaceAt :: Int -> a -> [a] -> [a] replaceAt :: Int -> a -> [a] -> [a]
replaceAt idx val xs = deleteAt (idx + 1) (insertAt idx val xs) 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 :: forall a. Eq a => [a] -> [a] -> Int
findSubA fullA subA findSubA fullA subA
| length fullA < length subA = -1 | length fullA < length subA = -1
@ -62,13 +71,16 @@ takeR amt fullA = drop (length fullA - amt) fullA
dropR :: Int -> [a] -> [a] dropR :: Int -> [a] -> [a]
dropR amt fullA = take (length fullA - amt) fullA dropR amt fullA = take (length fullA - amt) fullA
safeInit :: [a] -> [a]
safeInit [] = []
safeInit xs = init xs
absNum :: Integral a => a -> [b] -> Int absNum :: Integral a => a -> [b] -> Int
absNum rawNum lst = abs (fromIntegral rawNum) `mod` length lst absNum rawNum lst = abs (fromIntegral rawNum) `mod` length lst
notEmptyStack :: State -> Lens' State [a] -> Bool notEmptyStack :: State -> Lens' State [a] -> Bool
notEmptyStack state accessor = not . null $ view accessor state notEmptyStack state accessor = not . null $ view accessor state
-- This head error should never happen
instructionDup :: State -> Lens' State [a] -> State instructionDup :: State -> Lens' State [a] -> State
instructionDup state accessor = instructionDup state accessor =
case uncons (view accessor state) of 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 -- 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. -- 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 = instructionDupN state accessor =
if notEmptyStack state accessor case uncons (view int state) of
then Just (i1,is) ->
case uncons (view int state) of case uncons (view accessor state{_int = is}) of
Just (i1,_) -> instructionDupNHelper i1 accessor (instructionPop state int) Just (a1,as) -> instructionDupNHelper i1 a1 accessor (state{_int = is} & accessor .~ as)
_ -> state _ -> state
else state _ -> state
where where
instructionDupNHelper :: Int -> Lens' State [a] -> State -> State instructionDupNHelper :: Int -> a -> Lens' State [a] -> State -> State
instructionDupNHelper count internalAccessor internalState = instructionDupNHelper count instruction internalAccessor internalState =
if count > 1 && notEmptyStack internalState int if count > 0
then instructionDupNHelper (count - 1) internalAccessor (instructionDup internalState accessor) then instructionDupNHelper (count - 1) instruction internalAccessor (internalState & accessor .~ (instruction : view accessor internalState))
else internalState else internalState
instructionSwap :: State -> Lens' State [a] -> State instructionSwap :: State -> Lens' State [a] -> State
instructionSwap state accessor = instructionSwap state accessor =
if (length . take 2 $ view accessor state) == 2 state & accessor .~ swapper (view accessor state)
then state & accessor .~ swapper (view accessor state)
else state
where where
swapper :: [a] -> [a] swapper :: [a] -> [a]
swapper (x1 : x2 : xs) = x2 : x1 : xs swapper (x1 : x2 : xs) = x2 : x1 : xs
@ -113,9 +123,7 @@ instructionSwap state accessor =
-- an instruction later. Template haskell seems very complicated tho. -- an instruction later. Template haskell seems very complicated tho.
instructionRot :: State -> Lens' State [a] -> State instructionRot :: State -> Lens' State [a] -> State
instructionRot state accessor = instructionRot state accessor =
if (length . take 3 $ view accessor state) == 3 state & accessor .~ rotator (view accessor state)
then state & accessor .~ rotator (view accessor state)
else state
where where
rotator :: [a] -> [a] rotator :: [a] -> [a]
rotator (x1 : x2 : x3 : xs) = x3 : x1 : x2 : xs 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 :: forall a. Eq a => State -> Lens' State [a] -> State
instructionEq state accessor = instructionEq state accessor =
if length stackTop == 2 case uncons stackTop of
-- then state & bool .~ (head stackTop == stackTop !! 1) : view bool state & accessor .~ drop 2 (view accessor state) Nothing -> state
then Just (x1, x2 : _) -> state & bool .~ (x1 == x2) : view bool state & accessor .~ drop 2 (view accessor state)
case uncons stackTop of Just _ -> state
Nothing -> state
Just (x1, x2 : _) -> state & bool .~ (x1 == x2) : view bool state & accessor .~ drop 2 (view accessor state)
Just _ -> state
else state
where where
stackTop :: [a] stackTop :: [a]
stackTop = take 2 $ view accessor state stackTop = take 2 $ view accessor state
instructionStackDepth :: State -> Lens' State [a] -> 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 -- Will have a non-generic definition for the int stack
instructionYankDup :: State -> Lens' State [a] -> State instructionYankDup :: State -> Lens' State [a] -> State
@ -190,3 +195,116 @@ instructionConcat state accessor =
-- evolve fodder??????????? -- evolve fodder???????????
instructionNoOp :: State -> State instructionNoOp :: State -> State
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

View File

@ -94,12 +94,12 @@ instructionStringInsertChar state@(State {_string = s1 : ss, _char = c1 : cs, _i
instructionStringInsertChar state = state instructionStringInsertChar state = state
instructionStringContainsChar :: 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 {_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
instructionStringContainsChar state = instructionVectorContains state char string
instructionStringIndexOfChar :: State -> State 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 = instructionVectorIndexOf state char string
instructionStringIndexOfChar state = state
instructionStringSplitOnChar :: State -> State instructionStringSplitOnChar :: State -> State
instructionStringSplitOnChar state@(State {_string = s1 : ss, _char = c1 : cs}) = state {_string = reverse $ splitOn [c1] s1 <> ss, _char = cs} 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 instructionStringRemoveAllChar state = state
instructionStringOccurrencesOfChar :: 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 = instructionVectorOccurrencesOf state char string
instructionStringOccurrencesOfChar state = state
instructionStringReverse :: State -> State instructionStringReverse :: State -> State
instructionStringReverse state@(State {_string = s1 : ss}) = state{_string = reverse s1 : ss} instructionStringReverse state = instructionReverse state string
instructionStringReverse state = state
instructionStringHead :: State -> State instructionStringHead :: State -> State
instructionStringHead state@(State {_string = s1 : ss, _int = i1 : is}) = state{_string = take (absNum i1 s1) s1 : ss, _int = is} instructionStringHead state = instructionTakeN state string
instructionStringHead state = state
instructionStringTail :: State -> State 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 {_string = s1 : ss, _int = i1 : is}) = state{_string = takeR (absNum i1 s1) s1 : ss, _int = is}
instructionStringTail state = state instructionStringTail state = state
instructionStringAppendChar :: State -> State instructionStringAppendChar :: State -> State
instructionStringAppendChar state@(State {_string = s1 : ss, _char = c1 : cs}) = state{_string = (c1 : s1) : ss, _char = cs} instructionStringAppendChar state = instructionConj state char string
instructionStringAppendChar state = state
instructionStringRest :: State -> State instructionStringRest :: State -> State
instructionStringRest state@(State {_string = s1 : ss}) = state{_string = drop 1 s1 : ss} instructionStringRest state = instructionRest state string
instructionStringRest state = state
instructionStringButLast :: State -> State instructionStringButLast :: State -> State
instructionStringButLast state@(State {_string = s1 : ss}) = instructionStringButLast state = instructionButLast state string
if not $ null s1
then state{_string = init s1 : ss}
else state
instructionStringButLast state = state
instructionStringDrop :: State -> State 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 {_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 instructionStringButLastN state = state
instructionStringLength :: State -> State instructionStringLength :: State -> State
instructionStringLength state@(State {_string = s1 : ss, _int = is}) = state{_string = ss, _int = length s1 : is} instructionStringLength state = instructionLength state string
instructionStringLength state = state
instructionStringMakeEmpty :: State -> State instructionStringMakeEmpty :: State -> State
instructionStringMakeEmpty state@(State {_string = ss}) = state{_string = "" : ss} instructionStringMakeEmpty state = instructionVectorMakeEmpty state string
instructionStringIsEmptyString :: State -> State instructionStringIsEmptyString :: State -> State
instructionStringIsEmptyString state@(State {_string = s1 : ss, _bool = bs}) = state{_string = ss, _bool = null s1 : bs} 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 instructionStringRemoveNth state = state
instructionStringSetNth :: 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 {_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
instructionStringSetNth state = instructionVectorSetNth state char string
instructionStringStripWhitespace :: State -> State instructionStringStripWhitespace :: State -> State
instructionStringStripWhitespace state@(State {_string = s1 : ss}) = state{_string = strip s1 : ss} instructionStringStripWhitespace state@(State {_string = s1 : ss}) = state{_string = strip s1 : ss}

View File

@ -5,3 +5,51 @@ import State
instructionIntVectorConcat :: State -> State instructionIntVectorConcat :: State -> State
instructionIntVectorConcat state = instructionConcat state intVector 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
View 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})

View File

@ -1,5 +1,3 @@
{-# LANGUAGE RecordWildCards #-}
module Push where module Push where
import Control.Lens import Control.Lens

View File

@ -11,9 +11,8 @@ import State
-- import Debug.Trace -- import Debug.Trace
-- @TODO: Finish int and float tests
-- TODO: Need a function that can compare states. -- TODO: Need a function that can compare states.
-- May look at quickCheck later
intTestFunc :: String -> [Int] -> [Gene] -> State -> IO () intTestFunc :: String -> [Int] -> [Gene] -> State -> IO ()
intTestFunc name goal genome startState = intTestFunc name goal genome startState =
@ -61,7 +60,8 @@ main = do
intTestFunc "instructionIntMod" [3] [GeneInt 13, GeneInt 5, StateFunc instructionIntMod] emptyState intTestFunc "instructionIntMod" [3] [GeneInt 13, GeneInt 5, StateFunc instructionIntMod] emptyState
intTestFunc "instructionIntPop" [2] [GeneInt 2, GeneInt 0, StateFunc instructionIntPop] emptyState intTestFunc "instructionIntPop" [2] [GeneInt 2, GeneInt 0, StateFunc instructionIntPop] emptyState
intTestFunc "instructionIntDup" [3, 3, 2] [GeneInt 2, GeneInt 3, StateFunc instructionIntDup] 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 "instructionIntSwap" [2, 0, 3] [GeneInt 3, GeneInt 2, GeneInt 0, StateFunc instructionIntSwap] emptyState
intTestFunc "instructionIntSwapFail" [1] [GeneInt 1, 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 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 "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 "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 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
floatTestFunc "instructionFloatDupNonEmpty" [4.4, 4.4, 3.3] [GeneFloat 3.3, GeneFloat 4.4, StateFunc instructionFloatDup] emptyState
-- Bool tests 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 "instructionIntEqTrue" [True] [GeneInt 3, GeneInt 3, StateFunc instructionIntEq] emptyState
boolTestFunc "instructionIntEqFalse" [False] [GeneInt 3, GeneInt 5, StateFunc instructionIntEq] emptyState boolTestFunc "instructionIntEqFalse" [False] [GeneInt 3, GeneInt 5, StateFunc instructionIntEq] emptyState
boolTestFunc "instructionIntEqFail" [] [GeneInt 3, StateFunc instructionIntEq] emptyState boolTestFunc "instructionIntEqFail" [] [GeneInt 3, StateFunc instructionIntEq] emptyState
@ -256,3 +258,28 @@ main = do
-- vector int instructions -- vector int instructions
intVectorTestFunc "instructionIntVectorConcat" [[4, 5, 6, 1, 2, 3]] [GeneIntVector [1, 2, 3], GeneIntVector [4, 5, 6], StateFunc instructionIntVectorConcat] emptyState 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