genericize generic instructions

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)}) =

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

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

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