From 71fbf52e4ae1d8a8a3ad513a3c1954d6d90379a9 Mon Sep 17 00:00:00 2001
From: pingu <nor@acorneroftheweb.com>
Date: Tue, 7 Apr 2026 17:03:04 +0200
Subject: [PATCH] Mjapp

---
 Tia.cabal      |   1 +
 src/GBC/CPU.hs | 253 ++++++++++++++++++++++++++++++++++---------------
 2 files changed, 178 insertions(+), 76 deletions(-)

diff --git a/Tia.cabal b/Tia.cabal
index a291065..46bca37 100644
--- a/Tia.cabal
+++ b/Tia.cabal
@@ -71,6 +71,7 @@ library
     build-depends:    base ^>=4.20.2.0
                     , microlens-platform
                     , vector-sized
+                    , lattices
 
     -- Directories containing source files.
     hs-source-dirs:   src
diff --git a/src/GBC/CPU.hs b/src/GBC/CPU.hs
index ba144b3..da9f1bf 100644
--- a/src/GBC/CPU.hs
+++ b/src/GBC/CPU.hs
@@ -10,6 +10,7 @@ import Data.Word
 import Data.Bits
 import Data.Int
 import qualified Data.Vector.Sized as V
+import Algebra.Lattice
 
 splitWord :: Word16 -> (Word8, Word8)
 splitWord w = (fromIntegral $ w .>>. 8, fromIntegral $ w .&. 255)
@@ -44,7 +45,7 @@ instance Convert FlagRegister Word8 where
     ((.<<. negativeFlagPosition) $ if r ^. fNegative then 1 else 0) +
     ((.<<. halfCarryFlagPosition) $ if r ^. fHalfCarry then 1 else 0) +
     ((.<<. carryFlagPosition) $ if r ^. fCarry then 1 else 0)
-  
+
 instance Convert Word8 FlagRegister where
   convert w =
     let _fZero = (w `testBit` zeroFlagPosition)
@@ -211,87 +212,141 @@ data Instruction where
   EI :: Instruction
   NOP :: Instruction
 
