module Nes.Render.Background (renderBackground) where

import Data.Bits
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
import Data.Foldable
import Foreign
import Nes.Bus.State
import Nes.Memory
import Nes.Memory.Unsafe ()
import Nes.PPU.Pointers
import Nes.PPU.State hiding (ScrollRegister (..))
import qualified Nes.PPU.State as Scroll (ScrollRegister (..))
import Nes.Render.Frame
import Nes.Render.Monad
import qualified Nes.Render.Monad as Render
import Nes.Render.Palette
import Nes.Rom

renderBackground :: BusState -> Render DirtyFrame BGDrawn r ()
renderBackground :: forall r. BusState -> Render 'DirtyFrame 'BGDrawn r ()
renderBackground BusState
bus = Render.do
    let (Int
scrollX, Int
scrollY) =
            let
                scroll :: ScrollRegister
scroll = (PPUState -> ScrollRegister
_scrollRegister (PPUState -> ScrollRegister) -> PPUState -> ScrollRegister
forall a b. (a -> b) -> a -> b
$ BusState -> PPUState
_ppuState BusState
bus)
             in
                (Byte -> Int
byteToInt (Byte -> Int) -> Byte -> Int
forall a b. (a -> b) -> a -> b
$ ScrollRegister -> Byte
Scroll.x ScrollRegister
scroll, Byte -> Int
byteToInt (Byte -> Int) -> Byte -> Int
forall a b. (a -> b) -> a -> b
$ ScrollRegister -> Byte
Scroll.y ScrollRegister
scroll)
        ppuVram :: MemoryPointer
ppuVram = PPUPointers -> MemoryPointer
vram (PPUPointers -> MemoryPointer) -> PPUPointers -> MemoryPointer
forall a b. (a -> b) -> a -> b
$ BusState -> PPUPointers
_ppuPointers BusState
bus
    let (ByteString
nt1, ByteString
nt2) = case (PPUState -> Mirroring
_mirroring (PPUState -> Mirroring) -> PPUState -> Mirroring
forall a b. (a -> b) -> a -> b
$ BusState -> PPUState
_ppuState BusState
bus, ControlRegister -> Addr
getNametableAddr (ControlRegister -> Addr)
-> (PPUState -> ControlRegister) -> PPUState -> Addr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PPUState -> ControlRegister
_controlRegister (PPUState -> Addr) -> PPUState -> Addr
forall a b. (a -> b) -> a -> b
$ BusState -> PPUState
_ppuState BusState
bus) of
            (Mirroring
Vertical, Addr
0x2000) -> (MemoryPointer -> (Int, Int) -> ByteString
bsFromSlice MemoryPointer
ppuVram (Int
0, Int
0x400), MemoryPointer -> (Int, Int) -> ByteString
bsFromSlice MemoryPointer
ppuVram (Int
0x400, Int
0x800))
            (Mirroring
Vertical, Addr
0x2800) -> (MemoryPointer -> (Int, Int) -> ByteString
bsFromSlice MemoryPointer
ppuVram (Int
0, Int
0x400), MemoryPointer -> (Int, Int) -> ByteString
bsFromSlice MemoryPointer
ppuVram (Int
0x400, Int
0x800))
            (Mirroring
Horizontal, Addr
0x2000) -> (MemoryPointer -> (Int, Int) -> ByteString
bsFromSlice MemoryPointer
ppuVram (Int
0, Int
0x400), MemoryPointer -> (Int, Int) -> ByteString
bsFromSlice MemoryPointer
ppuVram (Int
0x400, Int
0x800))
            (Mirroring
Horizontal, Addr
0x2400) -> (MemoryPointer -> (Int, Int) -> ByteString
bsFromSlice MemoryPointer
ppuVram (Int
0, Int
0x400), MemoryPointer -> (Int, Int) -> ByteString
bsFromSlice MemoryPointer
ppuVram (Int
0x400, Int
0x800))
            (Mirroring
Vertical, Addr
0x2400) -> (MemoryPointer -> (Int, Int) -> ByteString
bsFromSlice MemoryPointer
ppuVram (Int
0x400, Int
0x800), MemoryPointer -> (Int, Int) -> ByteString
bsFromSlice MemoryPointer
ppuVram (Int
0, Int
0x400))
            (Mirroring
Vertical, Addr
0x2C00) -> (MemoryPointer -> (Int, Int) -> ByteString
bsFromSlice MemoryPointer
ppuVram (Int
0x400, Int
0x800), MemoryPointer -> (Int, Int) -> ByteString
bsFromSlice MemoryPointer
ppuVram (Int
0, Int
0x400))
            (Mirroring
Horizontal, Addr
0x2800) -> (MemoryPointer -> (Int, Int) -> ByteString
bsFromSlice MemoryPointer
ppuVram (Int
0x400, Int
0x800), MemoryPointer -> (Int, Int) -> ByteString
bsFromSlice MemoryPointer
ppuVram (Int
0, Int
0x400))
            (Mirroring
Horizontal, Addr
0x2C00) -> (MemoryPointer -> (Int, Int) -> ByteString
bsFromSlice MemoryPointer
ppuVram (Int
0x400, Int
0x800), MemoryPointer -> (Int, Int) -> ByteString
bsFromSlice MemoryPointer
ppuVram (Int
0, Int
0x400))
            (Mirroring, Addr)
