module Nes.Render.Frame (
    -- * State
    FrameState (..),
    newFrameState,

    -- * Frame
    frameWidth,
    frameHeight,
    frameLength,
    frameSetPixel,

    -- * Buffer
    Buffer (..),
    bufferWidth,
    bufferHeight,
    bufferLength,
    bufferGet,
    bufferSet,
    bufferCoordToOffset,
    bufferGetOffset,
    bufferSetOffset,

    -- * Sprite Pixel
    SpritePixel,
    SpritePixels,
    addSpritePixel,
    foreachSpritePixel,

    -- * Pixel
    Coord,
    Color,
    PixelType (..),

    -- * Misc
    SpritePriority (..),
) where

import Control.Monad
import Data.Array (Ix (..))
import Data.Map.Strict as M
import Data.Vector.Mutable
import qualified Data.Vector.Mutable as V
import Foreign hiding (new)
import GHC.ForeignPtr
import Nes.Memory (MemoryPointer)
import Nes.Memory.Internal

-- | Width (in pixels of the frame)
frameWidth :: Int
frameWidth :: Int
frameWidth = Int
256

-- | Height (in pixels of the frame)
frameHeight :: Int
frameHeight :: Int
frameHeight = Int
240

-- | Size, in bytes, of the frame
frameLength :: Int
frameLength :: Int
frameLength = Int
frameWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
frameHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3

