ktx-font 0.1.0.1 → 0.2.0.0
raw patch · 7 files changed
+1136/−46 lines, 7 filesdep +brillodep +directorydep +filepathdep ~kb-text-shapedep ~ktx-codecnew-component:exe:ktx-font-demo
Dependencies added: brillo, directory, filepath, kb-text-layout, ktx-font, tasty, tasty-hunit
Dependency ranges changed: kb-text-shape, ktx-codec
Files
- CHANGELOG.md +31/−0
- demo/Main.hs +271/−0
- ktx-font.cabal +101/−3
- src/Codec/Ktx2/Font.hs +36/−6
- src/Codec/Ktx2/Font/Layout.hs +263/−0
- src/Codec/Ktx2/Font/Shaping.hs +134/−37
- test/Spec.hs +300/−0
CHANGELOG.md view
@@ -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`.
+ demo/Main.hs view
@@ -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
ktx-font.cabal view
@@ -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
src/Codec/Ktx2/Font.hs view
@@ -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
+ src/Codec/Ktx2/Font/Layout.hs view
@@ -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
src/Codec/Ktx2/Font/Shaping.hs view
@@ -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 }
+ test/Spec.hs view
@@ -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)]