module Codec.Ktx2.Font.Shaping
  ( shape
  , Cursor(..)
  , initialCursor
  , PlacedRun
  -- * re-exports
  , KBTS.Font
  , Atlas.Compact(..)
  , Atlas.Box(..)
  ) where

import Codec.Ktx2.Font qualified as Font
import Control.Concurrent (withMVar)
import Data.List (mapAccumL)
import Data.Text (Text)
import Data.Text qualified as Text
import Graphics.MSDF.Atlas.Compact qualified as Atlas
import KB.Text.Shape qualified as TextShape
import KB.Text.Shape.Font qualified as KBTS

shape :: Cursor -> Font.StackContext a -> Text -> IO [PlacedRun]
shape :: forall a. Cursor -> StackContext a -> Text -> IO [PlacedRun]
shape Cursor
cur ctx :: StackContext a
ctx@Font.StackContext{MVar Context
shapeContext :: MVar Context
shapeContext :: forall a. StackContext a -> MVar Context
shapeContext} Text
t =
  if Text -> Bool
Text.null Text
t then
    [PlacedRun] -> IO [PlacedRun]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  else
    MVar Context -> (Context -> IO [PlacedRun]) -> IO [PlacedRun]
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Context
shapeContext \Context
kbts ->
      Cursor -> StackContext a -> [(Run, [Glyph])] -> [PlacedRun]
forall a.
Cursor -> StackContext a -> [(Run, [Glyph])] -> [PlacedRun]
collect Cursor
cur StackContext a
ctx ([(Run, [Glyph])] -> [PlacedRun])
-> IO [(Run, [Glyph])] -> IO [PlacedRun]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context
-> ((?shapeContext::ShapeContext) => IO ()) -> IO [(Run, [Glyph])]
TextShape.run Context
kbts ((?shapeContext::ShapeContext) => Text -> IO ()
Text -> IO ()
TextShape.text_ Text
t)

data Cursor = Cursor
  { Cursor -> Float
curX, Cursor -> Float
curY :: Float
  , Cursor -> Float
lineHeight :: Float -- ^ Space between the baselines, as a multiple of the font size.
  }
  deriving (Cursor -> Cursor -> Bool
(Cursor -> Cursor -> Bool)
-> (Cursor -> Cursor -> Bool) -> Eq Cursor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Cursor -> Cursor -> Bool
== :: Cursor -> Cursor -> Bool
$c/= :: Cursor -> Cursor -> Bool
/= :: Cursor -> Cursor -> Bool
Eq, Int -> Cursor -> ShowS
[Cursor] -> ShowS
Cursor -> String
(Int -> Cursor -> ShowS)
-> (Cursor -> String) -> ([Cursor] -> ShowS) -> Show Cursor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Cursor -> ShowS
showsPrec :: Int -> Cursor -> ShowS
$cshow :: Cursor -> String
show :: Cursor -> String
$cshowList :: [Cursor] -> ShowS
showList :: [Cursor] -> ShowS
Show)

initialCursor
  :: Float -- ^ Line height multiplier.
  -> Cursor
initialCursor :: Float -> Cursor
initialCursor = Float -> Float -> Float -> Cursor
Cursor Float
0 Float
0

type PlacedRun =
  ( (KBTS.Font, Maybe Atlas.Compact)
  , [(Char, Atlas.Box, Atlas.Box)]
  )

collect :: Cursor -> Font.StackContext a -> [(TextShape.Run, [TextShape.Glyph])] -> [PlacedRun]
collect :: forall a.
Cursor -> StackContext a -> [(Run, [Glyph])] -> [PlacedRun]
collect Cursor
cur StackContext a
ctx = (Cursor, [PlacedRun]) -> [PlacedRun]
forall a b. (a, b) -> b
snd ((Cursor, [PlacedRun]) -> [PlacedRun])
-> ([(Run, [Glyph])] -> (Cursor, [PlacedRun]))
-> [(Run, [Glyph])]
-> [PlacedRun]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cursor -> (Run, [Glyph]) -> (Cursor, PlacedRun))
-> Cursor -> [(Run, [Glyph])] -> (Cursor, [PlacedRun])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (StackContext a -> Cursor -> (Run, [Glyph]) -> (Cursor, PlacedRun)
forall a.
StackContext a -> Cursor -> (Run, [Glyph]) -> (Cursor, PlacedRun)
collectRun StackContext a
ctx) Cursor
cur

