FontyFruity 0.1.0.1 → 0.1.0.2
raw patch · 14 files changed
+1870/−1866 lines, 14 filessetup-changed
Files
- FontyFruity.cabal +55/−55
- LICENSE +30/−30
- Setup.hs +2/−2
- changelog +11/−8
- src/Graphics/Text/TrueType.hs +292/−291
- 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.1 -synopsis: A true type file format loader -description: - An haskell Truetype file parser. - . - You can load a font file and extract some curves to be - drawed with a library like Rasterific . -license: BSD3 -license-file: LICENSE -author: Vincent Berthoux -maintainer: vincent.berthoux@gmail.com --- copyright: -category: Graphics, Text, Font -build-type: Simple --- extra-source-files: -cabal-version: >=1.10 - -extra-source-files: changelog - -Source-Repository head - Type: git - Location: https://github.com/Twinside/FontyFruity.git - -Source-Repository this - Type: git - Location: https://github.com/Twinside/FontyFruity.git - Tag: v0.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.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+
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,8 +1,11 @@--*-change-log-*- - -v0.1.0.1 - * Fixing some missing information in the cabal file. - -v0.1 - * Initial version - +-*-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+
src/Graphics/Text/TrueType.hs view
@@ -1,291 +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 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+