{-# LANGUAGE RecordWildCards #-}

-- | Flat span buffer: strided prim arrays for geometry and colors, boxed texts.
module NanoUI.Frame.SpanArena
  ( SpanArena
  , newSpanArena
  , resetSpanArena
  , pushSpan
  , spanArenaCount
  , spanArenaToList
  , spanArenaToListOccluded
  , foldSpanArena
  ) where

import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import qualified Data.IntMap.Strict as IM
import Data.Primitive.Array (MutableArray, copyMutableArray, newArray, readArray, sizeofMutableArray, writeArray)
import Data.Primitive.PrimArray
  ( MutablePrimArray
  , newPrimArray
  , readPrimArray
  , resizeMutablePrimArray
  , writePrimArray
  )
import Data.Text (Text)
import qualified Data.Text as T
import Data.Word (Word32)
import GHC.Exts (RealWorld)
import NanoUI.Types (Color (..), Rect (..), colorToWord32, rectFullyInside, rectIntersect)

data SpanArena = SpanArena
  { SpanArena -> IORef Int
saCount :: IORef Int
  , SpanArena -> IORef SpanArenaArrays
saArrays :: IORef SpanArenaArrays
  }

-- | Span columns. @saRects@ holds 'rectStride' floats per span (the span rect,
-- then its clip), @saColors@ the foreground and background, and @saTexts@ one
-- text per span; its size is the capacity.
data SpanArenaArrays = SpanArenaArrays
  { SpanArenaArrays -> MutablePrimArray RealWorld Float
saRects :: !(MutablePrimArray RealWorld Float)
  , SpanArenaArrays -> MutablePrimArray RealWorld Word32
saColors :: !(MutablePrimArray RealWorld Word32)
  , SpanArenaArrays -> MutableArray RealWorld Text
saTexts :: !(MutableArray RealWorld Text)
  }

rectStride :: Int
rectStride :: Int
rectStride = Int
8

newSpanArena :: Int -> IO SpanArena
newSpanArena :: Int -> IO SpanArena
newSpanArena Int
cap0 = do
  let cap :: Int
cap = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
16 Int
cap0
  saCount <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
  saRects <- newPrimArray (cap * rectStride)
  saColors <- newPrimArray (cap * 2)
  saTexts <- newArray cap T.empty
  saArrays <- newIORef SpanArenaArrays {..}
  pure SpanArena {..}

resetSpanArena :: SpanArena -> IO ()
resetSpanArena :: SpanArena -> IO ()
resetSpanArena SpanArena
sa = IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (SpanArena -> IORef Int
saCount SpanArena
sa) Int
0

spanArenaCount :: SpanArena -> IO Int
spanArenaCount :: SpanArena -> IO Int
spanArenaCount SpanArena
sa = IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (SpanArena -> IORef Int
saCount SpanArena
sa)

{-# NOINLINE growSpanArena #-}
growSpanArena :: SpanArena -> SpanArenaArrays -> Int -> IO SpanArenaArrays
growSpanArena :: SpanArena -> SpanArenaArrays -> Int -> IO SpanArenaArrays
growSpanArena SpanArena
sa SpanArenaArrays {saRects :: SpanArenaArrays -> MutablePrimArray RealWorld Float
saRects = MutablePrimArray RealWorld Float
rects, saColors :: SpanArenaArrays -> MutablePrimArray RealWorld Word32
saColors = MutablePrimArray RealWorld Word32
colors, saTexts :: SpanArenaArrays -> MutableArray RealWorld Text
saTexts = MutableArray RealWorld Text
texts} Int
needed = do
  let cap :: Int
cap = MutableArray RealWorld Text -> Int
forall s a. MutableArray s a -> Int
sizeofMutableArray MutableArray RealWorld Text
texts
      newCap :: Int
newCap = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
needed (Int
cap Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)
  saRects <- MutablePrimArray (PrimState IO) Float
-> Int -> IO (MutablePrimArray (PrimState IO) Float)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> m (MutablePrimArray (PrimState m) a)
resizeMutablePrimArray MutablePrimArray RealWorld Float
MutablePrimArray (PrimState IO) Float
rects (Int
newCap Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
rectStride)
  saColors <- resizeMutablePrimArray colors (newCap * 2)
  saTexts <- newArray newCap T.empty
  copyMutableArray saTexts 0 texts 0 cap
  let a = SpanArenaArrays {MutableArray RealWorld Text
MutablePrimArray RealWorld Float
MutablePrimArray RealWorld Word32
saRects :: MutablePrimArray RealWorld Float
saColors :: MutablePrimArray RealWorld Word32
saTexts :: MutableArray RealWorld Text
saRects :: MutablePrimArray RealWorld Float
saColors :: MutablePrimArray RealWorld Word32
saTexts :: MutableArray RealWorld Text
..}
  writeIORef (saArrays sa) a
  pure a

{-# INLINE pushSpan #-}
pushSpan :: SpanArena -> Rect -> Text -> Color -> Color -> Rect -> IO ()
pushSpan :: SpanArena -> Rect -> Text -> Color -> Color -> Rect -> IO ()
pushSpan SpanArena
sa (Rect Float
x Float
y Float
w Float
h) Text
txt Color
fg Color
bg (Rect Float
cx Float
cy Float
cw Float
ch) = do
  i <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (SpanArena -> IORef Int
saCount SpanArena
sa)
  a0 <- readIORef (saArrays sa)
  SpanArenaArrays {..} <-
    if i < sizeofMutableArray (saTexts a0) then pure a0 else growSpanArena sa a0 (i + 1)
  let !r = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
rectStride
  writePrimArray saRects r x
  writePrimArray saRects (r + 1) y
  writePrimArray saRects (r + 2) w
  writePrimArray saRects (r + 3) h
  writePrimArray saRects (r + 4) cx
  writePrimArray saRects (r + 5) cy
  writePrimArray saRects (r + 6) cw
  writePrimArray saRects (r + 7) ch
  writePrimArray saColors (2 * i) (colorToWord32 fg)
  writePrimArray saColors (2 * i + 1) (colorToWord32 bg)
  writeArray saTexts i txt
  writeIORef (saCount sa) (i + 1)

spanArenaToList :: SpanArena -> IO [(Rect, Text, Color, Color, Rect)]
spanArenaToList :: SpanArena -> IO [(Rect, Text, Color, Color, Rect)]
spanArenaToList = IntMap Rect -> SpanArena -> IO [(Rect, Text, Color, Color, Rect)]
spanArenaToListOccluded IntMap Rect
forall a. IntMap a
IM.empty

-- | Spans in push order, dropping those hidden behind @panels@.
spanArenaToListOccluded :: IM.IntMap Rect -> SpanArena -> IO [(Rect, Text, Color, Color, Rect)]
spanArenaToListOccluded :: IntMap Rect -> SpanArena -> IO [(Rect, Text, Color, Color, Rect)]
spanArenaToListOccluded IntMap Rect
panels SpanArena
sa =
  IntMap Rect
-> SpanArena
-> Bool
-> ([(Rect, Text, Color, Color, Rect)]
    -> Rect
    -> Text
    -> Color
    -> Color
    -> Rect
    -> IO [(Rect, Text, Color, Color, Rect)])
-> [(Rect, Text, Color, Color, Rect)]
-> IO [(Rect, Text, Color, Color, Rect)]
forall acc.
IntMap Rect
-> SpanArena
-> Bool
-> (acc -> Rect -> Text -> Color -> Color -> Rect -> IO acc)
-> acc
-> IO acc
foldSpans IntMap Rect
panels SpanArena
sa Bool
True (\[(Rect, Text, Color, Color, Rect)]
acc Rect
r Text
t Color
fg Color
bg Rect
c -> [(Rect, Text, Color, Color, Rect)]
-> IO [(Rect, Text, Color, Color, Rect)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Rect
r, Text
t, Color
fg, Color
bg, Rect
c) (Rect, Text, Color, Color, Rect)
-> [(Rect, Text, Color, Color, Rect)]
-> [(Rect, Text, Color, Color, Rect)]
forall a. a -> [a] -> [a]
: [(Rect, Text, Color, Color, Rect)]
acc)) []

foldSpanArena :: SpanArena -> (Rect -> Text -> Color -> Color -> Rect -> IO ()) -> IO ()
foldSpanArena :: SpanArena
-> (Rect -> Text -> Color -> Color -> Rect -> IO ()) -> IO ()
foldSpanArena SpanArena
sa Rect -> Text -> Color -> Color -> Rect -> IO ()
f = IntMap Rect
-> SpanArena
-> Bool
-> (() -> Rect -> Text -> Color -> Color -> Rect -> IO ())
-> ()
-> IO ()
forall acc.
IntMap Rect
-> SpanArena
-> Bool
-> (acc -> Rect -> Text -> Color -> Color -> Rect -> IO acc)
-> acc
-> IO acc
foldSpans IntMap Rect
forall a. IntMap a
IM.empty SpanArena
sa Bool
False (\()
_ Rect
r Text
t Color
fg Color
bg Rect
c -> Rect -> Text -> Color -> Color -> Rect -> IO ()
f Rect
r Text
t Color
fg Color
bg Rect
c) ()

-- | Fold over the spans not hidden behind @panels@, first to last, or last to
-- first when @backwards@ (so a consing fold builds a list in push order).
{-# INLINE foldSpans #-}
foldSpans ::
  IM.IntMap Rect ->
  SpanArena ->
  Bool ->
  (acc -> Rect -> Text -> Color -> Color -> Rect -> IO acc) ->
  acc ->
  IO acc
foldSpans :: forall acc.
IntMap Rect
-> SpanArena
-> Bool
-> (acc -> Rect -> Text -> Color -> Color -> Rect -> IO acc)
-> acc
-> IO acc
foldSpans IntMap Rect
panels SpanArena
sa Bool
backwards acc -> Rect -> Text -> Color -> Color -> Rect -> IO acc
f acc
z = do
  n <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (SpanArena -> IORef Int
saCount SpanArena
sa)
  SpanArenaArrays {..} <- readIORef (saArrays sa)
  let panelRects = IntMap Rect -> [Rect]
forall a. IntMap a -> [a]
IM.elems IntMap Rect
panels
      go !Int
i !acc
acc
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = acc -> IO acc
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure acc
acc
        | Bool
otherwise = do
            let !r :: Int
r = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
rectStride
            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
saRects Int
r
            y <- readPrimArray saRects (r + 1)
            w <- readPrimArray saRects (r + 2)
            h <- readPrimArray saRects (r + 3)
            cx <- readPrimArray saRects (r + 4)
            cy <- readPrimArray saRects (r + 5)
            cw <- readPrimArray saRects (r + 6)
            ch <- readPrimArray saRects (r + 7)
            fg <- readPrimArray saColors (2 * i)
            bg <- readPrimArray saColors (2 * i + 1)
            txt <- readArray saTexts i
            let rect = Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
y Float
w Float
h
                clip = Float -> Float -> Float -> Float -> Rect
Rect Float
cx Float
cy Float
cw Float
ch
            acc' <-
              if not (null panelRects) && spanOccluded panelRects rect clip
                then pure acc
                else f acc rect txt (Color fg) (Color bg) clip
            go (if backwards then i - 1 else i + 1) acc'
  go (if backwards then n - 1 else 0) z

spanOccluded :: [Rect] -> Rect -> Rect -> Bool
spanOccluded :: [Rect] -> Rect -> Rect -> Bool
spanOccluded [Rect]
panelRects Rect
rect Rect
clip =
  case Rect -> Rect -> Maybe Rect
rectIntersect Rect
rect Rect
clip of
    Maybe Rect
Nothing -> Bool
True
    Just Rect
visible -> (Rect -> Bool) -> [Rect] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Rect -> Rect -> Bool
rectFullyInside Rect
visible) [Rect]
panelRects