diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,37 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## 0.2.0.0 - 2026-09-02 + +- Requires `kb-text-layout >= 0.1.2.0`, whose emergency breaks stop inside + shaping clusters, so a ligature is never split across lines by `placeText`. +- Migrated to `kb-text-shape >= 0.2.1.0`. The bundled kbts blobs changed + format, so the `.ktxf` assets have to be rebuilt. +- Added the `Codec.Ktx2.Font.Layout` module: multiline layout on top of + `kb-text-layout` with wrapping (greedy or optimal), alignment, and + measurement helpers, all in the same cap-height units as the glyph planes. + * `shapeText` does all the font work once, and the pure `placeText` breaks + and places the result for any width, so resizes don't touch the fonts. + * `layoutTextWith` is the two chained together. +- Added `Shaping.shapeClusters`: shaping along a single pen that keeps the + codepoint index and advance of every glyph. `unsafeShapeClusters` is the same + for callers already holding the locked context. +- `StackContext` gained a `layout` field with the measurement caches. +- The demo now lays out with wrapping: Left/Right adjust the wrap width, + F1 toggles the break strategy. +- Fixed `Cursor.ySign` being applied to the glyph positioning offsets as well as + to the line advance. The glyph planes and the offsets are both Y-up, so only + the line advance follows the sign. `initialCursorDown` now really does advance + the lines downwards, and stacked marks land on the correct side of the glyph. +- Fixed the swapped `PlacedGlyph.glyph` / `PlacedGlyph.plane` haddocks. `glyph` + is the atlas box, `plane` is the screen box. +- `shape` now reads the font metrics while the fonts are known to be alive + instead of leaving the lookup to the caller's laziness. +- `bundleFont` now fails on em-sized layouts from fonts without a cap height + instead of writing infinities into the atlas planes. +- Added the `ktx-font-demo` executable (behind the `executables` flag), an + interactive Brillo viewer for the bundles built from `assets.yaml`. + ## 0.1.0.1 - 2026-03-18 - Make plane rescaling depend on `layout.atlas.sizeUnit`. diff --git a/demo/Main.hs b/demo/Main.hs new file mode 100644 --- /dev/null +++ b/demo/Main.hs @@ -0,0 +1,271 @@ +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 diff --git a/ktx-font.cabal b/ktx-font.cabal --- a/ktx-font.cabal +++ b/ktx-font.cabal @@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.39.1. +-- This file has been generated from package.yaml by hpack version 0.39.6. -- -- see: https://github.com/sol/hpack name: ktx-font -version: 0.1.0.1 +version: 0.2.0.0 synopsis: GPU-ready rasterized fonts category: Graphics author: IC Rainbow @@ -23,9 +23,18 @@ type: git location: https://gitlab.com/dpwiz/ktx +flag executables + manual: True + default: False + +flag tests + manual: True + default: False + library exposed-modules: Codec.Ktx2.Font + Codec.Ktx2.Font.Layout Codec.Ktx2.Font.Shaping other-modules: Paths_ktx_font @@ -60,10 +69,99 @@ , base >=4.11 && <5 , bytestring , containers - , kb-text-shape + , kb-text-layout >=0.1.1.0 && <0.2 + , kb-text-shape >=0.2.1.0 && <0.3 , ktx-codec >=0.1 , msdf-atlas , text , vector , zstd default-language: Haskell2010 + +executable ktx-font-demo + main-is: Main.hs + other-modules: + Paths_ktx_font + autogen-modules: + Paths_ktx_font + hs-source-dirs: + demo + default-extensions: + BlockArguments + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DuplicateRecordFields + ImplicitParams + ImportQualifiedPost + LambdaCase + NamedFieldPuns + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + PatternSynonyms + RankNTypes + RecordWildCards + StrictData + TupleSections + TypeApplications + ViewPatterns + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.11 && <5 + , brillo >=2.0 + , bytestring + , ktx-codec + , ktx-font + , msdf-atlas + , text + , zstd + default-language: Haskell2010 + if !flag(executables) + buildable: False + +test-suite ktx-font-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_ktx_font + autogen-modules: + Paths_ktx_font + hs-source-dirs: + test + default-extensions: + BlockArguments + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DuplicateRecordFields + ImplicitParams + ImportQualifiedPost + LambdaCase + NamedFieldPuns + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + PatternSynonyms + RankNTypes + RecordWildCards + StrictData + TupleSections + TypeApplications + ViewPatterns + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.11 && <5 + , directory >=1.3 && <2 + , filepath >=1.4 && <2 + , ktx-font + , msdf-atlas + , tasty + , tasty-hunit + , text + , vector + default-language: Haskell2010 + if !flag(tests) + buildable: False diff --git a/src/Codec/Ktx2/Font.hs b/src/Codec/Ktx2/Font.hs --- a/src/Codec/Ktx2/Font.hs +++ b/src/Codec/Ktx2/Font.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Codec.Ktx2.Font ( -- * KTX font bundles Bundle(..) @@ -47,6 +49,7 @@ import Graphics.MSDF.Atlas.Compact (Compact, compact) import Graphics.MSDF.Atlas.Compact qualified as Compact import Graphics.MSDF.Atlas.Layout qualified as Layout +import KB.Text.Layout.Measure qualified as Measure import KB.Text.Shape qualified as TextShape import KB.Text.Shape.FFI.Enums qualified as KBTS import KB.Text.Shape.FFI.Handles (Font(..), intHandle) @@ -75,15 +78,13 @@ layout <- eitherDecodeFileStrict pathJson >>= either fail pure ttfData <- ByteString.readFile pathTtf - kbtsData <- Font.extractBlob ttfData 0 - font <- createFont kbtsData 0 + font <- createFont ttfData 0 + kbtsData <- loadedBlob pathTtf font rescale <- case layout.atlas.sizeUnit of Just Layout.CapsHeight -> pure id - Nothing -> do - factor <- withFontData font $ pure . Font.emToCaps - pure $ scalePlanes factor + Nothing -> fmap scalePlanes . withFontData font $ emToCapsOf pathTtf destroyFont font sourceKtx <- Ktx2.fromFile pathKtx2 @@ -94,9 +95,36 @@ KVD.insertBytes KTX_KEY_atlas (Zstd.compress 19 atlasData) $ KVD.insertBytes KTX_KEY_kbts (Zstd.compress 19 kbtsData) $ KVD.insertText KTX_KEY_kbts_version kbtsVersion $ - KVD.setWriterWith ("ktx-font 0.1.0.1 / " <>) sourceKtx.kvd + KVD.setWriterWith (writerTag <>) sourceKtx.kvd Ktx2.toFile pathKtxf sourceKtx{Ktx2.kvd} +{- | The kbts blob that loading the source produced as a side effect. + +A source that was a blob already is kept as is. +-} +loadedBlob :: FilePath -> FontData -> IO ByteString +loadedBlob pathTtf font = + case font.fontResources of + [_source, blob] -> pure blob + [blob] -> pure blob + huh -> fail $ "Unexpected font resources in " <> pathTtf <> ": " <> show (length huh) + +{- | The em to cap-height factor of a font that declares a cap height. + +An em-sized layout can only be normalized to the cap height if the font +has one, so bail out here instead of writing infinities into the planes +and failing much later, at shaping time. +-} +emToCapsOf :: FilePath -> Font -> IO Float +emToCapsOf pathTtf font = do + info <- Font.getFontInfo font + if info.capitalHeight <= 0 + then fail $ "No cap height in " <> pathTtf <> " (missing or truncated OS/2 table)" + else pure $ Font.emToCaps info + +writerTag :: Text +writerTag = "ktx-font " <> CURRENT_PACKAGE_VERSION <> " / " + -- | Rescale planes to caps height instead of ems. -- -- With 1.4 factor, 1em targeting 10px would become 14px. @@ -176,6 +204,7 @@ data StackContext a = StackContext { shapeContext :: MVar TextShape.Context + , layout :: Measure.LayoutContext -- ^ Measurement caches over the same context. Aliases the locked context, so use it only while holding 'shapeContext'. , bundled :: IntMap a , atlases :: IntMap Compact -- XXX: Font.Handle ~ Ptr Font.Handle ~ Int } @@ -186,6 +215,7 @@ createStackContext :: Foldable t => t Bundle -> IO (StackContext ()) createStackContext bundles = do ctx <- TextShape.createContext + layout <- Measure.createLayoutContext ctx locals <- for (toList bundles) \Bundle{..} -> withFontData fontData \font -> do _refs <- TextShape.pushFont ctx font diff --git a/src/Codec/Ktx2/Font/Layout.hs b/src/Codec/Ktx2/Font/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Ktx2/Font/Layout.hs @@ -0,0 +1,263 @@ +{- | Multiline text layout on top of the bundled fonts. + +Text is shaped and measured once, then broken into lines and placed +with the usual cursor conventions from "Codec.Ktx2.Font.Shaping". +Only the shaping needs the font context; breaking and placing are pure, +so the same 'ShapedText' can be laid out again for every new width. + +All the widths are in cap-height units, matching the glyph planes. +Multiply by font size to match your projection settings. +-} +module Codec.Ktx2.Font.Layout + ( -- * Styles + TextStyle + , bundleStyle + -- * Shaping + , ShapedText + , shapeText + -- * Placing + , placeText + , LayoutOptions(..) + , Strategy(..) + , Align(..) + -- * All at once + , layoutText + , layoutTextWith + -- * Results + , PlacedLine(..) + , placedRuns + , Break.LineEnd(..) + -- * Measuring + , measureText + , shrinkwrapText + , clearLayoutCache + ) where + +import Codec.Ktx2.Font qualified as Font +import Codec.Ktx2.Font.Shaping (PlacedGlyph(..)) +import Codec.Ktx2.Font.Shaping qualified as Shaping +import Control.Concurrent (withMVar) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Vector (Vector, (!)) +import Data.Vector qualified as Vector +import Graphics.MSDF.Atlas.Compact qualified as Atlas +import KB.Text.Layout.Analysis (BreakKind(..)) +import KB.Text.Layout.Break qualified as Break +import KB.Text.Layout.Measure qualified as Measure +import KB.Text.Shape.Font (withFontData) + +{- | A font bundle prepared for measuring. + +The bundle must stay alive for as long as the style is in use, +same as with the stack context itself. +-} +data TextStyle = TextStyle + { style :: Measure.Style + , bundle :: Font.Bundle + , breakHyphen :: Hyphen -- ^ Appended to lines broken inside a word. + } + +bundleStyle :: Font.StackContext a -> Font.Bundle -> IO TextStyle +bundleStyle ctx bundle = do + style <- withFontData bundle.fontData \font -> + Measure.newStyle ctx.layout font 1.0 + breakHyphen <- shapeHyphen ctx bundle + pure TextStyle{style, bundle, breakHyphen} + +-- | A @-@ shaped once at the origin, to be moved to the end of a line. +data Hyphen = Hyphen + { font :: (Shaping.Font, Maybe Shaping.Compact) + , glyphs :: [PlacedGlyph] + } + +shapeHyphen :: Font.StackContext a -> Font.Bundle -> IO Hyphen +shapeHyphen ctx bundle = + Shaping.shape (Shaping.initialCursorDown 0) ctx (Shaping.withFont_ bundle (Shaping.text_ "-")) >>= \case + [(font, glyphs)] -> pure Hyphen{font, glyphs} + runs -> fail $ "Expected a single run for the hyphen, got " <> show (length runs) + +data Strategy + = Greedy -- ^ Pack each line as full as possible. Fast, good for editable text. + | Optimal -- ^ Minimize raggedness across the whole paragraph. + deriving stock (Eq, Show) + +data Align = AlignLeft | AlignCenter | AlignRight + deriving stock (Eq, Show) + +data LayoutOptions = LayoutOptions + { cursor :: Shaping.Cursor + , strategy :: Strategy + , align :: Align + } + deriving stock (Eq, Show) + +{- | Text shaped as a single unbroken line and measured for breaking. + +Placing it into lines is pure, see 'placeText'. +-} +data ShapedText = ShapedText + { prepared :: Measure.PreparedText + , offsets :: Vector Int -- ^ Codepoint offset of each measured segment, plus the total. + , advances :: Vector Float -- ^ Pen position before each codepoint, plus the total. + , fonts :: [(Shaping.Font, Maybe Shaping.Compact)] -- ^ The shaped runs, in pen order. + , glyphs :: Vector [(Int, PlacedGlyph)] -- ^ Placed glyphs of each codepoint, tagged with their run. + , breakHyphen :: Hyphen + } + +-- | Shape and measure the text. This is the only step that needs the fonts. +shapeText :: Font.StackContext a -> TextStyle -> Text -> IO ShapedText +shapeText ctx ts t = do + (prepared, runs) <- withMVar ctx.shapeContext \kbts -> do + prepared <- Measure.prepare ctx.layout ts.style t + runs <- + if Text.null t then + pure [] + else + Shaping.unsafeShapeClusters kbts ctx $ + Shaping.withFont_ ts.bundle (Shaping.text_ t) + pure (prepared, runs) + let + size = Text.length t + clusters = + [ (run, g) + | (run, (_font, runGlyphs)) <- zip [0 ..] runs + , g <- runGlyphs + , g.cluster >= 0 + , g.cluster < size + ] + offsets = Vector.scanl' (\off seg -> off + Text.length seg.text) 0 prepared.segments + advances = Vector.scanl' (+) 0 $ + Vector.accum (+) (Vector.replicate size 0) + [ (g.cluster, g.advance) + | (_run, g) <- clusters + ] + glyphs = Vector.map reverse $ + Vector.accum (flip (:)) (Vector.replicate size []) + [ (g.cluster, (run, placed)) + | (run, g) <- clusters + , Just placed <- [g.placed] + ] + pure ShapedText + { prepared + , offsets + , advances + , fonts = map fst runs + , glyphs + , breakHyphen = ts.breakHyphen + } + +data PlacedLine = PlacedLine + { runs :: [Shaping.PlacedRun] + , text :: Text -- ^ What landed on the line, including the trailing @-@ when hyphenated. + , width :: Float -- ^ Visible line width, excluding trailing spaces. + , ended :: Break.LineEnd + , origin :: (Float, Float) -- ^ Line pen start, after alignment. + } + +{- | Break the shaped text to fit the maximum width and place the lines. + +Each line is a run of visible pieces shifted as a whole to the line start, +closing up over the invisible segments between them, so the glyphs keep +their shaped positions relative to each other. +-} +placeText :: LayoutOptions -> Float -> ShapedText -> [PlacedLine] +placeText opts maxWidth st = + zipWith placeLine [0 :: Int ..] ranges + where + ranges = case opts.strategy of + Greedy -> Break.layoutGreedy st.prepared maxWidth + Optimal -> Break.layoutOptimal st.prepared maxWidth + + segments = st.prepared.segments + lastSegment = Vector.length segments - 1 + + placeLine line range = PlacedLine + { runs = lineRuns <> hyphenRuns + , text = Break.materializeLineRange st.prepared range + , width = range.width + , ended = range.ended + , origin = (x0, y) + } + where + x0 = opts.cursor.curX + case opts.align of + AlignLeft -> 0 + AlignCenter -> max 0 (maxWidth - range.width) / 2 + AlignRight -> max 0 (maxWidth - range.width) + y = opts.cursor.curY + fromIntegral line * opts.cursor.lineHeight * opts.cursor.ySign + + pieces = + [ (c0, c1) + | j <- [range.from.segment .. min range.to.segment lastSegment] + , visible (segments ! j).kind + , let c0 = st.offsets ! j + if j == range.from.segment then range.from.grapheme else 0 + , let c1 = if j == range.to.segment then st.offsets ! j + range.to.grapheme else st.offsets ! (j + 1) + , c0 < c1 + ] + + shifts = case pieces of + [] -> [] + (c0, _) : _ -> scanl (-) (x0 - st.advances ! c0) gaps + + gaps = zipWith (\(_, c1) (c0, _) -> st.advances ! c0 - st.advances ! c1) pieces (drop 1 pieces) + + pen = foldl' (\_ ((_, c1), dx) -> dx + st.advances ! c1) x0 (zip pieces shifts) + + lineRuns = + [ (fontAtlas, placed) + | (run, fontAtlas) <- zip [0 :: Int ..] st.fonts + , let placed = + [ shift dx g + | ((c0, c1), dx) <- zip pieces shifts + , c <- [c0 .. c1 - 1] + , (run', g) <- st.glyphs ! c + , run' == run + ] + , not (null placed) + ] + + hyphenRuns = + [ (st.breakHyphen.font, map (shift pen) st.breakHyphen.glyphs) + | range.ended == Break.Hyphenated + ] + + shift dx g@PlacedGlyph{plane} = g{plane = Atlas.moveBox dx y plane} + + visible = \case + SoftHyphen -> False + HardBreak -> False + ZeroWidthBreak -> False + _ -> True + +{- | Break text to fit the maximum width, then shape and place the lines. + +Left-aligned greedy layout. Use 'layoutTextWith' for more options. +-} +layoutText :: Shaping.Cursor -> Font.StackContext a -> TextStyle -> Float -> Text -> IO [PlacedLine] +layoutText cursor = layoutTextWith LayoutOptions{cursor, strategy = Greedy, align = AlignLeft} + +-- | 'shapeText' followed by 'placeText'. +layoutTextWith :: LayoutOptions -> Font.StackContext a -> TextStyle -> Float -> Text -> IO [PlacedLine] +layoutTextWith opts ctx ts maxWidth t = + placeText opts maxWidth <$> shapeText ctx ts t + +-- | Flatten the lines for rendering. +placedRuns :: [PlacedLine] -> [Shaping.PlacedRun] +placedRuns = concatMap (.runs) + +-- | Measure text width as a single unbroken line. +measureText :: Font.StackContext a -> TextStyle -> Text -> IO Float +measureText ctx ts t = + withMVar ctx.shapeContext \_kbts -> + Measure.measure ctx.layout ts.style t + +-- | The smallest maximum width that doesn't add more lines than the given one. +shrinkwrapText :: Font.StackContext a -> TextStyle -> Float -> Text -> IO Float +shrinkwrapText ctx ts maxWidth t = + withMVar ctx.shapeContext \_kbts -> do + prep <- Measure.prepare ctx.layout ts.style t + pure $ Break.shrinkwrap prep maxWidth + +-- | Drop the measurement caches, e.g. after evicting some fonts. +clearLayoutCache :: Font.StackContext a -> IO () +clearLayoutCache ctx = Measure.clearCache ctx.layout diff --git a/src/Codec/Ktx2/Font/Shaping.hs b/src/Codec/Ktx2/Font/Shaping.hs --- a/src/Codec/Ktx2/Font/Shaping.hs +++ b/src/Codec/Ktx2/Font/Shaping.hs @@ -6,12 +6,16 @@ , TextShape.char_ , withFont_ , shapeWith + , shapeClusters + , unsafeShapeClusters , Cursor(..) , initialCursorUp , initialCursorDown -- * Output , PlacedRun , PlacedGlyph(..) + , ClusterRun + , ClusterGlyph(..) -- * Re-exports , KBTS.Font , Atlas.Compact(..) @@ -20,9 +24,12 @@ import Codec.Ktx2.Font qualified as Font import Control.Concurrent (withMVar) +import Control.Exception (evaluate) import Data.List (mapAccumL) +import Data.Maybe (catMaybes) import Data.Text (Text) import Data.Text qualified as Text +import Data.Traversable (for) import Graphics.MSDF.Atlas.Compact qualified as Atlas import KB.Text.Shape qualified as TextShape import KB.Text.Shape.FFI.Handles qualified as Handles @@ -53,7 +60,9 @@ -> Font.StackContext a -> ((?shapeContext :: Handles.ShapeContext) => IO ()) -> IO [PlacedRun] -shape cur ctx action = snd <$> shapeWith (collectRun ctx) cur ctx action +shape cur ctx@Font.StackContext{shapeContext} action = + withMVar shapeContext \kbts -> + shapeScaled kbts (collectRun ctx) cur action {- | Run shaping and process results using a custom accumulator function -} @@ -67,6 +76,47 @@ withMVar shapeContext \kbts -> mapAccumL collectFun cur <$> TextShape.run kbts action +{- | Shape a block as one unbroken line, keeping the cluster index of each glyph. + +The pen starts at the origin and never resets, not even on newlines, so the +placements can be sliced into lines later by whoever knows the cluster ranges. +See "Codec.Ktx2.Font.Layout". +-} +shapeClusters + :: Font.StackContext a + -> ((?shapeContext :: Handles.ShapeContext) => IO ()) + -> IO [ClusterRun] +shapeClusters ctx@Font.StackContext{shapeContext} action = + withMVar shapeContext \kbts -> + unsafeShapeClusters kbts ctx action + +-- | 'shapeClusters' for callers already holding the locked context. +unsafeShapeClusters + :: TextShape.Context + -> Font.StackContext a + -> ((?shapeContext :: Handles.ShapeContext) => IO ()) + -> IO [ClusterRun] +unsafeShapeClusters kbts ctx = shapeScaled kbts (collectClusters ctx) 0 + +{- | Shape and collect the runs together with their cap-height scale. + +The font metrics are read straight from the font memory, so the lookup +happens while the fonts are known to be alive, not when the caller +gets around to forcing the results. +-} +shapeScaled + :: TextShape.Context + -> (acc -> (Float, (TextShape.Run, [TextShape.Glyph])) -> (acc, placed)) + -> acc + -> ((?shapeContext :: Handles.ShapeContext) => IO ()) + -> IO [placed] +shapeScaled kbts collect acc action = do + runs <- TextShape.run kbts action + scaled <- for runs \run@(TextShape.Run{font}, _glyphs) -> do + scale <- capHeightScale font + (,run) <$> evaluate scale + pure . snd $ mapAccumL collect acc scaled + withFont_ :: (?shapeContext :: Handles.ShapeContext) => Font.Bundle -> IO () -> IO () withFont_ Font.Bundle{fontData} action = KBTS.withFontData fontData \font -> @@ -75,19 +125,27 @@ data Cursor = Cursor { curX, curY :: Float , lineHeight :: Float -- ^ Space between the baselines, as a multiple of the font size. - , ySign :: Float -- ^ Should match atlas yOrigin and screen direction. + , ySign :: Float + {- ^ The direction the lines advance in. + + The glyph boxes come out Y-up, like the font's own units, so text that reads + top to bottom advances along the negative axis. Use 'initialCursorDown' and + 'initialCursorUp' instead of picking the sign by hand. + -} } deriving (Eq, Show) +-- | A cursor for text that reads bottom to top. initialCursorUp :: Float -- ^ Line height multiplier. -> Cursor -initialCursorUp = initialCursor (-1) +initialCursorUp = initialCursor 1 +-- | A cursor for text that reads top to bottom. This is the usual one. initialCursorDown :: Float -- ^ Line height multiplier. -> Cursor -initialCursorDown = initialCursor 1 +initialCursorDown = initialCursor (-1) initialCursor :: Float -- ^ Y axis signum @@ -109,51 +167,90 @@ data PlacedGlyph = PlacedGlyph { codepoint :: Char -- ^ Unicode codepoint associated with the glyph. Mostly for debugging. , glyphId :: Int -- ^ Glyph ID in font and atlas. You can use this to look up the glyph boxes from GPU if you upload the glyph data as arrays. - , glyph :: Atlas.Box -- ^ Glyph box on screen. The size and offsets are normalized so you can run the shaping once, then transform the whole block as you need. - , plane :: Atlas.Box -- ^ Glyph box in atlas. The size is normalized to UV of the texure. + , glyph :: Atlas.Box -- ^ Glyph box in the atlas. The size is normalized to the UV of the texture. + , plane :: Atlas.Box -- ^ Glyph box on screen. The size and offsets are normalized so you can run the shaping once, then transform the whole block as you need. } deriving (Eq, Show) -collectRun :: Font.StackContext a -> Cursor -> (TextShape.Run, [TextShape.Glyph]) -> (Cursor, PlacedRun) -collectRun ctx cur (TextShape.Run{font}, glyphs) = placeRun <$> mapAccumL (place fontUnitScale atlas_) cur glyphs +-- | Text runs with uniform direction and script, placed along a single pen. +type ClusterRun = + ( (KBTS.Font, Maybe Atlas.Compact) + , [ClusterGlyph] + ) + +data ClusterGlyph = ClusterGlyph + { cluster :: Int -- ^ Index of the codepoint the glyph came from. + , advance :: Float -- ^ Pen advance contributed by the glyph, in cap-height units. + , placed :: Maybe PlacedGlyph -- ^ Nothing for glyphs without a box, like newlines. + } + deriving (Eq, Show) + +collectRun :: Font.StackContext a -> Cursor -> (Float, (TextShape.Run, [TextShape.Glyph])) -> (Cursor, PlacedRun) +collectRun ctx cur (fontUnitScale, (TextShape.Run{font}, glyphs)) = + ((font, atlas_),) . catMaybes <$> mapAccumL place cur glyphs where - fontUnitScale = capHeightScale font atlas_ = Font.lookupAtlas font ctx - placeRun :: [(Char, Int, Maybe (Atlas.Box, Atlas.Box))] -> PlacedRun - placeRun placed = - ( (font, atlas_) - , do - (codepoint, glyphId, Just (glyph, plane)) <- placed - pure PlacedGlyph{codepoint, glyphId, glyph, plane} + place pen@Cursor{curX, curY} glyph = + ( advance fontUnitScale pen glyph + , placedGlyph fontUnitScale atlas_ curX curY glyph ) +collectClusters :: Font.StackContext a -> Float -> (Float, (TextShape.Run, [TextShape.Glyph])) -> (Float, ClusterRun) +collectClusters ctx pen (fontUnitScale, (TextShape.Run{font}, glyphs)) = + ((font, atlas_),) <$> mapAccumL place pen glyphs + where + atlas_ = Font.lookupAtlas font ctx + + place penX glyph@TextShape.Glyph{codepointIndex} = + ( penX + step + , ClusterGlyph + { cluster = codepointIndex + , advance = step + , placed = placedGlyph fontUnitScale atlas_ penX 0 glyph + } + ) + where + step = glyphAdvance fontUnitScale glyph + -- | Normalize font metrics using "cap height" -capHeightScale :: KBTS.Font -> Float -capHeightScale font = case KBTS.capHeight font of - 0 -> error "capHeight not set" - n -> 1 / n +capHeightScale :: KBTS.Font -> IO Float +capHeightScale font = do + info <- KBTS.getFontInfo font + case info.capitalHeight of + n | n <= 0 -> error "capHeight not set" + | otherwise -> pure $ 1 / fromIntegral n --- -- | Normalize font metrics using "units per em" --- emScale :: KBTS.Font -> Float --- emScale font = 1 / KBTS.unitsPerEm font +{- | Look up the glyph boxes and put the plane at the pen position. -place :: Float -> Maybe Atlas.Compact -> Cursor -> TextShape.Glyph -> (Cursor, (Char, Int, Maybe (Atlas.Box, Atlas.Box))) -place fontUnitScale atlas_ cur@Cursor{..} glyph@TextShape.Glyph{codepoint, offsetX, offsetY, id=glyphId} = - ( nextCur - , (codepoint, fromIntegral glyphId, if codepoint == '\n' then Nothing else params_) - ) - where - nextCur = advance fontUnitScale cur glyph +The glyph planes and the positioning offsets are both Y-up, so the offsets +are applied as-is. Only the line advance follows 'ySign'. +-} +placedGlyph :: Float -> Maybe Atlas.Compact -> Float -> Float -> TextShape.Glyph -> Maybe PlacedGlyph +placedGlyph fontUnitScale atlas_ penX penY TextShape.Glyph{codepoint, offsetX, offsetY, id=glyphId} + | codepoint == '\n' = Nothing + | otherwise = do + atlas <- atlas_ + (glyph, plane) <- Atlas.lookupGlyph (fromIntegral glyphId) atlas + pure PlacedGlyph + { codepoint + , glyphId = fromIntegral glyphId + , glyph + , plane = + Atlas.moveBox + (penX + fromIntegral offsetX * fontUnitScale) + (penY + fromIntegral offsetY * fontUnitScale) + plane + } - params_ = atlas_ >>= Atlas.lookupGlyph (fromIntegral glyphId) >>= pure . fmap placeGlyph - placeGlyph = - Atlas.moveBox - (curX + fromIntegral offsetX * fontUnitScale) - (curY + fromIntegral offsetY * fontUnitScale * ySign) +-- | The pen step of a glyph along the line. Newlines move the cursor, not the pen. +glyphAdvance :: Float -> TextShape.Glyph -> Float +glyphAdvance fontUnitScale glyph@TextShape.Glyph{advanceX} + | glyph.codepoint == '\n' = 0 + | otherwise = fromIntegral advanceX * fontUnitScale advance :: Float -> Cursor -> TextShape.Glyph -> Cursor -advance fontUnitScale cur@Cursor{..} TextShape.Glyph{advanceX, advanceY, codepoint} = +advance fontUnitScale cur@Cursor{..} glyph@TextShape.Glyph{advanceY, codepoint} = if codepoint == '\n' then cur { curX = 0 @@ -161,6 +258,6 @@ } else cur - { curX = curX + fromIntegral advanceX * fontUnitScale - , curY = curY + fromIntegral advanceY * fontUnitScale * ySign + { curX = curX + glyphAdvance fontUnitScale glyph + , curY = curY + fromIntegral advanceY * fontUnitScale } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,300 @@ +module Main where + +import Control.Monad (unless) +import Data.Foldable (for_) +import Data.List (isSuffixOf) +import Data.Text qualified as Text +import Data.Traversable (for) +import Data.Vector.Storable qualified as Storable +import System.Directory (doesFileExist, listDirectory) +import System.FilePath (()) +import Test.Tasty (TestTree, defaultMain, testGroup, withResource) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +import Codec.Ktx2.Font (Bundle(..)) +import Codec.Ktx2.Font qualified as Font +import Codec.Ktx2.Font.Layout qualified as Layout +import Codec.Ktx2.Font.Shaping (Box(..), Compact(..), PlacedGlyph(..)) +import Codec.Ktx2.Font.Shaping qualified as Shaping + +{- | Font bundles built from @assets.yaml@. + +Regenerate them with @stack exec ktx-build@ when the assets or the bundle format change. +-} +bundlesPath :: FilePath +bundlesPath = ".." "assets" "fonts" + +main :: IO () +main = do + entries <- listDirectory bundlesPath + let sources = [bundlesPath entry | entry <- entries, ".ktxf" `isSuffixOf` entry] + unless (null sources) $ + putStrLn $ "Found " <> show (length sources) <> " bundles in " <> bundlesPath + + defaultMain $ + testGroup "ktx-font" + [ testCase "bundles are built" $ + assertBool (bundlesPath <> " has no .ktxf bundles, run the ktx-build asset build") $ + not (null sources) + + , testGroup "bundles" $ map bundleTests sources + + , withStack sources \getStack -> + testGroup "text" + [ shapingTests (fmap fst getStack) + , layoutTests getStack + ] + + , testCase "demo bundles are built" $ + doesFileExist ligatureBundle >>= + assertBool (ligatureBundle <> " is missing, run the ktx-build asset build") + + , withStack [ligatureBundle] ligatureTests + ] + +bundleTests :: FilePath -> TestTree +bundleTests source = + withResource (Font.loadBundleFile source) Font.freeBundle \getBundle -> + testGroup source + [ testCase "carries an atlas" do + Bundle{atlas} <- getBundle + assertBool "no glyphs in the atlas" $ + not (Storable.null atlas.glyphs) + Storable.length atlas.glyphs @?= Storable.length atlas.planes + + , testCase "atlas boxes are normalized to UV" do + Bundle{atlas} <- getBundle + Storable.forM_ atlas.glyphs \box -> + assertBool ("glyph box outside the 0..1 UV range: " <> show box) $ + inUnitRange box + ] + where + inUnitRange Box{x, y, w, h} = + x >= 0 && y >= 0 && x + w <= 1.001 && y + h <= 1.001 + +{- | Load every bundle into a single shaping context, the way a renderer would. + +The stack context doesn't keep the font memory alive, so the bundles have to outlive it. +-} +withStack :: [FilePath] -> (IO (Font.StackContext (), Layout.TextStyle) -> TestTree) -> TestTree +withStack sources withCtx = + withResource acquire release $ withCtx . fmap snd + where + acquire = do + bundles <- for sources Font.loadBundleFile + ctx <- Font.createStackContext bundles + style <- Layout.bundleStyle ctx (last bundles) + pure (bundles, (ctx, style)) + + release (bundles, (ctx, _style)) = do + Font.destroyStackContext ctx + for_ bundles Font.freeBundle + +shapingTests :: IO (Font.StackContext ()) -> TestTree +shapingTests getCtx = + testGroup "shaping" + [ testCase "shapes the samples" do + ctx <- getCtx + for_ samples \sample -> do + runs <- Shaping.shapeText (Shaping.initialCursorDown 2.0) ctx sample + assertBool ("nothing shaped for " <> show sample) $ + not (null runs) + assertBool ("no glyphs placed for " <> show sample) $ + not (null $ concatMap snd runs) + + , testCase "cursorDown advances the lines downwards" do + ctx <- getCtx + (top, bottom) <- twoLines (Shaping.initialCursorDown 2.0) ctx + assertBool ("second line is not below the first: " <> show (top, bottom)) $ + bottom.plane.y < top.plane.y + + , testCase "cursorUp advances the lines upwards" do + ctx <- getCtx + (first_, second_) <- twoLines (Shaping.initialCursorUp 2.0) ctx + assertBool ("second line is not above the first: " <> show (first_, second_)) $ + second_.plane.y > first_.plane.y + + , testCase "the newline advance matches the line height" do + ctx <- getCtx + (top, bottom) <- twoLines (Shaping.initialCursorDown 2.0) ctx + -- Same glyph on both lines, so the planes differ by exactly one line. + let gap = top.plane.y - bottom.plane.y + assertBool ("unexpected line gap: " <> show gap) $ + abs (gap - 2.0) < 0.001 + ] + where + -- The same glyph on two lines, so the placements are comparable. + -- The newline itself doesn't get placed. + twoLines cur ctx = do + runs <- Shaping.shapeText cur ctx "H\nH" + case concatMap snd runs of + [top, bottom] -> + pure (top, bottom) + placed -> + assertFailure $ "expected two placed glyphs, got " <> show placed + + samples = + [ "Test text, please shape." + , "Multiple\nlines\nwith an empty one:\n\nand a tail." + , "Punctuation: ,.!?;:'\"()[]{}" + ] + +layoutTests :: IO (Font.StackContext (), Layout.TextStyle) -> TestTree +layoutTests getStack = + testGroup "layout" + [ testCase "wide enough text stays on one line, matching plain shaping" do + (ctx, style) <- getStack + lns <- layout ctx style 1e6 "Sphinx of black quartz, judge my vow." + map (.ended) lns @?= [Layout.Finished] + shaped <- Shaping.shapeText cursor ctx "Sphinx of black quartz, judge my vow." + planesOf (Layout.placedRuns lns) `closeTo` planesOf shaped + + , testCase "narrow text wraps under the maximum width" do + (ctx, style) <- getStack + lns <- layout ctx style 3.0 "one two three four five" + assertBool "text did not wrap" $ length lns > 1 + for_ lns \line -> + unless (line.ended == Layout.Overflowed) $ + assertBool ("line too wide: " <> show (line.text, line.width)) $ + line.width <= 3.001 + + , testCase "hard breaks match the legacy newline behavior" do + (ctx, style) <- getStack + lns <- layout ctx style 1e6 "H\nH" + map (.ended) lns @?= [Layout.HardBroken, Layout.Finished] + case planesOf (Layout.placedRuns lns) of + [top, bottom] -> + assertBool ("unexpected line gap: " <> show (top, bottom)) $ + abs (top.y - bottom.y - 2.0) < 0.001 + planes -> + assertFailure $ "expected two placed glyphs, got " <> show planes + + , testCase "hard breaks don't accumulate drift" do + (ctx, style) <- getStack + lns <- layout ctx style 1e6 "H\nH\nH\nH" + let firsts = [p.x | line <- lns, p : _ <- [planesOf line.runs]] + length firsts @?= 4 + assertBool ("line starts drift: " <> show firsts) $ + maximum firsts - minimum firsts < 0.001 + + , testCase "empty lines are preserved" do + (ctx, style) <- getStack + lns <- layout ctx style 1e6 "a\n\nb" + map (.ended) lns @?= [Layout.HardBroken, Layout.HardBroken, Layout.Finished] + map (null . (.runs)) lns @?= [False, True, False] + + , testCase "right alignment pushes the origin to the edge" do + (ctx, style) <- getStack + lns <- Layout.layoutTextWith + Layout.LayoutOptions{cursor, strategy = Layout.Greedy, align = Layout.AlignRight} + ctx style 10 "H" + case lns of + [line] -> do + let (x0, _y0) = line.origin + assertBool ("origin not at the right edge: " <> show (x0, line.width)) $ + abs (x0 - (10 - line.width)) < 0.001 + _ -> + assertFailure $ "expected one line, got " <> show (length lns) + + , testCase "one shaping places at any width" do + (ctx, style) <- getStack + shaped <- Layout.shapeText ctx style "one two three four five" + let + place w = Layout.placeText Layout.LayoutOptions{cursor, strategy = Layout.Greedy, align = Layout.AlignLeft} w shaped + wide = place 1e6 + narrow = place 3.0 + length wide @?= 1 + assertBool "narrow placement did not wrap" $ length narrow > 1 + for_ (zip [0 :: Int ..] narrow) \(i, line) -> do + let (x0, y0) = line.origin + assertBool ("line " <> show i <> " is not on its own row: " <> show y0) $ + abs (y0 + fromIntegral i * 2.0) < 0.001 + plain <- Shaping.shapeText cursor{Shaping.curX = x0, Shaping.curY = y0} ctx line.text + planesOf line.runs `closeTo` planesOf plain + + , testCase "soft hyphens break with a visible hyphen" do + (ctx, style) <- getStack + shaped <- Layout.shapeText ctx style "hyphen\173ation" + w <- Layout.measureText ctx style "hyphenation" + let + lns = Layout.placeText Layout.LayoutOptions{cursor, strategy = Layout.Greedy, align = Layout.AlignLeft} (w * 0.75) shaped + map (.ended) lns @?= [Layout.Hyphenated, Layout.Finished] + case lns of + [top, bottom] -> do + top.text @?= "hyphen-" + bottom.text @?= "ation" + let glyphs = concatMap snd top.runs + assertBool "no glyphs on the hyphenated line" $ not (null glyphs) + (last glyphs).codepoint @?= '-' + assertBool ("hyphen not at the line end: " <> show (map (.plane) glyphs)) $ + (last glyphs).plane.x >= maximum (map (.plane.x) (init glyphs)) + _ -> + assertFailure $ "expected two lines, got " <> show (length lns) + + , testCase "measuring and shrinkwrapping" do + (ctx, style) <- getStack + w <- Layout.measureText ctx style "H" + assertBool ("H has no width: " <> show w) $ w > 0 + shrunk <- Layout.shrinkwrapText ctx style 3.0 "one two three four five" + assertBool ("shrinkwrap exceeded the limit: " <> show shrunk) $ shrunk <= 3.001 + ] + where + layout = Layout.layoutText cursor + +{- | Ligature tests need a font with real multi-codepoint glyphs. + +MapleMono renders its coding ligatures as per-glyph contextual alternates, +so its glyphs never span codepoints. NotoSans has a proper @ffi@ ligature. +-} +ligatureBundle :: FilePath +ligatureBundle = ".." "assets" "demo" "NotoSans-Regular.ktxf" + +ligatureTests :: IO (Font.StackContext (), Layout.TextStyle) -> TestTree +ligatureTests getStack = + testGroup "ligatures" + [ testCase "the bundle shapes the ligature as one glyph" do + (ctx, style) <- getStack + shaped <- Layout.shapeText ctx style ligature + let whole = glyphsOf (place shaped 1e6) + assertBool ("no ligature shaped for " <> show ligature <> ": " <> show (map (.codepoint) whole)) $ + length whole < Text.length ligature + + , testCase "emergency breaks keep the ligature whole" do + (ctx, style) <- getStack + shaped <- Layout.shapeText ctx style ligature + w <- Layout.measureText ctx style ligature + let whole = glyphsOf (place shaped 1e6) + for_ [w / 2, w * 0.9] \width -> do + let lns = place shaped width + map (.text) lns @?= [ligature] + map (.ended) lns @?= [Layout.Overflowed] + map (.plane) (glyphsOf lns) `closeTo` map (.plane) whole + + , testCase "wrapping after the ligature keeps the following text" do + (ctx, style) <- getStack + shaped <- Layout.shapeText ctx style (ligature <> "ab") + w <- max <$> Layout.measureText ctx style ligature <*> Layout.measureText ctx style "ab" + let lns = place shaped w + map (.text) lns @?= [ligature, "ab"] + for_ lns \line -> do + let (x0, y0) = line.origin + plain <- Shaping.shapeText cursor{Shaping.curX = x0, Shaping.curY = y0} ctx line.text + planesOf line.runs `closeTo` planesOf plain + ] + where + ligature = "ffi" + place shaped width = Layout.placeText Layout.LayoutOptions{cursor, strategy = Layout.Greedy, align = Layout.AlignLeft} width shaped + glyphsOf lns = concatMap snd (Layout.placedRuns lns) + +cursor :: Shaping.Cursor +cursor = Shaping.initialCursorDown 2.0 + +planesOf :: [Shaping.PlacedRun] -> [Box] +planesOf runs = [g.plane | (_font, glyphs) <- runs, g <- glyphs] + +closeTo :: [Box] -> [Box] -> IO () +closeTo actual expected = do + length actual @?= length expected + for_ (zip actual expected) \(a, e) -> + assertBool ("planes differ: " <> show (a, e)) $ + all (< 0.001) [abs (a.x - e.x), abs (a.y - e.y), abs (a.w - e.w), abs (a.h - e.h)]