_ -> [Char] -> (ByteString, ByteString)
forall a. HasCallStack => [Char] -> a
error [Char]
"Not supported mirror type"
    BusState
-> ByteString
-> ViewPort
-> (Int, Int)
-> Render 'DirtyFrame Any r ()
forall (a :: RenderStep) (b :: RenderStep) r.
BusState -> ByteString -> ViewPort -> (Int, Int) -> Render a b r ()
renderNameTable BusState
bus ByteString
nt1 (MkVP{xStart_ :: Int
xStart_ = Int
scrollX, yStart_ :: Int
yStart_ = Int
scrollY, xEnd_ :: Int
xEnd_ = Int
256, yEnd_ :: Int
yEnd_ = Int
240}) (-Int
scrollX, -Int
scrollY)
    if Int
scrollX Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
        then
            BusState
-> ByteString -> ViewPort -> (Int, Int) -> Render Any 'BGDrawn r ()
forall (a :: RenderStep) (b :: RenderStep) r.
BusState -> ByteString -> ViewPort -> (Int, Int) -> Render a b r ()
renderNameTable BusState
bus ByteString
nt2 (MkVP{xStart_ :: Int
xStart_ = Int
0, yStart_ :: Int
yStart_ = Int
0, xEnd_ :: Int
xEnd_ = Int
scrollX, yEnd_ :: Int
yEnd_ = Int
240}) (Int
256 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
scrollX, Int
0)
        else
            if Int
scrollY Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                then
                    BusState
-> ByteString -> ViewPort -> (Int, Int) -> Render Any 'BGDrawn r ()
forall (a :: RenderStep) (b :: RenderStep) r.
BusState -> ByteString -> ViewPort -> (Int, Int) -> Render a b r ()
renderNameTable BusState
bus ByteString
nt2 (MkVP{xStart_ :: Int
xStart_ = Int
0, yStart_ :: Int
yStart_ = Int
0, xEnd_ :: Int
xEnd_ = Int
256, yEnd_ :: Int
yEnd_ = Int
scrollY}) (Int
0, Int
240 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
scrollY)
                else
                    Render Any 'BGDrawn r ()
forall (b :: RenderStep) (a :: RenderStep) r. Render a b r ()
unsafeStep
  where
    bsFromSlice :: ForeignPtr () -> (Int, Int) -> ByteString
    bsFromSlice :: MemoryPointer -> (Int, Int) -> ByteString
bsFromSlice MemoryPointer
vram_ (Int
offset, Int
end) = ForeignPtr Word8 -> Int -> ByteString
BS.BS (MemoryPointer
vram_ MemoryPointer -> Int -> ForeignPtr Word8
forall a b. ForeignPtr a -> Int -> ForeignPtr b
`plusForeignPtr` Int
offset) (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

renderNameTable :: BusState -> ByteString -> ViewPort -> (Int, Int) -> Render a b r ()
renderNameTable :: forall (a :: RenderStep) (b :: RenderStep) r.
BusState -> ByteString -> ViewPort -> (Int, Int) -> Render a b r ()
renderNameTable BusState
bus ByteString
nametable ViewPort
vp (Int
shiftX, Int
shiftY) = Render.do
    let chr :: ByteString
chr = Rom -> ByteString
chrRom (Rom -> ByteString) -> (BusState -> Rom) -> BusState -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BusState -> Rom
_cartridge (BusState -> ByteString) -> BusState -> ByteString
forall a b. (a -> b) -> a -> b
$ BusState
bus
        bank :: Int
bank = Addr -> Int
addrToInt (Addr -> Int) -> (BusState -> Addr) -> BusState -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ControlRegister -> Addr
getBackgroundPatternAddr (ControlRegister -> Addr)
-> (BusState -> ControlRegister) -> BusState -> Addr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PPUState -> ControlRegister
_controlRegister (PPUState -> ControlRegister)
-> (BusState -> PPUState) -> BusState -> ControlRegister
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BusState -> PPUState
_ppuState (BusState -> Int) -> BusState -> Int
forall a b. (a -> b) -> a -> b
$ BusState
bus
        attrTable :: ByteString
attrTable = Int -> ByteString -> ByteString
BS.drop Int
0x3c0 ByteString
nametable
    [Int] -> (Int -> Render a a r ()) -> Render a a r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Int
0 .. Int
0x3c0] ((Int -> Render a a r ()) -> Render a a r ())
-> (Int -> Render a a r ()) -> Render a a r ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> Render.do
        let tileOffset :: Int
