{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}

-- | Draw arena lifecycle, command batching and vertex reservation. The shape
-- and text emitters reserve room here and poke vertices straight into the
-- pinned buffers.
module NanoUI.Draw.Arena
  ( newDrawArena
  , resetDrawArena
  , setDrawSnapScale
  , getDrawSnapScale
  , setDrawSquareGeometry
  , setDrawExternalText
  , beginLayer
  , currentLayer
  , currentClip
  , setClip
  , withClip
  , setTexture
  , finishDraw
  , withVerts
  , withVertsRaw
  , withVertsReserve
  , pushQuad
  , snapRectOrigin
  , unpackColorF
  , pokeQuadIndices
  , loopIO
  , whitePixelU
  , whitePixelV
  ) where

import Control.Monad (unless, when)
import Data.Bits (shiftR, (.&.))
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Maybe (fromMaybe)
import Data.Primitive.PrimArray
  ( MutablePrimArray
  , PrimArray
  , newPrimArray
  , readPrimArray
  , setPrimArray
  , unsafeFreezePrimArray
  , writePrimArray
  , resizeMutablePrimArray
  )
import Data.Word (Word32, Word8)
import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrBytes, withForeignPtr)
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
import Foreign.Marshal.Array (copyArray)
import Foreign.Ptr (Ptr)
import Foreign.Storable (pokeByteOff)
import GHC.Exts (RealWorld)
import NanoUI.Draw.Types
import NanoUI.SIMD (pokeQuadSIMD)
import NanoUI.Types (Color (..), Rect (..), onGrid, rectIntersect)

vertexCapacity :: Int
vertexCapacity :: Int
vertexCapacity = Int
4096

indexCapacity :: Int
indexCapacity :: Int
indexCapacity = Int
8192

bufferPoolLimit :: Int
bufferPoolLimit :: Int
bufferPoolLimit = Int
4

cmdInitialCapacity :: Int
cmdInitialCapacity :: Int
cmdInitialCapacity = Int
64

newDrawArena :: IO DrawArena
newDrawArena :: IO DrawArena
newDrawArena = do
  vFPtr <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes (Int
vertexCapacity Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
vertexSize)
  iFPtr <- mallocForeignPtrBytes (indexCapacity * indexSize)
  daVertexFPtr <- newIORef vFPtr
  daVertexPtr <- newIORef (unsafeForeignPtrToPtr vFPtr)
  daVertexCap <- newIORef vertexCapacity
  daVertexCount <- newIORef 0
  daVertexPool <- newIORef []
  daIndexFPtr <- newIORef iFPtr
  daIndexPtr <- newIORef (unsafeForeignPtrToPtr iFPtr)
  daIndexCap <- newIORef indexCapacity
  daIndexCount <- newIORef 0
  daIndexPool <- newIORef []
  daCmdStore <- newIORef =<< newPrimArray cmdInitialCapacity
  daCmdCount <- newIORef 0
  daCmdCapacity <- newIORef cmdInitialCapacity
  daCurrentLayer <- newIORef LayerContent
  daCurrentClip <- newPrimArray 4
  daCurrentTexture <- newIORef glyphAtlasTextureId
  daCmdStartIndex <- newIORef 0
  daSnapScale <- newIORef 0.0
  daSquareGeometry <- newIORef False
  daExternalText <- newIORef False
  let da = DrawArena {IORef Bool
IORef Float
IORef Int
IORef [(ForeignPtr Word8, Int)]
IORef (Ptr Word8)
IORef (ForeignPtr Word8)
IORef (MutablePrimArray RealWorld DrawCmd)
IORef Layer
MutablePrimArray RealWorld Float
daVertexFPtr :: IORef (ForeignPtr Word8)
daVertexPtr :: IORef (Ptr Word8)
daVertexCap :: IORef Int
daVertexCount :: IORef Int
daVertexPool :: IORef [(ForeignPtr Word8, Int)]
daIndexFPtr :: IORef (ForeignPtr Word8)
daIndexPtr :: IORef (Ptr Word8)
daIndexCap :: IORef Int
daIndexCount :: IORef Int
daIndexPool :: IORef [(ForeignPtr Word8, Int)]
daCmdStore :: IORef (MutablePrimArray RealWorld DrawCmd)
daCmdCount :: IORef Int
daCmdCapacity :: IORef Int
daCurrentLayer :: IORef Layer
daCurrentClip :: MutablePrimArray RealWorld Float
daCurrentTexture :: IORef Int
daCmdStartIndex :: IORef Int
daSnapScale :: IORef Float
daSquareGeometry :: IORef Bool
daExternalText :: IORef Bool
daExternalText :: IORef Bool
daSquareGeometry :: IORef Bool
daSnapScale :: IORef Float
daCmdStartIndex :: IORef Int
daCurrentTexture :: IORef Int
daCurrentClip :: MutablePrimArray RealWorld Float
daCurrentLayer :: IORef Layer
daCmdCapacity :: IORef Int
daCmdCount :: IORef Int
daCmdStore :: IORef (MutablePrimArray RealWorld DrawCmd)
daIndexPool :: IORef [(ForeignPtr Word8, Int)]
daIndexCount :: IORef Int
daIndexCap :: IORef Int
daIndexPtr :: IORef (Ptr Word8)
daIndexFPtr :: IORef (ForeignPtr Word8)
daVertexPool :: IORef [(ForeignPtr Word8, Int)]
daVertexCount :: IORef Int
daVertexCap :: IORef Int
daVertexPtr :: IORef (Ptr Word8)
daVertexFPtr :: IORef (ForeignPtr Word8)
..}
  resetDrawArena da
  pure da

