module Codec.Ktx2.Font.Shaping
  ( shapeText
  , shape
  , Cursor(..)
  , initialCursor
  , PlacedRun
  , PlacedGlyph(..)
  -- * 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.FFI.Handles qualified as Handles
import KB.Text.Shape.Font qualified as KBTS

{- | Perform text segmentation and shaping

The next step would be converting the

-}
shapeText :: Cursor -> Font.StackContext a -> Text -> IO [PlacedRun]
shapeText :: forall a. Cursor -> StackContext a -> Text -> IO [PlacedRun]
shapeText Cursor
cur StackContext a
ctx 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
    Cursor
-> StackContext a
-> ((?shapeContext::ShapeContext) => IO ())
-> IO [PlacedRun]
forall a.
Cursor
-> StackContext a
-> ((?shapeContext::ShapeContext) => IO ())
-> IO [PlacedRun]
shape Cursor
cur StackContext a
ctx ((?shapeContext::ShapeContext) => Text -> IO ()
Text -> IO ()
TextShape.text_ Text
t)

shape
  :: Cursor
  -> Font.StackContext a
  -> ((?shapeContext :: Handles.ShapeContext) => IO ())
  -> IO [PlacedRun]
shape :: forall a.
Cursor
-> StackContext a
-> ((?shapeContext::ShapeContext) => IO ())
-> IO [PlacedRun]
shape Cursor
cur ctx :: StackContext a
ctx@Font.StackContext{MVar Context
shapeContext :: MVar Context
shapeContext :: forall a. StackContext a -> MVar Context
shapeContext} (?shapeContext::ShapeContext) => IO ()
action =
  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 IO ()
(?shapeContext::ShapeContext) => IO ()
action

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

-- | Text runs with uniform direction and script.
type PlacedRun =
  ( (KBTS.Font, Maybe Atlas.Compact)
  , [PlacedGlyph]
  )

data PlacedGlyph = PlacedGlyph
  { PlacedGlyph -> Char
codepoint :: Char
  , PlacedGlyph -> Box
glyph :: Atlas.Box
  , PlacedGlyph -> Box
plane :: Atlas.Box
  }
  deriving (PlacedGlyph -> PlacedGlyph -> Bool
(PlacedGlyph -> PlacedGlyph -> Bool)
-> (PlacedGlyph -> PlacedGlyph -> Bool) -> Eq PlacedGlyph
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PlacedGlyph -> PlacedGlyph -> Bool
== :: PlacedGlyph -> PlacedGlyph -> Bool
$c/= :: PlacedGlyph -> PlacedGlyph -> Bool
/= :: PlacedGlyph -> PlacedGlyph -> Bool
Eq, Int -> PlacedGlyph -> ShowS
[PlacedGlyph] -> ShowS
PlacedGlyph -> String
(Int -> PlacedGlyph -> ShowS)
-> (PlacedGlyph -> String)
-> ([PlacedGlyph] -> ShowS)
-> Show PlacedGlyph
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PlacedGlyph -> ShowS
showsPrec :: Int -> PlacedGlyph -> ShowS
$cshow :: PlacedGlyph -> String
show :: PlacedGlyph -> String
$cshowList :: [PlacedGlyph] -> ShowS
showList :: [PlacedGlyph] -> ShowS
Show)

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) = [(Char, Maybe (Box, Box))] -> PlacedRun
placedRun ([(Char, Maybe (Box, Box))] -> PlacedRun)
-> (Cursor, [(Char, Maybe (Box, Box))]) -> (Cursor, PlacedRun)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Cursor -> Glyph -> (Cursor, (Char, Maybe (Box, Box))))
-> Cursor -> [Glyph] -> (Cursor, [(Char, Maybe (Box, Box))])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (Float
-> Maybe Compact
-> Cursor
-> Glyph
-> (Cursor, (Char, Maybe (Box, Box)))
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 :: [(Char, Maybe (Atlas.Box, Atlas.Box))] -> PlacedRun
    placedRun :: [(Char, Maybe (Box, Box))] -> PlacedRun
placedRun [(Char, Maybe (Box, Box))]
placed =
      ( (Font
font, Maybe Compact
atlas_)
      , do
          (codepoint, Just (glyph, plane)) <- [(Char, Maybe (Box, Box))]
placed
          pure PlacedGlyph{codepoint, glyph, plane}
      )

place :: Float -> Maybe Atlas.Compact -> Cursor -> TextShape.Glyph -> (Cursor, (Char, Maybe (Atlas.Box, Atlas.Box)))
place :: Float
-> Maybe Compact
-> Cursor
-> Glyph
-> (Cursor, (Char, Maybe (Box, Box)))
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)