ktx-font-0.2.0.0: demo/Main.hs

module Main (main) where

import Brillo.Data.Bitmap
import Brillo.Interface.Environment (getScreenSize)
import Brillo.Interface.IO.Game
import Codec.Compression.Zstd qualified as Zstd
import Codec.Ktx2.Font qualified as Ktxf
import Codec.Ktx2.Font.Layout qualified as Layout
import Codec.Ktx2.Font.Shaping qualified as Shaping
import Codec.Ktx2.Header qualified as Ktx2
import Codec.Ktx2.Read qualified as Ktx2
import Control.Exception (bracket)
import Data.ByteString (ByteString)
import Data.ByteString.Internal qualified as ByteString
import Data.Foldable
import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Traversable
import Foreign.ForeignPtr (touchForeignPtr)
import Graphics.MSDF.Atlas.Compact qualified as Atlas

import Debug.Trace

-- | Demo bundles built from @assets.yaml@ with an uncompressed (rgba8) texture.
--
-- The shaper tries the fonts from the top of the stack, so the last one
-- is the default and the fallbacks go before it.
sources :: [FilePath]
sources =
  [ "assets/demo/NotoEmoji-Regular.ktxf" -- fallback
  , "assets/demo/NotoSans-Regular.ktxf" -- fallback
  , "assets/demo/MapleMono-Regular.ktxf" -- default
  ]

main :: IO ()
main = do
  -- fonts are loaded, but detached
  allFontsTextures <- for sources \ktxf -> do
    bundle <- Ktxf.loadBundleFile ktxf
    texture <- readFontTexture ktxf -- load and prepare for Brillo
    pure (bundle, texture)

  let allFonts = fmap fst allFontsTextures
  bracket (Ktxf.createStackContext allFonts) Ktxf.destroyStackContext \ctx' -> do
    -- ctx is a stack for the particular collection of fonts.
    -- We still have to front-load all the content for fonts used in the withFont_ sections.
    let ctx = Ktxf.mapWithBundle (fmap const <$> allFontsTextures) ctx'

    let
      txt = Text.unlines
        [ "<=> ->> =/= transduce_ Hff" -- ligatures welcome
        , "" -- empty line should be present
        , "Sphinx of black quartz, judge my vow."
        , "Příliš žluťoučký kůň úpěl ďábelské ódy"
        , "Eĥoŝanĝoj ĉiuĵaŭde ☝️🤪."
        , "Not in MapleMono: Ꞹ₿₪ᵺꭒ"
        , "🤯Ебучие шрифты! Как они вообще работают?!"
        , "Victor jagt zwölf Boxkämpfer quer über den großen Sylter Deich"
        ]
      lineHeight = 2.0 -- distance between baselines, set to 2x cap height and ignoring ascenders/descenders
      targetSize = 32 -- pixels per cap height
      wrapPx = 1280 -- maximum line width, in pixels
      strategy = Layout.Greedy
      mpos = (0, 0)
      placed = []
    style <- Layout.bundleStyle ctx (last allFonts)
    world <- relayout World{..}
    playIO
      FullScreen
      (greyN 0.125)
      2
      world
      (\w -> getScreenSize >>= render w)
      (flip onEvent)
      (const pure)
      -- (\_dt w -> handleKey w $ SpecialKey KeyTab)

    -- XXX: also, prevents FontData inside bundles from slipping away
    for_ allFontsTextures \(bundle, texture) -> do
      traceM $ "Letting go of " <> show texture
      Ktxf.freeBundle bundle
      touchTexture texture

woop :: Text -> Text
woop t = case Text.splitAt 1 t of (a, b) -> b <> a

