From 6ebab16d8114460b35a7714ceed8d786e32374ae Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Wed, 14 Dec 2022 18:18:18 +1300 Subject: [PATCH] Transliterate FTFC into these FontConfig language bindings. --- FreeType/FontConfig.hs | 191 +++++++++++++++++++++++++++ Graphics/Text/Font/Choose/Pattern.hs | 10 +- 2 files changed, 199 insertions(+), 2 deletions(-) diff --git a/FreeType/FontConfig.hs b/FreeType/FontConfig.hs index cadfaa0..d7b7ea5 100644 --- a/FreeType/FontConfig.hs +++ b/FreeType/FontConfig.hs @@ -17,6 +17,18 @@ import System.IO.Unsafe (unsafePerformIO) import Control.Exception (throw) import Graphics.Text.Font.Choose.Result (Error(ErrTypeMismatch)) +-- For FcFt transliteration +import Graphics.Text.Font.Choose.Value (Value(..)) +import Graphics.Text.Font.Choose.Pattern (getValue', getValue0, getValue, getValues') +import Data.Maybe (fromMaybe) +import FreeType.Core.Base (FT_Library, ft_New_Face, ft_Set_Pixel_Sizes, ft_Set_Transform, + FT_FaceRec(..), FT_SizeRec(..), FT_Size_Metrics(..)) +import FreeType.Control.Subpixel (FT_LcdFilter) +import FreeType.Core.Types (FT_Matrix(..)) +import Linear.V2 (V2(..)) +import Linear.Matrix(M22) +import Data.Bits ((.|.)) + c2w :: Char -> Word32 c2w = fromIntegral . fromEnum @@ -66,3 +78,182 @@ ftQueryFace face filename id = withCString filename $ \filename' -> thawPattern_ $ fcFreeTypeQueryFace face filename' id nullPtr foreign import ccall "FcFreeTypeQueryFace" fcFreeTypeQueryFace :: FT_Face -> CString -> Int -> Ptr () -> IO Pattern_ -- Final arg's deprecated! + +------ +--- Transliterated from FcFt +--- https://codeberg.org/dnkl/fcft/ +------ + +data FTFC_Instance = Instance { + fontName :: String, + fontPath :: Maybe String, + fontFace :: FT_Face, + fontLoadFlags :: Int, + fontAntialias :: Bool, + fontEmbolden :: Bool, + fontIsColor :: Bool, + fontRenderFlags :: Int, + fontRenderFlagsSubpixel :: Int, + fontPixelSizeFixup :: Double, + fontPixelFixupEstimated :: Bool, + fontBGR :: Bool, + fontLCDFilter :: FT_LcdFilter, + fontFeats :: [String], -- Callers probably want to validate via harfbuzz + fontMetrics :: FTFC_Metrics +} +data FTFC_Metrics = Metrics { + height :: Int, + descent :: Int, + ascent :: Int, + maxAdvance :: (Int, Int), + metricsAntialias :: Bool, + metricsSubpixel :: Subpixel, + metricsName :: String +} +data Subpixel = SubpixelNone | SubpixelHorizontalRGB | SubpixelHorizontalBGR | + SubpixelVerticalRGB | SubpixelVerticalBGR + +instantiatePattern :: FT_Library -> Pattern -> (Double, Double) -> IO FTFC_Instance +instantiatePattern ftlib pattern (req_pt_size, req_px_size) = do + let dpi = fromMaybe 75 $ getValue' "dpi" pattern :: Double + let size = fromMaybe req_pt_size $ getValue' "size" pattern + + ft_face <- case getValue "ftface" pattern of + ValueFTFace x -> return x + _ -> ft_New_Face ftlib (getValue0 "file" pattern) -- is a mutex needed? + (toEnum $ fromMaybe 0 $ getValue' "index" pattern) + + ft_Set_Pixel_Sizes ft_face 0 $ toEnum $ getValue0 "pixelsize" pattern + let scalable = fromMaybe True $ getValue' "scalable" pattern + let outline = fromMaybe True $ getValue' "outline" pattern + (pixel_fixup, fixup_estimated) <- case getValue "pixelsizefixupfactor" pattern of + ValueDouble x -> return (x, False) + _ | scalable && not outline -> do + let px_size = if req_px_size < 0 then req_pt_size * dpi / 72 else req_px_size + ft_face' <- peek ft_face + size' <- peek $ frSize ft_face' + return (px_size / (fromIntegral $ smY_ppem $ srMetrics size'), True) + _ -> return (1, False) + + let hinting = fromMaybe True $ getValue' "hinting" pattern + let antialias = fromMaybe True $ getValue' "antialias" pattern + let hintstyle = fromMaybe 1 $ getValue' "hintstyle" pattern :: Int + let rgba = fromMaybe 0 $ getValue' "rgba" pattern :: Int + let load_flags | not antialias && (not hinting || hintstyle == 0) = + ft_LOAD_NO_HINTING .|. ft_LOAD_MONOCHROME + | not antialias = ft_LOAD_MONOCHROME + | not hinting || hintstyle == 0 = ft_LOAD_NO_HINTING + | otherwise = ft_LOAD_DEFAULT + let load_target | not antialias && hinting && hintstyle /= 0 = ft_LOAD_TARGET_MONO + | not antialias = ft_LOAD_TARGET_NORMAL + | not hinting || hintstyle == 0 = ft_LOAD_TARGET_NORMAL + | hintstyle == 1 = ft_LOAD_TARGET_LIGHT + | hintstyle == 2 = ft_LOAD_TARGET_NORMAL + | rgba `elem` [1, 2] = ft_LOAD_TARGET_LCD + | rgba `elem` [3, 4] = ft_LOAD_TARGET_LCD_V + | otherwise = ft_LOAD_TARGET_NORMAL + + let embedded_bitmap = fromMaybe True $ getValue' "embeddedbitmap" pattern + let load_flags1 | embedded_bitmap = load_flags .|. ft_LOAD_NO_BITMAP + | otherwise = load_flags + let autohint = fromMaybe False $ getValue' "autohint" pattern + let load_flags2 | autohint = load_flags .|. ft_LOAD_FORCE_AUTOHINT + | otherwise = load_flags + let render_flags_normal | not antialias = ft_RENDER_MODE_MONO + | otherwise = ft_RENDER_MODE_NORMAL + let render_flags_subpixel | not antialias = ft_RENDER_MODE_MONO + | rgba `elem` [1, 2] = ft_RENDER_MODE_LCD + | rgba `elem` [3, 4] = ft_RENDER_MODE_LCD_V + | otherwise = ft_RENDER_MODE_NORMAL + + let lcdfilter = case fromMaybe 1 $ getValue' "lcdfilter" pattern :: Int of { + 3 -> 16; x -> x} + case getValue "matrix" pattern of + ValueMatrix m -> ft_Set_Transform ft_face (Just $ m22toFt m) Nothing + _ -> return () + + ft_face' <- peek ft_face + size' <- peek $ frSize ft_face' + let metrics' = srMetrics size' + let c x = fromIntegral x / 64 * pixel_fixup + return Instance { + fontName = getValue0 "fullname" pattern, + fontPath = getValue' "file" pattern, + fontFace = ft_face, + fontLoadFlags = load_target .|. load_flags .|. ft_LOAD_COLOR, + fontAntialias = antialias, + fontEmbolden = fromMaybe False $ getValue' "embolden" pattern, + fontIsColor = fromMaybe False $ getValue' "color" pattern, + fontRenderFlags = render_flags_normal, + fontRenderFlagsSubpixel = render_flags_subpixel, + fontPixelSizeFixup = pixel_fixup, + fontPixelFixupEstimated = fixup_estimated, + fontBGR = rgba `elem` [2, 4], + fontLCDFilter = toEnum lcdfilter, + fontFeats = getValues' "fontfeatures" pattern, + fontMetrics = Metrics { + height = fromEnum $ c $ smHeight metrics', + descent = fromEnum $ c $ smDescender metrics', + ascent = fromEnum $ c $ smAscender metrics', + maxAdvance = (fromEnum $ c $ smMax_advance metrics', + fromEnum $ c $ smHeight metrics'), + metricsAntialias = antialias, + metricsSubpixel = case rgba of + _ | not antialias -> SubpixelNone + 1 -> SubpixelHorizontalRGB + 2 -> SubpixelHorizontalBGR + 3 -> SubpixelVerticalRGB + 4 -> SubpixelVerticalBGR + _ -> SubpixelNone, + metricsName = getValue0 "fullname" pattern + } + } + +m22toFt :: M22 Double -> FT_Matrix +m22toFt (V2 (V2 xx xy) (V2 yx yy)) = FT_Matrix { + mXx = c xx * 0x10000, mXy = c xy * 0x10000, + mYx = c yx * 0x10000, mYy = c yy * 0x10000 + } where c = toEnum . fromEnum + +-- Taken from FreeType language bindings, +-- but converted to constants rather than pattern synonyms. +ft_LOAD_DEFAULT, ft_LOAD_NO_SCALE, ft_LOAD_NO_HINTING, ft_LOAD_RENDER, + ft_LOAD_NO_BITMAP, ft_LOAD_VERTICAL_LAYOUT, ft_LOAD_FORCE_AUTOHINT, + ft_LOAD_CROP_BITMAP, ft_LOAD_PEDANTIC, ft_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH, + ft_LOAD_NO_RECURSE, ft_LOAD_IGNORE_TRANSFORM, ft_LOAD_MONOCHROME, + ft_LOAD_LINEAR_DESIGN, ft_LOAD_NO_AUTOHINT, ft_LOAD_COLOR, + ft_LOAD_COMPUTE_METRICS, ft_LOAD_BITMAP_METRICS_ONLY :: Int +ft_LOAD_DEFAULT = 0 +ft_LOAD_NO_SCALE = 1 +ft_LOAD_NO_HINTING = 2 +ft_LOAD_RENDER = 4 +ft_LOAD_NO_BITMAP = 8 +ft_LOAD_VERTICAL_LAYOUT = 16 +ft_LOAD_FORCE_AUTOHINT = 32 +ft_LOAD_CROP_BITMAP = 64 +ft_LOAD_PEDANTIC = 128 +ft_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH = 512 +ft_LOAD_NO_RECURSE = 1024 +ft_LOAD_IGNORE_TRANSFORM = 2048 +ft_LOAD_MONOCHROME = 4096 +ft_LOAD_LINEAR_DESIGN = 8192 +ft_LOAD_NO_AUTOHINT = 32768 +ft_LOAD_COLOR = 1048576 +ft_LOAD_COMPUTE_METRICS = 2097152 +ft_LOAD_BITMAP_METRICS_ONLY = 4194304 + +ft_LOAD_TARGET_NORMAL, ft_LOAD_TARGET_LIGHT, ft_LOAD_TARGET_MONO, + ft_LOAD_TARGET_LCD, ft_LOAD_TARGET_LCD_V :: Int +ft_LOAD_TARGET_NORMAL = 0 +ft_LOAD_TARGET_LIGHT = 65536 +ft_LOAD_TARGET_MONO = 131072 +ft_LOAD_TARGET_LCD = 196608 +ft_LOAD_TARGET_LCD_V = 262144 + +ft_RENDER_MODE_NORMAL, ft_RENDER_MODE_LIGHT, ft_RENDER_MODE_MONO, + ft_RENDER_MODE_LCD, ft_RENDER_MODE_LCD_V :: Int +ft_RENDER_MODE_NORMAL = 0 +ft_RENDER_MODE_LIGHT = 1 +ft_RENDER_MODE_MONO = 2 +ft_RENDER_MODE_LCD = 3 +ft_RENDER_MODE_LCD_V = 4 diff --git a/Graphics/Text/Font/Choose/Pattern.hs b/Graphics/Text/Font/Choose/Pattern.hs index c26580e..337874b 100644 --- a/Graphics/Text/Font/Choose/Pattern.hs +++ b/Graphics/Text/Font/Choose/Pattern.hs @@ -3,7 +3,7 @@ module Graphics.Text.Font.Choose.Pattern (Pattern(..), Binding(..), equalSubset, normalizePattern, filter, defaultSubstitute, nameParse, nameUnparse, format, Pattern_, withPattern, thawPattern, thawPattern_, patternAsPointer, - setValue, setValues, unset, getValue, getValue0, + setValue, setValues, unset, getValues, getValues', getValue, getValue', getValue0, parseFontFamily, parseFontFeatures, parseFontVars, parseLength, parseFontStretch, parseFontWeight) where @@ -24,7 +24,7 @@ import Debug.Trace (trace) -- For reporting internal errors! import System.IO.Unsafe (unsafePerformIO) import Control.Monad (forM, join) -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Control.Exception (bracket) -- Imported for CSS bindings @@ -46,9 +46,15 @@ setValue :: ToValue x => String -> Binding -> x -> Pattern -> Pattern setValue key b value pat = (key, [(b, toValue value)]):unset key pat setValues :: ToValue x => String -> Binding -> [x] -> Pattern -> Pattern setValues key b values pat = (key, [(b, toValue v) | v <- values]):unset key pat +getValues :: String -> Pattern -> [Value] +getValues key pat | Just ret <- lookup key pat = map snd ret + | otherwise = [] +getValues' key pat = mapMaybe fromValue $ getValues key pat getValue :: String -> Pattern -> Value getValue key pat | Just ((_, ret):_) <- lookup key pat = ret | otherwise = ValueVoid +getValue' :: ToValue x => String -> Pattern -> Maybe x +getValue' key pat = fromValue $ getValue key pat getValue0 :: ToValue x => String -> Pattern -> x getValue0 key pat = fromValue' $ getValue key pat -- 2.30.2