-execute :: CPU -> Instruction -> CPU
+data Exec a b c = Done c | Await a (b -> Exec a b c)
+
+instance Functor (Exec a b) where
+  fmap f (Done a) = Done $ f a
+  fmap f (Await n g) = Await n (\a -> f <$> g a)
+
+instance Lattice a => Applicative (Exec a b) where
+  pure = Done
+  (Done f) <*> fa = f <$> fa
+  (Await n f) <*> (Done a) = Await n $ \b -> case f b of
+                             Done f -> Done $ f a
+                             ff -> ff <*> Done a
+  (Await n f) <*> (Await n' g) = Await (n \/ n') $ \a -> f a <*> g a
+
+instance Lattice a => Monad (Exec a b) where
+  Done a >>= f = f a
+  Await n g >>= f = Await n $ \b -> case g b of
+                                  Done a -> f a
+                                  ff -> ff >>= f
+
+data Status where
+  Running :: Status
+  Halted :: Status
+
+instance Lattice Status where
+  Running \/ Halted = Halted
+  Halted \/ Running = Halted
+  f \/ _ = f
+
+  Running /\ Halted = Running
+  Halted /\ Running = Running
+  f /\ _ = f
+
+execute :: CPU -> Instruction -> Exec Status CPU CPU
 execute cpu = \case
   ADDR t _c -> let value = cpu ^. t
                    (newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. carry in
+        pure $
                cpu & a .~ newValue
                    & flags .~ newFlags
   ADDHL _c -> let value = fetch cpu $ cpu ^. hl
                   (newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. carry in
+        pure $
               cpu & a .~ newValue
                   & flags .~ newFlags
   ADDN value _c -> let (newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. carry in
+        pure $
                 cpu & a .~ newValue
                     & flags .~ newFlags
   SUBR t _c -> let value =  cpu ^. t
                    (newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. carry in
+        pure $
                cpu & a .~ newValue
                    & flags .~ newFlags
   SUBHL _c -> let value = fetch cpu $ cpu ^. hl
                   (newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. carry in
+        pure $
               cpu & a .~ newValue
                   & flags .~ newFlags
   SUBN value _c -> let (newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. carry in
+        pure $
                    cpu & a .~ newValue
                        & flags .~ newFlags
   CPR t -> let value = cpu ^. t
                (_, newFlags) = sub (cpu ^. a) value $ False in
+        pure $
               cpu & flags .~ newFlags
   CPHL -> let value = fetch cpu $ cpu ^. hl
               (_, newFlags) = sub (cpu ^. a) value $ False in
+        pure $
            cpu & flags .~ newFlags
   CPN value -> let (_, newFlags) = sub (cpu ^. a) value $ False in
+        pure $
                 cpu & flags .~ newFlags
   INCR t -> let (value, newFlags) = add (cpu ^. t) 1 False in
+        pure $
             cpu & t .~ value
                 & flags .~ newFlags
   INCHL -> let target = cpu ^. hl
                value = fetch cpu target
                (newValue, newFlags) = add value 1 False in
+        pure $
            write cpu target newValue & flags .~ newFlags
   DECR t -> let (value, newFlags) = sub (cpu ^. t) 1 False in
+        pure $
             cpu & t .~ value
                 & flags .~ newFlags
   DECHL -> let target = cpu ^. hl
                value = fetch cpu target
                (newValue, newFlags) = sub value 1 False in
+        pure $
            write cpu target newValue & flags .~ newFlags
   BOR t op _f -> let newValue = (cpu ^. a) `op` (cpu ^. t)
                      newFlags = _f {_fZero = newValue == 0} in
+        pure $
                 cpu & a .~ newValue
                     & flags .~ newFlags
   BOHL op _f -> let target = cpu ^. hl
                     value = fetch cpu target
                     newValue = (cpu ^. a) `op` value
                     newFlags = _f {_fZero = value == 0} in
+        pure $
                 cpu & a .~ newValue
                     & flags .~ newFlags
-            
+
   BON value op _f -> let newValue = (cpu ^. a) `op` value
                          newFlags = _f {_fZero = newValue == 0} in
+        pure $
                     cpu & a .~ newValue
                         & flags .~ newFlags
-  CCF -> cpu & negative .~ False
-             & halfCarry .~  False
-             & carry %~ not
-  SCF -> cpu & negative .~ False
-             & halfCarry .~  False
-             & carry .~ True
+  CCF -> pure $
+           cpu & negative .~ False
+               & halfCarry .~  False
+               & carry %~ not
+  SCF -> pure $
+           cpu & negative .~ False
+               & halfCarry .~  False
+               & carry .~ True
   DAA -> undefined -- TODO: undefined in manual
-  CPL -> cpu & a %~ complement
-             & negative .~ True
-             & halfCarry .~ True
-  INCRR -> cpu & bc %~ (+1)
-  DECRR -> cpu & bc %~ (+1)
+  CPL -> pure $
+           cpu & a %~ complement
+               & negative .~ True
+               & halfCarry .~ True
+  INCRR -> pure $ cpu & bc %~ (+1)
+  DECRR -> pure $ cpu & bc %~ (+1)
   ADDHLRR t -> let _flags = cpu ^. flags
                    _hl = cpu ^. hl
                    val = cpu ^. t
                    (newValue, newFlags) = add16 _hl val _flags in
+        pure $
              cpu & hl .~ newValue
                  & flags .~ newFlags
   ADDSP _e -> let value = cpu ^. sp
                   newValue :: Word16 = fromIntegral $ (fromIntegral value :: Integer) + (fromIntegral _e) in
+        pure $
               cpu & sp .~ newValue
                   & flags .~
                       FlagRegister { _fZero = False,
@@ -300,144 +355,169 @@ execute cpu = \case
                                      _fCarry = value > newValue
                                    }
   RLCA -> let _fCarry = (cpu ^. a) `testBit` 8 in
-    cpu & a %~ (`rotateL` 1)
-        & flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
+    pure $
+      cpu & a %~ (`rotateL` 1)
+          & flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
   RRCA -> let _fCarry = (cpu ^. a) `testBit` 1 in
-    cpu & a %~ (`rotateR` 1)
-        & flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
+    pure $
+      cpu & a %~ (`rotateR` 1)
+          & flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
   RLA -> let _fCarry = (cpu ^. a) `testBit` 8
              _c = cpu ^. carry in
-    cpu & a %~ (if _c then (+1) else id) . (.<<. 1)
-        & flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
+    pure $
+      cpu & a %~ (if _c then (+1) else id) . (.<<. 1)
+          & flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
   RRA -> let _fCarry = (cpu ^. a) `testBit` 1
              _c = cpu ^. carry in
-    cpu & a %~ (if _c then (+128) else id) . (.>>. 1)
-        & flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
+    pure $
+      cpu & a %~ (if _c then (+128) else id) . (.>>. 1)
+          & flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
   RLC t -> let _fCarry = (cpu ^. t) `testBit` 8
                newValue = cpu ^. t `rotateL` 1 in
-    cpu & t .~ newValue
-        & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
+    pure $
+      cpu & t .~ newValue
+          & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
   RLCHL -> let target = cpu ^. hl
                value = fetch cpu target
                _fCarry = (value) `testBit` 8
                newValue = value `rotateL` 1 in
-    write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
+    pure $
+      write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
   RRC t -> let _fCarry = (cpu ^. t) `testBit` 1
                newValue = cpu ^. t `rotateR` 1 in
-    cpu & t .~ newValue
-        & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
+    pure $
+      cpu & t .~ newValue
+          & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
   RRCHL -> let target = cpu ^. hl
                value = fetch cpu target
                _fCarry = value `testBit` 1
                newValue = value `rotateR` 1 in
-    write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
+    pure $
+      write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
   RL t -> let _fCarry = (cpu ^. t) `testBit` 8
               _c = cpu ^. carry
               newValue = (if _c then (+1) else id) $ cpu ^. t .<<. 1 in
-    cpu & t .~ newValue
-        & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
+    pure $
+      cpu & t .~ newValue
+          & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
   RLHL -> let target = cpu ^. hl
               value = fetch cpu target
               _c = cpu ^. carry
               _fCarry = value `testBit` 8
               newValue = (if _c then (+1) else id) $ value .<<. 1 in
-    write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
+    pure $
+      write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
   RR t -> let _fCarry = (cpu ^. t) `testBit` 1
               _c = cpu ^. carry
               newValue = (if _c then (+128) else id) $ cpu ^. t .>>. 1 in
-    cpu & t .~ newValue
-        & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
+    pure $
+      cpu & t .~ newValue
+          & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
   RRHL -> let target = cpu ^. hl
               value = fetch cpu target
               _c = cpu ^. carry
               _fCarry = value `testBit` 1
               newValue = (if _c then (+128) else id) $ value .>>. 1 in
-    write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
+    pure $
+      write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
   SLA t -> let _fCarry = (cpu ^. t) `testBit` 8
                newValue = cpu ^. t .<<. 1
     in
+        pure $
            cpu & t .~ newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
   SLAHL -> let target = cpu ^. hl
                value = fetch cpu target
                newValue = value .<<. 1
                _fCarry = value `testBit` 8
     in
+        pure $
            write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
   SR t arith -> let _fCarry = (cpu ^. t) `testBit` 1
                     value = cpu ^. t
-                    newValue = let temp = value .>>. 1 in if value `testBit` 8 && arith then temp `setBit` 8 else temp 
+                    newValue = let temp = value .>>. 1 in if value `testBit` 8 && arith then temp `setBit` 8 else temp
     in
+        pure $
            cpu & t .~ newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
   SRHL arith -> let target = cpu ^. hl
                     value = fetch cpu target
                     newValue = let temp = value .>>. 1 in if value `testBit` 8 && arith then temp `setBit` 8 else temp
                     _fCarry = value `testBit` 1 in
+        pure $
            write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
   SWAP t -> let newValue = cpu ^. t `rotateR` 4 in
+        pure $
            cpu & t .~ newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, _fCarry = False}
   SWAPHL -> let target = cpu ^. hl
                 value = fetch cpu target
                 newValue = value `rotateR` 4 in
+        pure $
            write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, _fCarry = False}
   BIT t i -> let value = cpu ^. t in
-    cpu & flags %~ (\_f -> _f { _fZero = not $ value `testBit` i, _fNegative = False, _fHalfCarry = True })
+    pure $
+      cpu & flags %~ (\_f -> _f { _fZero = not $ value `testBit` i, _fNegative = False, _fHalfCarry = True })
   BITHL i -> let target = cpu ^. hl
                  value = fetch cpu target in
-    cpu & flags %~ (\_f -> _f { _fZero = not $ value `testBit` i, _fNegative = False, _fHalfCarry = True })
-  RES t i -> cpu & t %~ (`clearBit` i)
+    pure $
+      cpu & flags %~ (\_f -> _f { _fZero = not $ value `testBit` i, _fNegative = False, _fHalfCarry = True })
+  RES t i -> pure $ cpu & t %~ (`clearBit` i)
   RESHL i -> let target = cpu ^. hl
                  value = fetch cpu target
                  newValue = value `clearBit` i in
+        pure $
              write cpu target newValue
-  SET t i -> cpu & t %~ (`setBit` i)
+  SET t i -> pure $ cpu & t %~ (`setBit` i)
   SETHL i -> let target = cpu ^. hl
                  value = fetch cpu target
                  newValue = value `setBit` i in
-             write cpu target newValue
-  LDRR t _f -> cpu & t .~ cpu ^. _f
-  LDRN t v -> cpu & t .~ v
+        pure $ write cpu target newValue
+  LDRR t _f -> pure $ cpu & t .~ cpu ^. _f
+  LDRN t v -> pure $ cpu & t .~ v
   LDRHL t -> let target = cpu ^. hl
                  value = fetch cpu target in
-               cpu & t .~ value
+               pure $ cpu & t .~ value
   LDXR t _f -> let target = cpu ^. t in
-    write cpu target $ cpu ^. _f
+    pure $ write cpu target $ cpu ^. _f
   LDXN t v -> let target = cpu ^. t in
-    write cpu target v
-  LDANN _f -> cpu & a .~ fetch cpu _f
-  LDNNA _t -> write cpu _t $ cpu ^. a
+    pure $ write cpu target v
+  LDANN _f -> pure $ cpu & a .~ fetch cpu _f
+  LDNNA _t -> pure $ write cpu _t $ cpu ^. a
   LDHAC -> let target = 65280 + (fromIntegral $ cpu ^. c)
                value = fetch cpu target in
-             cpu & a .~ value
+             pure $ cpu & a .~ value
   LDHCA -> let target = 65280 + (fromIntegral $ cpu ^. c) in
-             write cpu target $ cpu ^. a
+             pure $ write cpu target $ cpu ^. a
   LDHAN v -> let target = 65280 + (fromIntegral v)
                  value = fetch cpu target in
-               cpu & a .~ value
+               pure $ cpu & a .~ value
   LDHNA v -> let target = 65280 + (fromIntegral v) in
-             write cpu target $ cpu ^. a
+             pure $ write cpu target $ cpu ^. a
   LDAHL op -> let target = cpu ^. hl
                   value = fetch cpu target in
-                cpu & a .~ value
-                    & hl %~ op
+        pure $
+          cpu & a .~ value
+              & hl %~ op
   LDHLA op -> let target = cpu ^. hl in
-                write cpu target (cpu ^. a)
-                    & hl %~ op
-  LDRRNN t v -> cpu & t .~ v
-  LDNNSP v -> write cpu v . fetch cpu $ cpu ^. sp
-  LDSPHL -> cpu & sp .~ cpu ^. hl
+        pure $
+          write cpu target (cpu ^. a)
+              & hl %~ op
+  LDRRNN t v -> pure $ cpu & t .~ v
+  LDNNSP v -> pure $ write cpu v . fetch cpu $ cpu ^. sp
+  LDSPHL -> pure $ cpu & sp .~ cpu ^. hl
   PUSHRR t -> let cpu' = cpu & sp %~ subtract 1
                   (msb, lsb) = splitWord $ cpu ^. t
                   cpu'' = write cpu' (cpu' ^. sp) msb & sp %~ subtract 1 in
-                 write cpu'' (cpu'' ^. sp) lsb
+                pure $ write cpu'' (cpu'' ^. sp) lsb
   POPRR t -> let lsb = fetch cpu (cpu ^. sp)
                  cpu' = cpu & sp %~ (+1)
                  msb = fetch cpu' (cpu' ^. sp)
                  value = combineWords msb lsb
              in
-               cpu & t .~ value
-                   & sp %~ (+1)
+               pure $
+                 cpu & t .~ value
+                     & sp %~ (+1)
   LDHLSPE v -> let value = cpu ^. sp
                    newValue :: Word16 = fromIntegral $ (fromIntegral value :: Integer) + (fromIntegral v) in
+              pure $
                  cpu & hl .~ value
                      & flags .~
                          FlagRegister { _fZero = False,
@@ -445,39 +525,60 @@ execute cpu = \case
                                         _fHalfCarry = value .&. 16 + fromIntegral v .&. 16 > 16, -- TODO: check if this still works out
                                         _fCarry = value > newValue
                                       }
-  JPNN v -> cpu & pc .~ v
-  JPHL -> cpu & pc .~ cpu ^. hl
-  JPCCNN v _f op -> if op $ cpu ^. _f then cpu & pc .~ v else cpu
-  JRE v -> let target = fromIntegral $ (fromIntegral (cpu ^. pc) :: Integer) + fromIntegral v in cpu & pc .~ target
-  JRCCE v _f op -> if op $ cpu ^. _f then
+  JPNN v -> pure $ cpu & pc .~ v
+  JPHL -> pure $ cpu & pc .~ cpu ^. hl
+  JPCCNN v _f op -> pure $ if op $ cpu ^. _f then cpu & pc .~ v else cpu
+  JRE v -> let target = fromIntegral $ (fromIntegral (cpu ^. pc) :: Integer) + fromIntegral v in pure $ cpu & pc .~ target
+  JRCCE v _f op -> pure $ if op $ cpu ^. _f then
                      let target = fromIntegral $ (fromIntegral (cpu ^. pc) :: Integer) + fromIntegral v in
                      cpu & pc .~ target
                    else
                      cpu
-  CALLNN v -> undefined
-  CALLCCNN v _f op -> undefined
+  CALLNN v -> let (msb,lsb) = splitWord $ cpu ^. pc
+                  cpu' = cpu & sp %~ subtract 1
+                  cpu'' = (write cpu' (cpu' ^. sp) msb) & sp %~ subtract 1
+                  cpu''' = (write cpu'' (cpu'' ^. sp) lsb) in
+    pure $ cpu''' & pc .~ v
+  CALLCCNN v _f op -> pure $ if op $ cpu ^. _f then
+                        let (msb,lsb) = splitWord $ cpu ^. pc
+                            cpu' = cpu & sp %~ subtract 1
+                            cpu'' = (write cpu' (cpu' ^. sp) msb) & sp %~ subtract 1
+                            cpu''' = (write cpu'' (cpu'' ^. sp) lsb) in
+                        cpu''' & pc .~ v
+                      else
+                        cpu
   RET -> let lsb = fetch cpu (cpu ^. sp)
              cpu' = cpu & sp %~ (+1)
              msb = fetch cpu' (cpu' ^. sp)
              value = combineWords msb lsb in