-- XXX: BitmapData keeps the texture ForeignPointer
readFontTexture :: FilePath -> IO Texture
readFontTexture path = do
  ktx <- Ktx2.open path
  let
    Ktx2.Header{supercompressionScheme, pixelWidth, pixelHeight} = Ktx2.header ktx
    wh = (fromIntegral pixelWidth, fromIntegral pixelHeight)
  print (Ktx2.header ktx, wh)
  levels <- Ktx2.levels ktx
  mip0' <-
    case toList levels of
      [] -> error $ "No mip levels in " <> path
      level0 : _ -> Ktx2.levelData ktx level0
  mip0 <-
    case supercompressionScheme of
      0 ->
        pure mip0'
      2 ->
        case Zstd.decompress mip0' of
          Zstd.Decompress bs -> pure bs
          Zstd.Error err -> error err
          Zstd.Skip -> error "empty level data"
      huh ->
        error $ "unsupported supercompressionScheme: " <> show huh
  Ktx2.close ktx
  let ByteString.BS fptr len = mip0
  pure $! Texture path mip0 wh $
   BitmapData len (BitmapFormat TopToBottom PxRGBA) (fromIntegral pixelWidth, fromIntegral pixelHeight) True fptr

data World = World
  { ctx :: Ktxf.StackContext Texture
  , mpos :: (Float, Float)
  , txt :: Text
  , style :: Layout.TextStyle
  , lineHeight :: Float
  , wrapPx :: Float
  , strategy :: Layout.Strategy
  , placed :: [Layout.PlacedLine]
  , targetSize :: Float
  }

relayout :: World -> IO World
relayout w@World{..} = do
  results <- Layout.layoutTextWith
    Layout.LayoutOptions
      { cursor = Shaping.initialCursorDown lineHeight
      , strategy
      , align = Layout.AlignLeft
      }
    ctx style (wrapPx / targetSize) txt
  pure w{placed = results}

data Texture = Texture FilePath ByteString (Float, Float) BitmapData

touchTexture :: Texture -> IO ()
touchTexture (Texture _ bs _ _) = touchForeignPtr fp
  where
    (fp, _, _) = ByteString.toForeignPtr bs

instance Show Texture where
  show (Texture src _ _ _) = show src

textureSection :: Texture -> Atlas.Box -> Picture
textureSection (Texture _ _ (tw, th) bd) ab = BitmapSection rect bd
  where
    Atlas.Box{x=ax, y=ay, w=aw, h=ah} = ab
    rect = Rectangle{rectPos, rectSize}
    -- rectPos = (round $ ax * tw, round $ th - (ay + ah) * th) -- when atlas is yBottom
    rectPos = (round $ ax * tw, round $ ay * th) -- when atlas is yTop
    rectSize = (round $ aw * tw, round $ ah * th)

