module Nes.Render.Sprite (renderSprites, applySprites) where

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

-- | Renders sprites on buffer
--
-- It  expects the background to be already drawn on the pixel buffer
renderSprites :: BusState -> Render BGDrawn BGAndSpritesDrawn r ()
renderSprites :: forall r. BusState -> Render 'BGDrawn 'BGAndSpritesDrawn r ()
renderSprites BusState
bus = Render.do
    let oam :: MemoryPointer
oam = PPUPointers -> MemoryPointer
oamData (PPUPointers -> MemoryPointer) -> PPUPointers -> MemoryPointer
forall a b. (a -> b) -> a -> b
$ BusState -> PPUPointers
_ppuPointers BusState
bus
        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
getSpritePatternAddr (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
    [Int]
-> (Int -> Render 'BGDrawn 'BGDrawn r ())
-> Render 'BGDrawn 'BGDrawn 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
4 .. Int
oamDataSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]) ((Int -> Render 'BGDrawn 'BGDrawn r ())
 -> Render 'BGDrawn 'BGDrawn r ())
-> (Int -> Render 'BGDrawn 'BGDrawn r ())
-> Render 'BGDrawn 'BGDrawn r ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> Render.do
        Int
tileIdx <- IO Int -> Render 'BGDrawn 'BGDrawn r Int
forall a (b :: RenderStep) r. IO a -> Render b b r a
liftIO (IO Int -> Render 'BGDrawn 'BGDrawn r Int)
-> IO Int -> Render 'BGDrawn 'BGDrawn r Int
forall a b. (a -> b) -> a -> b
$ 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 (Int -> Addr
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Addr -> Addr -> Addr
forall a. Num a => a -> a -> a
+ Addr
1) MemoryPointer
oam
        Int
tileCol <- IO Int -> Render 'BGDrawn 'BGDrawn r Int
forall a (b :: RenderStep) r. IO a -> Render b b r a
liftIO (IO Int -> Render 'BGDrawn 'BGDrawn r Int)
-> IO Int -> Render 'BGDrawn 'BGDrawn r Int
forall a b. (a -> b) -> a -> b
$ 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 (Int -> Addr
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Addr -> Addr -> Addr
forall a. Num a => a -> a -> a
+ Addr
3) MemoryPointer
oam
        Int
tileRow <- IO Int -> Render 'BGDrawn 'BGDrawn r Int
forall a (b :: RenderStep) r. IO a -> Render b b r a
liftIO (IO Int -> Render 'BGDrawn 'BGDrawn r Int)
-> IO Int -> Render 'BGDrawn 'BGDrawn r Int
forall a b. (a -> b) -> a -> b
$ 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 (Int -> Addr
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i) MemoryPointer
oam
        Byte
attributes <- IO Byte -> Render 'BGDrawn 'BGDrawn r Byte
forall a (b :: RenderStep) r. IO a -> Render b b r a
liftIO (IO Byte -> Render 'BGDrawn 'BGDrawn r Byte)
-> IO Byte -> Render 'BGDrawn 'BGDrawn r Byte
forall a b. (a -> b) -> a -> b
$ Addr -> MemoryPointer -> IO Byte
forall a (m :: * -> *). MemoryInterface a m => Addr -> a -> m Byte
readByte (Int -> Addr
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Addr -> Addr -> Addr
forall a. Num a => a -> a -> a
+ Addr
2) MemoryPointer
oam
        let flipVertical :: Bool
flipVertical = Byte -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Byte
attributes Int
7
            flipHorizontal :: Bool
flipHorizontal = Byte -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Byte
attributes Int
6
            priority :: SpritePriority
priority = if Byte -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Byte
attributes Int
5 then SpritePriority
Back else SpritePriority
Front
            paletteIdx :: Int
paletteIdx = Byte -> Int
byteToInt (Byte
attributes Byte -> Byte -> Byte
forall a. Bits a => a -> a -> a
.&. Byte
0b11)
            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
tileIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16) ByteString
chr
        (Int
_, Int
c1, Int
c2, Int
c3) <- IO (Int, Int, Int, Int)
-> Render 'BGDrawn 'BGDrawn r (Int, Int, Int, Int)
forall a (b :: RenderStep) r. IO a -> Render b b r a
liftIO (IO (Int, Int, Int, Int)
 -> Render 'BGDrawn 'BGDrawn r (Int, Int, Int, Int))
-> IO (Int, Int, Int, Int)
-> Render 'BGDrawn 'BGDrawn r (Int, Int, Int, Int)
forall a b. (a -> b) -> a -> b
$ PPUPointers -> Int -> IO (Int, Int, Int, Int)
getSpritePalette (BusState -> PPUPointers
_ppuPointers BusState
bus) Int
paletteIdx
        [Int]
-> (Int -> Render 'BGDrawn 'BGDrawn r ())
-> Render 'BGDrawn 'BGDrawn r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Int
0 .. Int
7] ((Int -> Render 'BGDrawn 'BGDrawn r ())
 -> Render 'BGDrawn 'BGDrawn r ())
-> (Int -> Render 'BGDrawn 'BGDrawn r ())
-> Render 'BGDrawn 'BGDrawn r ()
forall a b. (a -> b) -> a -> b
$ \Int
y -> Render.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 'BGDrawn 'BGDrawn r ())
-> Render 'BGDrawn 'BGDrawn 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 'BGDrawn 'BGDrawn r ())
 -> Render 'BGDrawn 'BGDrawn r ())
-> (Int -> Render 'BGDrawn 'BGDrawn r ())
-> Render 'BGDrawn 'BGDrawn r ()
forall a b. (a -> b) -> a -> b
$ \Int
x -> Render.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 :: Maybe Color
color = case Word8
value of
                        Word8
0 -> Maybe Color
forall a. Maybe a
Nothing
                        Word8
1 -> Color -> Maybe Color
forall a. a -> Maybe a
Just (Color -> Maybe Color) -> Color -> Maybe Color
forall a b. (a -> b) -> a -> b
$ [Color]
systemPalette [Color] -> Int -> Color
forall a. HasCallStack => [a] -> Int -> a
!! Int
c1
                        Word8
2 -> Color -> Maybe Color
forall a. a -> Maybe a
Just (Color -> Maybe Color) -> Color -> Maybe Color
forall a b. (a -> b) -> a -> b
$ [Color]
systemPalette [Color] -> Int -> Color
forall a. HasCallStack => [a] -> Int -> a
!! Int
c2
                        Word8
3 -> Color -> Maybe Color
forall a. a -> Maybe a
Just (Color -> Maybe Color) -> Color -> Maybe Color
forall a b. (a -> b) -> a -> b
$ [Color]
systemPalette [Color] -> Int -> Color
forall a. HasCallStack => [a] -> Int -> a
!! Int
c3
                        Word8
_ -> Maybe Color
forall a. Maybe a
Nothing
                case Maybe Color
color of
                    Maybe Color
Nothing -> () -> Render 'BGDrawn 'BGDrawn r ()
forall a (b :: RenderStep) r. a -> Render b b r a
Render.return ()
                    (Just Color
c) ->
                        let
                            coord :: (Int, Int)
coord =
                                ( Int -> Int -> Bool -> Int
forall {a}. Num a => a -> a -> Bool -> a
flipCoord Int
tileCol Int
x Bool
flipHorizontal
                                , Int -> Int -> Bool -> Int
forall {a}. Num a => a -> a -> Bool -> a
flipCoord Int
tileRow Int
y Bool
flipVertical
                                )
                         in
                            (FrameState -> FrameState) -> Render 'BGDrawn 'BGDrawn r ()
forall (b :: RenderStep) r.
(FrameState -> FrameState) -> Render b b r ()
modifyFrameState ((FrameState -> FrameState) -> Render 'BGDrawn 'BGDrawn r ())
-> (FrameState -> FrameState) -> Render 'BGDrawn 'BGDrawn r ()
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> SpritePixel -> FrameState -> FrameState
addSpritePixel (Int, Int)
coord (Color
c, SpritePriority
priority)

    Render 'BGDrawn 'BGAndSpritesDrawn r ()
forall (b :: RenderStep) (a :: RenderStep) r. Render a b r ()
unsafeStep
  where
    flipCoord :: a -> a -> Bool -> a
