181 lines
6.9 KiB
Haskell
181 lines
6.9 KiB
Haskell
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)
|
|
|
|
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)
|
|
|
|
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
|
|
|
|
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
|
|
|
|
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 = if notEmptyStack state accessor then state & accessor .~ head (view accessor state) : view accessor state else state
|
|
|
|
instructionPop :: State -> Lens' State [a] -> State
|
|
instructionPop state accessor = if notEmptyStack state accessor then state & accessor .~ drop 1 (view accessor state) 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 :: State -> Lens' State [a] -> State
|
|
instructionDupN state accessor =
|
|
if notEmptyStack state accessor && notEmptyStack state int
|
|
then instructionDupNHelper (head (view int state)) accessor (instructionPop state int)
|
|
else 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)
|
|
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
|
|
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 =
|
|
if (length . take 3 $ view accessor state) == 3
|
|
then state & accessor .~ rotator (view accessor state)
|
|
else 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 =
|
|
if length stackTop == 2
|
|
then state & bool .~ (head stackTop == stackTop !! 1) : view bool state & accessor .~ drop 2 (view accessor state)
|
|
else 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)
|
|
|
|
-- Will have a non-generic definition for the int stack
|
|
instructionYankDup :: State -> Lens' State [a] -> State
|
|
instructionYankDup state@(State {_int = i : is}) accessor =
|
|
if notEmptyStack state accessor
|
|
then (state & accessor .~ (view accessor state !! max 0 (min i (length (view accessor state) - 1))) : view accessor state) {_int = is}
|
|
else state
|
|
instructionYankDup state@(State {_int = []}) _ = state
|
|
|
|
-- Is this optimal? Running instrucitonYankDup twice?????
|
|
-- int non generic too
|
|
instructionYank :: forall a. State -> Lens' State [a] -> State
|
|
instructionYank state@(State {_int = rawIndex : _}) accessor =
|
|
let
|
|
myIndex :: Int
|
|
myIndex = max 0 (min rawIndex (length (view accessor state) - 1))
|
|
item :: a
|
|
item = view accessor state !! myIndex
|
|
deletedState :: State
|
|
deletedState = state & accessor .~ deleteAt myIndex (view accessor state)
|
|
in
|
|
if notEmptyStack state accessor then deletedState & accessor .~ item : view accessor deletedState else state
|
|
instructionYank state _ = state
|
|
|
|
-- int non generic :(
|
|
-- Rewrite this eventually?
|
|
instructionShoveDup :: State -> Lens' State [a] -> State
|
|
instructionShoveDup state@(State {_int = i : is}) accessor =
|
|
if notEmptyStack state accessor
|
|
then (state & accessor .~ combineTuple (head $ view accessor state) (splitAt (max 0 (min i (length (view accessor state) - 1))) (view accessor state))) {_int = is}
|
|
else state
|
|
instructionShoveDup state@(State {_int = []}) _ = state
|
|
|
|
-- also also not int generic
|
|
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 =
|
|
if (length . take 2 $ view accessor state) == 2
|
|
then droppedState & accessor .~ (head (view accessor state) <> view accessor state !! 1) : view accessor droppedState
|
|
-- then undefined
|
|
else state
|
|
where
|
|
droppedState :: State
|
|
droppedState = state & accessor .~ drop 2 (view accessor state)
|
|
|
|
-- evolve fodder???????????
|
|
instructionNoOp :: State -> State
|
|
instructionNoOp state = state
|