collectRun :: Font.StackContext a -> Cursor -> (TextShape.Run, [TextShape.Glyph]) -> (Cursor, PlacedRun)
collectRun :: forall a.
StackContext a -> Cursor -> (Run, [Glyph]) -> (Cursor, PlacedRun)
collectRun StackContext a
ctx Cursor
cur (TextShape.Run{Font
font :: Font
font :: Run -> Font
font}, [Glyph]
glyphs) = [PlacedGlyph] -> PlacedRun
placedRun ([PlacedGlyph] -> PlacedRun)
-> (Cursor, [PlacedGlyph]) -> (Cursor, PlacedRun)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Cursor -> Glyph -> (Cursor, PlacedGlyph))
-> Cursor -> [Glyph] -> (Cursor, [PlacedGlyph])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (Float -> Maybe Compact -> Cursor -> Glyph -> (Cursor, PlacedGlyph)
place Float
fontUnitScale Maybe Compact
atlas_) Cursor
cur [Glyph]
glyphs
  where
    atlas_ :: Maybe Compact
atlas_ = Font -> StackContext a -> Maybe Compact
forall a. Font -> StackContext a -> Maybe Compact
Font.lookupAtlas Font
font StackContext a
ctx
    -- fontUnitScale = 1 / KBTS.unitsPerEm font
    fontUnitScale :: Float
fontUnitScale = Float
1 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Font -> Float
forall a. Num a => Font -> a
KBTS.capHeight Font
font

    placedRun :: [PlacedGlyph] -> PlacedRun
    placedRun :: [PlacedGlyph] -> PlacedRun
placedRun [PlacedGlyph]
placed =
      ( (Font
font, Maybe Compact
atlas_)
      , do
          (c, Just (ab, pb)) <- [PlacedGlyph]
placed
          pure (c, ab, pb)
      )

type PlacedGlyph = (Char, Maybe (Atlas.Box, Atlas.Box))

place :: Float -> Maybe Atlas.Compact -> Cursor -> TextShape.Glyph -> (Cursor, PlacedGlyph)
place :: Float -> Maybe Compact -> Cursor -> Glyph -> (Cursor, PlacedGlyph)
place Float
fontUnitScale Maybe Compact
atlas_ cur :: Cursor
cur@Cursor{Float
curX :: Cursor -> Float
curY :: Cursor -> Float
lineHeight :: Cursor -> Float
curX :: Float
curY :: Float
lineHeight :: Float
..} TextShape.Glyph{id :: Glyph -> Word16
id=Word16
glyphId, Char
Int
Maybe Glyph
Word8
Word16
Word32
Word64
UnicodeJoiningType
GlyphFlags
codepoint :: Char
uid :: Word16
codepointIndex :: Int
offsetX :: Int
offsetY :: Int
advanceX :: Int
advanceY :: Int
attachGlyph :: Maybe Glyph
decomposition :: Word64
classes :: Word32
flags :: GlyphFlags
joiningType :: UnicodeJoiningType
unicodeFlags :: Word8
syllabicClass :: Word8
syllabicPosition :: Word8
useClass :: Word8
combiningClass :: Word8
advanceX :: Glyph -> Int
advanceY :: Glyph -> Int
attachGlyph :: Glyph -> Maybe Glyph
classes :: Glyph -> Word32
codepoint :: Glyph -> Char
codepointIndex :: Glyph -> Int
combiningClass :: Glyph -> Word8
decomposition :: Glyph -> Word64
flags :: Glyph -> GlyphFlags
joiningType :: Glyph -> UnicodeJoiningType
offsetX :: Glyph -> Int
offsetY :: Glyph -> Int
syllabicClass :: Glyph -> Word8
syllabicPosition :: Glyph -> Word8
uid :: Glyph -> Word16
unicodeFlags :: Glyph -> Word8
useClass :: Glyph -> Word8
..} =
  if Char
codepoint Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' then
    (Cursor
cur{curX = 0, curY = curY + lineHeight * ySign}, (Char
codepoint, Maybe (Box, Box)
forall a. Maybe a
Nothing))
  else
    ( Cursor
cur
      { curX = curX + fromIntegral advanceX * fontUnitScale
      , curY = curY + fromIntegral advanceY * fontUnitScale * ySign
      }
    , (Char
codepoint, Maybe (Box, Box)
params_)
    )
  where
    ySign :: Float
ySign = -Float
1 -- XXX: should match atlas py direction
    params_ :: Maybe (Box, Box)
params_ = Maybe Compact
atlas_ Maybe Compact -> (Compact -> Maybe (Box, Box)) -> Maybe (Box, Box)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Compact -> Maybe (Box, Box)
Atlas.lookupGlyph (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
glyphId) Maybe (Box, Box)
-> ((Box, Box) -> Maybe (Box, Box)) -> Maybe (Box, Box)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Box, Box) -> Maybe (Box, Box)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Box, Box) -> Maybe (Box, Box))
-> ((Box, Box) -> (Box, Box)) -> (Box, Box) -> Maybe (Box, Box)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Box -> Box) -> (Box, Box) -> (Box, Box)
forall a b. (a -> b) -> (Box, a) -> (Box, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Box -> Box
placeGlyph
    placeGlyph :: Box -> Box
placeGlyph =
      Float -> Float -> Box -> Box
Atlas.moveBox
        (Float
curX Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offsetX Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
fontUnitScale)
        (Float
curY Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offsetY Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
fontUnitScale Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
ySign)