FontyFruity 0.1.0.2 → 0.1.0.3
raw patch · 14 files changed
+1873/−1870 lines, 14 filesdep ~basesetup-changed
Dependency ranges changed: base
Files
- FontyFruity.cabal +55/−55
- LICENSE +30/−30
- Setup.hs +2/−2
- changelog +14/−11
- src/Graphics/Text/TrueType.hs +292/−292
- src/Graphics/Text/TrueType/Bytecode.hs +122/−122
- src/Graphics/Text/TrueType/CharacterMap.hs +358/−358
- src/Graphics/Text/TrueType/Glyph.hs +305/−305
- src/Graphics/Text/TrueType/Header.hs +108/−108
- src/Graphics/Text/TrueType/HorizontalInfo.hs +108/−108
- src/Graphics/Text/TrueType/LanguageIds.hs +324/−324
- src/Graphics/Text/TrueType/MaxpTable.hs +51/−51
- src/Graphics/Text/TrueType/OffsetTable.hs +79/−79
- src/Graphics/Text/TrueType/Types.hs +25/−25
FontyFruity.cabal view
@@ -1,55 +1,55 @@--- Initial FontyFruity.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/--name: FontyFruity-version: 0.1.0.2-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.1.0.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-- ghc-options: -Wall -O2- ghc-prof-options: -Wall -prof -auto-all- hs-source-dirs: src- default-language: Haskell2010- build-depends: base >= 4.6 && < 4.7- , 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.1.0.3 +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.1.0.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 + + 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 +
LICENSE view
@@ -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.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple +main = defaultMain
changelog view
@@ -1,11 +1,14 @@--*-change-log-*---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.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. +
src/Graphics/Text/TrueType.hs view
@@ -1,292 +1,292 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--- | Module in charge of loading fonts.-module Graphics.Text.TrueType- ( -- * Functions- decodeFont- , loadFontFile- , getStringCurveAtPoint-- -- * Types- , Font- , Dpi- , PointSize- ) where--import Control.Applicative( (<$>) )-import Control.Monad( foldM )-import Data.Function( on )-import Data.List( sortBy, mapAccumL )-import Data.Word( Word32 )-import Data.Binary( Binary( .. ) )-import Data.Binary.Get( Get- , bytesRead- , getWord16be- , getWord32be- , getByteString- , 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 Data.Binary as DB-import qualified Control.Exception as E--- I feel so dirty. :(-import System.IO.Unsafe( unsafePerformIO )-#endif--import qualified Data.ByteString 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 Debug.Trace-}---- | Type representing a font.-data Font = Font- { _fontOffsetTable :: !OffsetTable- , _fontTables :: ![(B.ByteString, B.ByteString)]- , _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- }--emptyFont :: OffsetTable -> Font-emptyFont table = Font- { _fontTables = []- , _fontOffsetTable = table- , _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---- | Decode a in-memory true type file.-decodeFont :: LB.ByteString -> Either String Font-decodeFont str =-#if MIN_VERSION_binary(0,6,4)- case G.runGetOrFail getFont str of- Left err -> Left $ show err- Right (_, _, value) -> Right value-#else- unsafePerformIO $ E.evaluate (return $ G.runGet getFont str)- `E.catch` catcher- where catcher :: E.SomeException -> IO (Either String a)- catcher e = return . Left $ show e-#endif--decodeWithDefault :: forall a . Binary a => a -> LB.ByteString -> a-decodeWithDefault defaultValue str =-#if MIN_VERSION_binary(0,6,4)- case G.runGetOrFail get str of- Left _ -> defaultValue- Right (_, _, value) -> value-#else- unsafePerformIO $ E.evaluate (DB.decode str) `E.catch` catcher- where catcher :: E.SomeException -> IO a- catcher _ = return defaultValue-#endif--fetchTables :: OffsetTable -> Get Font-fetchTables tables = foldM fetch (emptyFont tables) tableList- where- tableList = sortBy (compare `on` _tdeOffset)- . V.toList- $ _otEntries tables- gotoOffset entry = do- readed <- bytesRead - let toDrop = fromIntegral (_tdeOffset entry) - readed- if toDrop < 0 then fail "Weirdo weird"- else skip $ fromIntegral toDrop-- 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@(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-- fetch font entry | _tdeTag entry == "loca" =- gotoOffset entry >> getLoca font-- fetch font entry | _tdeTag entry == "glyf" =- gotoOffset entry >>- getLazyByteString (fromIntegral $ _tdeLength entry)- >>= getGlyph font-- fetch font entry | _tdeTag entry == "head" = do- table <- gotoOffset entry >> get- return $ font { _fontHeader = Just table }-- fetch font entry | _tdeTag entry == "maxp" = do- table <- gotoOffset entry >> get- return $ font { _fontMaxp = Just table }-- fetch font entry | _tdeTag entry == "cmap" = do- table <- gotoOffset entry >> get- return $ font { _fontMap = Just table }-- fetch font entry | _tdeTag entry == "hhea" = do- table <- gotoOffset entry >> get- return $ font { _fontHorizontalHeader = Just table }- fetch font@Font { _fontMaxp = Just maxp,- _fontHorizontalHeader = Just hdr } entry- | _tdeTag entry == "hmtx" = do- gotoOffset entry- let metricCount = _hheaLongHorMetricCount hdr- table <- getHorizontalMetrics (fromIntegral metricCount) glyphCount- return font { _fontHorizontalMetrics = Just table }- where glyphCount = fromIntegral $ _maxpnumGlyphs maxp-- fetch font entry = do- let tableLength = fromIntegral $ _tdeLength entry- rawData <- gotoOffset entry >> getByteString tableLength- return $ font { _fontTables =- (_tdeTag entry, rawData) : _fontTables 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 _ _ = []---- | 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, unitsPerEm font,) <$> glyphOfStrings font str | (font, size, str) <- lst]-- unitsPerEm Font { _fontHeader = Just hdr } = fromIntegral $ _fUnitsPerEm hdr- unitsPerEm _ = 1-- 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 + + -- * Types + , Font + , Dpi + , PointSize + ) where + +import Control.Applicative( (<$>) ) +import Control.Monad( foldM ) +import Data.Function( on ) +import Data.List( sortBy, mapAccumL ) +import Data.Word( Word32 ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( Get + , bytesRead + , getWord16be + , getWord32be + , getByteString + , 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 Data.Binary as DB +import qualified Control.Exception as E +-- I feel so dirty. :( +import System.IO.Unsafe( unsafePerformIO ) +#endif + +import qualified Data.ByteString 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 Debug.Trace-} + +-- | Type representing a font. +data Font = Font + { _fontOffsetTable :: !OffsetTable + , _fontTables :: ![(B.ByteString, B.ByteString)] + , _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 + } + +emptyFont :: OffsetTable -> Font +emptyFont table = Font + { _fontTables = [] + , _fontOffsetTable = table + , _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 + +-- | Decode a in-memory true type file. +decodeFont :: LB.ByteString -> Either String Font +decodeFont str = +#if MIN_VERSION_binary(0,6,4) + case G.runGetOrFail getFont str of + Left err -> Left $ show err + Right (_, _, value) -> Right value +#else + unsafePerformIO $ E.evaluate (return $ G.runGet getFont str) + `E.catch` catcher + where catcher :: E.SomeException -> IO (Either String a) + catcher e = return . Left $ show e +#endif + +decodeWithDefault :: forall a . Binary a => a -> LB.ByteString -> a +decodeWithDefault defaultValue str = +#if MIN_VERSION_binary(0,6,4) + case G.runGetOrFail get str of + Left _ -> defaultValue + Right (_, _, value) -> value +#else + unsafePerformIO $ E.evaluate (DB.decode str) `E.catch` catcher + where catcher :: E.SomeException -> IO a + catcher _ = return defaultValue +#endif + +fetchTables :: OffsetTable -> Get Font +fetchTables tables = foldM fetch (emptyFont tables) tableList + where + tableList = sortBy (compare `on` _tdeOffset) + . V.toList + $ _otEntries tables + gotoOffset entry = do + readed <- bytesRead + let toDrop = fromIntegral (_tdeOffset entry) - readed + if toDrop < 0 then fail "Weirdo weird" + else skip $ fromIntegral toDrop + + 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@(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 + + fetch font entry | _tdeTag entry == "loca" = + gotoOffset entry >> getLoca font + + fetch font entry | _tdeTag entry == "glyf" = + gotoOffset entry >> + getLazyByteString (fromIntegral $ _tdeLength entry) + >>= getGlyph font + + fetch font entry | _tdeTag entry == "head" = do + table <- gotoOffset entry >> get + return $ font { _fontHeader = Just table } + + fetch font entry | _tdeTag entry == "maxp" = do + table <- gotoOffset entry >> get + return $ font { _fontMaxp = Just table } + + fetch font entry | _tdeTag entry == "cmap" = do + table <- gotoOffset entry >> get + return $ font { _fontMap = Just table } + + fetch font entry | _tdeTag entry == "hhea" = do + table <- gotoOffset entry >> get + return $ font { _fontHorizontalHeader = Just table } + fetch font@Font { _fontMaxp = Just maxp, + _fontHorizontalHeader = Just hdr } entry + | _tdeTag entry == "hmtx" = do + gotoOffset entry + let metricCount = _hheaLongHorMetricCount hdr + table <- getHorizontalMetrics (fromIntegral metricCount) glyphCount + return font { _fontHorizontalMetrics = Just table } + where glyphCount = fromIntegral $ _maxpnumGlyphs maxp + + fetch font entry = do + let tableLength = fromIntegral $ _tdeLength entry + rawData <- gotoOffset entry >> getByteString tableLength + return $ font { _fontTables = + (_tdeTag entry, rawData) : _fontTables 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 _ _ = [] + +-- | 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, unitsPerEm font,) <$> glyphOfStrings font str | (font, size, str) <- lst] + + unitsPerEm Font { _fontHeader = Just hdr } = fromIntegral $ _fUnitsPerEm hdr + unitsPerEm _ = 1 + + 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] +
src/Graphics/Text/TrueType/Bytecode.hs view
@@ -1,122 +1,122 @@-module Graphics.Text.TrueType.Bytecode where--import Data.Word( Word8, Word16 )-import qualified Data.Vector.Unboxed as VU--type InstructionFlag = Bool--data Instruction =- NPUSHB (VU.Vector Word8)- | NPUSHW (VU.Vector Word16)-- -- | Set Vectors To Coordinate axis.- -- Apply to freedom & projection vector- | SVTCA InstructionFlag- -- | Set projection vector to coordinate axis.- -- Apply to projection vector- | SPVTCA InstructionFlag- -- | Set Freedom Vector To Coordinate Axis.- -- Apply to the freedom vector- | SFVTCA InstructionFlag- -- | Set Projection Vector To Line.- -- Apply to projection vector- | SPVTL InstructionFlag- -- | Set Freedom Vector To Line.- -- Apply to freedom vector- | SFVTL InstructionFlag- -- | Set Freedom Vector To Projection Vector.- -- Apply to freedom vector- | SFVTPV- -- | Set Dual Projection Vector To Line- -- dual projection vector- | SDPVTL- -- | Set Projection Vector To Line.- -- Apply to projection vector- | SVPTL- -- | Set Projection Vector From Stack.- -- Apply to projection vector- | SPVFS- -- | Set Freedom Vector From Stack.- -- Apply to freedom vector- | SFVFS- -- | Set reference point 0.- -- Apply to rp0- | SRP0- -- | Set reference point 1.- -- Apply to rp1- | SRP1- -- | Set reference point 2.- -- Apply to rp2- | SRP2- -- | Set zone pointer 0.- -- Apply to zp0.- | SZP0- -- | Set zone pointer 1.- -- Apply to zp1.- | SZP1- -- | Set zone pointer 2.- -- Apply to zp2.- | SZP2- -- | Set zone pointers- -- Apply to zp0, zp1, zp2- | SZPS- -- | Round To Half Grid.- -- Apply to round state.- | RTHG- -- | Round To Grid.- -- Apply to round state.- | RTG- -- | Round To Double Grid.- -- Apply to round state.- | RTDG- -- | Round up To Grid.- -- Apply to round state.- | RUTG- -- | Round down to grid.- -- Apply to round state.- | RDTG- -- | Set rounding off- -- Apply to rounds tate.- | ROFF- -- | Super round- -- Apply to rounds tate.- | SROUND- -- | Super 45 round- -- Apply to rounds tate.- | S45ROUND- -- | Set loop.- -- Apply to loop- | SLOOP- -- | Set Single Width Cut-In- -- Apply to single width cut-in- | SSWCI- -- | Set Control Value Table Cut-In- -- Apply to control value cut-in- | SCVTCI- -- | Set Minimum Distance- -- Apply to minimum distance- | SMD- -- | Get Freedom vector- | GFV- -- | Get Projection vector- | GPV- -- | Get Information- | GETINFO- -- | Measure Pixels Per EM- | MPPEM- -- | Measure Point size- | MPS-- -- | If test- | IF- -- | Else- | ELSE- -- | Jump relative on false- | JROF- -- | Jump relative on true- | JROT- -- | Jump relative- | JMPR- -- | Loop and call- | LOOPCALL-+module Graphics.Text.TrueType.Bytecode where + +import Data.Word( Word8, Word16 ) +import qualified Data.Vector.Unboxed as VU + +type InstructionFlag = Bool + +data Instruction = + NPUSHB (VU.Vector Word8) + | NPUSHW (VU.Vector Word16) + + -- | Set Vectors To Coordinate axis. + -- Apply to freedom & projection vector + | SVTCA InstructionFlag + -- | Set projection vector to coordinate axis. + -- Apply to projection vector + | SPVTCA InstructionFlag + -- | Set Freedom Vector To Coordinate Axis. + -- Apply to the freedom vector + | SFVTCA InstructionFlag + -- | Set Projection Vector To Line. + -- Apply to projection vector + | SPVTL InstructionFlag + -- | Set Freedom Vector To Line. + -- Apply to freedom vector + | SFVTL InstructionFlag + -- | Set Freedom Vector To Projection Vector. + -- Apply to freedom vector + | SFVTPV + -- | Set Dual Projection Vector To Line + -- dual projection vector + | SDPVTL + -- | Set Projection Vector To Line. + -- Apply to projection vector + | SVPTL + -- | Set Projection Vector From Stack. + -- Apply to projection vector + | SPVFS + -- | Set Freedom Vector From Stack. + -- Apply to freedom vector + | SFVFS + -- | Set reference point 0. + -- Apply to rp0 + | SRP0 + -- | Set reference point 1. + -- Apply to rp1 + | SRP1 + -- | Set reference point 2. + -- Apply to rp2 + | SRP2 + -- | Set zone pointer 0. + -- Apply to zp0. + | SZP0 + -- | Set zone pointer 1. + -- Apply to zp1. + | SZP1 + -- | Set zone pointer 2. + -- Apply to zp2. + | SZP2 + -- | Set zone pointers + -- Apply to zp0, zp1, zp2 + | SZPS + -- | Round To Half Grid. + -- Apply to round state. + | RTHG + -- | Round To Grid. + -- Apply to round state. + | RTG + -- | Round To Double Grid. + -- Apply to round state. + | RTDG + -- | Round up To Grid. + -- Apply to round state. + | RUTG + -- | Round down to grid. + -- Apply to round state. + | RDTG + -- | Set rounding off + -- Apply to rounds tate. + | ROFF + -- | Super round + -- Apply to rounds tate. + | SROUND + -- | Super 45 round + -- Apply to rounds tate. + | S45ROUND + -- | Set loop. + -- Apply to loop + | SLOOP + -- | Set Single Width Cut-In + -- Apply to single width cut-in + | SSWCI + -- | Set Control Value Table Cut-In + -- Apply to control value cut-in + | SCVTCI + -- | Set Minimum Distance + -- Apply to minimum distance + | SMD + -- | Get Freedom vector + | GFV + -- | Get Projection vector + | GPV + -- | Get Information + | GETINFO + -- | Measure Pixels Per EM + | MPPEM + -- | Measure Point size + | MPS + + -- | If test + | IF + -- | Else + | ELSE + -- | Jump relative on false + | JROF + -- | Jump relative on true + | JROT + -- | Jump relative + | JMPR + -- | Loop and call + | LOOPCALL +
src/Graphics/Text/TrueType/CharacterMap.hs view
@@ -1,358 +1,358 @@-{-# LANGUAGE RankNTypes #-}-module Graphics.Text.TrueType.CharacterMap- ( TtfEncoding( .. )- , CharacterMaps- , LangId- , findCharGlyph- ) where--import Control.Monad( replicateM, forM )-import Control.Applicative( (<$>), (<*>) )-import Control.Monad( when )-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 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--{-import Debug.Trace-}-{-import Text.Printf-}--------------------------------------------------------- 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- tableDesc <- replicateM tableCount $- (,,) <$> get <*> getWord16be <*> getWord32be-- tables <-- forM tableDesc $ \(platformId, platformSpecific, offset) -> do- currentOffset <- fromIntegral <$> bytesRead- let toSkip = fromIntegral offset - currentOffset + startIndex- when (toSkip > 0)- (skip $ fromIntegral toSkip)- CharacterMap platformId platformSpecific <$> get- 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-- 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"- 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.Monad( replicateM, forM ) +import Control.Applicative( (<$>), (<*>) ) +import Control.Monad( when ) +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 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 + +{-import Debug.Trace-} +{-import Text.Printf-} + +-------------------------------------------------- +---- 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 + tableDesc <- replicateM tableCount $ + (,,) <$> get <*> getWord16be <*> getWord32be + + tables <- + forM tableDesc $ \(platformId, platformSpecific, offset) -> do + currentOffset <- fromIntegral <$> bytesRead + let toSkip = fromIntegral offset - currentOffset + startIndex + when (toSkip > 0) + (skip $ fromIntegral toSkip) + CharacterMap platformId platformSpecific <$> get + 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 + + 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" + 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
src/Graphics/Text/TrueType/Glyph.hs view
@@ -1,305 +1,305 @@-{-# 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.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 +
src/Graphics/Text/TrueType/Header.hs view
@@ -1,108 +1,108 @@-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( .. ) + , 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 +
src/Graphics/Text/TrueType/HorizontalInfo.hs view
@@ -1,108 +1,108 @@-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.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 +
src/Graphics/Text/TrueType/LanguageIds.hs view
@@ -1,324 +1,324 @@-{-# 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( .. ) + ) 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 +
src/Graphics/Text/TrueType/MaxpTable.hs view
@@ -1,51 +1,51 @@-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 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 +
src/Graphics/Text/TrueType/OffsetTable.hs view
@@ -1,79 +1,79 @@-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( .. ) + ) 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 +
src/Graphics/Text/TrueType/Types.hs view
@@ -1,25 +1,25 @@-module Graphics.Text.TrueType.Types- ( Fixed- , FWord- ) where--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-+module Graphics.Text.TrueType.Types + ( Fixed + , FWord + ) where + +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 +