From cb478a28d7241d8ee2992ebb44afae94d54ccd86 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Fri, 27 Jan 2023 10:04:09 +1300 Subject: [PATCH] Integrate richtext APIs. --- cabal.sandbox.config | 27 ----- src/Typograffiti.hs | 4 +- src/Typograffiti/Rich.hs | 128 ++++++++++++++++++++++ src/Typograffiti/Store.hs | 17 ++- src/Typograffiti/Text.hs | 49 ++++++++- typograffiti2.cabal => typograffiti.cabal | 2 +- 6 files changed, 188 insertions(+), 39 deletions(-) delete mode 100644 cabal.sandbox.config create mode 100644 src/Typograffiti/Rich.hs rename typograffiti2.cabal => typograffiti.cabal (96%) diff --git a/cabal.sandbox.config b/cabal.sandbox.config deleted file mode 100644 index 745df70..0000000 --- a/cabal.sandbox.config +++ /dev/null @@ -1,27 +0,0 @@ --- This is a Cabal package environment file. --- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY. --- Please create a 'cabal.config' file in the same directory --- if you want to change the default settings for this sandbox. - - -local-repo: /home/alcinnz/argonaut/typograffiti2/.cabal-sandbox/packages -logs-dir: /home/alcinnz/argonaut/typograffiti2/.cabal-sandbox/logs -world-file: /home/alcinnz/argonaut/typograffiti2/.cabal-sandbox/world -user-install: False -package-db: /home/alcinnz/argonaut/typograffiti2/.cabal-sandbox/x86_64-linux-ghc-8.6.5-packages.conf.d -build-summary: /home/alcinnz/argonaut/typograffiti2/.cabal-sandbox/logs/build.log - -install-dirs - prefix: /home/alcinnz/argonaut/typograffiti2/.cabal-sandbox - bindir: $prefix/bin - libdir: $prefix/lib - libsubdir: $abi/$libname - dynlibdir: $libdir/$abi - libexecdir: $prefix/libexec - libexecsubdir: $abi/$pkgid - datadir: $prefix/share - datasubdir: $abi/$pkgid - docdir: $datadir/doc/$abi/$pkgid - htmldir: $docdir/html - haddockdir: $htmldir - sysconfdir: $prefix/etc diff --git a/src/Typograffiti.hs b/src/Typograffiti.hs index 75ba32e..493dbca 100644 --- a/src/Typograffiti.hs +++ b/src/Typograffiti.hs @@ -12,7 +12,9 @@ module Typograffiti( makeDrawGlyphs, AllocatedRendering(..), Layout(..), SpatialTransform(..), TextTransform(..), move, scale, rotate, color, alpha, withFontStore, newFontStore, FontStore(..), Font(..), - SampleText (..), defaultSample, addSampleFeature, + SampleText (..), defaultSample, addSampleFeature, parseSampleFeature, parseSampleFeatures, + addFontVariant, parseFontVariant, parseFontVariants, + varItalic, varOptSize, varSlant, varWidth, varWeight, RichText (..), str, txt, ($$), style, apply, on, off, alternate, alt, case_, centerCJKPunct, capSpace, ctxtSwash, petiteCaps', smallCaps', expertJ, finGlyph, fract, fullWidth, hist, hkana, hlig, hojo, halfWidth, diff --git a/src/Typograffiti/Rich.hs b/src/Typograffiti/Rich.hs new file mode 100644 index 0000000..d2fd64a --- /dev/null +++ b/src/Typograffiti/Rich.hs @@ -0,0 +1,128 @@ +module Typograffiti.Rich where +import Data.Text.Lazy (Text, append, pack) +import qualified Data.Text.Lazy as Txt +import Data.Text.Glyphize (Feature(..), tag_from_string, parseFeature) +import Data.String (IsString(..)) +import Data.Word (Word32) + +length' = toEnum . fromEnum . Txt.length + +data RichText = RichText { + text :: Text, + features :: [Feature] +} + +instance IsString RichText where + fromString x = flip RichText [] $ pack x +str :: String -> RichText +str = fromString +txt :: Text -> RichText +txt = flip RichText [] + +($$) :: RichText -> RichText -> RichText +RichText ltext lfeat $$ RichText rtext rfeat = RichText { + text = append ltext rtext, + features = let n = length' ltext in lfeat ++ [ + feat { featStart = start + n, featEnd = end + n } + | feat@Feature { featStart = start, featEnd = end } <- rfeat] + } + +style :: String -> Word32 -> RichText -> RichText +style feat value (RichText text feats) = RichText { + text = text, + features = Feature (tag_from_string feat) value 0 (length' text) : feats + } +apply :: String -> RichText -> RichText +apply syntax rich | Just feat <- parseFeature syntax = rich { + features = feat { featStart = 0, featEnd = length' $ text rich } : features rich + } + | otherwise = rich + +alt, case_, centerCJKPunct, capSpace, ctxtSwash, petiteCaps', smallCaps', expertJ, + finGlyph, fract, fullWidth, hist, hkana, hlig, hojo, halfWidth, italic, justifyAlt, + jap78, jap83, jap90, jap04, kerning, lBounds, liningFig, localized, mathGreek, + altAnnotation, nlcKanji, oldFig, ordinals, ornament, propAltWidth, petiteCaps, + propKana, propFig, propWidth, quarterWidth, rBounds, ruby, styleAlt, sciInferior, + smallCaps, simpleCJ, subscript, superscript, swash, titling, traditionNameJ, + tabularFig, traditionCJ, thirdWidth, unicase, vAlt, vert, vHalfAlt, vKanaAlt, + vKerning, vPropAlt, vRotAlt, vrot, slash0 :: Word32 -> RichText -> RichText +altFrac, ctxtAlt, ctxtLig, optLigs, lig, rand :: Bool -> RichText -> RichText +alt = style "aalt" +altFrac True= style "afrc" 4 +altFrac False=style "afrc" 0 +ctxtAlt True= style "calt" 6 +ctxtAlt False=style "calt" 0 +case_ = style "case" +ctxtLig True= style "clig" 8 +ctxtLig False=style "clig" 0 +centerCJKPunct = style "cpct" +capSpace = style "cpsp" +ctxtSwash = style "cswh" +petiteCaps' = style "c2pc" +smallCaps' = style "c2sc" +optLigs True= style "dlig" 4 +optLigs False=style "dlig" 0 +expertJ = style "expt" +finGlyph = style "falt" +fract = style "frac" +fullWidth = style "fwid" +hist = style "hist" +hkana = style "hkna" +hlig = style "hlig" +hojo = style "hojo" +halfWidth = style "hwid" +italic = style "ital" +justifyAlt = style "jalt" +jap78 = style "jp78" +jap83 = style "jp83" +jap90 = style "jp90" +jap04 = style "jp04" +kerning = style "kern" +lBounds = style "lfbd" +lig True = style "liga" 4 +lig False = style "liga" 0 +liningFig = style "lnum" +localized = style "locl" +mathGreek = style "mgrk" +altAnnotation=style "nalt" +nlcKanji = style "nlck" +oldFig = style "onum" +ordinals = style "ordn" +ornament = style "ornm" +propAltWidth= style "palt" +petiteCaps = style "pcap" +propKana = style "pkna" +propFig = style "pnum" +propWidth = style "pwid" +quarterWidth= style "qwid" +rand True = style "rand" 3 +rand False = style "rand" 0 +rBounds = style "rtbd" +ruby = style "ruby" +styleAlt = style "salt" +sciInferior = style "sinf" +smallCaps = style "smcp" +simpleCJ = style "smpl" +subscript = style "subs" +superscript = style "sups" +swash = style "swsh" +titling = style "titl" +traditionNameJ = style "tnam" +tabularFig = style "tnum" +traditionCJ = style "trad" +thirdWidth = style "twid" +unicase = style "unic" +vAlt = style "valt" +vert = style "vert" +vHalfAlt = style "vhal" +vKanaAlt = style "vkna" +vKerning = style "vkrn" +vPropAlt = style "vpal" +vRotAlt = style "vrt2" +vrot = style "vrtr" +slash0 = style "zero" + +off, on, alternate :: Word32 +off = 0 +on = 1 +alternate = 3 diff --git a/src/Typograffiti/Store.hs b/src/Typograffiti/Store.hs index 4419ada..69e0af0 100644 --- a/src/Typograffiti/Store.hs +++ b/src/Typograffiti/Store.hs @@ -33,6 +33,8 @@ import qualified Data.Text.Glyphize as HB import Data.Text.Lazy (Text, pack) import qualified Data.Text.Lazy as Txt import FreeType.Core.Base +import FreeType.Core.Types (FT_Fixed) +import FreeType.Format.Multiple (ft_Set_Var_Design_Coordinates) import Typograffiti.Atlas import Typograffiti.Cache @@ -57,7 +59,7 @@ makeDrawTextCached :: (MonadIO m, MonadFail m, MonadError TypograffitiError m, makeDrawTextCached store filepath index fontsize SampleText {..} = do s <- liftIO $ atomically $ readTMVar $ fontMap store font <- case M.lookup (filepath, fontsize, index) s of - Nothing -> allocFont store filepath index fontsize + Nothing -> allocFont store filepath index fontsize fontOptions Just font -> return font let glyphs = map (codepoint . fst) $ @@ -74,8 +76,9 @@ makeDrawTextCached store filepath index fontsize SampleText {..} = do return $ drawLinesWrapper tabwidth $ \RichText {..} -> drawGlyphs store atlas $ shape (harfbuzz font) defaultBuffer { HB.text = text } [] -allocFont :: (MonadIO m) => FontStore n -> FilePath -> Int -> GlyphSize -> m Font -allocFont FontStore {..} filepath index fontsize = liftIO $ do +allocFont :: (MonadIO m) => + FontStore n -> FilePath -> Int -> GlyphSize -> HB.FontOptions -> m Font +allocFont FontStore {..} filepath index fontsize options = liftIO $ do font <- ft_New_Face lib filepath $ toEnum index case fontsize of PixelSize w h -> ft_Set_Pixel_Sizes font (toEnum $ x2 w) (toEnum $ x2 h) @@ -84,7 +87,8 @@ allocFont FontStore {..} filepath index fontsize = liftIO $ do (toEnum dpix) (toEnum dpiy) bytes <- B.readFile filepath - let font' = HB.createFont $ HB.createFace bytes $ toEnum index + let font' = HB.createFontWithOptions options $ HB.createFace bytes $ toEnum index + liftIO $ ft_Set_Var_Design_Coordinates font $ map float2fixed $ HB.fontVarCoordsDesign font' atlases <- liftIO $ atomically $ newTMVar [] let ret = Font font' font atlases @@ -93,7 +97,10 @@ allocFont FontStore {..} filepath index fontsize = liftIO $ do map <- takeTMVar fontMap putTMVar fontMap $ M.insert (filepath, fontsize, index) ret map return ret - where x2 = (*2) + where + x2 = (*2) + float2fixed :: Float -> FT_Fixed + float2fixed = toEnum . fromEnum . (*65536) allocAtlas' :: (MonadIO m, MonadFail m) => TMVar [(IS.IntSet, Atlas)] -> FT_Face -> IS.IntSet -> m Atlas diff --git a/src/Typograffiti/Text.hs b/src/Typograffiti/Text.hs index 2627186..c906a03 100644 --- a/src/Typograffiti/Text.hs +++ b/src/Typograffiti/Text.hs @@ -29,9 +29,13 @@ import qualified Data.Set as S import qualified Data.IntSet as IS import Linear import qualified Data.ByteString as B -import Data.Text.Glyphize (defaultBuffer, Buffer(..), shape, GlyphInfo(..)) +import Data.Text.Glyphize (defaultBuffer, Buffer(..), shape, GlyphInfo(..), + parseFeature, parseVariation, Variation(..), + FontOptions(..), defaultFontOptions) import qualified Data.Text.Glyphize as HB import FreeType.Core.Base +import FreeType.Core.Types (FT_Fixed) +import FreeType.Format.Multiple (ft_Set_Var_Design_Coordinates) import Data.Text.Lazy (Text, pack) import qualified Data.Text.Lazy as Txt import Data.Word (Word32) @@ -47,11 +51,12 @@ data GlyphSize = CharSize Float Float Int Int data SampleText = SampleText { sampleFeatures :: [HB.Feature], sampleText :: Text, - tabwidth :: Int + tabwidth :: Int, + fontOptions :: FontOptions } defaultSample :: SampleText -defaultSample = SampleText [] (pack $ map toEnum [32..126]) 4 +defaultSample = SampleText [] (pack $ map toEnum [32..126]) 4 defaultFontOptions addSampleFeature :: String -> Word32 -> SampleText -> SampleText addSampleFeature name value sample@SampleText {..} = sample { sampleFeatures = @@ -62,6 +67,35 @@ addSampleFeature name value sample@SampleText {..} = sample { i = w $ length sampleFeatures w :: Int -> Word w = toEnum +parseSampleFeature :: String -> SampleText -> SampleText +parseSampleFeature syntax sample | Just feat <- parseFeature syntax = sample { + sampleFeatures = feat : sampleFeatures sample + } + | otherwise = sample +parseSampleFeatures :: [String] -> SampleText -> SampleText +parseSampleFeatures = flip $ foldl $ flip parseSampleFeature +addFontVariant :: String -> Float -> SampleText -> SampleText +addFontVariant name val sampleText = sampleText { + fontOptions = (fontOptions sampleText) { + optionVariations = Variation (HB.tag_from_string name) val : + optionVariations (fontOptions sampleText) + } + } +parseFontVariant :: String -> SampleText -> SampleText +parseFontVariant syntax sample | Just var <- parseVariation syntax = sample { + fontOptions = (fontOptions sample) { + optionVariations = var : optionVariations (fontOptions sample) + } + } + | otherwise = sample +parseFontVariants :: [String] -> SampleText -> SampleText +parseFontVariants = flip $ foldl $ flip parseFontVariant + +varItalic = "ital" +varOptSize = "opsz" +varSlant = "slnt" +varWidth = "wdth" +varWeight = "wght" makeDrawText :: (MonadIO m, MonadFail m, MonadError TypograffitiError m, MonadIO n, MonadFail n, MonadError TypograffitiError n) => @@ -76,19 +110,24 @@ makeDrawText lib filepath index fontsize SampleText {..} = do (toEnum dpix) (toEnum dpiy) bytes <- liftIO $ B.readFile filepath - let font' = HB.createFont $ HB.createFace bytes $ toEnum index + let font' = HB.createFontWithOptions fontOptions $ HB.createFace bytes $ toEnum index let glyphs = map (codepoint . fst) $ shape font' defaultBuffer { HB.text = Txt.replicate (toEnum $ succ $ length sampleFeatures) sampleText } sampleFeatures let glyphs' = map toEnum $ IS.toList $ IS.fromList $ map fromEnum glyphs + -- FIXME expose this function... + liftIO $ ft_Set_Var_Design_Coordinates font $ map float2fixed $ HB.fontVarCoordsDesign font' atlas <- allocAtlas (glyphRetriever font) glyphs' liftIO $ ft_Done_Face font drawGlyphs <- makeDrawGlyphs return $ drawLinesWrapper tabwidth $ \RichText {..} -> drawGlyphs atlas $ shape font' defaultBuffer { HB.text = text } features - where x2 = (*2) + where + x2 = (*2) + float2fixed :: Float -> FT_Fixed + float2fixed = toEnum . fromEnum . (*65536) makeDrawText' a b c d = ft_With_FreeType $ \ft -> runExceptT $ makeDrawText ft a b c d diff --git a/typograffiti2.cabal b/typograffiti.cabal similarity index 96% rename from typograffiti2.cabal rename to typograffiti.cabal index 32ad207..4069ea3 100644 --- a/typograffiti2.cabal +++ b/typograffiti.cabal @@ -35,7 +35,7 @@ library Typograffiti.Rich build-depends: base >=4.12 && <4.13, linear>=1.20, containers >= 0.6, freetype2 >= 0.2, gl >= 0.8, mtl >= 2.2, stm >= 2.5, text, - vector >= 0.12, harfbuzz-pure >= 0.0.7, bytestring >= 0.10 + vector >= 0.12, harfbuzz-pure >= 1.0.1, bytestring >= 0.10 hs-source-dirs: src default-language: Haskell2010 -- 2.30.2