{-# INLINE frameSetPixel #-}
frameSetPixel :: (Word8, Word8, Word8) -> (Int, Int) -> MemoryPointer -> IO ()
frameSetPixel :: (Word8, Word8, Word8) -> (Int, Int) -> MemoryPointer -> IO ()
frameSetPixel (Word8
colorR, Word8
colorG, Word8
colorB) (Int
x, Int
y) MemoryPointer
fptr = do
    let base :: Int
base = Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
frameWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Int
0, Int
frameLength) (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        -- Note: we don't use 'writeByte' because base + 2 might overflow
        ForeignPtr Any -> (Ptr Any -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr (MemoryPointer -> ForeignPtr Any
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr MemoryPointer
fptr) ((Ptr Any -> IO ()) -> IO ()) -> (Ptr Any -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Any
ptr -> do
            Ptr Any -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Any
ptr Int
base Word8
colorR
            Ptr Any -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Any
ptr (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Word8
colorG
            Ptr Any -> Int -> Word8 -> IO ()
forall b. Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Any
ptr (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Word8
colorB

-- | Width of the internal buffer
--
-- Equals 'frameWidth'
bufferWidth :: Int
bufferWidth :: Int
bufferWidth = Int
frameWidth

-- | Height of the internal buffer
--
-- _Warning_ is not equal to 'frameHeight'
--
-- See https://www.nesdev.org/wiki/PPU_rendering#Vertical_blanking_lines_(241-260)
bufferHeight :: Int
bufferHeight :: Int
bufferHeight = Int
261

-- | Number of elements in a buffer
bufferLength :: Int
bufferLength :: Int
bufferLength = Int
bufferWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
bufferHeight

{-# INLINE bufferSet #-}
bufferSet :: a -> Coord -> Buffer a -> IO ()
bufferSet :: forall a. a -> (Int, Int) -> Buffer a -> IO ()
bufferSet a
pixel (Int, Int)
coord = a -> Int -> Buffer a -> IO ()
forall a. a -> Int -> Buffer a -> IO ()
bufferSetOffset a
pixel ((Int, Int) -> Int
bufferCoordToOffset (Int, Int)
coord)

{-# INLINE bufferSetOffset #-}
bufferSetOffset :: a -> Int -> Buffer a -> IO ()
bufferSetOffset :: forall a. a -> Int -> Buffer a -> IO ()
bufferSetOffset a
pixel Int
offset (MkBuffer IOVector a
fb) =
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Int
0, Int
bufferWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
bufferHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
offset) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        MVector (PrimState IO) a -> Int -> a -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
V.write
            IOVector a
MVector (PrimState IO) a
fb
            Int
offset
            a
pixel

{-# INLINE bufferGet #-}
bufferGet :: Coord -> Buffer a -> IO (Maybe a)
bufferGet :: forall a. (Int, Int) -> Buffer a -> IO (Maybe a)
bufferGet (Int, Int)
coord = Int -> Buffer a -> IO (Maybe a)
forall a. Int -> Buffer a -> IO (Maybe a)
bufferGetOffset ((Int, Int) -> Int
bufferCoordToOffset (Int, Int)
coord)

{-# INLINE bufferGetOffset #-}
bufferGetOffset :: Int -> Buffer a -> IO (Maybe a)
bufferGetOffset :: forall a. Int -> Buffer a -> IO (Maybe a)
bufferGetOffset Int
offset (MkBuffer IOVector a
fb) =
    if (Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Int
0, Int
bufferWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
bufferHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
offset
        then
            a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState IO) a -> Int -> IO a
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
V.read IOVector a
MVector (PrimState IO) a
fb Int
offset
        else Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

{-# INLINE bufferCoordToOffset #-}
bufferCoordToOffset :: Coord -> Int
bufferCoordToOffset :: (Int, Int) -> Int
bufferCoordToOffset (Int
x, Int
y) = Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
frameWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x

{-# INLINE addSpritePixel #-}
addSpritePixel :: Coord -> SpritePixel -> FrameState -> FrameState
addSpritePixel :: (Int, Int) -> SpritePixel -> FrameState -> FrameState
addSpritePixel (Int, Int)
coord SpritePixel
pixel FrameState
st = FrameState
st{spritePixels = M.insert (bufferCoordToOffset coord) pixel (spritePixels st)}

{-# INLINE foreachSpritePixel #-}
foreachSpritePixel :: (Monad m) => (Int -> SpritePixel -> m ()) -> FrameState -> m ()
foreachSpritePixel :: forall (m :: * -> *).
Monad m =>
(Int -> SpritePixel -> m ()) -> FrameState -> m ()
foreachSpritePixel Int -> SpritePixel -> m ()
f = (Int -> SpritePixel -> m () -> m ())
-> m () -> Map Int SpritePixel -> m ()
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey' (\Int
key SpritePixel
pixel m ()
rest -> Int -> SpritePixel -> m ()
f Int
key SpritePixel
pixel m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
rest) (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Map Int SpritePixel -> m ())
-> (FrameState -> Map Int SpritePixel) -> FrameState -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FrameState -> Map Int SpritePixel
spritePixels

data FrameState = MkFrameState
    { FrameState -> MemoryPointer
sdl2Frame :: {-# UNPACK #-} !MemoryPointer
    , FrameState -> Buffer ((Word8, Word8, Word8), PixelType)
pixelBuffer :: {-# UNPACK #-} !(Buffer (Color, PixelType))
    , FrameState -> Map Int SpritePixel
spritePixels :: {-# UNPACK #-} !SpritePixels
    }

type SpritePixels = Map Int SpritePixel
type SpritePixel = (Color, SpritePriority)

-- | Allocates the buffers and frame
newFrameState :: IO FrameState
newFrameState :: IO FrameState
newFrameState = do
    !MemoryPointer
sdl2Frame <- Int -> IO MemoryPointer
callocForeignPtr Int
frameLength
    !Buffer ((Word8, Word8, Word8), PixelType)
pixelBuffer <- IOVector ((Word8, Word8, Word8), PixelType)
-> Buffer ((Word8, Word8, Word8), PixelType)
forall a. IOVector a -> Buffer a
MkBuffer (IOVector ((Word8, Word8, Word8), PixelType)
 -> Buffer ((Word8, Word8, Word8), PixelType))
-> IO (IOVector ((Word8, Word8, Word8), PixelType))
-> IO (Buffer ((Word8, Word8, Word8), PixelType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> ((Word8, Word8, Word8), PixelType)
-> IO (MVector (PrimState IO) ((Word8, Word8, Word8), PixelType))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MVector (PrimState m) a)
V.replicate Int
bufferLength ((Word8
0, Word8
0, Word8
0), PixelType
TransparentBG)
    let !spritePixels :: Map k a
spritePixels = Map k a
forall k a. Map k a
empty
    FrameState -> IO FrameState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FrameState -> IO FrameState) -> FrameState -> IO FrameState
forall a b. (a -> b) -> a -> b
$ MkFrameState{MemoryPointer
Map Int SpritePixel
Buffer ((Word8, Word8, Word8), PixelType)
forall k a. Map k a
spritePixels :: Map Int SpritePixel
sdl2Frame :: MemoryPointer
pixelBuffer :: Buffer ((Word8, Word8, Word8), PixelType)
sdl2Frame :: MemoryPointer
pixelBuffer :: Buffer ((Word8, Word8, Word8), PixelType)
spritePixels :: forall k a. Map k a
..}

newtype Buffer a = MkBuffer {forall a. Buffer a -> IOVector a
unBuffer :: IOVector a}

-- | Says _where_ the pixel comes from
data PixelType
    = -- | An opaque background pixel (e.g. pipe in mario)
      TransparentBG
    | -- | A transparent background pixel (e.g. sky in mario)
      OpaqueBG
    | -- | Pixel from a sprite
      Sprite
    deriving (PixelType -> PixelType -> Bool
(PixelType -> PixelType -> Bool)
-> (PixelType -> PixelType -> Bool) -> Eq PixelType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PixelType -> PixelType -> Bool
== :: PixelType -> PixelType -> Bool
$c/= :: PixelType -> PixelType -> Bool
/= :: PixelType -> PixelType -> Bool
Eq, Int -> PixelType -> ShowS
[PixelType] -> ShowS
PixelType -> String
(Int -> PixelType -> ShowS)
-> (PixelType -> String)
-> ([PixelType] -> ShowS)
-> Show PixelType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PixelType -> ShowS
showsPrec :: Int -> PixelType -> ShowS
$cshow :: PixelType -> String
show :: PixelType -> String
$cshowList :: [PixelType] -> ShowS
showList :: [PixelType] -> ShowS
Show)

-- | Priority of the sprite (from bit 5 of attribute table)
--
-- https://www.nesdev.org/wiki/PPU_sprite_priority
data SpritePriority = Front | Back deriving (SpritePriority -> SpritePriority -> Bool
(SpritePriority -> SpritePriority -> Bool)
-> (SpritePriority -> SpritePriority -> Bool) -> Eq SpritePriority
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SpritePriority -> SpritePriority -> Bool
== :: SpritePriority -> SpritePriority -> Bool
$c/= :: SpritePriority -> SpritePriority -> Bool
/= :: SpritePriority -> SpritePriority -> Bool
Eq, Int -> SpritePriority -> ShowS
[SpritePriority] -> ShowS
SpritePriority -> String
(Int -> SpritePriority -> ShowS)
-> (SpritePriority -> String)
-> ([SpritePriority] -> ShowS)
-> Show SpritePriority
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SpritePriority -> ShowS
showsPrec :: Int -> SpritePriority -> ShowS
$cshow :: SpritePriority -> String
show :: SpritePriority -> String
$cshowList :: [SpritePriority] -> ShowS
showList :: [SpritePriority] -> ShowS
Show)

type Color = (Word8, Word8, Word8)

type Coord = (Int, Int)