tileOffset = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
nametable Int
i
            tileCol :: Int
tileCol = Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
32
            tileRow :: Int
tileRow = Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
32
            tile :: ByteString
tile =
                Int -> ByteString -> ByteString
BS.take Int
16 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
                    Int -> ByteString -> ByteString
BS.drop (Int
bank Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tileOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16) ByteString
chr
        (Int, Int, Int, Int)
palette <- IO (Int, Int, Int, Int) -> Render a a r (Int, Int, Int, Int)
forall a (b :: RenderStep) r. IO a -> Render b b r a
liftIO (IO (Int, Int, Int, Int) -> Render a a r (Int, Int, Int, Int))
-> IO (Int, Int, Int, Int) -> Render a a r (Int, Int, Int, Int)
forall a b. (a -> b) -> a -> b
$ PPUPointers -> ByteString -> Int -> Int -> IO (Int, Int, Int, Int)
getBackgroundPalette (BusState -> PPUPointers
_ppuPointers BusState
bus) ByteString
attrTable Int
tileCol Int
tileRow
        (Int, Int, Int, Int) -> ByteString -> Int -> Int -> Render a a r ()
renderTile (Int, Int, Int, Int)
palette ByteString
tile Int
tileCol Int
tileRow
    Render a b r ()
forall (b :: RenderStep) (a :: RenderStep) r. Render a b r ()
unsafeStep
  where
    renderTile :: (Int, Int, Int, Int) -> ByteString -> Int -> Int -> Render a a r ()
renderTile (Int
c0, Int
c1, Int
c2, Int
c3) ByteString
tile Int
tileCol Int
tileRow = [Int] -> (Int -> Render a a r ()) -> Render a a r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Int
0 .. Int
7] ((Int -> Render a a r ()) -> Render a a r ())
-> (Int -> Render a a r ()) -> Render a a r ()
forall a b. (a -> b) -> a -> b
$ \Int
y -> do
        let upper :: Word8
upper = HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
tile Int
y
            lower :: Word8
lower = HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
tile (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8)
        [Int] -> (Int -> Render a a r ()) -> Render a a r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int
0 .. Int
7]) ((Int -> Render a a r ()) -> Render a a r ())
-> (Int -> Render a a r ()) -> Render a a r ()
forall a b. (a -> b) -> a -> b
$ \Int
x -> do
            let value :: Word8
