diff --git a/src/Instructions/ExecInstructions.hs b/src/Instructions/ExecInstructions.hs index bd27ec2..cb28fb2 100644 --- a/src/Instructions/ExecInstructions.hs +++ b/src/Instructions/ExecInstructions.hs @@ -2,6 +2,7 @@ module Instructions.ExecInstructions where import State import Instructions.IntInstructions +import Instructions.GenericInstructions instructionExecIf :: State -> State instructionExecIf state@(State {_exec = (e1 : e2 : es), _bool = (b : _)}) = @@ -11,9 +12,25 @@ instructionExecIf state@(State {_exec = (e1 : e2 : es), _bool = (b : _)}) = instructionExecIf state = state instructionExecDup :: State -> State -instructionExecDup state@(State {_exec = alles@(e : _)}) = - state {_exec = e : alles} -instructionExecDup state = state +instructionExecDup state = instructionDup state exec + +instructionExecDupN :: State -> State +instructionExecDupN state = instructionDupN state exec + +instructionExecPop :: State -> State +instructionExecPop state = instructionPop state exec + +instructionExecSwap :: State -> State +instructionExecSwap state = instructionSwap state exec + +instructionExecRot :: State -> State +instructionExecRot state = instructionRot state exec + +instructionExecFlush :: State -> State +instructionExecFlush state = instructionFlush state exec + +instructionExecEq :: State -> State +instructionExecEq state = instructionEq state exec instructionExecDoRange :: State -> State instructionExecDoRange state@(State {_exec = (e1 : es), _int = (i0 : i1 : is)}) = diff --git a/src/Instructions/FloatInstructions.hs b/src/Instructions/FloatInstructions.hs index 8d9c834..fc05e0f 100644 --- a/src/Instructions/FloatInstructions.hs +++ b/src/Instructions/FloatInstructions.hs @@ -1,5 +1,6 @@ module Instructions.FloatInstructions where +import Instructions.GenericInstructions import State instructionFloatAdd :: State -> State @@ -51,6 +52,22 @@ instructionFloatGTE state@(State {_float = f1 : f2 : fs, _bool = bs}) = state {_ instructionFloatGTE state = state instructionFloatPop :: State -> State -instructionFloatPop state@(State {_float = (_ : fs)}) = state {_float = fs} -instructionFloatPop state = state +instructionFloatPop state = instructionPop state float +instructionFloatDup :: State -> State +instructionFloatDup state = instructionPop state float + +instructionFloatDupN :: State -> State +instructionFloatDupN state = instructionDupN state float + +instructionFloatSwap :: State -> State +instructionFloatSwap state = instructionSwap state float + +instructionFloatRot :: State -> State +instructionFloatRot state = instructionRot state float + +instructionFloatFlush :: State -> State +instructionFloatFlush state = instructionFlush state float + +instructionFloatEq :: State -> State +instructionFloatEq state = instructionEq state float diff --git a/src/Instructions/GenericInstructions.hs b/src/Instructions/GenericInstructions.hs new file mode 100644 index 0000000..a1ff7ba --- /dev/null +++ b/src/Instructions/GenericInstructions.hs @@ -0,0 +1,65 @@ +module Instructions.GenericInstructions where + +import Control.Lens +import State + +-- import Debug.Trace + +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 diff --git a/src/Instructions/IntInstructions.hs b/src/Instructions/IntInstructions.hs index 3d25aa4..87d9112 100644 --- a/src/Instructions/IntInstructions.hs +++ b/src/Instructions/IntInstructions.hs @@ -1,6 +1,7 @@ module Instructions.IntInstructions where import State +import Instructions.GenericInstructions -- import Debug.Trace instructionIntAdd :: State -> State @@ -55,6 +56,23 @@ instructionIntGTE :: State -> State instructionIntGTE state@(State {_int = i1 : i2 : is, _bool = bs}) = state {_int = is, _bool = (i1 >= i2) : bs} instructionIntGTE state = state +instructionIntDup :: State -> State +instructionIntDup state = instructionDup state int + instructionIntPop :: State -> State -instructionIntPop state@(State {_int = (_ : is)}) = state {_int = is} -instructionIntPop state = state +instructionIntPop state = instructionPop state int + +instructionIntDupN :: State -> State +instructionIntDupN state = instructionDupN state int + +instructionIntSwap :: State -> State +instructionIntSwap state = instructionSwap state int + +instructionIntRot :: State -> State +instructionIntRot state = instructionRot state int + +instructionIntFlush :: State -> State +instructionIntFlush state = instructionFlush state int + +instructionIntEq :: State -> State +instructionIntEq state = instructionEq state int