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.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.Foldable import Data.Maybe import Data.Text (Text) import Data.Text qualified as Text import Data.Traversable import Graphics.MSDF.Atlas.Compact qualified as Atlas type AllFonts a = [a] sources :: AllFonts FilePath sources = [ "assets/NotoEmoji-Regular.ktxf" -- fallback , "assets/NotoSans-Regular.ktxf" -- fallback , "assets/Ubuntu-R.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) bracket (Ktxf.createStackContext $ map fst allFontsTextures) Ktxf.destroyStackContext \ctx' -> do -- ctx is a stack for the particular collection of fonts -- here, AllFonts. let ctx = Ktxf.mapWithBundle [ (b, const t) | (b, t) <- allFontsTextures] ctx' let -- txt = "λ🤪.🤪" txt = Text.unlines [ "‹^transduce_› Hff" , "" -- 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 Ubuntu: Ꞹ₿₪ᵺꭒ" , "🤯Ебучие шрифты! Как они вообще работают?!" , "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 mpos = (0, 0) runs <- Shaping.shapeText (Shaping.Cursor 0 0 lineHeight) ctx' txt 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) -> Ktxf.freeBundle bundle 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' <- Ktx2.levelData ktx $ head (toList levels) 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 pure $! Texture mip0 wh $ bitmapDataOfByteString (fromIntegral pixelWidth) (fromIntegral pixelHeight) (BitmapFormat TopToBottom PxRGBA) mip0 True data World = World { ctx :: Ktxf.StackContext Texture , mpos :: (Float, Float) , txt :: Text , lineHeight :: Float , runs :: [Shaping.PlacedRun] , targetSize :: Float } data Texture = Texture ByteString (Float, Float) BitmapData 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, 1.0 - round (ay + ah)) -- when atlas is yBottom or bd is from BMP? 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, txt, runs} (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) ] ] annRuns = flip mapMaybe runs \((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 - lineSize ax = mx * (fromIntegral screenW - bw) ay = my * (fromIntegral screenH - bh) nLines = fromIntegral . length $ Text.lines txt 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 -> reshape $ woop old Char c -> reshape $ old `Text.snoc` c SpecialKey KeySpace -> reshape $ old `Text.snoc` ' ' SpecialKey KeyEnter -> reshape $ old `Text.snoc` '\n' SpecialKey KeyBackspace -> if Text.null old then pure w else reshape $ Text.init old SpecialKey KeyPageUp -> pure w{targetSize = targetSize + 1} SpecialKey KeyPageDown -> pure w{targetSize = targetSize - 1} SpecialKey KeyHome -> pure w{targetSize = targetSize * 2} SpecialKey KeyEnd -> pure w{targetSize = targetSize / 2} eh -> do print eh pure w where reshape new = do results <- Shaping.shapeText (Shaping.Cursor 0 0 lineHeight) ctx new pure w{txt = new, runs = results}