value =
                    ((Word8
1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. (Word8
lower Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftR` (Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x))) Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` Int
1)
                        Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. (Word8
1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. (Word8
upper Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftR` (Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x)))
            let color :: Color
color = case Word8
value of
                    Word8
0 -> [Color]
systemPalette [Color] -> Int -> Color
forall a. HasCallStack => [a] -> Int -> a
!! Int
c0
                    Word8
1 -> [Color]
systemPalette [Color] -> Int -> Color
forall a. HasCallStack => [a] -> Int -> a
!! Int
c1
                    Word8
2 -> [Color]
systemPalette [Color] -> Int -> Color
forall a. HasCallStack => [a] -> Int -> a
!! Int
c2
                    Word8
3 -> [Color]
systemPalette [Color] -> Int -> Color
forall a. HasCallStack => [a] -> Int -> a
!! Int
c3
                    Word8
_ -> [Char] -> Color
forall a. HasCallStack => [Char] -> a
error [Char]
"Bad color index"
                pixel :: (Color, PixelType)
pixel = (Color
color, if Word8
value Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0 then PixelType
TransparentBG else PixelType
OpaqueBG)
                pixelX :: Int
pixelX = Int
tileCol Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x
                pixelY :: Int
pixelY = Int
tileRow Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y
            Bool -> Render a a r () -> Render a a r ()
forall (a :: RenderStep) r.
Bool -> Render a a r () -> Render a a r ()
whenR
                ( ViewPort -> Int
xStart_ ViewPort
vp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
pixelX
                    Bool -> Bool -> Bool
&& Int
pixelX Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< ViewPort -> Int
xEnd_ ViewPort
vp
                    Bool -> Bool -> Bool
&& ViewPort -> Int
yStart_ ViewPort
vp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
pixelY
                    Bool -> Bool -> Bool
&& Int
pixelY Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< ViewPort -> Int
yEnd_ ViewPort
vp
                )
                (Render a a r () -> Render a a r ())
-> Render a a r () -> Render a a r ()
forall a b. (a -> b) -> a -> b
$ (FrameState -> IO ()) -> Render a a r ()
forall a (b :: RenderStep) r.
(FrameState -> IO a) -> Render b b r a
withFrameState
                ((FrameState -> IO ()) -> Render a a r ())
-> (FrameState -> IO ()) -> Render a a r ()
forall a b. (a -> b) -> a -> b
$ (Color, PixelType)
-> (Int, Int) -> Buffer (Color, PixelType) -> IO ()
forall a. a -> (Int, Int) -> Buffer a -> IO ()
bufferSet (Color, PixelType)
pixel (Int
pixelX Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
shiftX, Int
pixelY Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
shiftY) (Buffer (Color, PixelType) -> IO ())
-> (FrameState -> Buffer (Color, PixelType)) -> FrameState -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FrameState -> Buffer (Color, PixelType)
pixelBuffer

data ViewPort = MkVP {ViewPort -> Int
xEnd_ :: Int, ViewPort -> Int
yEnd_ :: Int, ViewPort -> Int
xStart_ :: Int, ViewPort -> Int
yStart_ :: Int}

getBackgroundPalette :: PPUPointers -> ByteString -> Int -> Int -> IO (Int, Int, Int, Int)
getBackgroundPalette :: PPUPointers -> ByteString -> Int -> Int -> IO (Int, Int, Int, Int)
getBackgroundPalette PPUPointers
ptrs ByteString
attrTable Int
tileCol Int
tileRow = do
    let attrTableIdx :: Int
attrTableIdx = Int
tileRow Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tileCol Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4
        attrByte :: Byte
attrByte = Word8 -> Byte
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Byte) -> Word8 -> Byte
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
attrTable Int
attrTableIdx
    let paletteIdx :: Byte
paletteIdx =
            (Byte -> Byte -> Byte
forall a. Bits a => a -> a -> a
.&. Byte
0b11) (Byte -> Byte) -> Byte -> Byte
forall a b. (a -> b) -> a -> b
$ case (Int
tileCol Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
4 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2, Int
tileRow Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
4 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) of
                (Int
0, Int
0) -> Byte
attrByte
                (Int
1, Int
0) -> Byte
attrByte Byte -> Int -> Byte
forall a. Bits a => a -> Int -> a
`shiftR` Int
2
                (Int
0, Int
1) -> Byte
attrByte Byte -> Int -> Byte
forall a. Bits a => a -> Int -> a
`shiftR` Int
4
                (Int
1, Int
1) -> Byte
attrByte Byte -> Int -> Byte
forall a. Bits a => a -> Int -> a
`shiftR` Int
6
                (Int, Int)
_ -> [Char] -> Byte
forall a. HasCallStack => [Char] -> a
error [Char]
"Should not happen"
        paletteOffset :: Addr
paletteOffset = Word16 -> Addr
Addr (Word16 -> Addr) -> Word16 -> Addr
forall a b. (a -> b) -> a -> b
$ Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Byte -> Int
byteToInt Byte
paletteIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4
    Int
c0 <- Byte -> Int
byteToInt (Byte -> Int) -> IO Byte -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Addr -> MemoryPointer -> IO Byte
forall a (m :: * -> *). MemoryInterface a m => Addr -> a -> m Byte
readByte Addr
0 (PPUPointers -> MemoryPointer
paletteTable PPUPointers
ptrs)
    Int
c1 <- Byte -> Int
byteToInt (Byte -> Int) -> IO Byte -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Addr -> MemoryPointer -> IO Byte
forall a (m :: * -> *). MemoryInterface a m => Addr -> a -> m Byte
readByte Addr
paletteOffset (PPUPointers -> MemoryPointer
paletteTable PPUPointers
ptrs)
    Int
c2 <- Byte -> Int
byteToInt (Byte -> Int) -> IO Byte -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Addr -> MemoryPointer -> IO Byte
forall a (m :: * -> *). MemoryInterface a m => Addr -> a -> m Byte
readByte (Addr
paletteOffset Addr -> Addr -> Addr
forall a. Num a => a -> a -> a
+ Addr
1) (PPUPointers -> MemoryPointer
paletteTable PPUPointers
ptrs)
    Int
c3 <- Byte -> Int
byteToInt (Byte -> Int) -> IO Byte -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Addr -> MemoryPointer -> IO Byte
forall a (m :: * -> *). MemoryInterface a m => Addr -> a -> m Byte
readByte (Addr
paletteOffset Addr -> Addr -> Addr
forall a. Num a => a -> a -> a
+ Addr
2) (PPUPointers -> MemoryPointer
paletteTable PPUPointers
ptrs)
    (Int, Int, Int, Int) -> IO (Int, Int, Int, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
Prelude.return (Int
c0, Int
c1, Int
c2, Int
c3)