-           cpu & pc .~ value
-               & ie .~ 1
-  RETCC _f op -> undefined
+        pure $ cpu' & pc .~ value
+                & ie .~ 1
+                & sp %~ (+1)
+  RETCC _f op -> pure $ if op $ cpu ^. _f then
+                        let lsb = fetch cpu (cpu ^. sp)
+                            cpu' = cpu & sp %~ (+1)
+                            msb = fetch cpu' (cpu' ^. sp)
+                            value = combineWords msb lsb in
+                        cpu' & pc .~ value
+                             & ie .~ 1
+                             & sp %~ (+1)
+                        else cpu
   RETI -> let lsb = fetch cpu (cpu ^. sp)
               cpu' = cpu & sp %~ (+1)
               msb = fetch cpu' (cpu' ^. sp)
               value = combineWords msb lsb in
+        pure $
             cpu & pc .~ value
                 & ie .~ 1
   RSTN v -> let cpu' = cpu & sp %~ subtract 1
                 (msb,lsb) = splitWord $ cpu ^. pc
                 cpu'' = write cpu' (cpu' ^. sp) msb & sp %~ subtract 1 in
-              write cpu'' (cpu'' ^. sp) lsb & pc .~ v
-  HALT -> undefined
+              pure $ write cpu'' (cpu'' ^. sp) lsb & pc .~ v
+  HALT -> Await Halted pure
   STOP -> undefined
-  DI -> cpu & ie .~ 0
-  EI -> cpu & ie .~ 1
-  NOP -> cpu
+  DI -> pure $ cpu & ie .~ 0
+  EI -> pure $ cpu & ie .~ 1
+  NOP -> pure $ cpu
   where
     add :: Word8 -> Word8 -> Bool -> (Word8, FlagRegister)
     add o n _c = let new        = o + n + if _c then 1 else 0