flipCoord a
base a
n Bool
flip' = if Bool -> Bool
not Bool
flip' then a
base a -> a -> a
forall a. Num a => a -> a -> a
+ a
n else a
base a -> a -> a
forall a. Num a => a -> a -> a
+ a
7 a -> a -> a
forall a. Num a => a -> a -> a
- a
n

getSpritePalette :: PPUPointers -> Int -> IO (Int, Int, Int, Int)
getSpritePalette :: PPUPointers -> Int -> IO (Int, Int, Int, Int)
getSpritePalette PPUPointers
ptrs Int
paletteIdx = do
    let offset :: Addr
offset = 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
0x11 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
paletteIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4)
    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
offset (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
offset 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
offset 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
0, Int
c1, Int
c2, Int
c3)

-- TODO https://github.com/bugzmanov/nes_ebook/blob/785b9ed8b803d9f4bd51274f4d0c68c14a1b3a8b/code/ch6.4/src/render/mod.rs#L63

-- | Merges the sprite buffer with the pixel buffer, using the priority atteched to pixels
applySprites :: Render BGAndSpritesDrawn Renderable r ()
applySprites :: forall r. Render 'BGAndSpritesDrawn 'Renderable r ()
applySprites = Render.do
    (FrameState -> IO ())
-> Render 'BGAndSpritesDrawn 'BGAndSpritesDrawn r ()
forall a (b :: RenderStep) r.
(FrameState -> IO a) -> Render b b r a
withFrameState ((FrameState -> IO ())
 -> Render 'BGAndSpritesDrawn 'BGAndSpritesDrawn r ())
-> (FrameState -> IO ())
-> Render 'BGAndSpritesDrawn 'BGAndSpritesDrawn r ()
forall a b. (a -> b) -> a -> b
$ \FrameState
st ->
        (Int -> SpritePixel -> IO ()) -> FrameState -> IO ()
forall (m :: * -> *).
Monad m =>
(Int -> SpritePixel -> m ()) -> FrameState -> m ()
foreachSpritePixel
            ( \Int
i SpritePixel
value -> case SpritePixel
value of
                (Color
c, SpritePriority
Front) -> (Color, PixelType) -> Int -> Buffer (Color, PixelType) -> IO ()
forall a. a -> Int -> Buffer a -> IO ()
bufferSetOffset (Color
c, PixelType
Sprite) Int
i (Buffer (Color, PixelType) -> IO ())
-> Buffer (Color, PixelType) -> IO ()
forall a b. (a -> b) -> a -> b
$ FrameState -> Buffer (Color, PixelType)
pixelBuffer FrameState
st
                (Color
c, SpritePriority
Back) -> do
                    Maybe PixelType
mpixeltype <- ((Color, PixelType) -> PixelType)
-> Maybe (Color, PixelType) -> Maybe PixelType
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Color, PixelType) -> PixelType
forall a b. (a, b) -> b
snd (Maybe (Color, PixelType) -> Maybe PixelType)
-> IO (Maybe (Color, PixelType)) -> IO (Maybe PixelType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Buffer (Color, PixelType) -> IO (Maybe (Color, PixelType))
forall a. Int -> Buffer a -> IO (Maybe a)
bufferGetOffset Int
i (FrameState -> Buffer (Color, PixelType)
pixelBuffer FrameState
st)
                    case Maybe PixelType
mpixeltype of
                        Just PixelType
TransparentBG -> (Color, PixelType) -> Int -> Buffer (Color, PixelType) -> IO ()
forall a. a -> Int -> Buffer a -> IO ()
bufferSetOffset (Color
c, PixelType
Sprite) Int
i (Buffer (Color, PixelType) -> IO ())
-> Buffer (Color, PixelType) -> IO ()
forall a b. (a -> b) -> a -> b
$ FrameState -> Buffer (Color, PixelType)
pixelBuffer FrameState
st
                        Maybe PixelType
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            )
            FrameState
st
    Render 'BGAndSpritesDrawn 'Renderable r ()
forall (b :: RenderStep) (a :: RenderStep) r. Render a b r ()
unsafeStep