Tehee

.gitignore

@@ -31,3 +31,5 @@ result-*
 # Ignore automatically generated direnv output
 .direnv
 
+# Ignore spec
+gbctr.pdf

src/GB/CPU.hs

@@ -63,24 +63,43 @@ data Registers = Registers { _a     :: Word8
 makeLenses ''Registers
 
 getBC :: Registers -> Word16
-getBC r = (flip shiftL 8 . fromIntegral $ r ^. b) + (fromIntegral $ r ^. c)
+getBC r = (( .<<. 8) . fromIntegral $ r ^. b) + (fromIntegral $ r ^. c)
 
 setBC :: Registers -> Word16 -> Registers
-setBC r w = r & b %~ (const $ fromIntegral $ shiftR w 8) & c %~ (const $ fromIntegral $ w .&. 255)
+setBC r w = r & b %~ (const $ fromIntegral $ w .>>. 8) & c %~ (const $ fromIntegral $ w .&. 255)
+
+getHL :: Registers -> Word16
+getHL r = ((.<<. 8) . fromIntegral $ r ^. h) + (fromIntegral $ r ^. l)
+
+setHL :: Registers -> Word16 -> Registers
+setHL r w = r & h %~ (const $ fromIntegral $ w .>>. 8) & l %~ (const $ fromIntegral $ w .&. 255)
 
 data CPU = CPU { _registers :: Registers
                , _pc :: Word16
+               , _sp :: Word16
                , _bus :: (V.Vector 65536 Word8) }
 makeLenses ''CPU
 
 data ArithmeticTarget = A | B | C | D | E | H | L
 
 data Instruction where
-  Add :: ArithmeticTarget -> Instruction
+  AddR :: ArithmeticTarget -> Bool -> Instruction
+  AddHL :: Bool -> Instruction
+  AddN :: Word8 -> Bool -> Instruction
+  SubR :: ArithmeticTarget -> Bool -> Instruction
+  SubHL :: Bool -> Instruction
+  SubN :: Word8 -> Bool -> Instruction
+  CpR :: ArithmeticTarget -> Bool -> Instruction
+  CpHL :: Bool -> Instruction
+  CpN :: Word8 -> Bool -> Instruction
+  IncR :: ArithmeticTarget -> Instruction
+  IncHL :: Instruction
+  DecR :: ArithmeticTarget -> Instruction
+  DecHL :: Instruction
 
 execute :: CPU -> Instruction -> CPU
 execute cpu = \case
-  Add t -> let value = case t of
+  AddR t _c -> let value = case t of
                      A -> cpu ^. registers . a
                      B -> cpu ^. registers . b
                      C -> cpu ^. registers . c
@@ -88,14 +107,86 @@ execute cpu = \case
                      E -> cpu ^. registers . e
                      H -> cpu ^. registers . h
                      L -> cpu ^. registers . l
-               (newValue, newFlags) = add (cpu ^. registers . a) value in
+                   (newValue, newFlags) = add (cpu ^. registers . a) value $ _c && cpu ^. registers . flags . carry in
             cpu & registers . a %~ const newValue & registers . flags %~ const newFlags
+  AddHL _c -> let value = fetch cpu . getHL $ cpu ^. registers
+                  (newValue, newFlags) = add (cpu ^. registers . a) value $ _c && cpu ^. registers . flags . carry in
+           cpu & registers . a %~ const newValue & registers . flags %~ const newFlags
+  AddN value _c -> let (newValue, newFlags) = add (cpu ^. registers . a) value $ _c && cpu ^. registers .flags . carry in
+                cpu & registers . a %~ const newValue & registers . flags %~ const newFlags
+  SubR t _c -> let value = case t of
+                     A -> cpu ^. registers . a
+                     B -> cpu ^. registers . b
+                     C -> cpu ^. registers . c
+                     D -> cpu ^. registers . d
+                     E -> cpu ^. registers . e
+                     H -> cpu ^. registers . h
+                     L -> cpu ^. registers . l
+                   (newValue, newFlags) = sub (cpu ^. registers . a) value $ _c && cpu ^. registers . flags . carry in
+            cpu & registers . a %~ const newValue & registers . flags %~ const newFlags
+  SubHL _c -> let value = fetch cpu . getHL $ cpu ^. registers
+                  (newValue, newFlags) = sub (cpu ^. registers . a) value $ _c && cpu ^. registers . flags . carry in
+           cpu & registers . a %~ const newValue & registers . flags %~ const newFlags
+  SubN value _c -> let (newValue, newFlags) = sub (cpu ^. registers . a) value $ _c && cpu ^. registers .flags . carry in
+                cpu & registers . a %~ const newValue & registers . flags %~ const newFlags
+  CpR t _c -> let value = case t of
+                     A -> cpu ^. registers . a
+                     B -> cpu ^. registers . b
+                     C -> cpu ^. registers . c
+                     D -> cpu ^. registers . d
+                     E -> cpu ^. registers . e
+                     H -> cpu ^. registers . h
+                     L -> cpu ^. registers . l
+                  (_, newFlags) = sub (cpu ^. registers . a) value $ _c && cpu ^. registers . flags . carry in
+            cpu & registers . flags %~ const newFlags
+  CpHL _c -> let value = fetch cpu . getHL $ cpu ^. registers
+                 (_, newFlags) = sub (cpu ^. registers . a) value $ _c && cpu ^. registers . flags . carry in
+           cpu & registers . flags %~ const newFlags
+  CpN value _c -> let (_, newFlags) = sub (cpu ^. registers . a) value $ _c && cpu ^. registers .flags . carry in
+                cpu & registers . flags %~ const newFlags
+  IncR t -> let (target, target') = case t of
+                     A -> (a,a)
+                     B -> (b,b)
+                     C -> (c,c)
+                     D -> (d,d)
+                     E -> (e,e)
+                     H -> (h,h)
+                     L -> (l,l)
+                (value, newFlags) = add (cpu ^. registers . target) 1 False in
+            cpu & registers . target' %~ const value & registers . flags %~ const newFlags
+  IncHL -> let target = getHL $ cpu ^. registers
+               value = fetch cpu target
+               (newValue, newFlags) = add value 1 False in
+            cpu & bus %~ (flip V.update $ V.singleton (fromIntegral target, newValue)) & registers . flags %~ const newFlags
+  DecR t -> let (target, target') = case t of
+                     A -> (a,a)
+                     B -> (b,b)
+                     C -> (c,c)
+                     D -> (d,d)
+                     E -> (e,e)
+                     H -> (h,h)
+                     L -> (l,l)
+                (value, newFlags) = sub (cpu ^. registers . target) 1 False in
+            cpu & registers . target' %~ const value & registers . flags %~ const newFlags
+  DecHL -> let target = getHL $ cpu ^. registers
+               value = fetch cpu target
+               (newValue, newFlags) = sub value 1 False in
+            cpu & bus %~ (flip V.update $ V.singleton (fromIntegral target, newValue)) & registers . flags %~ const newFlags
+  where
+    add :: Word8 -> Word8 -> Bool -> (Word8, FlagRegister)
+    add o n _c = let new        = o + n + if _c then 1 else 0
+                     _zero      = new == 0
+                     _subtract  = False
+                     _carry     = o > new
+                     _halfCarry = o .&. 16 + n .&. 16 > 16 in
+                 (new, FlagRegister {..})
+    fetch :: CPU -> Word16 -> Word8
+    fetch _cpu addr = flip V.index (fromIntegral addr) $ _cpu ^. bus
 
-  where add :: Word8 -> Word8 -> (Word8, FlagRegister)
+    sub :: Word8 -> Word8 -> Bool -> (Word8, FlagRegister)
-        add o n =
+    sub o n _c = let new        = o - n - if _c then 1 else 0
-          let new = o + n
+                     _zero      = new == 0
-              _zero = new == 0
+                     _subtract  = True
-              _subtract = False
+                     _carry     = o > new
-              _carry = o > new
+                     _halfCarry = o .&. 16 + n .&. 16 > 16 in
-              _halfCarry = o .&. 16 + n .&. 16 > 16 in
+                 (new, FlagRegister {..})
-          (new, FlagRegister {..})