resetDrawArena :: DrawArena -> IO ()
resetDrawArena :: DrawArena -> IO ()
resetDrawArena DrawArena
da = do
  IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (DrawArena -> IORef Int
daVertexCount DrawArena
da) Int
0
  IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (DrawArena -> IORef Int
daIndexCount DrawArena
da) Int
0
  IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (DrawArena -> IORef Int
daCmdCount DrawArena
da) Int
0
  IORef Layer -> Layer -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (DrawArena -> IORef Layer
daCurrentLayer DrawArena
da) Layer
LayerContent
  DrawArena -> Rect -> IO ()
setClip DrawArena
da (Float -> Float -> Float -> Float -> Rect
Rect Float
0 Float
0 Float
1e9 Float
1e9)
  IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (DrawArena -> IORef Int
daCurrentTexture DrawArena
da) Int
glyphAtlasTextureId
  IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (DrawArena -> IORef Int
daCmdStartIndex DrawArena
da) Int
0

-- | Device pixel scale used to snap primitive origins/endpoints to whole
-- device pixels. A non-positive value disables snapping. The SDL backend keeps
-- this in sync with the window pixel density. Headless contexts and the RGFW backend
-- leave it disabled.
{-# INLINE setDrawSnapScale #-}
setDrawSnapScale :: DrawArena -> Float -> IO ()
setDrawSnapScale :: DrawArena -> Float -> IO ()
setDrawSnapScale DrawArena
da Float
s = IORef Float -> Float -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (DrawArena -> IORef Float
daSnapScale DrawArena
da) (if Float
s Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 then Float
s else Float
0)

{-# INLINE getDrawSnapScale #-}
getDrawSnapScale :: DrawArena -> IO Float
getDrawSnapScale :: DrawArena -> IO Float
getDrawSnapScale DrawArena
da = IORef Float -> IO Float
forall a. IORef a -> IO a
readIORef (DrawArena -> IORef Float
daSnapScale DrawArena
da)

-- | Square geometry for hosts that draw flat, axis-aligned fills, such as the
-- RGFW backend. Rounded rects, circles and their strokes lower to
-- plain rects, and coverage-AA strips lower to solid quads with no
-- transparent fringe vertices. Persists across 'resetDrawArena'.
{-# INLINE setDrawSquareGeometry #-}
setDrawSquareGeometry :: DrawArena -> Bool -> IO ()
setDrawSquareGeometry :: DrawArena -> Bool -> IO ()
setDrawSquareGeometry DrawArena
da = IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (DrawArena -> IORef Bool
daSquareGeometry DrawArena
da)

-- | External text for hosts that rasterize text themselves from the collected
-- text spans. Text emitters push no quads, so fonts without a glyph atlas do
-- not leave per-character advance boxes in the buffer. Persists across
-- 'resetDrawArena'.
{-# INLINE setDrawExternalText #-}
setDrawExternalText :: DrawArena -> Bool -> IO ()
setDrawExternalText :: DrawArena -> Bool -> IO ()
setDrawExternalText DrawArena
da = IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (DrawArena -> IORef Bool
daExternalText DrawArena
da)

{-# NOINLINE poolTake #-}
poolTake :: BufferPool -> Int -> Int -> IO (ForeignPtr Word8)
poolTake :: IORef [(ForeignPtr Word8, Int)]
-> Int -> Int -> IO (ForeignPtr Word8)
poolTake IORef [(ForeignPtr Word8, Int)]
pool Int
bytes Int
minCap = do
  entries <- IORef [(ForeignPtr Word8, Int)] -> IO [(ForeignPtr Word8, Int)]
forall a. IORef a -> IO a
readIORef IORef [(ForeignPtr Word8, Int)]
pool
  case break (\(ForeignPtr Word8
_, Int
cap) -> Int
cap Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
minCap) entries of
    ([(ForeignPtr Word8, Int)]
before, (ForeignPtr Word8
ptr, Int
_) : [(ForeignPtr Word8, Int)]
after) -> do
      IORef [(ForeignPtr Word8, Int)]
-> [(ForeignPtr Word8, Int)] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [(ForeignPtr Word8, Int)]
pool ([(ForeignPtr Word8, Int)]
before [(ForeignPtr Word8, Int)]
-> [(ForeignPtr Word8, Int)] -> [(ForeignPtr Word8, Int)]
forall a. [a] -> [a] -> [a]
++ [(ForeignPtr Word8, Int)]
after)
      ForeignPtr Word8 -> IO (ForeignPtr Word8)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ForeignPtr Word8
ptr
    ([(ForeignPtr Word8, Int)], [(ForeignPtr Word8, Int)])
_ -> Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
bytes

{-# NOINLINE poolGive #-}
poolGive :: BufferPool -> ForeignPtr Word8 -> Int -> IO ()
poolGive :: IORef [(ForeignPtr Word8, Int)] -> ForeignPtr Word8 -> Int -> IO ()
poolGive IORef [(ForeignPtr Word8, Int)]
pool ForeignPtr Word8
ptr Int
cap = do
  entries <- IORef [(ForeignPtr Word8, Int)] -> IO [(ForeignPtr Word8, Int)]
forall a. IORef a -> IO a
readIORef IORef [(ForeignPtr Word8, Int)]
pool
  writeIORef pool (take bufferPoolLimit ((ptr, cap) : entries))

{-# NOINLINE growBuffer #-}
growBuffer ::
  Int ->
  IORef (ForeignPtr Word8) ->
  IORef (Ptr Word8) ->
  IORef Int ->
  BufferPool ->
  Int ->
  Int ->
  IO ()
growBuffer :: Int
-> IORef (ForeignPtr Word8)
-> IORef (Ptr Word8)
-> IORef Int
-> IORef [(ForeignPtr Word8, Int)]
-> Int
-> Int
-> IO ()
growBuffer Int
count IORef (ForeignPtr Word8)
fptrRef IORef (Ptr Word8)
ptrRef IORef Int
capRef IORef [(ForeignPtr Word8, Int)]
pool Int
elemBytes Int
needElems = do
  cap <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
capRef
  let required = Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
needElems
  when (required > cap) $ do
    oldFPtr <- readIORef fptrRef
    let newCap = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Int
cap Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) Int
required
    newFPtr <- poolTake pool (newCap * elemBytes) newCap
    withForeignPtr newFPtr $ \Ptr Word8
newP ->
      ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
oldFPtr ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
oldP ->
        Ptr Word8 -> Ptr Word8 -> Int -> IO ()
forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
copyArray Ptr Word8
newP Ptr Word8
oldP (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
elemBytes)
    poolGive pool oldFPtr cap
    writeIORef fptrRef newFPtr
    writeIORef ptrRef (unsafeForeignPtrToPtr newFPtr)
    writeIORef capRef newCap

ensureCapacity :: DrawArena -> Int -> Int -> IO ()
ensureCapacity :: DrawArena -> Int -> Int -> IO ()
ensureCapacity DrawArena
da Int
needVerts Int
needIndices = do
  vCount <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (DrawArena -> IORef Int
daVertexCount DrawArena
da)
  growBuffer vCount (daVertexFPtr da) (daVertexPtr da) (daVertexCap da) (daVertexPool da) vertexSize needVerts
  iCount <- readIORef (daIndexCount da)
  growBuffer iCount (daIndexFPtr da) (daIndexPtr da) (daIndexCap da) (daIndexPool da) indexSize needIndices

{-# INLINE ensureAndAlloc #-}
ensureAndAlloc :: DrawArena -> Int -> Int -> IO (Ptr Word8, Ptr Word8, Int, Int)
ensureAndAlloc :: DrawArena -> Int -> Int -> IO (Ptr Word8, Ptr Word8, Int, Int)
ensureAndAlloc DrawArena
da Int
needV Int
needI = do
  vCount <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (DrawArena -> IORef Int
daVertexCount DrawArena
da)
  iCount <- readIORef (daIndexCount da)
  vCap <- readIORef (daVertexCap da)
  iCap <- readIORef (daIndexCap da)
  unless (vCount + needV <= vCap && iCount + needI <= iCap) $
    ensureCapacity da needV needI
  vp <- readIORef (daVertexPtr da)
  ip <- readIORef (daIndexPtr da)
  pure (vp, ip, vCount, iCount)

{-# NOINLINE growCmdStore #-}
growCmdStore :: DrawArena -> Int -> IO ()
growCmdStore :: DrawArena -> Int -> IO ()
growCmdStore DrawArena
da Int
oldCap = do
  let newCap :: Int
newCap = Int
oldCap Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2
  arr <- IORef (MutablePrimArray RealWorld DrawCmd)
-> IO (MutablePrimArray RealWorld DrawCmd)
forall a. IORef a -> IO a
readIORef (DrawArena -> IORef (MutablePrimArray RealWorld DrawCmd)
daCmdStore DrawArena
da)
  newArr <- resizeMutablePrimArray arr newCap
  writeIORef (daCmdStore da) newArr
  writeIORef (daCmdCapacity da) newCap

-- | Close the pending index run as a command. A run that continues the last
-- command's state and index range extends that command instead. Only reached
-- when the layer, clip or texture changes and from 'finishDraw', so it stays
-- out of the emitters.
{-# NOINLINE flushCmd #-}
flushCmd :: DrawArena -> IO ()
flushCmd :: DrawArena -> IO ()
flushCmd DrawArena
da = do
  start <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (DrawArena -> IORef Int
daCmdStartIndex DrawArena
da)
  end <- readIORef (daIndexCount da)
  when (end > start) $ do
    Rect cx cy cw ch <- currentClip da
    tex <- readIORef (daCurrentTexture da)
    layer <- readIORef (daCurrentLayer da)
    n <- readIORef (daCmdCount da)
    arr <- readIORef (daCmdStore da)
    let off = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
start :: Word32
        cnt = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start) :: Word32
    extended <-
      if n <= 0
        then pure False
        else do
          prev <- readPrimArray arr (n - 1)
          let same =
                DrawCmd -> Float
cmdClipX DrawCmd
prev Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
cx
                  Bool -> Bool -> Bool
&& DrawCmd -> Float
cmdClipY DrawCmd
prev Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
cy
                  Bool -> Bool -> Bool
&& DrawCmd -> Float
cmdClipW DrawCmd
prev Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
cw
                  Bool -> Bool -> Bool
&& DrawCmd -> Float
cmdClipH DrawCmd
prev Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
ch
                  Bool -> Bool -> Bool
&& DrawCmd -> Int
cmdTextureId DrawCmd
prev Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tex
                  Bool -> Bool -> Bool
&& DrawCmd -> Layer
cmdLayer DrawCmd
prev Layer -> Layer -> Bool
forall a. Eq a => a -> a -> Bool
== Layer
layer
                  Bool -> Bool -> Bool
&& DrawCmd -> Word32
cmdIndexOffset DrawCmd
prev Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ DrawCmd -> Word32
cmdIndexCount DrawCmd
prev Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
off
          when same $
            writePrimArray arr (n - 1) prev {cmdIndexCount = cmdIndexCount prev + cnt}
          pure same
    unless extended $ do
      cap <- readIORef (daCmdCapacity da)
      when (n >= cap) $ growCmdStore da cap
      arr' <- readIORef (daCmdStore da)
      writePrimArray arr' n (DrawCmd cx cy cw ch tex off cnt layer)
      writeIORef (daCmdCount da) (n + 1)
    writeIORef (daCmdStartIndex da) end

{-# INLINE currentLayer #-}
currentLayer :: DrawArena -> IO Layer
currentLayer :: DrawArena -> IO Layer
currentLayer = IORef Layer -> IO Layer
forall a. IORef a -> IO a
readIORef (IORef Layer -> IO Layer)
-> (DrawArena -> IORef Layer) -> DrawArena -> IO Layer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DrawArena -> IORef Layer
daCurrentLayer

beginLayer :: DrawArena -> Layer -> IO ()
beginLayer :: DrawArena -> Layer -> IO ()
beginLayer DrawArena
da Layer
layer = do
  cur <- IORef Layer -> IO Layer
forall a. IORef a -> IO a
readIORef (DrawArena -> IORef Layer
daCurrentLayer DrawArena
da)
  when (cur /= layer) $ do
    flushCmd da
    writeIORef (daCurrentLayer da) layer
    readIORef (daIndexCount da) >>= writeIORef (daCmdStartIndex da)

setClip :: DrawArena -> Rect -> IO ()
setClip :: DrawArena -> Rect -> IO ()
setClip DrawArena
da (Rect Float
x Float
y Float
w Float
h) = do
  DrawArena -> IO ()
flushCmd DrawArena
da
  let clip :: MutablePrimArray RealWorld Float
clip = DrawArena -> MutablePrimArray RealWorld Float
daCurrentClip DrawArena
da
  MutablePrimArray (PrimState IO) Float -> Int -> Float -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld Float
MutablePrimArray (PrimState IO) Float
clip Int
0 Float
x
  MutablePrimArray (PrimState IO) Float -> Int -> Float -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld Float
MutablePrimArray (PrimState IO) Float
clip Int
1 Float
y
  MutablePrimArray (PrimState IO) Float -> Int -> Float -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld Float
MutablePrimArray (PrimState IO) Float
clip Int
2 Float
w
  MutablePrimArray (PrimState IO) Float -> Int -> Float -> IO ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld Float
MutablePrimArray (PrimState IO) Float
clip Int
3 Float
h

{-# INLINE currentClip #-}
currentClip :: DrawArena -> IO Rect
currentClip :: DrawArena -> IO Rect
currentClip DrawArena
da = do
  let clip :: MutablePrimArray RealWorld Float
clip = DrawArena -> MutablePrimArray RealWorld Float
daCurrentClip DrawArena
da
  x <- MutablePrimArray (PrimState IO) Float -> Int -> IO Float
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld Float
MutablePrimArray (PrimState IO) Float
clip Int
0
  y <- readPrimArray clip 1
  w <- readPrimArray clip 2
  h <- readPrimArray clip 3
  pure $! Rect x y w h


-- | Run @act@ clipped to the intersection with the current clip. Not
-- exception-safe: the frame resets the clip before the next paint anyway.
{-# INLINE withClip #-}
withClip :: DrawArena -> Rect -> IO a -> IO a
withClip :: forall a. DrawArena -> Rect -> IO a -> IO a
withClip DrawArena
da Rect
rect IO a
act = do
  prev <- DrawArena -> IO Rect
currentClip DrawArena
da
  setClip da (fromMaybe (Rect 0 0 0 0) (rectIntersect prev rect))
  act <* setClip da prev

-- | Bind a texture. The unchanged case is the common one and stays inline; a
-- real switch closes the pending command out of line.
{-# INLINE setTexture #-}
setTexture :: DrawArena -> Int -> IO ()
setTexture :: DrawArena -> Int -> IO ()
setTexture DrawArena
da Int
tex = do
  cur <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (DrawArena -> IORef Int
daCurrentTexture DrawArena
da)
  when (cur /= tex) $ switchTexture da tex

{-# NOINLINE switchTexture #-}
switchTexture :: DrawArena -> Int -> IO ()
switchTexture :: DrawArena -> Int -> IO ()
switchTexture DrawArena
da Int
tex = do
  DrawArena -> IO ()
flushCmd DrawArena
da
  IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (DrawArena -> IORef Int
daCurrentTexture DrawArena
da) Int
tex

finishDraw :: DrawArena -> IO DrawData
finishDraw :: DrawArena -> IO DrawData
finishDraw DrawArena
da = do
  DrawArena -> IO ()
flushCmd DrawArena
da
  vFPtr <- IORef (ForeignPtr Word8) -> IO (ForeignPtr Word8)
forall a. IORef a -> IO a
readIORef (DrawArena -> IORef (ForeignPtr Word8)
daVertexFPtr DrawArena
da)
  iFPtr <- readIORef (daIndexFPtr da)
  vCount <- readIORef (daVertexCount da)
  iCount <- readIORef (daIndexCount da)
  count <- readIORef (daCmdCount da)
  arr <- readIORef (daCmdStore da)
  (cmds, slices) <- groupCmdsByLayer arr count
  pure
    DrawData
      { drawVertices = vFPtr
      , drawVertexCount = vCount
      , drawIndices = iFPtr
      , drawIndexCount = iCount
      , drawCommands = cmds
      , drawLayerSlices = slices
      }

-- | Stable counting sort of the recorded commands by layer, plus one slice per
-- layer into the sorted array.
groupCmdsByLayer :: MutablePrimArray RealWorld DrawCmd -> Int -> IO (PrimArray DrawCmd, PrimArray LayerSlice)
groupCmdsByLayer :: MutablePrimArray RealWorld DrawCmd
-> Int -> IO (PrimArray DrawCmd, PrimArray LayerSlice)
groupCmdsByLayer MutablePrimArray RealWorld DrawCmd
src Int
n = do
  let layers :: Int
layers = Layer -> Int
forall a. Enum a => a -> Int
fromEnum (Layer
forall a. Bounded a => a
maxBound :: Layer) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      layerAt :: Int -> IO Int
layerAt Int
i = Layer -> Int
forall a. Enum a => a -> Int
fromEnum (Layer -> Int) -> (DrawCmd -> Layer) -> DrawCmd -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DrawCmd -> Layer
cmdLayer (DrawCmd -> Int) -> IO DrawCmd -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutablePrimArray (PrimState IO) DrawCmd -> Int -> IO DrawCmd
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld DrawCmd
MutablePrimArray (PrimState IO) DrawCmd
src Int
i
  counts <- Int -> IO (MutablePrimArray (PrimState IO) Int)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
layers
  setPrimArray counts 0 layers (0 :: Int)
  loopIO 0 (n - 1) $ \Int
i -> do
    l <- Int -> IO Int
layerAt Int
i
    readPrimArray counts l >>= writePrimArray counts l . (+ 1)
  cursors <- newPrimArray layers
  slices <- newPrimArray layers
  let offsets !Int
l !Int
off =
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
layers) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          c <- MutablePrimArray (PrimState IO) Int -> Int -> IO Int
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld Int
MutablePrimArray (PrimState IO) Int
counts Int
l
          writePrimArray cursors l off
          writePrimArray slices l (LayerSlice off c)
          offsets (l + 1) (off + c)
  offsets 0 0
  dest <- newPrimArray n
  loopIO 0 (n - 1) $ \Int
i -> do
    cmd <- MutablePrimArray (PrimState IO) DrawCmd -> Int -> IO DrawCmd
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> m a
readPrimArray MutablePrimArray RealWorld DrawCmd
MutablePrimArray (PrimState IO) DrawCmd
src Int
i
    let l = Layer -> Int
forall a. Enum a => a -> Int
fromEnum (DrawCmd -> Layer
cmdLayer DrawCmd
cmd)
    j <- readPrimArray cursors l
    writePrimArray dest j cmd
    writePrimArray cursors l (j + 1)
  (,) <$> unsafeFreezePrimArray dest <*> unsafeFreezePrimArray slices

{-# INLINE unpackColorF #-}
unpackColorF :: Color -> (Float, Float, Float, Float)
unpackColorF :: Color -> (Float, Float, Float, Float)
unpackColorF (Color Word32
w) =
  let !inv255 :: Float
inv255 = Float
1.0 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
255.0
      !r :: Float
r = Word32 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
24) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
inv255
      !g :: Float
g = Word32 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
inv255
      !b :: Float
b = Word32 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
8) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
inv255
      !a :: Float
a = Word32 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
inv255
   in (Float
r, Float
g, Float
b, Float
a)

-- Allocate room for a primitive, hand the derived offsets to the body, and
-- commit the vertex/index counts afterwards. INLINE: erased at -O.
{-# INLINE withVerts #-}
withVerts :: DrawArena -> Int -> Int -> (Ptr Word8 -> Ptr Word8 -> Int -> Int -> Word32 -> IO ()) -> IO ()
withVerts :: DrawArena
-> Int
-> Int
-> (Ptr Word8 -> Ptr Word8 -> Int -> Int -> Word32 -> IO ())
-> IO ()
withVerts DrawArena
da Int
needV Int
needI Ptr Word8 -> Ptr Word8 -> Int -> Int -> Word32 -> IO ()
f = do
  (vp, ip, base, baseIdx) <- DrawArena -> Int -> Int -> IO (Ptr Word8, Ptr Word8, Int, Int)
ensureAndAlloc DrawArena
da Int
needV Int
needI
  let !vOff = Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
vertexSize
      !iOff = Int
baseIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
indexSize
      !baseIdxWord = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
base :: Word32
  f vp ip vOff iOff baseIdxWord
  writeIORef (daVertexCount da) (base + needV)
  writeIORef (daIndexCount da) (baseIdx + needI)

-- Like 'withVerts' but for primitives that index vertices relative to 'base'
-- themselves instead of using one contiguous offset.
{-# INLINE withVertsRaw #-}
withVertsRaw :: DrawArena -> Int -> Int -> (Ptr Word8 -> Ptr Word8 -> Int -> Int -> IO ()) -> IO ()
withVertsRaw :: DrawArena
-> Int
-> Int
-> (Ptr Word8 -> Ptr Word8 -> Int -> Int -> IO ())
-> IO ()
withVertsRaw DrawArena
da Int
needV Int
needI Ptr Word8 -> Ptr Word8 -> Int -> Int -> IO ()
f = do
  (vp, ip, base, baseIdx) <- DrawArena -> Int -> Int -> IO (Ptr Word8, Ptr Word8, Int, Int)
ensureAndAlloc DrawArena
da Int
needV Int
needI
  f vp ip base baseIdx
  writeIORef (daVertexCount da) (base + needV)
  writeIORef (daIndexCount da) (baseIdx + needI)

-- | Reserve room for up to @maxV@ vertices / @maxI@ indices, hand the body a
-- commit action, then record only the counts the body reports. Batches many
-- small quads (text glyphs) into one arena reservation instead of one
-- @withVerts@ closure + capacity check per quad.
{-# INLINE withVertsReserve #-}
withVertsReserve ::
  DrawArena ->
  Int ->
  Int ->
  (Ptr Word8 -> Ptr Word8 -> Int -> Int -> (Int -> Int -> IO ()) -> IO ()) ->
  IO ()
withVertsReserve :: DrawArena
-> Int
-> Int
-> (Ptr Word8
    -> Ptr Word8 -> Int -> Int -> (Int -> Int -> IO ()) -> IO ())
-> IO ()
withVertsReserve DrawArena
da Int
maxV Int
maxI Ptr Word8
-> Ptr Word8 -> Int -> Int -> (Int -> Int -> IO ()) -> IO ()
f = do
  (vp, ip, base, baseIdx) <- DrawArena -> Int -> Int -> IO (Ptr Word8, Ptr Word8, Int, Int)
ensureAndAlloc DrawArena
da Int
maxV Int
maxI
  f vp ip base baseIdx $ \Int
nv Int
ni -> do
    IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (DrawArena -> IORef Int
daVertexCount DrawArena
da) (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nv)
    IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (DrawArena -> IORef Int
daIndexCount DrawArena
da) (Int
baseIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ni)

-- | Strict numeric loop. Replaces @forM_ [lo .. hi]@ on the rounded-geometry
-- hot path, where the intermediate range list was a measurable allocation and
-- prevented the body from fusing into a straight-line loop.
{-# INLINE loopIO #-}
loopIO :: Int -> Int -> (Int -> IO ()) -> IO ()
loopIO :: Int -> Int -> (Int -> IO ()) -> IO ()
loopIO !Int
lo !Int
hi Int -> IO ()
f = Int -> IO ()
go Int
lo
  where
    go :: Int -> IO ()
go !Int
i
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
hi = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = Int -> IO ()
f Int
i IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

{-# INLINE pushQuad #-}
pushQuad :: DrawArena -> Rect -> Float -> Float -> Float -> Float -> Color -> IO ()
pushQuad :: DrawArena
-> Rect -> Float -> Float -> Float -> Float -> Color -> IO ()
pushQuad DrawArena
da (Rect Float
x Float
y Float
w Float
h) Float
u0 Float
v0 Float
u1 Float
v1 Color
col = do
  let !(Float
r, Float
g, Float
b, Float
a) = Color -> (Float, Float, Float, Float)
unpackColorF Color
col
  DrawArena
-> Int
-> Int
-> (Ptr Word8 -> Ptr Word8 -> Int -> Int -> Word32 -> IO ())
-> IO ()
withVerts DrawArena
da Int
4 Int
6 ((Ptr Word8 -> Ptr Word8 -> Int -> Int -> Word32 -> IO ())
 -> IO ())
-> (Ptr Word8 -> Ptr Word8 -> Int -> Int -> Word32 -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
vp Ptr Word8
ip Int
vOff Int
iOff Word32
baseIdxWord ->
    Ptr Word8
-> Int
-> Ptr Word8
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Word32
-> IO ()
pokeQuadSIMD Ptr Word8
vp Int
vOff Ptr Word8
ip Int
iOff Float
x Float
y Float
w Float
h Float
u0 Float
v0 Float
u1 Float
v1 Float
r Float
g Float
b Float
a Word32
baseIdxWord

{-# INLINE snapRectOrigin #-}
snapRectOrigin :: DrawArena -> Rect -> IO Rect
snapRectOrigin :: DrawArena -> Rect -> IO Rect
snapRectOrigin DrawArena
da (Rect Float
x Float
y Float
w Float
h) = do
  s <- IORef Float -> IO Float
forall a. IORef a -> IO a
readIORef (DrawArena -> IORef Float
daSnapScale DrawArena
da)
  pure (Rect (onGrid s x) (onGrid s y) w h)

{-# INLINE pokeQuadIndices #-}
pokeQuadIndices :: Ptr Word8 -> Int -> Word32 -> Word32 -> Word32 -> Word32 -> IO ()
pokeQuadIndices :: Ptr Word8 -> Int -> Word32 -> Word32 -> Word32 -> Word32 -> IO ()
pokeQuadIndices Ptr Word8
ip Int
off Word32
a Word32
b Word32
c Word32
d = do
  Ptr Word8 -> Int -> Word32 -> IO ()
forall b. Ptr b -> Int -> Word32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
ip Int
off Word32
a
  Ptr Word8 -> Int -> Word32 -> IO ()
forall b. Ptr b -> Int -> Word32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
ip (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) Word32
b
  Ptr Word8 -> Int -> Word32 -> IO ()
forall b. Ptr b -> Int -> Word32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
ip (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8) Word32
c
  Ptr Word8 -> Int -> Word32 -> IO ()
forall b. Ptr b -> Int -> Word32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
ip (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
12) Word32
a
  Ptr Word8 -> Int -> Word32 -> IO ()
forall b. Ptr b -> Int -> Word32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
ip (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
16) Word32
c
  Ptr Word8 -> Int -> Word32 -> IO ()
forall b. Ptr b -> Int -> Word32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
ip (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
20) Word32
d

-- | Center of the 4x4 white pixel patch in the 1024x1024 font atlas.
whitePixelU :: Float
whitePixelU :: Float
whitePixelU = Float
1.5 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
1024.0

whitePixelV :: Float
whitePixelV :: Float
whitePixelV = Float
1.5 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
1024.0