@@ 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
@@ 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