render :: World -> (Int, Int) -> IO Picture
render World{ctx, mpos = (mx, my), lineHeight, targetSize, wrapPx, placed} (screenW, screenH) = pure . mconcat $ measures : letters
  where
    lineSize = lineHeight * targetSize

    measures = mconcat $ drop 2
      [ Translate (-1920) 250 . Color red . Scale 0.5 0.5 $ Text (Text.pack $ show (targetSize, bb))
      , Translate bx by . Color yellow $ rectangleWire bw bh <> Circle 3 <> Circle 5 -- the "natural position of the box"
      -- , Color yellow $ Line [(ax, ay), (bx, by)] -- the offset
      , Color white $ Circle 2 <> Circle 7 -- middle of the screen
      , Translate ax ay $ Color red $ rectangleWire bw bh -- the aligned box that should contain the text
      , Translate gx gy  $ mconcat
        [ Color green $ Line [(0, 0), (bw, 0)]
        , Color yellow $ Line [(0, 0), (bx, by)]
        , Color blue $ Line [(0, targetSize), (bw, targetSize)]
        , Color cyan $ Circle 4 <> Circle targetSize <> Circle (targetSize * lineHeight)
        , Color magenta $ Line [(wrapPx, targetSize), (wrapPx, targetSize - bh)] -- wrap width guide
        ]
      ]

    annRuns = flip mapMaybe (Layout.placedRuns placed) \((font, atlas_), glyphs) -> do
      tex <- Ktxf.lookupBundled font ctx
      Atlas.Compact{_type, _size} <- atlas_
      pure (tex, 1 / _size, glyphs)

    letters = foldMap drawRun annRuns

    drawRun (tex, pixelsToNorm, glyphs) = map (drawGlyph tex pixelsToNorm) glyphs

    drawGlyph tex pixelsToNorm Shaping.PlacedGlyph{glyph, plane=Atlas.Box{x, y}} = -- w/h are used from ab, in pixels
      Translate gx gy $ -- move around in pixels to fit into the aligned box
        Scale targetSize targetSize $ -- scale to target
        Translate x y $ -- text layout in normalized units (static!)
          -- flip mappend (Color yellow $ rectangleWire w h) $ -- a box of each glyph
          Scale pixelsToNorm pixelsToNorm $ -- bitmap sections are in pixels, move to normalized units
            textureSection tex glyph

    gx = ax - bw * 0.5
    gy = ay + bh * 0.5 - targetSize -- first caps line at the box top, then the cursor goes down
    ax = mx * (fromIntegral screenW - bw)
    ay = my * (fromIntegral screenH - bh)
    nLines = fromIntegral $ length placed
    bh = nLines * lineSize

    bb@(bx, by, bw, _bh) = toBox $ foldl' grow (-1e6, -1e6, 1e6, 1e6) trbls
      where
        toBox (t, r, b, l) =
          ( l * 0.5 + r * 0.5
          , b * 0.5 + t * 0.5
          , abs $ r - l
          , abs $ b - t
          )

        grow (t1, r1, b1, l1) (t2, r2, b2, l2) =
          ( max t1 t2
          , max r1 r2
          , min b1 b2
          , min l1 l2
          )

        trbls = do
          (_, _, glyphs) <- annRuns
          Shaping.PlacedGlyph{plane} <- glyphs
          let Atlas.Box{x, y, w} = Atlas.scaleBox targetSize plane
          pure
            ( y + 0.5 -- XXX: ignoring glyph height and using cap height (the sizes are normalized to it)
            , x + w * 0.5
            , y - 0.5 -- ditto
            , x - w * 0.5
            )

onEvent :: World -> Event -> IO World
onEvent w = \case
  EventKey key Down _ _pos -> handleKey w key
  EventMotion (mx, my) -> pure w{mpos = (mx / 2 / 1920, my / 2 / 1080)}
  _ -> pure w

handleKey :: World -> Key -> IO World
handleKey w@World{txt = old, ..} = \case
  SpecialKey KeyTab ->
    relayout w{txt = woop old}
  Char c ->
    relayout w{txt = old `Text.snoc` c}
  SpecialKey KeySpace ->
    relayout w{txt = old `Text.snoc` ' '}
  SpecialKey KeyEnter ->
    relayout w{txt = old `Text.snoc` '\n'}
  SpecialKey KeyBackspace ->
    if Text.null old then
      pure w
    else
      relayout w{txt = Text.init old}
  SpecialKey KeyPageUp ->
    relayout w{targetSize = targetSize + 1}
  SpecialKey KeyPageDown ->
    relayout w{targetSize = targetSize - 1}
  SpecialKey KeyHome ->
    relayout w{targetSize = targetSize * 2}
  SpecialKey KeyEnd ->
    relayout w{targetSize = targetSize / 2}
  SpecialKey KeyLeft ->
    relayout w{wrapPx = max 40 $ wrapPx - 40}
  SpecialKey KeyRight ->
    relayout w{wrapPx = wrapPx + 40}
  SpecialKey KeyF1 ->
    relayout w{strategy = flipStrategy strategy}
  eh -> do
    print eh
    pure w
  where
    flipStrategy = \case
      Layout.Greedy -> Layout.Optimal
      Layout.Optimal -> Layout.Greedy