pingu/Tia
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Mjau

Browse Source
This commit is contained in:
pingu
2026-04-01 11:19:41 +02:00
parent 47aedfdd8e
commit a69d0c9342
5 changed files with 65 additions and 34 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
README.md
View File

@@ -1,2 +0,0 @@
# Tia

5
README.org Normal file
View File

@@ -0,0 +1,5 @@
#+title: Tia
This aims to be an emulator for the gameboy color, made in Haskell for the memes.
It as of right now has no particular ambitions, but rather an exploration of emulating that system, one bit at the time.

3
Tia.cabal
View File

@@ -58,7 +58,8 @@ library
import: warnings
-- Modules exported by the library.
exposed-modules: GB.CPU
exposed-modules: GBC
, GBC.CPU
-- Modules included in this library but not exported.
-- other-modules:

2
src/GB.hs → src/GBC.hs
View File

@@ -1,3 +1,3 @@
{-# LANGUAGE TemplateHaskell
, RecordWildCards #-}
module GB where
module GBC where

87
src/GB/CPU.hs → src/GBC/CPU.hs
View File

@@ -3,7 +3,7 @@
, DataKinds
, FlexibleContexts
, GADTs #-}
module GB.CPU where
module GBC.CPU where
import Lens.Micro.Platform
import Data.Word
@@ -34,17 +34,17 @@ carryFlagPosition = 4
instance Convert FlagRegister Word8 where
convert r =
((`shiftL` zeroFlagPosition) $ if r ^. zero then 1 else 0) +
((`shiftL` negativeFlagPosition) $ if r ^. negative then 1 else 0) +
((`shiftL` halfCarryFlagPosition) $ if r ^. halfCarry then 1 else 0) +
((`shiftL` carryFlagPosition) $ if r ^. carry then 1 else 0)
((.<<. zeroFlagPosition) $ if r ^. zero then 1 else 0) +
((.<<. negativeFlagPosition) $ if r ^. negative then 1 else 0) +
((.<<. halfCarryFlagPosition) $ if r ^. halfCarry then 1 else 0) +
((.<<. carryFlagPosition) $ if r ^. carry then 1 else 0)
instance Convert Word8 FlagRegister where
convert w =
let _zero = (shiftR w zeroFlagPosition .&. 1 /= 0)
_negative = (shiftR w negativeFlagPosition .&. 1 /= 0)
_halfCarry = (shiftR w halfCarryFlagPosition .&. 1 /= 0)
_carry = (shiftR w carryFlagPosition .&. 1 /= 0) in
let _zero = (w `testBit` zeroFlagPosition)
_negative = (w `testBit` negativeFlagPosition)
_halfCarry = (w `testBit` halfCarryFlagPosition)
_carry = (w `testBit` carryFlagPosition) in
FlagRegister {..}
@@ -118,6 +118,11 @@ data Instruction where
RR :: ArithmeticTarget -> Instruction
RRHL :: Instruction
SLA :: ArithmeticTarget -> Instruction
SLAHL :: Instruction
SRA :: ArithmeticTarget -> Instruction
SRAHL :: Instruction
execute :: CPU -> Instruction -> CPU
execute cpu = \case
AddR t _c -> let value = cpu ^. registers . t
@@ -197,69 +202,91 @@ execute cpu = \case
(newValue, newFlags) = add16 _hl _bc _flags in
cpu & registers . hl .~ newValue
& registers . flags .~ newFlags
AddSP e -> let value = cpu ^. sp
newValue :: Word16 = fromIntegral (fromIntegral value) + (fromIntegral e) in
AddSP _e -> let value = cpu ^. sp
newValue :: Word16 = fromIntegral (fromIntegral value :: Integer) + (fromIntegral _e) in
cpu & sp .~ newValue
& registers . flags .~
FlagRegister { _zero = False,
_negative = False,
_halfCarry = value .&. 16 + fromIntegral e .&. 16 > 16, -- TODO: check if this still works out
_halfCarry = value .&. 16 + fromIntegral _e .&. 16 > 16, -- TODO: check if this still works out
_carry = value > newValue
}
RLCA -> let _carry = cpu ^. registers . a .&. 128 == 128 in
RLCA -> let _carry = (cpu ^. registers . a) `testBit` 8 in
cpu & registers . a %~ (`rotateL` 1)
& registers . flags .~ FlagRegister {_zero = False, _negative = False, _halfCarry = False, ..}
RRCA -> let _carry = cpu ^. registers . a .&. 1 == 1 in
RRCA -> let _carry = (cpu ^. registers . a) `testBit` 1 in
cpu & registers . a %~ (`rotateR` 1)
& registers . flags .~ FlagRegister {_zero = False, _negative = False, _halfCarry = False, ..}
RLA -> let _carry = cpu ^. registers . a .&. 128 == 128
RLA -> let _carry = (cpu ^. registers . a) `testBit` 8
_c = cpu ^. registers . flags . carry in
cpu & registers . a %~ (if _c then (+1) else id) . (`shiftL` 1)
cpu & registers . a %~ (if _c then (+1) else id) . (.<<. 1)
& registers . flags .~ FlagRegister {_zero = False, _negative = False, _halfCarry = False, ..}
RRA -> let _carry = cpu ^. registers . a .&. 1 == 1
RRA -> let _carry = (cpu ^. registers . a) `testBit` 1
_c = cpu ^. registers . flags . carry in
cpu & registers . a %~ (if _c then (+128) else id) . (`shiftR` 1)
cpu & registers . a %~ (if _c then (+128) else id) . (.>>. 1)
& registers . flags .~ FlagRegister {_zero = False, _negative = False, _halfCarry = False, ..}
RLC t -> let _carry = cpu ^. registers . t .&. 128 == 128
RLC t -> let _carry = (cpu ^. registers . t) `testBit` 8
newValue = cpu ^. registers . t `rotateL` 1 in
cpu & registers . t .~ newValue
& registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
RLCHL -> let target = cpu ^. registers . hl
value = fetch cpu target
_carry = value .&. 128 == 128
_carry = (value) `testBit` 8
newValue = value `rotateL` 1 in
write cpu target newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
RRC t -> let _carry = cpu ^. registers . t .&. 1 == 1
RRC t -> let _carry = (cpu ^. registers . t) `testBit` 1
newValue = cpu ^. registers . t `rotateR` 1 in
cpu & registers . t .~ newValue
& registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
RRCHL -> let target = cpu ^. registers . hl
value = fetch cpu target
_carry = value .&. 1 == 1
_carry = value `testBit` 1
newValue = value `rotateR` 1 in
write cpu target newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
RL t -> let _carry = cpu ^. registers . t .&. 128 == 128
RL t -> let _carry = (cpu ^. registers . t) `testBit` 8
_c = cpu ^. registers . flags . carry
newValue = (if _c then (+1) else id) $ cpu ^. registers . t `shiftL` 1 in
newValue = (if _c then (+1) else id) $ cpu ^. registers . t .<<. 1 in
cpu & registers . t .~ newValue
& registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
RLHL -> let target = cpu ^. registers . hl
value = fetch cpu target
_c = cpu ^. registers . flags . carry
_carry = value .&. 128 == 128
newValue = (if _c then (+1) else id) $ value `shiftL` 1 in
_carry = value `testBit` 8
newValue = (if _c then (+1) else id) $ value .<<. 1 in
write cpu target newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
RR t -> let _carry = cpu ^. registers . t .&. 1 == 1
RR t -> let _carry = (cpu ^. registers . t) `testBit` 1
_c = cpu ^. registers . flags . carry
newValue = (if _c then (+128) else id) $ cpu ^. registers . t `shiftR` 1 in
newValue = (if _c then (+128) else id) $ cpu ^. registers . t .>>. 1 in
cpu & registers . t .~ newValue
& registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
RRHL -> let target = cpu ^. registers . hl
value = fetch cpu target
_c = cpu ^. registers . flags . carry
_carry = value .&. 1 == 1
newValue = (if _c then (+128) else id) $ value `shiftR` 1 in
_carry = value `testBit` 1
newValue = (if _c then (+128) else id) $ value .>>. 1 in
write cpu target newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
SLA t -> let _carry = (cpu ^. registers . t) `testBit` 8
newValue = cpu ^. registers . t .<<. 1
in
cpu & registers . t .~ newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
SLAHL -> let target = cpu ^. registers . hl
value = fetch cpu target
newValue = value .<<. 1
_carry = value `testBit` 8
in
write cpu target newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
SRA t -> let _carry = (cpu ^. registers . t) `testBit` 1
value = cpu ^. registers . t
newValue = let temp = value .>>. 1 in if value `testBit` 8 then temp `setBit` 8 else temp
in
cpu & registers . t .~ newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
SRAHL -> let target = cpu ^. registers . hl
value = fetch cpu target
newValue = let temp = value .>>. 1 in if value `testBit` 8 then temp `setBit` 8 else temp
_carry = value `testBit` 8
in
write cpu target newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
where
add :: Word8 -> Word8 -> Bool -> (Word8, FlagRegister)
add o n _c = let new = o + n + if _c then 1 else 0