diff --git a/FontyFruity.cabal b/FontyFruity.cabal --- a/FontyFruity.cabal +++ b/FontyFruity.cabal @@ -1,56 +1,62 @@ --- Initial FontyFruity.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - -name: FontyFruity -version: 0.2.1 -synopsis: A true type file format loader -description: - An haskell Truetype file parser. - . - You can load a font file and extract some curves to be - drawed with a library like Rasterific . -license: BSD3 -license-file: LICENSE -author: Vincent Berthoux -maintainer: vincent.berthoux@gmail.com --- copyright: -category: Graphics, Text, Font -build-type: Simple --- extra-source-files: -cabal-version: >=1.10 - -extra-source-files: changelog - -Source-Repository head - Type: git - Location: https://github.com/Twinside/FontyFruity.git - -Source-Repository this - Type: git - Location: https://github.com/Twinside/FontyFruity.git - Tag: v0.2.1 - - -library - exposed-modules: Graphics.Text.TrueType - other-modules: Graphics.Text.TrueType.Bytecode - , Graphics.Text.TrueType.MaxpTable - , Graphics.Text.TrueType.Header - , Graphics.Text.TrueType.Glyph - , Graphics.Text.TrueType.Types - , Graphics.Text.TrueType.OffsetTable - , Graphics.Text.TrueType.CharacterMap - , Graphics.Text.TrueType.LanguageIds - , Graphics.Text.TrueType.HorizontalInfo - , Graphics.Text.TrueType.Name - - ghc-options: -Wall -O2 - ghc-prof-options: -Wall -prof -auto-all - hs-source-dirs: src - default-language: Haskell2010 - build-depends: base >= 4.6 && < 4.9 - , binary >= 0.5 && < 0.8 - , bytestring >= 0.10 && < 0.11 - , containers >= 0.4.2 && < 0.6 - , vector >= 0.9 && < 0.11 - +-- Initial FontyFruity.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: FontyFruity +version: 0.3 +synopsis: A true type file format loader +description: + A haskell Truetype file parser. + . + You can load a font file and extract some curves to be + drawed with a library like Rasterific . +license: BSD3 +license-file: LICENSE +author: Vincent Berthoux +maintainer: vincent.berthoux@gmail.com +-- copyright: +category: Graphics, Text, Font +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +extra-source-files: changelog + +Source-Repository head + Type: git + Location: https://github.com/Twinside/FontyFruity.git + +Source-Repository this + Type: git + Location: https://github.com/Twinside/FontyFruity.git + Tag: v0.3 + + +library + exposed-modules: Graphics.Text.TrueType + other-modules: Graphics.Text.TrueType.Bytecode + , Graphics.Text.TrueType.MaxpTable + , Graphics.Text.TrueType.Header + , Graphics.Text.TrueType.Glyph + , Graphics.Text.TrueType.Types + , Graphics.Text.TrueType.OffsetTable + , Graphics.Text.TrueType.CharacterMap + , Graphics.Text.TrueType.LanguageIds + , Graphics.Text.TrueType.HorizontalInfo + , Graphics.Text.TrueType.Name + , Graphics.Text.TrueType.FontFolders + , Graphics.Text.TrueType.FontType + + ghc-options: -Wall -O2 + ghc-prof-options: -Wall -prof -auto-all + hs-source-dirs: src + default-language: Haskell2010 + build-depends: base >= 4.6 && < 4.9 + , binary >= 0.5 + , bytestring >= 0.10 + , containers >= 0.4.2 && < 0.6 + , vector >= 0.9 + , directory + , text + , filepath + , deepseq >= 1.2 + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,30 @@ -Copyright (c) 2014, Vincent Berthoux - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Vincent Berthoux nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c) 2014, Vincent Berthoux + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Vincent Berthoux nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,26 +1,31 @@ --*-change-log-*- - -v0.2.1 April 2014 - * Fixing some character map loading problem (again) - * Fixing font loading with out of order tables - -v0.2 March 2014 - * Fixing character map loading when identical table - offset are used. - * Adding bounding box extraction for test snippet. - -v0.1.0.4 February 2014 - * Fixing hackage's haddock generation - -v0.1.0.3 February 2014 - * Dropping base upper bound. - -v0.1.0.2 February 2014 - * Fixing compilation with old version of binary. - -v0.1.0.1 February 2014 - * Fixing some missing information in the cabal file. - -v0.1 February 2014 - * Initial version. - +-*-change-log-*- + +v0.3 June 2014 + * Adding a font finding function + * Adding a font cache type to speed-up frequent font + finding. + +v0.2.1 April 2014 + * Fixing some character map loading problem (again) + * Fixing font loading with out of order tables + +v0.2 March 2014 + * Fixing character map loading when identical table + offset are used. + * Adding bounding box extraction for test snippet. + +v0.1.0.4 February 2014 + * Fixing hackage's haddock generation + +v0.1.0.3 February 2014 + * Dropping base upper bound. + +v0.1.0.2 February 2014 + * Fixing compilation with old version of binary. + +v0.1.0.1 February 2014 + * Fixing some missing information in the cabal file. + +v0.1 February 2014 + * Initial version. + diff --git a/src/Graphics/Text/TrueType.hs b/src/Graphics/Text/TrueType.hs --- a/src/Graphics/Text/TrueType.hs +++ b/src/Graphics/Text/TrueType.hs @@ -1,336 +1,356 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | Module in charge of loading fonts. -module Graphics.Text.TrueType - ( -- * Functions - decodeFont - , loadFontFile - , getStringCurveAtPoint - , stringBoundingBox - - -- * Types - , Font( .. ) - , Dpi - , PointSize - ) where - -import Control.Applicative( (<$>) ) -import Control.Monad( foldM, forM ) -import Data.Function( on ) -import Data.List( sortBy, mapAccumL, foldl' ) -import Data.Word( Word16, Word32 ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( Get - , bytesRead - , getWord16be - , getWord32be - , getLazyByteString - , skip - ) - -#if MIN_VERSION_binary(0,6,4) -import qualified Data.Binary.Get as G -#else -import qualified Data.Binary.Get as G -import qualified Control.Exception as E --- I feel so dirty. :( -import System.IO.Unsafe( unsafePerformIO ) -#endif - -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy as LB -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as VU - -{-import Graphics.Text.TrueType.Types-} -import Graphics.Text.TrueType.MaxpTable -import Graphics.Text.TrueType.Glyph -import Graphics.Text.TrueType.Header -import Graphics.Text.TrueType.OffsetTable -import Graphics.Text.TrueType.CharacterMap -import Graphics.Text.TrueType.HorizontalInfo -import Graphics.Text.TrueType.Name - -{-import Debug.Trace-} - --- | Type representing a font. -data Font = Font - { _fontOffsetTable :: !OffsetTable - , _fontTables :: ![(B.ByteString, B.ByteString)] - , _fontNames :: Maybe NameTable - , _fontHeader :: Maybe FontHeader - , _fontMaxp :: Maybe MaxpTable - , _fontMap :: Maybe CharacterMaps - , _fontGlyph :: Maybe (V.Vector Glyph) - , _fontLoca :: Maybe (VU.Vector Word32) - , _fontHorizontalHeader :: Maybe HorizontalHeader - , _fontHorizontalMetrics :: Maybe HorizontalMetricsTable - } - deriving (Show) - -emptyFont :: OffsetTable -> Font -emptyFont table = Font - { _fontTables = [] - , _fontOffsetTable = table - , _fontNames = Nothing - , _fontHeader = Nothing - , _fontGlyph = Nothing - , _fontMaxp = Nothing - , _fontLoca = Nothing - , _fontMap = Nothing - , _fontHorizontalHeader = Nothing - , _fontHorizontalMetrics = Nothing - } - --- | Load a font file, the file path must be pointing --- to the true type file (.ttf) -loadFontFile :: FilePath -> IO (Either String Font) -loadFontFile filepath = decodeFont <$> LB.readFile filepath - -getOrFail :: Get a -> LB.ByteString -> Either String a -getOrFail getter str = -#if MIN_VERSION_binary(0,6,4) - case G.runGetOrFail getter str of - Left err -> Left $ show err - Right (_, _, value) -> Right value -#else - unsafePerformIO $ E.evaluate (return $ G.runGet getter str) - `E.catch` catcher - where catcher :: E.SomeException -> IO (Either String a) - catcher e = return . Left $ show e -#endif - --- | Decode a in-memory true type file. -decodeFont :: LB.ByteString -> Either String Font -decodeFont = getOrFail getFont - -decodeWithDefault :: forall a . Binary a => a -> LB.ByteString -> a -decodeWithDefault defaultValue str = - case getOrFail get str of - Left _ -> defaultValue - Right v -> v - -gotoOffset :: TableDirectoryEntry -> Get () -gotoOffset entry = do - readed <- bytesRead - let toDrop = fromIntegral (_tdeOffset entry) - readed - if toDrop < 0 then fail "Weirdo weird" - else skip $ fromIntegral toDrop - -getLoca :: Font -> Get Font -getLoca font@(Font { _fontMaxp = Just maxp, _fontHeader = Just hdr }) - | _fHdrIndexToLocFormat hdr == 0 = do - v <- VU.replicateM glyphCount - ((* 2) . fromIntegral <$> getWord16be) - return font { _fontLoca = Just v } - | otherwise = do - v <- VU.replicateM glyphCount getWord32be - return font { _fontLoca = Just v } - where glyphCount = fromIntegral $ _maxpnumGlyphs maxp -getLoca font = return font - -getGlyph :: Font -> LB.ByteString -> Get Font -getGlyph font@(Font { _fontLoca = Just locations }) str = - - return font { _fontGlyph = Just . V.map decoder $ VU.convert locationInterval } - where decoder (xStart, xEnd) - | xEnd <= xStart = emptyGlyph - | otherwise = - decodeWithDefault emptyGlyph $ chop xStart xEnd - chop start _ = LB.drop (fromIntegral start) str - locationsAll = locations `VU.snoc` (fromIntegral $ LB.length str) - locationInterval = VU.zip locations $ VU.tail locationsAll -getGlyph font _ = return font - -getHmtx :: Font -> Get Font -getHmtx font@Font { _fontMaxp = Just maxp, - _fontHorizontalHeader = Just hdr } = do - let metricCount = _hheaLongHorMetricCount hdr - glyphCount = fromIntegral $ _maxpnumGlyphs maxp - table <- getHorizontalMetrics (fromIntegral metricCount) glyphCount - return font { _fontHorizontalMetrics = Just table } -getHmtx font = return font - -fetchTables :: OffsetTable -> Get Font -fetchTables offsetTable = do - let sortedTables = - sortBy (compare `on` _tdeOffset) . V.toList $ _otEntries offsetTable - tableData <- - forM sortedTables $ \entry -> do - gotoOffset entry - (B.unpack $ _tdeTag entry,) <$> getLazyByteString (fromIntegral $ _tdeLength entry) - - foldM (fetch tableData) (emptyFont offsetTable) - ["head" :: String, "maxp", "cmap", "name", "hhea", "loca", "glyf", "hmtx"] - where - getFetch tables name getter = - case [str | (n, str) <- tables, n == name] of - [] -> fail $ "Table not found " ++ name - (s:_) -> - case getOrFail getter s of - Left err -> fail err - Right v -> return v - - fetch tables font "head" = do - table <- getFetch tables "head" get - return $ font { _fontHeader = Just table } - - fetch tables font "maxp" = do - table <- getFetch tables "maxp" get - return $ font { _fontMaxp = Just table } - - fetch tables font "cmap" = do - table <- getFetch tables "cmap" get - return $ font { _fontMap = Just table } - - fetch tables font "name" = do - table <- getFetch tables "name" get - return $ font { _fontNames = Just table } - - fetch tables font "hhea" = do - table <- getFetch tables "hhea" get - return $ font { _fontHorizontalHeader = Just table } - - fetch tables font "glyf" = - case [getGlyph font s | ("glyf", s) <- tables] of - [] -> return font - (g:_) -> g - - fetch tables font "loca" = - getFetch tables "loca" (getLoca font) - - fetch tables font "hmtx" = do - getFetch tables "hmtx" (getHmtx font) - - fetch _ font _ = return font - -getFont :: Get Font -getFont = get >>= fetchTables - --- | Express device resolution in dot per inch. -type Dpi = Int - --- | Font size expressed in points. -type PointSize = Int - -glyphOfStrings :: Font -> String -> [(Glyph, HorizontalMetric)] -glyphOfStrings Font { _fontMap = Just mapping - , _fontGlyph = Just glyphes - , _fontHorizontalMetrics = Just hmtx } str = - fetcher . findCharGlyph mapping 0 <$> str - where - fetcher ix = (glyphes V.! ix, _glyphMetrics hmtx V.! ix) -glyphOfStrings _ _ = [] - -unitsPerEm :: Font -> Word16 -unitsPerEm Font { _fontHeader = Just hdr } = - fromIntegral $ _fUnitsPerEm hdr -unitsPerEm _ = 1 - --- | Compute the bounding box of a string displayed with a font at --- a given size. The resulting coordinate represent the width and the --- height in pixels. -stringBoundingBox :: Font -> Dpi -> PointSize -> String -> (Float, Float) -stringBoundingBox font dpi size str = - foldl' go (0, 0) $ glyphOfStrings font str - where - emSize = fromIntegral $ unitsPerEm font - - toPixel v = fromIntegral v * pixelSize / emSize - where pixelSize = fromIntegral (size * dpi) / 72 - - go (xf, yf) (glyph, metric) = (width', height') - where - advance = _hmtxAdvanceWidth metric - width' = xf + toPixel advance - height' = max yf . toPixel . _glfYMax $ _glyphHeader glyph - - --- | Extract a list of outlines for every char in the string. --- The given curves are in an image like coordinate system, --- with the origin point in the upper left corner. -getStringCurveAtPoint :: Dpi -- ^ Dot per inch of the output. - -> (Float, Float) -- ^ Initial position of the baseline. - -> [(Font, PointSize, String)] -- ^ Text to draw - -> [[VU.Vector (Float, Float)]] -- ^ List of contours for each char -getStringCurveAtPoint dpi initPos lst = snd $ mapAccumL go initPos glyphes where - glyphes = concat [(font, size, fromIntegral $ unitsPerEm font,) - <$> glyphOfStrings font str | (font, size, str) <- lst] - - toPixel (_, pointSize, emSize, _) v = fromIntegral v * pixelSize / emSize - where - pixelSize = fromIntegral (pointSize * dpi) / 72 - - toFCoord (_, pointSize, emSize, _) v = floor $ v * emSize / pixelSize - where - pixelSize = fromIntegral (pointSize * dpi) / 72 - - maximumSize = maximum [ toPixel p . _glfYMax $ _glyphHeader glyph - | p@(_, _, _, (glyph, _)) <- glyphes ] - - go (xf, yf) p@(font, pointSize, _, (glyph, metric)) = ((toPixel p $ xi + advance, yf), curves) - where - (xi, yi) = (toFCoord p xf, toFCoord p yf) - bearing = fromIntegral $ _hmtxLeftSideBearing metric - advance = fromIntegral $ _hmtxAdvanceWidth metric - curves = - getGlyphIndexCurvesAtPointSizeAndPos font dpi (toFCoord p maximumSize) - (pointSize, glyph) (xi + bearing, yi) - - -getGlyphIndexCurvesAtPointSizeAndPos :: Font -> Dpi -> Int -> (PointSize, Glyph) -> (Int, Int) - -> [VU.Vector (Float, Float)] -getGlyphIndexCurvesAtPointSizeAndPos Font { _fontHeader = Nothing } _ _ _ _ = [] -getGlyphIndexCurvesAtPointSizeAndPos Font { _fontGlyph = Nothing } _ _ _ _ = [] -getGlyphIndexCurvesAtPointSizeAndPos - Font { _fontHeader = Just hdr, _fontGlyph = Just allGlyphs } - dpi maximumSize (pointSize, topGlyph) (baseX, baseY) = glyphReverse <$> glyphExtract topGlyph - where - go index | index >= V.length allGlyphs = [] - | otherwise = glyphExtract $ allGlyphs V.! index - - pixelSize = fromIntegral (pointSize * dpi) / 72 - emSize = fromIntegral $ _fUnitsPerEm hdr - - maxiF = toPixelCoordinate (0 :: Int) maximumSize - baseYF = toPixelCoordinate (0 :: Int) baseY - - glyphReverse = VU.map (\(x,y) -> (x, maxiF - y + baseYF)) - - toPixelCoordinate shift coord = - (fromIntegral (shift + fromIntegral coord) * pixelSize) / emSize - - composeGlyph composition = VU.map updateCoords <$> subCurves - where - subCurves = go . fromIntegral $ _glyphCompositeIndex composition - toFloat v = fromIntegral v / (0x4000 :: Float) - CompositeScaling ai bi ci di ei fi = _glyphCompositionScale composition - - scaler v1 v2 - | fromIntegral (abs (abs ai - abs ci)) <= (33 / 65536 :: Float) = 2 * vf - | otherwise = vf - where - vf = toFloat $ max (abs v1) (abs v2) - - m = scaler ai bi - n = scaler ci di - - am = toFloat ai / m - cm = toFloat ci / m - bn = toFloat ci / n - dn = toFloat di / n - e = toFloat ei - f = toFloat fi - - updateCoords (x,y) = - (m * (am * x + cm *y + e), n * (bn * x + dn * y + f)) - - glyphExtract Glyph { _glyphContent = GlyphEmpty } = [] - glyphExtract Glyph { _glyphContent = GlyphComposite compositions _ } = - concatMap composeGlyph $ V.toList compositions - glyphExtract Glyph { _glyphContent = GlyphSimple countour } = - [ VU.map (\(x, y) -> (toPixelCoordinate baseX x, toPixelCoordinate (0 :: Int) y)) c - | c <- extractFlatOutline countour] - +{-# LANGUAGE CPP #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Module in charge of loading fonts. +module Graphics.Text.TrueType + ( -- * Functions + decodeFont + , loadFontFile + , getStringCurveAtPoint + , stringBoundingBox + , findFontOfFamily + + -- * Font cache + , FontCache + , FontDescriptor( .. ) + , findFontInCache + , buildCache + + -- * Types + , Font( .. ) + , FontStyle( .. ) + , Dpi + , PointSize + ) where + +import Control.Applicative( (<$>) ) +import Control.Monad( foldM, forM ) +import Data.Function( on ) +import Data.List( sortBy, mapAccumL, foldl' ) +import Data.Word( Word16 ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( Get + , bytesRead + , getWord16be + , getWord32be + , getLazyByteString + , skip + ) + +#if MIN_VERSION_binary(0,6,4) +import qualified Data.Binary.Get as G +import Control.DeepSeq( NFData ) +#else +import qualified Data.Binary.Get as G +import qualified Control.Exception as E +-- I feel so dirty. :( +import System.IO.Unsafe( unsafePerformIO ) +import Control.DeepSeq( NFData, ($!!) ) +#endif + +import qualified Data.Map as M +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as LB +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU + +{-import Graphics.Text.TrueType.Types-} +import Graphics.Text.TrueType.MaxpTable +import Graphics.Text.TrueType.Glyph +import Graphics.Text.TrueType.Header +import Graphics.Text.TrueType.OffsetTable +import Graphics.Text.TrueType.CharacterMap +import Graphics.Text.TrueType.HorizontalInfo +import Graphics.Text.TrueType.Name() +import Graphics.Text.TrueType.FontType +import Graphics.Text.TrueType.FontFolders + +{-import Debug.Trace-} + +-- | Load a font file, the file path must be pointing +-- to the true type file (.ttf) +loadFontFile :: FilePath -> IO (Either String Font) +loadFontFile filepath = decodeFont <$> LB.readFile filepath + +getOrFail :: NFData a => Get a -> LB.ByteString -> Either String a +getOrFail getter str = +#if MIN_VERSION_binary(0,6,4) + case G.runGetOrFail getter str of + Left err -> Left $ show err + Right (_, _, value) -> Right value +#else + unsafePerformIO $ E.evaluate (let v = G.runGet getter str in + return $!! v) + `E.catch` catcher + where catcher :: E.SomeException -> IO (Either String a) + catcher e = return . Left $ show e +#endif + +-- | Decode a in-memory true type file. +decodeFont :: LB.ByteString -> Either String Font +decodeFont = getOrFail getFont + +decodeWithDefault :: forall a . (NFData a, Binary a) + => a -> LB.ByteString -> a +decodeWithDefault defaultValue str = + case getOrFail get str of + Left _ -> defaultValue + Right v -> v + +gotoOffset :: TableDirectoryEntry -> Get () +gotoOffset entry = do + readed <- bytesRead + let toDrop = fromIntegral (_tdeOffset entry) - readed + if toDrop < 0 then fail "Weirdo weird" + else skip $ fromIntegral toDrop + +getLoca :: Font -> Get Font +getLoca font@(Font { _fontMaxp = Just maxp, _fontHeader = Just hdr }) + | _fHdrIndexToLocFormat hdr == 0 = do + v <- VU.replicateM glyphCount + ((* 2) . fromIntegral <$> getWord16be) + return font { _fontLoca = Just v } + | otherwise = do + v <- VU.replicateM glyphCount getWord32be + return font { _fontLoca = Just v } + where glyphCount = fromIntegral $ _maxpnumGlyphs maxp +getLoca font = return font + +getGlyph :: Font -> LB.ByteString -> Get Font +getGlyph font@(Font { _fontLoca = Just locations }) str = + + return font { _fontGlyph = Just . V.map decoder $ VU.convert locationInterval } + where decoder (xStart, xEnd) + | xEnd <= xStart = emptyGlyph + | otherwise = + decodeWithDefault emptyGlyph $ chop xStart xEnd + chop start _ = LB.drop (fromIntegral start) str + locationsAll = locations `VU.snoc` (fromIntegral $ LB.length str) + locationInterval = VU.zip locations $ VU.tail locationsAll +getGlyph font _ = return font + +getHmtx :: Font -> Get Font +getHmtx font@Font { _fontMaxp = Just maxp, + _fontHorizontalHeader = Just hdr } = do + let metricCount = _hheaLongHorMetricCount hdr + glyphCount = fromIntegral $ _maxpnumGlyphs maxp + table <- getHorizontalMetrics (fromIntegral metricCount) glyphCount + return font { _fontHorizontalMetrics = Just table } +getHmtx font = return font + +fetchTables :: [String] -> OffsetTable -> Get Font +fetchTables tableList offsetTable = do + let sortedTables = + sortBy (compare `on` _tdeOffset) . V.toList $ _otEntries offsetTable + tableData <- + forM sortedTables $ \entry -> do + gotoOffset entry + (B.unpack $ _tdeTag entry,) <$> getLazyByteString (fromIntegral $ _tdeLength entry) + + foldM (fetch tableData) (emptyFont offsetTable) tableList + + where + getFetch tables name getter = + case [str | (n, str) <- tables, n == name] of + [] -> fail $ "Table not found " ++ name + (s:_) -> + case getOrFail getter s of + Left err -> fail err + Right v -> return v + + fetch tables font "head" = do + table <- getFetch tables "head" get + return $ font { _fontHeader = Just table } + + fetch tables font "maxp" = do + table <- getFetch tables "maxp" get + return $ font { _fontMaxp = Just table } + + fetch tables font "cmap" = do + table <- getFetch tables "cmap" get + return $ font { _fontMap = Just table } + + fetch tables font "name" = do + table <- getFetch tables "name" get + return $ font { _fontNames = Just table } + + fetch tables font "hhea" = do + table <- getFetch tables "hhea" get + return $ font { _fontHorizontalHeader = Just table } + + fetch tables font "glyf" = + case [getGlyph font s | ("glyf", s) <- tables] of + [] -> return font + (g:_) -> g + + fetch tables font "loca" = + getFetch tables "loca" (getLoca font) + + fetch tables font "hmtx" = do + getFetch tables "hmtx" (getHmtx font) + + fetch _ font _ = return font + +getFont :: Get Font +getFont = get >>= fetchTables allTables + where + allTables = ["head", "maxp", "cmap", "name", "hhea", "loca", "glyf", "hmtx"] + +getFontNameAndStyle :: Get Font +getFontNameAndStyle = + (filterTable isNecessaryForName <$> get) >>= fetchTables ["head", "name"] + where + isNecessaryForName v = v == "name" || v == "head" + +-- | This function will search in the system for truetype +-- files and index them in a cache for further fast search. +buildCache :: IO FontCache +buildCache = buildFontCache loader + where + loader n = + toMayb . getOrFail getFontNameAndStyle <$> LB.readFile n + toMayb (Left _) = Nothing + toMayb (Right v) = Just v + +-- | Try to find a font with the given properties in the +-- font cache. +findFontInCache :: FontCache -> FontDescriptor -> Maybe FilePath +findFontInCache (FontCache cache) descr = M.lookup descr cache + +-- | This function will scan the system's font folder to +-- find a font with the desired properties. Favor using +-- a FontCache to speed up the lookup process. +findFontOfFamily :: String -> FontStyle -> IO (Maybe FilePath) +findFontOfFamily = findFont loader + where + loader n = + toMayb . getOrFail getFontNameAndStyle <$> LB.readFile n + toMayb (Left _) = Nothing + toMayb (Right v) = Just v + +-- | Express device resolution in dot per inch. +type Dpi = Int + +-- | Font size expressed in points. +type PointSize = Int + +glyphOfStrings :: Font -> String -> [(Glyph, HorizontalMetric)] +glyphOfStrings Font { _fontMap = Just mapping + , _fontGlyph = Just glyphes + , _fontHorizontalMetrics = Just hmtx } str = + fetcher . findCharGlyph mapping 0 <$> str + where + fetcher ix = (glyphes V.! ix, _glyphMetrics hmtx V.! ix) +glyphOfStrings _ _ = [] + +unitsPerEm :: Font -> Word16 +unitsPerEm Font { _fontHeader = Just hdr } = + fromIntegral $ _fUnitsPerEm hdr +unitsPerEm _ = 1 + +-- | Compute the bounding box of a string displayed with a font at +-- a given size. The resulting coordinate represent the width and the +-- height in pixels. +stringBoundingBox :: Font -> Dpi -> PointSize -> String -> (Float, Float) +stringBoundingBox font dpi size str = + foldl' go (0, 0) $ glyphOfStrings font str + where + emSize = fromIntegral $ unitsPerEm font + + toPixel v = fromIntegral v * pixelSize / emSize + where pixelSize = fromIntegral (size * dpi) / 72 + + go (xf, yf) (glyph, metric) = (width', height') + where + advance = _hmtxAdvanceWidth metric + width' = xf + toPixel advance + height' = max yf . toPixel . _glfYMax $ _glyphHeader glyph + + +-- | Extract a list of outlines for every char in the string. +-- The given curves are in an image like coordinate system, +-- with the origin point in the upper left corner. +getStringCurveAtPoint :: Dpi -- ^ Dot per inch of the output. + -> (Float, Float) -- ^ Initial position of the baseline. + -> [(Font, PointSize, String)] -- ^ Text to draw + -> [[VU.Vector (Float, Float)]] -- ^ List of contours for each char +getStringCurveAtPoint dpi initPos lst = snd $ mapAccumL go initPos glyphes where + glyphes = concat [(font, size, fromIntegral $ unitsPerEm font,) + <$> glyphOfStrings font str | (font, size, str) <- lst] + + toPixel (_, pointSize, emSize, _) v = fromIntegral v * pixelSize / emSize + where + pixelSize = fromIntegral (pointSize * dpi) / 72 + + toFCoord (_, pointSize, emSize, _) v = floor $ v * emSize / pixelSize + where + pixelSize = fromIntegral (pointSize * dpi) / 72 + + maximumSize = maximum [ toPixel p . _glfYMax $ _glyphHeader glyph + | p@(_, _, _, (glyph, _)) <- glyphes ] + + go (xf, yf) p@(font, pointSize, _, (glyph, metric)) = ((toPixel p $ xi + advance, yf), curves) + where + (xi, yi) = (toFCoord p xf, toFCoord p yf) + bearing = fromIntegral $ _hmtxLeftSideBearing metric + advance = fromIntegral $ _hmtxAdvanceWidth metric + curves = + getGlyphIndexCurvesAtPointSizeAndPos font dpi (toFCoord p maximumSize) + (pointSize, glyph) (xi + bearing, yi) + + +getGlyphIndexCurvesAtPointSizeAndPos :: Font -> Dpi -> Int -> (PointSize, Glyph) -> (Int, Int) + -> [VU.Vector (Float, Float)] +getGlyphIndexCurvesAtPointSizeAndPos Font { _fontHeader = Nothing } _ _ _ _ = [] +getGlyphIndexCurvesAtPointSizeAndPos Font { _fontGlyph = Nothing } _ _ _ _ = [] +getGlyphIndexCurvesAtPointSizeAndPos + Font { _fontHeader = Just hdr, _fontGlyph = Just allGlyphs } + dpi maximumSize (pointSize, topGlyph) (baseX, baseY) = glyphReverse <$> glyphExtract topGlyph + where + go index | index >= V.length allGlyphs = [] + | otherwise = glyphExtract $ allGlyphs V.! index + + pixelSize = fromIntegral (pointSize * dpi) / 72 + emSize = fromIntegral $ _fUnitsPerEm hdr + + maxiF = toPixelCoordinate (0 :: Int) maximumSize + baseYF = toPixelCoordinate (0 :: Int) baseY + + glyphReverse = VU.map (\(x,y) -> (x, maxiF - y + baseYF)) + + toPixelCoordinate shift coord = + (fromIntegral (shift + fromIntegral coord) * pixelSize) / emSize + + composeGlyph composition = VU.map updateCoords <$> subCurves + where + subCurves = go . fromIntegral $ _glyphCompositeIndex composition + toFloat v = fromIntegral v / (0x4000 :: Float) + CompositeScaling ai bi ci di ei fi = _glyphCompositionScale composition + + scaler v1 v2 + | fromIntegral (abs (abs ai - abs ci)) <= (33 / 65536 :: Float) = 2 * vf + | otherwise = vf + where + vf = toFloat $ max (abs v1) (abs v2) + + m = scaler ai bi + n = scaler ci di + + am = toFloat ai / m + cm = toFloat ci / m + bn = toFloat ci / n + dn = toFloat di / n + e = toFloat ei + f = toFloat fi + + updateCoords (x,y) = + (m * (am * x + cm *y + e), n * (bn * x + dn * y + f)) + + glyphExtract Glyph { _glyphContent = GlyphEmpty } = [] + glyphExtract Glyph { _glyphContent = GlyphComposite compositions _ } = + concatMap composeGlyph $ V.toList compositions + glyphExtract Glyph { _glyphContent = GlyphSimple countour } = + [ VU.map (\(x, y) -> (toPixelCoordinate baseX x, toPixelCoordinate (0 :: Int) y)) c + | c <- extractFlatOutline countour] + diff --git a/src/Graphics/Text/TrueType/Bytecode.hs b/src/Graphics/Text/TrueType/Bytecode.hs --- a/src/Graphics/Text/TrueType/Bytecode.hs +++ b/src/Graphics/Text/TrueType/Bytecode.hs @@ -1,445 +1,445 @@ -{-# LANGUAGE CPP #-} -module Graphics.Text.TrueType.Bytecode where - -import Prelude hiding ( EQ, GT, LT ) -import Control.Applicative( (<$>) ) -{-import Control.Monad.State.Strict( modify )-} -import Data.Bits( (.&.), testBit ) -import Data.Binary.Get( Get, getWord8, getWord16be ) -import Data.Monoid( mempty ) -import Data.Int( Int32 ) -import qualified Data.Map as M -import Data.Word( Word8, Word16 ) -import qualified Data.Vector.Unboxed as VU - -import Graphics.Text.TrueType.Types - -type InstructionFlag = Bool - -data Instruction - -- | Pop one argument from the stack - = AA - | ABS - | ADD - | ALIGNPTS - | ALIGNRP - | AND - | CALL - | CEILING - | CINDEX - | CLEAR - | DEBUG - | DELTAC1 - | DELTAC2 - | DELTAC3 - | DELTAP1 - | DELTAP2 - | DELTAP3 - | DEPTH - | DIV - | DUP - | EIF - | ELSE - | ENDF - | EQ - | EVEN - | FDEF - | FLIPOFF - | FLIPON - | FLIPPT - | FLIPRGOFF - | FLIPRGON - | FLOOR - | GC PositionSource - | GETINFO - -- | Get Freedom vector - | GFV - | GPV - | GT - | GTEQ - | IDEF - | IF - | INSTCTRL - | IP - | ISECT - | IUP Direction - | JMPR - | JROF - | JROT - | LOOPCALL - | LT - | LTEQ - | MAX - | MD PositionSource - | MDAP Rounding - | MDRP PointReset DistanceKeeping Rounding Word8 - | MIAP Rounding - | MIN - | MINDEX - | MIRP PointReset DistanceKeeping Rounding Word8 - | MPPEM - | MPS - | MSIRP PointReset - | MUL - | NEG - | NEQ - | NOT - | NPUSHB (VU.Vector Word8) - | NPUSHW (VU.Vector Word16) - | NROUND Word8 - | ODD - | OR - | POP - | PUSHB (VU.Vector Word8) - | PUSHW (VU.Vector Word16) - | RCVT - | RDTG - | ROFF - | ROLL - | ROUND Word8 - | RS - | RTDG - | RTG - | RTHG - | RUTG - | S45ROUND - | SANGW - | SCANCTRL - | SCANTYPE - | SCFS - | SCVTCI - | SDB - | SDPVTL Parallelism - | SDS - | SFVFS - | SFVTCA Direction - | SFVTL Parallelism - | SFVTPV - | SHC CountourRef - | SHP CountourRef - | SHPIX - | SHZ CountourRef - | SLOOP - | SMD - | SPVFS - | SPVTCA Direction - | SPVTL Parallelism - | SROUND - | SRP0 - | SRP1 - | SRP2 - | SSW - | SSWCI - | SUB - | SVTCA Direction - | SWAP - | SZP0 - | SZP1 - | SZP2 - | SZPS - | UTP - | WCVTF - | WCVTP - | WS - deriving (Eq, Show) - -data CountourRef - = UseRP2InZP1 - | UseRP1InZP0 - deriving (Eq, Show) - -data Parallelism - = VectorParallel - | VectorPerpendicular - deriving (Eq, Show) - -data PositionSource - = PositionCurrent - | PositionOriginal - deriving (Eq, Show) - -data Direction - = DirectionX - | DirectionY - deriving (Eq, Show) - -data Rounding - = RoundingNone - | Rounding - deriving (Eq, Show) - -data PointReset - = ResetNot - | ResetRP0 - deriving (Eq, Show) - -data DistanceKeeping - = DistanceFree - | DistanceGreaterThanMin - deriving (Eq, Show) - -data ByteCodeProgram - = If [ByteCodeProgram] - | IfElse [ByteCodeProgram] [ByteCodeProgram] - | Function [ByteCodeProgram] - | Sequence [Instruction] - deriving (Eq, Show) - -instructionToProgram :: [Instruction]-> [ByteCodeProgram] -instructionToProgram = firstOfThird . go [] - where - firstOfThird (f, _, _) = f - - go acc [] = (reverse acc, [], []) - go acc (IF : rest) = - case go [] rest of - (ifBranch, [], final) -> go (If ifBranch : acc) final - (ifBranch, elseBranch, final) -> - go (IfElse ifBranch elseBranch : acc) final - go acc (EIF : rest) = (reverse acc, [], rest) - go acc (ELSE : rest) = (acc, elseBranch, final) - where (elseBranch, _, final) = go [] rest - go acc (FDEF : rest) = go (Function def: acc) final - where (def, _, final) = go [] rest - go acc (ENDF : rest) = (reverse acc, [], rest) - go acc (x : xs) = go (Sequence [x] : acc) xs - - -inRange :: Ord a => a -> (a, a) -> Bool -inRange v (lo, hi) = lo <= v && v <= hi - -getInstr :: Get Instruction -getInstr = getWord8 >>= go - where - mirpParse x constructor = constructor reset distance rounding distanceType - where - reset | x `testBit` 4 = ResetRP0 - | otherwise = ResetNot - - distance | x `testBit` 3 = DistanceGreaterThanMin - | otherwise = DistanceFree - - rounding | x `testBit` 2 = Rounding - | otherwise = RoundingNone - - distanceType = x .&. 0x3 - - go w = case w of - 0x7F -> return AA - 0x64 -> return ABS - 0x60 -> return ADD - 0x27 -> return ALIGNPTS - 0x3C -> return ALIGNRP - 0x5A -> return AND - 0x2B -> return CALL - 0x67 -> return CEILING - 0x25 -> return CINDEX - 0x22 -> return CLEAR - 0x4F -> return DEBUG - 0x73 -> return DELTAC1 - 0x74 -> return DELTAC2 - 0x75 -> return DELTAC3 - 0x5D -> return DELTAP1 - 0x71 -> return DELTAP2 - 0x72 -> return DELTAP3 - 0x24 -> return DEPTH - 0x62 -> return DIV - 0x20 -> return DUP - 0x59 -> return EIF - 0x1B -> return ELSE - 0x2D -> return ENDF - 0x54 -> return EQ - 0x57 -> return EVEN - 0x2C -> return FDEF - 0x4E -> return FLIPOFF - 0x4D -> return FLIPON - 0x80 -> return FLIPPT - 0x82 -> return FLIPRGOFF - 0x81 -> return FLIPRGON - 0x66 -> return FLOOR - 0x46 -> return $ GC PositionCurrent - 0x47 -> return $ GC PositionOriginal - 0x88 -> return GETINFO - 0x0D -> return GFV - 0x0C -> return GPV - 0x52 -> return GT - 0x53 -> return GTEQ - 0x89 -> return IDEF - 0x58 -> return IF - 0x8E -> return INSTCTRL - 0x39 -> return IP - 0x0F -> return ISECT - 0x30 -> return $ IUP DirectionY - 0x31 -> return $ IUP DirectionX - 0x1C -> return JMPR - 0x79 -> return JROF - 0x78 -> return JROT - 0x2A -> return LOOPCALL - 0x50 -> return LT - 0x51 -> return LTEQ - 0x8B -> return MAX - 0x49 -> return $ MD PositionCurrent - 0x4A -> return $ MD PositionOriginal - 0x2E -> return $ MDAP RoundingNone - 0x2F -> return $ MDAP Rounding - x | x `inRange` (0xC0, 0xDF) -> return $ mirpParse x MDRP - 0x3E -> return $ MIAP RoundingNone - 0x3F -> return $ MIAP Rounding - 0x8C -> return MIN - 0x26 -> return MINDEX - x | x `inRange` (0xE0, 0xFF) -> return $ mirpParse x MIRP - 0x4B -> return MPPEM - 0x4C -> return MPS - 0x3A -> return $ MSIRP ResetNot - 0x3B -> return $ MSIRP ResetRP0 - 0x63 -> return MUL - 0x65 -> return NEG - 0x55 -> return NEQ - 0x5C -> return NOT - 0x40 -> do - count <- fromIntegral <$> getWord8 - NPUSHB <$> VU.replicateM count getWord8 - - 0x41 -> do - count <- fromIntegral <$> getWord8 - NPUSHW <$> VU.replicateM count getWord16be - x | x `inRange` (0x6C, 0x6F) -> - return . NROUND $ x .&. 3 - 0x56 -> return ODD - 0x5B -> return OR - 0x21 -> return POP - x | x `inRange` (0xB0, 0xB7) -> do - let count = fromIntegral $ (x .&. 0x7) + 1 - PUSHB <$> VU.replicateM count getWord8 - x | x `inRange` (0xB8, 0xBF) -> do - let count = fromIntegral $ (x .&. 0x7) + 1 - PUSHW <$> VU.replicateM count getWord16be - 0x45 -> return RCVT - 0x7D -> return RDTG - 0x7A -> return ROFF - 0x8A -> return ROLL - x | x `inRange` (0x68, 0x6B) -> - return $ ROUND (x .&. 0x3) - 0x43 -> return RS - 0x3D -> return RTDG - 0x18 -> return RTG - 0x19 -> return RTHG - 0x7C -> return RUTG - 0x77 -> return S45ROUND - 0x7E -> return SANGW - 0x85 -> return SCANCTRL - 0x8D -> return SCANTYPE - 0x48 -> return SCFS - 0x1D -> return SCVTCI - 0x5E -> return SDB - 0x86 -> return $ SDPVTL VectorParallel - 0x87 -> return $ SDPVTL VectorPerpendicular - 0x5F -> return SDS - 0x0B -> return SFVFS - 0x04 -> return $ SFVTCA DirectionY - 0x05 -> return $ SFVTCA DirectionX - 0x08 -> return $ SFVTL VectorParallel - 0x09 -> return $ SFVTL VectorPerpendicular - 0x0E -> return SFVTPV - 0x34 -> return $ SHC UseRP2InZP1 - 0x35 -> return $ SHC UseRP1InZP0 - 0x32 -> return $ SHP UseRP2InZP1 - 0x33 -> return $ SHP UseRP1InZP0 - 0x38 -> return SHPIX - 0x36 -> return $ SHZ UseRP2InZP1 - 0x37 -> return $ SHZ UseRP1InZP0 - 0x17 -> return SLOOP - 0x1A -> return SMD - 0x0A -> return SPVFS - 0x02 -> return $ SPVTCA DirectionY - 0x03 -> return $ SPVTCA DirectionX - 0x06 -> return $ SPVTL VectorParallel - 0x07 -> return $ SPVTL VectorPerpendicular - 0x76 -> return SROUND - 0x10 -> return SRP0 - 0x11 -> return SRP1 - 0x12 -> return SRP2 - 0x1F -> return SSW - 0x1E -> return SSWCI - 0x61 -> return SUB - 0x00 -> return $ SVTCA DirectionY - 0x01 -> return $ SVTCA DirectionX - 0x23 -> return SWAP - 0x13 -> return SZP0 - 0x14 -> return SZP1 - 0x15 -> return SZP2 - 0x16 -> return SZPS - 0x29 -> return UTP - 0x70 -> return WCVTF - 0x44 -> return WCVTP - 0x42 -> return WS - _ -> fail "instruction reader coverage pleaser" - -type Point = (F26Dot6, F26Dot6) - -data GraphicalState = GraphicalState - { _stAutoFlip :: !Bool - , _stCutIn :: {-# UNPACK #-} !F26Dot6 - , _stDeltaBase :: {-# UNPACK #-} !Int32 - , _stDeltaShift :: {-# UNPACK #-} !Int32 - , _stDualProjection :: !(Maybe Point) - , _stFreedomVector :: !Point - , _stInstructionControl :: !Bool - , _stLoop :: {-# UNPACK #-} !Int32 - , _stMinDistance :: {-# UNPACK #-} !F26Dot6 - , _stProjectionVector :: !Point - , _stRoundState :: {-# UNPACK #-} !Int32 - , _stRp0 :: {-# UNPACK #-} !Int32 - , _stRp1 :: {-# UNPACK #-} !Int32 - , _stRp2 :: {-# UNPACK #-} !Int32 - , _stScanControl :: !Bool - , _stSingleWidthCutIn :: {-# UNPACK #-} !F26Dot6 - , _stSingleWidthValue :: {-# UNPACK #-} !F26Dot6 - , _stZp0 :: {-# UNPACK #-} !Int32 - , _stZp1 :: {-# UNPACK #-} !Int32 - , _stZp2 :: {-# UNPACK #-} !Int32 - , _stFunctions :: !(M.Map Int32 [ByteCodeProgram]) - } - deriving (Eq, Show) - -initialState :: GraphicalState -initialState = GraphicalState - { _stAutoFlip = True - , _stCutIn = 17 / 16 - , _stDeltaBase = 9 - , _stDeltaShift = 3 - , _stDualProjection = Nothing - , _stFreedomVector = (1, 0) - , _stInstructionControl = False - , _stLoop = 1 - , _stMinDistance = 1 - , _stProjectionVector = (1, 0) - , _stRoundState = 1 - , _stRp0 = 0 - , _stRp1 = 0 - , _stRp2 = 0 - , _stScanControl = False - , _stSingleWidthCutIn = 0 - , _stSingleWidthValue = 0 - , _stZp0 = 1 - , _stZp1 = 1 - , _stZp2 = 1 - , _stFunctions = mempty - } - -#if 0 - -evaluate :: [ByteCodeProgram] -> () -evaluate instrs = - where - byteExec [] stack = stack - byteExec (If _ : instr) (0:stack) = byteExec instr stack - byteExec (If thenBody : instr) (_:stack) = byteExec (thenBody ++ instr) stack - byteExec (IfElse _ elseBody) (0:stack) = byteExec (elseBody ++ instr) stack - byteExec (IfElse thenBody _) (_:stack) = byteExec (thenBody ++ instr) stack - byteExec (Function functionBody : instr) (id:stack) = - modify (\s -> s { _stFunctions = M.add id functionBody }) >> byteExec instr stack - byteExec (Sequence intructions : rest) stack = go instructions stack >>= byteExec rest - -#endif - +{-# LANGUAGE CPP #-} +module Graphics.Text.TrueType.Bytecode where + +import Prelude hiding ( EQ, GT, LT ) +import Control.Applicative( (<$>) ) +{-import Control.Monad.State.Strict( modify )-} +import Data.Bits( (.&.), testBit ) +import Data.Binary.Get( Get, getWord8, getWord16be ) +import Data.Monoid( mempty ) +import Data.Int( Int32 ) +import qualified Data.Map as M +import Data.Word( Word8, Word16 ) +import qualified Data.Vector.Unboxed as VU + +import Graphics.Text.TrueType.Types + +type InstructionFlag = Bool + +data Instruction + -- | Pop one argument from the stack + = AA + | ABS + | ADD + | ALIGNPTS + | ALIGNRP + | AND + | CALL + | CEILING + | CINDEX + | CLEAR + | DEBUG + | DELTAC1 + | DELTAC2 + | DELTAC3 + | DELTAP1 + | DELTAP2 + | DELTAP3 + | DEPTH + | DIV + | DUP + | EIF + | ELSE + | ENDF + | EQ + | EVEN + | FDEF + | FLIPOFF + | FLIPON + | FLIPPT + | FLIPRGOFF + | FLIPRGON + | FLOOR + | GC PositionSource + | GETINFO + -- | Get Freedom vector + | GFV + | GPV + | GT + | GTEQ + | IDEF + | IF + | INSTCTRL + | IP + | ISECT + | IUP Direction + | JMPR + | JROF + | JROT + | LOOPCALL + | LT + | LTEQ + | MAX + | MD PositionSource + | MDAP Rounding + | MDRP PointReset DistanceKeeping Rounding Word8 + | MIAP Rounding + | MIN + | MINDEX + | MIRP PointReset DistanceKeeping Rounding Word8 + | MPPEM + | MPS + | MSIRP PointReset + | MUL + | NEG + | NEQ + | NOT + | NPUSHB (VU.Vector Word8) + | NPUSHW (VU.Vector Word16) + | NROUND Word8 + | ODD + | OR + | POP + | PUSHB (VU.Vector Word8) + | PUSHW (VU.Vector Word16) + | RCVT + | RDTG + | ROFF + | ROLL + | ROUND Word8 + | RS + | RTDG + | RTG + | RTHG + | RUTG + | S45ROUND + | SANGW + | SCANCTRL + | SCANTYPE + | SCFS + | SCVTCI + | SDB + | SDPVTL Parallelism + | SDS + | SFVFS + | SFVTCA Direction + | SFVTL Parallelism + | SFVTPV + | SHC CountourRef + | SHP CountourRef + | SHPIX + | SHZ CountourRef + | SLOOP + | SMD + | SPVFS + | SPVTCA Direction + | SPVTL Parallelism + | SROUND + | SRP0 + | SRP1 + | SRP2 + | SSW + | SSWCI + | SUB + | SVTCA Direction + | SWAP + | SZP0 + | SZP1 + | SZP2 + | SZPS + | UTP + | WCVTF + | WCVTP + | WS + deriving (Eq, Show) + +data CountourRef + = UseRP2InZP1 + | UseRP1InZP0 + deriving (Eq, Show) + +data Parallelism + = VectorParallel + | VectorPerpendicular + deriving (Eq, Show) + +data PositionSource + = PositionCurrent + | PositionOriginal + deriving (Eq, Show) + +data Direction + = DirectionX + | DirectionY + deriving (Eq, Show) + +data Rounding + = RoundingNone + | Rounding + deriving (Eq, Show) + +data PointReset + = ResetNot + | ResetRP0 + deriving (Eq, Show) + +data DistanceKeeping + = DistanceFree + | DistanceGreaterThanMin + deriving (Eq, Show) + +data ByteCodeProgram + = If [ByteCodeProgram] + | IfElse [ByteCodeProgram] [ByteCodeProgram] + | Function [ByteCodeProgram] + | Sequence [Instruction] + deriving (Eq, Show) + +instructionToProgram :: [Instruction]-> [ByteCodeProgram] +instructionToProgram = firstOfThird . go [] + where + firstOfThird (f, _, _) = f + + go acc [] = (reverse acc, [], []) + go acc (IF : rest) = + case go [] rest of + (ifBranch, [], final) -> go (If ifBranch : acc) final + (ifBranch, elseBranch, final) -> + go (IfElse ifBranch elseBranch : acc) final + go acc (EIF : rest) = (reverse acc, [], rest) + go acc (ELSE : rest) = (acc, elseBranch, final) + where (elseBranch, _, final) = go [] rest + go acc (FDEF : rest) = go (Function def: acc) final + where (def, _, final) = go [] rest + go acc (ENDF : rest) = (reverse acc, [], rest) + go acc (x : xs) = go (Sequence [x] : acc) xs + + +inRange :: Ord a => a -> (a, a) -> Bool +inRange v (lo, hi) = lo <= v && v <= hi + +getInstr :: Get Instruction +getInstr = getWord8 >>= go + where + mirpParse x constructor = constructor reset distance rounding distanceType + where + reset | x `testBit` 4 = ResetRP0 + | otherwise = ResetNot + + distance | x `testBit` 3 = DistanceGreaterThanMin + | otherwise = DistanceFree + + rounding | x `testBit` 2 = Rounding + | otherwise = RoundingNone + + distanceType = x .&. 0x3 + + go w = case w of + 0x7F -> return AA + 0x64 -> return ABS + 0x60 -> return ADD + 0x27 -> return ALIGNPTS + 0x3C -> return ALIGNRP + 0x5A -> return AND + 0x2B -> return CALL + 0x67 -> return CEILING + 0x25 -> return CINDEX + 0x22 -> return CLEAR + 0x4F -> return DEBUG + 0x73 -> return DELTAC1 + 0x74 -> return DELTAC2 + 0x75 -> return DELTAC3 + 0x5D -> return DELTAP1 + 0x71 -> return DELTAP2 + 0x72 -> return DELTAP3 + 0x24 -> return DEPTH + 0x62 -> return DIV + 0x20 -> return DUP + 0x59 -> return EIF + 0x1B -> return ELSE + 0x2D -> return ENDF + 0x54 -> return EQ + 0x57 -> return EVEN + 0x2C -> return FDEF + 0x4E -> return FLIPOFF + 0x4D -> return FLIPON + 0x80 -> return FLIPPT + 0x82 -> return FLIPRGOFF + 0x81 -> return FLIPRGON + 0x66 -> return FLOOR + 0x46 -> return $ GC PositionCurrent + 0x47 -> return $ GC PositionOriginal + 0x88 -> return GETINFO + 0x0D -> return GFV + 0x0C -> return GPV + 0x52 -> return GT + 0x53 -> return GTEQ + 0x89 -> return IDEF + 0x58 -> return IF + 0x8E -> return INSTCTRL + 0x39 -> return IP + 0x0F -> return ISECT + 0x30 -> return $ IUP DirectionY + 0x31 -> return $ IUP DirectionX + 0x1C -> return JMPR + 0x79 -> return JROF + 0x78 -> return JROT + 0x2A -> return LOOPCALL + 0x50 -> return LT + 0x51 -> return LTEQ + 0x8B -> return MAX + 0x49 -> return $ MD PositionCurrent + 0x4A -> return $ MD PositionOriginal + 0x2E -> return $ MDAP RoundingNone + 0x2F -> return $ MDAP Rounding + x | x `inRange` (0xC0, 0xDF) -> return $ mirpParse x MDRP + 0x3E -> return $ MIAP RoundingNone + 0x3F -> return $ MIAP Rounding + 0x8C -> return MIN + 0x26 -> return MINDEX + x | x `inRange` (0xE0, 0xFF) -> return $ mirpParse x MIRP + 0x4B -> return MPPEM + 0x4C -> return MPS + 0x3A -> return $ MSIRP ResetNot + 0x3B -> return $ MSIRP ResetRP0 + 0x63 -> return MUL + 0x65 -> return NEG + 0x55 -> return NEQ + 0x5C -> return NOT + 0x40 -> do + count <- fromIntegral <$> getWord8 + NPUSHB <$> VU.replicateM count getWord8 + + 0x41 -> do + count <- fromIntegral <$> getWord8 + NPUSHW <$> VU.replicateM count getWord16be + x | x `inRange` (0x6C, 0x6F) -> + return . NROUND $ x .&. 3 + 0x56 -> return ODD + 0x5B -> return OR + 0x21 -> return POP + x | x `inRange` (0xB0, 0xB7) -> do + let count = fromIntegral $ (x .&. 0x7) + 1 + PUSHB <$> VU.replicateM count getWord8 + x | x `inRange` (0xB8, 0xBF) -> do + let count = fromIntegral $ (x .&. 0x7) + 1 + PUSHW <$> VU.replicateM count getWord16be + 0x45 -> return RCVT + 0x7D -> return RDTG + 0x7A -> return ROFF + 0x8A -> return ROLL + x | x `inRange` (0x68, 0x6B) -> + return $ ROUND (x .&. 0x3) + 0x43 -> return RS + 0x3D -> return RTDG + 0x18 -> return RTG + 0x19 -> return RTHG + 0x7C -> return RUTG + 0x77 -> return S45ROUND + 0x7E -> return SANGW + 0x85 -> return SCANCTRL + 0x8D -> return SCANTYPE + 0x48 -> return SCFS + 0x1D -> return SCVTCI + 0x5E -> return SDB + 0x86 -> return $ SDPVTL VectorParallel + 0x87 -> return $ SDPVTL VectorPerpendicular + 0x5F -> return SDS + 0x0B -> return SFVFS + 0x04 -> return $ SFVTCA DirectionY + 0x05 -> return $ SFVTCA DirectionX + 0x08 -> return $ SFVTL VectorParallel + 0x09 -> return $ SFVTL VectorPerpendicular + 0x0E -> return SFVTPV + 0x34 -> return $ SHC UseRP2InZP1 + 0x35 -> return $ SHC UseRP1InZP0 + 0x32 -> return $ SHP UseRP2InZP1 + 0x33 -> return $ SHP UseRP1InZP0 + 0x38 -> return SHPIX + 0x36 -> return $ SHZ UseRP2InZP1 + 0x37 -> return $ SHZ UseRP1InZP0 + 0x17 -> return SLOOP + 0x1A -> return SMD + 0x0A -> return SPVFS + 0x02 -> return $ SPVTCA DirectionY + 0x03 -> return $ SPVTCA DirectionX + 0x06 -> return $ SPVTL VectorParallel + 0x07 -> return $ SPVTL VectorPerpendicular + 0x76 -> return SROUND + 0x10 -> return SRP0 + 0x11 -> return SRP1 + 0x12 -> return SRP2 + 0x1F -> return SSW + 0x1E -> return SSWCI + 0x61 -> return SUB + 0x00 -> return $ SVTCA DirectionY + 0x01 -> return $ SVTCA DirectionX + 0x23 -> return SWAP + 0x13 -> return SZP0 + 0x14 -> return SZP1 + 0x15 -> return SZP2 + 0x16 -> return SZPS + 0x29 -> return UTP + 0x70 -> return WCVTF + 0x44 -> return WCVTP + 0x42 -> return WS + _ -> fail "instruction reader coverage pleaser" + +type Point = (F26Dot6, F26Dot6) + +data GraphicalState = GraphicalState + { _stAutoFlip :: !Bool + , _stCutIn :: {-# UNPACK #-} !F26Dot6 + , _stDeltaBase :: {-# UNPACK #-} !Int32 + , _stDeltaShift :: {-# UNPACK #-} !Int32 + , _stDualProjection :: !(Maybe Point) + , _stFreedomVector :: !Point + , _stInstructionControl :: !Bool + , _stLoop :: {-# UNPACK #-} !Int32 + , _stMinDistance :: {-# UNPACK #-} !F26Dot6 + , _stProjectionVector :: !Point + , _stRoundState :: {-# UNPACK #-} !Int32 + , _stRp0 :: {-# UNPACK #-} !Int32 + , _stRp1 :: {-# UNPACK #-} !Int32 + , _stRp2 :: {-# UNPACK #-} !Int32 + , _stScanControl :: !Bool + , _stSingleWidthCutIn :: {-# UNPACK #-} !F26Dot6 + , _stSingleWidthValue :: {-# UNPACK #-} !F26Dot6 + , _stZp0 :: {-# UNPACK #-} !Int32 + , _stZp1 :: {-# UNPACK #-} !Int32 + , _stZp2 :: {-# UNPACK #-} !Int32 + , _stFunctions :: !(M.Map Int32 [ByteCodeProgram]) + } + deriving (Eq, Show) + +initialState :: GraphicalState +initialState = GraphicalState + { _stAutoFlip = True + , _stCutIn = 17 / 16 + , _stDeltaBase = 9 + , _stDeltaShift = 3 + , _stDualProjection = Nothing + , _stFreedomVector = (1, 0) + , _stInstructionControl = False + , _stLoop = 1 + , _stMinDistance = 1 + , _stProjectionVector = (1, 0) + , _stRoundState = 1 + , _stRp0 = 0 + , _stRp1 = 0 + , _stRp2 = 0 + , _stScanControl = False + , _stSingleWidthCutIn = 0 + , _stSingleWidthValue = 0 + , _stZp0 = 1 + , _stZp1 = 1 + , _stZp2 = 1 + , _stFunctions = mempty + } + +#if 0 + +evaluate :: [ByteCodeProgram] -> () +evaluate instrs = + where + byteExec [] stack = stack + byteExec (If _ : instr) (0:stack) = byteExec instr stack + byteExec (If thenBody : instr) (_:stack) = byteExec (thenBody ++ instr) stack + byteExec (IfElse _ elseBody) (0:stack) = byteExec (elseBody ++ instr) stack + byteExec (IfElse thenBody _) (_:stack) = byteExec (thenBody ++ instr) stack + byteExec (Function functionBody : instr) (id:stack) = + modify (\s -> s { _stFunctions = M.add id functionBody }) >> byteExec instr stack + byteExec (Sequence intructions : rest) stack = go instructions stack >>= byteExec rest + +#endif + diff --git a/src/Graphics/Text/TrueType/CharacterMap.hs b/src/Graphics/Text/TrueType/CharacterMap.hs --- a/src/Graphics/Text/TrueType/CharacterMap.hs +++ b/src/Graphics/Text/TrueType/CharacterMap.hs @@ -1,375 +1,381 @@ -{-# LANGUAGE RankNTypes #-} -module Graphics.Text.TrueType.CharacterMap - ( TtfEncoding( .. ) - , CharacterMaps - , LangId - , findCharGlyph - ) where - -import Control.Monad( replicateM ) -import Control.Applicative( (<$>), (<*>) ) -import Control.Monad( when, foldM ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( Get - , skip - , bytesRead - , getWord8 - , getWord16be - , getWord32be ) - -import Data.Binary.Put( putWord16be - , putWord32be ) -import Data.Int( Int16 ) -import Data.List( find, sortBy ) -import qualified Data.Map.Strict as M -import Data.Maybe( fromMaybe ) -import Data.Word( Word8, Word16, Word32 ) -import Data.Ord( comparing ) - -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as VU - -import Graphics.Text.TrueType.LanguageIds - --------------------------------------------------- ----- TtfEncoding --------------------------------------------------- -data TtfEncoding - = EncodingSymbol - | EncodingUnicode - | EncodingShiftJIS - | EncodingBig5 - | EncodingPRC - | EncodingWansung - | EncodingJohab - deriving (Eq, Show) - -instance Binary TtfEncoding where - put EncodingSymbol = putWord16be 0 - put EncodingUnicode = putWord16be 1 - put EncodingShiftJIS = putWord16be 2 - put EncodingBig5 = putWord16be 3 - put EncodingPRC = putWord16be 4 - put EncodingWansung = putWord16be 5 - put EncodingJohab = putWord16be 6 - - get = do - v <- getWord16be - case v of - 0 -> return EncodingSymbol - 1 -> return EncodingUnicode - 2 -> return EncodingShiftJIS - 3 -> return EncodingBig5 - 4 -> return EncodingPRC - 5 -> return EncodingWansung - 6 -> return EncodingJohab - _ -> fail "Unknown encoding" - -class CharMappeable a where - -- | Given a group a character, return a valid glyph - -- id and the rest of the string. - glyphIdFromTable :: a -> Char -> Int - - -- | Given a table, retrieve the language code - langIdOfCharMap :: a -> LangId - -type LangId = Word16 - --------------------------------------------------- ----- CharacterMaps --------------------------------------------------- -data CharacterMap = CharacterMap - { _charMapPlatformId :: !PlatformId - , _charMapPlatformSpecific :: !Word16 - , _charMap :: !CharacterTable - } - deriving (Eq, Show) - -instance Ord CharacterMap where - compare = comparing _charMap - -newtype CharacterMaps = CharacterMaps [CharacterMap] - deriving (Eq, Show) - -instance Binary CharacterMaps where - put _ = fail "Unimplemented" - get = do - startIndex <- bytesRead - versionNumber <- getWord16be - when (versionNumber /= 0) - (fail "Characte map - invalid version number") - tableCount <- fromIntegral <$> getWord16be - let descFetcher = (,,) <$> get <*> getWord16be <*> getWord32be - third (_, _, t) = t - tableDesc <- - sortBy (comparing third) <$> replicateM tableCount descFetcher - - - let fetcher (allMaps, lst) (platformId, platformSpecific, offset) - | M.member offset allMaps = case M.lookup offset allMaps of - Nothing -> fail "Impossible" - Just table -> - return (allMaps, CharacterMap platformId platformSpecific table : lst) - fetcher (allMaps, lst) (platformId, platformSpecific, offset) = do - currentOffset <- fromIntegral <$> bytesRead - let toSkip = fromIntegral offset - currentOffset + startIndex - when (toSkip > 0) - (skip $ fromIntegral toSkip) - mapData <- get - let charMap = CharacterMap platformId platformSpecific mapData - return (M.insert offset mapData allMaps, charMap : lst) - - (_, tables) <- foldM fetcher (M.empty, []) tableDesc - return . CharacterMaps $ sortBy (comparing _charMap) tables - -data CharMapOffset = CharMapOffset - { _cmoPlatformId :: !Word16 - , _cmoEncodingId :: !TtfEncoding - , _cmoOffset :: !Word32 - } - deriving (Eq, Show) - -instance Binary CharMapOffset where - get = CharMapOffset <$> getWord16be <*> get <*> getWord32be - put (CharMapOffset platform encoding offset) = - putWord16be platform >> put encoding >> putWord32be offset - --------------------------------------------------- ----- CharacterTable --------------------------------------------------- -data CharacterTable - = TableFormat0 !Format0 - | TableFormat2 !Format2 - | TableFormat4 !Format4 - | TableFormat6 !Format6 - | TableFormatUnknown !Word16 - deriving (Eq, Show) - -charTableMap :: (forall table . (CharMappeable table) => table -> a) - -> CharacterTable -> a -charTableMap f = go - where - go (TableFormat0 t) = f t - go (TableFormat2 t) = f t - go (TableFormat4 t) = f t - go (TableFormat6 t) = f t - go (TableFormatUnknown v) = f v - -findCharGlyph :: CharacterMaps -> LangId -> Char -> Int -findCharGlyph (CharacterMaps charMaps) langId character = - fromMaybe 0 $ find (/= 0) - [charTableMap (flip glyphIdFromTable character) m - | allMap <- charMaps - , let m = _charMap allMap - , isLangCompatible m] - where - isLangCompatible v = tableLang == 0 || tableLang == langId - where tableLang = charTableMap langIdOfCharMap v - -instance Ord CharacterTable where - compare (TableFormat0 v1) (TableFormat0 v2) = - (comparing langIdOfCharMap) v1 v2 - compare (TableFormat2 v1) (TableFormat2 v2) = - (comparing langIdOfCharMap) v1 v2 - compare (TableFormat4 v1) (TableFormat4 v2) = - (comparing langIdOfCharMap) v1 v2 - compare (TableFormat6 v1) (TableFormat6 v2) = - (comparing langIdOfCharMap) v1 v2 - compare (TableFormat0 _) _ = LT - compare (TableFormat2 _) _ = LT - compare (TableFormat4 _) _ = LT - compare (TableFormat6 _) _ = LT - compare _ _ = GT - -instance Binary CharacterTable where - put _ = fail "Binary.put CharacterTable - Unimplemented" - get = do - format <- getWord16be - case format of - 0 -> TableFormat0 <$> get - 2 -> TableFormat2 <$> get - 4 -> TableFormat4 <$> get - 6 -> TableFormat6 <$> get - n -> return $ TableFormatUnknown n - -instance CharMappeable Word16 where - glyphIdFromTable _ _ = 0 - langIdOfCharMap _ = 0 - - --------------------------------------------------- ----- Format4 --------------------------------------------------- -data Format4 = Format4 - { _f4Language :: {-# UNPACK #-} !LangId - , _f4Map :: M.Map Word16 Word16 - } - deriving (Eq, Show) - -instance CharMappeable Format4 where - glyphIdFromTable tab v = - fromIntegral . M.findWithDefault 0 wc $ _f4Map tab - where wc = fromIntegral $ fromEnum v - langIdOfCharMap = _f4Language - -instance Binary Format4 where - put _ = error "put Format4 - unimplemented" - get = do - startIndex <- bytesRead - tableLength <- fromIntegral <$> getWord16be - language <- getWord16be - -- 2 * segCount - segCount <- (`div` 2) . fromIntegral <$> getWord16be - -- 2 * (2**FLOOR(log2(segCount))) - _searchRange <- getWord16be - -- log2(searchRange/2) - _entrySelector <- getWord16be - -- (2 * segCount) - searchRange - _rangeShift <- getWord16be - - let fetcher :: Get (VU.Vector Int) - fetcher = - VU.replicateM segCount (fromIntegral <$> getWord16be) - - endCodes <- fetcher - _reservedPad <- getWord16be - startCodes <- fetcher - idDelta <- - VU.replicateM segCount (fromIntegral <$> getWord16be) :: Get (VU.Vector Int16) - idRangeOffset <- fetcher - - tableBeginIndex <- bytesRead - let idDeltaInt = VU.map fromIntegral idDelta - rangeInfo = init . VU.toList $ - VU.zip5 startCodes endCodes idDeltaInt idRangeOffset $ - VU.enumFromN 0 segCount - - indexLeft = fromIntegral $ - (tableLength - (tableBeginIndex - startIndex + 2)) - `div` 2 - - indexTable <- VU.replicateM indexLeft getWord16be - - endIndex <- bytesRead - let toSkip = endIndex - startIndex - tableLength + 2 - if toSkip < 0 then - fail $ "Read to much Format4 table " ++ show toSkip - else - skip $ fromIntegral toSkip - - - return . Format4 language . M.fromList - $ concatMap (prepare segCount indexTable) rangeInfo - where - prepare _ _ (start, end, delta, 0, _) = - [(fromIntegral $ char, fromIntegral $ char + delta) - | char <- [start .. end]] - prepare segCount indexTable - (start, end, delta, rangeOffset, ix) = - -- this is... so convoluted oO - [( fromIntegral char - , fromIntegral (if glyphId == 0 then 0 else glyphId + fromIntegral delta)) - | char <- [start .. end] - , let index = - (rangeOffset `div` 2) + (char - start) + ix - - segCount - , index < VU.length indexTable - , let glyphId = indexTable VU.! index - ] - --------------------------------------------------- ----- Format0 --------------------------------------------------- -data Format0 = Format0 - { _format0Language :: {-# UNPACK #-} !LangId - , _format0Table :: !(VU.Vector Word8) - } - deriving (Eq, Show) - -instance CharMappeable Format0 where - glyphIdFromTable Format0 { _format0Table = table } v - | ic > VU.length table = 0 - | otherwise = fromIntegral $ table VU.! ic - where ic = fromEnum v - - langIdOfCharMap = _format0Language - -instance Binary Format0 where - put _ = fail "Binary.Format0.put - unimplemented" - get = do - tableSize <- getWord16be - when (tableSize /= 262) $ - fail ("table cmap format 0, invalid size: " - ++ show tableSize) - Format0 <$> getWord16be <*> VU.replicateM 256 getWord8 - --------------------------------------------------- ----- Format2 --------------------------------------------------- -data Format2 = Format2 - { _format2Language :: {-# UNPACK #-} !LangId - , _format2SubKeys :: !(VU.Vector Word16) - , _format2SubHeaders :: !(V.Vector Format2SubHeader) - } - deriving (Eq, Show) - -data Format2SubHeader = Format2SubHeader - { _f2SubCode :: {-# UNPACK #-} !Word16 - , _f2EntryCount :: {-# UNPACK #-} !Word16 - , _f2IdDelta :: {-# UNPACK #-} !Int16 - , _f2IdRangeOffset :: {-# UNPACK #-} !Word16 - } - deriving (Eq, Show) - -instance CharMappeable Format2 where - glyphIdFromTable _ _ = 0 - langIdOfCharMap = _format2Language - -instance Binary Format2SubHeader where - put (Format2SubHeader a b c d) = - p16 a >> p16 b >> pi16 c >> p16 d - where - p16 = putWord16be - pi16 = p16 . fromIntegral - - get = Format2SubHeader <$> g16 <*> g16 <*> (fromIntegral <$> g16) <*> g16 - where g16 = getWord16be - - -instance Binary Format2 where - put _ = fail "Format2.put - unimplemented" - get = do - _tableSize <- getWord16be - lang <- getWord16be - subKeys <- VU.map (`div` 8) <$> VU.replicateM 256 getWord16be - let maxSubIndex = VU.maximum subKeys - subHeaders <- V.replicateM (fromIntegral maxSubIndex) get - -- TODO finish the parsing of format 2 - return $ Format2 lang subKeys subHeaders - --------------------------------------------------- ----- Format6 --------------------------------------------------- -data Format6 = Format6 - { _format6Language :: {-# UNPACK #-} !LangId - , _format6FirstCode :: {-# UNPACK #-} !Word16 - , _format6ArrayIndex :: !(VU.Vector Word16) - } - deriving (Eq, Show) - -instance CharMappeable Format6 where - glyphIdFromTable Format6 { _format6ArrayIndex = table } v - | ic < VU.length table = fromIntegral $ table VU.! ic - | otherwise = 0 - where ic = fromEnum v - - langIdOfCharMap = _format6Language - -instance Binary Format6 where - put _ = fail "Format6.put - unimplemented" - get = do - _length <- getWord16be - language <- getWord16be - firstCode <- getWord16be - entryCount <- fromIntegral <$> getWord16be - Format6 language firstCode <$> VU.replicateM entryCount getWord16be +{-# LANGUAGE RankNTypes #-} +module Graphics.Text.TrueType.CharacterMap + ( TtfEncoding( .. ) + , CharacterMaps + , LangId + , findCharGlyph + ) where + +import Control.Applicative( (<$>), (<*>) ) +import Control.DeepSeq( NFData( .. ) ) +import Control.Monad( replicateM, when, foldM ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( Get + , skip + , bytesRead + , getWord8 + , getWord16be + , getWord32be ) + +import Data.Binary.Put( putWord16be + , putWord32be ) +import Data.Int( Int16 ) +import Data.List( find, sortBy ) +import qualified Data.Map.Strict as M +import Data.Maybe( fromMaybe ) +import Data.Word( Word8, Word16, Word32 ) +import Data.Ord( comparing ) + +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU + +import Graphics.Text.TrueType.LanguageIds + +-------------------------------------------------- +---- TtfEncoding +-------------------------------------------------- +data TtfEncoding + = EncodingSymbol + | EncodingUnicode + | EncodingShiftJIS + | EncodingBig5 + | EncodingPRC + | EncodingWansung + | EncodingJohab + deriving (Eq, Show) + +instance Binary TtfEncoding where + put EncodingSymbol = putWord16be 0 + put EncodingUnicode = putWord16be 1 + put EncodingShiftJIS = putWord16be 2 + put EncodingBig5 = putWord16be 3 + put EncodingPRC = putWord16be 4 + put EncodingWansung = putWord16be 5 + put EncodingJohab = putWord16be 6 + + get = do + v <- getWord16be + case v of + 0 -> return EncodingSymbol + 1 -> return EncodingUnicode + 2 -> return EncodingShiftJIS + 3 -> return EncodingBig5 + 4 -> return EncodingPRC + 5 -> return EncodingWansung + 6 -> return EncodingJohab + _ -> fail "Unknown encoding" + +class CharMappeable a where + -- | Given a group a character, return a valid glyph + -- id and the rest of the string. + glyphIdFromTable :: a -> Char -> Int + + -- | Given a table, retrieve the language code + langIdOfCharMap :: a -> LangId + +type LangId = Word16 + +-------------------------------------------------- +---- CharacterMaps +-------------------------------------------------- +data CharacterMap = CharacterMap + { _charMapPlatformId :: !PlatformId + , _charMapPlatformSpecific :: !Word16 + , _charMap :: !CharacterTable + } + deriving (Eq, Show) + +instance NFData CharacterMap where + rnf (CharacterMap {}) = () + +instance Ord CharacterMap where + compare = comparing _charMap + +newtype CharacterMaps = CharacterMaps [CharacterMap] + deriving (Eq, Show) + +instance NFData CharacterMaps where + rnf (CharacterMaps maps) = rnf maps `seq` () + +instance Binary CharacterMaps where + put _ = fail "Unimplemented" + get = do + startIndex <- bytesRead + versionNumber <- getWord16be + when (versionNumber /= 0) + (fail "Characte map - invalid version number") + tableCount <- fromIntegral <$> getWord16be + let descFetcher = (,,) <$> get <*> getWord16be <*> getWord32be + third (_, _, t) = t + tableDesc <- + sortBy (comparing third) <$> replicateM tableCount descFetcher + + + let fetcher (allMaps, lst) (platformId, platformSpecific, offset) + | M.member offset allMaps = case M.lookup offset allMaps of + Nothing -> fail "Impossible" + Just table -> + return (allMaps, CharacterMap platformId platformSpecific table : lst) + fetcher (allMaps, lst) (platformId, platformSpecific, offset) = do + currentOffset <- fromIntegral <$> bytesRead + let toSkip = fromIntegral offset - currentOffset + startIndex + when (toSkip > 0) + (skip $ fromIntegral toSkip) + mapData <- get + let charMap = CharacterMap platformId platformSpecific mapData + return (M.insert offset mapData allMaps, charMap : lst) + + (_, tables) <- foldM fetcher (M.empty, []) tableDesc + return . CharacterMaps $ sortBy (comparing _charMap) tables + +data CharMapOffset = CharMapOffset + { _cmoPlatformId :: !Word16 + , _cmoEncodingId :: !TtfEncoding + , _cmoOffset :: !Word32 + } + deriving (Eq, Show) + +instance Binary CharMapOffset where + get = CharMapOffset <$> getWord16be <*> get <*> getWord32be + put (CharMapOffset platform encoding offset) = + putWord16be platform >> put encoding >> putWord32be offset + +-------------------------------------------------- +---- CharacterTable +-------------------------------------------------- +data CharacterTable + = TableFormat0 !Format0 + | TableFormat2 !Format2 + | TableFormat4 !Format4 + | TableFormat6 !Format6 + | TableFormatUnknown !Word16 + deriving (Eq, Show) + +charTableMap :: (forall table . (CharMappeable table) => table -> a) + -> CharacterTable -> a +charTableMap f = go + where + go (TableFormat0 t) = f t + go (TableFormat2 t) = f t + go (TableFormat4 t) = f t + go (TableFormat6 t) = f t + go (TableFormatUnknown v) = f v + +findCharGlyph :: CharacterMaps -> LangId -> Char -> Int +findCharGlyph (CharacterMaps charMaps) langId character = + fromMaybe 0 $ find (/= 0) + [charTableMap (flip glyphIdFromTable character) m + | allMap <- charMaps + , let m = _charMap allMap + , isLangCompatible m] + where + isLangCompatible v = tableLang == 0 || tableLang == langId + where tableLang = charTableMap langIdOfCharMap v + +instance Ord CharacterTable where + compare (TableFormat0 v1) (TableFormat0 v2) = + (comparing langIdOfCharMap) v1 v2 + compare (TableFormat2 v1) (TableFormat2 v2) = + (comparing langIdOfCharMap) v1 v2 + compare (TableFormat4 v1) (TableFormat4 v2) = + (comparing langIdOfCharMap) v1 v2 + compare (TableFormat6 v1) (TableFormat6 v2) = + (comparing langIdOfCharMap) v1 v2 + compare (TableFormat0 _) _ = LT + compare (TableFormat2 _) _ = LT + compare (TableFormat4 _) _ = LT + compare (TableFormat6 _) _ = LT + compare _ _ = GT + +instance Binary CharacterTable where + put _ = fail "Binary.put CharacterTable - Unimplemented" + get = do + format <- getWord16be + case format of + 0 -> TableFormat0 <$> get + 2 -> TableFormat2 <$> get + 4 -> TableFormat4 <$> get + 6 -> TableFormat6 <$> get + n -> return $ TableFormatUnknown n + +instance CharMappeable Word16 where + glyphIdFromTable _ _ = 0 + langIdOfCharMap _ = 0 + + +-------------------------------------------------- +---- Format4 +-------------------------------------------------- +data Format4 = Format4 + { _f4Language :: {-# UNPACK #-} !LangId + , _f4Map :: M.Map Word16 Word16 + } + deriving (Eq, Show) + +instance CharMappeable Format4 where + glyphIdFromTable tab v = + fromIntegral . M.findWithDefault 0 wc $ _f4Map tab + where wc = fromIntegral $ fromEnum v + langIdOfCharMap = _f4Language + +instance Binary Format4 where + put _ = error "put Format4 - unimplemented" + get = do + startIndex <- bytesRead + tableLength <- fromIntegral <$> getWord16be + language <- getWord16be + -- 2 * segCount + segCount <- (`div` 2) . fromIntegral <$> getWord16be + -- 2 * (2**FLOOR(log2(segCount))) + _searchRange <- getWord16be + -- log2(searchRange/2) + _entrySelector <- getWord16be + -- (2 * segCount) - searchRange + _rangeShift <- getWord16be + + let fetcher :: Get (VU.Vector Int) + fetcher = + VU.replicateM segCount (fromIntegral <$> getWord16be) + + endCodes <- fetcher + _reservedPad <- getWord16be + startCodes <- fetcher + idDelta <- + VU.replicateM segCount (fromIntegral <$> getWord16be) :: Get (VU.Vector Int16) + idRangeOffset <- fetcher + + tableBeginIndex <- bytesRead + let idDeltaInt = VU.map fromIntegral idDelta + rangeInfo = init . VU.toList $ + VU.zip5 startCodes endCodes idDeltaInt idRangeOffset $ + VU.enumFromN 0 segCount + + indexLeft = fromIntegral $ + (tableLength - (tableBeginIndex - startIndex + 2)) + `div` 2 + + indexTable <- VU.replicateM indexLeft getWord16be + + endIndex <- bytesRead + let toSkip = endIndex - startIndex - tableLength + 2 + if toSkip < 0 then + fail $ "Read to much Format4 table " ++ show toSkip + else + skip $ fromIntegral toSkip + + + return . Format4 language . M.fromList + $ concatMap (prepare segCount indexTable) rangeInfo + where + prepare _ _ (start, end, delta, 0, _) = + [(fromIntegral $ char, fromIntegral $ char + delta) + | char <- [start .. end]] + prepare segCount indexTable + (start, end, delta, rangeOffset, ix) = + -- this is... so convoluted oO + [( fromIntegral char + , fromIntegral (if glyphId == 0 then 0 else glyphId + fromIntegral delta)) + | char <- [start .. end] + , let index = + (rangeOffset `div` 2) + (char - start) + ix + - segCount + , index < VU.length indexTable + , let glyphId = indexTable VU.! index + ] + +-------------------------------------------------- +---- Format0 +-------------------------------------------------- +data Format0 = Format0 + { _format0Language :: {-# UNPACK #-} !LangId + , _format0Table :: !(VU.Vector Word8) + } + deriving (Eq, Show) + +instance CharMappeable Format0 where + glyphIdFromTable Format0 { _format0Table = table } v + | ic > VU.length table = 0 + | otherwise = fromIntegral $ table VU.! ic + where ic = fromEnum v + + langIdOfCharMap = _format0Language + +instance Binary Format0 where + put _ = fail "Binary.Format0.put - unimplemented" + get = do + tableSize <- getWord16be + when (tableSize /= 262) $ + fail ("table cmap format 0, invalid size: " + ++ show tableSize) + Format0 <$> getWord16be <*> VU.replicateM 256 getWord8 + +-------------------------------------------------- +---- Format2 +-------------------------------------------------- +data Format2 = Format2 + { _format2Language :: {-# UNPACK #-} !LangId + , _format2SubKeys :: !(VU.Vector Word16) + , _format2SubHeaders :: !(V.Vector Format2SubHeader) + } + deriving (Eq, Show) + +data Format2SubHeader = Format2SubHeader + { _f2SubCode :: {-# UNPACK #-} !Word16 + , _f2EntryCount :: {-# UNPACK #-} !Word16 + , _f2IdDelta :: {-# UNPACK #-} !Int16 + , _f2IdRangeOffset :: {-# UNPACK #-} !Word16 + } + deriving (Eq, Show) + +instance CharMappeable Format2 where + glyphIdFromTable _ _ = 0 + langIdOfCharMap = _format2Language + +instance Binary Format2SubHeader where + put (Format2SubHeader a b c d) = + p16 a >> p16 b >> pi16 c >> p16 d + where + p16 = putWord16be + pi16 = p16 . fromIntegral + + get = Format2SubHeader <$> g16 <*> g16 <*> (fromIntegral <$> g16) <*> g16 + where g16 = getWord16be + + +instance Binary Format2 where + put _ = fail "Format2.put - unimplemented" + get = do + _tableSize <- getWord16be + lang <- getWord16be + subKeys <- VU.map (`div` 8) <$> VU.replicateM 256 getWord16be + let maxSubIndex = VU.maximum subKeys + subHeaders <- V.replicateM (fromIntegral maxSubIndex) get + -- TODO finish the parsing of format 2 + return $ Format2 lang subKeys subHeaders + +-------------------------------------------------- +---- Format6 +-------------------------------------------------- +data Format6 = Format6 + { _format6Language :: {-# UNPACK #-} !LangId + , _format6FirstCode :: {-# UNPACK #-} !Word16 + , _format6ArrayIndex :: !(VU.Vector Word16) + } + deriving (Eq, Show) + +instance CharMappeable Format6 where + glyphIdFromTable Format6 { _format6ArrayIndex = table } v + | ic < VU.length table = fromIntegral $ table VU.! ic + | otherwise = 0 + where ic = fromEnum v + + langIdOfCharMap = _format6Language + +instance Binary Format6 where + put _ = fail "Format6.put - unimplemented" + get = do + _length <- getWord16be + language <- getWord16be + firstCode <- getWord16be + entryCount <- fromIntegral <$> getWord16be + Format6 language firstCode <$> VU.replicateM entryCount getWord16be diff --git a/src/Graphics/Text/TrueType/FontFolders.hs b/src/Graphics/Text/TrueType/FontFolders.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Text/TrueType/FontFolders.hs @@ -0,0 +1,160 @@ + +module Graphics.Text.TrueType.FontFolders + ( loadUnixFontFolderList + , loadWindowsFontFolderList + , fontFolders + , findFont + , FontCache( .. ) + , FontDescriptor( .. ) + , buildFontCache + ) where + +import Control.Applicative( (<$>), (<*>) ) +{-import Control.DeepSeq( ($!!) )-} +{-import Data.Monoid( (<>) )-} +import System.Directory( getDirectoryContents + , doesDirectoryExist + ) +import qualified Data.Map as M +import System.Environment( lookupEnv ) +import System.FilePath( () ) +{- +import Text.XML.HXT.Core( runX + , readDocument + , withValidate + , withSubstDTDEntities + , no + , multi + , getChildren + , isElem + , hasName + , getText + , (>>>) ) +-- -} + +{-import qualified Control.Exception as E-} +import qualified Data.Text as T + +import Graphics.Text.TrueType.FontType +import Graphics.Text.TrueType.Header +import Graphics.Text.TrueType.Name + +{-catchAny :: IO a -> (E.SomeException -> IO a) -> IO a-} +{-catchAny = E.catch-} + +{- +loadParseFontsConf :: IO [FilePath] +loadParseFontsConf = runX ( + readDocument [withValidate no, withSubstDTDEntities no] + "/etc/fonts/fonts.conf" + >>> multi (isElem >>> hasName "dir" >>> getChildren >>> getText)) + +-- -} + +loadUnixFontFolderList :: IO [FilePath] +loadUnixFontFolderList = + -- Quick hack, need to change XML parser to a lighter one + return ["/usr/share/fonts", "/usr/local/share/fonts", "~/.fonts"] + {- + catchAny (do conf <- loadParseFontsConf + return $!! ( "truetype") <$> conf) + (const $ return []) + --} + +loadWindowsFontFolderList :: IO [FilePath] +loadWindowsFontFolderList = toFontFolder <$> lookupEnv "Windir" + where toFontFolder (Just a) = [a "Fonts"] + toFontFolder Nothing = [] + +loadOsXFontFolderList :: IO [FilePath] +loadOsXFontFolderList = return + ["~/Library/Fonts" + ,"/Library/Fonts" + ,"/System/Library/Fonts" + ,"/System Folder/Fonts" + ] + + +fontFolders :: IO [FilePath] +fontFolders = do + unix <- loadUnixFontFolderList + win <- loadWindowsFontFolderList + osx <- loadOsXFontFolderList + return $ unix ++ win ++ osx + +-- | A font descriptor is a key used to find a font +-- in a font cache. +data FontDescriptor = FontDescriptor + { -- | The family name of the font + _descriptorFamilyName :: T.Text + -- | The desired style + , _descriptorStyle :: FontStyle + } + deriving (Eq, Ord, Show) + +-- | A font cache is a cache listing all the found +-- fonts on the system, allowing faster font lookup +-- once created +newtype FontCache = + FontCache (M.Map FontDescriptor FilePath) + +-- | Look in the system's folder for usable fonts. +buildFontCache :: (FilePath -> IO (Maybe Font)) -> IO FontCache +buildFontCache loader = do + folders <- fontFolders + found <- build [("", v) | v <- folders] + return . FontCache + $ M.fromList [(d, path) | (Just d, path) <- found] + where + descriptorOf Font { _fontHeader = Just hdr + , _fontNames = Just names} = + Just $ FontDescriptor (fontFamilyName names) + (_fHdrMacStyle hdr) + descriptorOf _ = Nothing + + build [] = return [] + build ((".", _):rest) = build rest + build (("..", _):rest) = build rest + build ((_, n):rest) = do + isDirectory <- doesDirectoryExist n + + if isDirectory then do + sub <- getDirectoryContents n + (++) <$> build [(s, n s) | s <- sub] + <*> build rest + else do + f <- loader n + case f of + Nothing -> build rest + Just fo -> ((descriptorOf fo, n) :) <$> build rest + +findFont :: (FilePath -> IO (Maybe Font)) -> String -> FontStyle + -> IO (Maybe FilePath) +findFont loader fontName fontStyle = do + folders <- fontFolders + searchIn [("", v) | v <- folders] + where + fontNameText = T.pack fontName + isMatching n (Font { _fontHeader = Just hdr + , _fontNames = Just names}) + | _fHdrMacStyle hdr == fontStyle && + fontFamilyName names == fontNameText = Just n + isMatching _ _ = Nothing + + searchIn [] = return Nothing + searchIn ((".", _):rest) = searchIn rest + searchIn (("..", _):rest) = searchIn rest + searchIn ((_, n):rest) = do + isDirectory <- doesDirectoryExist n + + let findOrRest Nothing = searchIn rest + findOrRest l = return l + + if isDirectory then do + sub <- getDirectoryContents n + subRez <- searchIn [(s, n s) | s <- sub] + findOrRest subRez + else do + font <- loader n + findOrRest $ font >>= isMatching n + diff --git a/src/Graphics/Text/TrueType/FontType.hs b/src/Graphics/Text/TrueType/FontType.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Text/TrueType/FontType.hs @@ -0,0 +1,57 @@ +module Graphics.Text.TrueType.FontType + ( Font( .. ) + , emptyFont + ) where + +import Control.DeepSeq( NFData( .. ) ) +import Data.Word( Word32 ) +import qualified Data.ByteString.Char8 as B +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU + +import Graphics.Text.TrueType.MaxpTable +import Graphics.Text.TrueType.Glyph +import Graphics.Text.TrueType.Header +import Graphics.Text.TrueType.OffsetTable +import Graphics.Text.TrueType.CharacterMap +import Graphics.Text.TrueType.HorizontalInfo +import Graphics.Text.TrueType.Name + + +-- | Type representing a font. +data Font = Font + { _fontOffsetTable :: !OffsetTable + , _fontTables :: ![(B.ByteString, B.ByteString)] + , _fontNames :: Maybe NameTable + , _fontHeader :: Maybe FontHeader + , _fontMaxp :: Maybe MaxpTable + , _fontMap :: Maybe CharacterMaps + , _fontGlyph :: Maybe (V.Vector Glyph) + , _fontLoca :: Maybe (VU.Vector Word32) + , _fontHorizontalHeader :: Maybe HorizontalHeader + , _fontHorizontalMetrics :: Maybe HorizontalMetricsTable + } + deriving (Show) + +instance NFData Font where + rnf font = + _fontOffsetTable font `seq` + _fontTables font `seq` + _fontGlyph font `seq` + _fontLoca font `seq` + () + +emptyFont :: OffsetTable -> Font +emptyFont table = Font + { _fontTables = [] + , _fontOffsetTable = table + , _fontNames = Nothing + , _fontHeader = Nothing + , _fontGlyph = Nothing + , _fontMaxp = Nothing + , _fontLoca = Nothing + , _fontMap = Nothing + , _fontHorizontalHeader = Nothing + , _fontHorizontalMetrics = Nothing + } + diff --git a/src/Graphics/Text/TrueType/Glyph.hs b/src/Graphics/Text/TrueType/Glyph.hs --- a/src/Graphics/Text/TrueType/Glyph.hs +++ b/src/Graphics/Text/TrueType/Glyph.hs @@ -1,305 +1,317 @@ -{-# LANGUAGE TupleSections #-} -module Graphics.Text.TrueType.Glyph - ( GlyphHeader( .. ) - , GlyphContour( .. ) - , CompositeScaling( .. ) - , GlyphComposition( .. ) - , GlyphContent( .. ) - , Glyph( .. ) - , GlyphFlag( .. ) - , extractFlatOutline - , emptyGlyph - ) where - -import Control.Applicative( (<$>), (<*>) ) -import Data.Bits( setBit, testBit, shiftL ) -import Data.Int( Int16 ) -import Data.List( mapAccumL, mapAccumR, zip4 ) -import Data.Monoid( mempty ) -import Data.Word( Word8, Word16 ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( Get - , getWord8 - , getWord16be ) - -import Data.Binary.Put( putWord8, putWord16be ) -import Data.Tuple( swap ) - -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as VU - -{-import Text.Printf-} -{-import Debug.Trace-} - -data GlyphHeader = GlyphHeader - { -- | If the number of contours is greater than or equal - -- to zero, this is a single glyph; if negative, this is - -- a composite glyph. - _glfNumberOfContours :: {-# UNPACK #-} !Int16 - -- | Minimum x for coordinate data. - , _glfXMin :: {-# UNPACK #-} !Int16 - -- | Minimum y for coordinate data. - , _glfYMin :: {-# UNPACK #-} !Int16 - -- | Maximum x for coordinate data. - , _glfXMax :: {-# UNPACK #-} !Int16 - -- | Maximum y for coordinate data. - , _glfYMax :: {-# UNPACK #-} !Int16 - } - deriving (Eq, Show) - -emptyGlyphHeader :: GlyphHeader -emptyGlyphHeader = GlyphHeader 0 0 0 0 0 - -instance Binary GlyphHeader where - get = GlyphHeader <$> g16 <*> g16 <*> g16 <*> g16 <*> g16 - where g16 = fromIntegral <$> getWord16be - - put (GlyphHeader count xmini ymini xmaxi ymaxi) = - p16 count >> p16 xmini >> p16 ymini >> p16 xmaxi >> p16 ymaxi - where p16 = putWord16be . fromIntegral - -data GlyphContour = GlyphContour - { _glyphInstructions :: !(VU.Vector Word8) - , _glyphFlags :: ![GlyphFlag] - , _glyphPoints :: ![VU.Vector (Int16, Int16)] - } - deriving (Eq, Show) - -data CompositeScaling = CompositeScaling - { _a :: {-# UNPACK #-} !Int16 - , _b :: {-# UNPACK #-} !Int16 - , _c :: {-# UNPACK #-} !Int16 - , _d :: {-# UNPACK #-} !Int16 - , _e :: {-# UNPACK #-} !Int16 - , _f :: {-# UNPACK #-} !Int16 - } - deriving (Eq, Show) - -data GlyphComposition = GlyphComposition - { _glyphCompositeFlag :: {-# UNPACK #-} !Word16 - , _glyphCompositeIndex :: {-# UNPACK #-} !Word16 - , _glyphCompositionArg :: {-# UNPACK #-} !(Int16, Int16) - , _glyphCompositionScale :: !CompositeScaling - } - deriving (Eq, Show) - -data GlyphContent - = GlyphEmpty - | GlyphSimple !GlyphContour - | GlyphComposite !(V.Vector GlyphComposition) !(VU.Vector Word8) - deriving (Eq, Show) - -data Glyph = Glyph - { _glyphHeader :: !GlyphHeader - , _glyphContent :: !GlyphContent - } - deriving (Eq, Show) - -emptyGlyph :: Glyph -emptyGlyph = Glyph emptyGlyphHeader GlyphEmpty - -getCompositeOutline :: Get GlyphContent -getCompositeOutline = - (\(instr, vals) -> GlyphComposite (V.fromList vals) instr) <$> go - where - go = do - flag <- getWord16be - index <- getWord16be - args <- fetchArguments flag - scaling <- fetchScaling flag - let fullScaling = fetchOffset scaling args flag - value = GlyphComposition flag index args fullScaling - - if flag `testBit` mORE_COMPONENTS then - (\(instr, acc) -> (instr, value : acc )) <$> go - else - if flag `testBit` wE_HAVE_INSTRUCTIONS then do - count <- fromIntegral <$> getWord16be - (, [value]) <$> VU.replicateM count getWord8 - else - return (mempty, [value]) - - - fetchArguments flag - | flag `testBit` aRG_1_AND_2_ARE_WORDS = - (,) <$> getInt16be <*> getInt16be - | otherwise = - (,) <$> getInt8 <*> getInt8 - - fetchScaling flag - | flag `testBit` wE_HAVE_A_SCALE = - (\v -> CompositeScaling v 0 0 v) <$> getF2Dot14 - | flag `testBit` wE_HAVE_AN_X_AND_Y_SCALE = - (\x y -> CompositeScaling x 0 0 y) <$> getF2Dot14 <*> getF2Dot14 - | flag `testBit` wE_HAVE_A_TWO_BY_TWO = - CompositeScaling <$> getF2Dot14 <*> getF2Dot14 - <*> getF2Dot14 <*> getF2Dot14 - | otherwise = return $ CompositeScaling one 0 0 one - where one = 1 `shiftL` 14 - - fetchOffset scaling (a1, a2) flag - | flag `testBit` aRGS_ARE_XY_VALUES = scaling a1 a2 - | otherwise = scaling 0 0 -- TODO fix this crap - - {-- - if (!ARGS_ARE_XY_VALUES) - 1st short contains the index of matching point in compound being constructed - 2nd short contains index of matching point in component -} - - getInt16be = fromIntegral <$> getWord16be - getF2Dot14 = fromIntegral <$> getWord16be - getInt8 = fromIntegral <$> getWord8 - - aRG_1_AND_2_ARE_WORDS = 0 - aRGS_ARE_XY_VALUES = 1 - {-rOUND_XY_TO_GRID = 2-} - wE_HAVE_A_SCALE = 3 - {-rESERVED = 4-} - mORE_COMPONENTS = 5 - wE_HAVE_AN_X_AND_Y_SCALE = 6 - wE_HAVE_A_TWO_BY_TWO = 7 - wE_HAVE_INSTRUCTIONS = 8 - {-uSE_MY_METRICS = 9-} - {-oVERLAP_COMPOUND = 10-} - {-sCALED_COMPONENT_OFFSET = 11-} - {-uNSCALED_COMPONENT_OFFSET = 12-} - -data GlyphFlag = GlyphFlag - { -- | If set, the point is on the curve; - -- otherwise, it is off the curve. - _flagOnCurve :: !Bool - -- | If set, the corresponding x-coordinate is 1 - -- byte long. If not set, 2 bytes. - , _flagXshort :: !Bool - -- | If set, the corresponding y-coordinate is 1 - -- byte long. If not set, 2 bytes. - , _flagYShort :: !Bool - -- | If set, the next byte specifies the number of additional - -- times this set of flags is to be repeated. In this way, the - -- number of flags listed can be smaller than the number of - -- points in a character. - , _flagRepeat :: !Bool - -- | This flag has two meanings, depending on how the x-Short - -- Vector flag is set. If x-Short Vector is set, this bit - -- describes the sign of the value, with 1 equalling positive and - -- 0 negative. If the x-Short Vector bit is not set and this bit is set, - -- then the current x-coordinate is the same as the previous x-coordinate. - -- If the x-Short Vector bit is not set and this bit is also not set, the - -- current x-coordinate is a signed 16-bit delta vector. - , _flagXSame :: !Bool - -- | This flag has two meanings, depending on how the y-Short Vector flag - -- is set. If y-Short Vector is set, this bit describes the sign of the - -- value, with 1 equalling positive and 0 negative. If the y-Short Vector - -- bit is not set and this bit is set, then the current y-coordinate is the - -- same as the previous y-coordinate. If the y-Short Vector bit is not set - -- and this bit is also not set, the current y-coordinate is a signed - -- 16-bit delta vector. - , _flagYSame :: !Bool - } - deriving (Eq, Show) - -instance Binary GlyphFlag where - put (GlyphFlag a0 a1 a2 a3 a4 a5) = - putWord8 . foldl setter 0 $ zip [0..] [a0, a1, a2, a3, a4, a5] - where setter v ( _, False) = v - setter v (ix, True) = setBit v ix - get = do - tester <- testBit <$> getWord8 - return $ GlyphFlag - { _flagOnCurve = tester 0 - , _flagXshort = tester 1 - , _flagYShort = tester 2 - , _flagRepeat = tester 3 - , _flagXSame = tester 4 - , _flagYSame = tester 5 - } - -getGlyphFlags :: Int -> Get [GlyphFlag] -getGlyphFlags count = go 0 - where - go n | n >= count = return [] - go n = do - flag <- get - if _flagRepeat flag - then do - repeatCount <- fromIntegral <$> getWord8 - let real = min (count - n) (repeatCount + 1) - (replicate real flag ++) <$> go (n + real) - else (flag :) <$> go (n + 1) - -getCoords :: [GlyphFlag] -> Get (VU.Vector (Int16, Int16)) -getCoords flags = - VU.fromList <$> (zip <$> go (_flagXSame, _flagXshort) 0 flags - <*> go (_flagYSame, _flagYShort) 0 flags) - where - go _ _ [] = return [] - go axx@(isSame, isShort) prevCoord (flag:flagRest) = do - let fetcher - | isShort flag && isSame flag = - (prevCoord +) . fromIntegral <$> getWord8 - | isShort flag = - (prevCoord - ) . fromIntegral <$> getWord8 - | isSame flag = - return prevCoord - | otherwise = - (prevCoord +) . fromIntegral <$> getWord16be - - newCoord <- fetcher - (newCoord :) <$> go axx newCoord flagRest - -extractFlatOutline :: GlyphContour - -> [VU.Vector (Int16, Int16)] -extractFlatOutline contour = map go $ zip flagGroup coords - where - allFlags = _glyphFlags contour - coords = _glyphPoints contour - (_, flagGroup) = - mapAccumL (\acc v -> swap $ splitAt (VU.length v) acc) allFlags coords - - go (flags, coord) - | VU.null coord = mempty - | otherwise = VU.fromList . (firstPoint :) $ expand mixed - where - isOnSide = map _flagOnCurve flags - firstOnCurve = head isOnSide - lst@(firstPoint:xs) = VU.toList coord - mixed = zip4 isOnSide (tail isOnSide) lst xs - midPoint (x1, y1) (x2, y2) = - ((x1 + x2) `div` 2, (y1 + y2) `div` 2) - - expand [] = [] - expand [(onp, on, prevPoint, currPoint)] - | onp == on = (prevPoint `midPoint` currPoint) : endJunction - | otherwise = endJunction - where endJunction - | on && firstOnCurve = - [currPoint, currPoint `midPoint` firstPoint, firstPoint] - | otherwise = [currPoint, firstPoint] - expand ((onp, on, prevPoint, currPoint):rest) - | onp == on = prevPoint `midPoint` currPoint : currPoint : expand rest - | otherwise = currPoint : expand rest - -getSimpleOutline :: Int16 -> Get GlyphContent -getSimpleOutline counterCount = do - endOfPoints <- VU.replicateM (fromIntegral counterCount) getWord16be - let pointCount = VU.last endOfPoints + 1 - instructionCount <- fromIntegral <$> getWord16be - instructions <- VU.replicateM instructionCount getWord8 - - flags <- getGlyphFlags $ fromIntegral pointCount - GlyphSimple . GlyphContour instructions flags - . breakOutline endOfPoints <$> getCoords flags - where - prepender (v, lst) = v : lst - breakOutline endPoints coords = - prepender . mapAccumR breaker coords . VU.toList $ VU.init endPoints - where breaker array ix = VU.splitAt (fromIntegral ix + 1) array - -instance Binary Glyph where - put _ = fail "Glyph.put - unimplemented" - get = do - hdr <- get - case _glfNumberOfContours hdr of - -1 -> Glyph hdr <$> getCompositeOutline - n -> Glyph hdr <$> getSimpleOutline n - +{-# LANGUAGE TupleSections #-} +module Graphics.Text.TrueType.Glyph + ( GlyphHeader( .. ) + , GlyphContour( .. ) + , CompositeScaling( .. ) + , GlyphComposition( .. ) + , GlyphContent( .. ) + , Glyph( .. ) + , GlyphFlag( .. ) + , extractFlatOutline + , emptyGlyph + ) where + +import Control.DeepSeq +import Control.Applicative( (<$>), (<*>) ) +import Data.Bits( setBit, testBit, shiftL ) +import Data.Int( Int16 ) +import Data.List( mapAccumL, mapAccumR, zip4 ) +import Data.Monoid( mempty ) +import Data.Word( Word8, Word16 ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( Get + , getWord8 + , getWord16be ) + +import Data.Binary.Put( putWord8, putWord16be ) +import Data.Tuple( swap ) + +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU + +{-import Text.Printf-} +{-import Debug.Trace-} + +data GlyphHeader = GlyphHeader + { -- | If the number of contours is greater than or equal + -- to zero, this is a single glyph; if negative, this is + -- a composite glyph. + _glfNumberOfContours :: {-# UNPACK #-} !Int16 + -- | Minimum x for coordinate data. + , _glfXMin :: {-# UNPACK #-} !Int16 + -- | Minimum y for coordinate data. + , _glfYMin :: {-# UNPACK #-} !Int16 + -- | Maximum x for coordinate data. + , _glfXMax :: {-# UNPACK #-} !Int16 + -- | Maximum y for coordinate data. + , _glfYMax :: {-# UNPACK #-} !Int16 + } + deriving (Eq, Show) + +instance NFData GlyphHeader where + rnf (GlyphHeader _ _ _ _ _) = () + +emptyGlyphHeader :: GlyphHeader +emptyGlyphHeader = GlyphHeader 0 0 0 0 0 + +instance Binary GlyphHeader where + get = GlyphHeader <$> g16 <*> g16 <*> g16 <*> g16 <*> g16 + where g16 = fromIntegral <$> getWord16be + + put (GlyphHeader count xmini ymini xmaxi ymaxi) = + p16 count >> p16 xmini >> p16 ymini >> p16 xmaxi >> p16 ymaxi + where p16 = putWord16be . fromIntegral + +data GlyphContour = GlyphContour + { _glyphInstructions :: !(VU.Vector Word8) + , _glyphFlags :: ![GlyphFlag] + , _glyphPoints :: ![VU.Vector (Int16, Int16)] + } + deriving (Eq, Show) + +instance NFData GlyphContour where + rnf (GlyphContour instr fl points) = + instr `seq` fl `seq` points `seq` () + +data CompositeScaling = CompositeScaling + { _a :: {-# UNPACK #-} !Int16 + , _b :: {-# UNPACK #-} !Int16 + , _c :: {-# UNPACK #-} !Int16 + , _d :: {-# UNPACK #-} !Int16 + , _e :: {-# UNPACK #-} !Int16 + , _f :: {-# UNPACK #-} !Int16 + } + deriving (Eq, Show) + +data GlyphComposition = GlyphComposition + { _glyphCompositeFlag :: {-# UNPACK #-} !Word16 + , _glyphCompositeIndex :: {-# UNPACK #-} !Word16 + , _glyphCompositionArg :: {-# UNPACK #-} !(Int16, Int16) + , _glyphCompositionScale :: !CompositeScaling + } + deriving (Eq, Show) + +data GlyphContent + = GlyphEmpty + | GlyphSimple !GlyphContour + | GlyphComposite !(V.Vector GlyphComposition) !(VU.Vector Word8) + deriving (Eq, Show) + +data Glyph = Glyph + { _glyphHeader :: !GlyphHeader + , _glyphContent :: !GlyphContent + } + deriving (Eq, Show) + +instance NFData Glyph where + rnf (Glyph hdr cont) = + rnf hdr `seq` cont `seq` () + +emptyGlyph :: Glyph +emptyGlyph = Glyph emptyGlyphHeader GlyphEmpty + +getCompositeOutline :: Get GlyphContent +getCompositeOutline = + (\(instr, vals) -> GlyphComposite (V.fromList vals) instr) <$> go + where + go = do + flag <- getWord16be + index <- getWord16be + args <- fetchArguments flag + scaling <- fetchScaling flag + let fullScaling = fetchOffset scaling args flag + value = GlyphComposition flag index args fullScaling + + if flag `testBit` mORE_COMPONENTS then + (\(instr, acc) -> (instr, value : acc )) <$> go + else + if flag `testBit` wE_HAVE_INSTRUCTIONS then do + count <- fromIntegral <$> getWord16be + (, [value]) <$> VU.replicateM count getWord8 + else + return (mempty, [value]) + + + fetchArguments flag + | flag `testBit` aRG_1_AND_2_ARE_WORDS = + (,) <$> getInt16be <*> getInt16be + | otherwise = + (,) <$> getInt8 <*> getInt8 + + fetchScaling flag + | flag `testBit` wE_HAVE_A_SCALE = + (\v -> CompositeScaling v 0 0 v) <$> getF2Dot14 + | flag `testBit` wE_HAVE_AN_X_AND_Y_SCALE = + (\x y -> CompositeScaling x 0 0 y) <$> getF2Dot14 <*> getF2Dot14 + | flag `testBit` wE_HAVE_A_TWO_BY_TWO = + CompositeScaling <$> getF2Dot14 <*> getF2Dot14 + <*> getF2Dot14 <*> getF2Dot14 + | otherwise = return $ CompositeScaling one 0 0 one + where one = 1 `shiftL` 14 + + fetchOffset scaling (a1, a2) flag + | flag `testBit` aRGS_ARE_XY_VALUES = scaling a1 a2 + | otherwise = scaling 0 0 -- TODO fix this crap + + {-- + if (!ARGS_ARE_XY_VALUES) + 1st short contains the index of matching point in compound being constructed + 2nd short contains index of matching point in component -} + + getInt16be = fromIntegral <$> getWord16be + getF2Dot14 = fromIntegral <$> getWord16be + getInt8 = fromIntegral <$> getWord8 + + aRG_1_AND_2_ARE_WORDS = 0 + aRGS_ARE_XY_VALUES = 1 + {-rOUND_XY_TO_GRID = 2-} + wE_HAVE_A_SCALE = 3 + {-rESERVED = 4-} + mORE_COMPONENTS = 5 + wE_HAVE_AN_X_AND_Y_SCALE = 6 + wE_HAVE_A_TWO_BY_TWO = 7 + wE_HAVE_INSTRUCTIONS = 8 + {-uSE_MY_METRICS = 9-} + {-oVERLAP_COMPOUND = 10-} + {-sCALED_COMPONENT_OFFSET = 11-} + {-uNSCALED_COMPONENT_OFFSET = 12-} + +data GlyphFlag = GlyphFlag + { -- | If set, the point is on the curve; + -- otherwise, it is off the curve. + _flagOnCurve :: !Bool + -- | If set, the corresponding x-coordinate is 1 + -- byte long. If not set, 2 bytes. + , _flagXshort :: !Bool + -- | If set, the corresponding y-coordinate is 1 + -- byte long. If not set, 2 bytes. + , _flagYShort :: !Bool + -- | If set, the next byte specifies the number of additional + -- times this set of flags is to be repeated. In this way, the + -- number of flags listed can be smaller than the number of + -- points in a character. + , _flagRepeat :: !Bool + -- | This flag has two meanings, depending on how the x-Short + -- Vector flag is set. If x-Short Vector is set, this bit + -- describes the sign of the value, with 1 equalling positive and + -- 0 negative. If the x-Short Vector bit is not set and this bit is set, + -- then the current x-coordinate is the same as the previous x-coordinate. + -- If the x-Short Vector bit is not set and this bit is also not set, the + -- current x-coordinate is a signed 16-bit delta vector. + , _flagXSame :: !Bool + -- | This flag has two meanings, depending on how the y-Short Vector flag + -- is set. If y-Short Vector is set, this bit describes the sign of the + -- value, with 1 equalling positive and 0 negative. If the y-Short Vector + -- bit is not set and this bit is set, then the current y-coordinate is the + -- same as the previous y-coordinate. If the y-Short Vector bit is not set + -- and this bit is also not set, the current y-coordinate is a signed + -- 16-bit delta vector. + , _flagYSame :: !Bool + } + deriving (Eq, Show) + +instance Binary GlyphFlag where + put (GlyphFlag a0 a1 a2 a3 a4 a5) = + putWord8 . foldl setter 0 $ zip [0..] [a0, a1, a2, a3, a4, a5] + where setter v ( _, False) = v + setter v (ix, True) = setBit v ix + get = do + tester <- testBit <$> getWord8 + return $ GlyphFlag + { _flagOnCurve = tester 0 + , _flagXshort = tester 1 + , _flagYShort = tester 2 + , _flagRepeat = tester 3 + , _flagXSame = tester 4 + , _flagYSame = tester 5 + } + +getGlyphFlags :: Int -> Get [GlyphFlag] +getGlyphFlags count = go 0 + where + go n | n >= count = return [] + go n = do + flag <- get + if _flagRepeat flag + then do + repeatCount <- fromIntegral <$> getWord8 + let real = min (count - n) (repeatCount + 1) + (replicate real flag ++) <$> go (n + real) + else (flag :) <$> go (n + 1) + +getCoords :: [GlyphFlag] -> Get (VU.Vector (Int16, Int16)) +getCoords flags = + VU.fromList <$> (zip <$> go (_flagXSame, _flagXshort) 0 flags + <*> go (_flagYSame, _flagYShort) 0 flags) + where + go _ _ [] = return [] + go axx@(isSame, isShort) prevCoord (flag:flagRest) = do + let fetcher + | isShort flag && isSame flag = + (prevCoord +) . fromIntegral <$> getWord8 + | isShort flag = + (prevCoord - ) . fromIntegral <$> getWord8 + | isSame flag = + return prevCoord + | otherwise = + (prevCoord +) . fromIntegral <$> getWord16be + + newCoord <- fetcher + (newCoord :) <$> go axx newCoord flagRest + +extractFlatOutline :: GlyphContour + -> [VU.Vector (Int16, Int16)] +extractFlatOutline contour = map go $ zip flagGroup coords + where + allFlags = _glyphFlags contour + coords = _glyphPoints contour + (_, flagGroup) = + mapAccumL (\acc v -> swap $ splitAt (VU.length v) acc) allFlags coords + + go (flags, coord) + | VU.null coord = mempty + | otherwise = VU.fromList . (firstPoint :) $ expand mixed + where + isOnSide = map _flagOnCurve flags + firstOnCurve = head isOnSide + lst@(firstPoint:xs) = VU.toList coord + mixed = zip4 isOnSide (tail isOnSide) lst xs + midPoint (x1, y1) (x2, y2) = + ((x1 + x2) `div` 2, (y1 + y2) `div` 2) + + expand [] = [] + expand [(onp, on, prevPoint, currPoint)] + | onp == on = (prevPoint `midPoint` currPoint) : endJunction + | otherwise = endJunction + where endJunction + | on && firstOnCurve = + [currPoint, currPoint `midPoint` firstPoint, firstPoint] + | otherwise = [currPoint, firstPoint] + expand ((onp, on, prevPoint, currPoint):rest) + | onp == on = prevPoint `midPoint` currPoint : currPoint : expand rest + | otherwise = currPoint : expand rest + +getSimpleOutline :: Int16 -> Get GlyphContent +getSimpleOutline counterCount = do + endOfPoints <- VU.replicateM (fromIntegral counterCount) getWord16be + let pointCount = VU.last endOfPoints + 1 + instructionCount <- fromIntegral <$> getWord16be + instructions <- VU.replicateM instructionCount getWord8 + + flags <- getGlyphFlags $ fromIntegral pointCount + GlyphSimple . GlyphContour instructions flags + . breakOutline endOfPoints <$> getCoords flags + where + prepender (v, lst) = v : lst + breakOutline endPoints coords = + prepender . mapAccumR breaker coords . VU.toList $ VU.init endPoints + where breaker array ix = VU.splitAt (fromIntegral ix + 1) array + +instance Binary Glyph where + put _ = fail "Glyph.put - unimplemented" + get = do + hdr <- get + case _glfNumberOfContours hdr of + -1 -> Glyph hdr <$> getCompositeOutline + n -> Glyph hdr <$> getSimpleOutline n + diff --git a/src/Graphics/Text/TrueType/Header.hs b/src/Graphics/Text/TrueType/Header.hs --- a/src/Graphics/Text/TrueType/Header.hs +++ b/src/Graphics/Text/TrueType/Header.hs @@ -1,108 +1,137 @@ -module Graphics.Text.TrueType.Header - ( FontHeader( .. ) - , HeaderFlags( .. ) - ) where - -import Control.Applicative( (<$>), (<*>) ) -import Data.Bits( setBit, testBit ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( getWord16be - , getWord32be - , getWord64be - ) - -import Data.Binary.Put( putWord16be) - -import Data.Int( Int16 ) -import Data.List( foldl' ) -import Data.Word( Word16, Word32, Word64 ) - -import Graphics.Text.TrueType.Types - -data FontHeader = FontHeader - { -- | Table version number 0x00010000 for version 1.0. - _fHdrVersionNumber :: !Fixed - -- | fontRevision Set by font manufacturer. - , _fHdrFontRevision :: !Fixed - -- | To compute: set it to 0, sum the entire font as - -- ULONG, then store 0xB1B0AFBA - sum. - , _fHdrChecksumAdjust :: !Word32 - - -- | Should be equal to 0x5F0F3CF5. - , _fHdrMagicNumber :: !Word32 - , _fHdrFlags :: !HeaderFlags - - -- | Valid range is from 16 to 16384 - , _fUnitsPerEm :: !Word16 - -- | International date (8-byte field). - , _fHdrCreateTime :: !Word64 - -- | International date (8-byte field). - , _fHdrModificationTime :: !Word64 - - -- | For all glyph bounding boxes. - , _fHdrxMin :: !FWord - -- | For all glyph bounding boxes. - , _fHdrYMin :: !FWord - -- | For all glyph bounding boxes. - , _fHdrXMax :: !FWord - -- | For all glyph bounding boxes. - , _fHdrYMax :: !FWord - -- | Bit 0 bold (if set to 1); Bit 1 italic (if set to 1) - , _fHdrMacStyle :: !Word16 - -- | Smallest readable size in pixels. - , _fHdrLowestRecPPEM :: !Word16 - - -- | 0 Fully mixed directional glyphs; - -- 1 Only strongly left to right; - -- 2 Like 1 but also contains neutrals ; - -- -1 Only strongly right to left; - -- -2 Like -1 but also contains neutrals. - , _fHdrFontDirectionHint :: !Int16 - -- | 0 for short offsets, 1 for long. - , _fHdrIndexToLocFormat :: !Int16 - -- | 0 for current format. - , _fHdrGlyphDataFormat :: !Int16 - } - deriving (Eq, Show) - -instance Binary FontHeader where - put _ = fail "Unimplemented" - get = - FontHeader <$> get <*> get <*> g32 <*> g32 <*> get - <*> g16 <*> g64 <*> g64 <*> get <*> get - <*> get <*> get <*> g16 <*> g16 <*> gi16 - <*> gi16 <*> gi16 - where g16 = getWord16be - g32 = getWord32be - gi16 = fromIntegral <$> getWord16be - g64 = getWord64be - - -data HeaderFlags = HeaderFlags - { -- | Bit 0 - baseline for font at y=0; - _hfBaselineY0 :: !Bool - -- | Bit 1 - left sidebearing at x=0; - , _hfLeftSideBearing :: !Bool - -- | Bit 2 - instructions may depend on point size; - , _hfInstrDependPointSize :: !Bool - -- | Bit 3 - force ppem to integer values for all internal - -- scaler math; may use fractional ppem sizes if this bit - -- is clear; - , _hfForcePPEM :: !Bool - -- | Bit 4 - instructions may alter advance width (the - -- advance widths might not scale linearly); - , _hfAlterAdvance :: !Bool - } - deriving (Eq, Show) - -instance Binary HeaderFlags where - get = do - flags <- getWord16be - let at ix = flags `testBit` ix - return $ HeaderFlags (at 0) (at 1) (at 2) (at 3) (at 4) - - put (HeaderFlags a0 a1 a2 a3 a4) = - putWord16be . foldl' setter 0 $ zip [0..] [a0, a1, a2, a3, a4] - where setter acc (_, False) = acc - setter acc (ix, True) = setBit acc ix - +module Graphics.Text.TrueType.Header + ( FontHeader( .. ) + , FontStyle( .. ) + , HeaderFlags( .. ) + ) where + +import Control.Applicative( (<$>), (<*>) ) +import Control.DeepSeq( NFData( .. ) ) +import Data.Bits( (.|.), setBit, testBit ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( getWord16be + , getWord32be + , getWord64be + ) + +import Data.Binary.Put( putWord16be) + +import Data.Int( Int16 ) +import Data.List( foldl' ) +import Data.Word( Word16, Word32, Word64 ) + +import Graphics.Text.TrueType.Types + +-- | Describe the basic stylistic properties +-- of a font. +data FontStyle = FontStyle + { _fontStyleBold :: !Bool -- ^ If the font is bold. + , _fontStyleItalic :: !Bool -- ^ If the font is italic. + } + deriving (Eq, Ord, Show) + +instance Binary FontStyle where + put style = putWord16be $ italicByte .|. boldByte + where + boldByte + | _fontStyleBold style = 1 + | otherwise = 0 + + italicByte + | _fontStyleItalic style = 2 + | otherwise = 0 + + get = do + styleWord <- getWord16be + let bitAt = testBit styleWord + return $ FontStyle (bitAt 0) (bitAt 1) + +data FontHeader = FontHeader + { -- | Table version number 0x00010000 for version 1.0. + _fHdrVersionNumber :: !Fixed + -- | fontRevision Set by font manufacturer. + , _fHdrFontRevision :: !Fixed + -- | To compute: set it to 0, sum the entire font as + -- ULONG, then store 0xB1B0AFBA - sum. + , _fHdrChecksumAdjust :: !Word32 + + -- | Should be equal to 0x5F0F3CF5. + , _fHdrMagicNumber :: !Word32 + , _fHdrFlags :: !HeaderFlags + + -- | Valid range is from 16 to 16384 + , _fUnitsPerEm :: !Word16 + -- | International date (8-byte field). + , _fHdrCreateTime :: !Word64 + -- | International date (8-byte field). + , _fHdrModificationTime :: !Word64 + + -- | For all glyph bounding boxes. + , _fHdrxMin :: !FWord + -- | For all glyph bounding boxes. + , _fHdrYMin :: !FWord + -- | For all glyph bounding boxes. + , _fHdrXMax :: !FWord + -- | For all glyph bounding boxes. + , _fHdrYMax :: !FWord + -- | Bit 0 bold (if set to 1); Bit 1 italic (if set to 1) + , _fHdrMacStyle :: !FontStyle + -- | Smallest readable size in pixels. + , _fHdrLowestRecPPEM :: !Word16 + + -- | 0 Fully mixed directional glyphs; + -- 1 Only strongly left to right; + -- 2 Like 1 but also contains neutrals ; + -- -1 Only strongly right to left; + -- -2 Like -1 but also contains neutrals. + , _fHdrFontDirectionHint :: !Int16 + -- | 0 for short offsets, 1 for long. + , _fHdrIndexToLocFormat :: !Int16 + -- | 0 for current format. + , _fHdrGlyphDataFormat :: !Int16 + } + deriving (Eq, Show) + +instance NFData FontHeader where + rnf (FontHeader {}) = () + +instance Binary FontHeader where + put _ = fail "Unimplemented" + get = + FontHeader <$> get <*> get <*> g32 <*> g32 <*> get + <*> g16 <*> g64 <*> g64 <*> get <*> get + <*> get <*> get <*> get <*> g16 <*> gi16 + <*> gi16 <*> gi16 + where g16 = getWord16be + g32 = getWord32be + gi16 = fromIntegral <$> getWord16be + g64 = getWord64be + + +data HeaderFlags = HeaderFlags + { -- | Bit 0 - baseline for font at y=0; + _hfBaselineY0 :: !Bool + -- | Bit 1 - left sidebearing at x=0; + , _hfLeftSideBearing :: !Bool + -- | Bit 2 - instructions may depend on point size; + , _hfInstrDependPointSize :: !Bool + -- | Bit 3 - force ppem to integer values for all internal + -- scaler math; may use fractional ppem sizes if this bit + -- is clear; + , _hfForcePPEM :: !Bool + -- | Bit 4 - instructions may alter advance width (the + -- advance widths might not scale linearly); + , _hfAlterAdvance :: !Bool + } + deriving (Eq, Show) + +instance Binary HeaderFlags where + get = do + flags <- getWord16be + let at ix = flags `testBit` ix + return $ HeaderFlags (at 0) (at 1) (at 2) (at 3) (at 4) + + put (HeaderFlags a0 a1 a2 a3 a4) = + putWord16be . foldl' setter 0 $ zip [0..] [a0, a1, a2, a3, a4] + where setter acc (_, False) = acc + setter acc (ix, True) = setBit acc ix + diff --git a/src/Graphics/Text/TrueType/HorizontalInfo.hs b/src/Graphics/Text/TrueType/HorizontalInfo.hs --- a/src/Graphics/Text/TrueType/HorizontalInfo.hs +++ b/src/Graphics/Text/TrueType/HorizontalInfo.hs @@ -1,108 +1,112 @@ -module Graphics.Text.TrueType.HorizontalInfo - ( HorizontalHeader( .. ) - , HorizontalMetricsTable( .. ) - , HorizontalMetric( .. ) - , getHorizontalMetrics - ) where - -import Control.Applicative( (<$>), (<*>) ) -import Control.Monad( when, replicateM_ ) -import Data.Word( Word16 ) -import Data.Int( Int16 ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( Get, getWord16be, getWord32be ) -import Data.Binary.Put( putWord16be, putWord32be ) -import qualified Data.Vector as V - -import Graphics.Text.TrueType.Types - -data HorizontalHeader = HorizontalHeader - { -- | Distance from baseline of highest ascender - _hheaAscent :: {-# UNPACK #-} !FWord - -- | Distance from baseline of lowest descender - , _hheaDescent :: {-# UNPACK #-} !FWord - -- | typographic line gap - , _hheaLineGap :: {-# UNPACK #-} !FWord - -- | must be consistent with horizontal metrics - , _hheaAdvanceWidthMax :: {-# UNPACK #-} !FWord - -- | must be consistent with horizontal metrics - , _hheaMinLeftSideBearing :: {-# UNPACK #-} !FWord - -- | must be consistent with horizontal metrics - , _hheaMinRightSideBearing :: {-# UNPACK #-} !FWord - -- | max(lsb + (xMax-xMin)) - , _hheaXmaxExtent :: {-# UNPACK #-} !FWord - -- | used to calculate the slope of the caret - -- (rise/run) set to 1 for vertical caret - , _hheaCaretSlopeRise :: {-# UNPACK #-} !Int16 - -- | 0 for vertical - , _hheaCaretSlopeRun :: {-# UNPACK #-} !Int16 - -- | set value to 0 for non-slanted fonts - , _hheaCaretOffset :: {-# UNPACK #-} !FWord - -- | 0 for current format - , _hheaMetricDataFormat :: {-# UNPACK #-} !Int16 - -- | number of advance widths in metrics table - , _hheaLongHorMetricCount :: {-# UNPACK #-} !Word16 - } - deriving (Eq, Show) - -instance Binary HorizontalHeader where - put hdr = do - putWord32be 0x00010000 - put $ _hheaAscent hdr - put $ _hheaDescent hdr - put $ _hheaLineGap hdr - put $ _hheaAdvanceWidthMax hdr - put $ _hheaMinLeftSideBearing hdr - put $ _hheaMinRightSideBearing hdr - put $ _hheaXmaxExtent hdr - putWord16be . fromIntegral $ _hheaCaretSlopeRise hdr - putWord16be . fromIntegral $ _hheaCaretSlopeRun hdr - put $ _hheaCaretOffset hdr - replicateM_ 4 $ putWord16be 0 - putWord16be . fromIntegral $ _hheaMetricDataFormat hdr - putWord16be $ _hheaLongHorMetricCount hdr - - get = do - ver <- getWord32be - when (ver /= 0x00010000) - (fail "Invalid HorizontalHeader (hhea) version") - startHdr <- HorizontalHeader - <$> get <*> get <*> get <*> get - <*> get <*> get <*> get - <*> (fromIntegral <$> getWord16be) - <*> (fromIntegral <$> getWord16be) - <*> get - replicateM_ 4 getWord16be -- reserved, don't care - startHdr <$> (fromIntegral <$> getWord16be) - <*> getWord16be - -data HorizontalMetric = HorizontalMetric - { _hmtxAdvanceWidth :: {-# UNPACK #-} !Word16 - , _hmtxLeftSideBearing :: {-# UNPACK #-} !Int16 - } - deriving (Eq, Show) - -instance Binary HorizontalMetric where - put (HorizontalMetric adv bear) = - putWord16be adv >> putWord16be (fromIntegral bear) - - get = HorizontalMetric <$> g16 <*> (fromIntegral <$> g16) - where g16 = getWord16be - -data HorizontalMetricsTable = HorizontalMetricsTable - { _glyphMetrics :: !(V.Vector HorizontalMetric) - } - deriving (Eq, Show) - -getHorizontalMetrics :: Int -- ^ Metrics count - -> Int -- ^ Glyph count - -> Get HorizontalMetricsTable -getHorizontalMetrics numberOfMetrics glyphCount = do - hMetrics <- V.replicateM numberOfMetrics get - let lastAdvance = _hmtxAdvanceWidth $ V.last hMetrics - run <- V.replicateM sideBearingCount $ - HorizontalMetric lastAdvance . fromIntegral <$> getWord16be - return $ HorizontalMetricsTable $ V.concat [hMetrics, run] - where - sideBearingCount = glyphCount - numberOfMetrics - +module Graphics.Text.TrueType.HorizontalInfo + ( HorizontalHeader( .. ) + , HorizontalMetricsTable( .. ) + , HorizontalMetric( .. ) + , getHorizontalMetrics + ) where + +import Control.Applicative( (<$>), (<*>) ) +import Control.DeepSeq( NFData( .. ) ) +import Control.Monad( when, replicateM_ ) +import Data.Word( Word16 ) +import Data.Int( Int16 ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( Get, getWord16be, getWord32be ) +import Data.Binary.Put( putWord16be, putWord32be ) +import qualified Data.Vector as V + +import Graphics.Text.TrueType.Types + +data HorizontalHeader = HorizontalHeader + { -- | Distance from baseline of highest ascender + _hheaAscent :: {-# UNPACK #-} !FWord + -- | Distance from baseline of lowest descender + , _hheaDescent :: {-# UNPACK #-} !FWord + -- | typographic line gap + , _hheaLineGap :: {-# UNPACK #-} !FWord + -- | must be consistent with horizontal metrics + , _hheaAdvanceWidthMax :: {-# UNPACK #-} !FWord + -- | must be consistent with horizontal metrics + , _hheaMinLeftSideBearing :: {-# UNPACK #-} !FWord + -- | must be consistent with horizontal metrics + , _hheaMinRightSideBearing :: {-# UNPACK #-} !FWord + -- | max(lsb + (xMax-xMin)) + , _hheaXmaxExtent :: {-# UNPACK #-} !FWord + -- | used to calculate the slope of the caret + -- (rise/run) set to 1 for vertical caret + , _hheaCaretSlopeRise :: {-# UNPACK #-} !Int16 + -- | 0 for vertical + , _hheaCaretSlopeRun :: {-# UNPACK #-} !Int16 + -- | set value to 0 for non-slanted fonts + , _hheaCaretOffset :: {-# UNPACK #-} !FWord + -- | 0 for current format + , _hheaMetricDataFormat :: {-# UNPACK #-} !Int16 + -- | number of advance widths in metrics table + , _hheaLongHorMetricCount :: {-# UNPACK #-} !Word16 + } + deriving (Eq, Show) + +instance NFData HorizontalHeader where + rnf (HorizontalHeader {}) = () + +instance Binary HorizontalHeader where + put hdr = do + putWord32be 0x00010000 + put $ _hheaAscent hdr + put $ _hheaDescent hdr + put $ _hheaLineGap hdr + put $ _hheaAdvanceWidthMax hdr + put $ _hheaMinLeftSideBearing hdr + put $ _hheaMinRightSideBearing hdr + put $ _hheaXmaxExtent hdr + putWord16be . fromIntegral $ _hheaCaretSlopeRise hdr + putWord16be . fromIntegral $ _hheaCaretSlopeRun hdr + put $ _hheaCaretOffset hdr + replicateM_ 4 $ putWord16be 0 + putWord16be . fromIntegral $ _hheaMetricDataFormat hdr + putWord16be $ _hheaLongHorMetricCount hdr + + get = do + ver <- getWord32be + when (ver /= 0x00010000) + (fail "Invalid HorizontalHeader (hhea) version") + startHdr <- HorizontalHeader + <$> get <*> get <*> get <*> get + <*> get <*> get <*> get + <*> (fromIntegral <$> getWord16be) + <*> (fromIntegral <$> getWord16be) + <*> get + replicateM_ 4 getWord16be -- reserved, don't care + startHdr <$> (fromIntegral <$> getWord16be) + <*> getWord16be + +data HorizontalMetric = HorizontalMetric + { _hmtxAdvanceWidth :: {-# UNPACK #-} !Word16 + , _hmtxLeftSideBearing :: {-# UNPACK #-} !Int16 + } + deriving (Eq, Show) + +instance Binary HorizontalMetric where + put (HorizontalMetric adv bear) = + putWord16be adv >> putWord16be (fromIntegral bear) + + get = HorizontalMetric <$> g16 <*> (fromIntegral <$> g16) + where g16 = getWord16be + +data HorizontalMetricsTable = HorizontalMetricsTable + { _glyphMetrics :: !(V.Vector HorizontalMetric) + } + deriving (Eq, Show) + +getHorizontalMetrics :: Int -- ^ Metrics count + -> Int -- ^ Glyph count + -> Get HorizontalMetricsTable +getHorizontalMetrics numberOfMetrics glyphCount = do + hMetrics <- V.replicateM numberOfMetrics get + let lastAdvance = _hmtxAdvanceWidth $ V.last hMetrics + run <- V.replicateM sideBearingCount $ + HorizontalMetric lastAdvance . fromIntegral <$> getWord16be + return $ HorizontalMetricsTable $ V.concat [hMetrics, run] + where + sideBearingCount = glyphCount - numberOfMetrics + diff --git a/src/Graphics/Text/TrueType/LanguageIds.hs b/src/Graphics/Text/TrueType/LanguageIds.hs --- a/src/Graphics/Text/TrueType/LanguageIds.hs +++ b/src/Graphics/Text/TrueType/LanguageIds.hs @@ -1,324 +1,327 @@ -{-# LANGUAGE FlexibleInstances #-} -module Graphics.Text.TrueType.LanguageIds - ( PlatformId( .. ) - , UnicodePlatformSpecific( .. ) - , MacPlatformId( .. ) - , MacLanguage( .. ) - ) where - -import Control.Applicative( (<$>) ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( getWord16be ) -import Data.Binary.Put( putWord16be ) -import Data.Word( Word16 ) -import qualified Data.Map.Strict as M - -data PlatformId - = PlatformUnicode -- ^ 0 - | PlatformMacintosh -- ^ 1 - | PlatformISO -- ^ 2 - | PlatformWindows -- ^ 3 - | PlatformCustom -- ^ 4 - | PlatformId Word16 - deriving (Eq, Show) - -instance Binary PlatformId where - put = p where - p16 = putWord16be - p PlatformUnicode = p16 0 - p PlatformMacintosh = p16 1 - p PlatformISO = p16 2 - p PlatformWindows = p16 3 - p PlatformCustom = p16 4 - p (PlatformId v) = p16 v - - get = do - val <- getWord16be - return $ case val of - 0 -> PlatformUnicode - 1 -> PlatformMacintosh - 2 -> PlatformISO - 3 -> PlatformWindows - 4 -> PlatformCustom - n -> PlatformId n - -data UnicodePlatformSpecific - = UnicodePlatform1_0 - | UnicodePlatform1_1 - | UnicodeISO10645 - | UnicodeBMPOnly2_0 - | UnicodeFull2_0 - | UnicodeVariation - | UnicodeFull - deriving (Eq, Show) - -unicodePlatformSpecificToId :: UnicodePlatformSpecific -> Word16 -unicodePlatformSpecificToId = go - where - go UnicodePlatform1_0 = 0 - go UnicodePlatform1_1 = 1 - go UnicodeISO10645 = 2 - go UnicodeBMPOnly2_0 = 3 - go UnicodeFull2_0 = 4 - go UnicodeVariation = 5 - go UnicodeFull = 6 - -instance Binary UnicodePlatformSpecific where - put = putWord16be . unicodePlatformSpecificToId - - get = do - v <- getWord16be - return $ case v of - 0 -> UnicodePlatform1_0 - 1 -> UnicodePlatform1_1 - 2 -> UnicodeISO10645 - 3 -> UnicodeBMPOnly2_0 - 4 -> UnicodeFull2_0 - 5 -> UnicodeVariation - 6 -> UnicodeFull - _ -> UnicodeFull - -data MacPlatformId - = MacSpecificRoman - | MacSpecificJapanese - | MacSpecificChineseTraditional - | MacSpecificKorean - | MacSpecificArabic - | MacSpecificHebrew - | MacSpecificGreek - | MacSpecificRussian - | MacSpecificRSymbol - | MacSpecificDevanagari - | MacSpecificGurmukhi - | MacSpecificGujarati - | MacSpecificOriya - | MacSpecificBengali - | MacSpecificTamil - | MacSpecificTelugu - | MacSpecificKannada - | MacSpecificMalayalam - | MacSpecificSinhalese - | MacSpecificBurmese - | MacSpecificKhmer - | MacSpecificThai - | MacSpecificLaotian - | MacSpecificGeorgian - | MacSpecificArmenian - | MacSpecificChineseSimplified - | MacSpecificTibetan - | MacSpecificMongolian - | MacSpecificGeez - | MacSpecificSlavic - | MacSpecificVietnamese - | MacSpecificSindhi - | MacSpecificUninterpreted - deriving (Eq, Ord, Show) - -macSpecifcIdList :: [MacPlatformId] -macSpecifcIdList = - [ MacSpecificRoman, MacSpecificJapanese, MacSpecificChineseTraditional - , MacSpecificKorean, MacSpecificArabic, MacSpecificHebrew - , MacSpecificGreek, MacSpecificRussian, MacSpecificRSymbol - , MacSpecificDevanagari, MacSpecificGurmukhi, MacSpecificGujarati - , MacSpecificOriya, MacSpecificBengali, MacSpecificTamil - , MacSpecificTelugu, MacSpecificKannada, MacSpecificMalayalam - , MacSpecificSinhalese, MacSpecificBurmese, MacSpecificKhmer - , MacSpecificThai, MacSpecificLaotian, MacSpecificGeorgian - , MacSpecificArmenian, MacSpecificChineseSimplified, MacSpecificTibetan - , MacSpecificMongolian, MacSpecificGeez, MacSpecificSlavic - , MacSpecificVietnamese, MacSpecificSindhi, MacSpecificUninterpreted - ] - - -prepareSpecificMaps :: Ord a => [a] -> (M.Map a Word16, M.Map Word16 a) -prepareSpecificMaps lst = (toWord, toPlatform) - where - toWord = M.fromList $ zip lst [0 ..] - toPlatform = M.fromList $ zip [0 ..] lst - -mapSpecifcIdMaps :: ( M.Map MacPlatformId Word16 - , M.Map Word16 MacPlatformId ) -mapSpecifcIdMaps = prepareSpecificMaps macSpecifcIdList - -instance Binary MacPlatformId where - get = finder <$> getWord16be - where - (_, to) = mapSpecifcIdMaps - finder v = M.findWithDefault MacSpecificUninterpreted v to - - put v = putWord16be val - where - (from, _) = mapSpecifcIdMaps - val = M.findWithDefault 32 v from - -data MacLanguage - = MacLangEnglish - | MacLangFrench - | MacLangGerman - | MacLangItalian - | MacLangDutch - | MacLangSwedish - | MacLangSpanish - | MacLangDanish - | MacLangPortuguese - | MacLangNorwegian - | MacLangHebrew - | MacLangJapanese - | MacLangArabic - | MacLangFinnish - | MacLangGreek - | MacLangInuktitut - | MacLangIcelandic - | MacLangMaltese - | MacLangTurkish - | MacLangCroatian - | MacLangChineseTraditional - | MacLangUrdu - | MacLangHindi - | MacLangThai - | MacLangKorean - | MacLangLithuanian - | MacLangPolish - | MacLangHungarian - | MacLangEstonian - | MacLangLatvian - | MacLangSami - | MacLangFaroese - | MacLangFarsiPersian - | MacLangRussian - | MacLangChineseSimplified - | MacLangFlemish - | MacLangIrishGaelic - | MacLangAlbanian - | MacLangRomanian - | MacLangCzech - | MacLangSlovak - | MacLangSlovenian - | MacLangYiddish - | MacLangSerbian - | MacLangMacedonian - | MacLangBulgarian - | MacLangUkrainian - | MacLangByelorussian - | MacLangUzbek - | MacLangKazakh - | MacLangAzerbaijaniCyrillic - | MacLangAzerbaijaniArabic - | MacLangArmenian - | MacLangGeorgian - | MacLangMoldavian - | MacLangKirghiz - | MacLangTajiki - | MacLangTurkmen - | MacLangMongolian - | MacLangMongolianCyrillic - | MacLangPashto - | MacLangKurdish - | MacLangKashmiri - | MacLangSindhi - | MacLangTibetan - | MacLangNepali - | MacLangSanskrit - | MacLangMarathi - | MacLangBengali - | MacLangAssamese - | MacLangGujarati - | MacLangPunjabi - | MacLangOriya - | MacLangMalayalam - | MacLangKannada - | MacLangTamil - | MacLangTelugu - | MacLangSinhalese - | MacLangBurmese - | MacLangKhmer - | MacLangLao - | MacLangVietnamese - | MacLangIndonesian - | MacLangTagalong - | MacLangMalayRoman - | MacLangMalayArabic - | MacLangAmharic - | MacLangTigrinya - | MacLangGalla - | MacLangSomali - | MacLangSwahili - | MacLangKinyarwandaRuanda - | MacLangRundi - | MacLangNyanjaChewa - | MacLangMalagasy - | MacLangEsperanto - | MacLangWelsh - | MacLangBasque - | MacLangCatalan - | MacLangLatin - | MacLangQuenchua - | MacLangGuarani - | MacLangAymara - | MacLangTatar - | MacLangUighur - | MacLangDzongkha - | MacLangJavanese - | MacLangSundanese - | MacLangGalician - | MacLangAfrikaans - | MacLangBreton - | MacLangScottishGaelic - | MacLangManxGaelic - | MacLangIrishGaelicWithDot - | MacLangTongan - | MacLangGreekPolytonic - | MacLangGreenlandic - | MacLangAzerbaijani - deriving (Eq, Ord, Show) - -macLangList :: [MacLanguage] -macLangList = - [ MacLangEnglish , MacLangFrench , MacLangGerman , MacLangItalian - , MacLangDutch , MacLangSwedish , MacLangSpanish , MacLangDanish - , MacLangPortuguese , MacLangNorwegian , MacLangHebrew , MacLangJapanese - , MacLangArabic , MacLangFinnish , MacLangGreek , MacLangInuktitut - , MacLangIcelandic , MacLangMaltese , MacLangTurkish , MacLangCroatian - , MacLangChineseTraditional , MacLangUrdu , MacLangHindi , MacLangThai - , MacLangKorean , MacLangLithuanian , MacLangPolish , MacLangHungarian - , MacLangEstonian , MacLangLatvian , MacLangSami , MacLangFaroese - , MacLangFarsiPersian , MacLangRussian , MacLangChineseSimplified - , MacLangFlemish - , MacLangIrishGaelic , MacLangAlbanian , MacLangRomanian , MacLangCzech - , MacLangSlovak , MacLangSlovenian , MacLangYiddish , MacLangSerbian - , MacLangMacedonian , MacLangBulgarian , MacLangUkrainian , MacLangByelorussian - , MacLangUzbek , MacLangKazakh , MacLangAzerbaijaniCyrillic - , MacLangAzerbaijaniArabic - , MacLangArmenian , MacLangGeorgian , MacLangMoldavian , MacLangKirghiz - , MacLangTajiki , MacLangTurkmen , MacLangMongolian , MacLangMongolianCyrillic - , MacLangPashto , MacLangKurdish , MacLangKashmiri , MacLangSindhi - , MacLangTibetan , MacLangNepali , MacLangSanskrit , MacLangMarathi - , MacLangBengali , MacLangAssamese , MacLangGujarati , MacLangPunjabi - , MacLangOriya , MacLangMalayalam , MacLangKannada , MacLangTamil - , MacLangTelugu , MacLangSinhalese , MacLangBurmese , MacLangKhmer - , MacLangLao , MacLangVietnamese , MacLangIndonesian , MacLangTagalong - , MacLangMalayRoman , MacLangMalayArabic , MacLangAmharic , MacLangTigrinya - , MacLangGalla , MacLangSomali , MacLangSwahili , MacLangKinyarwandaRuanda - , MacLangRundi , MacLangNyanjaChewa , MacLangMalagasy , MacLangEsperanto - , MacLangWelsh , MacLangBasque , MacLangCatalan , MacLangLatin - , MacLangQuenchua , MacLangGuarani , MacLangAymara , MacLangTatar - , MacLangUighur , MacLangDzongkha , MacLangJavanese , MacLangSundanese - , MacLangGalician , MacLangAfrikaans , MacLangBreton , MacLangScottishGaelic - , MacLangManxGaelic , MacLangIrishGaelicWithDot , MacLangTongan - , MacLangGreekPolytonic , MacLangGreenlandic , MacLangAzerbaijani - ] - -mapLangIdMaps :: (M.Map MacLanguage Word16, M.Map Word16 MacLanguage) -mapLangIdMaps = prepareSpecificMaps macLangList - -instance Binary MacLanguage where - get = finder <$> getWord16be - where - (_, to) = mapLangIdMaps - finder v = M.findWithDefault MacLangEnglish v to - - put v = putWord16be val - where - (from, _) = mapLangIdMaps - val = M.findWithDefault 0 v from - +{-# LANGUAGE FlexibleInstances #-} +module Graphics.Text.TrueType.LanguageIds + ( PlatformId( .. ) + , UnicodePlatformSpecific( .. ) + , MacPlatformId( .. ) + , MacLanguage( .. ) + , platformToWord + , unicodePlatformSpecificToId + ) where + +import Control.Applicative( (<$>) ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( getWord16be ) +import Data.Binary.Put( putWord16be ) +import Data.Word( Word16 ) +import qualified Data.Map.Strict as M + +data PlatformId + = PlatformUnicode -- ^ 0 + | PlatformMacintosh -- ^ 1 + | PlatformISO -- ^ 2 + | PlatformWindows -- ^ 3 + | PlatformCustom -- ^ 4 + | PlatformId Word16 + deriving (Eq, Show) + +instance Binary PlatformId where + put = putWord16be . platformToWord + get = do + val <- getWord16be + return $ case val of + 0 -> PlatformUnicode + 1 -> PlatformMacintosh + 2 -> PlatformISO + 3 -> PlatformWindows + 4 -> PlatformCustom + n -> PlatformId n + +platformToWord :: PlatformId -> Word16 +platformToWord = p where + p PlatformUnicode = 0 + p PlatformMacintosh = 1 + p PlatformISO = 2 + p PlatformWindows = 3 + p PlatformCustom = 4 + p (PlatformId v) = v + +data UnicodePlatformSpecific + = UnicodePlatform1_0 + | UnicodePlatform1_1 + | UnicodeISO10645 + | UnicodeBMPOnly2_0 + | UnicodeFull2_0 + | UnicodeVariation + | UnicodeFull + deriving (Eq, Show) + +unicodePlatformSpecificToId :: UnicodePlatformSpecific -> Word16 +unicodePlatformSpecificToId = go + where + go UnicodePlatform1_0 = 0 + go UnicodePlatform1_1 = 1 + go UnicodeISO10645 = 2 + go UnicodeBMPOnly2_0 = 3 + go UnicodeFull2_0 = 4 + go UnicodeVariation = 5 + go UnicodeFull = 6 + +instance Binary UnicodePlatformSpecific where + put = putWord16be . unicodePlatformSpecificToId + + get = do + v <- getWord16be + return $ case v of + 0 -> UnicodePlatform1_0 + 1 -> UnicodePlatform1_1 + 2 -> UnicodeISO10645 + 3 -> UnicodeBMPOnly2_0 + 4 -> UnicodeFull2_0 + 5 -> UnicodeVariation + 6 -> UnicodeFull + _ -> UnicodeFull + +data MacPlatformId + = MacSpecificRoman + | MacSpecificJapanese + | MacSpecificChineseTraditional + | MacSpecificKorean + | MacSpecificArabic + | MacSpecificHebrew + | MacSpecificGreek + | MacSpecificRussian + | MacSpecificRSymbol + | MacSpecificDevanagari + | MacSpecificGurmukhi + | MacSpecificGujarati + | MacSpecificOriya + | MacSpecificBengali + | MacSpecificTamil + | MacSpecificTelugu + | MacSpecificKannada + | MacSpecificMalayalam + | MacSpecificSinhalese + | MacSpecificBurmese + | MacSpecificKhmer + | MacSpecificThai + | MacSpecificLaotian + | MacSpecificGeorgian + | MacSpecificArmenian + | MacSpecificChineseSimplified + | MacSpecificTibetan + | MacSpecificMongolian + | MacSpecificGeez + | MacSpecificSlavic + | MacSpecificVietnamese + | MacSpecificSindhi + | MacSpecificUninterpreted + deriving (Eq, Ord, Show) + +macSpecifcIdList :: [MacPlatformId] +macSpecifcIdList = + [ MacSpecificRoman, MacSpecificJapanese, MacSpecificChineseTraditional + , MacSpecificKorean, MacSpecificArabic, MacSpecificHebrew + , MacSpecificGreek, MacSpecificRussian, MacSpecificRSymbol + , MacSpecificDevanagari, MacSpecificGurmukhi, MacSpecificGujarati + , MacSpecificOriya, MacSpecificBengali, MacSpecificTamil + , MacSpecificTelugu, MacSpecificKannada, MacSpecificMalayalam + , MacSpecificSinhalese, MacSpecificBurmese, MacSpecificKhmer + , MacSpecificThai, MacSpecificLaotian, MacSpecificGeorgian + , MacSpecificArmenian, MacSpecificChineseSimplified, MacSpecificTibetan + , MacSpecificMongolian, MacSpecificGeez, MacSpecificSlavic + , MacSpecificVietnamese, MacSpecificSindhi, MacSpecificUninterpreted + ] + + +prepareSpecificMaps :: Ord a => [a] -> (M.Map a Word16, M.Map Word16 a) +prepareSpecificMaps lst = (toWord, toPlatform) + where + toWord = M.fromList $ zip lst [0 ..] + toPlatform = M.fromList $ zip [0 ..] lst + +mapSpecifcIdMaps :: ( M.Map MacPlatformId Word16 + , M.Map Word16 MacPlatformId ) +mapSpecifcIdMaps = prepareSpecificMaps macSpecifcIdList + +instance Binary MacPlatformId where + get = finder <$> getWord16be + where + (_, to) = mapSpecifcIdMaps + finder v = M.findWithDefault MacSpecificUninterpreted v to + + put v = putWord16be val + where + (from, _) = mapSpecifcIdMaps + val = M.findWithDefault 32 v from + +data MacLanguage + = MacLangEnglish + | MacLangFrench + | MacLangGerman + | MacLangItalian + | MacLangDutch + | MacLangSwedish + | MacLangSpanish + | MacLangDanish + | MacLangPortuguese + | MacLangNorwegian + | MacLangHebrew + | MacLangJapanese + | MacLangArabic + | MacLangFinnish + | MacLangGreek + | MacLangInuktitut + | MacLangIcelandic + | MacLangMaltese + | MacLangTurkish + | MacLangCroatian + | MacLangChineseTraditional + | MacLangUrdu + | MacLangHindi + | MacLangThai + | MacLangKorean + | MacLangLithuanian + | MacLangPolish + | MacLangHungarian + | MacLangEstonian + | MacLangLatvian + | MacLangSami + | MacLangFaroese + | MacLangFarsiPersian + | MacLangRussian + | MacLangChineseSimplified + | MacLangFlemish + | MacLangIrishGaelic + | MacLangAlbanian + | MacLangRomanian + | MacLangCzech + | MacLangSlovak + | MacLangSlovenian + | MacLangYiddish + | MacLangSerbian + | MacLangMacedonian + | MacLangBulgarian + | MacLangUkrainian + | MacLangByelorussian + | MacLangUzbek + | MacLangKazakh + | MacLangAzerbaijaniCyrillic + | MacLangAzerbaijaniArabic + | MacLangArmenian + | MacLangGeorgian + | MacLangMoldavian + | MacLangKirghiz + | MacLangTajiki + | MacLangTurkmen + | MacLangMongolian + | MacLangMongolianCyrillic + | MacLangPashto + | MacLangKurdish + | MacLangKashmiri + | MacLangSindhi + | MacLangTibetan + | MacLangNepali + | MacLangSanskrit + | MacLangMarathi + | MacLangBengali + | MacLangAssamese + | MacLangGujarati + | MacLangPunjabi + | MacLangOriya + | MacLangMalayalam + | MacLangKannada + | MacLangTamil + | MacLangTelugu + | MacLangSinhalese + | MacLangBurmese + | MacLangKhmer + | MacLangLao + | MacLangVietnamese + | MacLangIndonesian + | MacLangTagalong + | MacLangMalayRoman + | MacLangMalayArabic + | MacLangAmharic + | MacLangTigrinya + | MacLangGalla + | MacLangSomali + | MacLangSwahili + | MacLangKinyarwandaRuanda + | MacLangRundi + | MacLangNyanjaChewa + | MacLangMalagasy + | MacLangEsperanto + | MacLangWelsh + | MacLangBasque + | MacLangCatalan + | MacLangLatin + | MacLangQuenchua + | MacLangGuarani + | MacLangAymara + | MacLangTatar + | MacLangUighur + | MacLangDzongkha + | MacLangJavanese + | MacLangSundanese + | MacLangGalician + | MacLangAfrikaans + | MacLangBreton + | MacLangScottishGaelic + | MacLangManxGaelic + | MacLangIrishGaelicWithDot + | MacLangTongan + | MacLangGreekPolytonic + | MacLangGreenlandic + | MacLangAzerbaijani + deriving (Eq, Ord, Show) + +macLangList :: [MacLanguage] +macLangList = + [ MacLangEnglish , MacLangFrench , MacLangGerman , MacLangItalian + , MacLangDutch , MacLangSwedish , MacLangSpanish , MacLangDanish + , MacLangPortuguese , MacLangNorwegian , MacLangHebrew , MacLangJapanese + , MacLangArabic , MacLangFinnish , MacLangGreek , MacLangInuktitut + , MacLangIcelandic , MacLangMaltese , MacLangTurkish , MacLangCroatian + , MacLangChineseTraditional , MacLangUrdu , MacLangHindi , MacLangThai + , MacLangKorean , MacLangLithuanian , MacLangPolish , MacLangHungarian + , MacLangEstonian , MacLangLatvian , MacLangSami , MacLangFaroese + , MacLangFarsiPersian , MacLangRussian , MacLangChineseSimplified + , MacLangFlemish + , MacLangIrishGaelic , MacLangAlbanian , MacLangRomanian , MacLangCzech + , MacLangSlovak , MacLangSlovenian , MacLangYiddish , MacLangSerbian + , MacLangMacedonian , MacLangBulgarian , MacLangUkrainian , MacLangByelorussian + , MacLangUzbek , MacLangKazakh , MacLangAzerbaijaniCyrillic + , MacLangAzerbaijaniArabic + , MacLangArmenian , MacLangGeorgian , MacLangMoldavian , MacLangKirghiz + , MacLangTajiki , MacLangTurkmen , MacLangMongolian , MacLangMongolianCyrillic + , MacLangPashto , MacLangKurdish , MacLangKashmiri , MacLangSindhi + , MacLangTibetan , MacLangNepali , MacLangSanskrit , MacLangMarathi + , MacLangBengali , MacLangAssamese , MacLangGujarati , MacLangPunjabi + , MacLangOriya , MacLangMalayalam , MacLangKannada , MacLangTamil + , MacLangTelugu , MacLangSinhalese , MacLangBurmese , MacLangKhmer + , MacLangLao , MacLangVietnamese , MacLangIndonesian , MacLangTagalong + , MacLangMalayRoman , MacLangMalayArabic , MacLangAmharic , MacLangTigrinya + , MacLangGalla , MacLangSomali , MacLangSwahili , MacLangKinyarwandaRuanda + , MacLangRundi , MacLangNyanjaChewa , MacLangMalagasy , MacLangEsperanto + , MacLangWelsh , MacLangBasque , MacLangCatalan , MacLangLatin + , MacLangQuenchua , MacLangGuarani , MacLangAymara , MacLangTatar + , MacLangUighur , MacLangDzongkha , MacLangJavanese , MacLangSundanese + , MacLangGalician , MacLangAfrikaans , MacLangBreton , MacLangScottishGaelic + , MacLangManxGaelic , MacLangIrishGaelicWithDot , MacLangTongan + , MacLangGreekPolytonic , MacLangGreenlandic , MacLangAzerbaijani + ] + +mapLangIdMaps :: (M.Map MacLanguage Word16, M.Map Word16 MacLanguage) +mapLangIdMaps = prepareSpecificMaps macLangList + +instance Binary MacLanguage where + get = finder <$> getWord16be + where + (_, to) = mapLangIdMaps + finder v = M.findWithDefault MacLangEnglish v to + + put v = putWord16be val + where + (from, _) = mapLangIdMaps + val = M.findWithDefault 0 v from + diff --git a/src/Graphics/Text/TrueType/MaxpTable.hs b/src/Graphics/Text/TrueType/MaxpTable.hs --- a/src/Graphics/Text/TrueType/MaxpTable.hs +++ b/src/Graphics/Text/TrueType/MaxpTable.hs @@ -1,51 +1,55 @@ -module Graphics.Text.TrueType.MaxpTable( MaxpTable( .. ) ) where - -import Control.Applicative( (<$>), (<*>) ) -import Data.Word( Word16 ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( getWord16be ) - -import Graphics.Text.TrueType.Types - -data MaxpTable = MaxpTable - { -- | version number 0x00010000 for version 1.0. - _maxpTableVersion :: !Fixed - -- | The number of glyphs in the font. - , _maxpnumGlyphs :: !Word16 - -- | Maximum points in a non-composite glyph. - , _maxpmaxPoints :: !Word16 - -- | Maximum contours in a non-composite glyph. - , _maxpmaxContours :: !Word16 - -- | Maximum points in a composite glyph. - , _maxpmaxCompositePoints :: !Word16 - -- | Maximum contours in a composite glyph. - , _maxpmaxCompositeContours :: !Word16 - -- | 1 if instructions do not use the twilight zone (Z0), or 2 if instructions do use Z0; should be set to 2 in most cases. - , _maxpmaxZones :: !Word16 - -- | Maximum points used in Z0. - , _maxpmaxTwilightPoints :: !Word16 - -- | Number of Storage Area locations. - , _maxpmaxStorage :: !Word16 - -- | Number of FDEFs. - , _maxpmaxFunctionDefs :: !Word16 - -- | Number of IDEFs. - , _maxpmaxInstructionDefs :: !Word16 - -- | Maximum stack depth . - , _maxpmaxStackElements :: !Word16 - -- | Maximum byte count for glyph instructions. - , _maxpmaxSizeOfInstructions :: !Word16 - -- | Maximum number of components referenced at "top level" for any composite glyph. - , _maxpmaxComponentElements :: !Word16 - -- | Maximum levels of recursion; 1 for simple components. - , _maxpmaxComponentDepth :: !Word16 - } - deriving (Eq, Show) - -instance Binary MaxpTable where - put _ = fail "Unimplemented" - get = MaxpTable - <$> get <*> g16 <*> g16 <*> g16 <*> g16 <*> g16 - <*> g16 <*> g16 <*> g16 <*> g16 <*> g16 <*> g16 - <*> g16 <*> g16 <*> g16 - where g16 = getWord16be - +module Graphics.Text.TrueType.MaxpTable( MaxpTable( .. ) ) where + +import Control.Applicative( (<$>), (<*>) ) +import Control.DeepSeq( NFData( .. ) ) +import Data.Word( Word16 ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( getWord16be ) + +import Graphics.Text.TrueType.Types + +data MaxpTable = MaxpTable + { -- | version number 0x00010000 for version 1.0. + _maxpTableVersion :: !Fixed + -- | The number of glyphs in the font. + , _maxpnumGlyphs :: !Word16 + -- | Maximum points in a non-composite glyph. + , _maxpmaxPoints :: !Word16 + -- | Maximum contours in a non-composite glyph. + , _maxpmaxContours :: !Word16 + -- | Maximum points in a composite glyph. + , _maxpmaxCompositePoints :: !Word16 + -- | Maximum contours in a composite glyph. + , _maxpmaxCompositeContours :: !Word16 + -- | 1 if instructions do not use the twilight zone (Z0), or 2 if instructions do use Z0; should be set to 2 in most cases. + , _maxpmaxZones :: !Word16 + -- | Maximum points used in Z0. + , _maxpmaxTwilightPoints :: !Word16 + -- | Number of Storage Area locations. + , _maxpmaxStorage :: !Word16 + -- | Number of FDEFs. + , _maxpmaxFunctionDefs :: !Word16 + -- | Number of IDEFs. + , _maxpmaxInstructionDefs :: !Word16 + -- | Maximum stack depth . + , _maxpmaxStackElements :: !Word16 + -- | Maximum byte count for glyph instructions. + , _maxpmaxSizeOfInstructions :: !Word16 + -- | Maximum number of components referenced at "top level" for any composite glyph. + , _maxpmaxComponentElements :: !Word16 + -- | Maximum levels of recursion; 1 for simple components. + , _maxpmaxComponentDepth :: !Word16 + } + deriving (Eq, Show) + +instance NFData MaxpTable where + rnf (MaxpTable {}) = () + +instance Binary MaxpTable where + put _ = fail "Unimplemented" + get = MaxpTable + <$> get <*> g16 <*> g16 <*> g16 <*> g16 <*> g16 + <*> g16 <*> g16 <*> g16 <*> g16 <*> g16 <*> g16 + <*> g16 <*> g16 <*> g16 + where g16 = getWord16be + diff --git a/src/Graphics/Text/TrueType/Name.hs b/src/Graphics/Text/TrueType/Name.hs --- a/src/Graphics/Text/TrueType/Name.hs +++ b/src/Graphics/Text/TrueType/Name.hs @@ -1,63 +1,117 @@ -module Graphics.Text.TrueType.Name - ( NameTable - , NameRecords - ) where - -import Control.Applicative( (<$>), (<*>), pure ) -import Control.Monad( when, replicateM ) -import Data.Function( on ) -import Data.List( maximumBy ) -import Data.Monoid( mempty ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( getWord16be, getByteString ) -import Data.Binary.Put( putWord16be ) -import Data.Word( Word16 ) -import qualified Data.Vector as V -import qualified Data.ByteString as B - -data NameTable = NameTable - { _ntRecords :: !(V.Vector NameRecords) } - deriving Show - -instance Binary NameTable where - put _ = fail "Binary.put NameTable - unimplemented" - get = do - nameFormatId <- getWord16be - when (nameFormatId /= 0) $ - fail "Invalid name table format" - count <- getWord16be - stringOffset <- getWord16be - records <- replicateM (fromIntegral count) get - let maxRec = maximumBy (compare `on` _nrOffset) records - toFetch = fromIntegral (_nrOffset maxRec) + fromIntegral (_nrLength maxRec) - - fromIntegral stringOffset - - strTable <- getByteString toFetch - let fetcher r = r { _nrString = B.take iLength $ B.drop iOffset strTable } - where iLength = fromIntegral $ _nrLength r - iOffset = fromIntegral $ _nrOffset r - - return . NameTable . V.fromListN (fromIntegral count) $ map fetcher records - -data NameRecords = NameRecords - { _nrPlatoformId :: {-# UNPACK #-} !Word16 - , _nrPlatformSpecificId :: {-# UNPACK #-} !Word16 - , _nrLanguageId :: {-# UNPACK #-} !Word16 - , _nrNameId :: {-# UNPACK #-} !Word16 - , _nrLength :: {-# UNPACK #-} !Word16 - , _nrOffset :: {-# UNPACK #-} !Word16 - , _nrString :: !B.ByteString - } - deriving Show - -instance Binary NameRecords where - get = NameRecords <$> g16 <*> g16 <*> g16 - <*> g16 <*> g16 <*> g16 - <*> pure mempty - where g16 = getWord16be - - put (NameRecords p ps l n len ofs _) = - p16 p >> p16 ps >> p16 l >> p16 n >> p16 len >> p16 ofs - where p16 = putWord16be - - +module Graphics.Text.TrueType.Name + ( NameTable + , NameRecords + , fontFamilyName + ) where + +import Control.DeepSeq( NFData( .. ) ) +import Control.Applicative( (<$>), (<*>), pure ) +import Control.Monad( when, replicateM ) +import Data.Foldable( asum ) +import Data.Function( on ) +import Data.List( maximumBy ) +import Data.Monoid( mempty ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( getWord16be, getByteString ) +import Data.Binary.Put( putWord16be ) +import Data.Word( Word16 ) +import qualified Data.Vector as V +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +import Graphics.Text.TrueType.LanguageIds + +data NameTable = NameTable + { _ntRecords :: !(V.Vector NameRecords) } + deriving Show + +instance NFData NameTable where + rnf (NameTable {}) = () + +instance Binary NameTable where + put _ = fail "Binary.put NameTable - unimplemented" + get = do + nameFormatId <- getWord16be + when (nameFormatId /= 0) $ + fail "Invalid name table format" + count <- getWord16be + stringOffset <- getWord16be + records <- replicateM (fromIntegral count) get + let maxRec = maximumBy (compare `on` _nrOffset) records + toFetch = fromIntegral (_nrOffset maxRec) + fromIntegral (_nrLength maxRec) + - fromIntegral stringOffset + + strTable <- getByteString toFetch + let fetcher r = r { _nrString = B.take iLength $ B.drop iOffset strTable } + where iLength = fromIntegral $ _nrLength r + iOffset = fromIntegral $ _nrOffset r + + return . NameTable . V.fromListN (fromIntegral count) $ map fetcher records + +data NameRecords = NameRecords + { _nrPlatoformId :: {-# UNPACK #-} !Word16 + , _nrPlatformSpecificId :: {-# UNPACK #-} !Word16 + , _nrLanguageId :: {-# UNPACK #-} !Word16 + , _nrNameId :: {-# UNPACK #-} !Word16 + , _nrLength :: {-# UNPACK #-} !Word16 + , _nrOffset :: {-# UNPACK #-} !Word16 + , _nrString :: !B.ByteString + } + deriving Show + +fontFamilyName :: NameTable -> T.Text +fontFamilyName (NameTable { _ntRecords = records }) = + maybe T.empty id . asum $ transform <$> + [ (selectorUnicode, utf16Decoder) + , (selectorMac, utf8Decoder) + , (selectorWin0, utf16Decoder) + , (selectorWin1, utf16Decoder) + ] + where + utf16Decoder = TE.decodeUtf16BE . _nrString + utf8Decoder = TE.decodeUtf8 . _nrString + transform (selector, decoder) = + decoder <$> V.find selector records + + fontFamilyId = 1 + + windowsPlatform = + platformToWord PlatformWindows + selectorWin0 r = + _nrNameId r == fontFamilyId && + _nrPlatoformId r == windowsPlatform && + _nrPlatformSpecificId r == 0 + + selectorWin1 r = + _nrNameId r == fontFamilyId && + _nrPlatoformId r == windowsPlatform && + _nrPlatformSpecificId r == 1 + + macPlatform = + platformToWord PlatformMacintosh + selectorMac r = + _nrNameId r == fontFamilyId && + _nrPlatoformId r == macPlatform && + _nrPlatformSpecificId r == 0 + + unicodePlatform = + platformToWord PlatformUnicode + semanticUnicode2 = + unicodePlatformSpecificToId UnicodeBMPOnly2_0 + selectorUnicode r = + _nrNameId r == fontFamilyId && + _nrPlatoformId r == unicodePlatform && + _nrPlatformSpecificId r == semanticUnicode2 + +instance Binary NameRecords where + get = NameRecords <$> g16 <*> g16 <*> g16 + <*> g16 <*> g16 <*> g16 + <*> pure mempty + where g16 = getWord16be + + put (NameRecords p ps l n len ofs _) = + p16 p >> p16 ps >> p16 l >> p16 n >> p16 len >> p16 ofs + where p16 = putWord16be + + diff --git a/src/Graphics/Text/TrueType/OffsetTable.hs b/src/Graphics/Text/TrueType/OffsetTable.hs --- a/src/Graphics/Text/TrueType/OffsetTable.hs +++ b/src/Graphics/Text/TrueType/OffsetTable.hs @@ -1,79 +1,85 @@ -module Graphics.Text.TrueType.OffsetTable - ( OffsetTableHeader( .. ) - , OffsetTable( .. ) - , TableDirectoryEntry( .. ) - ) where - -import Control.Applicative( (<$>), (<*>) ) -import Data.Word( Word16, Word32 ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( getWord16be - , getWord32be - , getByteString - ) - -import Data.Binary.Put( putWord16be - , putWord32be - , putByteString - ) - -import qualified Data.Vector as V -import qualified Data.ByteString.Char8 as BC - -import Graphics.Text.TrueType.Types - -data OffsetTableHeader = OffsetTableHeader - { -- | sfnt version 0x00010000 for version 1.0. - _othSfntVersion :: !Fixed - -- | numTables Number of tables. - , _othTableCount :: !Word16 - -- | searchRange (Maximum power of 2 ? numTables) x 16. - , _othSearchRange :: !Word16 - -- | entrySelector Log2(maximum power of 2 ? numTables). - , _othEntrySelector :: !Word16 - -- | rangeShift NumTables x 16-searchRange. - , _othRangeShift :: !Word16 - } - deriving (Eq, Show) - -instance Binary OffsetTableHeader where - get = OffsetTableHeader <$> get <*> g16 <*> g16 <*> g16 <*> g16 - where g16 = getWord16be - put (OffsetTableHeader ver c sr es rs) = - put ver >> p16 c >> p16 sr >> p16 es >> p16 rs - where p16 = putWord16be - -data TableDirectoryEntry = TableDirectoryEntry - { -- | tag 4 -byte identifier. - _tdeTag :: !BC.ByteString - -- | CheckSum for this table. - , _tdeChecksum :: !Word32 - -- | Offset from beginning of TrueType font file. - , _tdeOffset :: !Word32 - -- | Length of this table. - , _tdeLength :: !Word32 - } - deriving (Eq, Show) - -instance Binary TableDirectoryEntry where - get = TableDirectoryEntry <$> getByteString 4 <*> g32 <*> g32 <*> g32 - where g32 = getWord32be - put (TableDirectoryEntry tag chk offset ln) = - putByteString tag >> p32 chk >> p32 offset >> p32 ln - where p32 = putWord32be - -data OffsetTable = OffsetTable - { _otHeader :: !OffsetTableHeader - , _otEntries :: !(V.Vector TableDirectoryEntry) - } - deriving (Eq, Show) - -instance Binary OffsetTable where - put (OffsetTable hdr entries) = - put hdr >> V.forM_ entries put - - get = do - hdr <- get - let count = fromIntegral $ _othTableCount hdr - OffsetTable hdr <$> V.replicateM count get - +module Graphics.Text.TrueType.OffsetTable + ( OffsetTableHeader( .. ) + , OffsetTable( .. ) + , TableDirectoryEntry( .. ) + , filterTable + ) where + +import Control.Applicative( (<$>), (<*>) ) +import Data.Word( Word16, Word32 ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( getWord16be + , getWord32be + , getByteString + ) + +import Data.Binary.Put( putWord16be + , putWord32be + , putByteString + ) + +import qualified Data.Vector as V +import qualified Data.ByteString.Char8 as BC + +import Graphics.Text.TrueType.Types + +data OffsetTableHeader = OffsetTableHeader + { -- | sfnt version 0x00010000 for version 1.0. + _othSfntVersion :: !Fixed + -- | numTables Number of tables. + , _othTableCount :: !Word16 + -- | searchRange (Maximum power of 2 ? numTables) x 16. + , _othSearchRange :: !Word16 + -- | entrySelector Log2(maximum power of 2 ? numTables). + , _othEntrySelector :: !Word16 + -- | rangeShift NumTables x 16-searchRange. + , _othRangeShift :: !Word16 + } + deriving (Eq, Show) + +instance Binary OffsetTableHeader where + get = OffsetTableHeader <$> get <*> g16 <*> g16 <*> g16 <*> g16 + where g16 = getWord16be + put (OffsetTableHeader ver c sr es rs) = + put ver >> p16 c >> p16 sr >> p16 es >> p16 rs + where p16 = putWord16be + +data TableDirectoryEntry = TableDirectoryEntry + { -- | tag 4 -byte identifier. + _tdeTag :: !BC.ByteString + -- | CheckSum for this table. + , _tdeChecksum :: !Word32 + -- | Offset from beginning of TrueType font file. + , _tdeOffset :: !Word32 + -- | Length of this table. + , _tdeLength :: !Word32 + } + deriving (Eq, Show) + +filterTable :: (BC.ByteString -> Bool) -> OffsetTable + -> OffsetTable +filterTable f table = + table { _otEntries = V.filter (f . _tdeTag) $ _otEntries table } + +instance Binary TableDirectoryEntry where + get = TableDirectoryEntry <$> getByteString 4 <*> g32 <*> g32 <*> g32 + where g32 = getWord32be + put (TableDirectoryEntry tag chk offset ln) = + putByteString tag >> p32 chk >> p32 offset >> p32 ln + where p32 = putWord32be + +data OffsetTable = OffsetTable + { _otHeader :: !OffsetTableHeader + , _otEntries :: !(V.Vector TableDirectoryEntry) + } + deriving (Eq, Show) + +instance Binary OffsetTable where + put (OffsetTable hdr entries) = + put hdr >> V.forM_ entries put + + get = do + hdr <- get + let count = fromIntegral $ _othTableCount hdr + OffsetTable hdr <$> V.replicateM count get + diff --git a/src/Graphics/Text/TrueType/Types.hs b/src/Graphics/Text/TrueType/Types.hs --- a/src/Graphics/Text/TrueType/Types.hs +++ b/src/Graphics/Text/TrueType/Types.hs @@ -1,44 +1,44 @@ -module Graphics.Text.TrueType.Types - ( Fixed - , FWord - , F26Dot6( .. ) - ) where - -import Data.Int( Int32 ) -import Control.Applicative( (<$>), (<*>) ) -import Data.Word( Word16 ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( getWord16be) -import Data.Binary.Put( putWord16be ) - -data Fixed = Fixed Word16 Word16 - deriving (Eq, Show) - -instance Binary Fixed where - get = Fixed <$> getWord16be <*> getWord16be - put (Fixed a b) = putWord16be a >> putWord16be b - -newtype FWord = FWord Word16 - deriving (Eq, Show) - -instance Binary FWord where - put (FWord w) = putWord16be w - get = FWord <$> getWord16be - -newtype F26Dot6 = F26Dot6 Int32 - deriving (Eq, Show, Ord) - -instance Num F26Dot6 where - (F26Dot6 a) + (F26Dot6 b) = F26Dot6 $ a + b - (F26Dot6 a) - (F26Dot6 b) = F26Dot6 $ a - b - (F26Dot6 a) * (F26Dot6 b) = F26Dot6 $ (a * b) `div` 64 - negate (F26Dot6 a) = F26Dot6 $ negate a - abs (F26Dot6 a) = F26Dot6 $ abs a - signum (F26Dot6 a) = F26Dot6 $ signum a * 64 - fromInteger a = F26Dot6 $ fromInteger a * 64 - -instance Fractional F26Dot6 where - fromRational a = F26Dot6 $ floor ad - where ad = fromRational a * 64 :: Double - (F26Dot6 a) / (F26Dot6 b) = F26Dot6 $ (a * 64) `div` b - +module Graphics.Text.TrueType.Types + ( Fixed + , FWord + , F26Dot6( .. ) + ) where + +import Data.Int( Int32 ) +import Control.Applicative( (<$>), (<*>) ) +import Data.Word( Word16 ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( getWord16be) +import Data.Binary.Put( putWord16be ) + +data Fixed = Fixed Word16 Word16 + deriving (Eq, Show) + +instance Binary Fixed where + get = Fixed <$> getWord16be <*> getWord16be + put (Fixed a b) = putWord16be a >> putWord16be b + +newtype FWord = FWord Word16 + deriving (Eq, Show) + +instance Binary FWord where + put (FWord w) = putWord16be w + get = FWord <$> getWord16be + +newtype F26Dot6 = F26Dot6 Int32 + deriving (Eq, Show, Ord) + +instance Num F26Dot6 where + (F26Dot6 a) + (F26Dot6 b) = F26Dot6 $ a + b + (F26Dot6 a) - (F26Dot6 b) = F26Dot6 $ a - b + (F26Dot6 a) * (F26Dot6 b) = F26Dot6 $ (a * b) `div` 64 + negate (F26Dot6 a) = F26Dot6 $ negate a + abs (F26Dot6 a) = F26Dot6 $ abs a + signum (F26Dot6 a) = F26Dot6 $ signum a * 64 + fromInteger a = F26Dot6 $ fromInteger a * 64 + +instance Fractional F26Dot6 where + fromRational a = F26Dot6 $ floor ad + where ad = fromRational a * 64 :: Double + (F26Dot6 a) / (F26Dot6 b) = F26Dot6 $ (a * 64) `div` b +